--GroupsImpl.mesa
--Last edited by Newman.es: May 6, 1983 
--Alto/Mesa/Laurel 6.1 version

DIRECTORY
  Ascii USING [CR, DEL, ESC, SP],
  BinaryTree USING [CompareTrees, DestroyTree, Enter, EnumerateTree, MergeTrees, Present, ReportProc, Tree, UserProc],
  BodyDefs USING [maxRNameLength, oldestTime, RName, Timestamp],
  exD: FROM "ExceptionDefs" USING [AppendStringToExceptionLine, ClearExceptionsRegion, DisplayExceptionStringOnLine, ExceptionLineOverflow],
  IODefs USING [LineOverflow, ReadChar, ReadID, Rubout, WriteChar, WriteDecimal, WriteLine, WriteString],
  LaurelExecDefs USING [MakeMenuCommandCallable],
  MailParseDefs USING [endOfInput, endOfList, FinalizeParse, InitializeParse, ParseHandle, ParseError, ParseNameList],
  NameInfoDefs USING [CheckStamp, Close, Enumerate, GetMembers, IsInList, MemberInfo, Membership, MembershipLevel, NameType, RListHandle],
  NameInfoSpecialDefs USING [CleanUp],
  Runtime USING [GetBcdTime],
  Storage USING [EmptyString, Node, Free, Prune],
  StreamDefs USING [FileNameError, NewByteStream, Read, StreamError, StreamHandle, userAbort],
  String USING [AppendChar, AppendString, DeleteSubString, EquivalentSubStrings, LowerCase, SubStringDescriptor],
  Time USING [Append, Unpack];

GroupsImpl: PROGRAM
  IMPORTS BinaryTree, exD, IODefs, LaurelExecDefs, NameInfoDefs, MailParseDefs, NameInfoSpecialDefs, Runtime, Storage, StreamDefs, String, Time =
  BEGIN OPEN Ascii;

Command: TYPE = {expand, isMember, union, intersect, subtract, inReg, notInReg};

Tree: TYPE = BinaryTree.Tree;

mdsZoneRecord: RECORD [POINTER TO MDSZoneProcs] _ [@mdsZoneProcs];
MDSZoneProcs: TYPE = MACHINE DEPENDENT RECORD [
  alloc: PROC [MDSZone, CARDINAL] RETURNS [POINTER],
  free: PROC [MDSZone, POINTER]];
mdsZoneProcs: MDSZoneProcs _ [Alloc, Free];
Alloc: PROC [z: MDSZone, c: CARDINAL] RETURNS [POINTER] =
  {RETURN [Storage.Node [c]]};
Free: PROC [z: MDSZone, p: POINTER] =
  {Storage.Free [p]};
z: MDSZone = LOOPHOLE [@mdsZoneRecord]; 
 
aborted: BOOLEAN _ FALSE;
level: NameInfoDefs.MembershipLevel _ upArrow;

maxRNameLength: CARDINAL = BodyDefs.maxRNameLength;

alreadySeen: Tree _ NIL;
  
  WriteString: PROC [STRING] = IODefs.WriteString;
  WriteLine: PROC [STRING] = IODefs.WriteLine;
  WriteCR: PROC = {IODefs.WriteChar [CR]};
  
  TerminateDataSink: PROC [ctMembers: CARDINAL] =
    BEGIN
    IF ctMembers = 0 THEN WriteLine [";(empty)"L]
    ELSE
      BEGIN
      WriteString["; ("L];
      IODefs.WriteDecimal[ctMembers];
      WriteString[" member"L];
      IF ctMembers > 1 THEN WriteString["s"L];
      WriteLine[")"L];
      END;
    END;
  
  DestroyTreeNil: PROC [tree: Tree, z: MDSZone] RETURNS [nil: Tree _ NIL] = INLINE {BinaryTree.DestroyTree [tree, z]};

  PutLevel: PROC [level: NameInfoDefs.MembershipLevel] =
    BEGIN
    WriteString [SELECT level FROM
      closure => "closure"L,
      upArrow => "upArrow"L,
      ENDCASE => "direct"L];
    END;  -- of PutLevel

  CompareGroups: PROC [
    group1, group2: BodyDefs.RName, option: Command] =
    BEGIN
    ctMembers: CARDINAL _ 0;
    tree1, tree2: Tree;

    Report: BinaryTree.ReportProc =  -- [id: Sv, membership: Membership]
      BEGIN
      good: BOOLEAN =
        SELECT option FROM
          intersect => (membership = both),
          subtract => (membership = first),
          union => TRUE,
          ENDCASE => ERROR;
      IF good THEN
        BEGIN
        aborted_ StreamDefs.userAbort;
        IF aborted THEN RETURN;
        IF ctMembers # 0 THEN WriteString[", "L];
        WriteString[id];
        ctMembers _ ctMembers + 1;
        END;
      END;  -- of Report

    tree1 _ ExpandFileOrGroup[group1 ! BadFile => GOTO return];
    IF aborted THEN {
      BinaryTree.DestroyTree[tree1, z]; WriteLine["Aborted"L]; RETURN};
    tree2 _ ExpandFileOrGroup[
      group2 ! BadFile => {BinaryTree.DestroyTree[tree1, z]; GOTO return}];
    IF aborted THEN {
      BinaryTree.DestroyTree[tree1, z];
      BinaryTree.DestroyTree[tree2, z];
      WriteLine["Aborted"L];
      RETURN};
    WriteString[
      SELECT option FROM
        intersect => "Intersection"L,
        subtract => "Subtraction"L,
        union => "Union"L,
        ENDCASE => ERROR];
    WriteString[" of group "L];
    WriteString[group1];
    WriteString[IF option = subtract THEN " minus "L ELSE " and "L];
    WriteString["group "L];
    WriteString[group2];
    WriteString [" ("L];
    PutLevel [level];
    WriteString["): "L];
    BinaryTree.CompareTrees[tree1, tree2, Report];
    IF aborted
      THEN {WriteCR[]; WriteLine ["Aborted"L]}
      ELSE TerminateDataSink [ctMembers];
    BinaryTree.DestroyTree[tree1, z];
    BinaryTree.DestroyTree[tree2, z];
    EXITS return => {};
    END;  -- of CompareGroups

     
  RegistryFilter: PROC [group: BodyDefs.RName, registry: STRING, include: BOOLEAN] =
    BEGIN
    tree: Tree;
    ctMembers: CARDINAL _ 0;
    
    ListUser: BinaryTree.UserProc =  -- [id: Sv]
      BEGIN
      hasReg: BOOLEAN _ HasRegistry [id, registry];
      IF hasReg # include THEN RETURN;
      aborted _ StreamDefs.userAbort;
      IF aborted THEN RETURN;
      IF ctMembers # 0 THEN WriteString[", "L];
      WriteString[id];
      ctMembers _ ctMembers + 1;
      END;  -- of ListUser
    
    IF Storage.EmptyString [registry] THEN {
      WriteLine["Empty registry name!"L]; RETURN};
    tree _ ExpandFileOrGroup[group ! BadFile => GOTO return];
    IF aborted THEN {
      BinaryTree.DestroyTree[tree, z]; WriteLine["Aborted"L]; RETURN};
    IF registry[0] = '. THEN DeleteFirstChar [registry];
      --strip off "." if present
    WriteString [IF include THEN "Intersection"L ELSE "Subtraction"L];
    WriteString[" of group "L];
    WriteString[group];
    WriteString[IF include THEN " and "L ELSE " minus "L];
    WriteString["registry "L];
    WriteString[registry];
    WriteString [" ("L];
    PutLevel [level];
    WriteString["): "L];
    BinaryTree.EnumerateTree[tree, ListUser];
    IF aborted
      THEN {WriteCR[]; WriteLine ["Aborted"L]}
      ELSE TerminateDataSink [ctMembers];
    BinaryTree.DestroyTree [tree, z];
    EXITS return => {};
    END;
  
  HasRegistry: PROC [name, registry: STRING] RETURNS [BOOLEAN] =
    BEGIN
    ssName, ssReg: String.SubStringDescriptor;
    IF name.length < registry.length THEN RETURN [FALSE];
    ssName _ [name, name.length-registry.length, registry.length];
    ssReg _ [registry, 0, registry.length];
    RETURN [String.EquivalentSubStrings [@ssName, @ssReg]];
    END;
    
  --ExpandFileOrGroup should be called only at the top level of an expansion (since a file can't be nested in either a group or another file).  It destroys the "alreadySeen" tree, built up by ExpandFile/ExpandGroup, when it is done.
  
  ExpandFileOrGroup: PROC [name: STRING] RETURNS [tree: Tree _ NIL] =
    BEGIN
    IF name[0] = '@ THEN
      BEGIN
      DeleteFirstChar [name];
      tree _ ExpandFile[name
        ! BadFile => alreadySeen _ DestroyTreeNil [alreadySeen, z]];
      END
    ELSE
      tree _ ExpandGroup[name];
    alreadySeen _ DestroyTreeNil [alreadySeen, z];
    END;
    
  BadFile: ERROR = CODE;  --raised whenever ExpandFile runs into any trouble

  ExpandFile: PROC [fileName: STRING] RETURNS [tree: Tree _ NIL] =
    BEGIN
    stream: StreamDefs.StreamHandle;
    where: {inList, endOfList, endOfInput} _ inList;
    
    getChar: PROC RETURNS [ch: CHARACTER] =
      BEGIN
      IF where = endOfList THEN
        {where _ endOfInput;
	RETURN[MailParseDefs.endOfInput]};
      ch _ stream.get[stream
        ! StreamDefs.StreamError => 
	  {where _ endOfList;
	  ch _ MailParseDefs.endOfList;
	  CONTINUE}];
      END;  -- of getChar
    
    --Errors used to abort parsing
    UnqualifiedName: ERROR [badName: STRING] = CODE;
    NestedFileIllegal: ERROR [badName: STRING] = CODE;
    UserAbort: ERROR = CODE;
  
    process: PROC [name, registry: STRING, isFile, isNested: BOOLEAN] RETURNS [write: BOOLEAN _ FALSE] =
      BEGIN
      fullName: STRING;
      fullNameLength: CARDINAL;
      IF StreamDefs.userAbort THEN ERROR UserAbort;
      IF isFile THEN ERROR NestedFileIllegal [name];
      IF registry.length = 0 THEN ERROR UnqualifiedName[name];
      fullNameLength _ name.length + 1 --"."-- + registry.length;
      fullName _ z.NEW [StringBody[fullNameLength]];
      String.AppendString[to: fullName, from: name];
      String.AppendChar[fullName, '.];
      String.AppendString[to: fullName, from: registry];
      tree _ AddNameOrGroup[fullName, tree];
      z.FREE [@fullName];
      END;  -- of process
    
    error: BOOLEAN _ FALSE;
    parse: MailParseDefs.ParseHandle;
    exD.DisplayExceptionStringOnLine["Expanding "L, 1];
    exD.AppendStringToExceptionLine[fileName, 1
      ! exD.ExceptionLineOverflow => CONTINUE];
    stream _ StreamDefs.NewByteStream [fileName, StreamDefs.Read !
      StreamDefs.FileNameError =>
        BEGIN
	WriteString ["Cannot acquire file "L];
        WriteLine [fileName];
        ERROR BadFile;
        END]; 
	
    parse _ MailParseDefs.InitializeParse [getChar];
    
    MailParseDefs.ParseNameList [parse, process !
      UnqualifiedName =>
        BEGIN
        WriteString ["Unqualified name not allowed: """];
        WriteString [badName];
        WriteString [""" in file "L];
        WriteLine[fileName];
        error _ TRUE;
        CONTINUE;
        END;
      NestedFileIllegal =>
        BEGIN
        WriteString ["Nested file not allowed: "];
        WriteString [badName];
        WriteString [""" in file "L];
        WriteLine[fileName];
        error _ TRUE;
        CONTINUE;
        END;
      MailParseDefs.ParseError =>
        BEGIN
        WriteString ["Syntax error in file "L];
        WriteLine[fileName];
        error _ TRUE;
        CONTINUE;
        END;
      UserAbort => {aborted _ TRUE; CONTINUE}];
    MailParseDefs.FinalizeParse [parse];
    stream.destroy [stream];
    IF error THEN {BinaryTree.DestroyTree[tree, z]; ERROR BadFile};
    END;  -- of ExpandFile
    
  ExpandGroup: PROC [groupName: BodyDefs.RName] RETURNS [tree: Tree _ NIL] =
    BEGIN
    members: NameInfoDefs.RListHandle;
    enumproc: PROC [name: BodyDefs.RName] RETURNS [done: BOOLEAN _ FALSE] =
      BEGIN
      IF StreamDefs.userAbort THEN {aborted _ TRUE; RETURN[done: TRUE]};
      tree _ AddNameOrGroup[name, tree];
      IF aborted THEN RETURN[done: TRUE];  --return from all recursions
      END;  -- of enumproc

    exD.DisplayExceptionStringOnLine["Expanding "L, 1];
    exD.AppendStringToExceptionLine[groupName, 1
      ! exD.ExceptionLineOverflow => CONTINUE];
    members _ GetMembers[groupName ! NotAGroup => GOTO return];
    alreadySeen _ BinaryTree.Enter [alreadySeen, groupName, z];
    NameInfoDefs.Enumerate[members, enumproc];
    NameInfoDefs.Close[members];
    EXITS return => {};
    END;

  AddNameOrGroup: PROC [name: STRING, tree: Tree] RETURNS [mergedTree: Tree] =
    BEGIN
    IF ShouldExpand [name] THEN
      BEGIN
      newTree: Tree;
      IF BinaryTree.Present [alreadySeen, name] THEN RETURN [tree];
      newTree _ ExpandGroup[name];
      mergedTree _ BinaryTree.MergeTrees[tree, newTree, z];
      --consumes "tree" and "newTree"
      END
    ELSE mergedTree _ BinaryTree.Enter[tree, name, z];
    END;  -- of AddNameOrGroup

  NotAGroup: ERROR = CODE;

  GetMembers: PROCEDURE [
    name: BodyDefs.RName, oldStamp: BodyDefs.Timestamp _ BodyDefs.oldestTime]
    RETURNS [members: NameInfoDefs.RListHandle] =
    BEGIN
    info: NameInfoDefs.MemberInfo _ NameInfoDefs.GetMembers[name, oldStamp];
    WITH i: info SELECT FROM
      group => RETURN[i.members];
      ENDCASE => ERROR NotAGroup;
    END;

  GetRName: PROC [prompt, rName: STRING, individualOk: BOOLEAN] RETURNS [punt, individual: BOOLEAN] =
    BEGIN
    type: NameInfoDefs.NameType;
    WriteString [prompt];
    IODefs.ReadID [rName ! IODefs.LineOverflow, IODefs.Rubout =>
      {WriteLine [" XXX"L]; GOTO Leave;}];
    IF rName.length = 0 THEN {WriteLine [" XXX"L]; GOTO Leave};
    IF rName[0] = '@ THEN RETURN[FALSE, FALSE];  --file name
    type _ NameInfoDefs.CheckStamp [rName];
    SELECT type FROM
      individual =>
        IF NOT individualOk
          THEN {WriteLine ["	not a valid group"L]; GOTO Leave;}
          ELSE individual _ TRUE;
      group => individual _ FALSE;
      ENDCASE =>
        {WriteLine ["	not a valid individual or group"L]; GOTO Leave;};
    punt _ FALSE;
    EXITS Leave => punt _ TRUE;
    END; -- of GetRName

  ShouldExpand: PROC [name: BodyDefs.RName] RETURNS [yes: BOOLEAN] =
    BEGIN
    SELECT level FROM
      direct => RETURN [FALSE];
      upArrow => RETURN [HasUpArrow [name]];
      ENDCASE => RETURN [NameInfoDefs.CheckStamp [name] = group];
    END;  -- of ShouldExpand
    
  HasUpArrow: PROC [name: BodyDefs.RName]
    RETURNS [yes: BOOLEAN _ FALSE] =
    BEGIN
    FOR i: CARDINAL IN [0..name.length) DO
      SELECT name[i] FROM '^ => RETURN[TRUE]; '. => RETURN[FALSE]; ENDCASE;
      ENDLOOP;
    END;

  DeleteFirstChar: PROC [s: STRING] =
    BEGIN
    ss: String.SubStringDescriptor _ [s, 0, 1];
    String.DeleteSubString[@ss]
    END;
    
  IsMemberCommand: PROC =
    BEGIN
    name: STRING _ [maxRNameLength];
    group: STRING _ [maxRNameLength];
    pass: BOOLEAN;
    [pass,] _ GetRName["Membership check of: "L, name, TRUE];
    IF pass THEN RETURN;
    [pass,] _ GetRName[" in group: "L, group, FALSE];
    IF pass THEN RETURN;
    WriteCR[];
    IF name[0] = '@ OR group[0] = '@ THEN
      {WriteString ["Membership check not implemented for file name arguments"L]; RETURN};
    WriteString[name];
    WriteString[" is"L];
    IF NameInfoDefs.IsInList [group, name, level, self, members] # yes
      THEN WriteString["n't"L];
    WriteString[" in group "L];
    WriteString[group];
    WriteString[" ("L];
    PutLevel [level];
    WriteLine [")"L];
    NameInfoSpecialDefs.CleanUp[];
    END;  -- of IsMemberCommand

  ExpandCommand: PROC =
    BEGIN
    group: STRING _ [maxRNameLength];
    ctMembers: CARDINAL _ 0;
    pass: BOOLEAN;
    tree: Tree;

    ListUser: BinaryTree.UserProc =  -- [id: Sv]
      BEGIN
      aborted _ StreamDefs.userAbort;
      IF aborted THEN RETURN;
      IF ctMembers # 0 THEN WriteString[", "L];
      WriteString[id];
      ctMembers _ ctMembers + 1;
      END;  -- of ListUser

    [pass, ] _ GetRName ["Expand group: "L, group, FALSE];
    IF pass THEN RETURN;
    WriteCR[];
    tree _ ExpandFileOrGroup[group ! BadFile => GOTO return];
    IF aborted THEN {
      BinaryTree.DestroyTree[tree, z]; WriteLine["Aborted"L]; RETURN};
    IF tree = NIL THEN {WriteLine [" is empty"L]; RETURN;};
    WriteString["Expansion of group "L];
    WriteString[group];
    WriteString [" ("L];
    PutLevel [level];
    WriteString["): "L];
    BinaryTree.EnumerateTree[tree, ListUser];
    IF aborted
      THEN {WriteCR[]; WriteLine ["Aborted"L]}
      ELSE TerminateDataSink [ctMembers];
    BinaryTree.DestroyTree[tree, z];
    EXITS return => {};
    END;  -- of ExpandCommand

  DoubleGroupCommand: PROC [command: Command] =
    BEGIN
    group1: STRING _ [maxRNameLength];
    group2: STRING _ [maxRNameLength];
    pass: BOOLEAN;
    what: STRING _ SELECT command FROM
      subtract => "Subtracting group: "L,
      union => "Uniting groups: "L,
      ENDCASE => "Intersecting groups: "L;
    [pass, ] _ GetRName [what, group1, FALSE];
    IF pass THEN RETURN;
    what _ IF command = subtract THEN " minus group: "L ELSE " and: "L;
    [pass, ] _ GetRName [what, group2, FALSE];
    IF pass THEN RETURN;
    WriteCR[];
    CompareGroups[group1, group2, command];
    END;  -- of DoubleGroupCommand

  RegistryFilterCommand: PROC = 
    BEGIN
    include: BOOLEAN _ TRUE;
    group: STRING _ [maxRNameLength];
    reg: STRING _ [maxRNameLength];
    pass: BOOLEAN;
    [pass, ] _ GetRName ["Registry filter of group: "L, group, FALSE];
    IF pass THEN RETURN;
    WriteString [" against registry: "L];
    IODefs.ReadID[reg ! IODefs.LineOverflow, IODefs.Rubout =>
      {WriteLine [" XXX"L]; GOTO out}];
    IF reg.length = 0 THEN {WriteLine [" XXX"L]; GOTO out};
    IF reg[0] = '~ THEN 
       {include _ FALSE;
       DeleteFirstChar [reg];
       IF reg.length = 0 THEN {WriteLine [" XXX"L]; GOTO out}};
    WriteCR[];
    RegistryFilter [group, reg, include];
    EXITS out => {};
    END;

  ChangeLevel: PROC = 
    BEGIN
    char: CHARACTER;
    WriteString ["Change membership level (Closure, Direct, UpArrow): "L];
    PutLevel [level];
    WriteString [" _ "L];
    SELECT (char _ String.LowerCase [IODefs.ReadChar []]) FROM
      'c => level _ closure;
      'd => level _ direct;
      'u => level _ upArrow;
      ENDCASE => {WriteLine [" ??? "L]; RETURN};
    PutLevel [level];
    WriteCR[];
    END;  -- of ChangeLevel
    
Salutations: PROC [version: STRING] =
BEGIN OPEN Time;
time: STRING _ [20];
WriteCR[];
WriteString [version];
WriteString [", of "L];
Append [time, Unpack [Runtime.GetBcdTime []]];
time.length _ time.length - 3;		-- remove the seconds
WriteLine [time];
time.length _ 0;
Append [time, Unpack []];
WriteLine [time];
WriteCR[];
LaurelExecDefs.MakeMenuCommandCallable[user];
LaurelExecDefs.MakeMenuCommandCallable[newMail];
LaurelExecDefs.MakeMenuCommandCallable[mailFile];
LaurelExecDefs.MakeMenuCommandCallable[display];
LaurelExecDefs.MakeMenuCommandCallable[delete];
LaurelExecDefs.MakeMenuCommandCallable[undelete];
LaurelExecDefs.MakeMenuCommandCallable[moveTo];
LaurelExecDefs.MakeMenuCommandCallable[copy];
END;		-- of proc Salutations

--TTY stuff

Confirm: PROC [prompt: STRING, outputCR: BOOLEAN] RETURNS [confirmed: BOOLEAN] =
BEGIN
DO
	WriteString [prompt];
	WriteString [" [confirm] "L];
	SELECT String.LowerCase [IODefs.ReadChar []] FROM
		'y, CR, ESC, SP => confirmed _ TRUE;
		'n, DEL => confirmed _ FALSE;
		ENDCASE =>
			BEGIN
			WriteLine ["Yes (or CR) or No (or DEL)?"L];
			LOOP;
			END;
	EXIT;
ENDLOOP;
WriteString [IF confirmed THEN "Yes"L ELSE "No"L];
IF outputCR THEN WriteCR[];
END;		-- of proc Confirm

MainLoop: PROC = 
BEGIN
char: CHARACTER;
Version: STRING = "Groups 6.1"L;
Salutations [Version];
DO
	aborted _ StreamDefs.userAbort _ FALSE;
	WriteString ["=> "L];
	SELECT (char _ String.LowerCase [IODefs.ReadChar []]) FROM
		'e => ExpandCommand [];
		'i => DoubleGroupCommand [intersect];
		'l => ChangeLevel[];
		'm => IsMemberCommand[];
		'q => IF Confirm ["Quit"L, TRUE] THEN EXIT;
		'r => RegistryFilterCommand[];
		's => DoubleGroupCommand [subtract];
		'u => DoubleGroupCommand [union];
		ENDCASE =>
			BEGIN
			WriteLine ["? - Commands:
	E (Expansion),
	I (Intersection),
	L (change expansion Level)
	M (Membership check),
	Q (Quit),
	R (Registry filter),
	S (Subtraction), or
	U (Union)"L];
			LOOP;
			END;
exD.ClearExceptionsRegion[];
ENDLOOP;
WriteCR[];
[] _ Storage.Prune [];
END;		-- of proc MainLoop

-- GroupsImpl's mainline code:
MainLoop[];
END.