Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TPDB21.ZIP/TPDB.PAS

Pascal/Delphi Source File | 1989-02-22 | 37.5 KB | 1,531 lines

{$A+,B+,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
{$M 65520,0,655360}
Unit TPDB;

{This version is Version 2.1 February ??, 1989}

                     (***********************************)
                     (*     Turbo Pascal 5.0 Unit       *)
                     (*    for Accessing dBASE III      *)
                     (*             files.              *)
                     (*        Copyright 1989           *)
                     (*          Brian Corll            *)
                     (*       All Rights Reserved       *)
                     (*     dBASE is a registered       *)
                     (* trademark of Ashton-Tate, Inc.  *)
                     (* Version 2.1  February ??, 1989  *)
                     (***********************************)
                     (* Credits : Juan Vegarra          *)
                     (***********************************)


INTERFACE

Uses CRT,Dos,TPDBINDX,TPDBDate;


(******************************)
(*      Global Variables      *)
(******************************)

Const

  AutoWrap    : Boolean = False;
  CursorDown  = ^X;
  CursorEnd   = ^F;
  CursorHome  = ^A;
  CursorLeft  = ^S;
  CursorRight = ^D;
  CursorUp    = ^E;
  DelKey      = ^G;
  Duplicates = 1;
  Escape      = ^[;
  ExtKey      : Boolean = False;
  Filler      : Char =  #32;
  MaxLong = 2147483647;
  MaxReal = 3.4E37;
  MinLong = -2147483647;
  MinReal = 1.5E-45;
  NoDuplicates = 0;
  PageDown    = ^C;
  PageUp      = ^R;
  Return      = ^M;
  TabKey      = #9;
  UpperCase   : Boolean = False;


{Color constants - defined to take advantage of Turbo Pascal's
 constant folding capabilities.  See documentation.}


  Black        = $00;       DarkGray     = $08;
  Blue         = $01;       LightBlue    = $09;
  Green        = $02;       LightGreen   = $0A;
  Cyan         = $03;       LighBCyan    = $0B;
  Red          = $04;       LightRed     = $0C;
  Magenta      = $05;       LightMagenta = $0D;
  Brown        = $06;       Yellow       = $0E;
  LightGray    = $07;       White        = $0F;
  Blink        = $80;

  BlackBG      = $00;
  BlueBG       = $10;
  GreenBG      = $20;
  CyanBG       = $30;
  RedBG        = $40;
  MagentaBG    = $50;
  BrownBG      = $60;
  LightGrayBG  = $70;


Type

  Str2 = String[2];
  Str4 = String[4];
  Str5 = String[5];
  Str6 = String[6];
  Str8 = String[8];
  Str10 = String[10];
  Str15 = String[15];
  Str20 = String[20];
  Str30 = String[30];
  Str60 = String[60];
  Str80 = String[80];
  Str132 = String[132];
  CharSet = Set of Char;
  ByteSet = Set of Byte;

  FileName = String[66];
  DBRecPtr = ^DBType;
  DBType   = Array[1..4000] of Char;
  DBKey    = String[254];
  DisplayType = (Monochrome, CGA, EGA, MCGA, VGA);

  DBHeader = Record
       DBType    : Byte;
       Year      : Byte;
       Month     : Byte;
       Day       : Byte;
       RecCount  : LongInt;
       Location  : Integer;
       RecordLen : Integer;
       Reserved  : Array[1..20] of Byte;
       Terminator : Char;
         end;

    DBField = Record
       FieldName    : Array[1..11] of Char;
       FieldType    : Byte;
       FieldAddress : LongInt;
       FieldLen     : Byte;
       FieldDec     : Byte;
       Reserved     : Array[1..14] of Char;
         end;

HeadPtr = ^DBHeader;
PosPtr = ^DBEditArray;
FieldPtr = ^FieldArray;
DBEditArray = Array[1..2,1..128] of Integer;
FieldArray  = Array[1..128] of DBField;


Const

  Up   : CharSet = [CursorUp];
  Down : CharSet = [CursorDown,Return];
  Next : CharSet = [Escape];



Var
    Normal             : Byte;
    Reverse            : Byte;
    UCKey,IndOpen,
        DBFOpen    : Boolean;
    DBFileName         : FileName;
    DBFile,TempFile    : File;
    Header             : HeadPtr;
    Fields             : FieldPtr;
    Allocated,MAlloc   : Boolean;
    Message          : String[80];
    Positions          : PosPtr;
    DBRecord           : DBRecPtr;
    NumFields,ErrCode  : Integer;
    BC,Ch              : Char;
    TotalRecs,DBRecNum,
        R          : LongInt;
    Y,M,D,DW           : Word;
    NumLen,Decimals,
        LL,K       : Byte;
    DBIndex            : IndexFile;
    DBIndexName        : FileName;
    Found              : Boolean;
    Start,Stop         : Integer;
    CTxt           : Byte;
    VideoBase        : Word;
    VideoWait          : Boolean;


(**********************************)
(*   Procedures and Functions     *)
(**********************************)

Procedure AddDBKey(KeyStr : DBKey);
{Add a new key to an index.}

Procedure AddDBRec;
{Add a new record to a .DBF, after the record has been created with
 a call to NewDBRec.}

Procedure BailOut;
{TPDB error handling routine.}

Procedure Beep;
{Sound a couple of tones.}

Procedure BlockCursor;
{Turn on a block cursor.}

Function  BOF : Boolean;
{Test for beginning of .DBF file.}

Function BoolToStr(Param : Byte;IfTrue,IfFalse : Char): String;

Procedure CheckScreen(Var CurrPos:Byte;BC:Char;Up,Down:CharSet;Low,High:Byte);
{Used in full screen editing.}

Procedure CloseDBFile;
{Close dBASE file.}

Procedure CloseDBIndex;
{Close an index.}

Procedure CursorOff;

Procedure CursorOn;

Procedure DBOpenFile(DBName : FileName);
{Open dBASE file.}

Procedure DBReset;
{Reset dBASE file.}

Procedure DelDBKey(KeyStr : DBKey);
{Delete a key expression from an index}

Function  Deleted : Boolean;
{Test whether or not a record is deleted.}

Procedure Display;
{Display a record.}

Function  EOF : Boolean;
{Test for end of .DBF file.}

Function  FieldToStr(FNo : Byte) : string;
{Convert a field to a single string.}

Procedure FillRecs(NumRecs : LongInt);
{Append a specified number of records to a .DBF file.}

Procedure Find(SearchStr : String);
{Find a key string in an index.}

Procedure Flash(Row,Col, Attr:byte; Str : String);
{Display a string at a specific row and column on the screen, using
 direct screen writing methods.}

Procedure FlashC(Row,Attr:Byte;Str : String);
{Same as above, except string is centered.}

Procedure FlashFill(Row,Col,Rows,Cols,Attr : Byte;Ch : Char);
{Fill a region of the screen with a specified color and character.}

Procedure FlushDB;
{Flush record in memory to disk.}

Procedure Get(FNo,X,Y : Byte);
{Edit a field.}

Function GetBoolean(Var Param:Byte;IfTrue,IfFalse:Char;X,Y:Byte):Char;

Function GetByte(Var Param:Byte;LowLim,UpLim,Len,X,Y:Byte):Char;

Procedure GetDBRec(RecordNumber : LongInt);
{Read a specific record.}

Function GetInteger(Var Param:Integer;LowLim,UpLim:Integer;Len,X,Y:Byte):Char;
{Input an integer.}

Function GetLongInt(Var Param:LongInt;LowLim,UpLim:LongInt;Len,X,Y:Byte):Char;
{Input a long integer.}

Function GetReal(Var Param : Real; LowLim, UpLim : Real; Len, X, Y : Word) : Char;
{Input a real number.}

Function GetString(Var Param : String; Len, X, Y : Byte) : Char;
{Input a string.}

Procedure GoBottom;
{Go to bottom of file.}

Procedure GoTop;
{Go to top of file.}

Function  IIF(BoolVar : Boolean;IfTrue,IfFalse : String) : String;
{Test a boolean variable and return one of two strings.}

Function Input(Var S:String;Term:CharSet;L,X,Y:Byte;Var BC:Char):String;

Function IntToStr(Number : LongInt): String;

Function  JustL(InpStr: String; FieldLen: Integer): String;
{Left justify a string.}

Procedure LookUp(SearchStr : string);
{Find a key string in the open index.}

Function Lower(InpStr : string) : string;

Function  LTrim(InpStr: String): String;
{Trim leading blanks from a string.}

Procedure MakeDBIndex(DBIndexName : FileName;KeyLen,Status : Integer);
{Create a new index structure.}

Procedure Mark;
{Mark record for deletion.}

Procedure NewDBRec;
{Create new blank record.}

Procedure NextDBKey(KeyStr : DBKey);
{Move to next key in an index.}

Procedure NextRec;
{Skip to next record in .DBF}

Procedure OpenDBIndex(DBIndexName : FileName;KeyLen,Status : Integer);
{Open an index file.}

Procedure Pack;
{Pack a file.}

Function  PadL(InpStr: String; FieldLen: Integer): String;
{Pad a string with blanks on the left.}

Function  PadR(InpStr: String; FieldLen: Integer): String;
{Pad a string with blanks on the right.}

Procedure PrevDBKey(KeyStr : DBKey);
{Skip backward to previous key in an index.}

Procedure PrevRec;
{Skip backward to previous key in a .DBF file.}

Procedure Prompt(Row,Col : Byte;PromptStr : Str80);
{Display a prompt at a specified row and column.}

Procedure PutDBRec(RecordNumber : LongInt);
{Write a specified record.}

Function ReadChar : Char;

Procedure ReadDBHeader;
{Read .DBF header.}

Procedure ReadKB (Var ExtKey: Boolean; Var Ch: Char);

Function RealToStr(Number : Real): String;

Procedure Recall;
{Undelete a deleted record.}

Procedure Repl(FNo : Byte;InStr : string);
{Replace a particular field with a specified string.}

Procedure ReplEach(FNo : Byte;InStr : String);
{Replace a particular field in all records in a .DBF file with a
 specified string.}

Function  Replicate(Ch : Char;Count : word) : String;
{Create a string of a specified number of a character.}

Function  RTrim(InpStr: String): String;
{Trim trailing blanks from a string.}

Procedure Say(FNo,Row,Col : Byte);
{Display a field.}

Procedure SetColor(FG,BG : Byte);
{Set initial foreground and background colors.}

Procedure ShowStatus;
{Display .DBF status.}

Function  Sum(FNo : Byte) : Real;
{Sum the value of numeric fields in records.}

Function  Upper(InpStr: String): String;
{Convert a string to upper case.}

Procedure Wait;
{Wait for a key press and display a message.}

Procedure WriteDBHeader;
{Update .DBF header and write to disk.}

Procedure Zap;
{Delete all records.}


IMPLEMENTATION

Procedure AddDBKey(KeyStr : DBKey);
begin
     If UCKey then KeyStr := Upper(KeyStr);
     AddKey(DBIndex,DBRecNum,KeyStr);
end;

Procedure AddDBRec; {Add new record, no index open.}
Var
   RecordNumber : LongInt;
begin
     TotalRecs := TotalRecs + 1;
     RecordNumber := TotalRecs;
     DBRecNum := RecordNumber;
     RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
     Seek(DBFile,RecordNumber);
     BlockWrite(DBFile,DBRecord^,Header^.RecordLen,ErrCode);
     Dispose(DBRecord);
     Allocated := False;
end;

Procedure BailOut;
Var
   Message : String[80];
   Blooper : Word;

begin
     GotOne := True;
     If DBFOpen then CloseDBFile;
     If IndOpen then CloseDBIndex;
     SetColor(White,Blue);
     ClrScr;
     Case TPDBErr of
          1    : Message := 'Invalid DOS function code !';
             2    : Message := 'File not found ! '+
                    IIF(Length(RTrim(LTrim(TErrorName)))<>0,' -- > '+Upper(TErrorName),'');
          3    : Message := 'Path not found !';
          4    : Message := 'Too many open files !';
          5    : Message := 'File access denied !';
          6    : Message := 'Invalid file handle !';
          8    : Message := 'Not enough memory !';
          12   : Message := 'Invalid file access code !';
          15   : Message := 'Invalid drive number !';
          16   : Message := 'Cannot remove current directory !';
          17   : Message := 'Cannot rename across drives !';
          100  : Message := 'Disk read error !';
          101  : Message := 'Disk write error !';
          102  : Message := 'File not assigned !';
          103  : Message := 'File not open !';
          104  : Message := 'File not open for input !';
          105  : Message := 'File not open for output !';
          106  : Message := 'Invalid numeric format !';
          200  : Message := 'Division by zero !';
          201  : Message := 'Range check error !';
          202  : Message := 'Stack overflow error !';
          203  : Message := 'Heap overflow error !';
          204  : Message := 'Invalid pointer operation !';
          1000 : Message := 'Record size is greater than 4000 chars !';
          1002 : Message := 'Specified Index Key Length is greater than 254 chars !';
          1003 : Message := 'Invalid DBF File structure !';
          1004 : Message := 'Index File created with different key size !';
          1005 : Message := 'Not enough memory for index page stack !';
          end;
             Beep;Beep;
             FlashC(8,White+BlueBG,'TPDB Version 2.1');
             FlashC(10,Yellow+BlueBG,'ERROR !');
             FlashC(12,White+BlueBG,Message);
          CursorOff;
             FlashC(14,LightGreen+BlueBG,'Press any key to halt program....');
             FlashC(16,LightCyan+BlueBG,'Copyright 1989 Brian Corll');
          Repeat Until KeyPressed;
          TErrorName := '';
          TPDBErr := 0;
          ClrScr;
          Halt(1);
end;

Procedure Beep;

Begin
  Sound(1500); Delay(50);
  Sound(1000); Delay(50);
  NoSound;
End;


Function BOF : Boolean;
begin
     If DBRecNum = 1 then
        BOF := True
     else BOF := False;
end;

Function BoolToStr(Param : Byte;IfTrue,IfFalse : Char): String;
Var
  Temp : String;
BEGIN
  Case Param of
    0: Temp := Filler;
    1: Temp := IfTrue;
    2: Temp := IfFalse;
  End;
  BoolToStr:=Temp;
END;

Procedure CheckScreen(Var CurrPos:Byte;BC:Char;Up,Down:CharSet;Low,High:Byte);

Begin
  If (BC In Down) Then
     If CurrPos = High Then CurrPos := Low
     Else Inc(CurrPos)
  Else
     If (BC In Up) Then
        If CurrPos = Low Then CurrPos := High
        Else Dec(CurrPos)
End;

Procedure CloseDBFile;
Var
   EOFMarker : Byte;
begin
     WriteDBHeader;
     EOFMarker := $1A;
     Seek(DBFile,Header^.Location+(Header^.RecCount*Header^.RecordLen));
     BlockWrite(DBFile,EOFMarker,1);
     Close(DBFile);
     If not MAlloc then
     begin
    Dispose(Header);
    Dispose(Fields);
    Dispose(Positions);
     end;
     DBFOpen := False;
end;

Procedure CloseDBIndex;
begin
     CloseIndex(DBIndex);
     IndOpen := False;
end;

Procedure DBOpenFile(DBName : FileName); {Open dBASE file.}
begin
     New(Header);
     New(Fields);
     New(Positions);
     DBFileName := RTrim(LTrim(DBName));
     Assign(DBFile,DBFileName);
     {$I-} Reset(DBFile,1); {$I+}
     TPDBErr := IOResult;
     If (TPDBErr<>0) and (not GotOne) then
     begin
     TErrorName := DBName;
     BailOut;
     end;
     DBFOpen := True;
     DBRecNum := 1;
     ReadDBHeader;
end;

Procedure DBReset; {Reset dBASE file.}
begin
     {$I-} Reset(DBFile,1); {$I+}
     If TPDBErr=0 then TPDBErr := IOResult;
      If (TPDBErr<>0) and (not GotOne) then
      begin
      TErrorName := DBFileName;
      BailOut;
      end;
end;

Procedure DelDBKey(KeyStr : DBKey);
begin
     If UCKey then KeyStr := Upper(KeyStr);
     DeleteKey(DBIndex,DBRecNum,KeyStr);
end;

Function Deleted : Boolean;
begin
     If DBRecord^[1] = Chr(Ord($2A)) then
        Deleted := True
     else
         Deleted := False;
end;

Procedure Display;
Var
    FNo : Byte;
    K   : Integer;

begin
     ClrScr;
     For FNo := 1 to NumFields do
     begin
          For K := 1 to 11 do
             Write(Fields^[FNo].FieldName[K]);
          Write(': ');
          If Chr(Ord(Fields^[FNo].FieldType)) = 'D' then
          Write(FormDate(FieldToStr(FNo)))
          else Write(FieldToStr(FNo));
          Writeln;
      If FNo mod 23 = 0 then
      begin
      Wait;
      ClrScr;
      end;
     end;
     Wait;
end;

Function EOF : Boolean;
begin
     If DBRecNum = TotalRecs then
        EOF := True
     else EOF := False;
end;

Function FieldToStr(FNo : Byte) : string;
Var
   FF : Integer;
   Temp : String;
begin
     Temp := '';
     For FF := Positions^[1,FNo] to Positions^[2,FNo] do
         Temp := Temp + DBRecord^[FF];
     FieldToStr := Temp;
end;

Procedure FillRecs(NumRecs : LongInt);
Var
   J : LongInt;
begin
     If TotalRecs>0 then GoBottom;
     For J := 1 to NumRecs do
     begin
          NewDBRec;
          AddDBRec;
     end;
end;

Procedure Find(SearchStr : string); {Find a key string in the open index.}
begin
     FindKey(DBIndex,DBRecNum,SearchStr);
     If OK then
     begin
          GetDBRec(DBRecNum);
          Found := True;
     end
     else
     Found := False;
end;

{$L Flash.obj}

{$F+}

Procedure Flash(Row,Col, Attr:byte; Str : String);external;

   Function CurrVidDisplay: DisplayType; external;

    Function CurrentVideoMode: Byte; external;

    Procedure CursorOn;external;

    Procedure CursorOff;external;

    Procedure BlockCursor;external;

{$F-}

Procedure FlashC(Row,Attr:Byte;Str : String);
begin
     Flash(Row,40 - Length(Str) div 2,Attr,Str);
end;

Procedure FlashFill(Row,Col,Rows,Cols,Attr : Byte;Ch : Char);
Var
   Z : Byte;
   Temp : String;
begin
     Temp := Replicate(Ch,Cols);
     For Z := Row to Row + Rows-1 do
         Flash(Z,Col,Attr,Temp);
end;

Procedure FlushDB;
begin
     MAlloc := True;
     CloseDBFile;
     MAlloc := False;
     DBReset;
end;

Procedure Get(FNo,X,Y : Byte);
Var
   TempStr1 : string;
   TempLen,DC : Byte;

         Procedure Character;
         Var
            GG : Integer;
         begin
     TempStr1 := '';
     TempLen := Fields^[FNo].FieldLen;
     For GG := Positions^[1,FNo] to Positions^[2,FNo] do
     begin
         TempStr1 := TempStr1 + DBRecord^[GG];
     end;
         BC := GetString(TempStr1,TempLen,Y,X); {from DER12.arc}
     For GG := Positions^[1,FNo] to Positions^[2,FNo] do
         DBRecord^[GG] := Chr(Ord(#32));
     TempStr1 := PadR(TempStr1,Fields^[FNo].FieldLen);
     DC := 1;
     For GG := Positions^[1,FNo] to Positions^[2,FNo] do
         begin
          DBRecord^[GG] := TempStr1[DC];
          DC := DC + 1;
         end;
         Flash(X,Y,Normal,Tempstr1);
         end; {Procedure Character}


         Procedure Numeric;
         Var
            NumLen,DC : Byte;
            GG : Integer;
            TempInt : LongInt;
            TempReal : Real;
            RealStr : String;
            IntStr : String;


         begin
              NumLen := Fields^[FNo].FieldLen;
          Decimals := Fields^[FNo].FieldDec;
              If Decimals>0 then
              begin
          RealStr := '';
              TempReal := 0;
          For GG := Positions^[1,FNo] to Positions^[2,FNo] do
              RealStr := RealStr +DBRecord^[GG];
          Val(RealStr,TempReal,ErrCode);
              BC := GetReal(TempReal,MinReal,MaxReal,NumLen,Y,X);
              Str(TempReal : NumLen : Decimals,RealStr);
              DC := 1;
          For GG := Positions^[1,FNo] to Positions^[2,FNo] do
              begin
               DBRecord^[GG] := RealStr[DC];
               DC := DC + 1;
              end;
              Flash(X,Y,Normal,RealStr);
              end
              else
              begin
              IntStr := '';
              TempInt := 0;
          For GG := Positions^[1,FNo] to Positions^[2,FNo] do
              IntStr := IntStr+DBRecord^[GG];
          Val(IntStr,TempInt,ErrCode);
              BC := GetLongInt(TempInt,MinLong,MaxLong,NumLen,Y,X);
              Str(TempInt : NumLen,IntStr);
              DC := 1;
          For GG := Positions^[1,FNo] to Positions^[2,FNo] do
              begin
               DBRecord^[GG] := IntStr[DC];
               DC := DC + 1;
              end;
              Flash(X,Y,Normal,IntStr);
              end;
         end; {Procedure Numeric}

         Procedure Dates;
         Var
            TempDate,TmpDat2 : String[8];
            MM,DD,DC : Byte;
            YY,GG : Integer;
            TM,TD,TY,Month,Day : String[2];
            Year : String[4];
         begin
              TempDate := '';
              For GG := Positions^[1,FNo] to Positions^[2,FNo] do
                  TempDate := TempDate+DBRecord^[GG];
              Repeat
              Year := Copy(TempDate,1,4);
              Month := Copy(TempDate,5,2);
              Day := Copy(TempDate,7,2);
              Val(Year,YY,ErrCode);
              Val(Month,MM,ErrCode);
              Val(Day,DD,ErrCode);
              If YY>=1900 then YY := YY-1900;
              BC := GetByte(MM,0,12,2,Y,X);
              BC := GetByte(DD,0,31,2,Y+3,X);
              BC := GetInteger(YY,0,99,2,Y+6,X);
              Str(MM,Month);
              Str(DD,Day);
              YY := YY + 1900;
              Str(YY:4,Year);
              If DD<10 then Day := '0'+Day;
              If MM<10 then Month := '0'+Month;
              TempDate :=Year+Month+Day;
              If not ValidDate(TempDate) then Beep;
              TmpDat2 := Copy(TempDate,5,2)+'/'+Copy(TempDate,7,2)+'/'+
                      Copy(TempDate,3,2);
              Flash(X,Y,Normal,TmpDat2);
              Until ValidDate(TempDate);
              DC := 1;
          For GG := Positions^[1,FNo] to Positions^[2,FNo] do
              begin
               DBRecord^[GG] := TempDate[DC];
               DC := DC + 1;
              end;

         end; {Procedure Dates}

         Procedure Logical;
         Var
            BoolVar : Byte;
        TF : String[1];
     begin
            Case DBRecord^[Positions^[1,FNo]] of
                 'Y' : BoolVar := 1;
                 'N' : BoolVar := 2
                 else BoolVar := 0;
                 end;
        BC := GetBoolean(BoolVar,'Y','N',Y,X);
        TF := BoolToStr(BoolVar,'Y','N');
        DBRecord^[Positions^[1,FNo]] := TF[1];
            Flash(X,Y,Normal,TF);
         end;

     begin {Procedure Get}
           Case Chr(Ord(Fields^[FNo].FieldType)) of
          'C'     : Character;
          'L'     : Logical;
          'N'     : Numeric;
          'D'     : Dates;
          end;
     end;{Procedure Get}


Function GetBoolean(Var Param:Byte;IfTrue,IfFalse:Char;X,Y:Byte):Char;
Var
  BC    : Char;
  Temp  : String;
  Value : Byte;
Begin
  Value := Param;
  Temp := BoolToStr(Value,IfTrue,IfFalse);
  UpperCase := True;
  Temp := Input(Temp,[IfTrue,IfFalse],1,X,Y,BC);
  If Length(Temp) =  0 Then
  Begin
    Param := 0;
    Flash(Y,X,Normal,BoolToStr(Param,IfTrue,Iffalse));
  End
  Else
  Begin
    If Temp = Filler  Then Param := 0;
    If Temp = IfTrue  Then Param := 1;
    If Temp = IfFalse Then Param := 2;
  End;
  UpperCase := False;
  GetBoolean := BC;
End;

Function GetByte(Var Param:Byte;LowLim,UpLim,Len,X,Y:Byte):Char;
Var
  BC : Char;
  WW,WL,WH : LongInt;
Begin
  WW := LongInt(Param);
  WL := LongInt(LowLim);
  WH := LongInt(UpLim);
  BC := GetLongInt(WW,WL,WH,Len,X,Y);
  Param := Byte(WW);
  GetByte := BC;
End;                                                         { GetByte }

Procedure GetDBRec(RecordNumber : LongInt); {Read a specific record.}
begin
     If not Allocated then
     begin
          New(DBRecord);
          Allocated := True;
     end
     else
     begin
          Dispose(DBRecord);
          New(DBRecord);
          Allocated := True;
     end;
     DBRecNum := RecordNumber;
     RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
     Seek(DBFile,RecordNumber);
     BlockRead(DBFile,DBRecord^,Header^.RecordLen,ErrCode);
end;

Function GetInteger(Var Param:Integer;LowLim,UpLim:Integer;Len,X,Y:Byte):Char;
Var
  BC : Char;
  WW,WL,WH : LongInt;
Begin
  WW := LongInt(Param);
  WL := LongInt(LowLim);
  WH := LongInt(UpLim);
  BC := GetLongInt(WW,WL,WH,Len,X,Y);
  Param := Integer(WW);
  GetInteger := BC;
End;

Function GetLongInt(Var Param:LongInt;LowLim,UpLim:LongInt;Len,X,Y:Byte):Char;
Var
  Temp     : String;
  P, Value : LongInt;
  I        : Integer;
  Err      : Boolean;
  BC       : Char;
Begin
  Repeat
    Err := False;
     Str(Param, Temp);
    Temp := Input(Temp, ['0'..'9'], Len, X, Y, BC);
    Val(Temp, P, I);
    If length(Temp) = 0 Then Value := 0
    Else If I = 0 Then Value := P
         Else
         Begin
           Value := Param;
           Beep;
           Err := True;
         End;
    If (Not((Value >= LowLim) And (Value <= UpLim))) Then Beep;
  Until (Value >= LowLim) And (Value <= UpLim) And (Not(Err));
  Param := Value;
  GetLongInt := BC;
End;


Function GetReal(Var Param : Real; LowLim, UpLim : Real; Len, X, Y : Word) : Char;
Var
   Temp : String;
   P, Value : Real;
   I : Word;
   Err : Boolean;
   BC : Char;
Begin
   Repeat
         Err := False;
         Temp := RealToStr(Param);
         Temp := Input(Temp, ['0'..'9', '.','-'], Len, X, Y, BC);
         Val(Temp, P, I);
         If Length(Temp) = 0 Then Value := 0.0
            Else If I = 0 Then Value := P
            Else
            Begin
                 Value := Param;
                 Beep;
                 Err := True;
            End;
         If (Not((Value >= LowLim) And (Value <= UpLim))) Then Beep;
   Until (Value >= LowLim) And (Value <= UpLim) And (Not(Err));
   Param := Value;
   GetReal := BC;
End;

Function GetString(Var Param : String; Len, X, Y : Byte) : Char;
Var
   Temp : String;
   BC : Char;
Begin
   Temp := Param;
   Temp := Input(Temp, [#32..#126], Len, X, Y, BC);
   Param := Temp;
   GetString := BC;
End;

Function GetWord(Var Param:Word;LowLim,UpLim:Word;Len,X,Y:Byte):Char;
Var
   BC : Char;
   WW,WL,WH : LongInt;
Begin
   WW := LongInt(Param);
   WL := LongInt(LowLim);
   WH := LongInt(UpLim);
   BC := GetLongInt(WW,WL,WH,Len,X,Y);
   Param := Word(WW);
   GetWord := BC;
End;

Procedure GoBottom;
begin
     GetDBRec(Header^.RecCount);
end;

Procedure GoTop;
begin
     GetDBRec(1);
end;

Function IIF(BoolVar : Boolean;IfTrue,IfFalse : String) : String;
begin
     If BoolVar then IIF := IfTrue
     else IIF := IfFalse;
end;


Function Input(Var S:String;Term:CharSet;L,X,Y:Byte;Var BC:Char):String;
Const
  Next : CharSet = [Return,CursorUp,CursorDown,PageUp,PageDown,Escape];
Var
  P    : Byte;
  Ch   : Char;
  Temp : String;
Begin
  CursorOn;
  If S = '0' Then S[0] := #0;
  Temp:= Replicate(Filler,L-Length(S));
  Temp := Concat(S,Temp);
  Flash(Y,X,Reverse,Temp);
  P := 0;
  Repeat
    GoToXY(X+P,Y);
    Ch := ReadChar;
    If UpperCase Then CH := UpCase(CH);
    If (CH In Term) Then
    Begin
      If P < L Then
      Begin
        If Length(S) = L Then Delete(S, L, 1);
        Inc(P);
        Insert(CH, S, P);
        Write(Copy(S, P, L));
        If AutoWrap AND (P = L) Then Ch := Return;
      End
      Else If Not(AutoWrap) Then Beep;
    End
    Else
    Case CH Of
          ^H, #127 : If P > 0 Then
                   Begin
                     Delete(S, P, 1);
                     Write(^H, Copy(S, P, L), Filler);
                     Dec(P);
                   End
                   Else Beep;
          DelKey : If P < Length(S) Then
                   Begin
                     Delete(S, Succ(P), 1);
                     Write(Copy(S, Succ(P), L), Filler);
                   End;
        CursorLeft : If P > 0 Then Dec(P)
                   Else Beep;
        CursorRight: If P < Length(S) Then Inc(P)
                   Else Beep;
      CursorHome : P := 0;
       CursorEnd : P := Length(S);
                  ^Y : Begin
                            Write(Replicate(Filler, Length(S)-P));
                     Delete(S, Succ(P), L);
                         End;
    End;
  Until CH In Next;
  P := Length(S);
  Input := S;
  BC := CH;
  CursorOff;
End;


Function IntToStr(Number : LongInt): String;
Var
  Temp : String;
begin
  Str(Number,Temp);
  IntToStr := RTrim(LTrim(Temp));
end;

Function JustL(InpStr: String; FieldLen: Integer): String;
Begin
     JustL := PadR(LTrim(InpStr),FieldLen)
End;

Procedure LookUp(SearchStr : string); {Find a key string in the open index.}
begin
     SearchKey(DBIndex,DBRecNum,SearchStr);
     If OK then
     begin
          GetDBRec(DBRecNum);
          Found := True;
     end
     else
     Found := False;
end;

Function LTrim(InpStr: String): String;
Var i,len : Integer;
Begin
     len := length(InpStr);
     i := 1;
     While (i <= len) and (InpStr[i] = ' ') do
           i := i + 1;
     LTrim := Copy(InpStr,i,len-i+1)
End;

Procedure MakeDBIndex(DBIndexName : FileName;KeyLen,Status : Integer);
begin
     MakeIndex(DBIndex,DBIndexName,KeyLen,Status);
     CloseIndex(DBIndex);
end;

Procedure Mark;
begin
     DBRecord^[1] := Chr(Ord($2A));
end;

Procedure NewDBRec;
begin
     If not Allocated then
     begin
          New(DBRecord);
          Allocated := True;
     end
     else
     begin
          Dispose(DBRecord);
          New(DBRecord);
          Allocated := True;
     end;
     FillChar(DBRecord^,SizeOf(DBRecord^),#32);
     DBRecNum := TotalRecs + 1;
end;

Procedure NextDBKey(KeyStr : DBKey);
begin
     If UCKey then KeyStr := Upper(KeyStr);
     NextKey(DBIndex,DBRecNum,KeyStr);
     GetDBRec(DBRecNum);
end;

Procedure NextRec;
begin
     GetDBRec(DBRecNum+1);
end;


Procedure OpenDBIndex(DBIndexName : FileName;KeyLen,Status : Integer);
begin
     OpenIndex(DBIndex,DBIndexName,KeyLen,Status);
     IndOpen := True;
end;

Procedure Pack;
Var
   FNo : Byte;
   J,TRec   : LongInt;

   Procedure PutTempRec(RecordNumber : LongInt); {Add new record, no index open.}
   begin
        DBRecNum := RecordNumber;
        RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
        Seek(TempFile,RecordNumber);
        BlockWrite(TempFile,DBRecord^,Header^.RecordLen,ErrCode);
   end;

   begin
        MAlloc := True;
        CloseDBFile;
        Malloc := False;
        DBReset;
        ReadDBHeader;
        Assign(TempFile,'temp.$$$');
        ReWrite(TempFile,1);
        BlockWrite(TempFile,Header^,32,ErrCode);
        For FNo := 1 to NumFields do
        Begin
           BlockWrite(TempFile,Fields^[FNo],32,ErrCode);
        end;
        Header^.Terminator := Chr(Ord($0D));
        BlockWrite(TempFile,Header^.Terminator,1,ErrCode);
        TRec := 1;
        For J := 1 to TotalRecs do
        begin
             GetDBRec(J);
             If not Deleted then
                begin
                PutTempRec(TRec);
                TRec := TRec + 1;
                end;
        end;
        CloseDBFile;
        Close(TempFile);
        Erase(DBFile);
        Rename(TempFile,DBFileName);
        DBOpenFile(DBFileName);
        TotalRecs := TRec-1;
        WriteDBHeader;
end;{Procedure Pack}

Function PadL(InpStr: String; FieldLen: Integer): String;
Var
   STemp : String;
   i : Integer;
Begin
   If FieldLen >= SizeOF(InpStr) then
      FieldLen := SizeOf(InpStr)-1;
   If length(InpStr) > FieldLen then
      PadL := Copy(InpStr,1,FieldLen)
   Else
      Begin
        STemp := InpStr;
        For i := Length(STemp)+1 to FieldLen do
           Insert(' ',STemp,1);
        PadL := STemp
      End
End;{PadL}

Function PadR(InpStr: String; FieldLen: Integer): String;
Var
   STemp : String;
   i : Integer;
Begin
   If FieldLen >= SizeOF(InpStr) then
      FieldLen := SizeOf(InpStr)-1;
   If length(InpStr) > FieldLen then
      PadR := Copy(InpStr,1,FieldLen)
   Else
      Begin
        STemp := InpStr;
        For i := Length(STemp)+1 to FieldLen do
           STemp := STemp + ' ';
        PadR := STemp
      End
End;{PadR}

Procedure PrevDBKey(KeyStr : DBKey);
begin
     If UCKey then KeyStr := Upper(KeyStr);
     PrevKey(DBIndex,DBRecNum,KeyStr);
     GetDBRec(DBRecNum);
end;

Procedure PrevRec;
begin
     GetDBRec(DBRecNum-1);
end;

Procedure Prompt(Row,Col : Byte;PromptStr : Str80);
begin
     Flash(Row,Col,Normal,PromptStr);
end;

Procedure PutDBRec(RecordNumber : LongInt); {Add new record, no index open.}
begin
     DBRecNum := RecordNumber;
     RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
     Seek(DBFile,RecordNumber);
     BlockWrite(DBFile,DBRecord^,Header^.RecordLen,ErrCode);
     Dispose(DBRecord);
     Allocated := False;
end;{PutDBRec}

Function ReadChar : Char;
Var
   CH : Char;
Begin
    ReadKb(ExtKey, CH);
    If ExtKey Then
   Begin
   Case CH Of
        #75 : CH := CursorLeft;
        #77 : CH := CursorRight;
        #72 : CH := CursorUp;
        #80 : CH := CursorDown;
        #73 : CH := PageUp;
        #81 : CH := PageDown;
        #71 : CH := CursorHome;
        #79 : CH := CursorEnd;
        #83 : CH := DelKey;
        Else  CH := #0;
     End;
    If CH = #9  Then CH := TabKey;
  End;
  ReadChar := CH;
End;

Procedure ReadDBHeader;
{Read .DBF header.}
Var
   FNo : Byte;
   begin
        BlockRead(DBFile,Header^,32,ErrCode);
        TotalRecs := Header^.RecCount;
        NumFields := (Header^.Location - 33) div 32;
        For FNo := 1 to NumFields do
        Begin
           BlockRead(DBFile,Fields^[FNo],32,ErrCode);
        end;
        For K := 1 to NumFields do
    begin
         Positions^[1,K] := 0;
         Positions^[2,K] := 0;
        end;
        Start := 2;
    For FNo := 1 to NumFields do
    begin
         Stop := Start+Fields^[FNo].FieldLen-1;
         Positions^[1,FNo] := Start;
         Positions^[2,FNo] := Stop;
         Start := Stop+1;
    end;
end;

Procedure ReadKB (Var ExtKey: Boolean; Var Ch: Char);
begin
  ExtKey := False;
  Ch := ReadKey;
  If Ch = #0 Then
  Begin
    ExtKey := True;
    Ch := ReadKey;
  End;
end;

Function RealToStr(Number : Real): String;
Var
  Temp : String;
  I    : Word;
Begin
  Str(Number:NumLen:Decimals, Temp);
  Temp := LTrim(Temp);
  I := Length(Temp);
  While Temp[I] = '0' Do Dec(I);
  If Temp[I] = '.' Then Dec(I);
  RealToStr := Copy(Temp, 1, I);
End;


Procedure Recall;
begin
     DBRecord^[1] := Chr(Ord($20));
end;

Procedure Repl(FNo : Byte;InStr : string);
Var
   KK : Byte;
   FF : Integer;
   Temp : String;
begin
     Temp := RTrim(Ltrim(InStr));
     For FF := Positions^[1,FNo] to Positions^[2,FNo] do
     begin
    DBRecord^[FF] := #32;
     end;
     KK := 1;
     For FF := Positions^[1,FNo] to Positions^[2,FNo] do
     begin
    DBRecord^[FF] := Temp[KK];
    KK := KK + 1;
    If KK>Length(Temp) then Exit;
     end;
end;

Procedure ReplEach(FNo : Byte;InStr : String);
Var
   J : LongInt;

begin
     DBReset;
     For J := 1 to TotalRecs do
     begin
          GetDBrec(J);
      Repl(FNo,InStr);
      PutDBRec(J);
     end;
end;

{$L tpdb.obj}

{$F+}
Function Lower;external;

Function Replicate;external;

Function Upper;external;

{F-}

Function RTrim(InpStr: String): String;
Var
   i : Integer;
Begin
   i := length(InpStr);
   While (i >= 1) and (InpStr[i] = ' ') do
      i := i - 1;
   RTrim := Copy(InpStr,1,i)
End;

Procedure Say(FNo,Row,Col : Byte);
Var
   GG : Integer;
   TempStr : String;
   Bool : Char;
   TempDate : String[8];
   Month,Day,Year : String[2];
   YY : Integer;
   MM,DD : Byte;
begin
     Case Chr(Ord(Fields^[FNo].FieldType)) of
          'C','N' : begin
              TempStr :='';
          For GG := Positions^[1,FNo] to Positions^[2,FNo] do
          TempStr := TempStr+DBRecord^[GG];
          Flash(Row,Col,Normal,TempStr);
          end;
      'L' : begin
              Bool := DBRecord^[Positions^[1,FNo]];
              Flash(Row,Col,Normal,Bool);
      end;
      'D' : begin
                  TempDate := FormDate(FieldToStr(FNo));
                  Flash(Row,Col,Normal,TempDate);
              end;
      end;
end;

Procedure SetColor(FG,BG : Byte);
begin
     TextColor(FG);
     TextBackGround(BG);
end;

Procedure ShowStatus; {Display .DBF status.}
Var
   FNo,K : Byte;
begin
     ClrScr;
     WriteLn('File name is ',Upper(DBFileName),'.');
     WriteLn('Last update was on ',Header^.Month,'/',Header^.Day,'/',Header^.Year,'.');
     WriteLn('Number of records is ',Header^.RecCount,'.');
     WriteLn('Data starts at byte # ',Header^.Location,'.');
     WriteLn('Record length is ',Header^.RecordLen,' bytes.');
     WriteLn('There are ',NumFields,' fields.');
     Wait;
     For FNo := 1 to NumFields do
     begin
          Write('Field # ',FNo:2,': ');
          For K := 1 to 11 do
          Write(Fields^[FNo].FieldName[K]);
          Write(' Type: ',Chr(Fields^[FNo].FieldType));
          Write('     Length: ',Fields^[FNo].FieldLen:3);
          If Chr(Ord(Fields^[FNo].FieldType))='N' then
             Write('     Decimals: ',Fields^[FNo].FieldDec:2);
          WriteLn;
          If FNo mod 20 = 0 then Wait;
     end;
     Wait;
     DBReset;
end;

Function Sum(FNo : Byte) : Real;
{Sums a numeric field.  If specified field is not numeric returns 0.}
Var
   J : LongInt;
   TempStr : String;
   TempReal : Real;
   EC : Integer;
   TotalSum : Real;
begin
     If Chr(Ord(Fields^[FNo].FieldType))<>'N' then
     begin
          Sum := 0;
      Exit;
     end
     else
     begin
          DBReset;
      TotalSum := 0;
      For J := 1 to TotalRecs do
      begin
        GetDBRec(J);
        TempStr := RTrim(LTrim(FieldToStr(FNo)));
        Val(TempStr,TempReal,EC);
        TotalSum := TotalSum + TempReal;
      end;
      end;
    Sum := TotalSum;
end;



Procedure Wait;
begin
     Writeln('Press any key to continue...');
     Ch := ReadKey;
end;


Procedure WriteDBHeader; {Update .DBF header.}
begin
     DBReset;
     GetDate(Y,M,D,DW);
     Y := Y-1900;
     Header^.Year := Y;
     Header^.Month := M;
     Header^.Day := D;
     Header^.RecCount := TotalRecs;
     BlockWrite(DBFile,Header^,32,ErrCode);
end;

Procedure Zap;
Var
   FNo : Byte;
begin
     ReWrite(DBFile,1);
     TotalRecs := 0;
     Header^.RecCount := 0;
     BlockWrite(DBFile,Header^,32,ErrCode);
     For FNo := 1 to NumFields do
     Begin
     BlockWrite(DBFile,Fields^[FNo],32,ErrCode);
     end;
     Header^.Terminator := Chr(Ord($0D));
     BlockWrite(DBFile,Header^.Terminator,1,ErrCode);
     DBReset;
end;

begin {TPDB}
     TAErrorProc := @BailOut;
     DBFOpen := False;
     IndOpen := False;
     Allocated := False;
     MAlloc := False;
     if CurrentVideoMode = 7 then
        VideoBase := $B000
     else
        VideoBase := $B800;
     VideoWait := (CurrVidDisplay = CGA);
     TErrorName := '';
     TPDBErr := 0;
end. {TPDB}

{End of Source Code - TPDB.pas}

{ Version 2.1
  - fixed bug in Display procedure which sometimes caused
    date field not to display properly.

  - fixed bug in FieldToStr procedure - changed FF from byte to integer.}