Fresh Fish 8/FreshFishVol8-CD1.bin/useful/dev/obero/oberon-a/source/projectoberon/files.mod

Text File | 1994-08-08 | 18.2 KB | 690 lines

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

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

   Created by: J. Gutknecht
    Ported by: fjc (Frank Copeland)
    $Revision: 1.6 $
      $Author: fjc $
        $Date: 1994/08/08 16:41:14 $

  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]

*)

(*
** $C= CaseChk       $I= IndexChk  $L= LongAdr   $N= NilChk
** $P= PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
** $V= OvflChk       $Z= ZeroVars
*)

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;
    next       : File;
  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. *)
  files : File;

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

  VAR f0 : File;

BEGIN (* Unlink *)
  IF f # NIL THEN
    IF files # NIL THEN
      IF f = files THEN
        files := files.next
      ELSE
        f0 := files;
        WHILE (f0.next # NIL) & (f0.next # f) DO
          f0 := f0.next
        END;
        IF f0.next = f THEN f0.next := f.next END;
      END;
    END;
    f.next := NIL
  END;
END Unlink;

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

  VAR res : LONGINT;

BEGIN (* ReadBuf *)
  res := Dos.base.Seek (f.fileHandle, pos, Dos.offsetBeginning);
  IF res # -1 THEN
    (* ASSERT (buf # NIL, 137); *)
    buf.lim := SHORT (Dos.base.Read (f^.fileHandle, buf.data, SectorSize));
    buf.apos := pos;
    buf.mod := FALSE;
  ELSE
    f.dosError := Dos.base.IoErr ()
  END
END ReadBuf;


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

  VAR res : LONGINT;

BEGIN (* WriteBuf *)
  (* ASSERT (buf # NIL, 137); *)
  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 ();
    END
  ELSE
    f.dosError := Dos.base.IoErr ();
  END
END WriteBuf;


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

  VAR buf, last, next : Buffer;

BEGIN (* GetBuf *)
  buf := f.firstbuf;
  LOOP
    (* ASSERT (buf # NIL, 137); *)
    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);
        (* ASSERT (buf # NIL, 137); *)
        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
    (* ASSERT (buf # NIL, 137); *)
    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
END Rename;


(*------------------------------------*)
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;

(* $D- disable copying of open arrays *)
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);
          (* ASSERT (buf # NIL, 137); *)
          buf.apos := 0; buf.next := buf; buf.mod := FALSE;
          NEW (f);
          (* ASSERT (f # NIL, 137); *)
          f.len := fib.size;
          Oberon.ADOS2OberonTime (fib.date, 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;
          f.next := files; files := f;
          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;

(*------------------------------------*)
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;

(* $D- disable copying of open arrays *)
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);
    (* ASSERT (buf # NIL, 137); *)
    buf.apos := 0; buf.next := buf; buf.mod := TRUE; buf.lim := 0;
    NEW (f);
    (* ASSERT (f # NIL, 137); *)
    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;
    f.next := files; files := f;
    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
    Unlink (f); 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
    Unlink (f); 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
    Unlink (f); 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 *)
  (* ASSERT (f # NIL, 137); *)
  RETURN f.len
END Length;


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

BEGIN (* GetDate *)
  (* ASSERT (f # NIL, 137); *)
  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; r.file := f;
  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.buf := f.firstbuf
  END
END Set;


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

  VAR buf : Buffer;

BEGIN (* Read *)
  (* ASSERT (r.file # NIL, 137); *)
  (* ASSERT (r.buf # NIL, 137); *)
  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);
    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 *)
  (* ASSERT (r.file # NIL, 137); *)
  (* ASSERT (r.buf # NIL, 137); *)
  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; 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 *)
  (* ASSERT (r.file # NIL, 137); *)
  (* ASSERT (r.buf # NIL, 137); *)
  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; INC (r.apos, SectorSize);
      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 *)
  (* ASSERT (r.file # NIL, 137); *)
  (* ASSERT (r.buf # NIL, 137); *)
  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; INC (r.apos, SectorSize);
      r.bpos := 0; 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;

(*------------------------------------*)
PROCEDURE* Cleanup ();

BEGIN
  WHILE files # NIL DO
    IF files.fileHandle # NIL THEN
      Unbuffer (files); Dos.base.OldClose (files.fileHandle)
    END;
    files := files.next
  END;
END Cleanup;

BEGIN
  InitTempKey();
  files := NIL; SYS.SETCLEANUP (Cleanup)
END Files.

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

  $Log: Files.mod $
  Revision 1.6  1994/08/08  16:41:14  fjc
  Release 1.4

  Revision 1.5  1994/06/14  02:14:31  fjc
  - Updated for release

  Revision 1.4  1994/06/09  14:12:41  fjc
  - Incorporated changes to Amiga interface

  Revision 1.3  1994/06/04  16:03:39  fjc
  - Changed to use new Amiga interface

  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] : Chinged 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.

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