Fresh Fish 10/Fresh_Fish_10_2352.bin/new/dev/obero/oberon-a/source/library/files.mod

Text File | 1995-06-29 | 16KB | 702 lines

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

     $RCSfile: Files.mod $
  Description: Operations on files and the file directory.

   Created by: fjc (Frank Copeland)
    $Revision: 1.13 $
      $Author: fjc $
        $Date: 1995/06/04 23:22:41 $

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

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

<* STANDARD- *>

MODULE Files;

IMPORT
  SYS := SYSTEM, Kernel, e := Exec, d := Dos, du := DosUtil,
  str := Strings, conv := Conversions, oc := OberonClock;

CONST
  SectorSize = 1024;
  MaxBufs = 4;

TYPE

  File *= POINTER TO Handle;

  Buffer = POINTER TO BufferRecord;

  Rider *= RECORD
    eof -: BOOLEAN;
    res -: LONGINT;
    file : File;
    pos : LONGINT;
    buf : Buffer;
    bpos : INTEGER;
  END; (* Rider *)

  Handle = RECORD
    fl -: d.FileLockPtr;
    fh -: d.FileHandlePtr;
    name : ARRAY 256 OF CHAR;
    tempNo : LONGINT;
    pos, len : LONGINT;
    nofbufs : INTEGER;
    next : File;
    firstbuf : Buffer;
  END; (* Handle *)

  DataSector = ARRAY SectorSize OF SYS.BYTE;

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


VAR
  root : File;
  tempNo : LONGINT;

CONST
  tempExt = ".tmp";
  bkpExt = ".bkp";


PROCEDURE GetTempNo;

  VAR time, date : LONGINT;

BEGIN (* GetTempNo *)
  oc.GetClock (time, date);
  tempNo := ABS ((date * 10000H + time) DIV 2)
END GetTempNo;


PROCEDURE MakeName
  ( name : ARRAY OF CHAR;
    tempNo : LONGINT;
    ext : ARRAY OF CHAR;
    VAR tempName : ARRAY OF CHAR );

  VAR pathPart : e.LSTRPTR; s : ARRAY 13 OF CHAR;

<*$CopyArrays-*>
BEGIN (* MakeName *)
  COPY (name, tempName);
  IF tempName # "" THEN
    pathPart := d.PathPart (tempName); pathPart [0] := 0X
  END;
  ASSERT (conv.IntToStr (tempNo, 16, 0, "0", s));
  str.Append (ext, s);
  ASSERT (d.AddPart (tempName, s, LEN (tempName)))
END MakeName;


PROCEDURE Search ( fl : d.FileLockPtr ) : File;

  VAR f : File;

BEGIN (* Search *)
  f := root;
  WHILE (f # NIL) & (d.SameLock (fl, f.fl) # d.same) DO f := f.next END;
  RETURN f
END Search;


PROCEDURE Unlink (f : File);

  VAR f0 : File;

BEGIN (* Unlink *)
  IF root # NIL THEN
    IF f = root THEN
      root := root.next
    ELSE
      f0 := root;
      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 Unlink;


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

  VAR res : LONGINT;

BEGIN (* ReadBuf *)
  res := d.Seek (f.fh, pos, d.beginning);
  IF res # -1 THEN
    buf.lim := SHORT (d.Read (f^.fh, buf.data, SectorSize));
    buf.apos := pos;
    buf.mod := FALSE;
  END
END ReadBuf;


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

  VAR res : LONGINT;

BEGIN (* WriteBuf *)
  res := d.Seek (f.fh, buf.apos, d.beginning);
  IF res # -1 THEN
    res := d.Write (f.fh, buf.data, buf.lim);
    IF res = buf.lim THEN
      buf.mod := FALSE;
    END
  END
END WriteBuf;


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 Delete * ( name : ARRAY OF CHAR; VAR res : INTEGER );
<*$CopyArrays-*>
BEGIN (* Delete *)
  IF d.DeleteFile (name) THEN
    res := 0
  ELSE
    res := SHORT (d.IoErr ());
    IF res = d.objectNotFound THEN res := 0 END
  END
END Delete;


PROCEDURE Rename * ( old, new : ARRAY OF CHAR; VAR res : INTEGER );
<*$CopyArrays-*>
BEGIN (* Rename *)
  IF d.Rename (old, new) THEN res := 0
  ELSE res := SHORT (d.IoErr ())
  END
END Rename;


PROCEDURE Old * ( name : ARRAY OF CHAR ) : File;

  VAR
    f : File; fl : d.FileLockPtr; fh : d.FileHandlePtr;
    fib : d.FileInfoBlockPtr; len : LONGINT; buf : Buffer;

<*$CopyArrays-*>
BEGIN (* Old *)
  fl := d.Lock (name, d.sharedLock);
  IF fl # NIL THEN
    f := Search (fl);
    IF f = NIL THEN
      fh := d.Open (name, d.oldFile);
      IF fh # NIL THEN
        fib := d.AllocDosObjectTags (d.fib, NIL);
        IF fib # NIL THEN
          IF d.Examine (fl, fib^) THEN len := fib.size;
          ELSE len := 0
          END;
          d.FreeDosObject (d.fib, fib);
          NEW (f);
          IF f # NIL THEN
            NEW (buf);
            IF buf # NIL THEN
              buf.apos := 0; buf.next := buf; buf.mod := FALSE;
              IF len > SectorSize THEN buf.lim := SectorSize
              ELSE buf.lim := SHORT (len)
              END;
              f.len := len; f.firstbuf := buf; f.nofbufs := 1;
              COPY (name, f.name); f.tempNo := 0;
              f.fl := fl; f.fh := fh; f.pos := 0;
              f.next := root; root := f;
              ReadBuf (f, buf, 0);
              RETURN f
            END;
          END;
        END;
      END;
      d.OldClose (fh)
    END;
    d.UnLock (fl)
  END;
  RETURN f
END Old;


PROCEDURE New * ( name : ARRAY OF CHAR ) : File;

  VAR
    f : File; fl : d.FileLockPtr; fh : d.FileHandlePtr;
    buf : Buffer; tempName : ARRAY 256 OF CHAR;

<*$CopyArrays-*>
BEGIN (* New *)
  REPEAT
    IF tempNo < MAX (LONGINT) THEN INC (tempNo) ELSE tempNo := 1 END;
    MakeName (name, tempNo, tempExt, tempName)
  UNTIL ~du.FileExists (tempName);
  fh := d.Open (tempName, d.newFile);
  IF fh # NIL THEN
    NEW (f);
    IF f # NIL THEN
      NEW (buf);
      IF buf # NIL THEN
        buf.apos := 0; buf.next := buf; buf.mod := TRUE;
        buf.lim := 0;
        f.len := 0; f.firstbuf := buf; f.nofbufs := 1;
        COPY (name, f.name); f.tempNo := tempNo;
        f.fl := d.Lock (tempName, d.sharedLock); f.fh := fh; f.pos := 0;
        f.next := root; root := f;
        ReadBuf (f, buf, 0);
        RETURN f
      END
    END
  END;
  d.OldClose (fh);
  RETURN f
END New;


PROCEDURE Register * ( f : File );

  VAR tempName, bkpName : ARRAY 256 OF CHAR; res : INTEGER;

BEGIN (* Register *)
  ASSERT (f # NIL, 97);
  IF f.fh # NIL THEN
    Unbuffer (f); Unlink (f);
    IF d.Close (f.fh) THEN
      f.fh := NIL; d.UnLock (f.fl); f.fl := NIL;
      IF f.tempNo # 0 THEN
        MakeName (f.name, f.tempNo, tempExt, tempName);
        IF f.name = "" THEN
          Delete (tempName, res);
        ELSE
          MakeName (f.name, f.tempNo, bkpExt, bkpName);
          Rename (f.name, bkpName, res);
          IF res = 0 THEN
            Rename (tempName, f.name, res);
            IF res = 0 THEN Delete (bkpName, res) END
          ELSIF res = d.objectNotFound THEN
            Rename (tempName, f.name, res);
          END
        END
      END
    END
  END
END Register;


PROCEDURE Close * ( f : File );
BEGIN (* Close *)
  ASSERT (f # NIL, 97);
  IF f.fh # NIL THEN
    Unbuffer (f); Unlink (f);
    IF d.Close (f.fh) THEN f.fh := NIL; d.UnLock (f.fl); f.fl := NIL END
  END
END Close;


PROCEDURE Purge * ( f : File );

  VAR tempName : ARRAY 256 OF CHAR; res : INTEGER;

BEGIN (* Purge *)
  ASSERT (f # NIL, 97);
  IF f.fh # NIL THEN
    Unbuffer (f); Unlink (f);
    IF d.Close (f.fh) THEN f.fh := NIL; d.UnLock (f.fl); f.fl := NIL END;
    IF f.tempNo # 0