Mercurial > hg > sonic-visualiser
changeset 1746:bf4a7015033e
Update vext
| author | Chris Cannam |
|---|---|
| date | Fri, 06 Oct 2017 13:28:35 +0100 |
| parents | 3587df7758e7 |
| children | ffe59b457557 |
| files | vext vext.ps1 vext.sml |
| diffstat | 3 files changed, 328 insertions(+), 29 deletions(-) [+] |
line wrap: on
line diff
--- a/vext Wed Oct 04 21:03:24 2017 +0100 +++ b/vext Fri Oct 06 13:28:35 2017 +0100 @@ -62,7 +62,7 @@ ERROR: No supported SML compiler or interpreter found EOF - cat <<EOF + cat 1>&2 <<EOF The Vext external source code manager needs a Standard ML (SML) compiler or interpreter to run. @@ -90,7 +90,7 @@ arglist="" for arg in "$@"; do if [ -n "$arglist" ]; then arglist="$arglist,"; fi - if echo "$arg" | grep -q '[^a-z]' ; then + if echo "$arg" | grep -q '["'"'"']' ; then arglist="$arglist\"usage\"" else arglist="$arglist\"$arg\"" @@ -110,6 +110,7 @@ fi ;; mlton) if [ ! -x "$gen_out" ]; then + echo "[Precompiling Vext binary...]" 1>&2 echo "val _ = main ()" | cat "$program" - > "$gen_sml" mlton -output "$gen_out" "$gen_sml" fi @@ -141,7 +142,7 @@ ) > "$gen_sml" CM_VERBOSE=false sml "$gen_sml" ;; *) - echo "Unknown SML implementation name: $sml"; + echo "ERROR: Unknown SML implementation name: $sml" 1>&2; exit 2 ;; esac
--- a/vext.ps1 Wed Oct 04 21:03:24 2017 +0100 +++ b/vext.ps1 Fri Oct 06 13:28:35 2017 +0100 @@ -6,6 +6,9 @@ #> +Set-StrictMode -Version 2.0 +$ErrorActionPreference = "Stop" + $sml = $env:VEXT_SML $mydir = Split-Path $MyInvocation.MyCommand.Path -Parent @@ -40,7 +43,7 @@ } } -if ($args -match "[^a-z]") { +if ($args -match "'""") { $arglist = '["usage"]' } else { $arglist = '["' + ($args -join '","') + '"]' @@ -51,6 +54,10 @@ $program = $program -replace "\\","\\\\" echo "use ""$program""; vext $arglist" | polyml -q --error-exit | Out-Host + if (-not $?) { + exit $LastExitCode + } + } elseif ($sml -eq "smlnj") { $lines = @(Get-Content $program) @@ -74,28 +81,33 @@ }; "@ -split "[\r\n]+" - $outro = @" + $outro = @" val _ = vext $arglist; val _ = OS.Process.exit (OS.Process.success); "@ -split "[\r\n]+" - $script = @() - $script += $intro - $script += $lines - $script += $outro + $script = @() + $script += $intro + $script += $lines + $script += $outro - $tmpfile = ([System.IO.Path]::GetTempFileName()) -replace "[.]tmp",".sml" + $tmpfile = ([System.IO.Path]::GetTempFileName()) -replace "[.]tmp",".sml" - $script | Out-File -Encoding "ASCII" $tmpfile + $script | Out-File -Encoding "ASCII" $tmpfile - $env:CM_VERBOSE="false" + $env:CM_VERBOSE="false" - sml $tmpfile $args[1,$args.Length] + sml $tmpfile - del $tmpfile + if (-not $?) { + del $tmpfile + exit $LastExitCode + } + + del $tmpfile } else { - "Unknown SML implementation name: $sml" - exit 2 + "Unknown SML implementation name: $sml" + exit 2 }
--- a/vext.sml Wed Oct 04 21:03:24 2017 +0100 +++ b/vext.sml Fri Oct 06 13:28:35 2017 +0100 @@ -1,12 +1,16 @@ -(* This file is automatically generated from the individual - source files in the Vext repository. *) +(* + DO NOT EDIT THIS FILE. + This file is automatically generated from the individual + source files in the Vext repository. +*) (* Vext A simple manager for third-party source code dependencies - Copyright 2017 Chris Cannam. + Copyright 2017 Chris Cannam, Particular Programs Ltd, + and Queen Mary, University of London Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation @@ -27,13 +31,14 @@ CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - Except as contained in this notice, the names of Chris Cannam and - Particular Programs Ltd shall not be used in advertising or - otherwise to promote the sale, use or other dealings in this - Software without prior written authorization. + Except as contained in this notice, the names of Chris Cannam, + Particular Programs Ltd, and Queen Mary, University of London + shall not be used in advertising or otherwise to promote the sale, + use or other dealings in this Software without prior written + authorization. *) -val vext_version = "0.9.6" +val vext_version = "0.9.8" datatype vcs = @@ -131,6 +136,7 @@ val project_file = "vext-project.json" val project_lock_file = "vext-lock.json" val user_config_file = ".vext.json" + val archive_dir = ".vext-archive" end signature VCS_CONTROL = sig @@ -192,6 +198,7 @@ val mydir : unit -> string val homedir : unit -> string val mkpath : string -> unit result + val rmpath : string -> unit result val project_spec_path : string -> string val project_lock_path : string -> string val verbose : unit -> bool @@ -376,6 +383,36 @@ | OK () => ((OS.FileSys.mkDir path; OK ()) handle OS.SysErr (e, _) => ERROR ("Directory creation failed: " ^ e)) + + fun rmpath path = + let open OS + fun files_from dirstream = + case FileSys.readDir dirstream of + NONE => [] + | SOME file => + (* readDir is supposed to filter these, + but let's be extra cautious: *) + if file = Path.parentArc orelse file = Path.currentArc + then files_from dirstream + else file :: files_from dirstream + fun contents dir = + let val stream = FileSys.openDir dir + val files = map (fn f => Path.joinDirFile + { dir = dir, file = f }) + (files_from stream) + val _ = FileSys.closeDir stream + in files + end + fun remove path = + if FileSys.isLink path (* dangling links bother isDir *) + then FileSys.remove path + else if FileSys.isDir path + then (app remove (contents path); FileSys.rmDir path) + else FileSys.remove path + in + (remove path; OK ()) + handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e) + end end functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct @@ -1398,6 +1435,246 @@ (fn HG => H.id_of | GIT => G.id_of) vcs context spec end + +type exclusions = string list + +structure Archive :> sig + + val archive : string * exclusions -> project -> OS.Process.status + +end = struct + + (* The idea of "archive" is to replace hg/git archive, which won't + include files, like the Vext-introduced external libraries, + that are not under version control with the main repo. + + The process goes like this: + + - Make sure we have a target filename from the user, and take + its basename as our archive directory name + + - Make an "archive root" subdir of the project repo, named + typically .vext-archive + + - Identify the VCS used for the project repo. Note that any + explicit references to VCS type in this structure are to + the VCS used for the project (something Vext doesn't + otherwise care about), not for an individual library + + - Synthesise a Vext project with the archive root as its + root path, "." as its extdir, with one library whose + name is the user-supplied basename and whose explicit + source URL is the original project root; update that + project -- thus cloning the original project to a subdir + of the archive root + + - Synthesise a Vext project identical to the original one for + this project, but with the newly-cloned copy as its root + path; update that project -- thus checking out clean copies + of the external library dirs + + - Call out to an archive program to archive up the new copy, + running e.g. + tar cvzf project-release.tar.gz \ + --exclude=.hg --exclude=.git project-release + in the archive root dir + + - (We also omit the vext-project.json file and any trace of + Vext. It can't properly be run in a directory where the + external project folders already exist but their repo history + does not. End users shouldn't get to see Vext) + + - Clean up by deleting the new copy + *) + + fun project_vcs_and_id dir = + let val context = { + rootpath = dir, + extdir = ".", + providers = [], + accounts = [] + } + val vcs_maybe = + case [HgControl.exists context ".", + GitControl.exists context "."] of + [OK true, OK false] => OK HG + | [OK false, OK true] => OK GIT + | _ => ERROR ("Unable to identify VCS for directory " ^ dir) + in + case vcs_maybe of + ERROR e => ERROR e + | OK vcs => + case (fn HG => HgControl.id_of | GIT => GitControl.id_of) + vcs context "." of + ERROR e => ERROR ("Unable to obtain id of project repo: " + ^ e) + | OK id => OK (vcs, id) + end + + fun make_archive_root (context : context) = + let val path = OS.Path.joinDirFile { + dir = #rootpath context, + file = VextFilenames.archive_dir + } + in + case FileBits.mkpath path of + ERROR e => raise Fail ("Failed to create archive directory \"" + ^ path ^ "\": " ^ e) + | OK () => path + end + + fun archive_path archive_dir target_name = + OS.Path.joinDirFile { + dir = archive_dir, + file = target_name + } + + fun check_nonexistent path = + case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of + NONE => () + | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting") + + fun file_url path = + let val forward_path = + String.translate (fn #"\\" => "/" | + c => Char.toString c) path + in + (* Path is expected to be absolute already, but if it + starts with a drive letter, we'll need an extra slash *) + case explode forward_path of + #"/"::rest => "file:///" ^ implode rest + | _ => "file:///" ^ forward_path + end + + fun make_archive_copy target_name (vcs, project_id) + ({ context, ... } : project) = + let val archive_root = make_archive_root context + val synthetic_context = { + rootpath = archive_root, + extdir = ".", + providers = [], + accounts = [] + } + val synthetic_library = { + libname = target_name, + vcs = vcs, + source = URL_SOURCE (file_url (#rootpath context)), + branch = DEFAULT_BRANCH, (* overridden by pinned id below *) + project_pin = PINNED project_id, + lock_pin = PINNED project_id + } + val path = archive_path archive_root target_name + val _ = print ("Cloning original project to " ^ path + ^ " at revision " ^ project_id ^ "...\n"); + val _ = check_nonexistent path + in + case AnyLibControl.update synthetic_context synthetic_library of + ERROR e => ERROR ("Failed to clone original project to " + ^ path ^ ": " ^ e) + | OK _ => OK archive_root + end + + fun update_archive archive_root target_name + (project as { context, ... } : project) = + let val synthetic_context = { + rootpath = archive_path archive_root target_name, + extdir = #extdir context, + providers = #providers context, + accounts = #accounts context + } + in + foldl (fn (lib, acc) => + case acc of + ERROR e => ERROR e + | OK _ => AnyLibControl.update synthetic_context lib) + (OK "") + (#libs project) + end + + datatype packer = TAR + | TAR_GZ + | TAR_BZ2 + | TAR_XZ + (* could add other packers, e.g. zip, if we knew how to + handle the file omissions etc properly in pack_archive *) + + fun packer_and_basename path = + let val extensions = [ (".tar", TAR), + (".tar.gz", TAR_GZ), + (".tar.bz2", TAR_BZ2), + (".tar.xz", TAR_XZ)] + val filename = OS.Path.file path + in + foldl (fn ((ext, packer), acc) => + if String.isSuffix ext filename + then SOME (packer, + String.substring (filename, 0, + String.size filename - + String.size ext)) + else acc) + NONE + extensions + end + + fun pack_archive archive_root target_name target_path packer exclusions = + case FileBits.command { + rootpath = archive_root, + extdir = ".", + providers = [], + accounts = [] + } "" ([ + "tar", + case packer of + TAR => "cf" + | TAR_GZ => "czf" + | TAR_BZ2 => "cjf" + | TAR_XZ => "cJf", + target_path, + "--exclude=.hg", + "--exclude=.git", + "--exclude=vext", + "--exclude=vext.sml", + "--exclude=vext.ps1", + "--exclude=vext.bat", + "--exclude=vext-project.json", + "--exclude=vext-lock.json" + ] @ (map (fn e => "--exclude=" ^ e) exclusions) @ + [ target_name ]) + of + ERROR e => ERROR e + | OK _ => FileBits.rmpath (archive_path archive_root target_name) + + fun archive (target_path, exclusions) (project : project) = + let val _ = check_nonexistent target_path + val (packer, name) = + case packer_and_basename target_path of + NONE => raise Fail ("Unsupported archive file extension in " + ^ target_path) + | SOME pn => pn + val details = + case project_vcs_and_id (#rootpath (#context project)) of + ERROR e => raise Fail e + | OK details => details + val archive_root = + case make_archive_copy name details project of + ERROR e => raise Fail e + | OK archive_root => archive_root + val outcome = + case update_archive archive_root name project of + ERROR e => ERROR e + | OK _ => + case pack_archive archive_root name + target_path packer exclusions of + ERROR e => ERROR e + | OK _ => OK () + in + case outcome of + ERROR e => raise Fail e + | OK () => OS.Process.success + end + +end + val libobjname = "libraries" fun load_libspec spec_json lock_json libname : libspec = @@ -1660,7 +1937,7 @@ else (); return_code end - + fun load_local_project pintype = let val userconfig = load_userconfig () val rootpath = OS.FileSys.getDir () @@ -1670,10 +1947,8 @@ fun with_local_project pintype f = let val return_code = f (load_local_project pintype) - handle e => - (print ("Failed with exception: " ^ - (exnMessage e) ^ "\n"); - OS.Process.failure) + handle e => (print ("Error: " ^ exnMessage e); + OS.Process.failure) val _ = print "\n"; in return_code @@ -1701,9 +1976,19 @@ ^ " 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" + ^ " archive pack up project and all libraries into an archive file\n" + ^ " (invoke as 'vext archive target-file.tar.gz')\n" ^ " version print the Vext version number and exit\n\n"); OS.Process.failure) +fun archive target args = + case args of + [] => + with_local_project USE_LOCKFILE (Archive.archive (target, [])) + | "--exclude"::xs => + with_local_project USE_LOCKFILE (Archive.archive (target, xs)) + | _ => usage () + fun vext args = let val return_code = case args of @@ -1713,6 +1998,7 @@ | ["update"] => update () | ["lock"] => lock () | ["version"] => version () + | "archive"::target::args => archive target args | _ => usage () in OS.Process.exit return_code;