Meeting Pearls 1/Meeting Pearls Vol 1 (1994).iso/installed_progs/dev/fsystem-1.2/fsystem.mod

Text File | 1994-05-22 | 31.2 KB | 1,121 lines

(* (* $VER: FSystem 1.2 (24-Nov-93) Copyright © by Lars Düning *) *)

MODULE FSystem;

(*---------------------------------------------------------------------------
** File handling library module.
**
** Copyright © 1991-1993  Lars Düning  -  All rights reserved.
** Permission granted for non-commercial use.
**---------------------------------------------------------------------------
** The module evolved from the Filesystem module of Amiga-Oberon v1.17.1.
** It was developed independantly, though being compatible on source level.
**
** BUGS:
**   Doesn't use the OS-2.0 buffered files.
**   Doesn't know multi-assigns.
**---------------------------------------------------------------------------
** Oberon-2: Amiga-Oberon v3.10, F. Siebert / A+L AG
**---------------------------------------------------------------------------
** [lars] Lars Düning; Am Wendenwehr 25; D-38114-Braunschweig;
**                     Germany; Tel. [phone]
**---------------------------------------------------------------------------
** 25-Feb-91 [lars]
** 25-May-91 [lars] variable buffer sizes
** 30-Nov-91 [lars] removed a type, quick adaption for v2.13.
** 01-Dec-91 [lars] where suiting, LONGINT replaced by SYSTEM.ADDRESS.
** 21-Mar-93 [lars] recompiled for Oberon v3.00, ReadLongString() new
** 24-Nov-93 [lars] recompiled for Oberon v3.10
**---------------------------------------------------------------------------
*)

(* $OvflChk- $RangeChk- $StackChk- $NilChk- $ReturnChk- $CaseChk- *)

IMPORT
  (* $IF Debug *) Debug, (* $END *)
  bt:BasicTypes, sd:SecureDos, ol:OberonLib,
  d:Dos, e:Exec, s:SYSTEM;

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

TYPE
  BufPtr    = UNTRACED POINTER TO s.BYTE;
  FilePtr * = POINTER TO File;

CONST

  StdBufSize *= 1024;  (* Default buffer size *)
  cEof        = 1CX;   (* End-Of-File character *)

    (* Open() access modes *)

  newFile * = d.newFile;   (* excl. access, erases existing file *)
  oldFile * = d.oldFile;   (* shared access, file has to exist *)
  update  * = d.readWrite; (* excl. access, file may exist *)

    (* Open() operation modes *)

  writeOnly * = 0;
  readOnly  * = 1;
  readWrite * = 2;

    (* File.status, error codes in fact *)

  ok        * = 0;  (* no error occured *)
  eof       * = 1;  (* end of file reached *)
  readerr   * = 2;  (* unspecified read error, ask Dos *)
  writeerr  * = 3;  (* unspecified write error, ask Dos *)
  onlyread  * = 4;  (* tried to write a read-only file *)
  onlywrite * = 5;  (* tried to read a write-only file *)
  toofar    * = 6;  (* seeked beyond the file's limits *)
  outofmem  * = 7;  (* run out of memory *)
  cantopen  * = 8;  (* couldn't open file *)
  cantlock  * = 9;  (* couldn't lock file *)

TYPE
  File * = RECORD
    handle * : d.FileHandlePtr;
    status * : INTEGER;
    write  * : BOOLEAN;
    read   * : BOOLEAN;
    name   * : POINTER TO ARRAY OF CHAR;
    string * : bt.DynString;
    bufchg   : BOOLEAN;
    buffer   : POINTER TO ARRAY OF s.BYTE;
    bufptr   : LONGINT;  (* pointer to act position in buffer *)
    buflen   : LONGINT;  (* number of bytes in buffer *)
    bpos     : LONGINT;  (* true position of buffer[0] in file *)
    pos      : LONGINT;  (* 'virtual' position of user in file *)
    size     : LONGINT;  (* size of the file *)
  END;
  (* The file structure makes no statements about the 'true' current
   * fileposition as managed by DosS (except .read is TRUE and .buflen 0).
   * That means that prior to every file operation using Dos at least
   * one Dos.Seek(file.pos) should happen, better a call to EmptyBuf() to
   * flush the internal buffers.
   *)

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE Use * (VAR    file: File
                ;       name: ARRAY OF CHAR
                ;    accMode: INTEGER
                ;    opMode : INTEGER
                ;    bufsize: LONGINT
                ): BOOLEAN;


(* Open a file according to access and operation mode.
**
** Arguments:
**   file: the empty(!) File structure to fill in.
**   name: the name of the file to open (will be copied into file).
**   accMode: the access mode to use.
**   opMode : the operation mode to use.
**   bufSize: size of the buffer to allocate, must be at least 1.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** A bufsize of 1 will result in unbuffered io.
*)

VAR
  lock: d.FileLockPtr;
  info : d.FileInfoBlock;

BEGIN
  file.buffer := NIL;
  file.string := NIL;
  file.handle := NIL;
  file.name   := NIL;
  lock := NIL;
  LOOP
    IF bufsize < 1 THEN
      file.status := outofmem;
      EXIT;
    END;
    s.ALLOCATE(file.buffer, bufsize);
    s.ALLOCATE(file.name, LEN(name));
    IF (file.buffer = NIL) OR (file.name = NIL) THEN
      file.status := outofmem;
      EXIT;
    END;
    COPY(name, file.name^);
    file.handle := sd.Open(name,accMode);
    IF (file.handle = NIL) & (accMode = update) THEN
      accMode := newFile;
      file.handle := sd.Open(name,accMode);
    END;
    IF file.handle = NIL THEN
      file.status := cantopen;
      EXIT
    END;
    IF accMode = newFile THEN
      file.size := 0;
    ELSE
      lock := sd.Lock(name,d.sharedLock);
      IF (lock = NIL) OR (~d.Examine(lock, info)) THEN
        file.status := cantlock;
        EXIT;
      END;
      file.size := info.size;
      sd.UnLock(lock);
    END;
    file.bufchg := FALSE;
    file.bufptr := 0;
    file.buflen := 0;
    file.bpos   := 0;
    file.pos    := 0;
    file.write  := opMode # readOnly;
    file.read   := opMode # writeOnly;
    file.status := ok;
    RETURN TRUE;
  END;

  IF file.buffer # NIL THEN
    (* $IFNOT GarbageCollector *)
      DISPOSE(file.buffer);
    (* $END *)
    file.buffer := NIL;
  END;
  IF file.name # NIL THEN
    (* $IFNOT GarbageCollector *)
      DISPOSE(file.name);
    (* $END *)
    file.name := NIL;
  END;
  IF file.handle # NIL THEN
    sd.Close(file.handle);
    file.handle := NIL;
  END;
  IF lock # NIL THEN
    sd.UnLock(lock);
  END;
  RETURN FALSE;
END Use;

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE open * (VAR    file: File
                 ;       name: ARRAY OF CHAR
                 ;    accMode: INTEGER
                 ): BOOLEAN;


(* Open a file for read/write with a default sized buffer.
**
** Arguments:
**   file: the empty(!) File structure to fill in.
**   name: the name of the file to open (will be copied into file).
**   accMode: the access mode to use.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The allocated buffer will be of StdBufSize.
** The file will be opened for reading and writing.
*)

BEGIN
  RETURN Use (file, name, accMode, readWrite, StdBufSize);
END open;

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE Open * (VAR  file: File
                 ;     name: ARRAY OF CHAR
                 ;    write: BOOLEAN
                 ): BOOLEAN;

(* Open a file for read or write with a default sized buffer.
**
** Arguments:
**   file: the empty(!) File structure to fill in.
**   name: the name of the file to open (will be copied into file).
**   write: TRUE if the file shall be written, FALSE if it shall be read.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The allocated buffer will be of StdBufSize. The file will be opened
** for either reading or writing.
**
** This is a compatibility function to FileSystem.
*)

VAR
  accMode, opMode : INTEGER;
BEGIN
  IF write THEN accMode := newFile; opMode := writeOnly;
           ELSE accMode := oldFile; opMode := readOnly;  END;
  RETURN Use (file, name, accMode, opMode, StdBufSize);
END Open;

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE OpenReadWrite* (VAR file: File; name: ARRAY OF CHAR) : BOOLEAN;

(* Open a file for read and write with a default sized buffer.
**
** Arguments:
**   file: the empty(!) File structure to fill in.
**   name: the name of the file to open (will be copied into file).
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The allocated buffer will be of StdBufSize. The file will be opened
** for reading and writing.
**
** This is a compatibility function to FileSystem.
*)

BEGIN
  RETURN Use (file, name, update, readWrite, StdBufSize);
END OpenReadWrite;

(*-------------------------------------------------------------------------*)
PROCEDURE Flush * {"FSystem.FlushBuf"} (VAR file: File): BOOLEAN;
PROCEDURE FlushBuf * (VAR file: File): BOOLEAN;

(* Flush the buffers of a file.
**
** Arguments:
**   file: the file to flush.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**   file will be update appropriately.
**
** If the file has been changed, this call will flush the internal buffer
** out to the disk file. To do this, the file.buflen bytes starting
** from file.buffer[0] are written, then the old file.pos will be seeked.
*)

VAR
  p, pos, buflen, l, ptr : LONGINT;

BEGIN
  IF ~file.read OR ~file.bufchg THEN
    file.status := ok;
    RETURN TRUE;
  END;
  pos := file.pos; (* file.pos # file.bpos+file.buflen is possible *)
  p := d.Seek (file.handle, file.bpos, d.beginning);
  IF p < 0 THEN
    file.status := writeerr;
    RETURN FALSE;
  END;
  file.pos := file.bpos;
  file.bufptr := 0;
  buflen := file.buflen;
  ptr := 0;
  WHILE buflen > 0 DO
    l := d.Write(file.handle,file.buffer[ptr],buflen);
    IF l<0 THEN
      file.status := writeerr;
      RETURN FALSE;
    END;
    INC(file.pos, l);
    INC(ptr, l);
    file.bufptr := ptr;
    DEC(buflen,l);
  END;
  file.buflen := 0;
  file.bufchg := FALSE;
  file.bufptr := 0;
  file.bpos := file.pos;
  p := d.Seek(file.handle, pos, d.beginning);
  IF p < 0 THEN
    file.status := readerr;
    RETURN FALSE;
  END;
  file.pos := pos;
  file.status := ok;
  RETURN TRUE;
END FlushBuf;

(*-------------------------------------------------------------------------*)
PROCEDURE EmptyBuf (VAR file: File): BOOLEAN;

(* Internal: Unconditionally flush the buffers of a file.
**
** Arguments:
**   file: the file to flush.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**   file will be update appropriately.
**
** The buffer of the file will always be emptied. If necessary, its
** contents are written to disk using FlushBuf().
** This function is needed if many data are to be written en bloc,
** or if a new buffer has to be read.
*)

BEGIN
  IF file.write AND file.bufchg THEN
    RETURN FlushBuf(file);
  END;
  IF (file.buflen # 0) & (d.Seek(file.handle, file.pos, d.beginning) < 0) THEN
    file.status := readerr;
    RETURN FALSE;
  END;
  file.buflen := 0;
  file.bufptr := 0;
  file.bpos := file.pos;
  file.bufchg := FALSE;
  file.status := ok;
  RETURN TRUE;
END EmptyBuf;

(*-------------------------------------------------------------------------*)
PROCEDURE close * {"FSystem.Close"} (VAR file: File);
PROCEDURE Close * (VAR file: File): BOOLEAN;

(* Close the file.
**
** Arguments:
**   file: the file to close.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** Before closing, all changed data is written out using FlushBuf().
*)

VAR res: BOOLEAN;

BEGIN
  res := FlushBuf(file);
  (* $IFNOT GarbageCollector *)
    IF file.name # NIL THEN DISPOSE (file.name); END;
    IF file.string # NIL THEN DISPOSE (file.string); END;
    DISPOSE(file.buffer);
  (* $END *)
  file.name := NIL;
  file.string := NIL;
  file.buffer := NIL;
  sd.Close(file.handle); file.handle := NIL;
  RETURN res;
END Close;

(*-------------------------------------------------------------------------*)
PROCEDURE read * {"FSystem.Read"}(VAR file: File; VAR to: ARRAY OF s.BYTE);
PROCEDURE Read * (VAR file: File; VAR to: ARRAY OF s.BYTE): BOOLEAN;

(* Read data from a file.
**
** Arguments:
**   file: the file to read.
**   to  : the buffer to read into.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The function optimizes large reads by circumventing file's buffer then.
*)

VAR
  cnt: LONGINT;
  len: LONGINT;
  bufpos: LONGINT;

BEGIN
  IF ~file.read THEN file.status := onlywrite; RETURN FALSE; END;
  cnt := 0; bufpos := file.bufptr;
  IF LEN(to) > 2*LEN(file.buffer^) THEN
    IF NOT (EmptyBuf (file)) THEN RETURN FALSE END;
    bufpos := 0;
    WHILE cnt < LEN(to) DO
      len := d.Read(file.handle,to[cnt],LEN(to)-cnt);
      IF len=0 THEN file.status := eof;     RETURN FALSE END;
      IF len<0 THEN file.status := readerr; RETURN FALSE END;
      INC (cnt, len);
      INC (file.pos, len);
      file.bpos := file.pos;
    END;
  ELSE
    WHILE cnt<LEN(to) DO
      IF (bufpos=file.buflen) THEN
        IF NOT (EmptyBuf (file)) THEN RETURN FALSE END;
        bufpos := 0;
        file.buflen := d.Read(file.handle, file.buffer^,LEN(file.buffer^));
        IF file.buflen<0 THEN file.status := readerr; RETURN FALSE END;
        IF file.buflen=0 THEN file.status := eof;     RETURN FALSE END;
      END;
      len := LEN(to) - cnt;
      IF len > file.buflen - bufpos THEN
        len := file.buflen - bufpos;
      END;
      e.CopyMem (file.buffer[bufpos], to[cnt], len);
      INC(cnt, len); INC(bufpos, len);
      INC(file.pos, len);
    END;
  END;
  file.bufptr := bufpos;
  file.status := ok;
  RETURN TRUE;
END Read;

(*-------------------------------------------------------------------------*)
PROCEDURE readBlock * {"FSystem.ReadBlock"}
                      ( VAR    file : File
                      ;          to : s.ADDRESS
                      ;         size: LONGINT
                      ; VAR actSize : LONGINT
                      );
PROCEDURE ReadBlock * ( VAR    file : File
                      ;          to : s.ADDRESS
                      ;         size: LONGINT
                      ; VAR actSize : LONGINT
                      ): BOOLEAN;

(* Read a block of data from a file.
**
** Arguments:
**   file   : the file to read.
**   to     : the address of the buffer to read into.
**   size   : the length of the buffer = number of bytes to read.
**   actSize: variable taking the actual number of bytes read.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The function optimizes large reads by circumventing file's buffer then.
*)

VAR
  len: LONGINT;
  bufpos: LONGINT;
  pto: BufPtr;

BEGIN
  IF ~file.read THEN file.status := onlywrite; RETURN FALSE; END;
  pto := s.VAL (BufPtr, to);
  actSize := 0; bufpos := file.bufptr;
  IF size > 2*LEN(file.buffer^) THEN
    IF NOT (EmptyBuf (file)) THEN RETURN FALSE END;
    bufpos := 0;
    WHILE actSize < size DO
      len := d.Read(file.handle,pto^,size-actSize);
      IF len=0 THEN file.status := eof;     RETURN FALSE END;
      IF len<0 THEN file.status := readerr; RETURN FALSE END;
      INC (actSize, len);
      pto := s.VAL (BufPtr, s.VAL(LONGINT, pto) + len);
      INC (file.pos, len);
      file.bpos := file.pos;
    END;
  ELSE
    WHILE actSize<size DO
      IF (bufpos=file.buflen) THEN
        IF NOT (EmptyBuf (file)) THEN RETURN FALSE END;
        bufpos := 0;
        file.buflen := d.Read(file.handle,file.buffer^,LEN(file.buffer^));
        IF file.buflen=0 THEN file.status := eof;     RETURN FALSE END;
        IF file.buflen<0 THEN file.status := readerr; RETURN FALSE END;
      END;
      len := size - actSize;
      IF len > file.buflen - bufpos THEN
        len := file.buflen - bufpos;
      END;
      e.CopyMem (file.buffer[bufpos], pto^, len);
      INC(actSize, len);
      pto := s.VAL (BufPtr, s.VAL(LONGINT, pto) + len);
      INC(bufpos, len);
      INC(file.pos, len);
    END;
  END;
  file.bufptr := bufpos;
  file.status := ok;
  RETURN TRUE;
END ReadBlock;

(*-------------------------------------------------------------------------*)
PROCEDURE readChar * {"FSystem.ReadChar"}(VAR file: File; VAR ch: CHAR);
PROCEDURE ReadChar * (VAR file: File; VAR ch: CHAR): BOOLEAN;

(* Read a character from a file.
**
** Arguments:
**   file: the file to read.
**   ch  : the variable taking the character read.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** On eof, ch is set to EOF.
*)

BEGIN
  IF ~file.read THEN file.status := onlywrite; RETURN FALSE; END;
  ch := cEof;
  IF (file.bufptr=file.buflen) THEN
    IF NOT (EmptyBuf (file)) THEN RETURN FALSE END;
    file.buflen := d.Read(file.handle,file.buffer^,LEN(file.buffer^));
    IF file.buflen=0 THEN file.status := eof;     RETURN FALSE END;
    IF file.buflen<0 THEN file.status := readerr; RETURN FALSE END;
  END;
  ch := CHR(file.buffer[file.bufptr]);
  INC(file.bufptr);
  INC(file.pos);
  file.status := ok;
  RETURN TRUE;
END ReadChar;

(*-------------------------------------------------------------------------*)
PROCEDURE readString * {"FSystem.ReadString"}
                       (VAR file: File; VAR to: ARRAY OF CHAR);
PROCEDURE ReadString * (VAR file: File; VAR to: ARRAY OF CHAR): BOOLEAN;

(* Read a string from a file.
**
** Arguments:
**   file: the file to read.
**   to  : the buffer to read the string into.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The string is read until a \0 or a \n shows up (which is not stored)
** or the buffer is exhausted. If possible, the read string is terminated
** with \0.
*)

VAR
  cnt: LONGINT;
  bufpos: LONGINT;
  eos: BOOLEAN;

BEGIN
  IF ~file.read THEN file.status := onlywrite; RETURN FALSE; END;
  cnt := 0; bufpos := file.bufptr; eos := FALSE;
  WHILE (cnt<LEN(to)) AND NOT eos DO
    IF (bufpos=file.buflen) THEN
      IF NOT (EmptyBuf (file)) THEN RETURN FALSE END;
      bufpos := 0;
      file.buflen := d.Read(file.handle,file.buffer^,LEN(file.buffer^));
      to[cnt] := 0X;
      IF file.buflen=0 THEN file.status := eof; RETURN FALSE END;
      IF file.buflen<0 THEN file.status := readerr; RETURN FALSE END;
    END;
    to[cnt] := CHR(file.buffer[bufpos]);
    CASE to[cnt] OF 0X,0AX: eos := TRUE; to[cnt] := 0X | ELSE END;
    INC(cnt); INC(bufpos);
    INC (file.pos);
  END;
  file.bufptr := bufpos;
  file.status := ok;
  RETURN TRUE;
END ReadString;


(*-------------------------------------------------------------------------*)
PROCEDURE ReadLongString * {"FSystem.ReadLString"}(VAR file: File): BOOLEAN;
PROCEDURE readLString * {"FSystem.ReadLString"}(VAR file: File);
PROCEDURE ReadLString * (VAR file: File): BOOLEAN;

(* Read a long string from a file.
**
** Arguments:
**   file: the file to read.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**   The read string is store in file.string.
**
** The string is read until a \0 or a \n shows up (which is not stored).
** If possible, the read string is terminated with \0.
**
** ReadLongString() is a compatibility function to FileSystem.
*)

VAR
  cnt: LONGINT;
  bufpos: LONGINT;
  eos: BOOLEAN;
  new: bt.DynString;

BEGIN
  IF ~file.read THEN file.status := onlywrite; RETURN FALSE; END;
  IF file.string = NIL THEN
    s.ALLOCATE (file.string, 100H);
    IF file.string = NIL THEN file.status := outofmem; RETURN FALSE; END;
  END;
  file.string[0] := 0X;
  cnt := 0; bufpos := file.bufptr; eos := FALSE;
  WHILE NOT eos DO
    IF cnt >= LEN(file.string^) THEN
      s.ALLOCATE (new, 2 * cnt);
      COPY (file.string^, new^);
(* $IFNOT GarbageCollector *)
      DISPOSE (file.string);
(* $END *)
      file.string := new;
    END;

    IF (bufpos=file.buflen) THEN
      IF NOT (EmptyBuf (file)) THEN RETURN FALSE END;
      bufpos := 0;
      file.buflen := d.Read(file.handle,file.buffer^,LEN(file.buffer^));
      file.string[cnt] := 0X;
      IF file.buflen=0 THEN file.status := eof; RETURN FALSE END;
      IF file.buflen<0 THEN file.status := readerr; RETURN FALSE END;
    END;
    file.string[cnt] := CHR(file.buffer[bufpos]);
    CASE file.string[cnt] OF 0X,0AX: eos := TRUE; file.string[cnt] := 0X | ELSE END;
    INC (cnt); INC(bufpos);
    INC (file.pos);
  END;
  file.bufptr := bufpos;
  file.status := ok;
  RETURN TRUE;
END ReadLString;

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE write * {"FSystem.Write"}(VAR file: File; VAR from: ARRAY OF s.BYTE);
(* $CopyArrays- *)
PROCEDURE Write * (VAR file: File; VAR from: ARRAY OF s.BYTE): BOOLEAN;

(* Write data to a file.
**
** Arguments:
**   file: the file to write.
**   from: the buffer to write from.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The function optimizes large writes by circumventing file's buffer then.
*)

VAR
  cnt: LONGINT;
  len: LONGINT;
  bufpos: LONGINT;
  buflen: LONGINT;

BEGIN
  IF ~file.write THEN file.status := onlyread; RETURN FALSE END;
  cnt := 0; bufpos := file.bufptr;
  buflen := file.buflen;
  IF LEN(from) > 2*LEN(file.buffer^) THEN
    IF NOT (EmptyBuf (file)) THEN
      file.status := writeerr; RETURN FALSE
    END;
    bufpos := 0;
    buflen := 0;
    WHILE cnt < LEN(from) DO
      len := d.Write(file.handle,from[cnt],LEN(from)-cnt);
      IF len<0 THEN file.status := writeerr; RETURN FALSE END;
      INC (cnt, len);
      INC (file.pos, len);
      IF (file.pos > file.size) THEN file.size := file.pos END;
      file.bpos := file.pos;
    END;
  ELSE
    WHILE cnt<LEN(from) DO
      IF (bufpos=LEN(file.buffer^)) THEN
        file.buflen := buflen;
        IF NOT EmptyBuf(file) THEN
          file.status := writeerr; RETURN FALSE
        END;
        bufpos := 0;
        buflen := 0;
      END;
      len := LEN(from) - cnt;
      IF len > LEN(file.buffer^) - bufpos THEN
        len := LEN(file.buffer^) - bufpos;
      END;
      e.CopyMem (from[cnt], file.buffer[bufpos], len);
      INC(cnt, len); INC(bufpos, len);
      IF (bufpos > buflen) THEN buflen := bufpos; END;
      INC (file.pos, len);
      IF (file.pos > file.size) THEN file.size := file.pos END;
      file.bufchg := TRUE;
    END;
  END;
  file.bufptr := bufpos;
  file.buflen := buflen;
  file.status := ok;
  RETURN TRUE;
END Write;

(*-------------------------------------------------------------------------*)
PROCEDURE writeBlock * {"FSystem.WriteBlock"}
                       ( VAR    file : File
                       ;        from : s.ADDRESS
                       ;        size : LONGINT
                       ; VAR actSize : LONGINT
                       );
PROCEDURE WriteBlock * ( VAR    file : File
                       ;        from : s.ADDRESS
                       ;        size : LONGINT
                       ; VAR actSize : LONGINT
                       ): BOOLEAN;

(* Write a block of data to a file.
**
** Arguments:
**   file    : the file to write.
**   from    : the address of the buffer to write from.
**   size    : the length of the buffer = the number of bytes to write.
**   actSize : variable taking the actual number of bytes written.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**   actsize: the number of bytes written.
**
** The function optimizes large writes by circumventing file's buffer then.
*)

VAR
  len: LONGINT;
  bufpos: LONGINT;
  buflen: LONGINT;
  pfrom : BufPtr;

BEGIN
  IF ~file.write THEN file.status := onlyread; RETURN FALSE END;
  actSize := 0; bufpos := file.bufptr;
  buflen := file.buflen;
  pfrom := s.VAL (BufPtr, from);
  IF size > 2 * LEN(file.buffer^) THEN
    IF NOT (EmptyBuf (file)) THEN
      file.status := writeerr; RETURN FALSE
    END;
    bufpos := 0;
    buflen := 0;
    WHILE actSize < size DO
      len := d.Write(file.handle, pfrom^, size-actSize);
      IF len<0 THEN file.status := writeerr; RETURN FALSE END;
      INC (actSize, len);
      pfrom := s.VAL (BufPtr, s.VAL(LONGINT, pfrom) + len);
      INC (file.pos, len);
      IF (file.pos > file.size) THEN file.size := file.pos END;
      file.bpos := file.pos;
    END;
  ELSE
    WHILE actSize<size DO
      IF (bufpos=LEN(file.buffer^)) THEN
        file.buflen := buflen;
        IF NOT EmptyBuf(file) THEN
          file.status := writeerr; RETURN FALSE
        END;
        bufpos := 0;
        buflen := 0;
      END;
      len := size - actSize;
      IF len > LEN(file.buffer^) - bufpos THEN
        len := LEN(file.buffer^) - bufpos;
      END;
      e.CopyMem (pfrom^, file.buffer[bufpos], len);
      INC(actSize, len); INC(bufpos, len);
      pfrom := s.VAL(BufPtr, s.VAL(LONGINT, pfrom) + len);
      IF bufpos > buflen THEN buflen := bufpos END;
      INC(file.pos,len);
      IF file.pos > file.size THEN file.size := file.pos END;
      file.bufchg := TRUE;
    END;
  END;
  file.buflen := buflen;
  file.bufptr := bufpos;
  file.bufchg := TRUE;
  file.status := ok;
  RETURN TRUE;
END WriteBlock;

(*-------------------------------------------------------------------------*)
PROCEDURE writeChar * {"FSystem.WriteChar"}(VAR file: File; ch: CHAR);
PROCEDURE WriteChar * (VAR file: File; ch: CHAR): BOOLEAN;

(* Write a character to a file.
**
** Arguments:
**   file: the file to write.
**   ch  : the character to write.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
*)

VAR
  bufpos : LONGINT;
BEGIN
  IF ~file.write THEN file.status := onlyread; RETURN FALSE END;
  bufpos := file.bufptr;
  IF bufpos=LEN(file.buffer^) THEN
    IF NOT EmptyBuf(file) THEN
      file.status := writeerr; RETURN FALSE
    END;
    bufpos := 0;
  END;
  file.buffer[bufpos] := ch;
  INC (bufpos); file.bufptr := bufpos;
  IF bufpos > file.buflen THEN file.buflen := bufpos END;
  INC(file.pos);
  IF file.pos > file.size THEN file.size := file.pos END;
  file.status := ok;
  file.bufchg := TRUE;
  RETURN TRUE;
END WriteChar;

(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE writeString * {"FSystem.WriteString"}
                        (VAR file: File; from: ARRAY OF CHAR);
(* $CopyArrays- *)
PROCEDURE WriteString * (VAR file: File; from: ARRAY OF CHAR): BOOLEAN;

(* Write a string to a file.
**
** Arguments:
**   file: the file to write.
**   from: the string to write.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The function writes the string plus one \n character.
*)

VAR
  slen : LONGINT;
  eos: BOOLEAN;
  cnt: LONGINT;
  len: LONGINT;
  bufpos: LONGINT;
  buflen: LONGINT;

BEGIN
  IF ~file.write THEN file.status := onlyread; RETURN FALSE END;

  slen := 0; eos := FALSE;
  WHILE (slen < LEN (from)) AND NOT eos DO
    IF from[slen] = 0X THEN
      eos := TRUE;
      from[slen] := 0AX;
    END;
    INC (slen);
  END;

  cnt := 0; bufpos := file.bufptr;
  buflen := file.buflen;
  IF slen > 2 * LEN(file.buffer^) THEN
    IF NOT (EmptyBuf (file)) THEN
      file.status := writeerr; RETURN FALSE
    END;
    bufpos := 0;
    buflen := 0;
    WHILE cnt < slen DO
      len := d.Write(file.handle,from[cnt], slen-cnt);
      IF len<0 THEN file.status := writeerr; RETURN FALSE END;
      INC (cnt, len);
      INC (file.pos, len);
      IF (file.pos > file.size) THEN file.size := file.pos END;
      file.bpos := file.pos;
    END;
  ELSE
    WHILE cnt<slen DO
      IF (bufpos=LEN(file.buffer^)) THEN
        file.buflen := buflen;
        IF NOT EmptyBuf(file) THEN
          file.status := writeerr; RETURN FALSE
        END;
        bufpos := 0;
        buflen := 0;
      END;
      len := slen - cnt;
      IF len > LEN(file.buffer^) - bufpos THEN
        len := LEN(file.buffer^) - bufpos;
      END;
      e.CopyMem (from[cnt], file.buffer[bufpos], len);
      INC(cnt, len); INC(bufpos, len);
      IF (bufpos > buflen) THEN buflen := bufpos; END;
      INC (file.pos, len);
      IF (file.pos > file.size) THEN file.size := file.pos END;
      file.bufchg := TRUE;
    END;
  END;
  file.bufptr := bufpos;
  file.buflen := buflen;
  file.status := ok;

  IF ~eos AND ~WriteChar (file, 0AX) THEN RETURN FALSE; END;

  RETURN TRUE;
END WriteString;

(*-------------------------------------------------------------------------*)
PROCEDURE Size * (VAR file: File): LONGINT;

(* Determine the size of a file.
**
** Arguments:
**   file: the file to query.
**
** Result:
**   The file's size in bytes.
*)

BEGIN
  RETURN file.size;
END Size;

(*-------------------------------------------------------------------------*)
PROCEDURE Position * (VAR file: File): LONGINT;

(* Determine the current position in a file.
**
** Arguments:
**   file: the file to query.
**
** Result:
**   The position within the file in bytes.
*)

BEGIN
  RETURN file.pos;
END Position;

(*-------------------------------------------------------------------------*)
PROCEDURE move * {"FSystem.Move"}(VAR file: File; to: LONGINT);
PROCEDURE Move * (VAR file: File; to: LONGINT): BOOLEAN;

(* Seek within a file.
**
** Arguments:
**   file: the file to seek in.
**   to  : the new position to seek, counted in bytes from the files start.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
*)

VAR l: LONGINT;

BEGIN
  IF (to >= file.bpos) & (to < file.bpos + file.buflen) THEN
    l := to - file.bpos;
    file.pos := to;
    INC (file.bufptr, l);
    file.status := ok;
    RETURN TRUE;
  END;

  IF NOT EmptyBuf(file)       THEN                        RETURN FALSE END;
  IF (to>file.size) OR (to<0) THEN file.status := toofar; RETURN FALSE END;
  IF d.Seek(file.handle,to,d.beginning)=0 THEN END;
  file.pos  := to;
  file.bpos := to;
  file.status := ok;
  RETURN TRUE;
END Move;

(*-------------------------------------------------------------------------*)
PROCEDURE forward * {"FSystem."}(VAR file: File; to: LONGINT);
PROCEDURE Forward * (VAR file: File; to: LONGINT): BOOLEAN;

(* Seek forward within a file.
**
** Arguments:
**   file: the file to seek in.
**   to  : the number of bytes to skip forward.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
*)

BEGIN
  RETURN Move(file,file.pos+to);
END Forward;

(*-------------------------------------------------------------------------*)
PROCEDURE backward * {"FSystem.Backward"}(VAR file: File; to: LONGINT);
PROCEDURE Backward * (VAR file: File; to: LONGINT): BOOLEAN;

(* Seek backward within a file.
**
** Arguments:
**   file: the file to seek in.
**   to  : the number of bytes to skip backward.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
*)

BEGIN
  RETURN Move(file,file.pos-to);
END Backward;

(*-------------------------------------------------------------------------*)
PROCEDURE delete * {"FSystem.Delete"}(VAR file: File);
PROCEDURE Delete * (VAR file: File): BOOLEAN;

(* Delete a file.
**
** Arguments:
**   file: the file to delete.
**
** Result:
**   TRUE on success, else FALSE with file.status denoting the error.
**
** The file is closed, then deleted.
*)

VAR
  name : POINTER TO ARRAY OF CHAR;
  rc : BOOLEAN;
BEGIN
  IF file.name = NIL THEN
    file.status := cantopen;
    RETURN FALSE;
  END;
  NEW(name, LEN(file.name^));
  COPY(file.name^, name^);
  close(file);
  rc := d.DeleteFile(name^);
  (* $IFNOT GarbageCollector *)
    DISPOSE(name);
  (* $END *)
  RETURN rc;
END Delete;


(*-------------------------------------------------------------------------*)
(* $CopyArrays- *)
PROCEDURE Exists * (name: ARRAY OF CHAR): BOOLEAN;

(* Check if a named file exists.
**
** Arguments:
**   name: the filename to check.
**
** Result:
**   TRUE if the file exists, else FALSE.
**
** BUGS:
**   Doesn't handle multi-assigns.
*)

VAR
  lock: d.FileLockPtr;

BEGIN
  lock := sd.Lock(name,d.sharedLock);
  IF lock#NIL THEN
    sd.UnLock(lock); RETURN TRUE
  ELSE
    RETURN FALSE;
  END;
END Exists;

(*=========================================================================*)

END FSystem.

(***************************************************************************)