(* ------------------------------------------------------------------------
  :Program.       PCD
  :Contents.      CD-Befehl, der sich das alte Verzeichnis merkt
  :Author.        André Schenk [as]
  :Address.       Snail-Mail:              E-Mail:
  :Address.       Tapachstraße 97 C        2:2407/106.42@fidonet
  :Address.       D-70437 Stuttgart        andre@melior.stgt.sub.org
  :History.       v1.0 [as]  18-Jan-94     erste öffentliche Version
  :History.       v1.0 [kai] 22-Jan-94     Dos.SetCurrentDirName()
  :Language.      Oberon
  :Translator.    AMIGA OBERON v3.00d
------------------------------------------------------------------------ *)
MODULE PCD;

IMPORT
  a := ASCII,
  c := Conversions,
  d := Dos,
  e := Exec,
  s := Strings,
  S := SYSTEM;

CONST
  template = "DIR/F\o$VER: PCD 1.0 (18.01.94)";
  pattern  = "T:from";
  memerror = "Speichermangel";

TYPE
  Arguments = STRUCT (dummy : d.ArgsStruct)
    dir : e.STRPTR
  END;

VAR
  arg        : UNTRACED POINTER TO Arguments;
  RD         : d.RDArgsPtr;
  name       : ARRAY 11 OF CHAR;
  file       : d.FileHandlePtr;
  currentdir : e.STRPTR;

PROCEDURE Error (text : ARRAY OF CHAR);
BEGIN
  d.PrintF ("PCD: %s\n", S.ADR (text));
  HALT (20)
END Error;

PROCEDURE Exists (name : ARRAY OF CHAR) : BOOLEAN;
VAR
  lock : d.FileLockPtr;
BEGIN
  lock := d.Lock (name, d.sharedLock);
  IF lock # NIL THEN
    d.UnLock (lock);
    RETURN TRUE
  END;
  RETURN FALSE
END Exists;

PROCEDURE SearchName (VAR name : ARRAY OF CHAR; new : BOOLEAN) : BOOLEAN;
(* sucht in T: nach Dateien des Typs from* und liefert *)
(* new = TRUE  : den ersten  benutzbaren Namen         *)
(* new = FALSE : den letzten benutzten   Namen         *)
(* zurück                                              *)
VAR
  proc   : d.ProcessPtr;
  number : INTEGER;
  numstr : ARRAY 5 OF CHAR;

  PROCEDURE BuildName;
  BEGIN
    name := pattern;
    s.AppendChar (name, ".");
    c.IntToStringLeft (proc^.taskNum, numstr);
    s.Append (name, numstr);
    s.AppendChar (name, ".");
    c.IntToStringLeft (number, numstr);
    s.Append (name, numstr)
  END BuildName;

BEGIN
  proc := e.FindTask (NIL);
  IF proc = NIL THEN RETURN FALSE END;
  number := -1;
  REPEAT
    INC (number);
    BuildName
  UNTIL ~ Exists (name);
  IF ~ new THEN
    DEC (number);
    IF number < 0 THEN
      RETURN FALSE
    END;
    BuildName
  END;
  RETURN TRUE
END SearchName;

PROCEDURE FullName (VAR dir : ARRAY OF CHAR);
(* liefert den kompletten Pfad + Dateinamen zu "dir" *)
VAR
  lock : d.FileLockPtr;
BEGIN
  lock := d.Lock (dir, d.sharedLock);
  IF lock # NIL THEN
    IF d.NameFromLock (lock, dir, LEN (dir)) THEN END;
    d.UnLock (lock)
  END
END FullName;

PROCEDURE CD (dir : ARRAY OF CHAR);
VAR
  name          : e.STRPTR;
  lock, oldlock : d.FileLockPtr;
BEGIN
  S.ALLOCATE (name);
  IF name # NIL THEN
    COPY (dir, name^);
    FullName (name^);
    lock := d.Lock (name^, d.sharedLock);
    IF lock # NIL THEN
      oldlock := d.CurrentDir (lock);
      IF oldlock # NIL THEN
        d.UnLock (oldlock)
      END;
      IF d.SetCurrentDirName (name^) THEN END;
    END;
    DISPOSE (name)
  END
END CD;

BEGIN
  S.ALLOCATE (arg);        IF arg        = NIL THEN Error (memerror) END;
  S.ALLOCATE (currentdir); IF currentdir = NIL THEN Error (memerror) END;
  RD := d.ReadArgs (template, arg^, NIL);
  IF RD = NIL THEN HALT (20) END;
  IF (arg^.dir # NIL) THEN
    (* $OddChk- *)
    IF arg^.dir^ [0] # a.nul THEN
      IF SearchName (name, TRUE) THEN
        file := d.Open (name, d.newFile);
        IF file # NIL THEN
          IF d.GetCurrentDirName (currentdir^, SIZE (currentdir^)) THEN
            FullName (currentdir^);
            IF d.Write (file, currentdir^, s.Length (currentdir^)) > 0 THEN END
          END;
          IF d.Close (file) THEN END
        END
      END;
      CD (arg^.dir^)
    END
    (* $OddChk= *)
  ELSE
    S.ALLOCATE (arg^.dir); IF arg^.dir = NIL THEN Error (memerror) END;
    IF SearchName (name, FALSE) THEN
      file := d.Open (name, d.oldFile);
      IF file # NIL THEN
        (* $OddChk- *)
        IF d.Read (file, arg^.dir^, SIZE (arg^.dir^)) > 0 THEN
          CD (arg^.dir^)
        END;
        (* $OddChk= *)
        IF d.Close (file) THEN END;
        IF d.DeleteFile (name) THEN END
      END
    END;
    DISPOSE (arg^.dir)
  END

CLOSE
  IF RD # NIL THEN
    d.FreeArgs (RD)
  END;
  DISPOSE (arg);
  DISPOSE (currentdir)
END PCD.