(***************************************************************************

     $RCSfile: Files.mod $
  Description: Port of the Project Oberon Files module

   Created by: J. Gutknecht
    Ported by: fjc (Frank Copeland)
    $Revision: 1.2 $
      $Author: fjc $
        $Date: 1994/05/12 20:45:18 $

  Copyright © 1990-1993, ETH Zuerich
  Copyright © 1994, Frank Copeland.
  This file is part of the Oberon-A Library.
  See Oberon-A.doc for conditions of use and distribution.

  Log entries are at the end of the file.

***************************************************************************)

MODULE Files;

(*
  Interface notes
  ===============

  This module attempts to reproduce the behaviour of the Project Oberon
  module as closely as possible, with two major exceptions.  AmigaDOS does
  not allow multiple simultaneous access to a file.  Until I can work out
  some way of recycling AmigaDOS FileHandles, only one user will be allowed
  per file.  This implementation of Oberon does not include a resource
  tracker.  This means that files must be explicitly closed, using either
  Register (), Close () or Purge ().  File variables remain allocated after
  calls to these procedures, but cannot be used again; they should be
  explicitly de-allocated with SYSTEM.DISPOSE ().

  Implementation Notes
  ====================

  This module is built as a layer on top of AmigaDOS.  Old() attempts to
  open the named file with a read/write (but not exclusive) lock.  New()
  creates a temporary file.  Both will fail if they attempt to open an
  interactive file.  Register() deletes any existing file and renames the
  temporary file.  Purge() deletes the file.  Register(), Close() and
  Purge() explicitly close the AmigaDOS file but do not de-allocate the File
  variable; this allows the programmer to check for any errors that occur
  during the close operation.

  [TBD]

*)

(* $P- allow non-portable code *)
(* $L+ use absolute long addressing for global variables *)

IMPORT SYS := SYSTEM, Dos, DosUtil, Str := Strings, Oberon;


(* --- Public declarations ---------------------------------------------- *)


TYPE
  File * = POINTER TO Handle;  (* Note that file.dosError is public. *)
  Buffer = POINTER TO BufferRecord;

  Rider * = RECORD
    eof * : BOOLEAN;
    res * : LONGINT; (* Set to the error code returned by AmigaDOS *)
    file  : File;
    apos  : LONGINT;
    buf   : Buffer;
    bpos  : INTEGER;
  END; (* Rider *)


(* --- Private declarations and procedures ------------------------------ *)

(*
  These definitions are taken from the Project Oberon module FileDir, which
  does not exist in this implementation.
*)


CONST
  FnLength = 256; (* for AmigaDOS, = 32 for Project Oberon *)
  SectorSize = 1024;

TYPE
  FileName = ARRAY FnLength OF CHAR;
  DataSector = ARRAY SectorSize OF SYS.BYTE;


(*------------------------------------*)


CONST
  MaxBufs = 4;

TYPE
  DiskAdr = LONGINT;

  Handle = RECORD
    len        : LONGINT;
    nofbufs    : INTEGER;
    firstbuf   : Buffer;
    name       : FileName;
    time, date : LONGINT;
    fileHandle : Dos.FileHandlePtr;
    dosError * : LONGINT;           (* The AmigaDOS error code for the most
                                     * recent operation
                                     *)
    tempKey    : LONGINT;
  END; (* Handle *)

  BufferRecord = RECORD
    apos : LONGINT;
    lim  : INTEGER;
    mod  : BOOLEAN;
    next : Buffer;
    data : DataSector;
  END; (* BufferRecord *)

VAR
  tempKey : LONGINT; (* Used to generate temporary file names. *)


(*------------------------------------*)
PROCEDURE ReadBuf (f : File; buf : Buffer; pos : LONGINT);

  VAR res : LONGINT; arg : ARRAY 2 OF LONGINT;

BEGIN (* ReadBuf *)
  res := Dos.Base.Seek (f.fileHandle, pos, Dos.offsetBeginning);
  IF res # -1 THEN
    buf.lim := SHORT (Dos.Base.Read (f^.fileHandle, buf.data, SectorSize));
    buf.apos := pos;
    buf.mod := FALSE;
  ELSE
    f.dosError := Dos.Base.IoErr ();
    arg [0] := pos; arg [1] := f.dosError;
    res := Dos.Base.VPrintf ("ReadBuf: pos = %ld, IoErr = %ld\n", arg);
  END
END ReadBuf;


(*------------------------------------*)
PROCEDURE WriteBuf (f : File; buf : Buffer);

  VAR res : LONGINT; arg : ARRAY 2 OF LONGINT;

BEGIN (* WriteBuf *)
  res := Dos.Base.Seek (f.fileHandle, buf.apos, Dos.offsetBeginning);
  IF res # -1 THEN
    res := Dos.Base.Write (f.fileHandle, buf.data, buf.lim);
    IF res = buf.lim THEN
      buf.mod := FALSE;
    ELSE
      f.dosError := Dos.Base.IoErr ();
      arg [0] := res; arg [1] := f.dosError;
      res := Dos.Base.VPrintf ("WriteBuf (2): res = %ld, IoErr = %ld\n", arg);
    END
  ELSE
    f.dosError := Dos.Base.IoErr ();
    arg [0] := buf.apos; arg [1] := f.dosError;
    res := Dos.Base.VPrintf ("WriteBuf (1): apos = %ld, IoErr = %ld\n", arg);
  END
END WriteBuf;


(*
(*------------------------------------*)
PROCEDURE Buf (f : File; pos : LONGINT) : Buffer;

  VAR buf : Buffer;

BEGIN (* Buf *)
  buf := f.firstbuf;
  LOOP
    IF buf.apos = pos THEN EXIT END;
    buf := buf.next;
    IF buf = f.firstbuf THEN buf := NIL; EXIT END
  END; (* LOOP *)
  RETURN buf;
END Buf;
*)


(*------------------------------------*)
PROCEDURE GetBuf (f : File; pos : LONGINT) : Buffer;

  VAR buf, last, next : Buffer;

BEGIN (* GetBuf *)
  buf := f.firstbuf;
  LOOP
    IF buf.apos = pos THEN EXIT END;
    IF buf.next = f.firstbuf THEN
      last := buf;
      IF f.nofbufs < MaxBufs THEN (* allocate new buffer *)
        NEW (buf);
        INC (f.nofbufs);
      ELSE (* take one of the buffers (assuming more than one) *)
        buf := f.firstbuf; f.firstbuf := buf.next; last.next := buf.next;
        IF buf.mod THEN WriteBuf (f, buf) END
      END;
      IF pos < f.firstbuf.apos THEN
        f.firstbuf := buf
      ELSIF pos < last.apos THEN
        WHILE last.next.apos < pos DO last := last.next END;
      END;
      buf.next := last.next; last.next := buf;
      buf.apos := pos; buf.lim := 0; buf.mod := FALSE;
      IF pos (*<=*) < f.len THEN ReadBuf (f, buf, pos) END;
      EXIT
    END;
    buf := buf.next
  END; (* LOOP *)
  RETURN buf;
END GetBuf;


(*------------------------------------*)
PROCEDURE Unbuffer (f : File);

  VAR buf : Buffer;

BEGIN (* Unbuffer *)
  buf := f.firstbuf;
  REPEAT
    IF buf.mod THEN WriteBuf (f, buf) END;
    buf := buf.next
  UNTIL buf = f.firstbuf
END Unbuffer;


(*------------------------------------*)
PROCEDURE MakeTempName (VAR name : ARRAY OF CHAR; key : LONGINT);

  VAR i : INTEGER; digit : LONGINT;

BEGIN (* MakeTempName *)
  COPY ("T:", name);
  i := 10;
  WHILE i > 0 DO
    digit := key MOD 10H; IF digit >= 10 THEN INC (digit, 7) END;
    DEC (i); name [i] := CHR (digit + ORD ("0")); key := key DIV 10H
  END; (* WHILE *)
  name [10] := 0X; Str.Append (name, ".tmp")
END MakeTempName;


(* --- Public procedures ------------------------------------------------ *)


(*------------------------------------*)
(* $D- disable copying of open arrays *)
PROCEDURE Delete * (name : ARRAY OF CHAR; VAR res : LONGINT);

BEGIN (* Delete *)
  IF Dos.Base.DeleteFile (name) THEN
    res := 0
  ELSE
    res := Dos.Base.IoErr ();
    IF res = Dos.errorObjectNotFound THEN res := 0 END
  END; (* ELSE *)
END Delete;


(*------------------------------------*)
(* $D- disable copying of open arrays *)
PROCEDURE Rename * (old, new : ARRAY OF CHAR; VAR res : LONGINT);

BEGIN (* Rename *)
  IF Dos.Base.Rename (old, new) THEN
    res := 0
  ELSE
    res := Dos.Base.IoErr ()
  END; (* ELSE *)
END Rename;


(*------------------------------------*)
(* $D- disable copying of open arrays *)
PROCEDURE Old * (name : ARRAY OF CHAR) : File;
(*
  [TBD]

  * This really needs better error handling.  I expect testing will
    force me to provide it :-)

  * Implement check for interactive files.
*)

  VAR
    f : File; fl : Dos.FileLockPtr; fh : Dos.FileHandlePtr;
    fib : Dos.FileInfoBlockPtr; buf : Buffer;

BEGIN (* Old *)
  f := NIL;
  fl := Dos.Base.Lock (name, Dos.sharedLock);
  IF fl # NIL THEN
    fh := Dos.Base.Open (name, Dos.modeOldFile);
    IF fh # NIL THEN
      NEW (fib);
      IF fib # NIL THEN
        IF Dos.Base.Examine (fl, fib) THEN
          Dos.Base.UnLock (fl);
          NEW (buf); buf.apos := 0; buf.next := buf; buf.mod := FALSE;
          NEW (f); f.len := fib.fibSize;
          Oberon.ADOS2OberonTime (fib.fibDate, f.time, f.date);
          IF f.len > SectorSize THEN buf.lim := SectorSize
          ELSE buf.lim := SHORT (f.len)
          END;
          f.firstbuf := buf; f.nofbufs := 1; f.name [0] := 0X;
          f.fileHandle := fh; f.dosError := 0; f.tempKey := 0;
          ReadBuf (f, buf, 0);
        ELSE
          SYS.PUTREG (0, Dos.Base.Close (fh));
        END; (* IF *)
        SYS.DISPOSE (fib);
      ELSE
        SYS.PUTREG (0, Dos.Base.Close (fh));
      END; (* IF *)
    END; (* IF *)
  END; (* IF *)
  RETURN f;
END Old;

(*------------------------------------*)
(* $D- disable copying of open arrays *)
PROCEDURE New * (name : ARRAY OF CHAR) : File;
(*
  [TBD]

  * This really needs better error handling.  I expect testing will
    force me to provide it :-)

  * Implement check for interactive files.
*)

  VAR
    tempName : FileName; f : File; fh : Dos.FileHandlePtr; buf : Buffer;
    ch : CHAR; i : INTEGER;

BEGIN (* New *)
  f := NIL;
  IF name [0] = 0X THEN
    REPEAT MakeTempName (tempName, tempKey); INC (tempKey)
    UNTIL ~DosUtil.FileExists (tempName);
    fh := Dos.Base.Open (tempName, Dos.modeNewFile);
  ELSE
    COPY (name, tempName); Str.Append (tempName, "$tmp*");
    i := SHORT (Str.Length (tempName)) - 1; ch := "A";
    REPEAT tempName [i] := ch; ch := CHR (ORD (ch) + 1)
    UNTIL ~DosUtil.FileExists (tempName);
    fh := Dos.Base.Open (tempName, Dos.modeNewFile);
  END; (* ELSE *)
  IF fh # NIL THEN
    NEW (buf);
    buf.apos := 0; buf.next := buf; buf.mod := TRUE; buf.lim := 0;
    NEW (f);
    Oberon.GetClock (f.time, f.date);
    f.len := 0; f.firstbuf := buf; f.nofbufs := 1; COPY (name, f.name);
    f.fileHandle := fh; f.dosError := 0;
    IF name [0] = 0X THEN f.tempKey := tempKey-1
    ELSE f.tempKey := ORD (ch) - 1
    END;
    ReadBuf (f, buf, 0);
  END; (* IF *)
  RETURN f;
END New;


(*------------------------------------*)
PROCEDURE Register * (f : File);

  VAR tempName, bkpName : FileName; i : INTEGER;

BEGIN (* Register *)
  IF (f # NIL) & (f.fileHandle # NIL) THEN
    Unbuffer (f);
    IF Dos.Base.Close (f.fileHandle) THEN
      f.dosError := 0;
      IF f.name [0] = 0X THEN
        MakeTempName (tempName, f.tempKey);
        Delete (tempName, f.dosError)
      ELSE
        COPY (f.name, tempName); Str.Append (tempName, "$tmp*");
        i := SHORT (Str.Length (tempName)) - 1;
        tempName [i] := CHR (f.tempKey);
        COPY (f.name, bkpName); Str.Append (bkpName, "$bak");
        Rename (f.name, bkpName, f.dosError);
        IF (f.dosError = 0) THEN
          Rename (tempName, f.name, f.dosError);
          IF f.dosError = 0 THEN
            Delete (bkpName, f.dosError)
          END; (* IF *)
        ELSIF (f.dosError = Dos.errorObjectNotFound) THEN
          Rename (tempName, f.name, f.dosError);
        END; (* IF *)
      END; (* IF *)
    ELSE f.dosError := Dos.Base.IoErr ()
    END;
  END; (* IF *)
END Register;


(*------------------------------------*)
PROCEDURE Close * (f : File);

BEGIN (* Close *)
  IF f # NIL THEN
    Unbuffer (f);
    IF Dos.Base.Close (f.fileHandle) THEN f.dosError := 0
    ELSE f.dosError := Dos.Base.IoErr ()
    END; (* ELSE *)
  END; (* IF *)
END Close;


(*------------------------------------*)
PROCEDURE Purge * (f : File);

  VAR tempName : FileName; i : INTEGER;

BEGIN (* Purge *)
  IF f # NIL THEN
    Unbuffer (f);
    IF Dos.Base.Close (f.fileHandle) THEN
      f.dosError := 0;
      IF f.name [0] = 0X THEN
        MakeTempName (tempName, f.tempKey);
        Delete (tempName, f.dosError)
      ELSE
        COPY (f.name, tempName); Str.Append (tempName, "$tmp*");
        i := SHORT (Str.Length (tempName)) - 1;
        tempName [i] := CHR (f.tempKey);
        Delete (tempName, f.dosError)
      END; (* ELSE *)
    ELSE f.dosError := Dos.Base.IoErr ()
    END;
  END; (* IF *)
END Purge;


(*------------------------------------*)
PROCEDURE Length * (f : File) : LONGINT;

BEGIN (* Length *)
  RETURN f.len
END Length;


(*------------------------------------*)
PROCEDURE GetDate * (f : File; VAR t, d : LONGINT);

BEGIN (* GetDate *)
  t := f.time; d := f.date
END GetDate;


(*------------------------------------*)
PROCEDURE Set * (VAR r : Rider; f : File; pos : LONGINT);

BEGIN (* Set *)
  r.eof := FALSE; r.res := 0;
  IF f # NIL THEN
    IF pos < 0 THEN
      r.apos := 0; r.bpos := 0
    ELSE
      r.bpos := SHORT (pos MOD SectorSize); r.apos := pos - r.bpos
    END;
    r.file := f; r.buf := f.firstbuf
  ELSE
    r.file := NIL;
  END
END Set;


(*------------------------------------*)
PROCEDURE Read * (VAR r : Rider; VAR x : SYS.BYTE);

  VAR buf : Buffer;

BEGIN (* Read *)
  IF r.apos # r.buf.apos THEN r.buf := GetBuf (r.file, r.apos) END;
  IF r.bpos < r.buf.lim THEN
    x := r.buf.data [r.bpos]; INC (r.bpos)
  ELSIF (r.apos + SectorSize) < r.file.len THEN
    INC (r.apos, SectorSize);
    (* buf := Buf (r.file, r.apos);
    IF buf = NIL THEN
      IF r.buf.mod THEN WriteBuf (r.file, r.buf) END;
      ReadBuf (r.file, r.buf, r.apos)
    ELSE
      r.buf := buf
    END;
    *)
    r.buf := GetBuf (r.file, r.apos);
    x := r.buf.data [0]; r.bpos := 1
  ELSE
    x := 0X; r.eof := TRUE
  END
END Read;


(*------------------------------------*)
PROCEDURE ReadBytes *
  ( VAR r : Rider; VAR x : ARRAY OF SYS.BYTE; n : LONGINT);

  VAR src, dst, m : LONGINT;
      buf : Buffer;

BEGIN (* ReadBytes *)
  dst := SYS.VAL (LONGINT, SYS.ADR (x));
  IF LEN (x) < n THEN HALT (25) END;
  IF r.apos # r.buf.apos THEN r.buf := GetBuf (r.file, r.apos) END;
  LOOP
    IF n <= 0 THEN EXIT END;
    src := SYS.VAL (LONGINT, SYS.ADR(r.buf.data));
    INC (src, r.bpos); m := r.bpos + n;
    IF m <= r.buf.lim THEN
      SYS.MOVE (src, dst, n); r.bpos := SHORT (m); r.res := 0;
      EXIT
    ELSIF r.buf.lim = SectorSize THEN
      m := r.buf.lim - r.bpos;
      IF m > 0 THEN
        SYS.MOVE (src, dst, m); INC (dst, m); DEC (n, m)
      END;
      IF r.apos < r.file.len THEN
        INC (r.apos, SectorSize);
        r.bpos := 0;
        (*
        buf := Buf (r.file, r.apos);
        IF buf = NIL THEN
          IF r.buf.mod THEN WriteBuf (r.file, r.buf) END;
          ReadBuf (r.file, r.buf, r.apos)
        ELSE
          r.buf := buf
        END; (* ELSE *)
        *)
        r.buf := GetBuf (r.file, r.apos);
      ELSE
        r.res := n; r.eof := TRUE; EXIT
      END; (* ELSE *)
    ELSE
      m := r.buf.lim - r.bpos;
      IF m > 0 THEN
        SYS.MOVE (src, dst, m); r.bpos := r.buf.lim
      END;
      r.res := n - m; r.eof := TRUE; EXIT
    END; (* ELSE *)
  END; (* LOOP *)
END ReadBytes;


(*------------------------------------*)
PROCEDURE Write * (VAR r : Rider; x : SYS.BYTE);

  VAR f : File; buf : Buffer;

BEGIN (* Write *)
  IF r.apos # r.buf.apos THEN r.buf := GetBuf (r.file, r.apos) END;
  IF r.bpos >= r.buf.lim THEN
    IF r.bpos < SectorSize THEN
      INC (r.buf.lim); INC (r.file.len)
    ELSE
      f := r.file; (* WriteBuf (f, r.buf);*) INC (r.apos, SectorSize);
      (*
      buf := Buf (r.file, r.apos);
      IF buf = NIL THEN
        IF r.apos < f.len THEN ReadBuf (f, r.buf, r.apos)
        ELSE r.buf.apos := r.apos; r.buf.lim := 1; f.len := r.apos;
        END
      ELSE
        r.buf := buf
      END;
      *)
      r.buf := GetBuf (f, r.apos);
      IF r.apos >= f.len THEN r.buf.lim := 1; f.len := r.apos END;
      r.bpos := 0
    END
  END;
  r.buf.data [r.bpos] := x; INC (r.bpos); r.buf.mod := TRUE
END Write;


(*------------------------------------*)
PROCEDURE WriteBytes *
  (VAR r : Rider; VAR x : ARRAY OF SYS.BYTE; n : LONGINT);

  VAR src, dst, m : LONGINT; f : File; buf : Buffer;

BEGIN (* WriteBytes *)
  src := SYS.VAL (LONGINT, SYS.ADR (x));
  IF LEN (x) < n THEN HALT (25) END;
  IF r.apos # r.buf.apos THEN r.buf := GetBuf (r.file, r.apos) END;
  LOOP
    IF n <= 0 THEN EXIT END;
    r.buf.mod := TRUE;
    dst := SYS.VAL (LONGINT, SYS.ADR(r.buf.data)); INC (dst, r.bpos);
    m := r.bpos + n;
    IF m <= r.buf.lim THEN
      SYS.MOVE (src, dst, n); r.bpos := SHORT (m); EXIT
    ELSIF m <= SectorSize THEN
      SYS.MOVE (src, dst, n); r.bpos := SHORT (m);
      INC (r.file.len, n); r.buf.lim := SHORT (m); EXIT
    ELSE
      m := SectorSize - r.bpos;
      IF m > 0 THEN
        SYS.MOVE (src, dst, m); INC (src, m); DEC (n, m);
        INC (r.buf.lim, SHORT (m))
      END;
      f := r.file; (*WriteBuf (f, r.buf);*) INC (r.apos, SectorSize);
      r.bpos := 0;
      (*
      buf := Buf (f, r.apos);
      IF buf = NIL THEN
        IF r.apos < f.len THEN ReadBuf (f, r.buf, r.apos)
        ELSE r.buf.apos := r.apos; r.buf.lim := 0; f.len := r.apos
        END;
      ELSE
        r.buf := buf
      END; (* ELSE *)
      *)
      r.buf := GetBuf (f, r.apos);
      IF r.apos >= f.len THEN r.buf.lim := 0; f.len := r.apos END;
    END;
  END; (* LOOP *)
END WriteBytes;

(*------------------------------------*)
PROCEDURE Pos * (VAR r : Rider) : LONGINT;

BEGIN (* Pos *)
  RETURN r.apos + r.bpos
END Pos;


(*------------------------------------*)
PROCEDURE Base * (VAR r : Rider) : File;

BEGIN (* Base *)
  RETURN r.file;
END Base;

(*------------------------------------*)
PROCEDURE InitTempKey ();

  VAR time, date : LONGINT;

BEGIN (* InitTempKey *)
  Oberon.GetClock (time, date); tempKey := date * 10000H + time;
  IF tempKey = 0 THEN INC (tempKey) END
END InitTempKey;

BEGIN
  InitTempKey()
END Files.

(***************************************************************************

  $Log: Files.mod $
  Revision 1.2  1994/05/12  20:45:18  fjc
  - Prepared for release

  Revision 1.1  1994/01/15  21:39:12  fjc
  Start of revision control

  13 Jan 94 [FJC] : Changed GetBuf to keep buffers in position
                    order, hopefully eliminating seek errors.
                    Now no procedures call ReadBuf or WriteBuf directly.
  28 Dec 93 [FJC] : Actually, I had totally stuffed the handling
                    of temporary files.  *This* time, hopefully,
                    it is fixed.
  15 Dec 93 [FJC] : *Really* fixed handling of temporary files.
   2 Dec 93 [FJC] : Fixed handling of temporary files.

***************************************************************************)