---------------------------------------------------------------------------
MODULE PoolSet;
IMPORT Text, TextSeq, TextTextTbl, Pathname, Thread, Process,
Rd, FileRd, Fmt, TextConv, ASCII;
IMPORT PkgBase, System, TextUtils, PathRepr, FileInfo, Checkpoint,
PkgVC, TextPkgVCTbl, Tag, VCUtils, SMsg AS Msg,
APN AS APN, FSUtils, RegEx, MsgX, MsgIF;
---------------------------------------------------------------------------
CONST
Undefined = "%$#&!42?";
---------------------------------------------------------------------------
PROCEDURE NoVCIF(<*UNUSED*> self : PkgVCAccessor;
<*UNUSED*> dir : Pathname.T) : PkgVC.T RAISES {} =
BEGIN
RETURN NIL;
END NoVCIF;
---------------------------------------------------------------------------
PROCEDURE NewVCIF(self : PkgVCCreator; dir : Pathname.T) : PkgVC.T
RAISES {Error} =
VAR res : PkgVC.T;
BEGIN
IF dir = NIL THEN
RAISE Error("cannot create version control object: directory NIL");
END;
TRY
dir := FSUtils.CanonicalPathname(dir);
EXCEPT
FSUtils.E(e) => RAISE Error(e);
END;
res := NEW(PkgVC.T).init(self.msgif);
TRY
res.setPackageRoot(APN.New(dir));
IF self.env # NIL THEN
res.setEnvironment(self.env);
END;
EXCEPT
PkgVC.E(e) => RAISE Error("cannot create version control object: " & e);
END;
RETURN res;
END NewVCIF;
---------------------------------------------------------------------------
REVEAL
T = Public BRANDED "PoolSet Type 0.0" OBJECT
pools : TextSeq.T; (* list of pools *)
location : TextTextTbl.T; (* mapping from package name -> pool (path) *)
type : TextTextTbl.T; (* mapping from package name -> package type *)
pkgvc : TextPkgVCTbl.T;(* mapping from package name -> vc interface *)
cfg : PkgBase.T;
prefkind : PkgBase.Kind;
fileCache : FileInfo.T;
stateCache : Checkpoint.T;
useCache : BOOLEAN;
cacheEarly : BOOLEAN;
msgif : MsgIF.T;
pkgvcAcc : PkgVCAccessor;
internalVC : BOOLEAN;
verboseCache : BOOLEAN;
METHODS
OVERRIDES
init := Init;
prependPool := PrependPool;
appendPool := AppendPool;
setPreferredPkgKind := SetPreferredPkgKind;
exists := Exists;
pkgPath := PkgPath;
pkgType := PkgType;
pkgVCIF := PkgVCIF;
checkAll := CheckAll;
execAction := ExecAction;
execCmdList := ExecCmdList;
getCmdOutput := GetCmdOutput;
getAndCacheVersionState := GetAndCacheVersionState;
fileContents := FileContents;
checkout := Checkout;
getFileCache := GetFileCache;
cachedState := CachedState;
updateCache := UpdateCache;
newCheckpoint := NewCheckpoint;
replaceStateCache := ReplaceStateCache;
setAttr := SetAttr;
clearAttr := ClearAttr;
attrIsSet := AttrIsSet;
setVal := SetVal;
getVal := GetVal;
delVal := DelVal;
updateStateCache := UpdateStateCache;
actionProbablyNeeded := ActionProbablyNeeded;
dumpStateCache := DumpStateCache;
END;
---------------------------------------------------------------------------
PROCEDURE Init(self : T; cfg : PkgBase.T;
fn : TEXT := NIL;
useCache := TRUE;
p1 : Pathname.T := NIL;
p2 : Pathname.T := NIL;
p3 : Pathname.T := NIL;
p4 : Pathname.T := NIL;
p5 : Pathname.T := NIL;
msgif : MsgIF.T := NIL;
pkgvcAcc : PkgVCAccessor := NIL;
verboseCache := TRUE;
prefkind : TEXT := NIL;
cacheEarly := FALSE) : T RAISES {Error} =
(*
Initialize the search list with the given paths. `p1' has the greatest
priority. The package type and action configuration must be contained
in `cfg'.
*)
BEGIN
self.pkgvcAcc := pkgvcAcc;
self.internalVC := pkgvcAcc # NIL;
self.msgif := msgif;
self.useCache := useCache;
self.verboseCache := verboseCache;
self.cfg := cfg;
self.pools := NEW(TextSeq.T).init(5);
self.location := NEW(TextTextTbl.Default).init(40);
self.type := NEW(TextTextTbl.Default).init(40);
self.cacheEarly := cacheEarly;
IF self.internalVC THEN
self.pkgvc := NEW(TextPkgVCTbl.Default).init(40);
ELSE
self.pkgvc := NEW(TextPkgVCTbl.Default).init(1);
END;
self.prefkind := prefkind;
self.fileCache := NEW(FileInfo.T).init(1000, APN.New(PathRepr.RootDir),
self.msgif);
self.cfg.setCache(self.fileCache);
self.stateCache := Checkpoint.New(self.fileCache, self.msgif);
IF useCache AND fn # NIL AND FSUtils.IsFile(fn) THEN
TRY
self.stateCache.fromFile(fn);
EXCEPT
Checkpoint.Error(e) => RAISE Error(e);
END;
END;
IF p1 # NIL THEN
AppendPool(self, p1);
END;
IF p2 # NIL THEN
AppendPool(self, p2);
END;
IF p3 # NIL THEN
AppendPool(self, p3);
END;
IF p4 # NIL THEN
AppendPool(self, p4);
END;
IF p5 # NIL THEN
AppendPool(self, p5);
END;
RETURN self;
END Init;
---------------------------------------------------------------------------
PROCEDURE PrependPool(self : T; p : Pathname.T) RAISES {Error} =
(* Prepend `p' to the search list. *)
BEGIN
TRY
WITH pn = FSUtils.CanonicalPathname(PathRepr.Native(p)) DO
self.pools.addlo(pn);
IF self.cacheEarly AND self.useCache THEN
IF self.verboseCache AND NOT Msg.vFlag THEN
MsgX.T(self.msgif, "caching " & pn);
END;
self.fileCache.updateRec(APN.New(pn), NIL, NIL,
Checkpoint.skipDirExpr,
Checkpoint.skipFileExpr);
END;
END;
EXCEPT
FSUtils.E(e) => RAISE Error(e);
END;
END PrependPool;
---------------------------------------------------------------------------
PROCEDURE AppendPool(self : T; p : Pathname.T) RAISES {Error} =
(* Append `p' to the search list. *)
BEGIN
TRY
WITH pn = FSUtils.CanonicalPathname(PathRepr.Native(p)) DO
self.pools.addhi(pn);
IF self.cacheEarly AND self.useCache THEN
IF self.verboseCache AND NOT Msg.vFlag THEN
MsgX.T(self.msgif, "caching " & pn);
END;
self.fileCache.updateRec(APN.New(pn), NIL, NIL,
Checkpoint.skipDirExpr,
Checkpoint.skipFileExpr);
END;
END;
EXCEPT
FSUtils.E(e) => RAISE Error(e);
END;
END AppendPool;
---------------------------------------------------------------------------
PROCEDURE SetPreferredPkgKind(self : T; k : PkgBase.Kind) =
BEGIN
self.prefkind := k;
END SetPreferredPkgKind;
---------------------------------------------------------------------------
PROCEDURE Exists(self : T; pkg : PkgBase.Name;
hint : Pathname.T := NIL) : BOOLEAN RAISES {Error} =
(*
Check for the existence (and the type) of package `pkg' in the list
of pools and remember the results in an internal cache. Return
TRUE if the package was found in one of the pools.
*)
VAR
cached : BOOLEAN;
path : TEXT;
kind : PkgBase.Kind;
found := FALSE;
hintt : TEXT;
BEGIN
IF hint = NIL THEN
hintt := "NIL";
ELSE
TRY
hint := FSUtils.CanonicalPathname(hint);
EXCEPT
FSUtils.E(e) => RAISE Error(e);
END;
hintt := hint;
END;
IF Msg.dFlag THEN
MsgX.D(self.msgif, "PoolSet.Exists(" & pkg & ", " & hintt & ")");
END;
cached := self.location.get(pkg, path);
IF NOT cached THEN
IF hint # NIL THEN
path := Pathname.Join(PathRepr.Native(hint), pkg, NIL);
kind := self.prefkind;
found := self.cfg.kindFound(path, kind);
ELSE
FOR i := 0 TO self.pools.size() - 1 DO
path := Pathname.Join(self.pools.get(i), pkg, NIL);
kind := self.prefkind;
found := self.cfg.kindFound(path, kind);
IF found THEN EXIT END;
IF Msg.dFlag THEN
MsgX.D(self.msgif, "package " & pkg & " not found at " & path);
END;
END;
END;
IF found THEN
EVAL self.location.put(pkg, path);
EVAL self.type.put(pkg, kind);
IF Msg.dFlag THEN
MsgX.D(self.msgif, "package " & pkg & " kind " & kind &
" found at " & path);
MsgX.D(self.msgif, "checkpointing package " & path);
END;
TRY
IF self.useCache THEN
IF self.verboseCache AND NOT Msg.vFlag THEN
MsgX.T(self.msgif, "scanning " & path);
END;
self.stateCache.update(path, self.cacheEarly);
END;
EXCEPT
Checkpoint.Error(e) => RAISE Error(e);
END;
ELSE
EVAL self.location.put(pkg, Undefined);
EVAL self.type.put(pkg, Undefined);
END;
RETURN found;
END;
RETURN NOT Text.Equal(path, Undefined);
END Exists;
---------------------------------------------------------------------------
PROCEDURE PkgPath(self : T; name : PkgBase.Name) : Pathname.T =
(*
Return the path of the package with name `name' if cached,
NIL else.
*)
VAR path : Pathname.T;
BEGIN
IF self.location.get(name, path) THEN
RETURN path;
ELSE
RETURN NIL;
END;
END PkgPath;
---------------------------------------------------------------------------
PROCEDURE PkgVCIF(self : T; name : PkgBase.Name) : PkgVC.T RAISES {Error} =
VAR
res : PkgVC.T;
dir : TEXT;
BEGIN
IF NOT self.internalVC THEN RETURN NIL END;
IF NOT self.pkgvc.get(name, res) THEN
dir := PkgPath(self, name);
IF dir = NIL THEN
RAISE Error("cannot create version control object for missing " &
"package: " & name);
END;
res := self.pkgvcAcc.getVCIF(dir);
EVAL self.pkgvc.put(name, res);
END;
RETURN res;
END PkgVCIF;
---------------------------------------------------------------------------
PROCEDURE CheckAll(self : T; pkgList : TextSeq.T; VAR res : TEXT;
VAR missingPackages : TextSeq.T;
hints : TextTextTbl.T := NIL; checkHomogeneity := TRUE;
ignoreMissingPackages := FALSE) : BOOLEAN =
(*
Check for the existence and (type) homogeneity of all packages
in `pkgList'. Return TRUE if all packages exist and are of the
same type.
*)
VAR
pkg : PkgBase.Name := "";
actPkg : PkgBase.Name;
kind : PkgBase.Kind := NIL;
actKind : PkgBase.Kind;
hint : TEXT;
BEGIN
FOR i := 0 TO pkgList.size() - 1 DO
actPkg := pkgList.get(i);
IF hints # NIL THEN
IF hints.get(actPkg, hint) THEN
hint := PathRepr.Native(hint);
ELSE
hint := NIL;
END;
ELSE
hint := NIL;
END;
TRY
IF NOT self.exists(actPkg, hint) THEN
IF missingPackages = NIL THEN
missingPackages := NEW(TextSeq.T).init();
END;
missingPackages.addhi(actPkg);
IF NOT ignoreMissingPackages THEN
res := actPkg & " does not exist";
RETURN FALSE;
END;
END;
EXCEPT
Error(e) => res := e; RETURN FALSE;
END;
(* package exists, location and kind cached *)
IF kind = NIL THEN
kind := self.pkgType(actPkg);
pkg := actPkg;
ELSE
actKind := self.pkgType(actPkg);
IF checkHomogeneity AND NOT Text.Equal(kind, actKind) THEN
res := "different kinds of packages found: " &
pkg & "->" & kind & ", " & actPkg & "->" & actKind;
RETURN FALSE;
END;
END;
END;
RETURN TRUE;
END CheckAll;
---------------------------------------------------------------------------
PROCEDURE PkgType(self : T; name : PkgBase.Name) : PkgBase.Kind =
(* Return the type of package `name'. *)
VAR kind : PkgBase.Kind;
BEGIN
IF self.type.get(name, kind) THEN
RETURN kind;
ELSE
RETURN NIL;
END;
END PkgType;
---------------------------------------------------------------------------
PROCEDURE UpdateStateCache(self : T; dir : Pathname.T;
action : PkgBase.Action; ret : INTEGER;
rescan := TRUE)
RAISES {Error} =
PROCEDURE SetOnSuccess(attr : Checkpoint.Attr) =
BEGIN
IF ret = 0 THEN
attrs := attrs + Checkpoint.AttrSet{attr};
ELSE
attrs := attrs - Checkpoint.AttrSet{attr};
END;
END SetOnSuccess;
PROCEDURE ClearOnSuccess(attr : Checkpoint.Attr) =
BEGIN
IF ret = 0 THEN
attrs := attrs - Checkpoint.AttrSet{attr};
END;
END ClearOnSuccess;
PROCEDURE SetOnFailure(attr : Checkpoint.Attr) =
BEGIN
IF ret = 0 THEN
attrs := attrs - Checkpoint.AttrSet{attr};
ELSE
attrs := attrs + Checkpoint.AttrSet{attr};
END;
END SetOnFailure;
PROCEDURE Clear(attr : Checkpoint.Attr) =
BEGIN
attrs := attrs - Checkpoint.AttrSet{attr};
END Clear;
PROCEDURE SetDefaultUnbuilt() =
BEGIN
attrs := attrs - Checkpoint.AttrSet{
Checkpoint.Attr.DepMade,
Checkpoint.Attr.BuildOk,
Checkpoint.Attr.BuildOkL,
Checkpoint.Attr.BuildFailed,
Checkpoint.Attr.ShippedToLP,
Checkpoint.Attr.ShippedToPP,
Checkpoint.Attr.ShippedToGP
};
END SetDefaultUnbuilt;
PROCEDURE SetDefaultRebuild() =
BEGIN
attrs := attrs - Checkpoint.AttrSet{
Checkpoint.Attr.BuildOk,
Checkpoint.Attr.BuildOkL,
Checkpoint.Attr.BuildFailed,
Checkpoint.Attr.ShippedToLP,
Checkpoint.Attr.ShippedToPP,
Checkpoint.Attr.ShippedToGP
};
END SetDefaultRebuild;
PROCEDURE SetDefaultUnshipped() =
BEGIN
attrs := attrs - Checkpoint.AttrSet{
Checkpoint.Attr.ShippedToGP,
Checkpoint.Attr.ShippedToPP,
Checkpoint.Attr.ShippedToLP
};
END SetDefaultUnshipped;
PROCEDURE ClearPackageTags() RAISES {Error} =
BEGIN
TRY
self.stateCache.delVal(dir, "sticky-tag");
self.stateCache.delVal(dir, "release-tag");
self.stateCache.delVal(dir, "current-tag");
self.stateCache.delVal(dir, "current-release-tag");
self.stateCache.delVal(dir, "current-devel-tag");
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot delete checkpoint value " & pkg & ": " & e);
END;
END ClearPackageTags;
PROCEDURE ClearPkgVCCache() RAISES {Error} =
BEGIN
IF self.pkgvcAcc # NIL THEN
WITH vc = self.pkgVCIF(pkg) DO
vc.flushCache();
END;
END;
END ClearPkgVCCache;
VAR
pkg := Pathname.Last(dir);
attrs : Checkpoint.AttrSet;
BEGIN
IF NOT self.useCache THEN RETURN END;
TRY
attrs := self.stateCache.getAttr(dir);
EXCEPT
Checkpoint.Error =>
TRY
self.stateCache.update(dir);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot set attributes for package " & pkg & ": " & e);
END;
END;
IF Text.Equal(action, "build") THEN
SetOnSuccess(Checkpoint.Attr.BuildOk);
ClearOnSuccess(Checkpoint.Attr.BuildOkL);
SetOnFailure(Checkpoint.Attr.BuildFailed);
SetDefaultUnshipped();
ELSIF Text.Equal(action, "buildlocal") THEN
SetOnSuccess(Checkpoint.Attr.BuildOkL);
ClearOnSuccess(Checkpoint.Attr.BuildOk);
SetOnFailure(Checkpoint.Attr.BuildFailed);
SetDefaultUnshipped();
ELSIF Text.Equal(action, "checkconflicts") THEN
SetOnSuccess(Checkpoint.Attr.Conflicts);
SetOnFailure(Checkpoint.Attr.NoConflicts);
rescan := FALSE;
ELSIF Text.Equal(action, "checkmodified") THEN
SetOnSuccess(Checkpoint.Attr.Modified);
SetOnFailure(Checkpoint.Attr.Unmodified);
rescan := FALSE;
ELSIF Text.Equal(action, "checkout") THEN
SetDefaultUnbuilt();
SetOnSuccess(Checkpoint.Attr.UpToDate);
ClearOnSuccess(Checkpoint.Attr.Modified);
ClearOnSuccess(Checkpoint.Attr.OutOfDate);
ClearOnSuccess(Checkpoint.Attr.IsRelease);
ClearOnSuccess(Checkpoint.Attr.NoRelease);
ClearPackageTags();
ClearPkgVCCache();
ELSIF Text.Equal(action, "checkrelease") THEN
SetOnSuccess(Checkpoint.Attr.IsRelease);
SetOnFailure(Checkpoint.Attr.NoRelease);
rescan := FALSE;
ELSIF Text.Equal(action, "checkuptodate") THEN
SetOnSuccess(Checkpoint.Attr.UpToDate);
SetOnFailure(Checkpoint.Attr.OutOfDate);
rescan := FALSE;
ELSIF Text.Equal(action, "clean") THEN
SetDefaultUnbuilt();
ELSIF Text.Equal(action, "commitdevelmajor") THEN
ClearOnSuccess(Checkpoint.Attr.Modified);
ClearOnSuccess(Checkpoint.Attr.Conflicts);
ClearOnSuccess(Checkpoint.Attr.IsRelease);
SetOnSuccess(Checkpoint.Attr.UpToDate);
SetOnSuccess(Checkpoint.Attr.Unmodified);
SetOnSuccess(Checkpoint.Attr.NoRelease);
ClearPackageTags();
ClearPkgVCCache();
ELSIF Text.Equal(action, "commitdevelminor") THEN
ClearOnSuccess(Checkpoint.Attr.Modified);
ClearOnSuccess(Checkpoint.Attr.Conflicts);
ClearOnSuccess(Checkpoint.Attr.IsRelease);
SetOnSuccess(Checkpoint.Attr.UpToDate);
SetOnSuccess(Checkpoint.Attr.Unmodified);
SetOnSuccess(Checkpoint.Attr.NoRelease);
ClearPackageTags();
ClearPkgVCCache();
ELSIF Text.Equal(action, "commitdevelpatch") THEN
ClearOnSuccess(Checkpoint.Attr.Modified);
ClearOnSuccess(Checkpoint.Attr.Conflicts);
ClearOnSuccess(Checkpoint.Attr.IsRelease);
SetOnSuccess(Checkpoint.Attr.UpToDate);
SetOnSuccess(Checkpoint.Attr.Unmodified);
SetOnSuccess(Checkpoint.Attr.NoRelease);
ClearPackageTags();
ClearPkgVCCache();
ELSIF Text.Equal(action, "commitreleasemajor") THEN
ClearOnSuccess(Checkpoint.Attr.Modified);
ClearOnSuccess(Checkpoint.Attr.Conflicts);
ClearOnSuccess(Checkpoint.Attr.NoRelease);
SetOnSuccess(Checkpoint.Attr.UpToDate);
SetOnSuccess(Checkpoint.Attr.Unmodified);
SetOnSuccess(Checkpoint.Attr.IsRelease);
ClearPackageTags();
ClearPkgVCCache();
SetDefaultUnbuilt();
ELSIF Text.Equal(action, "commitreleaseminor") THEN
ClearOnSuccess(Checkpoint.Attr.Modified);
ClearOnSuccess(Checkpoint.Attr.Conflicts);
ClearOnSuccess(Checkpoint.Attr.NoRelease);
SetOnSuccess(Checkpoint.Attr.UpToDate);
SetOnSuccess(Checkpoint.Attr.Unmodified);
SetOnSuccess(Checkpoint.Attr.IsRelease);
ClearPackageTags();
ClearPkgVCCache();
SetDefaultUnbuilt();
ELSIF Text.Equal(action, "commitreleasepatch") THEN
ClearOnSuccess(Checkpoint.Attr.Modified);
ClearOnSuccess(Checkpoint.Attr.Conflicts);
ClearOnSuccess(Checkpoint.Attr.NoRelease);
SetOnSuccess(Checkpoint.Attr.UpToDate);
SetOnSuccess(Checkpoint.Attr.Unmodified);
SetOnSuccess(Checkpoint.Attr.IsRelease);
ClearPackageTags();
ClearPkgVCCache();
SetDefaultUnbuilt();
ELSIF Text.Equal(action, "conflicts") THEN
SetOnSuccess(Checkpoint.Attr.Conflicts);
SetOnFailure(Checkpoint.Attr.NoConflicts);
rescan := FALSE;
ELSIF Text.Equal(action, "currentdeveltag") THEN
ELSIF Text.Equal(action, "currentlabel") THEN
ELSIF Text.Equal(action, "currentreleasetag") THEN
ELSIF Text.Equal(action, "currenttag") THEN
ELSIF Text.Equal(action, "externalshell") THEN
rescan := FALSE;
ELSIF Text.Equal(action, "getlabel") THEN
ELSIF Text.Equal(action, "isrelease") THEN
SetOnSuccess(Checkpoint.Attr.IsRelease);
SetOnFailure(Checkpoint.Attr.NoRelease);
rescan := FALSE;
ELSIF Text.Equal(action, "listlabels") THEN
ELSIF Text.Equal(action, "mkdep") THEN
SetOnSuccess(Checkpoint.Attr.DepMade);
ELSIF Text.Equal(action, "modified") THEN
SetOnSuccess(Checkpoint.Attr.Modified);
SetOnFailure(Checkpoint.Attr.Unmodified);
rescan := FALSE;
ELSIF Text.Equal(action, "realclean") THEN
SetDefaultUnbuilt();
ELSIF Text.Equal(action, "setlabel") THEN
self.delVal(pkg, "current-label");
ELSIF Text.Equal(action, "shipglobal") THEN
SetOnSuccess(Checkpoint.Attr.ShippedToGP);
ELSIF Text.Equal(action, "shiplocal") THEN
SetOnSuccess(Checkpoint.Attr.ShippedToLP);
ELSIF Text.Equal(action, "shipproject") THEN
SetOnSuccess(Checkpoint.Attr.ShippedToPP);
ELSIF Text.Equal(action, "update") THEN
SetDefaultUnbuilt();
SetOnSuccess(Checkpoint.Attr.UpToDate);
ClearOnSuccess(Checkpoint.Attr.OutOfDate);
ClearOnSuccess(Checkpoint.Attr.IsRelease);
ClearOnSuccess(Checkpoint.Attr.NoRelease);
ClearPackageTags();
ClearPkgVCCache();
ELSIF Text.Equal(action, "merge") OR Text.Equal(action, "merge2") THEN
SetDefaultUnbuilt();
ClearPackageTags();
ClearPkgVCCache();
Clear(Checkpoint.Attr.Modified);
Clear(Checkpoint.Attr.Unmodified);
Clear(Checkpoint.Attr.UpToDate);
Clear(Checkpoint.Attr.NoConflicts);
ELSIF Text.Equal(action, "uptodate") THEN
SetOnSuccess(Checkpoint.Attr.UpToDate);
SetOnFailure(Checkpoint.Attr.OutOfDate);
rescan := FALSE;
ELSIF Text.Equal(action, "any-user-cmd") THEN
ELSIF Text.Equal(action, "need-mkdep-build-ship") THEN
IF Checkpoint.Attr.Changed IN attrs THEN
SetDefaultUnbuilt();
rescan := FALSE;
END;
ELSIF Text.Equal(action, "need-build-ship") THEN
SetDefaultRebuild();
rescan := FALSE;
ELSIF Text.Equal(action, "clear-mod-unmod") THEN
Clear(Checkpoint.Attr.Modified);
Clear(Checkpoint.Attr.Unmodified);
ClearPkgVCCache();
rescan := FALSE;
ELSIF Text.Equal(action, "clear-utd-nocfl") THEN
Clear(Checkpoint.Attr.UpToDate);
Clear(Checkpoint.Attr.NoConflicts);
ClearPkgVCCache();
self.delVal(pkg, "current-label");
rescan := FALSE;
ELSIF Text.Equal(action, "clear-tags") THEN
ClearOnSuccess(Checkpoint.Attr.IsRelease);
ClearOnSuccess(Checkpoint.Attr.NoRelease);
ClearPackageTags();
ClearPkgVCCache();
rescan := FALSE;
ELSIF Text.Equal(action, "diff") THEN
rescan := FALSE;
ELSIF Text.Equal(action, "diff1") THEN
rescan := FALSE;
ELSIF Text.Equal(action, "diff2") THEN
rescan := FALSE;
END;
Clear(Checkpoint.Attr.Changed);
TRY
dir := FSUtils.CanonicalPathname(dir);
self.stateCache.setAttr(dir, attrs);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot set attributes for package " & pkg & ": " & e);
| FSUtils.E(e) =>
RAISE Error("cannot set attributes for package " & pkg & ": " & e);
END;
IF rescan THEN
TRY
IF self.verboseCache AND NOT Msg.vFlag THEN
MsgX.T(self.msgif, "rescanning " & dir);
END;
self.stateCache.update(dir);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot checkpoint package " & pkg & ": " & e);
END;
END;
END UpdateStateCache;
---------------------------------------------------------------------------
PROCEDURE ActionProbablyNeeded(self : T;
pkg : PkgBase.Name;
dir : Pathname.T;
action : PkgBase.Action;
VAR ret : INTEGER;
VAR res : TEXT) : BOOLEAN
RAISES {Error} =
VAR
attrs : Checkpoint.AttrSet;
BEGIN
res := NIL;
ret := 0;
(* `ret' is the fake return value of the action. `0' means
`okay', `yes', and `true', everything else `failure',
`no', and `false'. *)
IF NOT self.useCache THEN RETURN TRUE END;
TRY
dir := FSUtils.CanonicalPathname(dir);
EXCEPT
FSUtils.E(e) => RAISE Error(e);
END;
TRY
attrs := self.stateCache.getAttr(dir);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot set attributes for package " & pkg & ": " & e);
END;
IF Text.Equal(action, "build") THEN
RETURN Checkpoint.Attr.BuildFailed IN attrs OR
NOT Checkpoint.Attr.BuildOk IN attrs;
ELSIF Text.Equal(action, "buildlocal") THEN
RETURN Checkpoint.Attr.BuildFailed IN attrs OR
NOT Checkpoint.Attr.BuildOkL IN attrs;
ELSIF Text.Equal(action, "checkconflicts") THEN
IF Checkpoint.Attr.Conflicts IN attrs THEN
ret := 0; RETURN TRUE;
ELSIF Checkpoint.Attr.NoConflicts IN attrs THEN
ret := 1; RETURN TRUE;
ELSE
RETURN TRUE;
END;
ELSIF Text.Equal(action, "checkmodified") THEN
IF Checkpoint.Attr.Modified IN attrs THEN
ret := 0; RETURN TRUE;
ELSIF Checkpoint.Attr.Unmodified IN attrs THEN
ret := 1; RETURN FALSE;
ELSE
RETURN TRUE;
END;
ELSIF Text.Equal(action, "checkout") THEN
ELSIF Text.Equal(action, "checkrelease") THEN
IF Checkpoint.Attr.IsRelease IN attrs THEN
ret := 0; RETURN FALSE;
ELSIF Checkpoint.Attr.NoRelease IN attrs THEN
ret := 1; RETURN FALSE;
ELSE
RETURN TRUE;
END;
ELSIF Text.Equal(action, "checkuptodate") THEN
IF Checkpoint.Attr.UpToDate IN attrs THEN
ret := 0; RETURN TRUE;
ELSIF Checkpoint.Attr.OutOfDate IN attrs THEN
ret := 1; RETURN TRUE;
ELSE
RETURN TRUE;
END;
ELSIF Text.Equal(action, "clean") THEN
ELSIF Text.Equal(action, "commitdevelmajor") THEN
ELSIF Text.Equal(action, "commitdevelminor") THEN
ELSIF Text.Equal(action, "commitdevelpatch") THEN
ELSIF Text.Equal(action, "commitreleasemajor") THEN
ELSIF Text.Equal(action, "commitreleaseminor") THEN
ELSIF Text.Equal(action, "commitreleasepatch") THEN
ELSIF Text.Equal(action, "conflicts") THEN
IF Checkpoint.Attr.Conflicts IN attrs THEN
ret := 0; RETURN FALSE;
ELSIF Checkpoint.Attr.NoConflicts IN attrs THEN
ret := 1; RETURN FALSE;
ELSE
RETURN TRUE;
END;
ELSIF Text.Equal(action, "currentdeveltag") THEN
res := self.getVal(pkg, "current-devel-tag");
RETURN res = NIL;
ELSIF Text.Equal(action, "currentlabel") THEN
res := self.getVal(pkg, "current-label");
RETURN res = NIL;
ELSIF Text.Equal(action, "currentreleasetag") THEN
res := self.getVal(pkg, "current-release-tag");
RETURN res = NIL;
ELSIF Text.Equal(action, "currenttag") THEN
res := self.getVal(pkg, "current-tag");
RETURN res = NIL;
ELSIF Text.Equal(action, "externalshell") THEN
ELSIF Text.Equal(action, "getlabel") THEN
ELSIF Text.Equal(action, "isrelease") THEN
res := self.getVal(pkg, "release-tag");
IF Checkpoint.Attr.IsRelease IN attrs THEN
ret := 0; RETURN FALSE;
ELSIF Checkpoint.Attr.NoRelease IN attrs THEN
ret := 1; RETURN FALSE;
ELSE
RETURN TRUE;
END;
ELSIF Text.Equal(action, "listlabels") THEN
ELSIF Text.Equal(action, "mkdep") THEN
RETURN NOT Checkpoint.Attr.DepMade IN attrs;
ELSIF Text.Equal(action, "modified") THEN
IF Checkpoint.Attr.Modified IN attrs THEN
ret := 0; RETURN FALSE;
ELSIF Checkpoint.Attr.Unmodified IN attrs THEN
ret := 1; RETURN FALSE;
ELSE
RETURN TRUE;
END;
ELSIF Text.Equal(action, "realclean") THEN
ELSIF Text.Equal(action, "setlabel") THEN
ELSIF Text.Equal(action, "shipglobal") THEN
RETURN NOT Checkpoint.Attr.ShippedToGP IN attrs;
ELSIF Text.Equal(action, "shiplocal") THEN
RETURN NOT Checkpoint.Attr.ShippedToLP IN attrs;
ELSIF Text.Equal(action, "shipproject") THEN
RETURN NOT Checkpoint.Attr.ShippedToPP IN attrs;
ELSIF Text.Equal(action, "update") THEN
ELSIF Text.Equal(action, "uptodate") THEN
IF Checkpoint.Attr.UpToDate IN attrs THEN
ret := 0; RETURN FALSE;
ELSIF Checkpoint.Attr.OutOfDate IN attrs THEN
ret := 1; RETURN FALSE;
ELSE
RETURN TRUE;
END;
ELSIF Text.Equal(action, "any-user-cmd") THEN
ELSIF Text.Equal(action, "evaluate-changes") THEN
END;
RETURN TRUE;
END ActionProbablyNeeded;
---------------------------------------------------------------------------
PROCEDURE ResultFromInternalVersionControl(
self : T;
pkg : PkgBase.Name;
action : PkgBase.Action;
parameters : TextTextTbl.T;
VAR res : TEXT;
VAR ret : INTEGER) : BOOLEAN RAISES {Error} =
PROCEDURE Ret(b : BOOLEAN) : INTEGER =
BEGIN
IF b THEN
RETURN 0;
ELSE
RETURN 1;
END;
END Ret;
PROCEDURE TagText(tag : Tag.T) : TEXT =
BEGIN
IF tag = NIL THEN
RETURN "no appropriate tag found";
END;
RETURN tag.denotation();
END TagText;
CONST DoubleQuote = '\"';
CONST Quote = '\'';
PROCEDURE EvalMsgOptions() =
VAR opts : TEXT;
PROCEDURE EvalOpts() =
VAR args, res : TEXT;
PROCEDURE EvalOpt(name : TEXT; VAR res : TEXT) : BOOLEAN =
VAR
start, end : INTEGER;
c : CHAR;
PROCEDURE FindNext(c : CHAR) =
BEGIN
WHILE end < Text.Length(args) AND Text.GetChar(args, end) # c DO
INC(end);
END;
IF end = Text.Length(args) THEN
INC(end);
END;
END FindNext;
BEGIN
start := TextUtils.Pos(args, name);
IF start > -1 THEN
INC(start, Text.Length(name));
WHILE start < Text.Length(args) AND
Text.GetChar(args, start) IN ASCII.Spaces DO
INC(start);
END;
IF start < Text.Length(args) THEN
c := Text.GetChar(args, start);
IF c = DoubleQuote THEN
INC(start);
end := start;
FindNext(c);
ELSIF c = Quote THEN
INC(start);
end := start;
FindNext(c);
ELSE
end := start;
FindNext(' ');
END;
res := Text.Sub(args, start, end - start);
RETURN TRUE;
END;
END;
RETURN FALSE;
END EvalOpt;
BEGIN
TRY
args := TextConv.Decode(opts, FALSE);
EXCEPT ELSE
MsgX.Error(self.msgif, "cannot un-escape options line: " & opts);
args := opts;
END;
IF Msg.dFlag THEN
MsgX.D(self.msgif, " args: `" & args & "'");
END;
IF EvalOpt("-message", res) THEN
IF Msg.dFlag THEN
MsgX.D(self.msgif, " argument -message `" & res & "'");
END;
msg := res;
END;
IF msg = NIL AND EvalOpt("-msg", res) THEN
IF Msg.dFlag THEN
MsgX.D(self.msgif, " argument -msg `" & res & "'");
END;
msg := res;
END;
IF msg = NIL AND EvalOpt("-m", res) THEN
IF Msg.dFlag THEN
MsgX.D(self.msgif, " argument -m `" & res & "'");
END;
msg := res;
END;
IF EvalOpt("-file", res) THEN
IF Msg.dFlag THEN
MsgX.D(self.msgif, " argument -file `" & res & "'");
END;
msgFile := APN.New(res);
END;
IF msgFile = NIL AND EvalOpt("-f", res) THEN
IF Msg.dFlag THEN
MsgX.D(self.msgif, " argument -f `" & res & "'");
END;
msgFile := APN.New(res);
END;
END EvalOpts;
BEGIN
IF parameters.get("PKGVMOPT", opts) THEN
EvalOpts();
END;
IF parameters.get("PKGMOPT", opts) THEN
EvalOpts();
END;
END EvalMsgOptions;
VAR
done := FALSE;
tag : Tag.T;
tagtext : TEXT;
vc, vcn : PkgVC.T;
msg : TEXT := NIL;
msgFile : APN.T := NIL;
BEGIN
TRY
IF self.pkgvcAcc # NIL THEN
vc := self.pkgVCIF(pkg);
IF vc # NIL THEN
IF Text.Equal(action, "checkconflicts") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "checking package " & pkg &
" for conflicts", level := 2);
END;
ret := Ret(vc.conflicts());
res := vc.lastVCMsg;
(* MsgX.T(self.msgif, res); *)
done := TRUE;
ELSIF Text.Equal(action, "checkmodified") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "checking package " & pkg &
" for modifications", level := 2);
END;
ret := Ret(vc.modified());
res := vc.lastVCMsg;
(* MsgX.T(self.msgif, res); *)
done := TRUE;
ELSIF Text.Equal(action, "checkout") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "checking out package " & pkg, level := 2);
END;
VAR loc, tagtext, pkg : TEXT; pkgs : TextSeq.T; BEGIN
IF parameters.get("TAG", tagtext) AND
parameters.get("LOCATION", loc) AND
parameters.get("PKG", pkg) THEN
vcn := NEW(PkgVC.T).init(self.msgif);
vcn.setEnvironment(vc.getEnvironment());
TRY
res := "unknown checkout error";
pkgs := NEW(TextSeq.T).init();
pkgs.addhi(pkg);
VCUtils.CheckoutDirect(vcn, NIL, loc, tagtext, pkgs);
res := vcn.lastVCMsg;
(* MsgX.T(self.msgif, res); *)
ret := 0;
EXCEPT
PkgVC.E(t) => ret := 1; res := vcn.lastVCMsg & "\n" & t;
END;
done := TRUE;
ELSE
RAISE Error("checkout missing one of TAG, LOCATION, PKG");
END;
END;
ELSIF Text.Equal(action, "checkrelease") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "checking if package " & pkg &
" is a release", level := 2);
END;
ret := Ret(vc.isRelease(tag));
res := TagText(tag);
done := TRUE;
ELSIF Text.Equal(action, "checkuptodate") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "checking if package " & pkg &
" is up-to-date", level := 2);
END;
ret := Ret(vc.upToDate());
res := vc.lastVCMsg;
(* MsgX.T(self.msgif, res); *)
done := TRUE;
ELSIF Text.Equal(action, "commitdevelmajor") THEN
TRY
EvalMsgOptions();
vc.commitChanges(PkgVC.CommitType.Major, msg, msgFile);
res := ""; (* commit will only leave the tag in lastVCMsg *)
ret := 0;
EXCEPT
PkgVC.E(t) => res := vc.lastVCMsg & "\n" & t; ret := 1;
END;
done := TRUE;
ELSIF Text.Equal(action, "commitdevelminor") THEN
TRY
EvalMsgOptions();
vc.commitChanges(PkgVC.CommitType.Minor, msg, msgFile);
res := ""; (* commit will only leave the tag in lastVCMsg *)
ret := 0;
EXCEPT
PkgVC.E(t) => res := vc.lastVCMsg & "\n" & t; ret := 1;
END;
done := TRUE;
ELSIF Text.Equal(action, "commitdevelpatch") THEN
TRY
EvalMsgOptions();
vc.commitChanges(PkgVC.CommitType.Patch, msg, msgFile);
res := ""; (* commit will only leave the tag in lastVCMsg *)
ret := 0;
EXCEPT
PkgVC.E(t) => res := vc.lastVCMsg & "\n" & t; ret := 1;
END;
done := TRUE;
ELSIF Text.Equal(action, "commitreleasemajor") THEN
TRY
EvalMsgOptions();
vc.commitRelease(PkgVC.CommitType.Major, msg, msgFile);
res := ""; (* commit will only leave the tag in lastVCMsg *)
ret := 0;
EXCEPT
PkgVC.E(t) => res := vc.lastVCMsg & "\n" & t; ret := 1;
END;
done := TRUE;
ELSIF Text.Equal(action, "commitreleaseminor") THEN
TRY
EvalMsgOptions();
vc.commitRelease(PkgVC.CommitType.Minor, msg, msgFile);
res := ""; (* commit will only leave the tag in lastVCMsg *)
ret := 0;
EXCEPT
PkgVC.E(t) => res := vc.lastVCMsg & "\n" & t; ret := 1;
END;
done := TRUE;
ELSIF Text.Equal(action, "commitreleasepatch") THEN
TRY
EvalMsgOptions();
vc.commitRelease(PkgVC.CommitType.Patch, msg, msgFile);
res := ""; (* commit will only leave the tag in lastVCMsg *)
ret := 0;
EXCEPT
PkgVC.E(t) => res := vc.lastVCMsg & "\n" & t; ret := 1;
END;
done := TRUE;
ELSIF Text.Equal(action, "conflicts") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "checking package " & pkg &
" for conflicts", level := 2);
END;
ret := Ret(vc.conflicts());
res := "";
done := TRUE;
ELSIF Text.Equal(action, "currentdeveltag") THEN
tag := vc.currentDevelopmentTag(); ret := 0;
res := TagText(tag);
done := TRUE;
ELSIF Text.Equal(action, "currentlabel") THEN
ELSIF Text.Equal(action, "currentreleasetag") THEN
tag := vc.currentReleaseTag(); ret := 0;
res := TagText(tag);
done := TRUE;
ELSIF Text.Equal(action, "currenttag") THEN
tag := vc.currentLocalTag(); ret := 0;
res := TagText(tag);
done := TRUE;
ELSIF Text.Equal(action, "getlabel") THEN
ELSIF Text.Equal(action, "isrelease") THEN
ret := Ret(vc.isRelease(tag));
res := "";
done := TRUE;
ELSIF Text.Equal(action, "listlabels") THEN
ELSIF Text.Equal(action, "modified") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "checking package " & pkg &
" for modifications", level := 2);
END;
ret := Ret(vc.modified());
res := "";
done := TRUE;
ELSIF Text.Equal(action, "setlabel") THEN
ELSIF Text.Equal(action, "update") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "updating package " & pkg, level := 2);
END;
IF parameters.get("TAG", tagtext) THEN
tag := Tag.New(tagtext);
IF VCUtils.TagExists(vc, tag) THEN
TRY
vc.update(tag);
res := vc.lastVCMsg;
(* MsgX.T(self.msgif, res); *)
ret := 0;
EXCEPT
PkgVC.E(t) => res := t; ret := 1;
END;
ELSE
res := "tag does not exist: " & tag.originalText();
ret := 1;
END;
ELSE
res := "no tag defined for update";
ret := 1;
END;
done := TRUE;
ELSIF Text.Equal(action, "uptodate") THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "checking if package " & pkg &
" is up-to-date", level := 2);
END;
ret := Ret(vc.upToDate());
res := "";
done := TRUE;
ELSIF Text.Equal(action, "diff") THEN
(* FIXME: provide internal implementation for diff action *)
ELSIF Text.Equal(action, "diff1") THEN
(* FIXME: provide internal implementation for diff1 action *)
ELSIF Text.Equal(action, "diff2") THEN
(* FIXME: provide internal implementation for diff2 action *)
END;
IF done THEN
UpdateStateCache(self, self.pkgPath(pkg), action, ret);
RETURN TRUE;
END;
END;
END;
EXCEPT
PkgVC.E(m) => RAISE Error("version control backend failed: " & m);
END;
RETURN FALSE;
END ResultFromInternalVersionControl;
---------------------------------------------------------------------------
PROCEDURE ExecAction(self : T; pkg : PkgBase.Name; action : PkgBase.Action;
VAR res : TEXT;
externalShell : TEXT := NIL;
parameters : TextTextTbl.T := NIL) : INTEGER
RAISES {Error} =
(*
Execute the action associated with `action' in the
package root directory of `pkg' and return the exit code of
the process (shell).
*)
VAR
ret : INTEGER;
cmd : PkgBase.CmdSeq;
nwd : Pathname.T;
kind : PkgBase.Kind;
errt : TEXT := "";
done := FALSE;
BEGIN
IF NOT self.exists(pkg) THEN
RAISE Error("package " & pkg & " does not exist");
END;
nwd := self.pkgPath(pkg);
kind := self.pkgType(pkg);
IF self.useCache AND
NOT ActionProbablyNeeded(self, pkg, nwd, action, ret, res) THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "omitting action " & action &
" based on cached state", level := 2);
END;
RETURN ret;
END;
IF self.useCache AND
(Text.Equal(action, "modified") OR Text.Equal(action, "conflicts") OR
Text.Equal(action, "uptodate") OR Text.Equal(action, "release")) THEN
TRY
WITH res = self.getAndCacheVersionState(pkg) DO
IF Msg.vFlag THEN
MsgX.V(self.msgif, "--- status package " &
TextUtils.Compress(res));
END;
END;
IF Text.Equal(action, "modified") THEN
IF self.attrIsSet(pkg, Checkpoint.Attr.Modified) THEN
ret := 0;
ELSE
ret := 1;
END;
ELSIF Text.Equal(action, "conflicts") THEN
IF self.attrIsSet(pkg, Checkpoint.Attr.Conflicts) THEN
ret := 0;
ELSE
ret := 1;
END;
ELSIF Text.Equal(action, "uptodate") THEN
IF self.attrIsSet(pkg, Checkpoint.Attr.UpToDate) THEN
ret := 0;
ELSE
ret := 1;
END;
ELSIF Text.Equal(action, "release") THEN
IF self.attrIsSet(pkg, Checkpoint.Attr.IsRelease) THEN
ret := 0;
ELSE
ret := 1;
END;
END;
done := TRUE;
EXCEPT
END;
END;
IF done THEN
RETURN ret;
END;
IF ResultFromInternalVersionControl(self, pkg, action, parameters,
res, ret) THEN
RETURN ret;
END;
res := "external command failure";
TRY
TRY
cmd := self.cfg.getAction(kind, action);
IF cmd = NIL THEN
RAISE Error("no commands for action " & action);
END;
TRY
cmd := TextUtils.SubstituteVariables(cmd, parameters);
EXCEPT
TextUtils.Error(e) => RAISE Error("parameter error in " & cmd &
": " & e);
END;
IF externalShell = NIL THEN
externalShell := self.cfg.getAction(kind, "externalshell");
END;
MsgX.T(self.msgif, "[" & nwd & "] " & cmd);
IF NOT Text.Empty(cmd) AND NOT Text.Equal(cmd, "-") THEN
IF externalShell = NIL THEN
errt := " failed";
ret := System.ExecuteList(cmd, msgif := self.msgif, wd := nwd);
ELSE
errt := " via shell " & externalShell & " failed";
ret := System.ExecuteShell(cmd, externalShell, msgif := self.msgif,
wd := nwd);
END;
(* caller is expected to print exit code when appropriate *)
res := "";
ELSE
ret := 0;
END;
UpdateStateCache(self, nwd, action, ret);
EXCEPT
System.ExecuteError => RAISE Error("execution of " & cmd & errt);
| Thread.Alerted => RAISE Error("execution of " & cmd &
"interrupted");
| Error(e) => RAISE Error(e);
END;
FINALLY
(* skip *)
END;
RETURN ret;
END ExecAction;
---------------------------------------------------------------------------
PROCEDURE ExecCmdList(self : T; pkg : PkgBase.Name; cmd : TEXT;
externalShell : TEXT := NIL) : INTEGER RAISES {Error} =
VAR
ret : INTEGER;
nwd : Pathname.T;
kind := self.pkgType(pkg);
BEGIN
IF NOT self.exists(pkg) THEN
RAISE Error("package " & pkg & " does not exist");
END;
nwd := self.pkgPath(pkg);
TRY
TRY
IF externalShell = NIL THEN
externalShell := self.cfg.getAction(kind, "externalshell");
END;
MsgX.T(self.msgif, "[" & nwd & "] " & cmd);
IF externalShell = NIL THEN
ret := System.ExecuteList(cmd, msgif := self.msgif, wd := nwd);
ELSE
ret := System.ExecuteShell(cmd, externalShell, msgif := self.msgif,
wd := nwd);
END;
UpdateStateCache(self, nwd, "any-user-cmd", ret);
EXCEPT
System.ExecuteError => RAISE Error("execution of " & cmd & " failed");
| Thread.Alerted => RAISE Error("execution of " & cmd &
"interrupted");
END;
FINALLY
(* skip *)
END;
RETURN ret;
END ExecCmdList;
---------------------------------------------------------------------------
PROCEDURE GetCmdOutput(self : T; pkg : PkgBase.Name;
cmd : TEXT; VAR ret : INTEGER) : TEXT RAISES {Error} =
VAR
proc : Process.T;
res : TEXT := NIL;
rd : Rd.T;
nwd : Pathname.T;
BEGIN
IF NOT self.exists(pkg) THEN
RAISE Error("package " & pkg & " does not exist");
END;
nwd := self.pkgPath(pkg);
TRY
TRY
MsgX.T(self.msgif, "[" & nwd & "] " & cmd);
proc := System.RdExecute(cmd, rd, nwd, msgif := self.msgif);
res := Rd.GetText(rd, LAST(INTEGER));
ret := Process.Wait(proc);
UpdateStateCache(self, nwd, "any-user-cmd", ret);
EXCEPT
Rd.Failure => RAISE Error("error reading from command " & cmd);
| Thread.Alerted => RAISE Error("execution of " & cmd & "interrupted");
| System.ExecuteError => RAISE Error("execution of " & cmd & " failed");
END;
FINALLY
(* skip *)
END;
RETURN res;
END GetCmdOutput;
---------------------------------------------------------------------------
PROCEDURE GetAndCacheVersionState(self : T; pkg : PkgBase.Name) : TEXT
RAISES {Error} =
VAR
ret : INTEGER;
res : TEXT;
val : TEXT;
cmd : TEXT;
kind := self.pkgType(pkg);
dir := self.pkgPath(pkg);
seq : TextSeq.T;
vc : PkgVC.T;
tag : Tag.T;
BEGIN
IF NOT self.useCache THEN RETURN NIL END;
IF self.pkgvcAcc # NIL THEN
vc := self.pkgVCIF(pkg);
TRY
IF vc # NIL THEN
IF Msg.vFlag THEN
MsgX.V(self.msgif, "getting short status for package " & pkg,
level := 2);
END;
IF vc.modified() THEN
UpdateStateCache(self, dir, "modified", 0, FALSE);
res := pkg & ": modified";
ELSE
UpdateStateCache(self, dir, "modified", 1, FALSE);
res := pkg & ":";
END;
IF vc.upToDate() THEN
UpdateStateCache(self, dir, "uptodate", 0, FALSE);
res := res & " up-to-date";
ELSE
UpdateStateCache(self, dir, "uptodate", 1, FALSE);
END;
IF vc.conflicts() THEN
UpdateStateCache(self, dir, "conflicts", 0, FALSE);
res := res & " conflicts";
ELSE
UpdateStateCache(self, dir, "conflicts", 1, FALSE);
END;
TRY
IF vc.isRelease(tag) THEN
UpdateStateCache(self, dir, "isrelease", 0, FALSE);
self.stateCache.setVal(dir, "release-tag", tag.denotation());
ELSE
UpdateStateCache(self, dir, "isrelease", 1, FALSE);
self.stateCache.delVal(dir, "release-tag");
END;
IF vc.isSticky(tag) THEN
self.stateCache.setVal(dir, "sticky-tag", tag.denotation());
ELSE
self.stateCache.delVal(dir, "sticky-tag");
END;
tag := vc.currentLocalTag();
self.stateCache.setVal(dir, "current-tag", tag.denotation());
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("checkpoint error for " & pkg & ": " & e);
END;
RETURN res;
END;
EXCEPT
PkgVC.E(m) => RAISE Error("version control backend failed: " & m);
END;
END;
cmd := self.cfg.getAction(kind, "shortstatus");
IF cmd = NIL THEN
cmd := "pkgvm -sstat";
END;
res := GetCmdOutput(self, pkg, cmd, ret);
IF ret # 0 THEN
RAISE Error("command `" & cmd & "' failed in package " & pkg &
" with status " & Fmt.Int(ret));
END;
seq := TextUtils.Split(res, " ");
IF TextUtils.MemberOfTextSeq(seq, "modified") THEN
UpdateStateCache(self, dir, "modified", 0, FALSE);
ELSE
UpdateStateCache(self, dir, "modified", 1, FALSE);
END;
IF TextUtils.MemberOfTextSeq(seq, "up-to-date") THEN
UpdateStateCache(self, dir, "uptodate", 0, FALSE);
ELSE
UpdateStateCache(self, dir, "uptodate", 1, FALSE);
END;
IF TextUtils.MemberOfTextSeq(seq, "conflicts") THEN
UpdateStateCache(self, dir, "conflicts", 0, FALSE);
ELSE
UpdateStateCache(self, dir, "conflicts", 1, FALSE);
END;
TRY
IF MatchesTextSeq(seq, "^release:", val) THEN
UpdateStateCache(self, dir, "isrelease", 0, FALSE);
self.stateCache.setVal(dir, "release-tag", TextAfterChar(val, ':'));
ELSE
UpdateStateCache(self, dir, "isrelease", 1, FALSE);
self.stateCache.delVal(dir, "release-tag");
END;
IF MatchesTextSeq(seq, "^current:", val) THEN
self.stateCache.setVal(dir, "current-tag", TextAfterChar(val, ':'));
ELSE
self.stateCache.delVal(dir, "current-tag");
END;
IF MatchesTextSeq(seq, "^sticky:", val) THEN
self.stateCache.setVal(dir, "sticky-tag", TextAfterChar(val, ':'));
ELSE
self.stateCache.delVal(dir, "sticky-tag");
END;
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("checkpoint error for " & pkg & ": " & e);
END;
RETURN res;
END GetAndCacheVersionState;
---------------------------------------------------------------------------
PROCEDURE MatchesTextSeq(ts : TextSeq.T; pattern : TEXT;
VAR res : TEXT) : BOOLEAN =
VAR pat : RegEx.Pattern;
BEGIN
TRY pat := RegEx.Compile(pattern); EXCEPT ELSE END;
FOR i := 0 TO ts.size() - 1 DO
WITH elem = ts.get(i) DO
IF RegEx.Execute(pat, elem) > -1 THEN
res := elem;
RETURN TRUE;
END;
END;
END;
RETURN FALSE;
END MatchesTextSeq;
---------------------------------------------------------------------------
PROCEDURE TextAfterChar(t : TEXT; c : CHAR) : TEXT =
VAR i := Text.FindChar(t, c);
BEGIN
IF i < 0 THEN
RETURN "";
END;
RETURN Text.Sub(t, i + 1);
END TextAfterChar;
---------------------------------------------------------------------------
PROCEDURE FileContents(self : T; pkg : PkgBase.Name; fn : TEXT) : TEXT
RAISES {Error} =
VAR
path : Pathname.T;
rd : Rd.T;
res : TEXT;
BEGIN
IF NOT self.exists(pkg) THEN
RAISE Error("package " & pkg & " does not exist");
END;
IF Pathname.Absolute(PathRepr.Native(fn)) THEN
RAISE Error("pathname " & fn & " must not be absolute");
END;
path := Pathname.Join(self.pkgPath(pkg), PathRepr.Native(fn), NIL);
TRY
rd := FileRd.Open(path);
EXCEPT ELSE
RAISE Error("cannot open file " & fn);
END;
TRY
TRY
res := Rd.GetText(rd, LAST(CARDINAL));
EXCEPT ELSE
RAISE Error("cannot read file " & fn);
END;
FINALLY
TRY Rd.Close(rd) EXCEPT ELSE END;
END;
RETURN res;
END FileContents;
---------------------------------------------------------------------------
PROCEDURE Checkout(self : T; pkg : PkgBase.Name;
checkoutCmd : PkgBase.Action;
externalShell : TEXT := NIL;
rootDir : Pathname.T := NIL;
parameters : TextTextTbl.T := NIL) : INTEGER
RAISES {Error} =
VAR
ret : INTEGER;
loc : TEXT;
cmd : PkgBase.CmdSeq;
kind := self.pkgType(pkg);
BEGIN
IF self.exists(pkg) THEN
RAISE Error("package " & pkg & " does already exist");
END;
TRY
TRY
cmd := self.cfg.getAction(self.pkgType(pkg), checkoutCmd);
IF cmd = NIL THEN (* undefined package type *)
cmd := self.cfg.getAction("DEFAULT", checkoutCmd);
END;
TRY
cmd := TextUtils.SubstituteVariables(cmd, parameters);
EXCEPT
TextUtils.Error(e) => RAISE Error("parameter error in " & cmd &
": " & e);
END;
IF externalShell = NIL THEN
externalShell := self.cfg.getAction(kind, "externalshell");
END;
MsgX.T(self.msgif, "[" & rootDir & "] " & cmd);
IF externalShell = NIL THEN
ret := System.ExecuteList(cmd, msgif := self.msgif, wd := rootDir);
ELSE
ret := System.ExecuteShell(cmd, externalShell, msgif := self.msgif,
wd := rootDir);
END;
IF parameters # NIL AND parameters.get("LOCATION", loc) THEN
rootDir := Pathname.Join(rootDir, loc, NIL);
ELSIF self.location.get(pkg, loc) THEN
IF NOT Text.Equal(loc, Undefined) THEN
rootDir := Pathname.Join(rootDir, loc, NIL);
END;
END;
EVAL self.location.delete(pkg, loc);
loc := Pathname.Join(rootDir, pkg, NIL);
EVAL self.exists(pkg, rootDir);
UpdateStateCache(self, loc, checkoutCmd, ret);
EXCEPT
System.ExecuteError => RAISE Error("execution of " & cmd & " failed");
| Thread.Alerted => RAISE Error("execution of " & cmd &
"interrupted");
END;
FINALLY
(* skip *)
END;
RETURN ret;
END Checkout;
---------------------------------------------------------------------------
PROCEDURE GetFileCache(self : T) : FileInfo.T =
BEGIN
RETURN self.fileCache;
END GetFileCache;
---------------------------------------------------------------------------
PROCEDURE NewCheckpoint(self : T; update := FALSE) : Checkpoint.T
RAISES {Error} =
VAR
cp := Checkpoint.New(self.fileCache, self.msgif);
iter := self.location.iterate();
pkg : TEXT;
path : TEXT;
BEGIN
TRY
WHILE iter.next(pkg, path) DO
IF NOT Text.Equal(path, Undefined) THEN
cp.addDir(path);
END;
END;
IF update THEN
IF self.verboseCache AND NOT Msg.vFlag THEN
MsgX.T(self.msgif, "scanning all packages (new checkpoint)...");
END;
cp.update();
END;
EXCEPT
Checkpoint.Error(e) => RAISE Error("NewCheckpoint: " & e);
END;
RETURN cp;
END NewCheckpoint;
---------------------------------------------------------------------------
PROCEDURE ReplaceStateCache(self : T; sc : Checkpoint.T) =
BEGIN
self.stateCache := sc;
END ReplaceStateCache;
---------------------------------------------------------------------------
PROCEDURE CachedState(self : T) : Checkpoint.T =
BEGIN
RETURN self.stateCache;
END CachedState;
---------------------------------------------------------------------------
PROCEDURE UpdateCache(self : T) RAISES {Error} =
BEGIN
IF NOT self.useCache THEN RETURN END;
TRY
IF self.verboseCache AND NOT Msg.vFlag THEN
MsgX.T(self.msgif, "scanning all packages (cache update)...");
END;
self.stateCache.update();
EXCEPT
Checkpoint.Error(e) => RAISE Error(e);
END;
END UpdateCache;
---------------------------------------------------------------------------
PROCEDURE DumpStateCache(self : T; header : TEXT) =
BEGIN
IF NOT self.useCache THEN RETURN END;
MsgX.T(self.msgif, header);
TRY MsgX.T(self.msgif, self.stateCache.toText()); EXCEPT ELSE END;
END DumpStateCache;
---------------------------------------------------------------------------
PROCEDURE SetAttr(self : T; pkg : PkgBase.Name; attr : Checkpoint.Attr)
RAISES {Error} =
VAR
path : TEXT;
attrs : Checkpoint.AttrSet;
BEGIN
IF NOT self.useCache THEN RETURN END;
IF self.location.get(pkg, path) THEN
TRY
attrs := self.stateCache.getAttr(path) + Checkpoint.AttrSet{attr};
self.stateCache.setAttr(path, attrs);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot set attributes for package " & pkg & ": " & e);
END;
ELSE
RAISE Error("SetAttr: no location for package " & pkg);
END;
END SetAttr;
---------------------------------------------------------------------------
PROCEDURE ClearAttr(self : T; pkg : PkgBase.Name; attr : Checkpoint.Attr)
RAISES {Error} =
VAR
path : TEXT;
attrs : Checkpoint.AttrSet;
BEGIN
IF NOT self.useCache THEN RETURN END;
IF self.location.get(pkg, path) THEN
TRY
attrs := self.stateCache.getAttr(path) - Checkpoint.AttrSet{attr};
self.stateCache.setAttr(path, attrs);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot set attributes for package " & pkg & ": " & e);
END;
ELSE
RAISE Error("SetAttr: no location for package " & pkg);
END;
END ClearAttr;
---------------------------------------------------------------------------
PROCEDURE AttrIsSet(self : T; pkg : PkgBase.Name; attr : Checkpoint.Attr)
: BOOLEAN RAISES {Error} =
VAR
path : TEXT;
attrs : Checkpoint.AttrSet;
BEGIN
IF NOT self.useCache THEN RETURN FALSE END;
IF self.location.get(pkg, path) THEN
TRY
attrs := self.stateCache.getAttr(path);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot get attributes for package " & pkg & ": " & e);
END;
RETURN attr IN attrs;
ELSE
RAISE Error("AttrIsSet: no location for package " & pkg);
END;
END AttrIsSet;
---------------------------------------------------------------------------
PROCEDURE SetVal(self : T; pkg : PkgBase.Name; name, val : TEXT)
RAISES {Error} =
VAR
path : TEXT;
BEGIN
IF NOT self.useCache THEN RETURN END;
IF self.location.get(pkg, path) THEN
TRY
self.stateCache.setVal(path, name, val);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot set value for package " & pkg & ": " & e);
END;
ELSE
RAISE Error("SetVal: no location for package " & pkg);
END;
END SetVal;
---------------------------------------------------------------------------
PROCEDURE GetVal(self : T; pkg : PkgBase.Name; name : TEXT) : TEXT
RAISES {Error} =
VAR
path : TEXT;
BEGIN
IF NOT self.useCache THEN RETURN NIL END;
IF self.location.get(pkg, path) THEN
TRY
RETURN self.stateCache.getVal(path, name);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot get value for package " & pkg & ": " & e);
END;
ELSE
RAISE Error("GetVal: no location for package " & pkg);
END;
END GetVal;
---------------------------------------------------------------------------
PROCEDURE DelVal(self : T; pkg : PkgBase.Name; name : TEXT) RAISES {Error} =
VAR
path : TEXT;
BEGIN
IF NOT self.useCache THEN RETURN END;
IF self.location.get(pkg, path) THEN
TRY
self.stateCache.delVal(path, name);
EXCEPT
Checkpoint.Error(e) =>
RAISE Error("cannot delete value for package " & pkg & ": " & e);
END;
ELSE
RAISE Error("GetVal: no location for package " & pkg);
END;
END DelVal;
---------------------------------------------------------------------------
BEGIN (* PoolSet MAIN *)
END PoolSet.