Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PSPPD100.ZIP/DBASE.PAS

Pascal/Delphi Source File | 1992-09-18 | 26.0 KB | 1,258 lines

{

                                                      ╔══════════════════╗
                                                      ║    Pure Power    ║
                                                      ║   Database Ctrl. ║
                                                      ║    Rev.  1.00    ║
                                                      ╚══════════════════╝

}

{$F-} {$O-} {$A+} {$G-} {$I-}
{$V-} {$B-} {$X-} {$N+} {$E+}

{$I FINAL.PAS}

{$IFDEF FINAL}
  {$R-} {$S-}
  {$D-} {$L-}
{$ENDIF}

Unit DBase;

Interface

Uses Dos,Strings,DBStack;

Const
  TempFile      = '$$PPDB$$.$$$';
  Signature     = 'PPDATABASE';

  CurVerHi      = 1;
  CurVerLo      = 00;

  NameFlag      = 1;
  InEXEFlag     = 2;

  DirFlag       = 1;

  C_None        = 0;
  C_ARJ         = 1;
  C_ZIP         = 2;
  C_LHA         = 3;
  C_ZOO         = 4;
  C_Other       = 49;

Type
  DBaseDirPtr   = ^DBaseDir;

  DBaseDir      = Record
                    Name   :String[12];
                    Number :Word;
                    Offset :LongInt;
                    Size   :Word;
                    Attr   :Byte;
                    Next   :DBaseDirPtr;
                  End;

  DBaseMain     = Record
                    Total  :Word;
                    Root   :Pointer;
                    Data   :DBaseDirPtr;
                  End;

  DBaseFile     = Object

                    PrevDirs  :StackObject;

                    HaveNames,
                    InEXE     :Boolean;

                    DataSize  :Word;
                    Compress,
                    DirEntry  :Byte;     {Length of each Dir entry in bytes}

                    FileName  :PathStr;
                    FileStart,
                    FileEnd   :LongInt;
                    Dir       :DBaseMain;

                    VerHi,
                    VerLo     :Byte;

                    Procedure Init;
                    Procedure GotoDir           (Number:Word);
                    Procedure DelDir            (Number:Word);
                    Procedure AppendDir         (Var Data:DBaseDir);
                    Procedure AdjustDirsAfter   (Offset,BySize:LongInt);
                    Procedure AdjustStackAfter  (Offset,BySize:LongInt);
                    Procedure DestroyDirs;

                    Function  FindEXESignature  (LookFrom:LongInt;Var EndPtr:LongInt):Word;
                    Function  WriteHeader       :Word;
                    Function  FindDir           (Var Data:DBaseDir):Word;
                    Function  SetDirFlag        (Name:String;Number:Word;Flag:Boolean):Word;

                    Function  AddCompression    (FName:PathStr;Method:Byte):Word;
                    Function  CreateDatabase    (FName:PathStr;NameOpt:Boolean):Word;
                    Function  OpenDatabase      (FName:PathStr;DStart,DEnd:LongInt):Word;
                    Function  CloseDatabase     :Word;
                    Function  CrossIntoDatabase (Name:String;Number:Word):Word;
                    Function  CrossOutOfDatabase:Word;

                    Function  BlockInsert       (Offset:LongInt;Data:Pointer;Size:Word):Word;
                    Function  BlockOverwrite    (Offset:LongInt;Data:Pointer;Size:Word):Word;
                    Function  BlockDelete       (Offset:LongInt;             Size:Word):Word;

                    Function  ReadDir           :Word;
                    Function  WriteDir          :Word;

                    Function  NewData           (Name:String;Number:Word;Data:Pointer;Size:Word):Word;
                    Function  ModData           (Name:String;Number:Word;Data:Pointer):Word;
                    Function  GetData           (Name:String;Number:Word;Data:Pointer):Word;
                    Function  DelData           (Name:String;Number:Word):Word;

                    Function  NewDataFile       (Name:String;Number:Word;FName:String):Word;
                    Function  ModDataFile       (Name:String;Number:Word;FName:String):Word;
                    Function  GetDataFile       (Name:String;Number:Word;FName:String):Word;

                    Function  ModEXE            (Offset:LongInt;Data:Pointer;Size:Word):Word;
                    Function  GetEXE            (Offset:LongInt;Data:Pointer;Size:Word):Word;

                    Private

                    F         :File;

                  End;

Function  DatabaseErrorMsg(ErrorNumber:Word):String;


Implementation

Procedure DBaseFile.Init;
Begin
  Dir.Total:=0;
  Dir.Root :=NIL;
  Dir.Data :=NIL;

  FileStart:=0;
  FileEnd  :=0;
  DirEntry :=0;
  DataSize :=0;
  FileName :='';

  VerHi    :=CurVerHi;
  VerLo    :=CurVerLo;

  PrevDirs.Init;
End;

Procedure DBaseFile.GotoDir(Number:Word);

Var
  T:Word;

Begin
  If Dir.Root=NIL Then Exit;
  T:=1;
  Dir.Data:=Dir.Root;
  While (T<Number) And (Dir.Data^.Next<>NIL) do
  Begin
    Dir.Data:=Dir.Data^.Next;
    Inc(T);
  End;
End;

Procedure DBaseFile.DelDir(Number:Word);

Var
  P:DBaseDirPtr;
  Q:Pointer;

Begin
  Dec(Dir.Total);
  If Number=1 Then
  Begin
    GotoDir(1);
    P:=Dir.Data;
    Dir.Root:=P^.Next;
    Dir.Data:=P^.Next;
    Dispose(P);
  End
  Else
  Begin
    GotoDir(Number);
    Q:=Dir.Data^.Next;
    P:=Dir.Data;
    GotoDir(Number-1);
    Dispose(P);
    Dir.Data^.Next:=Q;
  End;
End;

Procedure DBaseFile.AppendDir(Var Data:DBaseDir);

Var
  Q     :DBaseDirPtr;

Begin
  New(Q);
  Q^:=Data;
  Q^.Next:=NIL;

  Inc(Dir.Total);
  If Dir.Total=1 Then
  Begin
    Dir.Root:=Q;
    Dir.Data:=Q;
  End
  Else
  Begin
    GotoDir(65535);
    Dir.Data^.Next:=Q;
  End;
End;

Procedure DBaseFile.AdjustDirsAfter(Offset,BySize:LongInt);
Begin
  Dir.Data:=Dir.Root;
  While Dir.Data<>NIL do
  Begin
    If Dir.Data^.Offset>=Offset Then
      Inc(Dir.Data^.Offset,BySize);
    Dir.Data:=Dir.Data^.Next;
  End;
End;

Procedure DBaseFile.AdjustStackAfter(Offset,BySize:LongInt);

Const
  LastOffset:LongInt = 0;

Var
  OldStack :StackObject;
  DirInfo  :Data;

Begin
  If Offset<>MaxLongInt Then  {Are we given an offset?}
    LastOffset:=Offset        {Yes, so use it and remember it}
  Else
    Offset:=LastOffset;       {No, so use the last one we were given}

  OldStack.Init;
  While Not PrevDirs.Empty do
  Begin
    PrevDirs.Pop(DirInfo);
    If DirInfo.FileStart>=Offset Then Inc(DirInfo.FileStart,BySize);
    If DirInfo.FileEnd  >=Offset Then Inc(DirInfo.FileEnd  ,BySize);
    OldStack.Push(DirInfo);
  End;

  While Not OldStack.Empty do
  Begin
    OldStack.Pop(DirInfo);
    PrevDirs.Push(DirInfo);
  End;
End;

Procedure DBaseFile.DestroyDirs;
Begin
  Dir.Data:=Dir.Root;
  While Dir.Data<>NIL do
  Begin
    Dir.Root:=Dir.Data^.Next;
    Dispose(Dir.Data);
    Dir.Data:=Dir.Root;
  End;
  Dir.Total:=0;
End;

Function DBaseFile.FindEXESignature(LookFrom:LongInt;Var EndPtr:LongInt):Word;

Const
  MaxAm = 255;

Var
  CheckSig:String;
  NewSig  :String[15];
  Found   :LongInt;
  Amount  :LongInt;
  ThisTime:LongInt;

Begin
  NewSig:=Signature+'EX';
  Found :=0;
  Amount:=FileSize(F)-LookFrom;
  PadVar('',CheckSig,255);
  NewSig:=NewSig+'E';
  Seek(F,LookFrom);

  While (Amount<>0) And (Found=0) do
  Begin
    If Amount>MaxAm Then
      ThisTime:=MaxAm
    Else
      ThisTime:=Amount;

    BlockRead(F,CheckSig[1],ThisTime);
    If Pos(NewSig,CheckSig)>0 Then
      Found:=FilePos(F)-ThisTime+Pos(NewSig,CheckSig)+Length(NewSig)-4
    Else
    Begin
      If EOF(F) Then
        Amount:=0
      Else
      Begin
        Dec(Amount,ThisTime-18);
        Seek(F,FilePos(F)-18);
      End;
    End;
  End;
  EndPtr:=Found;
  FindEXESignature:=IOResult;
End;

Function DBaseFile.WriteHeader:Word;

Var
  Hdr :String;

Begin
  If InEXE Then
    Move(DataSize,Hdr[1],2)
  Else
    Move(Dir.Total,Hdr[1],2);

  Hdr[3]:=#0;
  Hdr[4]:=Chr(Compress);

  Hdr[5]:=Chr(0);
  If InEXE Then
    Hdr[5]:=Chr(Ord(Hdr[4]) Or InEXEFlag);
  If HaveNames Then
    Hdr[5]:=Chr(Ord(Hdr[4]) Or NameFlag);

  Hdr[0]:=#5;
  Hdr:=Hdr+Chr(CurVerHi)+Chr(CurVerLo)+Signature;

  BlockWrite(F,Hdr[1],17);
  WriteHeader:=IOResult;
End;

Function DBaseFile.SetDirFlag(Name:String;Number:Word;Flag:Boolean):Word;

Var
  WhichOne :Word;
  DirData  :DBaseDir;

Begin
  DirData.Name   :=Name;
  DirData.Number :=Number;
  WhichOne:=FindDir(DirData);
  If WhichOne<>0 Then
  Begin
    If Flag Then
      Dir.Data^.Attr:=Dir.Data^.Attr Or DirFlag
    Else
      Dir.Data^.Attr:=Dir.Data^.Attr And (Not DirFlag);
    SetDirFlag:=WriteDir;
  End
  Else
    SetDirFlag:=603;
End;

Function DBaseFile.AddCompression(FName:PathStr;Method:Byte):Word;

Label
  EndProc;

Var
  ErrorCode:Word;

Begin
  Assign(F,FName);
  Reset(F,1);
  ErrorCode:=IOResult;
  If ErrorCode>0 Then Goto EndProc;

  InEXE      :=False;
  HaveNames  :=False;
  Dir.Total  :=0;
  Compress   :=Method;

  Seek(F,FileSize(F));
  ErrorCode:=WriteHeader;
  Close(F);

EndProc:

  AddCompression:=ErrorCode;
End;

Function DBaseFile.CreateDatabase(FName:PathStr;NameOpt:Boolean):Word;
     {No Database may be open.  The Database is NOT opened.}
Var
  ErrorCode :Word;

Begin
  Init;

  InEXE        :=False;
  HaveNames    :=NameOpt;
  FileName     :=FName;
  Compress     :=0;

  Assign(F,FName);
  Rewrite(F,1);
  ErrorCode:=IOResult;
  If ErrorCode=0 Then ErrorCode:=WriteHeader;
  Close(F);

  Init;
  CreateDatabase:=ErrorCode;
End;

Function DBaseFile.FindDir(Var Data:DBaseDir):Word;
         {Returns the position number in the list, not the file number}
Var
  Found:Boolean;
  Count:Word;

Begin
  FindDir:=0;
  If Dir.Total=0 Then Exit;
  Found:=False;

  If HaveNames Then
  Begin
    Count:=0;
    Dir.Data:=Dir.Root;
    While (Dir.Data<>NIL) And Not Found do
    Begin
      Inc(Count);
      If (Data.Name=Dir.Data^.Name) And (Data.Number=Dir.Data^.Number) Then
        Found:=True
      Else
        Dir.Data:=Dir.Data^.Next;
    End;

    If Not Found Then
    Begin
      Count:=0;
      Dir.Data:=Dir.Root;
      While (Dir.Data<>NIL) And Not Found do
      Begin
        Inc(Count);
        If (Data.Name=Dir.Data^.Name) Then
          Found:=True
        Else
          Dir.Data:=Dir.Data^.Next;
      End;
    End;

  End;

  If Not Found Then
  Begin
    Count:=0;
    Dir.Data:=Dir.Root;
    While (Dir.Data<>NIL) And Not Found do
    Begin
      Inc(Count);
      If (Data.Number=Dir.Data^.Number) Then
        Found:=True
      Else
        Dir.Data:=Dir.Data^.Next;
    End;
  End;

  If Found Then
  Begin
    Data.Offset:=Dir.Data^.Offset;
    Data.Size  :=Dir.Data^.Size;
    Data.Attr  :=Dir.Data^.Attr;
    FindDir    :=Count;
  End;
End;

Function DBaseFile.OpenDatabase(FName:PathStr;DStart,DEnd:LongInt):Word;

Label
  EndProc,
  EndProcAndClose;

Var
  ErrorCode :Word;
  CheckSig  :String[10];

Begin
  ErrorCode:=0;

  If FName<>'' Then
  Begin
    Assign(F,FName);
    Reset(F,1);
    ErrorCode:=IOResult;
    If ErrorCode<>0 Then Goto EndProc;
    FileName:=FName;
  End;

  If (DStart=DEnd) Then     { ** For InEXE Only ** }
  Begin
    ErrorCode:=FindEXESignature(DEnd,FileEnd);
  End
  Else
  Begin
    FileStart:=DStart;
    If DEnd=MaxLongInt Then
      FileEnd:=FileSize(F)
    Else
      FileEnd  :=DEnd;
  End;

  If ErrorCode<>0 Then Goto EndProcAndClose;

  Seek(F,FileEnd-10);
  BlockRead(F,CheckSig[1],10);
  CheckSig[0]:=#10;
  ErrorCode:=IOResult;
  If (ErrorCode<>0) Or (CheckSig<>Signature) Then
  Begin
    ErrorCode:=701;     {Not a PPD File}
    Goto EndProcAndClose;
  End;

  Seek(F,FileEnd-17);
  BlockRead(F,CheckSig[1],7);
  ErrorCode:=IOResult;
  If ErrorCode<>0 Then
  Begin
    ErrorCode:=702;     {Not a PPD File}
    Goto EndProcAndClose;
  End;

  Compress:=Ord(CheckSig[4]);

  If (Ord(CheckSig[5]) And InEXEFlag) = 0 Then
    InEXE:=False
  Else
    InEXE:=True;

  If (Ord(CheckSig[5]) And NameFlag) = 0 Then
    HaveNames:=False
  Else
    HaveNames:=True;

  If InEXE Then
    Move(CheckSig[1],DataSize,2)
  Else
  Begin
    If HaveNames Then
      DirEntry:=12+2+4+2+1
    Else
      DirEntry:=2+4+2+1;
  End;

  VerHi:=Ord(CheckSig[6]);
  VerLo:=Ord(CheckSig[7]);

  If VerHi>CurVerHi Then
    ErrorCode:=602
  Else
    If VerLo>CurVerLo Then
      ErrorCode:=601;

  If Compress<>C_None Then
    ErrorCode:=650+Compress;

  Goto EndProc;

EndProcAndClose:

  Close(F);

EndProc:

  If Not InEXE And (ErrorCode=0) Then ErrorCode:=ReadDir;
  OpenDatabase:=ErrorCode;
End;

Function DBaseFile.CloseDatabase:Word;
Begin
  PrevDirs.Destroy;
  Init;
  Close(F);
  CloseDatabase:=IOResult;
End;

Function DBaseFile.CrossIntoDatabase(Name:String;Number:Word):Word;
                        {Never Add or Delete From a Directory Database}
Var
  WhichOne :Word;
  DirData  :DBaseDir;
  OldDir   :Data;

Begin
  DirData.Name:=Name;
  DirData.Number:=Number;
  WhichOne:=FindDir(DirData);

  If WhichOne=0 Then
    CrossIntoDatabase:=603
  Else
  Begin
    DestroyDirs;
    If PrevDirs.Full Then
      CrossIntoDatabase:=604
    Else
    Begin
      OldDir.FileStart:=FileStart;
      OldDir.FileEnd  :=FileEnd;
      PrevDirs.Push(OldDir);
      CrossIntoDatabase:=OpenDatabase('',DirData.Offset,DirData.Offset+DirData.Size);
    End;
  End;
End;

Function DBaseFile.CrossOutOfDatabase:Word;

Var
  OldDir :Data;

Begin
  If PrevDirs.Empty Then
    CrossOutOfDatabase:=605
  Else
  Begin
    DestroyDirs;
    PrevDirs.Pop(OldDir);
    CrossOutOfDatabase:=OpenDatabase('',OldDir.FileStart,OldDir.FileEnd);
  End;
End;

Function DBaseFile.BlockInsert(Offset:LongInt;Data:Pointer;Size:Word):Word;

Label
  EndProc,
  EndProcAndClose;

Var
  ErrorCode :Word;
  G         :File;
  P         :Pointer;
  AmountLeft:LongInt;
  CopyAmnt,
  BlockSize :Word;

Begin
  ErrorCode:=0;

  Seek(F,0);
  ErrorCode:=IOResult;
  If ErrorCode<>0 Then Goto EndProc;
  Assign(G,TempFile);
  Rewrite(G,1);
  ErrorCode:=IOResult;
  If ErrorCode<>0 Then Goto EndProc;

  Seek(G,FileSize(F)+Size-1);
  BlockWrite(G,G,1);            {Make the File the Correct Size}
  ErrorCode:=IOResult;
  If ErrorCode>0 Then Goto EndProcAndClose;

  If MaxAvail>=64512 Then
    BlockSize:=64512
  Else
    BlockSize:=MaxAvail;

  GetMem(P,BlockSize);

  Seek(F,0);
  Seek(G,0);

  AmountLeft:=Offset;

  While (AmountLeft<>0) And (ErrorCode=0) do
  Begin
    If AmountLeft<BlockSize Then
      CopyAmnt:=AmountLeft
    Else
      CopyAmnt:=BlockSize;
    BlockRead (F,P^,CopyAmnt);
    BlockWrite(G,P^,CopyAmnt);
    ErrorCode:=IOResult;
    Dec(AmountLeft,CopyAmnt);
  End;

  BlockWrite(G,Data^,Size);
  If ErrorCode=0 Then ErrorCode:=IOResult;

  AmountLeft:=FileSize(F)-Offset;

  While (AmountLeft<>0) And (ErrorCode=0) do
  Begin
    If AmountLeft<BlockSize Then
      CopyAmnt:=AmountLeft
    Else
      CopyAmnt:=BlockSize;
    BlockRead (F,P^,CopyAmnt);
    BlockWrite(G,P^,CopyAmnt);
    ErrorCode:=IOResult;
    Dec(AmountLeft,CopyAmnt);
  End;

  FreeMem(P,BlockSize);

  If ErrorCode<>0 Then Goto EndProcAndClose;

  Close(F);
  Close(G);
  Assign(F,FileName);
  Erase(F);
  Assign(G,TempFile);
  Rename(G,FileName);
  Assign(F,FileName);
  Reset(F,1);
  ErrorCode:=IOResult;

  Goto EndProc;

EndProcAndClose:

  Close(G);
  Assign(G,TempFile);
  Erase(G);

EndProc:

  BlockInsert:=ErrorCode;
End;

Function DBaseFile.BlockOverwrite(Offset:LongInt;Data:Pointer;Size:Word):Word;
         {Uses ABSOLUTE File Adress}

Label
  EndProc;

Var
  ErrorCode :Word;

Begin
  ErrorCode:=0;

  Seek(F,Offset);
  ErrorCode:=IOResult;
  If ErrorCode<>0 Then Goto EndProc;

  BlockWrite(F,Data^,Size);
  ErrorCode:=IOResult;

EndProc:

  BlockOverwrite:=ErrorCode;
End;

Function DBaseFile.BlockDelete(Offset:LongInt;Size:Word):Word;

Label
  EndProc,
  EndProcAndClose;

Var
  ErrorCode :Word;
  G         :File;
  P         :Pointer;
  AmountLeft:LongInt;
  CopyAmnt,
  BlockSize :Word;

Begin
  ErrorCode:=0;

  Seek(F,0);
  ErrorCode:=IOResult;
  If ErrorCode<>0 Then Goto EndProc;
  Assign(G,TempFile);
  Rewrite(G,1);
  ErrorCode:=IOResult;
  If ErrorCode<>0 Then Goto EndProc;

  Seek(G,FileSize(F)-Size-1);
  BlockWrite(G,G,1);            {Make the File the Correct Size}
  ErrorCode:=IOResult;
  If ErrorCode>0 Then Goto EndProcAndClose;

  If MaxAvail>=64512 Then
    BlockSize:=64512
  Else
    BlockSize:=MaxAvail;

  GetMem(P,BlockSize);

  Seek(F,0);
  Seek(G,0);

  AmountLeft:=Offset;

  While (AmountLeft<>0) And (ErrorCode=0) do
  Begin
    If AmountLeft<BlockSize Then
      CopyAmnt:=AmountLeft
    Else
      CopyAmnt:=BlockSize;
    BlockRead (F,P^,CopyAmnt);
    BlockWrite(G,P^,CopyAmnt);
    ErrorCode:=IOResult;
    Dec(AmountLeft,CopyAmnt);
  End;

  Seek(F,FilePos(F)+Size);

  AmountLeft:=FileSize(F)-Offset-Size;

  While (AmountLeft<>0) And (ErrorCode=0) do
  Begin
    If AmountLeft<BlockSize Then
      CopyAmnt:=AmountLeft
    Else
      CopyAmnt:=BlockSize;
    BlockRead (F,P^,CopyAmnt);
    BlockWrite(G,P^,CopyAmnt);
    ErrorCode:=IOResult;
    Dec(AmountLeft,CopyAmnt);
  End;

  FreeMem(P,BlockSize);

  If ErrorCode<>0 Then Goto EndProcAndClose;

  Close(F);
  Close(G);
  Assign(F,FileName);
  Erase(F);
  Assign(G,TempFile);
  Rename(G,FileName);
  Assign(F,FileName);
  Reset(F,1);
  ErrorCode:=IOResult;

  Goto EndProc;

EndProcAndClose:

  Close(G);
  Assign(G,TempFile);
  Erase(G);

EndProc:

  BlockDelete:=ErrorCode;
End;

Function DBaseFile.ReadDir:Word;

Var
  X,
  NewTotal :Word;
  Data     :DBaseDir;

Begin
  DestroyDirs;
  Seek(F,FileEnd-17);
  BlockRead(F,NewTotal,2);

  Seek(F,FileEnd-17-DirEntry*NewTotal);

  For X:=1 to NewTotal do
  Begin
    If HaveNames Then
    Begin
      BlockRead(F,Data.Name[1],12);
      Data.Name[0]:=#12;
      UnPadVar(Data.Name,Data.Name);
    End
    Else
      Data.Name:='';

    BlockRead(F,Data.Number,9);
    AppendDir(Data);
  End;

  ReadDir:=IOResult;
End;

Function DBaseFile.WriteDir:Word;

Var
  NewName    :String[12];
  ErrorCode,
  OldTotal   :Word;

Begin
  Seek(F,FileEnd-17);
  BlockRead(F,OldTotal,2);
  ErrorCode:=IOResult;
  If ErrorCode=0 Then
  Begin
    If OldTotal<Dir.Total Then
      ErrorCode:=BlockInsert(FileEnd-17,Ptr(0,0),(Dir.Total-OldTotal)*DirEntry)
                                    {Insert any old data to make up file size}
    Else
      ErrorCode:=BlockDelete(FileEnd-17-(OldTotal-Dir.Total)*DirEntry,
                                        (OldTotal-Dir.Total)*DirEntry);
    Seek(F,FileEnd-17-DirEntry*OldTotal);
    ErrorCode:=IOResult;
  End;

  If ErrorCode=0 Then
  Begin

    Dir.Data:=Dir.Root;
    While (Dir.Data<>NIL) And (ErrorCode=0) do
    Begin
      If HaveNames Then
      Begin
        FormatVar(Dir.Data^.Name,NewName,12,LeftText);
        BlockWrite(F,NewName[1],12);
      End;
      BlockWrite(F,Dir.Data^.Number,9);
      Dir.Data:=Dir.Data^.Next;
    End;
    If ErrorCode=0 Then ErrorCode:=WriteHeader;
    Inc(FileEnd,(LongInt(Dir.Total)-OldTotal)*DirEntry);
    AdjustStackAfter(MaxLongInt,(LongInt(Dir.Total)-OldTotal)*DirEntry);
  End;

  WriteDir:=ErrorCode;
End;

Function DBaseFile.NewData(Name:String;Number:Word;Data:Pointer;Size:Word):Word;

Var
  ErrorCode:Word;
  DirData  :DBaseDir;

Begin
  DirData.Name  :=Name;
  DirData.Number:=Number;
  DirData.Offset:=FileEnd-17-DirEntry*(Dir.Total);
  DirData.Size  :=Size;
  DirData.Attr  :=0;
  AppendDir(DirData);

  ErrorCode:=BlockInsert(FileStart+DirData.Offset,Data,Size);
  If ErrorCode=0 Then
  Begin
    Inc(FileEnd,Size);
    AdjustStackAfter(FileStart+DirData.Offset,Size);
    ErrorCode:=WriteDir;
  End;

  NewData:=ErrorCode;
End;

Function DBaseFile.ModData(Name:String;Number:Word;Data:Pointer):Word;

Var
  WhichOne,
  ErrorCode:Word;
  DirData  :DBaseDir;

Begin
  ErrorCode:=0;
  DirData.Name  :=Name;
  DirData.Number:=Number;
  WhichOne:=FindDir(DirData);

  If WhichOne=0 Then ErrorCode:=603;

  If ErrorCode=0 Then
    ErrorCode:=BlockOverwrite(FileStart+DirData.Offset,Data,DirData.Size);

  ModData:=ErrorCode;
End;

Function DBaseFile.GetData(Name:String;Number:Word;Data:Pointer):Word;

Var
  WhichOne,
  ErrorCode   :Word;
  DirData     :DBaseDir;

Begin
  ErrorCode:=0;
  DirData.Name  :=Name;
  DirData.Number:=Number;
  WhichOne:=FindDir(DirData);

  If WhichOne=0 Then ErrorCode:=603;

  If ErrorCode=0 Then
  Begin
    Seek(F,DirData.Offset);
    BlockRead(F,Data^,DirData.Size);
    ErrorCode:=IOResult;
  End;

  GetData:=ErrorCode;
End;

Function DBaseFile.DelData(Name:String;Number:Word):Word;

Var
  WhichOne,
  ErrorCode   :Word;
  DirData     :DBaseDir;

Begin
  ErrorCode:=0;
  DirData.Name  :=Name;
  DirData.Number:=Number;
  WhichOne:=FindDir(DirData);

  If WhichOne=0 Then ErrorCode:=603;

  If ErrorCode=0 Then
  Begin
    ErrorCode:=BlockDelete(FileStart+DirData.Offset,DirData.Size);
    DelDir(WhichOne);
  End;

  If ErrorCode=0 Then
  Begin
    AdjustDirsAfter(DirData.Offset,-DirData.Size);      {Don't add FileStart}
    Dec(FileEnd,DirData.Size);
    AdjustStackAfter(FileStart+DirData.Offset,-DirData.Size);
    ErrorCode:=WriteDir;
  End;

  DelData:=ErrorCode;
End;

Function DBaseFile.NewDataFile(Name:String;Number:Word;FName:String):Word;

Label
  EndProc,
  EndProcAndClose;

Var
  G        :File;
  ErrorCode:Word;
  Data     :Pointer;
  Size     :Word;

Begin
  Assign(G,FName);
  Reset(G,1);
  ErrorCode:=IOResult;
  If ErrorCode<>0 Then Goto EndProc;

  Size:=FileSize(G);
  If (Size>65500) Then
  Begin
    ErrorCode:=703;
    Goto EndProcAndClose;
  End;

  If (MaxAvail<5192) Or (MaxAvail-5192<Size) Then
  Begin
    ErrorCode:=203;
    Goto EndProcAndClose;
  End;

  GetMem(Data,Size);
  BlockRead(G,Data^,Size);

  ErrorCode:=NewData(Name,Number,Data,Size);

  FreeMem(Data,Size);

EndProcAndClose:

  Close(G);

EndProc:

  NewDataFile:=ErrorCode;
End;

Function DBaseFile.ModDataFile(Name:String;Number:Word;FName:String):Word;

Label
  EndProc,
  EndProcAndClose;

Var
  G        :File;
  WhichOne,
  ErrorCode:Word;
  Data     :Pointer;
  DirData  :DBaseDir;
  Size     :Word;

Begin
  ErrorCode:=0;
  DirData.Name  :=Name;
  DirData.Number:=Number;
  WhichOne:=FindDir(DirData);
  If WhichOne=0 Then
  Begin
    ErrorCode:=603;
    Goto EndProc;
  End;

  Assign(G,FName);
  Reset(G,1);
  ErrorCode:=IOResult;
  If ErrorCode<>0 Then Goto EndProc;

  Size:=FileSize(G);
  If (Size>65500) Then
  Begin
    ErrorCode:=703;
    Goto EndProcAndClose;
  End;

  If (Size<>DirData.Size) Then
  Begin
    ErrorCode:=606;
    Goto EndProcAndClose;
  End;

  If (MaxAvail<5192) Or (MaxAvail-5192<Size) Then
  Begin
    ErrorCode:=203;
    Goto EndProcAndClose;
  End;

  GetMem(Data,Size);
  BlockRead(G,Data^,Size);

  ErrorCode:=ModData(Name,Number,Data);

  FreeMem(Data,Size);

EndProcAndClose:

  Close(G);

EndProc:

  ModDataFile:=ErrorCode;
End;

Function DBaseFile.GetDataFile(Name:String;Number:Word;FName:String):Word;

Label
  EndProc,
  EndProcAndFree;

Var
  G           :File;
  DirData     :DBaseDir;
  Data        :Pointer;
  WhichOne,
  ErrorCode   :Word;

Begin
  ErrorCode:=0;
  DirData.Name  :=Name;
  DirData.Number:=Number;
  WhichOne:=FindDir(DirData);
  If WhichOne=0 Then
  Begin
    ErrorCode:=603;
    Goto EndProc;
  End;

  If (DirData.Size>65500) Then
  Begin
    ErrorCode:=703;
    Goto EndProc;
  End;

  If (MaxAvail<5192) Or (MaxAvail-5192<DirData.Size) Then
  Begin
    ErrorCode:=203;
    Goto EndProc;
  End;

  GetMem(Data,DirData.Size);
  ErrorCode:=GetData(Name,Number,Data);

  If ErrorCode=0 Then
  Begin
    Assign(G,FName);
    Rewrite(G,1);
    ErrorCode:=IOResult;
    If ErrorCode>0 Then Goto EndProcAndFree;
    BlockWrite(G,Data^,DirData.Size);
    Close(G);
    ErrorCode:=IOResult;
  End;

EndProcAndFree:

  FreeMem(Data,DirData.Size);

EndProc:

  GetDataFile:=ErrorCode;
End;

Function DBaseFile.ModEXE(Offset:LongInt;Data:Pointer;Size:Word):Word;
Begin
  Seek(F,FileEnd-17-DataSize+Offset);
  BlockWrite(F,Data^,Size);
  ModEXE:=IOResult;
End;

Function DBaseFile.GetEXE(Offset:LongInt;Data:Pointer;Size:Word):Word;
Begin
  Seek(F,FileEnd-17-DataSize+Offset);
  BlockRead(F,Data^,Size);
  GetEXE:=IOResult;
End;

Function DatabaseErrorMsg(ErrorNumber:Word):String;

Var
  Temp:String;

Begin
  If (ErrorNumber>650) And (ErrorNumber<700) Then
    Str(ErrorNumber-650,Temp)
  Else
    Str(ErrorNumber,Temp);
  Temp:=' '+Temp;

  Case ErrorNumber Of
    0     :DatabaseErrorMsg:='No Error';
    1..500:DatabaseErrorMsg:='Runtime Error'+Temp;
    601   :DatabaseErrorMsg:='Low-Version-Number Too High';
    602   :DatabaseErrorMsg:='High-Version-Number Too High';
    603   :DatabaseErrorMsg:='Item Requested Not Found in Database';
    604   :DatabaseErrorMsg:='Unable To Access Sub Database (Out of Directory Stack)';
    605   :DatabaseErrorMsg:='Already At Highest Level (Already In Parent Database)';
    606   :DatabaseErrorMsg:='Data Size Mismatch';
    651..
    699   :DatabaseErrorMsg:='Compression System'+Temp+' Used.  Decompress File';
    701   :DatabaseErrorMsg:='Bad Database Signature (Not a Database File)';
    702   :DatabaseErrorMsg:='Unable to Read Database Signature (Not a Database File)';
    703   :DatabaseErrorMsg:='Cannot Have Segments Larger Than 64kb';
  End;
End;

End.

{
╔══════════════════════════════════════════════════════════════╗
║                   Pure Power Software                        ║
╟──────────────────────────────────────────────────────────────╢
║                                                              ║
║       This  software  is copyright by Michael Gallias.       ║
║                                                              ║
╚══════════════════════════════════════════════════════════════╝
}