Topspeed_JPI/TS/MODBASE/MODBASE3.MOD

IMPLEMENTATION MODULE ModBase3;

(*
 *  ModBase
 *  Release 3.0
 *  (c) Copyright 1986 - 1991 Donald G. Fletcher
 *  (c) Copyright 1986 - 1991 PMI
 *  P.O. Box 8402
 *  Green Bay Wi 53308
 *  All Rights Reserved
 *  August 6, 1987 - modifications to use Logitech 3.0
 *)

(* This Module exports a type called DBFile which contains
   pertinent information concerning the structure of the dBase
   file. All operations on a dBase data file must specify this
   parameter usually as an "alias" using the first 2 or 3 letters
   of the dBase Filename. Date of Last Modification: April 16,
   1987. Repertoire Input Output routines used.
*)

(* 5/11/88 added safety to modbase; if TRUE file integrity should
  be preserved as long as the power doesn't fail during a write.
  also added changes concerning memos to be finished later*)

(* 6/88 Changed to add transparent handling of memo files *)

(* 10/20/88 changes to add following:
   Automatic updating of dbindexes
   Made fieldlist a Pointer and only allocate as needed
      saving quite a bit of memory
   Added appending flag to speed append operations  *)
(* Logitech modules*)


  FROM M2Strings IMPORT
    Assign,Pos;

  FROM StrEdit IMPORT
    Append;


  FROM SYSTEM IMPORT
     BYTE,ADDRESS, ADR, TSIZE;

  (* Repertoire modules *)

  IMPORT
    EnvironUtils;
  FROM StringIO IMPORT
    ErrorMessage, NoError, PrintMessage;

  FROM HandleIO IMPORT
    BlockRead, BlockWrite, CloseHandle, OpenFile, SetFilePtr,
    CreateFile,UpdateDisk, FileOffSet,GetFilePtr;

  FROM LowLevel IMPORT
    Address8086, Fill, Move, AddAddr;

  FROM MiscFunctions IMPORT  FieldNameChar,Alph;

  FROM Numbers IMPORT
    Min;

  FROM ErrorManager IMPORT
    WARN;

  FROM VStorage IMPORT
    DosAlloc, DosDealloc;

  IMPORT Locks,FAPI;
  IMPORT PosUtils;

  PROCEDURE DEALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
  BEGIN
    DosDealloc(loc,size);
  END DEALLOCATE;

  PROCEDURE ALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
  BEGIN
    DosAlloc(loc,size);
  END ALLOCATE;


 CONST
    Blank           = " ";
    Null            = 0C;
    EndOfHeader     = 0DH;
    HdrLenPos       = 8;
    DatePosition    = 1;  (* position of the first byte of the last update *)
    RecNumLoPos     = 4;
    RecNumHiPos     = 6;
    FieldNameLength = 10;
    InitCode        =61353;
    one=VAL( LONGINT, 1 );

  (* ************************* EXPORTED PROCEDURES **************************)
TYPE

   DBFileRec =
     RECORD
       fileID,
       MemoHandle: CARDINAL;
       open,
       MemoOpen,
           (* will open only if  accessed *)
       Safety: BOOLEAN;
           (* if true keeps disk up to date  *)
       autolock,
       exclusive,
       appending,
       hasmemo: BOOLEAN;
       recordmode:RecordModeType;
       fixup:FixUpProcedure;
       ErrorCode,
       Init,
       numberoffields: CARDINAL;
       lastupdate: ARRAY[0..2] OF CARDINAL;
       length: CARDINAL; (* of records in BYTES *)
       fieldlist: DBFieldPtr;
       numofrecords: LONGINT;
       currentrecnum: LONGINT;
       headerlength: CARDINAL;
       ReReadPtr,SavePtr,currentrec,BufferPtr: POINTER TO ARRAY
           [1..MaxRecLength] OF CHAR;
       name,
       MemoName: ARRAY [0..NameLen] OF CHAR;
       dbbuffer : ADDRESS;
       buffersize, (* requested size *)
       size : CARDINAL; (* size of buffer in bytes *)
       start : LONGINT; (* first record number *)
       MaxRecords, NumRecords : CARDINAL;
       IndexList:ADDRESS;
     END;
    DBFile=POINTER TO DBFileRec;

  PROCEDURE DBError( alias:DBFile):CARDINAL;
  BEGIN
    RETURN alias^.ErrorCode;
  END DBError;

  PROCEDURE FileName(alias:DBFile;VAR Name:ARRAY OF CHAR);
  BEGIN
    Assign(alias^.name,Name);
  END FileName;

  PROCEDURE SafetySet(alias:DBFile):BOOLEAN;
  BEGIN
    RETURN alias^.Safety;
  END SafetySet;

  PROCEDURE RecordLength(alias:DBFile):CARDINAL;
  BEGIN
    RETURN alias^.length;
  END RecordLength;

  PROCEDURE HasMemo(alias:DBFile):BOOLEAN;
  BEGIN
    RETURN alias^.hasmemo;
  END HasMemo;

  PROCEDURE NumberOfFields(alias:DBFile):CARDINAL;
  BEGIN
  RETURN alias^.numberoffields;
  END NumberOfFields;

  PROCEDURE Appending(alias:DBFile):BOOLEAN;
  BEGIN
    RETURN alias^.appending;
  END Appending;

  PROCEDURE RecordPtr(alias:DBFile):ADDRESS;
  BEGIN
    RETURN alias^.currentrec;
  END RecordPtr;

  PROCEDURE IndexList(alias:DBFile):ADDRESS;
  BEGIN
    RETURN alias^.IndexList;
  END IndexList;

  PROCEDURE SetIndexList(alias:DBFile;ndx:ADDRESS);
  BEGIN
    alias^.IndexList:=ndx;
  END SetIndexList;

  PROCEDURE Record(alias:DBFile):LONGINT;
  BEGIN
    RETURN alias^.currentrecnum;
  END Record;

  PROCEDURE FieldList(alias:DBFile):DBFieldPtr;
  BEGIN
    RETURN alias^.fieldlist;
  END FieldList;

  PROCEDURE BufferSize(alias:DBFile):CARDINAL;
  BEGIN
    RETURN alias^.buffersize;
  END BufferSize;

  PROCEDURE NumberRecords(alias:DBFile):LONGINT;
  BEGIN
    IF NOT alias^.exclusive THEN
      SetFilePtr( alias^.fileID, FromStart, VAL(LONGINT,4 ));
      PrintMessage(Locks.ReadRetry( alias^.fileID,  ADR(alias^.numofrecords),
                           4,10,alias^.name ));
    END;
    RETURN alias^.numofrecords;
  END NumberRecords;

  PROCEDURE InitDBF(filename: ARRAY OF CHAR; VAR alias:
      DBFile; BufferSize:CARDINAL; safety,Exclusive,AutoLock:BOOLEAN;
      FixUp:FixUpProcedure );


  BEGIN
    NEW(alias);
    IF Exclusive THEN
      AutoLock:= FALSE
    END;
    WITH alias^ DO
      open:=FALSE;
      exclusive:=Exclusive OR Locks.ExclusiveOnly;
      autolock:=AutoLock;
      fixup:=FixUp;
      MemoOpen:=FALSE;
      Safety:=safety;
      Init:=InitCode;
      Assign(filename,name);
      fieldlist:=NIL;
      currentrec:=NIL;
      BufferPtr:=NIL;
      SavePtr:=NIL;
      ReReadPtr:=NIL;
      dbbuffer:=NIL;
      IndexList:=NIL;
      size:=0;
      buffersize:=BufferSize;
      recordmode:=CurrentRec;
    END;

  END InitDBF;

  PROCEDURE NilDBF(VAR alias:DBFile);
  BEGIN
    alias:=NIL;
  END NilDBF;

  PROCEDURE Initialized(alias:DBFile):BOOLEAN;
  BEGIN
    IF alias=NIL THEN RETURN FALSE END;
    IF alias^.Init=InitCode THEN
      RETURN TRUE
    END;
    RETURN FALSE;
  END Initialized;

  PROCEDURE DisposeDBF(VAR alias:DBFile);
  BEGIN
    IF alias=NIL THEN RETURN END;
    IF alias^.open THEN CloseDBF(alias) END;
    DISPOSE(alias);
  END DisposeDBF;

  PROCEDURE OpenMemo(alias:DBFile):BOOLEAN;
  BEGIN
    IF alias^.MemoOpen THEN RETURN TRUE END;
    alias^.MemoOpen:=OpenFile(alias^.MemoHandle,alias^.MemoName)=0;
    RETURN alias^.MemoOpen;
  END OpenMemo;

  PROCEDURE MemoHandle(alias:DBFile):CARDINAL;
  BEGIN
    RETURN alias^.MemoHandle;
  END MemoHandle;

  PROCEDURE SetDBSafetyOn( alias: DBFile);
  BEGIN
    UpdateDBFile(alias);
    alias^.Safety:=TRUE;
  END SetDBSafetyOn;

  PROCEDURE SetDBSafetyOff( alias: DBFile);
  BEGIN
    alias^.Safety:=FALSE;
  END SetDBSafetyOff;

  PROCEDURE SetRecordMode(alias: DBFile;Mode:RecordModeType);
  BEGIN
    IF alias^.recordmode=Mode THEN RETURN END;
    IF alias^.recordmode=CurrentRec
    THEN
      alias^.SavePtr:=alias^.currentrec;
    END;
    CASE Mode OF
      CurrentRec: alias^.currentrec:=alias^.SavePtr;
     |Buffer:     alias^.currentrec:=alias^.BufferPtr;
     |ReRead:     alias^.currentrec:=alias^.ReReadPtr
    END;
    alias^.recordmode:=Mode;
  END SetRecordMode;


  PROCEDURE OpenDBF
            (alias    : DBFile  ):BOOLEAN;


  VAR
    firstbyte : CHAR;
    i         :CARDINAL;
    ActionTaken:CARDINAL;
    filemode:BITSET;



    PROCEDURE MakeDBFile;

    VAR
      dbh : ARRAY[ 0 .. MaxHeaderLen - 1 ] OF CHAR;


      PROCEDURE ReadDBHeader;
      (* HeaderLength must always be 32n+2 where n is a number equal to one
         more than the number of fields in the record *)

      BEGIN
        SetFilePtr( alias^.fileID, FromStart, VAL( LONGINT, HdrLenPos ) );
        PrintMessage( Locks.ReadRetry( alias^.fileID, ADR( alias^.headerlength ), 2 ,
        10,alias^.name));
        SetFilePtr( alias^.fileID, FromStart, VAL( LONGINT, 0 ) );
        PrintMessage(Locks.ReadRetry( alias^.fileID, ADR( dbh ), alias^.headerlength,
        10,alias^.name ));
      END ReadDBHeader;


      PROCEDURE GetLastUpdate;

      VAR
        i : CARDINAL;

      BEGIN
        FOR i := 0 TO 2 DO
          alias^.lastupdate[i] := ORD( dbh[1 + i] );
        END;   (* for *)
      END GetLastUpdate;


      PROCEDURE GetNumberOfRecords;

      BEGIN
        Move( ADR( dbh[4] ), ADR( alias^.numofrecords ), 4 )
      END GetNumberOfRecords;


      PROCEDURE GetHeaderLength;

      BEGIN
        alias^.headerlength := ( ORD( dbh[9] ) * 100H ) + ORD( dbh[8] );
      END GetHeaderLength;


      PROCEDURE GetRecordLength;

      BEGIN
        alias^.length := ( ORD( dbh[11] ) * 100H ) + ORD( dbh[10] );
      END GetRecordLength;


      PROCEDURE GetFieldList;

      VAR
        j,
        k,
        fieldindex : CARDINAL;
        finished   : BOOLEAN;


        PROCEDURE InitFieldList;

        BEGIN
          FOR j := 1 TO alias^.numberoffields DO
            Fill( ADR( alias^.fieldlist^[j].name ), FieldNameLength, 0C );
            alias^.fieldlist^[j].fldtype := " ";
            alias^.fieldlist^[j].size := 0;
            alias^.fieldlist^[j].decplaces := 0;
            alias^.fieldlist^[j].offset := 0;
            (* index position in CurrentRecord *)
          END;   (* FOR *)
        END InitFieldList;

      BEGIN
        alias^.numberoffields:= (alias^.headerlength DIV 32)-1;
        ALLOCATE(alias^.fieldlist,
          (TSIZE(DBFieldArray)DIV MaxField)*(alias^.numberoffields));
        InitFieldList;
        alias^.fieldlist^[1].offset := 2;
        finished := FALSE;
        FOR j:=1 TO alias^.numberoffields DO
          fieldindex := ( j - 1 ) * 32;
          k := 0;
          Move( ADR( dbh[32 + fieldindex] ), ADR( alias^.fieldlist^[j].name ),
                FieldNameLength );
          alias^.fieldlist^[j].fldtype := dbh[43 + fieldindex];
          alias^.fieldlist^[j].size := ORD( dbh[48 + fieldindex] );
          (* Get fieldsize *)
          alias^.fieldlist^[j].decplaces := ORD( dbh[49 + fieldindex] );
          (* Get number of decimal places *)
          IF j > 1
          THEN
            alias^.fieldlist^[j].offset := alias^.fieldlist^[j - 1].offset +
                                         alias^.fieldlist^[j - 1].size;
          END;   (* IF *)
        END;   (* for *)
      END GetFieldList;

    BEGIN (* MakeDBFile *)
      ReadDBHeader;
      (* Fill out the Record *)
      GetNumberOfRecords;
      GetLastUpdate;
      GetRecordLength;
      GetHeaderLength;
      GetFieldList;
    END MakeDBFile;

    (* Procedure Description -- OpendBF -- Looks up a file with the parameter
       given as a name -- Checks to see if it is a dBaseIII type file --
       Creates a record of the type DBFile containing the pertinent information
       from the header of the dBase File -- If the file is already opened it
       does nothing *)

  BEGIN (* OpenDBF *)
    IF alias^.Init=InitCode
    THEN
      IF alias^.open
      THEN
        RETURN TRUE;
      END;
    ELSE
      WARN('UnInititalized DBFile In OpenDBF');
    END;
    IF alias^.exclusive THEN
       filemode:={1,4}
     ELSE
       filemode:={1,6} (* allow all *)
     END;
     alias^.ErrorCode := FAPI.DOSOPEN( ADR(alias^.name),
        ADR(alias^.fileID), ADR(ActionTaken), VAL(LONGINT,0), FAPI.FILE_NORMAL,
        CARDINAL({0}), CARDINAL(filemode), VAL(LONGINT,0) );

    IF alias^.ErrorCode # NoError
    THEN
      RETURN FALSE;
    END;
    IF (NOT alias^.exclusive) AND Locks.NoLocking(alias^.fileID) THEN
       alias^.exclusive:=TRUE
    END;

    (* make sure the file is a dBase file *)
    IF NoError # Locks.ReadRetry( alias^.fileID, ADR( firstbyte ), 1,10,alias^.name )
    THEN
      RETURN FALSE
    END;
    IF ( firstbyte = CHR( 03H ) )
    THEN
      alias^.hasmemo := FALSE;
      alias^.open := TRUE;
    ELSIF ( firstbyte = CHR( 83H ) )
    THEN
      alias^.hasmemo := TRUE;
      alias^.open := TRUE;
    ELSE
      alias^.ErrorCode := CloseHandle( alias^.fileID );
      alias^.open := FALSE;
      RETURN FALSE;
    (*   WARN( "File is not a dBase III - type file -- proc-OpenDBF3" );*)
    END;   (* IF *)
    (* construct a dBFileDesc *)
    IF alias^.open
    THEN
      MakeDBFile;
      IF alias^.autolock THEN
        ALLOCATE( alias^.ReReadPtr, alias^.length );
      END;
      ALLOCATE( alias^.currentrec, alias^.length );
      IF alias^.numofrecords=VAL(LONGINT,0)
      THEN
        alias^.currentrecnum:=VAL(LONGINT,0);
      ELSE
        alias^.currentrecnum:=VAL(LONGINT,1);
      END;
      alias^.NumRecords :=  0 ;
      alias^.start := VAL( LONGINT, 0 );
      alias^.size := 0;
      SetDBBuffer(alias,alias^.buffersize);
      IF alias^.hasmemo THEN
        alias^.MemoOpen:=FALSE;
        Assign(alias^.name,alias^.MemoName);
        i:=Pos( ".", alias^.MemoName);
        IF i<=HIGH(alias^.MemoName)  THEN
          alias^.MemoName[i]:=0C;
        END;
        Append(alias^.MemoName,'.DBT' );
      END;
    END;   (* IF alias^.open *)
    RETURN TRUE;
  END OpenDBF;

  PROCEDURE SetDBBuffer(alias:DBFile ;BufferSize:CARDINAL );

  BEGIN
    alias^.buffersize:=BufferSize;
    IF alias^.open THEN
    IF alias^.size#0
    THEN
      DEALLOCATE(alias^.dbbuffer, alias^.size );
    END;
    (* calculate buffer size *)
    alias^.MaxRecords := BufferSize DIV alias^.length ;
    IF alias^.MaxRecords=0
    THEN
      alias^.MaxRecords:=1;
    END;
    alias^.size := alias^.MaxRecords  *
                          alias^.length;

    ALLOCATE( alias^.dbbuffer, alias^.size );
    alias^.start:=VAL(LONGINT,0);
    alias^.NumRecords:=0;
    IF alias^.numofrecords > VAL( LONGINT, 0 )
    THEN
      ReadDBRec( alias, alias^.currentrecnum  );
      (* read the  currentrecord *)
    ELSE
      alias^.BufferPtr:=alias^.dbbuffer;
      Fill(  alias^.currentrec, alias^.length, 0C );
      Fill(  alias^.BufferPtr, alias^.length, 0C );
    END (* if alias^.numofrecords *);
   END;
  END SetDBBuffer;

  PROCEDURE UpdateDBHeader( alias :DBFile );
  VAR
    month,
    day,
    year    : CARDINAL;
    datestr : ARRAY[ 1 .. 3 ] OF CHAR;
    dumstr  : ARRAY[ 0 .. 15 ] OF CHAR;
    lock:Locks.RangeRec;

  BEGIN
    IF NOT alias^.open
    THEN
      RETURN;
    END (* if not alias^.open *);
    IF NOT alias^.exclusive THEN
      lock.FileOffset := VAL( LONGINT,0);
      lock.RangeLength:=VAL(LONGINT,32);
      alias^.ErrorCode:=Locks.LockRetry(alias^.fileID,lock,10,alias^.name);
      IF alias^.ErrorCode#0 THEN WARN('Unable to lock in UpdateDBHeader') END;
    END;
    EnvironUtils.GetDate( month, day, year, dumstr, dumstr );
    alias^.numofrecords := NumberRecords(alias);
    SetFilePtr( alias^.fileID, FromStart, VAL( LONGINT, DatePosition ) );
    datestr[1] := CHR( year MOD 100 );
    datestr[2] := CHR( month );
    datestr[3] := CHR( day );
    alias^.ErrorCode := BlockWrite( alias^.fileID, ADR( datestr ), 3 );
    alias^.ErrorCode := BlockWrite( alias^.fileID, ADR( alias^.numofrecords ), 4 );
    alias^.ErrorCode := BlockWrite( alias^.fileID, ADR( alias^.headerlength ), 2 );
    IF NOT alias^.exclusive THEN
      alias^.ErrorCode:=Locks.UnLock(alias^.fileID,lock);
      IF alias^.ErrorCode#0 THEN WARN('Unable to Unlock in UpdateDBHeader') END;
    END;

  END UpdateDBHeader;

  PROCEDURE UpdateDBFile(alias :DBFile);

  BEGIN
    IF alias^.open
    THEN
      UpdateDBHeader(alias);
      UpdateDisk(alias^.fileID);
      IF alias^.MemoOpen
      THEN
        UpdateDisk(alias^.MemoHandle);
      END;
    END;
  END UpdateDBFile;

  PROCEDURE CloseDBF
            ( alias : DBFile );
  (* updates the header and closes the file *)

  BEGIN
    IF alias = NIL THEN
      RETURN
    END;
    IF NOT alias^.open
    THEN
      RETURN;
    END (* if not alias^.open *);
    UpdateDBHeader(alias);
    DEALLOCATE(alias^.fieldlist,
      (TSIZE(DBFieldArray)DIV MaxField)*(alias^.numberoffields));
    DEALLOCATE( alias^.dbbuffer, alias^.size );
    DEALLOCATE( alias^.currentrec, alias^.length );
    IF alias^.autolock THEN
      DEALLOCATE( alias^.ReReadPtr, alias^.length );
    END;
    alias^.ErrorCode := CloseHandle( alias^.fileID );
    IF alias^.MemoOpen
    THEN
      alias^.ErrorCode := CloseHandle( alias^.MemoHandle );
      alias^.MemoOpen := FALSE;
    END;
    alias^.open := FALSE;
  END CloseDBF;

(*$O- *)

  PROCEDURE ReadDBRec
            (alias  : DBFile;
                  recnum : LONGINT );
  (* deposits the fetched string in the currentrec field of alias *)
  CONST
    one=VAL( LONGINT, 1 );

  VAR
    recordpos : LONGINT;
    i,
    temp      :CARDINAL;
    long1,long2       :LONGINT;
    test      :BOOLEAN;

  BEGIN
    IF NOT alias^.open
    THEN (* check to make sure the file is open *)
      WARN('DBF file not open in ReadDBFile');
    END;
    alias^.appending:=FALSE;
    (* compiler bug forced braking down *)
    long1:= recnum - alias^.start;
    long2:=VAL(LONGINT,alias^.NumRecords) - VAL(LONGINT,1);
    test:=(long1 >
          long2  );
    IF ( long1<VAL(LONGINT,0) ) OR test
    THEN   (* is not in buffer *)
      IF  ( recnum > alias^.numofrecords ) OR
         (recnum=VAL(LONGINT,0))
      THEN
        WARN( "Record number out of range in ReadDBRec" )
      END;   (* IF *)
      IF VAL(LONGINT,alias^.MaxRecords) > alias^.numofrecords
      THEN   (* underflow *)
        alias^.start := one;
        alias^.NumRecords := VAL(CARDINAL,alias^.numofrecords);
      ELSE
        alias^.NumRecords := alias^.MaxRecords;
        IF recnum < alias^.start
        THEN   (* currec at top going down *)
          IF recnum > VAL(LONGINT,alias^.MaxRecords)
          THEN
            alias^.start := recnum - VAL(LONGINT,alias^.MaxRecords) + one;
             (* 2 to give 1 overlap ??*)
          ELSE
            alias^.start := one;
          END (* if recnum *);
        ELSE   (* recnum at bottom going up*)
          IF ( recnum + VAL(LONGINT,alias^.MaxRecords) - one ) >
             alias^.numofrecords
          THEN
            alias^.start := alias^.numofrecords - VAL(LONGINT,alias^.MaxRecords)
                                   + one;
          ELSE
            alias^.start := recnum;
          END ;
        END ;
      END;
      recordpos := ( alias^.start - one ) *
           VAL( LONGINT,alias^.length ) + VAL( LONGINT, alias^.headerlength );
      SetFilePtr( alias^.fileID, FromStart, VAL( LONGINT, recordpos ) );
      PrintMessage( Locks.ReadRetry( alias^.fileID,  alias^.dbbuffer ,
                              alias^.length * alias^.NumRecords ,10,alias^.name ));
    END (* if *);
    recordpos:=recnum - alias^.start;
    i:=VAL( CARDINAL, recordpos );
    temp:=alias^.length * i;
    alias^.BufferPtr :=  AddAddr( alias^.dbbuffer, temp);
     (* Make copy of buffer *)
    Move(alias^.BufferPtr,alias^.currentrec,alias^.length);

    alias^.currentrecnum := recnum;
    alias^.appending:=FALSE;
  END ReadDBRec;(*$O= *)

PROCEDURE CompareBlock( adr1,adr2:ADDRESS;size:CARDINAL):CARDINAL;
VAR
   count:CARDINAL;
   p1,p2:Address8086;
BEGIN
  count:=0;
  p1.a:=adr1;
  p2.a:=adr2;
  WHILE count<size
  DO
    IF p1.b^#p2.b^
    THEN
      RETURN count;
    END;
    INC(count);
    INC(p1.off);
    INC(p2.off);
  END (* while *);
  RETURN count;
END CompareBlock;


  PROCEDURE WriteDBRec
            ( alias : DBFile );

  VAR
    lock:Locks.RangeRec;
    recordpos : LONGINT;
    NeedToWrite:BOOLEAN;
  BEGIN
    IF NOT alias^.open
    THEN (* check to make sure the file is open *)
      WARN('DBFile not open in WriteDBRec');
    END;
    IF alias^.appending THEN (* if appending we have to prepare*)
      IF  NOT alias^.exclusive THEN
        lock.FileOffset := VAL( LONGINT,0);
        lock.RangeLength:=VAL(LONGINT,32);
        alias^.ErrorCode:=Locks.LockRetry(alias^.fileID,lock,10,alias^.name);
        IF alias^.ErrorCode#0 THEN WARN('Unable to lock in Header in WriteDBRec') END;
        SetFilePtr( alias^.fileID, FromStart, VAL(LONGINT,4 ));
        alias^.ErrorCode := BlockRead( alias^.fileID,  ADR(alias^.numofrecords),
                               4 );
      END;
      INC( alias^.numofrecords );
      alias^.currentrecnum := alias^.numofrecords;
      alias^.start:=alias^.numofrecords;
      IF  NOT alias^.exclusive THEN
        SetFilePtr( alias^.fileID, FromStart, VAL(LONGINT,4 ));
        alias^.ErrorCode := BlockWrite( alias^.fileID,  ADR(alias^.numofrecords),
                               4 );
      END;

      IF alias^.Safety
      THEN
        UpdateDisk(alias^.fileID);
      END;

    END;
    IF alias^.autolock  AND (LockRec(alias,alias^.currentrecnum)#0) THEN
      WARN('LockRec Failure in WriteDBRec')
    END;
    recordpos := ( alias^.currentrecnum - one ) * VAL( LONGINT,alias^.length
                   ) + VAL( LONGINT, alias^.headerlength );
    IF alias^.appending THEN
      NeedToWrite:=TRUE;
      (* unlock header only after locking  record *)
      IF  NOT alias^.exclusive THEN
        alias^.ErrorCode:=Locks.UnLock(alias^.fileID,lock);
        IF alias^.ErrorCode#0 THEN WARN('Unable to unlock Header in WriteDBRec') END;
      END;
    ELSE
      NeedToWrite:=CompareBlock(alias^.currentrec,alias^.BufferPtr,alias^.length)<
           alias^.length;
      IF alias^.autolock AND NeedToWrite THEN
        SetFilePtr( alias^.fileID, FromStart,  recordpos  );
        PrintMessage( BlockRead( alias^.fileID,  alias^.ReReadPtr ,
                                alias^.length ));
        IF CompareBlock(alias^.ReReadPtr,alias^.BufferPtr,alias^.length)<
            alias^.length
        THEN
          NeedToWrite:=alias^.fixup(alias);
          (* we update BufferPtr so Update of indexes works *)
          Move(alias^.ReReadPtr,alias^.BufferPtr,alias^.length);
        ELSE
          NeedToWrite:=TRUE; (*File was not changed *)
        END;
      END;

    END (*alias^.appendinng*);
    IF NeedToWrite THEN
      (* Find the file position for the BEGINNING of the record *)
      SetFilePtr( alias^.fileID, FromStart, recordpos  );
      (* Write the current record *)
      alias^.ErrorCode := BlockWrite( alias^.fileID,  alias^.currentrec ,
                               alias^.length );
      IF alias^.IndexList#NIL
      THEN (* most do this before modifying Buffer*)
        UpDateIndexes(alias);
      END;
      (* copy into buffer *)
      Move(alias^.currentrec,alias^.BufferPtr,alias^.length);
      IF alias^.Safety
      THEN
        UpdateDisk(alias^.fileID);
        IF alias^.MemoOpen
        THEN
          UpdateDisk(alias^.MemoHandle);
        END;
      END;
    END(* needtowrite*);
    IF alias^.autolock  AND (UnLockRec(alias,alias^.currentrecnum)#0) THEN
      WARN('UnLockRec Failure in WriteDBF')
    END;
    alias^.appending:=FALSE;
  END WriteDBRec;


  PROCEDURE GetField
            ( alias       : DBFile;
                  fieldnumber : CARDINAL;
              VAR field       : ARRAY OF CHAR );
  (* operates on the currently active record *)

  VAR
    limit : CARDINAL;

  BEGIN
    (* Find offset of field *)
    IF ( fieldnumber <= alias^.numberoffields ) AND ( fieldnumber > 0 )
    THEN
      WITH  alias^.fieldlist^[fieldnumber] DO
        limit := Min( HIGH( field )+1, size );
        Move( ADR( alias^.currentrec^[ offset] ),
         ADR( field ), limit );
      END;
      IF ( limit <= HIGH( field ) )
      THEN
        field[limit] := 0C
      END (* if *);
    ELSE
      WARN('Ilegal field number in GetField');
    END;   (* IF *)
  END GetField;

PROCEDURE Replace(alias: DBFile; fieldnumber: CARDINAL;
    field: ARRAY  OF CHAR);
VAR j, k: CARDINAL;
    EndOfStr: BOOLEAN;
BEGIN
  EndOfStr := FALSE;
  k := 0;
  WITH alias^.fieldlist^[fieldnumber] DO
    FOR j := (offset) TO
             (offset
             + size - 1) DO
      IF NOT EndOfStr THEN
        IF (k <= HIGH(field)) AND (field[k] # 0C) THEN
          alias^.currentrec^[j] := field[k];
        ELSE
          EndOfStr := TRUE;
          alias^.currentrec^[j] := ' ';
        END;
      ELSE
        alias^.currentrec^[j] := ' ';
      END;
      INC(k);
    END; (* FOR *)
  END;
END Replace;

PROCEDURE PosOfField(alias: DBFile; fieldname: ARRAY OF CHAR): CARDINAL;
  VAR  i: CARDINAL;
  BEGIN
    i := 1;
    (* field names are null terminated *)
    WHILE (i <= alias^.numberoffields) AND (NOT PosUtils.Equal(fieldname,

        alias^.fieldlist^[i].name)) DO
      INC(i);
    END;
    IF i > alias^.numberoffields THEN
     i := 0;
    END;
    RETURN i;
  END PosOfField;

   (* $O- *)

  PROCEDURE AppendBlank
            ( alias : DBFile );


  BEGIN
    IF NOT alias^.open
    THEN (* check to make sure the file is open *)
      WARN('DBFile not open in Append Blank');
    END;
    (* set buffer values *)
    alias^.appending:=TRUE;
    alias^.NumRecords:=1;
    alias^.BufferPtr:=alias^.dbbuffer;
    alias^.currentrecnum:=MAX(LONGINT);
    (* Write Recordsize number of blanks *)
    Fill(  alias^.currentrec, alias^.length, Blank );
  END AppendBlank;

  (* $O= *)


  PROCEDURE DeleteRecord
            ( alias : DBFile );

  BEGIN
    alias^.currentrec^[1] := '*';
    WriteDBRec( alias );
  END DeleteRecord;


  PROCEDURE UnDeleteRecord
            ( alias : DBFile );

  BEGIN
    alias^.currentrec^[1] := Blank;
    WriteDBRec( alias );
  END UnDeleteRecord;


  PROCEDURE Deleted
            ( alias : DBFile ) : BOOLEAN;

  BEGIN
    RETURN alias^.currentrec^[1] = '*';
  END Deleted;

  PROCEDURE LockRec(alias: DBFile;recnum:LONGINT):CARDINAL;
  VAR
    lock:Locks.RangeRec;
  BEGIN
    lock.FileOffset := ( recnum -one) *
           VAL( LONGINT,alias^.length ) + VAL( LONGINT, alias^.headerlength );
    lock.RangeLength:=VAL(LONGINT,alias^.length);
    RETURN Locks.LockRetry(alias^.fileID,lock,10,alias^.name);
  END LockRec;

  PROCEDURE UnLockRec(alias: DBFile;recnum:LONGINT):CARDINAL;
  VAR
    lock:Locks.RangeRec;
  BEGIN
    lock.FileOffset := ( recnum -one) *
           VAL( LONGINT,alias^.length ) + VAL( LONGINT, alias^.headerlength );
    lock.RangeLength:=VAL(LONGINT,alias^.length);
    RETURN Locks.UnLock(alias^.fileID,lock);
  END UnLockRec;

PROCEDURE InitMemo(handle:CARDINAL) ;
VAR
   buf:ARRAY[0..511] OF CHAR;
   i  :CARDINAL;
BEGIN
  FOR i:=1 TO 511 DO
    buf[i]:=0C;
  END (* for *);
  buf[0]:=1C;
  PrintMessage(BlockWrite(handle,ADR(buf),512));
END InitMemo;


PROCEDURE BuildDBF( fields: ARRAY OF
    DBFieldDescriptor;NumFields:CARDINAL; alias: DBFile):CARDINAL;

    (* THIS PROCEDURE WILL SILENTLY OVERWRITE ANY FILE WITH THE
       SAME NAME AS filename -- When used in a program, the
       existing files must be checked and an appropriate warning
       should be given. *)
    (* THIS PROCEDURE DOES NOT CLOSE THE CREATED FILE -- CloseDBF
       must be called to close the file *)
    (* The procedure is to read each field descriptor in the
       array until an illegal name (ie. any name that doesn't
       begin with a letter) is encountered) *)
    (* NOTE THAT FIELDNAMES IN DBASE3 ARE PADDED WITH 0C  *)

  VAR month, day, year, i, j,
     ActionTaken, offset: CARDINAL;
      dumstr, zstr: ARRAY [1..50] OF CHAR;
      (* zstr is initialized to nulls (0C) and used with
         HandleIO.BlockWrite to write blanks to the
         file *)
      tmpchar: CHAR; (* used to write CHAR values with BlockWrite *)
      filemode:BITSET;
      longtmp: LONGINT; (* used to avoid Function Type Coercion *)
    BEGIN
      IF alias^.Init#InitCode
      THEN
        WARN('Unitalized DBF in DBCreate')
      END;
      alias^.exclusive:=TRUE;
      alias^.hasmemo := FALSE;
      alias^.length := 1; (* even with no fields, the length is 1 *)
      alias^.headerlength := 0;
      alias^.numofrecords := VAL(LONGINT,0);
      alias^.currentrecnum:= VAL(LONGINT,0);
      alias^.open := TRUE;
      EnvironUtils.GetDate( month, day, year, dumstr, dumstr );
      (* open exclusive *)
        (* create if the file does not exist; truncate if it does exist *)
     IF alias^.exclusive THEN
        filemode:={1,4}
      ELSE
        filemode:={1,6} (* allow all *)
      END;
      alias^.ErrorCode := FAPI.DOSOPEN( ADR(alias^.name),
          ADR(alias^.fileID), ADR(ActionTaken), VAL(LONGINT,0),
          FAPI.FILE_NORMAL, CARDINAL({1,4}), CARDINAL(filemode),
          VAL(LONGINT,0) );
      IF alias^.ErrorCode#0 THEN RETURN alias^.ErrorCode END;
      Fill(ADR(zstr),HIGH(zstr), 0C);
      alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(zstr),32);
      (* Initialize the first 32 bytes of the header structure *)
      i := 0;
      offset := 2;
      WHILE (i <= HIGH(fields)) AND
      (i<NumFields) AND  Alph(fields[i].name[0]) DO
        fields[i].offset := offset;
        FOR j := 0 TO 9 DO
          IF FieldNameChar(fields[i].name[j]) THEN
            alias^.ErrorCode := BlockWrite(alias^.fileID,
                ADR(fields[i].name[j]), 1);
          ELSE
            alias^.ErrorCode := BlockWrite(alias^.fileID,
                ADR(zstr), 1);
          END;
        END; (* for *)
        alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(zstr),
            1); (* puts a byte in the 11th space *)
        IF CAP(fields[i].fldtype) = 'M' THEN
          alias^.hasmemo := TRUE;
          fields[i].size := 10;
        ELSIF CAP(fields[i].fldtype) = 'L' THEN
          fields[i].size := 1;
        ELSIF CAP(fields[i].fldtype) = 'D' THEN
          fields[i].size := 8;
        ELSIF (CAP(fields[i].fldtype) # 'C') AND
            (CAP(fields[i].fldtype) # 'N') THEN
          WARN('Illegal type encountered in BuildDBF');
        END;
        tmpchar := CAP(fields[i].fldtype);
        alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(tmpchar), 1);
        alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(zstr), 4);
        alias^.ErrorCode := BlockWrite(alias^.fileID,
            ADR(fields[i].size), 1);
        offset := offset + fields[i].size;
        IF CAP(fields[i].fldtype) = 'N' THEN
          alias^.ErrorCode := BlockWrite(alias^.fileID,
              ADR(fields[i].decplaces), 1);
        ELSE
          alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(zstr), 1)
        END;
        alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(zstr), 14);
        alias^.length := alias^.length + fields[i].size;
        INC(i);
      END; (* while *)
      alias^.numberoffields :=  i ;
      IF NumFields<i THEN
        alias^.numberoffields:=NumFields
      END;
      ALLOCATE(alias^.fieldlist,
          (TSIZE(DBFieldArray)DIV MaxField)*(alias^.numberoffields));
      FOR i := 0 TO alias^.numberoffields-1 DO
        alias^.fieldlist^[i+1] := fields[i];
      END;
      tmpchar := CHR(0DH);
      alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(tmpchar), 1);
      (* write the header terminator *)
      longtmp := GetFilePtr(alias^.fileID);
      alias^.headerlength := VAL(INTEGER,longtmp);
      (*
      alias^.headerlength := VAL(INTEGER,HandleIO.GetFilePtr(alias^.fileID));
      *)
        (* Next, set the first byte of the file to 03H or 83H *)
      SetFilePtr(alias^.fileID,FromStart,VAL(LONGINT,0));
      IF alias^.hasmemo THEN
        tmpchar := CHR(83H); (* the file has memo fields *)
        alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(tmpchar), 1);
        Assign(alias^.name,alias^.MemoName);
        i:=Pos( ".", alias^.MemoName);
        IF i<=HIGH(alias^.MemoName)  THEN
          alias^.MemoName[i]:=0C;
        END;
        Append(alias^.MemoName,'.DBT' );
        PrintMessage(CreateFile(alias^.MemoHandle,alias^.MemoName));
        alias^.MemoOpen:=TRUE;
        InitMemo(alias^.MemoHandle);
      ELSE
        tmpchar := 03C;
        alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(tmpchar), 1);
        (* the file doesn't have memos *)
      END; (* if *)
      tmpchar := CHR(year MOD 100);
      alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(tmpchar), 1);
        (* Write the year *)
      tmpchar := CHR(month);
      alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(tmpchar), 1);
        (* Write the month *)
      tmpchar := CHR(day);
      alias^.ErrorCode := BlockWrite(alias^.fileID, ADR(tmpchar), 1);
        (* Write the day *)
      SetFilePtr(alias^.fileID, FromStart, VAL(LONGINT,8));
      alias^.ErrorCode := BlockWrite(alias^.fileID,
          ADR(alias^.headerlength), 2);
      alias^.ErrorCode := BlockWrite(alias^.fileID,
          ADR(alias^.length), 2);
      alias^.size:=0;
      ALLOCATE(alias^.currentrec,alias^.length);
      SetDBBuffer(alias,1);(* minnimum size *)
      RETURN 0;
    END BuildDBF;

  PROCEDURE DefaultFixUp(alias:DBFile):BOOLEAN;
  (* what we do here is determine if we want to write
  in which case we return TRUE. If we need to write we will
  have to fix up any conflicts in the changed data.
  Here is what the default does:
  The record is fixed up on a field by field basis as follows:
  If all same nochange.
  If currentrec field # current buffer field then use current.
  if currentrec field = current buffer field then use disk version;
  We write always.
  *)

  VAR
    field:ARRAY[CurrentRec..ReRead] OF ARRAY[0..(MaxField-1)] OF CHAR;
    RM:RecordModeType;
    fld:CARDINAL;
  BEGIN
    FOR fld:=1 TO alias^.numberoffields DO
       FOR RM:=CurrentRec TO ReRead DO
         SetRecordMode(alias,RM);
         GetField(alias,fld,field[RM]);
       END (*for*);
       IF NOT PosUtils.Equal(field[ReRead],field[Buffer])
       THEN (* disk and buffer copys are different so we have a problem*)
         IF NOT PosUtils.Equal(field[ReRead],field[CurrentRec])
         THEN (* is new the same as on the disk?*)
           IF PosUtils.Equal(field[Buffer],field[CurrentRec])
           THEN (* did this transaction actually changer the field?*)
                (* if not set to disk version*)
             SetRecordMode(alias,CurrentRec);
             Replace(alias,fld,field[ReRead]);
           END;
         END;
       END;
    END(*for *);
    SetRecordMode(alias,CurrentRec);
    RETURN TRUE(* this version always does the write*)
  END DefaultFixUp;

END ModBase3.