(*---------------------------------------------------------------------------
  :Program.     ProgInfo.mod
  :Author.      Fridtjof Siebert.
  :Address.     Nobileweg 67, D-7000-Stuttgart-40
  :Phone.       (0)711/822509
  :ShortCut.    [fbs]
  :Version.     0.9
  :Date.        26-Oct-88, 02:23:06
  :CopyRight.   PD
  :Language.    MODULA-II
  :Translator.  M2Amiga.
  :Contents.    Program to get information on Author, Version etc. from
  :Contents.    Sourcecodes.
  :Remark.      Eats 48 Bytes each time you start it from WB. Don't know why!
  :Usage.       ProgInfo [File|Drawer|?] [p] [s]
  :Usage.       p lets ProgInfo forget Information on Procedures
  :Usage.       s lets ProgInfo sort the Programs alphabetically.
---------------------------------------------------------------------------*)

MODULE ProgInfo;

(*------  IMPORTs:  ------*)

FROM SYSTEM    IMPORT ADR, ADDRESS;

FROM Arts      IMPORT TermProcedure, detectCtrlC, Terminate;

FROM Arguments IMPORT GetArg, NumArgs, GetLock;

FROM Dos       IMPORT Open, Close, FileHandlePtr, oldFile, newFile, Read,
                      FileLockPtr, sharedLock, IoErr, CurrentDir,
                      noMoreEntries, FileInfoBlock, Examine, Lock, UnLock,
                      ExNext, FileInfoBlockPtr;

FROM InOut     IMPORT WriteString, WriteLn, Write, WriteInt;

FROM Strings   IMPORT Compare, Length, Copy, Insert, Occurs, first, last;

FROM Heap      IMPORT Allocate, AllocMem, Deallocate;

(*------  CONSTs:  ------*)

CONST
  tab = CHAR(9);

(*------  TYPEs:  ------*)

TYPE
  String = ARRAY[0..119] OF CHAR;         (* used for all kinds of strings *)
  StringPtr = POINTER TO String;

  LinkedStringPtr = POINTER TO LinkedString;
  LinkedString = RECORD          (* used to store more than 1 line of text *)
    Next: LinkedStringPtr;
    string: String;
  END;

  ProcMod = (OK, Proc, Mod, EOF);                 (* What did GetID find ? *)

(*------  Information for Procedures:  ------*)

  ProcIDs =     (Input,      Output,     Result,     Semantic,
                 Semantik,   Note,       UpDate);        (* Procedures IDs *)

  LinkedProcPtr = POINTER TO LinkedProc;
  LinkedProc = RECORD
    Next:     LinkedProcPtr;               (* for linking them             *)
    Name:     LinkedStringPtr;             (* Procedures Name & Parameters *)
    IDs: ARRAY ProcIDs OF LinkedStringPtr; (* Proc ID-Strings              *)
  END;

(*------  Information on Program:  ------*)

  StandardIDs = (Program,    Author,     Address,    Phone,
                 ShortCut,   Support,    Version,    Date,
                 Copyright,  Language,   Translator, Update,
                 History,    ModHistory, Imports,    Contents,
                 Remark,     Usage);                          (* Prg's IDs *)

  IDPtr = POINTER TO ID;
  ID = RECORD
    Next: IDPtr;                              (* for linking them          *)
    FileName: String;                         (* Prg's Name                *)
    Standard: ARRAY StandardIDs OF LinkedStringPtr; (* IDs                 *)
    Procs: LinkedProcPtr;                     (* Information on Procedures *)
  END;

(*------  Variables:  ------*)

VAR
  Source, Arg: String;            (* Source File's Name and Prg's Argument *)
  Procedures: BOOLEAN;        (* Shall I display Procedure's Information ? *)
  Sort: BOOLEAN;                  (* Shall I sort the Programs ?           *)
  Count: INTEGER;                 (* Count Arguments                       *)
  len: INTEGER;                   (* Arguments Length                      *)
  InH: FileHandlePtr;             (* File to load Sourcecodes              *)
  DataLen, ActData: LONGINT;      (* Pointer in Read-Buffer                *)
  IDStrings: ARRAY StandardIDs OF String; (* Identifiers                   *)
  ProcIDStrings: ARRAY ProcIDs OF String;
  FileIDs: IDPtr;                 (* Identifiers found in active File      *)
  Buffer: POINTER TO ARRAY[0..511] OF CHAR; (* Buffer for reading Bytes    *)
  LockPtr: FileLockPtr;           (* Source's Lock                         *)
  FileInfo: FileInfoBlock;        (* Source's InfoBlock                    *)
  OldLock: FileLockPtr;           (* to go back to Current Directory       *)


(*------  Test if pointer = NIL and quit if so:  ------*)

PROCEDURE MemQuit(x: ADDRESS);

BEGIN
  IF x=NIL THEN
    WriteString("System ran out of memory !!!"); WriteLn;
    Terminate(0);
  END;
END MemQuit;

(*------  Load one Byte from InH:  ------*)


PROCEDURE GetByte(): CHAR;

BEGIN
  INC(ActData);
  IF ActData>=DataLen THEN                  (* Buffer empty? *)
    DataLen := Read(InH, Buffer, 512);
    ActData := 0;
  END;
  RETURN Buffer^[ActData];
END GetByte;


(*----------------------  Find next Identifier:  --------------------------*)


PROCEDURE GetID(VAR id: String): ProcMod;
(* id will contain the next ID's Characters. The Result will be OK, if an  *)
(* identifier found, Proc if `PROCEDURE' found, Mod if `MODULE' found and  *)
(* EOF at End of File.                                                     *)

VAR
  p: INTEGER;                 (* position within id *)
  PString, MString: String;   (* `PROCEDURE' & `MODULE' *)

BEGIN
  PString := "PROCEDURE";
  MString := "MODULE";
  REPEAT
    CASE GetByte() OF
    ":":                       (* ID starts: *)
      p := -1;
      REPEAT
        INC(p);
        id[p] := GetByte();
        IF id[p]="." THEN       (* Get Chars until `.' *)
          id[p] := CHAR(0);
          RETURN OK;
        END;
      UNTIL (((id[p]<"a") OR (id[p]>"z")) AND ((id[p]<"A") OR (id[p]>"Z")))
            OR (DataLen=0); |
    "P":
      p := 0;
      REPEAT
        IF p=8 THEN RETURN Proc END;    (* `PROCEDURE' fount *)
        INC(p);
      UNTIL (p=9) OR (PString[p]#GetByte()) OR (DataLen=0); |
    "M":
      p := 0;
      REPEAT
        IF p=5 THEN RETURN Mod END;    (* `MODULE' found *)
        INC(p);
      UNTIL (p=6) OR (MString[p]#GetByte()) OR (DataLen=0); |
    ELSE
    END;
  UNTIL DataLen=NIL;    (* until no more Data ? *)
  RETURN EOF;
END GetID;


(*------------------  Add String from InH to Linked List:  ----------------*)


PROCEDURE AddString(VAR String: LinkedStringPtr);

VAR
  Str: LinkedStringPtr;
  pos: CARDINAL;

BEGIN
  IF String=NIL THEN            (* New String is first on: *)
    Allocate(String,SIZE(LinkedString)); MemQuit(String);
    Str := String;
  ELSE                          (* not first: find last: *)
    Str := String;
    WHILE Str^.Next#NIL DO
      Str := Str^.Next;
    END;
    Allocate(Str^.Next,SIZE(LinkedString));
    Str := Str^.Next;
    MemQuit(Str);
  END;
  WITH Str^ DO
    pos := 0;
    REPEAT
      string[pos] := GetByte();   (* Read Spaces and Tabs before text *)
    UNTIL ((string[pos]#" ") AND (string[pos]#tab)) OR (DataLen=0);
    (* get string until Controlcode (usually LF): *)
    WHILE ((string[pos]>=" ") OR (string[pos]=tab)) AND (DataLen#0) DO
      INC(pos);
      string[pos] := GetByte();         (* Read Character *)
      IF (string[pos]=")") AND (string[pos-1]="*") THEN   (* Until `*'`)' *)
        DEC(pos);
        string[pos] := CHAR(0);
      END;
    END;
    LOOP  (* remove spaces add the end to avoid unneeded LF's: *)
      IF pos=0 THEN EXIT END;
      IF string[pos-1]#" " THEN EXIT END;
      DEC(pos);
    END;
    string[pos] := CHAR(0);
  END;
END AddString;


(*--------------------  Free Memory of Linked Strings:  -------------------*)


PROCEDURE FreeStrings(Str: LinkedStringPtr);

BEGIN
  IF Str#NIL THEN
    FreeStrings(Str^.Next);
    Deallocate(Str);          (* rekursiv! *)
  END;
END FreeStrings;


(*--------------  Get Information for Procedures from InH:  ---------------*)


PROCEDURE GetProc(): LinkedProcPtr;
(* creates a LinkedProcPtr form InH *)

VAR
  NewProc: LinkedProcPtr;
  Str: LinkedStringPtr;
  pos: INTEGER;
  Klammerauf: INTEGER;
  id: StringPtr;
  IDCount: ProcIDs;
  IDsfound: BOOLEAN;

BEGIN
  Allocate(id,SIZE(String)); MemQuit(id);
  Allocate(NewProc,SIZE(LinkedProc)); MemQuit(NewProc);
  WITH NewProc^ DO
    Allocate(Name,SIZE(LinkedString)); MemQuit(Name);
    Str := Name;
    pos := 9;
    Str^.string := "PROCEDURE";
    Klammerauf := 0;
    IDsfound := FALSE;
    LOOP
      Str^.string[pos] := GetByte();
      IF DataLen=0 THEN
        Str^.string[pos] := CHAR(0);
        EXIT;
      END;
      CASE Str^.string[pos] OF
      CHAR(0)..CHAR(8),CHAR(10)..CHAR(31):
        Str^.string[pos] := CHAR(0);
        Allocate(Str^.Next,SIZE(LinkedString));
        Str := Str^.Next;
        MemQuit(Str);
        pos := -1; |
      "(": INC(Klammerauf); |
      ")": DEC(Klammerauf); |
      ";": IF Klammerauf=0 THEN EXIT END; |
      ELSE
      END;
      INC(pos);
      IF pos>79 THEN
        Allocate(Str^.Next,SIZE(LinkedString));
        Str := Str^.Next;
        MemQuit(Str);
        pos := 0;
      END;
    END;
    INC(pos);
    IF pos<80 THEN Str^.string[pos] := CHAR(0) END;
    LOOP
      CASE GetID(id^) OF
      OK:
        FOR IDCount := MIN(ProcIDs) TO MAX(ProcIDs) DO
          IF Compare(id^,first,Length(id^),ProcIDStrings[IDCount],FALSE)=0 THEN
            AddString(IDs[IDCount]);
            IDsfound := TRUE;
          END;
        END; |
      Proc:
        IF IDsfound THEN
          NewProc^.Next := GetProc();
        ELSE
          FreeStrings(NewProc^.Name);
          Deallocate(NewProc);
          NewProc := GetProc();
        END;
        RETURN NewProc;|
      Mod: |
      EOF: EXIT |
      END;
    END;
  END;   (* WITH NewProc^ DO *)
  IF IDsfound THEN
    RETURN NewProc;
  ELSE
    FreeStrings(NewProc^.Name);
    Deallocate(NewProc);
    RETURN NIL;
  END;
END GetProc;


(*-------------------------  Get IDs from InH:  ---------------------------*)


PROCEDURE SearchIDs(): IDPtr;

VAR
  NewID: IDPtr;
  id: String;
  IDCount: StandardIDs;
  IDsfound: BOOLEAN;
  Head: BOOLEAN;
  proc,NewProc: LinkedProcPtr;

BEGIN
  IDsfound := FALSE;
  Head := TRUE;
  Allocate(NewID,SIZE(ID)); MemQuit(NewID);
  WITH NewID^ DO
    LOOP
      CASE GetID(id) OF
      OK:
        IF Head THEN
          FOR IDCount := MIN(StandardIDs) TO MAX(StandardIDs) DO
            IF Compare(id,first,Length(id),IDStrings[IDCount],FALSE)=0 THEN
              AddString(Standard[IDCount]);
              IDsfound := TRUE;
            END;
          END;
        END; |
      Proc:
        IF NOT(Head) AND Procedures THEN
          NewProc := GetProc();
          IF NewProc#NIL THEN
            IF Procs=NIL THEN
              Procs := NewProc;
            ELSE
              proc := Procs;
              WHILE proc^.Next#NIL DO proc := proc^.Next END;
              proc^.Next := NewProc;
            END;
          END;
        END; |
      Mod: Head := FALSE; |
      EOF: EXIT |
      END;
    END;
  END;
  IF IDsfound THEN
    RETURN NewID;
  ELSE
    Deallocate(NewID);
    RETURN NIL;
  END;
END SearchIDs;


(*-----------------  Print out Programs Information:  ---------------------*)


PROCEDURE PrintInfo(id: IDPtr);

VAR
  IDCount: StandardIDs;
  ProcIDCnt: ProcIDs;
  Str: LinkedStringPtr;
  Proc: LinkedProcPtr;
  Text: String;

BEGIN
  WriteLn;
  WriteString(id^.FileName); WriteString(":"); WriteLn; WriteLn;
  FOR IDCount := MIN(StandardIDs) TO MAX(StandardIDs) DO
    Str := id^.Standard[IDCount];
    IF Str#NIL THEN
      Copy(Text,"            ",first,12-Length(IDStrings[IDCount]));
      Insert(Text,2,IDStrings[IDCount]);
      WriteString(Text); WriteString(": ");
      WriteString(Str^.string); WriteLn;
      WHILE Str^.Next#NIL DO
        Str := Str^.Next;
        WriteString("              "); WriteString(Str^.string); WriteLn;
      END;
    END;
  END;
  Proc := id^.Procs;
  WHILE Proc#NIL DO
    WriteLn;
    WITH Proc^ DO
      Str := Name;
      WHILE Str#NIL DO
        WriteString("  "); WriteString(Str^.string); WriteLn;
        Str := Str^.Next;
      END;
      WriteLn;
      FOR ProcIDCnt := MIN(ProcIDs) TO MAX(ProcIDs) DO
        Str := IDs[ProcIDCnt];
        IF Str#NIL THEN
          Copy(Text,"              ",first,12-Length(ProcIDStrings[ProcIDCnt]));
          Insert(Text,4,ProcIDStrings[ProcIDCnt]);
          WriteString(Text); WriteString(": ");
          WriteString(Str^.string); WriteLn;
          WHILE Str^.Next#NIL DO
            Str := Str^.Next;
            WriteString("              "); WriteString(Str^.string); WriteLn;
          END;
        END;
      END;
    END;
    Proc := Proc^.Next;
  END;
END PrintInfo;


(*------------------  Open and get ID's from a File:  ---------------------*)


PROCEDURE ProgInfoFile(Name, Path: ARRAY OF CHAR):IDPtr;

VAR
  IDs: IDPtr;

BEGIN
  InH := Open(ADR(Name),oldFile);
  IF InH#NIL THEN
    IDs := SearchIDs();
    IF IDs#NIL THEN
      Copy(IDs^.FileName,Name,first,HIGH(Name));
      Insert(IDs^.FileName,first,Path);
    END;
    Close(InH);
    InH := NIL;
    RETURN IDs;
  END;
  RETURN NIL;
END ProgInfoFile;


(*---------------------  Get ID's from a Directory:  ----------------------*)


PROCEDURE ProgInfoDrawer(lock: FileLockPtr; VAR Path: String):IDPtr;

VAR
  FileInfo: FileInfoBlockPtr;
  IDs, Act, New: IDPtr;
  oldlock, newlock: FileLockPtr;
  NewPath: StringPtr;

BEGIN
  Allocate(NewPath,SIZE(String)); MemQuit(NewPath);
  IDs := NIL;
  Allocate(FileInfo,SIZE(FileInfoBlock)); MemQuit(FileInfo);
  IF FileInfo#NIL THEN
    IF Examine(lock,FileInfo)#0 THEN
      WHILE ExNext(lock,FileInfo)#0 DO
        WITH FileInfo^ DO
          New := NIL;
          IF dirEntryType<0 THEN
            IF Occurs(fileName,first,".info",FALSE)=last THEN
              IF (Occurs(fileName,first,".mod",FALSE)#last) OR
                 (Occurs(fileName,first,".def",FALSE)#last) OR
                 (Occurs(fileName,first,".asm",FALSE)#last) THEN
                New := ProgInfoFile(fileName,Path);
              END;
            END;
          ELSE
            newlock := Lock(ADR(fileName),sharedLock);
            IF newlock#NIL THEN
              oldlock := CurrentDir(newlock);
              NewPath^ := Path;
              Insert(NewPath^,last,fileName);
              Insert(NewPath^,last,"/");
              New := ProgInfoDrawer(newlock,NewPath^);
              oldlock := CurrentDir(oldlock);
              UnLock(newlock);
            END;
          END;
          IF New#NIL THEN
            IF Sort THEN
              IF IDs=NIL THEN
                IDs := New; Act := New;
              ELSE
                Act^.Next := New;
              END;
              WHILE Act^.Next#NIL DO
                Act := Act^.Next;
              END;
            ELSE
              PrintInfo(New);
            END;
          END;
        END;   (* WITH FileInfo^ DO *)
      END;   (* WHILE ExNext(lock,FileInfo)#0 DO *)
    END;   (* IF Examine(lock,FileInfo)#0 THEN *)
    Deallocate(FileInfo);
  END;   (* IF FileInfo#NIL THEN *)
  oldlock := CurrentDir(oldlock);
  RETURN IDs;
END ProgInfoDrawer;


(*----------------------  Programmnamen Sortieren:  -----------------------*)


PROCEDURE SortIDs(VAR id: IDPtr);
(* A simple insertion sort: *)

  PROCEDURE CompStr(VAR Str1,Str2: ARRAY OF CHAR): BOOLEAN;
  (* Returns TRUE if Str1>=Str2 *)
  VAR pos: INTEGER;

  BEGIN
    pos := 0;
    WHILE (pos<HIGH(Str1)) AND (pos<HIGH(Str2)) DO
      IF Str1[pos]<Str2[pos] THEN RETURN FALSE END;
      IF Str1[pos]>Str2[pos] THEN RETURN TRUE END;
      INC(pos);
    END;
    RETURN HIGH(Str1)>=HIGH(Str2);
  END CompStr;

VAR
  NotSorted: IDPtr;
  Active,Last: IDPtr;
  new: IDPtr;
  DefName: String;

BEGIN
  NotSorted := id^.Next;
  id^.Next := NIL;
  WHILE NotSorted#NIL DO
    new := NotSorted;
    Active := id;
    Last := NIL;
    LOOP
      IF CompStr(Active^.FileName,new^.FileName) THEN EXIT END;
      Last := Active;
      Active := Active^.Next;
      IF Active=NIL THEN EXIT END;
    END;
    NotSorted := NotSorted^.Next;
    IF Last=NIL THEN
      id := new;
    ELSE
      Last^.Next := new;
    END;
    new^.Next := Active;
  END;
(* Remove xx.mod's if there's an xx.def *)
  NotSorted := id;
  Last := NIL;
  WHILE NotSorted#NIL DO
    DefName := NotSorted^.FileName;
    IF Occurs(DefName,first,".mod",FALSE)#last THEN
      DefName[Length(DefName)-3] := CHAR(0);
      Insert(DefName,last,"def");
      Active := id;
      LOOP
        IF Active=NIL THEN EXIT END;
        WITH Active^ DO
          IF Compare(FileName,first,Length(FileName),DefName,FALSE)=0 THEN
            IF Last=NIL THEN
              id := id^.Next;
            ELSE
              NotSorted := NotSorted^.Next;
              Last^.Next := NotSorted;
            END;
            EXIT;
          END;
          Active := Next;
        END;
      END;
    END;
    Last := NotSorted;
    IF NotSorted#NIL THEN
      NotSorted := NotSorted^.Next;
    END;
  END;
END SortIDs;


(*------  CleanUp:  ------*)

PROCEDURE CleanUp();

BEGIN
  IF InH#NIL THEN Close(InH) END;
  IF OldLock#NIL THEN OldLock := CurrentDir(OldLock) END;
  IF (LockPtr#NIL) AND (GetLock(1)=NIL) THEN UnLock(LockPtr) END;
END CleanUp;


(*--------------------------------  MAIN:  --------------------------------*)

BEGIN

(*------  Initialization:  ------*)

  Procedures := TRUE;
  Sort := FALSE;
  InH := NIL;
  ActData := 0; DataLen := 0;
  OldLock := NIL;
  LockPtr := NIL;
  detectCtrlC := FALSE;                     (* avoid to lock files forever *)
  TermProcedure(CleanUp);
  AllocMem(Buffer,512,TRUE); MemQuit(Buffer);

(*------  Initialize ID-Strings:  ------*)

  IDStrings[Program   ] := "Program";
  IDStrings[Author    ] := "Author";
  IDStrings[Address   ] := "Address";
  IDStrings[Phone     ] := "Phone";
  IDStrings[ShortCut  ] := "ShortCut";
  IDStrings[Support   ] := "Support";    (***)
  IDStrings[Version   ] := "Version";
  IDStrings[Date      ] := "Date";
  IDStrings[Copyright ] := "Copyright";
  IDStrings[Language  ] := "Language";
  IDStrings[Translator] := "Translator";
  IDStrings[Imports   ] := "Imports";
  IDStrings[Update    ] := "Update";
  IDStrings[ModHistory] := "ModHistory"; (***)
  IDStrings[History   ] := "History";    (***)
  IDStrings[Contents  ] := "Contents";
  IDStrings[Remark    ] := "Remark";
  IDStrings[Usage     ] := "Usage";      (***)

  ProcIDStrings[Input   ] := "Input";
  ProcIDStrings[Result  ] := "Result";
  ProcIDStrings[Semantic] := "Semantic";
  ProcIDStrings[Semantik] := "Semantik"; (***)
  ProcIDStrings[Note    ] := "Note";
  ProcIDStrings[UpDate  ] := "Update";

(*------  Get Arguments:  ------*)

  Count := 0;
  Source[0] := "?";

  WHILE Count<NumArgs() DO
    INC(Count);
    GetArg(Count,Arg,len);
    IF Compare(Arg,first,len,"P",FALSE)=0 THEN
      Procedures := FALSE;
    ELSIF Compare(Arg,first,len,"S",FALSE)=0 THEN
      Sort := TRUE;
    ELSIF Count=1 THEN
      Source := Arg;
      IF Length(Source)=0 THEN
        LockPtr := GetLock(1);
      END;
    ELSE
      Source := "?";
    END;
  END;

(*------  Usage:  ------*)

  IF Source[0]="?" THEN
    WriteString("ProgInfo --- © 1988 AMOK Stuttgart"); WriteLn;
    WriteString("Usage: ProgInfo [File|Drawer|?] [p] [q]"); WriteLn;
    WriteString("  p = Don't print information for procedures."); WriteLn;
    WriteString("  s = Sort programs alphabetically."); WriteLn;
    Terminate(0);
  END;

(*------  Test on File or Drawer:  ------*)

  IF LockPtr=NIL THEN
    LockPtr := Lock(ADR(Source),sharedLock);
    IF LockPtr=NIL THEN
      WriteString(Source); WriteString(" not found"); WriteLn;
      Terminate(0);
    END;
  END;
  IF Examine(LockPtr,ADR(FileInfo))=0 THEN
    WriteString("IO-Fehler!"); WriteLn;
    Terminate(0);
  END;

(*------  Search in Drawer:  ------*)

  IF FileInfo.dirEntryType>=0 THEN

    OldLock := CurrentDir(LockPtr);
    IF Length(Source)>0 THEN
      CASE Source[Length(Source)-1] OF
      "/",":": |
      "?": Source := "";
      ELSE
        Insert(Source,last,"/");
      END;
    END;
    FileIDs := ProgInfoDrawer(LockPtr,Source);

(*------  Search in File:  ------*)

  ELSE

    FileIDs := ProgInfoFile(Source,"");

  END;

(*------  Sortieren:  ------*)

  IF Sort AND (FileIDs#NIL) THEN
    SortIDs(FileIDs);
  END;

(*------  Print Data:  ------*)

  WHILE FileIDs#NIL DO
    PrintInfo(FileIDs);
    FileIDs := FileIDs^.Next;
  END;

  WriteLn;

END ProgInfo.