@@ 11,12 11,44 @@ set -eu
mydir=$(dirname "$0")
program="$mydir/vext.sml"
+hasher=
+local_install=
+if [ -w "$mydir" ]; then
+ if echo | sha256sum >/dev/null 2>&1 ; then
+ hasher=sha256sum
+ local_install=true
+ elif echo | shasum >/dev/null 2>&1 ; then
+ hasher=shasum
+ local_install=true
+ else
+ echo "WARNING: sha256sum or shasum program not found" 1>&2
+ fi
+fi
+
+if [ -n "$local_install" ]; then
+ hash=$(echo "$sml" | cat "$program" - | $hasher | cut -c1-16)
+ gen_sml=$mydir/.vext-$hash.sml
+ gen_out=$mydir/.vext-$hash.bin
+ trap 'rm -f $gen_sml' 0
+else
+ gen_sml=$(mktemp /tmp/vext-XXXXXXXX.sml)
+ gen_out=$(mktemp /tmp/vext-XXXXXXXX.bin)
+ trap 'rm -f $gen_sml $gen_out' 0
+fi
+
+if [ -x "$gen_out" ]; then
+ exec "$gen_out" "$@"
+fi
+
# We need one of Poly/ML, SML/NJ, or MLton. Since we're running a
# single-file SML program as if it were a script, our order of
-# preference is based on startup speed.
+# preference is based on startup speed, except in the local_install
+# case where we retain a persistent binary.
if [ -z "$sml" ]; then
- if sml -h 2>&1 | grep -q 'Standard ML of New Jersey'; then
+ if [ -n "$local_install" ] && mlton 2>&1 | grep -q 'MLton'; then
+ sml="mlton"
+ elif sml -h 2>&1 | grep -q 'Standard ML of New Jersey'; then
sml="smlnj"
# We would prefer Poly/ML to SML/NJ, except that Poly v5.7 has a
# nasty bug that occasionally causes it to deadlock on startup.
@@ 55,11 87,6 @@ EOF
fi
fi
-tmp_sml=$(mktemp /tmp/vext-XXXXXXXX.sml)
-tmp_out=$(mktemp /tmp/vext-XXXXXXXX.bin)
-
-trap 'rm -f $tmp_sml $tmp_out' 0
-
arglist=""
for arg in "$@"; do
if [ -n "$arglist" ]; then arglist="$arglist,"; fi
@@ 71,13 98,22 @@ for arg in "$@"; do
done
case "$sml" in
- poly) echo 'use "'"$program"'"; vext ['"$arglist"'];' |
- poly -q --error-exit ;;
+ poly)
+ if [ -n "$local_install" ] && polyc --help >/dev/null 2>&1 ; then
+ if [ ! -x "$gen_out" ]; then
+ polyc -o "$gen_out" "$program"
+ fi
+ "$gen_out" "$@"
+ else
+ echo 'use "'"$program"'"; vext ['"$arglist"'];' |
+ poly -q --error-exit
+ fi ;;
mlton)
- cat "$program" > "$tmp_sml"
- echo 'val _ = main ()' >> "$tmp_sml"
- mlton -output "$tmp_out" "$tmp_sml"
- "$tmp_out" "$@" ;;
+ if [ ! -x "$gen_out" ]; then
+ echo "val _ = main ()" | cat "$program" - > "$gen_sml"
+ mlton -output "$gen_out" "$gen_sml"
+ fi
+ "$gen_out" "$@" ;;
smlnj)
cat "$program" | (
cat <<EOF
@@ 102,8 138,8 @@ EOF
val _ = vext [$arglist];
val _ = OS.Process.exit (OS.Process.success);
EOF
- ) > "$tmp_sml"
- CM_VERBOSE=false sml "$tmp_sml" ;;
+ ) > "$gen_sml"
+ CM_VERBOSE=false sml "$gen_sml" ;;
*)
echo "Unknown SML implementation name: $sml";
exit 2 ;;
@@ 33,7 33,7 @@
Software without prior written authorization.
*)
-val vext_version = "0.9.4"
+val vext_version = "0.9.6"
datatype vcs =
@@ 48,9 48,11 @@ datatype source =
repo : string option
}
+type id_or_tag = string
+
datatype pin =
UNPINNED |
- PINNED of string
+ PINNED of id_or_tag
datatype libstate =
ABSENT |
@@ 60,7 62,8 @@ datatype libstate =
datatype localstate =
MODIFIED |
- UNMODIFIED
+ LOCK_MISMATCHED |
+ CLEAN
datatype branch =
BRANCH of string |
@@ 77,21 80,20 @@ datatype 'a result =
type libname = string
-type id_or_tag = string
-
type libspec = {
libname : libname,
vcs : vcs,
source : source,
branch : branch,
- pin : pin
+ project_pin : pin,
+ lock_pin : pin
}
type lock = {
libname : libname,
id_or_tag : id_or_tag
}
-
+
type remote_spec = {
anon : string option,
auth : string option
@@ 177,6 179,7 @@ signature LIB_CONTROL = sig
val review : context -> libspec -> (libstate * localstate) result
val status : context -> libspec -> (libstate * localstate) result
val update : context -> libspec -> id_or_tag result
+ val id_of : context -> libspec -> id_or_tag result
end
structure FileBits :> sig
@@ 402,7 405,8 @@ functor LibControlFn (V: VCS_CONTROL) :>
- ABSENT: Repo doesn't exist here at all.
*)
- fun check with_network context ({ libname, branch, pin, ... } : libspec) =
+ fun check with_network context
+ ({ libname, branch, project_pin, lock_pin, ... } : libspec) =
let fun check_unpinned () =
let val is_newest = if with_network
then V.is_newest
@@ 422,26 426,39 @@ functor LibControlFn (V: VCS_CONTROL) :>
ERROR e => ERROR e
| OK true => OK CORRECT
| OK false => OK WRONG
- fun check' () =
- case pin of
+ fun check_remote () =
+ case project_pin of
UNPINNED => check_unpinned ()
| PINNED target => check_pinned target
+ fun check_local () =
+ case V.is_modified_locally context libname of
+ ERROR e => ERROR e
+ | OK true => OK MODIFIED
+ | OK false =>
+ case lock_pin of
+ UNPINNED => OK CLEAN
+ | PINNED target =>
+ case V.is_at context (libname, target) of
+ ERROR e => ERROR e
+ | OK true => OK CLEAN
+ | OK false => OK LOCK_MISMATCHED
in
case V.exists context libname of
ERROR e => ERROR e
- | OK false => OK (ABSENT, UNMODIFIED)
+ | OK false => OK (ABSENT, CLEAN)
| OK true =>
- case (check' (), V.is_modified_locally context libname) of
+ case (check_remote (), check_local ()) of
(ERROR e, _) => ERROR e
| (_, ERROR e) => ERROR e
- | (OK state, OK true) => OK (state, MODIFIED)
- | (OK state, OK false) => OK (state, UNMODIFIED)
+ | (OK r, OK l) => OK (r, l)
end
val review = check true
val status = check false
-
- fun update context ({ libname, source, branch, pin, ... } : libspec) =
+
+ fun update context
+ ({ libname, source, branch,
+ project_pin, lock_pin, ... } : libspec) =
let fun update_unpinned () =
case V.is_newest context (libname, branch) of
ERROR e => ERROR e
@@ 453,9 470,12 @@ functor LibControlFn (V: VCS_CONTROL) :>
| OK true => OK target
| OK false => V.update_to context (libname, target)
fun update' () =
- case pin of
- UNPINNED => update_unpinned ()
- | PINNED target => update_pinned target
+ case lock_pin of
+ PINNED target => update_pinned target
+ | UNPINNED =>
+ case project_pin of
+ PINNED target => update_pinned target
+ | UNPINNED => update_unpinned ()
in
case V.exists context libname of
ERROR e => ERROR e
@@ 465,6 485,10 @@ functor LibControlFn (V: VCS_CONTROL) :>
ERROR e => ERROR e
| OK () => update' ()
end
+
+ fun id_of context ({ libname, ... } : libspec) =
+ V.id_of context libname
+
end
(* Simple Standard ML JSON parser
@@ 889,11 913,12 @@ end = struct
| Json.ERROR e => raise Fail ("Failed to parse file: " ^ e)
fun save_json_to filename json =
+ (* using binary I/O to avoid ever writing CR/LF line endings *)
let val jstr = Json.serialiseIndented json
- val stream = TextIO.openOut filename
+ val stream = BinIO.openOut filename
in
- TextIO.output (stream, jstr);
- TextIO.closeOut stream
+ BinIO.output (stream, Byte.stringToBytes jstr);
+ BinIO.closeOut stream
end
fun lookup_optional json kk =
@@ 1368,6 1393,9 @@ structure AnyLibControl :> LIB_CONTROL =
fun update context (spec as { vcs, ... } : libspec) =
(fn HG => H.update | GIT => G.update) vcs context spec
+
+ fun id_of context (spec as { vcs, ... } : libspec) =
+ (fn HG => H.id_of | GIT => G.id_of) vcs context spec
end
val libobjname = "libraries"
@@ 1382,10 1410,14 @@ fun load_libspec spec_json lock_json lib
val repo = retrieve ["repository"]
val url = retrieve ["url"]
val branch = retrieve ["branch"]
- val user_pin = retrieve ["pin"]
+ val project_pin = case retrieve ["pin"] of
+ NONE => UNPINNED
+ | SOME p => PINNED p
val lock_pin = case lookup_optional lock_json [libobjname, libname] of
- SOME ll => lookup_optional_string ll ["pin"]
- | NONE => NONE
+ NONE => UNPINNED
+ | SOME ll => case lookup_optional_string ll ["pin"] of
+ SOME p => PINNED p
+ | NONE => UNPINNED
in
{
libname = libname,
@@ 1400,12 1432,8 @@ fun load_libspec spec_json lock_json lib
SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
| _ => raise Fail ("Must have exactly one of service " ^
"or url string"),
- pin = case lock_pin of
- SOME p => PINNED p
- | NONE =>
- case user_pin of
- SOME p => PINNED p
- | NONE => UNPINNED,
+ project_pin = project_pin,
+ lock_pin = lock_pin,
branch = case branch of
SOME b => BRANCH b
| NONE => DEFAULT_BRANCH
@@ 1435,7 1463,11 @@ fun load_userconfig () : userconfig =
}
end
-fun load_project (userconfig : userconfig) rootpath use_locks : project =
+datatype pintype =
+ NO_LOCKFILE |
+ USE_LOCKFILE
+
+fun load_project (userconfig : userconfig) rootpath pintype : project =
let val spec_file = FileBits.project_spec_path rootpath
val lock_file = FileBits.project_lock_path rootpath
val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
@@ 1447,7 1479,7 @@ fun load_project (userconfig : userconfi
".\nPlease ensure the spec file is in the " ^
"project root and run this from there.")
val spec_json = JsonBits.load_json_from spec_file
- val lock_json = if use_locks
+ val lock_json = if pintype = USE_LOCKFILE
then JsonBits.load_json_from lock_file
handle IO.Io _ => Json.OBJECT []
else Json.OBJECT []
@@ 1497,12 1529,13 @@ fun hline_to 0 = ""
val libname_width = 25
val libstate_width = 11
-val localstate_width = 9
+val localstate_width = 17
val notes_width = 5
val divider = " | "
+val clear_line = "\r" ^ pad_to 80 "";
fun print_status_header () =
- print ("\r" ^ pad_to 80 "" ^ "\n " ^
+ print (clear_line ^ "\n " ^
pad_to libname_width "Library" ^ divider ^
pad_to libstate_width "State" ^ divider ^
pad_to localstate_width "Local" ^ divider ^
@@ 1513,7 1546,7 @@ fun print_status_header () =
hline_to notes_width ^ "\n")
fun print_outcome_header () =
- print ("\r" ^ pad_to 80 "" ^ "\n " ^
+ print (clear_line ^ "\n " ^
pad_to libname_width "Library" ^ divider ^
pad_to libstate_width "Outcome" ^ divider ^
"Notes" ^ "\n " ^
@@ 1532,8 1565,9 @@ fun print_status with_network (libname,
val localstate_str =
case status of
OK (_, MODIFIED) => "Modified"
- | OK (_, UNMODIFIED) => "Clean"
- | _ => ""
+ | OK (_, LOCK_MISMATCHED) => "Differs from Lock"
+ | OK (_, CLEAN) => "Clean"
+ | ERROR _ => ""
val error_str =
case status of
ERROR e => e
@@ 1607,15 1641,35 @@ fun update_project ({ context, libs } :
return_code
end
-fun load_local_project use_locks =
+fun lock_project ({ context, libs } : project) =
+ let val outcomes = map (fn lib =>
+ (#libname lib, AnyLibControl.id_of context lib))
+ libs
+ val locks =
+ List.concat
+ (map (fn (libname, result) =>
+ case result of
+ ERROR _ => []
+ | OK id => [{ libname = libname, id_or_tag = id }])
+ outcomes)
+ val return_code = return_code_for outcomes
+ val _ = print clear_line
+ in
+ if OS.Process.isSuccess return_code
+ then save_lock_file (#rootpath context) locks
+ else ();
+ return_code
+ end
+
+fun load_local_project pintype =
let val userconfig = load_userconfig ()
val rootpath = OS.FileSys.getDir ()
in
- load_project userconfig rootpath use_locks
+ load_project userconfig rootpath pintype
end
-fun with_local_project use_locks f =
- let val return_code = f (load_local_project use_locks)
+fun with_local_project pintype f =
+ let val return_code = f (load_local_project pintype)
handle e =>
(print ("Failed with exception: " ^
(exnMessage e) ^ "\n");
@@ 1625,10 1679,11 @@ fun with_local_project use_locks f =
return_code
end
-fun review () = with_local_project false review_project
-fun status () = with_local_project false status_of_project
-fun update () = with_local_project false update_project
-fun install () = with_local_project true update_project
+fun review () = with_local_project USE_LOCKFILE review_project
+fun status () = with_local_project USE_LOCKFILE status_of_project
+fun update () = with_local_project NO_LOCKFILE update_project
+fun lock () = with_local_project NO_LOCKFILE lock_project
+fun install () = with_local_project USE_LOCKFILE update_project
fun version () =
(print ("v" ^ vext_version ^ "\n");
@@ 1645,6 1700,7 @@ fun usage () =
^ " review check configured libraries against their providers, and report\n"
^ " install update configured libraries according to project specs and lock file\n"
^ " update update configured libraries and lock file according to project specs\n"
+ ^ " lock update lock file to match local library status\n"
^ " version print the Vext version number and exit\n\n");
OS.Process.failure)
@@ 1655,6 1711,7 @@ fun vext args =
| ["status"] => status ()
| ["install"] => install ()
| ["update"] => update ()
+ | ["lock"] => lock ()
| ["version"] => version ()
| _ => usage ()
in