UNIT Tdb;

{ RWI 950804: Added file locking                                    }
{ RWI 950810: TdbCloseAndErase en TdbCloseAndRename gebruiken nu    }
{             TdbLastIOResult                                       }
{ RWI 960113: TdbWrite was overwriting the first byte of the next   }
{             cached record when the IOSize was not an even number. }
{ RWI 961128: Added OS/2 support and TdbSeemsLocked.                }

{$IFNDEF DPMI}
{$IFNDEF OS2}
 {$DEFINE Caching}
{$ENDIF}
{$ENDIF}

INTERFACE

CONST MaxTdbs = 10;            { maximaal 10 databases tegelijkertijd open }
      TdbHeaderLen = 25;         { lengte van de header voor de .TDB files }
      TdbClosedNr = 0;

TYPE TdbNrType = 0..MaxTdbs;
     TdbResultType = (_TdbOk,           { actie gelukt }
                      _TdbNotFound,     { file niet gevonden }
                      _TdbTableFull,    { interne tabel zit vol }
                      _TdbCannotCreate  { kan geen database file aanmaken }
                     );
     TdbHeaderString = STRING[TdbHeaderLen];


VAR TdbLastResult   : TdbResultType;
    TdbLastIOResult : INTEGER;
    TdbLastRawSize  : LONGINT;


FUNCTION  TdbOpen (TdbPath : STRING; VAR TdbNr : TdbNrType) : TdbResultType;
FUNCTION  TdbSeemsLocked (TdbNr : TdbNrType) : BOOLEAN;
FUNCTION  TdbReadHeader (TdbNr : TdbNrType) : TdbHeaderString;
PROCEDURE TdbSetHeader (TdbNr : TdbNrType; Header : TdbHeaderString);
FUNCTION  TdbCreate (TdbPath : STRING; Header : TdbHeaderString; VAR TdbNr : TdbNrType) : TdbResultType;
PROCEDURE TdbClose (TdbNr : TdbNrType);
PROCEDURE TdbSetIO (TdbNr : TdbNrType; IOBufferSize : WORD);
FUNCTION  TdbRecCount (TdbNr : TdbNrType) : LONGINT;
FUNCTION  TdbRead (TdbNr : TdbNrType; Position : LONGINT; VAR Buffer) : BOOLEAN;
FUNCTION  TdbWrite (TdbNr : TdbNrType; Position : LONGINT; VAR Buffer) : BOOLEAN;
PROCEDURE TdbCut (TdbNr : TdbNrType; Position : LONGINT);
FUNCTION  TdbCache (TdbNr : TdbNrType) : BOOLEAN;
FUNCTION  TdbGetFilename (TdbNr : TdbNrType) : STRING;

FUNCTION  TdbCloseAndErase (TdbNr : TdbNrType) : BOOLEAN;
FUNCTION  TdbCloseAndRename (TdbNr : TdbNrType; FileName : STRING) : BOOLEAN;

FUNCTION  TdbLockFile (TdbNr : TdbNrType) : BOOLEAN;
PROCEDURE TdbUnLockFile (TdbNr : TdbNrType);


IMPLEMENTATION

USES
{$IFDEF Caching}
 {$IFNDEF DPMI}
     XmsLib,
 {$ENDIF}
{$ENDIF}
     Ramon;

CONST MAX_CBUFS = 255;       { 255 * 65528 = almost 16 megs }

TYPE TdbStatusType = (Open,Closed);

     TdbInfoRecord = RECORD
                           Status      : TdbStatusType;
                           Path        : STRING[128];
                           IOFile      : FILE;
                           IOBufSize   : WORD;
                           CurrPos     : LONGINT;
                           {$IFDEF Caching}
                           Cached      : BOOLEAN;
                           CachedRecNr : LONGINT;
                           {$IFDEF DPMI}
                           CBufCount   : 0..MAX_CBUFS;
                           CBufSize    : ARRAY[1..MAX_CBUFS] OF WORD;
                           CBufPtr     : ARRAY[1..MAX_CBUFS] OF POINTER;
                           {$ELSE}
                           XmbHandle   : WORD;               { voor de cache }
                           XmsIOSize   : WORD;
                           {$ENDIF}
                           {$ENDIF}
                     END;


VAR TdbInfo        : ARRAY[TdbNrType] OF TdbInfoRecord;
{$IFDEF Caching}
 {$IFNDEF DPMI}
    CacheBufje     : POINTER;
    CacheBufjeSize : WORD;
 {$ENDIF}
{$ENDIF}


{--------------------------------------------------------------------------}
{ TdbGetFilename                                                           }
{                                                                          }
FUNCTION TdbGetFilename (TdbNr : TdbNrType) : STRING;
BEGIN
     TdbGetFilename:=TdbInfo[TdbNr].Path;
END;


{--------------------------------------------------------------------------}
{ TdbOpen                                                                  }
{                                                                          }
{ Open de file waarvan het pad is opgegeven, als de file niet aanwezig is, }
{ geef dan de foutcode _TdbNotFound terug.                                 }
{                                                                          }
FUNCTION TdbOpen (TdbPath : STRING; VAR TdbNr : TdbNrType) : TdbResultType;

VAR Lp : TdbNrType;

BEGIN
     FOR Lp:=1 TO MaxTdbs DO
         WITH TdbInfo[Lp] DO
              IF (Status = Closed) THEN
              BEGIN
                   Path:=TdbPath;
                   Assign (IOFile,Path);
                   {$I-} Reset (IOFile,1); {$I+}
                   TdbLastIOResult:=IOResult;

                   IF (TdbLastIOResult <> 0) THEN
                   BEGIN
                        TdbOpen:=_TdbNotFound; { resultaat: file not found }
                        TdbLastResult:=_TdbNotFound;
                        Exit;
                   END;

                   Status:=Open;                    { nu is ie wel geopend }
                   CurrPos:=-1;
{$IFDEF Caching}
                   Cached:=FALSE;                      { nog niet gecached }
{$ENDIF}
                   TdbNr:=Lp;                    { tabel index terug geven }
                   TdbOpen:=_TdbOk;                       { resultaat: oke }
                   TdbLastResult:=_TdbOk;
                   TdbLastRawSize:=FileSize (IOFile);
                   Exit;
              END;

     TdbOpen:=_TdbTableFull;                   { resultaat: max tdb's open }
     TdbLastResult:=_TdbTableFull;
END;


{--------------------------------------------------------------------------}
{ TdbSeemsLocked                                                           }
{                                                                          }
{ Deze routine controleert of de database benadert kan worden.             }
{                                                                          }
FUNCTION TdbSeemsLocked (TdbNr : TdbNrType) : BOOLEAN;

VAR AByte: BYTE;

BEGIN
     TdbSeemsLocked:=TRUE;

     WITH TdbInfo[TdbNr] DO
     BEGIN
          {$I-} Seek (IOFile,0); {$I+}
          IF (IOResult <> 0) THEN
             Exit;

          {$I-} BlockRead (IOFile,AByte,1); {$I+}
          IF (IOResult <> 0) THEN
             Exit;
     END; { with }

     TdbSeemsLocked:=FALSE;
END;


{--------------------------------------------------------------------------}
{ TdbReadHeader                                                            }
{                                                                          }
{ Deze routine leest de header uit de .TDB file en geeft deze terug.       }
{                                                                          }
FUNCTION TdbReadHeader (TdbNr : TdbNrType) : TdbHeaderString;

VAR Header : TdbHeaderString;

BEGIN
     WITH TdbInfo[TdbNr] DO
     BEGIN
          IF (FileSize (IOFile) < TdbHeaderLen) THEN
             TdbReadHeader:='NO HEADER INSTALLED'
          ELSE BEGIN
               Seek (IOFile,0);
               BlockRead (IOFile,Header,TdbHeaderLen);
               TdbReadHeader:=Header;
               CurrPos:=-1; { ivm read/write optimalisaties }
          END;
     END; { with }
END;


{--------------------------------------------------------------------------}
{ TdbSetHeader                                                             }
{                                                                          }
{ Met deze routine kan de header van een database vervangen worden.        }
{                                                                          }
PROCEDURE TdbSetHeader (TdbNr : TdbNrType; Header : TdbHeaderString);

VAR Lp : BYTE;

BEGIN
     WITH TdbInfo[TdbNr] DO
     BEGIN
          IF (Length (Header) < TdbHeaderLen) THEN
             FOR Lp:=Length (Header)+1 TO TdbHeaderLen DO
                 Header[Lp]:=#26; { ctrl-z }
          Seek (IOFile,0);
          BlockWrite (IOFile,Header,TdbHeaderLen);
     END;
END;


{--------------------------------------------------------------------------}
{ TdbCreate                                                                }
{                                                                          }
{ Maak een nieuwe database aan.                                            }
{                                                                          }
FUNCTION TdbCreate (TdbPath : STRING; Header : TdbHeaderString; VAR TdbNr : TdbNrType) : TdbResultType;

VAR Lp  : TdbNrType;

BEGIN
     FOR Lp:=1 TO MaxTdbs DO
         WITH TdbInfo[Lp] DO
              IF (Status = Closed) THEN
              BEGIN
                   Path:=TdbPath;
                   Assign (IOFile,Path);
                   {$I-} ReWrite (IOFile,1); {$I+}
                   TdbLastIOResult:=IOResult;

                   IF (TdbLastIOResult <> 0) THEN
                   BEGIN
                        TdbCreate:=_TdbCannotCreate;
                        TdbLastResult:=_TdbCannotCreate;
                        Exit;
                   END;

                   Status:=Open;
                   CurrPos:=-1;
{$IFDEF Caching}
                   Cached:=FALSE;                      { nog niet gecached }
 {$IFDEF DPMI}
                   CBufCount:=0;
 {$ENDIF}
{$ENDIF}
                   TdbNr:=Lp;
                   TdbCreate:=_TdbOk;
                   TdbLastResult:=_TdbOk;

                   TdbSetHeader (TdbNr,Header);

                   Exit;
              END; { with }

     TdbCreate:=_TdbTableFull;
     TdbLastResult:=_TdbTableFull;
END;


{--------------------------------------------------------------------------}
{ TdbClose                                                                 }
{                                                                          }
{ Sluit de opgegeven Tdb file.                                             }
{                                                                          }
PROCEDURE TdbClose (TdbNr : TdbNrType);

VAR AnyCached : BOOLEAN;
    Lp        : TdbNrType;
    CLp       : 0..MAX_CBUFS;

BEGIN
     WITH TdbInfo[TdbNr] DO
     BEGIN
          IF (Status = Open) THEN
             Close (IOFile);

          Status:=Closed;

{$IFDEF Caching}
          IF Cached THEN
          BEGIN
 {$IFDEF DPMI}
               FOR Lp:=1 TO CBufCount DO
                   FreeMem (CBufPtr[Lp],CBufSize[Lp]);
               CBufCount:=0;
 {$ELSE}
               FreeXmb (XmbHandle);
 {$ENDIF}
               Cached:=FALSE;
          END;
{$ENDIF}
     END; { with }

{$IFDEF Caching}
 {$IFNDEF DPMI}
     AnyCached:=FALSE;
     FOR Lp:=1 TO MaxTdbs DO
         IF (TdbInfo[Lp].Status = Open) THEN
            AnyCached:=AnyCached OR TdbInfo[Lp].Cached;

     IF (NOT AnyCached) THEN
     BEGIN
          FreeMem (CacheBufje,CacheBufjeSize);
          CacheBufjeSize:=0;
     END;
 {$ENDIF}
{$ENDIF}
END;


{--------------------------------------------------------------------------}
{ TdbSetIO                                                                 }
{                                                                          }
{ Zet de specifieke zaken voor deze tdb.                                   }
{                                                                          }
PROCEDURE TdbSetIO (TdbNr : TdbNrType; IOBufferSize : WORD);
BEGIN
     WITH TdbInfo[TdbNr] DO
     BEGIN
          IOBufSize:=IOBufferSize;

{$IFDEF Caching}
 {$IFNDEF DPMI}
          IF ((IOBufSize AND 1) > 0) THEN
             XmsIOSize:=IOBufSize+1 { moet altijd een even waarde zijn }
          ELSE
              XmsIOSize:=IOBufSize;
 {$ENDIF}
{$ENDIF}
     END; { with }
END;


{--------------------------------------------------------------------------}
{ TdbRecCount                                                              }
{                                                                          }
{ Geef het aantal records dat in de file is opgeslagen terug.              }
{                                                                          }
FUNCTION TdbRecCount (TdbNr : TdbNrType) : LONGINT;
BEGIN
     WITH TdbInfo[TdbNr] DO
          TdbRecCount:=((FileSize (IOFile) - (TdbHeaderLen +1)) DIV IOBufSize);
END;


{--------------------------------------------------------------------------}
{ TdbRead                                                                  }
{                                                                          }
{ Lees een record uit de tdb vanaf de opgegeven positie en sla deze op in  }
{ het IO window.                                                           }
{                                                                          }
FUNCTION TdbRead (TdbNr : TdbNrType; Position : LONGINT; VAR Buffer) : BOOLEAN;
BEGIN
     TdbRead:=TRUE;
     Dec (Position);

     WITH TdbInfo[TdbNr] DO
     BEGIN
{$IFDEF Caching}
          IF Cached AND (Position < CachedRecNr) THEN
          BEGIN
 {$IFDEF DPMI}
               { zoek het blok waarin het record staat en geef die terug }
               ##
 {$ELSE}
               CopyFromXmb (XmsIOSize,CacheBufje,XmbHandle,Position*IOBufSize);
               Move (CacheBufje^,Buffer,IOBufSize);
 {$ENDIF}
          END ELSE
{$ENDIF}
          BEGIN
               {$I-}
               IF (CurrPos <> Position) THEN
                  Seek (IOFile,Position*IOBufSize+TdbHeaderLen+1);

               BlockRead (IOFile,Buffer,IOBufSize);
               CurrPos:=Position+1;
               {$I+}

               IF (IOResult <> 0) THEN
                  TdbRead:=FALSE;

          END; { if not cached }
     END; { with }
END;


{--------------------------------------------------------------------------}
{ TdbWrite                                                                 }
{                                                                          }
{ Sla het record in het IO window op in de tdb op de opgegeven positie.    }
{                                                                          }
FUNCTION TdbWrite (TdbNr : TdbNrType; Position : LONGINT; VAR Buffer) : Boolean;

TYPE BigArray = ARRAY[1..65000] OF BYTE;

VAR HelpBuf : ARRAY[0..2] OF BYTE;

BEGIN
     Dec (Position);
     TdbWrite:=TRUE;

     WITH TdbInfo[TdbNr] DO
     BEGIN
{$IFDEF Caching}
          IF Cached AND (Position < CachedRecNr) THEN
          BEGIN
 {$IFDEF DPMI}
               { zoek het juiste memory block en kopieer het record }
               ##
 {$ELSE}
               { RWI 960113: Gaat mis als XmsIOSize > IOBufSize en er     }
               {             nog records volgen op dit record, want dan   }
               {             wordt de eerste byte van het volgende record }
               {             overschreven!!                               }
               IF (XmsIOSize > IOBufSize) THEN
               BEGIN
                    { read first two bytes from next record }
                    CopyFromXmb (2,@HelpBuf[1],XmbHandle,(Position+1)*IOBufSize);

                    { write the current record, except the last byte }
                    CopyToXmb (XmsIOSize-2,@Buffer,XmbHandle,Position*IOBufSize);

                    { copy the last byte from this record }
                    HelpBuf[0]:=BigArray (Buffer)[IOBufSize];

                    { write the last byte of this record and the first }
                    { byte of the next record again.                   }
                    CopyToXmb (2,@HelpBuf,XmbHandle,Position*IOBufSize+XmsIOSize-2);
               END ELSE
                   CopyToXmb (XmsIOSize,@Buffer,XmbHandle,Position*IOBufSize);
 {$ENDIF}
          END;
{$ENDIF}
          {$I-}
          IF (CurrPos <> Position) THEN
             Seek (IOFile,Position*IOBufSize+TdbHeaderLen+1);

          BlockWrite (IOFile,Buffer,IOBufSize);
          CurrPos:=Position+1;
          {$I+}

          IF (IOResult <> 0) THEN
             TdbWrite:=FALSE;
     END; { with }
END;


{--------------------------------------------------------------------------}
{ TdbCut                                                                   }
{                                                                          }
{ Deze routine kapt de database file op de opgegeven positie af en wist    }
{ daarmee alle records inclusief de opgegeven positie.                     }
{                                                                          }
PROCEDURE TdbCut (TdbNr : TdbNrType; Position : LONGINT);
BEGIN
     Dec (Position);

     WITH TdbInfo[TdbNr] DO
     BEGIN
{$IFDEF Caching}
          IF Cached THEN
          BEGIN
               { eh..., tja... }
          END;
{$ENDIF}
          IF (CurrPos <> Position) THEN
             Seek (IOFile,Position*IOBufSize+TdbHeaderLen+1);

          Truncate (IOFile);
          CurrPos:=-1; { zekerheid, waar zal ie nu staan? Nou? Nou?!! }
     END; { with }
END;


{--------------------------------------------------------------------------}
{ TdbCache                                                                 }
{                                                                          }
{ Deze routine zet een cache op voor een geopende Tdb. Bij het sluiten     }
{ verdwijnt de cache automatisch. Alle records worden gecached en meteen   }
{ ingelezen zodra het geheugen is aangevraagd. Moet aangeroepen worden na  }
{ een Open of Create en SetIO, nooit voor een van deze calls.              }
{                                                                          }
FUNCTION TdbCache (TdbNr : TdbNrType) : BOOLEAN;
{$IFDEF Caching}
VAR BufferPtr   : POINTER;
    BufferSize  : WORD;
    BytesRead   : WORD;
    MoveCount   : WORD;
    StorePos    : LONGINT;
    BytesNeeded : LONGINT;
    KBNeeded    : WORD;
    Lp          : LONGINT;

BEGIN
     TdbCache:=FALSE; { assume succes }

     WITH TdbInfo[TdbNr] DO
     BEGIN
          IF (NOT Cached) THEN
          BEGIN
               BytesNeeded:=FileSize (IOFile);
               KBNeeded:=BytesNeeded DIV 1024;
               IF ((BytesNeeded MOD 1024) > 0) THEN
                  Inc (KBNeeded);

               XmbHandle:=0;

{$IFDEF DPMI}
               DPMI_Memory:=GlobalAlloc (GMEM_FIXED,KBNeeded*1024);
               IF (DPMI_Memory <> 0) THEN
               BEGIN
                    { Vraag DPMI manager om pointer naar huidig }
                    { geheugen blok.                            }
                    DPMI_Pointer:=GlobalLock (DPMI_Memory);

                    { file inlezen in blokken van maximaal 16Kb }
                    IF (MaxAvail > 16384) THEN BufferSize:=16384
                                          ELSE BufferSize:=MaxAvail;
                    IF ((BufferSize AND 1) > 0) THEN
                       Dec (BufferSize);

                    GetMem (BufferPtr,BufferSize);

                    StorePos:=0;
                    Seek (IOFile,TdbHeaderLen+1); { header niet cachen }
                    REPEAT
                          BlockRead (IOFile,BufferPtr^,BufferSize,BytesRead);

                          IF (BytesRead > 0) THEN
                          BEGIN
                               IF ((BytesRead AND 1) > 0) THEN
                                  Inc (BytesRead); { altijd een even getal }

                     ### kan mis gaan als ie over de rand van het DPMI buffer gaat!
                               Move (BufferPtr,DPMI_Pointer[StorePos],BytesRead);
                               StorePos:=StorePos+BytesRead;
                          END;
                    UNTIL (BytesRead = 0);

                    FreeMem (BufferPtr,BufferSize);

                    IF (XmsIOSize > CacheBufjeSize) THEN
                    BEGIN
                         IF (CacheBufjeSize > 0) THEN
                            FreeMem (CacheBufje,CacheBufjeSize);
                         CacheBufjeSize:=XmsIOSize;
                         GetMem (CacheBufje,CacheBufjeSize);
                    END;
              END;
{$ELSE}
              IF AllocateXmb (KBNeeded,XmbHandle) THEN
              BEGIN
{ file inlezen in blokken van maximaal 16Kb }
                    IF (MaxAvail > 16384) THEN BufferSize:=16384
                                          ELSE BufferSize:=MaxAvail;
                    IF ((BufferSize AND 1) > 0) THEN
                       Dec (BufferSize);

                    GetMem (BufferPtr,BufferSize);

                    StorePos:=0;
                    Seek (IOFile,TdbHeaderLen+1); { header niet cachen }
                    REPEAT
                          BlockRead (IOFile,BufferPtr^,BufferSize,BytesRead);

                          IF (BytesRead > 0) THEN
                          BEGIN
                               MoveCount:=BytesRead;

                               IF ((MoveCount AND 1) > 0) THEN
                                  Inc (MoveCount); { altijd een even getal }

                               CopyToXmb (MoveCount,BufferPtr,XmbHandle,StorePos);

                               StorePos:=StorePos+BytesRead;
                          END;
                    UNTIL (BytesRead = 0);

                    FreeMem (BufferPtr,BufferSize);

                    IF (XmsIOSize > CacheBufjeSize) THEN
                    BEGIN
                         IF (CacheBufjeSize > 0) THEN
                            FreeMem (CacheBufje,CacheBufjeSize);
                         CacheBufjeSize:=XmsIOSize;
                         GetMem (CacheBufje,CacheBufjeSize);
                    END;
{$ENDIF} {!DPMI}
                    { Alle records worden ingelezen, dus de cache }
                    { bevat hetzelfde aantal records als op DIT   }
                    { moment de database                          }
                    CachedRecNr:=TdbRecCount (TdbNr);
                    CurrPos:=-1;
                    Cached:=TRUE;
               END; { alloc mislukt }
          END; { nog niet gecached }

          IF (NOT Cached) THEN
             TdbCache:=TRUE; { failed to cache database }

     END; { with }
END;
{$ELSE} {!Caching}
BEGIN
     TdbCache:=FALSE; { succes }
END;
{$ENDIF}


{-------------------------------------------------------------------------}
{ TdbCloseAndErase                                                        }
{                                                                         }
{ Deze routine sluit de gegeven database, om hem vervolgens te            }
{ verwijderen.                                                            }
{                                                                         }
FUNCTION TdbCloseAndErase (TdbNr : TdbNrType) : BOOLEAN;
BEGIN
     TdbClose (TdbNr);
     {$I-} Erase (TdbInfo[TdbNr].IOFile); {$I+} TdbLastIOResult:=IOResult;
     TdbCloseAndErase:=(TdbLastIOResult = 0);
END;


{-------------------------------------------------------------------------}
{ TdbCloseAndRename                                                       }
{                                                                         }
{ Deze routine sluit de gegeven database, om hem vervolgens te renamen.   }
{                                                                         }
FUNCTION TdbCloseAndRename (TdbNr : TdbNrType; FileName : STRING) : BOOLEAN;
BEGIN
     TdbClose (TdbNr);
     {$I-} Rename (TdbInfo[TdbNr].IOFile,FileName); {$I+} TdbLastIOResult:=IOResult;
     TdbCloseAndRename:=(TdbLastIOResult = 0);
END;


{---------------------------------------------------------------------------}
{ TdbLockFile                                                               }
{                                                                           }
{ Deze routine probeert een database te locken. Als dat niet lukt, dan      }
{ wordt FALSE terug gegeven, anders TRUE.                                   }
{                                                                           }
FUNCTION TdbLockFile (TdbNr : TdbNrType) : BOOLEAN;
BEGIN
     TdbLockFile:=LockFile (TdbInfo[TdbNr].IOFile);
END;


{---------------------------------------------------------------------------}
{ TdbUnLockFile                                                             }
{                                                                           }
{ Deze routine unlockt een file die daarvoor met Lock geblokeerd is.        }
{                                                                           }
PROCEDURE TdbUnLockFile (TdbNr : TdbNrType);
BEGIN
     UnLockFile (TdbInfo[TdbNr].IOFile);
END;


{--------------------------------------------------------------------------}
{ Unit Initialisation                                                      }
{                                                                          }
{ Zet de status van alle Tdb records op Closed.                            }
{                                                                          }

VAR Lp : BYTE;

BEGIN
     FOR Lp:=1 TO MaxTdbs DO
     BEGIN
          TdbInfo[Lp].Status:=Closed;
{$IFDEF Caching}
          TdbInfo[Lp].Cached:=FALSE;
{$ENDIF}
     END;

{$IFDEF Caching}
     CacheBufjeSize:=0;
{$ENDIF}
END.
