home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPDB311.ZIP / TPDB.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-02-14  |  44.3 KB  |  1,714 lines
  1. {$A+,B-,D+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
  2. {$M 16384,0,655360}
  3.  
  4. Unit TPDB;
  5.  
  6. {This version is Version 3.11 September, 1989}
  7.  
  8.  
  9.                             (***********************************)
  10.                             (*         Object -Oriented        *)
  11.                             (*     Turbo Pascal 5.5 Unit       *)
  12.                      (*    for Accessing dBASE III      *)
  13.                      (*             files.              *)
  14.                      (*        Copyright 1989           *)
  15.                      (*          Brian Corll            *)
  16.                      (*       All Rights Reserved       *)
  17.                      (*     dBASE is a registered       *)
  18.                      (* trademark of Ashton-Tate, Inc.  *)
  19.                             (*   Version 3.11  September 1989  *)
  20.                             (***********************************)
  21.                             (*   Portions Copyright 1984,1989  *)
  22.                             (*    Borland International Corp.  *)
  23.                             (***********************************)
  24.  
  25.  
  26. INTERFACE
  27.  
  28. Uses CRT,Dos,TPDBINDX,TPDBDate,TPDBScrn,TPDBStr;
  29.  
  30.  
  31. (******************************)
  32. (*      Global VARiables      *)
  33. (******************************)
  34.  
  35. CONST
  36.  
  37.   (**************************************************************************)
  38.     MaxInds = 10; {Maximum number of indexes per file.  Change this as needed.}
  39.   (**************************************************************************)
  40.  
  41.   AutoWrap    : Boolean = FALSE;
  42.   CursorDown  = ^X;
  43.   CursorEND   = ^F;
  44.   CursorHome  = ^A;
  45.   CursorLeft  = ^S;
  46.   CursorRight = ^D;
  47.   CursorUp    = ^E;
  48.   DelKey      = ^G;
  49.   Duplicates  =  1;
  50.   Escape      = ^[;
  51.  
  52.   ExtKey       : Boolean = FALSE;
  53.   Filler       : Char =  #32;
  54.   MaxLong      = 2147483647;
  55.   MaxReal      = 3.4E37;
  56.   MinLong      = -2147483647;
  57.   MinReal      = 1.5E-45;
  58.   NoDuplicates = 0;
  59.   PageDown     = ^C;
  60.   PageUp       = ^R;
  61.   Return       = ^M;
  62.   TabKey       = #9;
  63.   UpperCase    : Boolean = FALSE;
  64.  
  65.   {Date format constants}
  66.   {Used by SetDateFormat procedure}
  67.   French   = 1; {dd/mm/yy}
  68.   German   = 2; {dd.mm.yy}
  69.   Italian  = 3; {dd-mm-yy}
  70.   American = 4; {mm/dd/yy}
  71.   British  = 5; {dd/mm/yy}
  72.   Ansi     = 99;{yy.mm.dd}
  73.  
  74.  
  75.  
  76. Type
  77.   Str2     = String[2];
  78.   Str4     = String[4];
  79.   Str5     = String[5];
  80.   Str6     = String[6];
  81.   Str8     = String[8];
  82.   Str10    = String[10];
  83.   Str15    = String[15];
  84.   Str20    = String[20];
  85.   Str30    = String[30];
  86.   Str60    = String[60];
  87.   Str80    = String[80];
  88.   Str132   = String[132];
  89.   Str254   = String[254];
  90.   CharSet  = Set of Char;
  91.   ByteSet  = Set of Byte;
  92.  
  93.   FileName = String[66];
  94.   DBRecPtr = ^DBType;
  95.   DBType   = Array[1..4000] of Char;
  96.  
  97.      DBHeader = RECORD
  98.             DBType    : Byte;
  99.             Year      : Byte;
  100.             Month     : Byte;
  101.             Day       : Byte;
  102.             RecCount  : LongInt;
  103.             Location  : Integer;
  104.             RecordLen : Integer;
  105.             Reserved  : Array[1..20] of Byte;
  106.             Terminator : Char;
  107.             END;
  108.  
  109.      DBField = Record
  110.        FieldName    : Array[1..11] of Char;
  111.        FieldType    : Byte;
  112.        FieldAddress : LongInt;
  113.          FieldLen     : Byte;
  114.          FieldDec     : Byte;
  115.        Reserved     : Array[1..14] of Char;
  116.          END;
  117.  
  118.          HeadPtr = ^DBHeader;
  119.          PosPtr = ^DBEditArray;
  120.          FieldPtr = ^FieldArray;
  121.          DBEditArray = Array[1..2,1..128] of Integer;
  122.          FieldArray  = Array[1..128] of DBField;
  123.          DBIndex = RECORD
  124.               Ndx : IndexFile;
  125.               NdxID : BYTE;
  126.               NdxName : FileName;
  127.               Open : BOOLEAN;
  128.              END;
  129.  
  130.          NdxArray = ARRAY[1..MaxInds] OF DBIndex;
  131.          NdxPtr = ^NdxArray;
  132.  
  133. (*****************************************************************************)
  134. (*             Database File Object Declaration                              *)
  135. (*****************************************************************************)
  136.  
  137.          DataObject = ^DBF;
  138.  
  139.          DBF =  OBJECT
  140.                 DBFName     : FileName;
  141.                 DBFile      : File;
  142.                 Header      : HeadPtr;
  143.                 Fields      : FieldPtr;
  144.                 Positions   : ^DBEditArray;
  145.                 DBFOpen     : BOOLEAN;
  146.                 IndsOpen    : BOOLEAN;
  147.                 Indexes     : NdxPtr;
  148.                 DBRecord    : ^DBType;
  149.                 DBRecNum    : LONGINT;
  150.                 TotalRecs   : LONGINT;
  151.                 NumFields   : BYTE;
  152.                 MAlloc      : BOOLEAN;
  153.                 Start,Stop  : INTEGER;
  154.                 FUNCTION    Add(Field1,Field2 : Byte):string;VIRTUAL;
  155.                 PROCEDURE   AddDBKey(NdxID : BYTE;KeyStr : DBKey);VIRTUAL;
  156.                 PROCEDURE   AddDBRec;VIRTUAL;
  157.                 FUNCTION    Allocated : BOOLEAN;
  158.                 PROCEDURE   AppendBlank;VIRTUAL;
  159.                 PROCEDURE   BailOut;VIRTUAL;
  160.                 FUNCTION    BinSearch(FieldNo : BYTE;
  161.                     Position : Integer;SearchKey : DBKey) : LONGINT;
  162.                 FUNCTION    BOF : Boolean;VIRTUAL;
  163.                 PROCEDURE   CloseDBIndex(NdxID : BYTE);VIRTUAL;
  164.                 PROCEDURE   DBReset;VIRTUAL;
  165.                 PROCEDURE   DelDBKey(KeyStr : DBKey;NdxID : BYTE);VIRTUAL;
  166.                 FUNCTION    Deleted : Boolean;VIRTUAL;
  167.                 PROCEDURE   Display;VIRTUAL;
  168.                 FUNCTION    Divide(Field1,Field2 : Byte):string;VIRTUAL;
  169.                 DESTRUCTOR  Done;VIRTUAL;
  170.                 FUNCTION    DBEOF : BOOLEAN;VIRTUAL;
  171.                 FUNCTION    Field(FNo : Byte) : string;VIRTUAL;
  172.                 PROCEDURE   FillRecs(NumRecs : LongInt);VIRTUAL;
  173.                 PROCEDURE   Find(NdxID : BYTE;SearchStr : string);VIRTUAL;
  174.                 PROCEDURE   FlushDB;VIRTUAL;
  175.                 PROCEDURE   Get(FNo,X,Y : Byte);VIRTUAL;
  176.                 PROCEDURE   GetDBRec(RecordNumber : LongInt);VIRTUAL;
  177.                 FUNCTION    GetField(RecordNo : LongInt;FNo : Byte) : String;VIRTUAL;
  178.                 PROCEDURE   GoBottom;VIRTUAL;
  179.                 PROCEDURE   GoTop;VIRTUAL;
  180.                 FUNCTION    IIF(BoolVAR : Boolean;IfTRUE,IfFALSE : String) : String;VIRTUAL;
  181.                 PROCEDURE   IndexOn(NdxID : BYTE;NdxName : FileName;
  182.                     NdxField : BYTE;DupFlag : BYTE);
  183.                 CONSTRUCTOR Init(DBName : FileName);
  184.                 FUNCTION    Locate(FieldNo : BYTE;SearchStr : String) : BOOLEAN;
  185.                 PROCEDURE   LookUp(SearchStr : string;NdxID : BYTE);VIRTUAL;
  186.                 PROCEDURE   MakeDBIndex(NdxID : BYTE;DBIndexName : FileName;KeyLen,Status : Integer);VIRTUAL;
  187.                 PROCEDURE   Mark;VIRTUAL;
  188.                 FUNCTION    Mul(Field1,Field2 : Byte):string;VIRTUAL;
  189.                 PROCEDURE   NextDBKey(NdxID : BYTE;KeyStr : DBKey);VIRTUAL;
  190.                 PROCEDURE   NewDBRec;VIRTUAL;
  191.                 PROCEDURE   NextRec;VIRTUAL;
  192.                 PROCEDURE   OpenDBIndex(NdxID : BYTE;DBIndexName : FileName;KeyLen,Status : Integer);VIRTUAL;
  193.                 PROCEDURE   Pack;VIRTUAL;
  194.                 PROCEDURE   PrevDBKey(NdxID : BYTE;KeyStr : DBKey);VIRTUAL;
  195.                 PROCEDURE   PrevRec;VIRTUAL;
  196.                 PROCEDURE   PutDBRec(RecordNumber : LongInt);VIRTUAL;
  197.                 PROCEDURE   ReadDBHeader;VIRTUAL;
  198.                 PROCEDURE   Recall;VIRTUAL;
  199.                 FUNCTION    RecCount : LONGINT;VIRTUAL;
  200.                 FUNCTION    RecNo : LONGINT;VIRTUAL;
  201.                 PROCEDURE   Repl(FNo : Byte;InStr : string);VIRTUAL;
  202.                 PROCEDURE   ReplEach(FNo : Byte;InStr : String);VIRTUAL;
  203.                 PROCEDURE   Save;VIRTUAL;
  204.                 PROCEDURE   Say(FNo,Row,Col : Byte);VIRTUAL;
  205.                 PROCEDURE   ShowStatus;VIRTUAL;
  206.                 PROCEDURE   Skip;VIRTUAL;
  207.                 FUNCTION    Sub(Field1,Field2 : Byte) : string;VIRTUAL;
  208.                 FUNCTION    Sum(FNo : Byte) : Real;VIRTUAL;
  209.                 PROCEDURE   WriteDBHeader;VIRTUAL;
  210.                 PROCEDURE   Zap;VIRTUAL;
  211.             END;
  212.  
  213. (****************************************************************************)
  214. (*          END Object Declaration                                          *)
  215. (****************************************************************************)
  216.  
  217. Const
  218.  
  219.             Up   : CharSet = [CursorUp];
  220.             Down : CharSet = [CursorDown,Return];
  221.             Next : CharSet = [Escape];
  222.  
  223. VAR
  224.             FilesOpen : BYTE;
  225.             UCKey : BOOLEAN;
  226.             ErrCode : INTEGER;
  227.             Found : BOOLEAN;
  228.             Ch,BC : CHAR;
  229.             Normal,Reverse : BYTE;
  230.             Decimals : Byte;
  231.             TempFile : File;
  232.             K : Byte;
  233.             NumLen : Byte;
  234.             Y,M,D,DW : WORD;
  235.             FromPack : BOOLEAN;
  236.             DateFormat : BYTE;
  237.  
  238. (**********************************)
  239. (*   PROCEDUREs and FUNCTIONs     *)
  240. (**********************************)
  241.  
  242. PROCEDURE Beep;
  243. {Sound a couple of tones.}
  244.  
  245. FUNCTION BoolToStr(Param : Byte;IfTRUE,IfFALSE : Char): String;
  246.  
  247.  
  248. PROCEDURE CheckScreen(VAR CurrPos:Byte;BC:Char;Up,Down:CharSet;Low,High:Byte);
  249. {Used in full screen editing.}
  250.  
  251. PROCEDURE CopyFile(Source,Dest : FileName);
  252.  
  253. PROCEDURE FlashFill(Row,Col,Rows,Cols,Attr : Byte;Ch : Char);
  254. {Fill a region of the screen with a specified color and character.}
  255.  
  256. FUNCTION GetBoolean(VAR Param:Byte;IfTRUE,IfFALSE:Char;X,Y:Byte):Char;
  257.  
  258. FUNCTION GetByte(VAR Param:Byte;LowLim,UpLim,Len,X,Y:Byte):Char;
  259.  
  260. FUNCTION GetInteger(VAR Param:Integer;LowLim,UpLim:Integer;Len,X,Y:Byte):Char;
  261. {Input an integer.}
  262.  
  263. FUNCTION GetLongInt(VAR Param:LongInt;LowLim,UpLim:LongInt;Len,X,Y:Byte):Char;
  264. {Input a long integer.}
  265.  
  266. FUNCTION GetReal(VAR Param : Real; LowLim, UpLim : Real; Len, X, Y : Word) : Char;
  267. {Input a real number.}
  268.  
  269. FUNCTION GetString(VAR Param : String; Len, X, Y : Byte) : Char;
  270. {Input a string.}
  271.  
  272. FUNCTION Input(VAR S:String;Term:CharSet;L,X,Y:Byte;VAR BC:Char):String;
  273.  
  274. FUNCTION IntToStr(Number : LongInt): String;
  275.  
  276. FUNCTION Max(N1,N2 : Integer) : Integer;
  277.  
  278. FUNCTION Min(N1,N2 : Integer) : Integer;
  279.  
  280. PROCEDURE Prompt(Row,Col : Byte;PromptStr : Str80);
  281. {Display a prompt at a specified row and column.}
  282.  
  283. FUNCTION ReadChar : Char;
  284.  
  285. PROCEDURE ReadKB (VAR ExtKey: Boolean; VAR Ch: Char);
  286.  
  287. FUNCTION RealToStr(Number : Real): String;
  288.  
  289. PROCEDURE SetDateFormat(Format : BYTE);
  290.  
  291. PROCEDURE SetDBColor(FG,BG : Byte);
  292. {Set initial foreground and background colors.}
  293.  
  294. PROCEDURE Wait;
  295. {Wait for a key press and display a message.}
  296.  
  297.  
  298. IMPLEMENTATION
  299.  
  300. FUNCTION DBF.Add(Field1,Field2 : Byte):string;
  301.     (* Adds two fields and returns the string of the sum. *)
  302. VAR
  303.         T1,T2,T3 : String;
  304.         A1,A2,A3 : Real;
  305.         ErrCode : Integer;
  306. BEGIN
  307.         T1 := RTrim(Field(Field1));
  308.         T2 := RTrim(Field(Field2));
  309.         Val(T1,A1,ErrCode);
  310.         Val(T2,A2,ErrCode);
  311.         A3 := A1+A2;
  312.         Str(A3 : Max(Fields^[Field1].FieldLen,Fields^[Field2].FieldLen) :
  313.                 Max(Fields^[Field1].FieldDec,Fields^[Field2].FieldDec),T3);
  314.         Add := LTrim(T3);
  315. END;
  316.  
  317. PROCEDURE DBF.AddDBKey(NdxID : BYTE;KeyStr : DBKey);
  318. BEGIN
  319.      If UCKey then KeyStr := Upper(KeyStr);
  320.       AddKey(Indexes^[NdxID].Ndx,DBRecNum,KeyStr);
  321. END;
  322.  
  323. PROCEDURE DBF.AddDBRec; {Add new record, no index open.}
  324. VAR
  325.    RecordNumber : LongInt;
  326. BEGIN
  327.      TotalRecs := TotalRecs + 1;
  328.      RecordNumber := TotalRecs;
  329.      DBRecNum := RecordNumber;
  330.      RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  331.      Seek(DBFile,RecordNumber);
  332.      BlockWrite(DBFile,DBRecord^,Header^.RecordLen,ErrCode);
  333.      Dispose(DBRecord);
  334. END;
  335.  
  336. FUNCTION DBF.Allocated : BOOLEAN;
  337. BEGIN
  338.     Allocated := (DBRecord <> NIL);
  339. END;
  340.  
  341. PROCEDURE DBF.AppendBlank;
  342. VAR
  343.     RecordNumber : LONGINT;
  344. BEGIN
  345.     NewDBRec;
  346.    TotalRecs := TotalRecs + 1;
  347.     RecordNumber := TotalRecs;
  348.     DBRecNum := RecordNumber;
  349.     RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  350.     Seek(DBFile,RecordNumber);
  351.     BlockWrite(DBFile,DBRecord^,Header^.RecordLen,ErrCode);
  352. END;
  353.  
  354.  
  355. PROCEDURE DBF.BailOut;
  356. VAR
  357.    Message : String[80];
  358.     Number : string;
  359.     ID : BYTE;
  360. BEGIN
  361.      GotOne := TRUE;
  362.       FOR ID := 1 TO MaxInds DO
  363.       IF Indexes^[ID].Open THEN
  364.             CloseDBIndex(ID);
  365.       IndsOpen := FALSE;
  366.      SetDBColor(White,Blue);
  367.      ClrScr;
  368.      Case TPDBErr of
  369.           1    : Message := 'Invalid DOS FUNCTION code !';
  370.              2    : Message := 'File not found ! '+
  371.         IIF(Length(RTrim(LTrim(TErrorName)))<>0,' -- > '+Upper(TErrorName),'');
  372.           3    : Message := 'Path not found !';
  373.           4    : Message := 'Too many open files !';
  374.           5    : Message := 'File access denied !';
  375.           6    : Message := 'Invalid file handle !';
  376.              8    : Message := 'Not enough memory !';
  377.              9    : Message := 'Too many open indexes !';
  378.           12   : Message := 'Invalid file access code !';
  379.           15   : Message := 'Invalid drive number !';
  380.           16   : Message := 'Cannot remove current directory !';
  381.           17   : Message := 'Cannot rename across drives !';
  382.           100  : Message := 'Disk read error !';
  383.           101  : Message := 'Disk write error !';
  384.           102  : Message := 'File not assigned !';
  385.           103  : Message := 'File not open !';
  386.           104  : Message := 'File not open for input !';
  387.           105  : Message := 'File not open for output !';
  388.           106  : Message := 'Invalid numeric format !';
  389.           200  : Message := 'Division by zero !';
  390.           201  : Message := 'Range check error !';
  391.           202  : Message := 'Stack overflow error !';
  392.           203  : Message := 'Heap overflow error !';
  393.           204  : Message := 'Invalid pointer operation !';
  394.           1000 : Message := 'Record size is greater than 4000 chars !';
  395.           1002 : Message := 'Specified Index Key Length is greater than 254 chars !';
  396.           1003 : Message := 'Invalid DBF File structure !';
  397.           1004 : Message := 'Index File created with different key size !';
  398.           1005 : Message := 'Not enough memory for index page stack !';
  399.           END;
  400.              Beep;Beep;
  401.              FlashC(8,White+BlueBG,'TPDB Version 3.11');
  402.              FlashC(10,Yellow+BlueBG,'ERROR !');
  403.              FlashC(12,White+RedBG,Message);
  404.           CursorOff;
  405.              FlashC(14,LightRed+BlueBG,'Press any key to halt program....');
  406.              FlashC(16,LightCyan+BlueBG,'Copyright 1989 Brian Corll');
  407.           Repeat Until KeyPressed;
  408.           TErrorName := '';
  409.           TPDBErr := 0;
  410.           SetDBColor(White,Black);
  411.           ClrScr;
  412.           Halt(1);
  413. END;
  414.  
  415. PROCEDURE Beep;
  416. BEGIN
  417.   Sound(1500); Delay(50);
  418.   Sound(1000); Delay(50);
  419.   NoSound;
  420. END;
  421.  
  422. FUNCTION DBF.BinSearch(FieldNo : BYTE;Position : Integer;SearchKey : DBKey) : LONGINT;
  423. {Implements a binary search for sorted files of unique elements }
  424.  
  425. VAR
  426.     Width : Integer;
  427.     J,Low,High,Result : LONGINT;
  428. BEGIN
  429.     Width := Length(SearchKey);
  430.     IF Width < 1 THEN EXIT;
  431.     Low := 1;
  432.     High := TotalRecs;
  433.     WHILE High >= Low DO
  434.     BEGIN
  435.         J := (Low + High) DIV 2;
  436.         GetDBRec(J);
  437.         IF SearchKey < Copy(Field(FieldNo),Position,Width) THEN
  438.             High := J-1
  439.         ELSE
  440.             IF SearchKey > Copy(Field(FieldNo),Position,Width) then
  441.                 Low := J + 1
  442.             ELSE
  443.             BEGIN
  444.                 BinSearch := J;
  445.                 EXIT
  446.             END
  447.     END;
  448.     BinSearch := 0;
  449. END;
  450.  
  451.  
  452. FUNCTION DBF.BOF : Boolean;
  453. BEGIN
  454.      If DBRecNum = 1 then
  455.         BOF := TRUE
  456.      else BOF := FALSE;
  457. END;
  458.  
  459. FUNCTION BoolToStr(Param : Byte;IfTRUE,IfFALSE : Char): String;
  460. VAR
  461.   Temp : String;
  462. BEGIN
  463.   Case Param of
  464.     0: Temp := Filler;
  465.     1: Temp := IfTRUE;
  466.     2: Temp := IfFALSE;
  467.   END;
  468.   BoolToStr:=Temp;
  469. END;
  470.  
  471.  
  472.  
  473. PROCEDURE CheckScreen(VAR CurrPos:Byte;BC:Char;Up,Down:CharSet;Low,High:Byte);
  474.  
  475. BEGIN
  476.   If (BC In Down) Then
  477.      If CurrPos = High Then CurrPos := Low
  478.      Else Inc(CurrPos)
  479.   Else
  480.      If (BC In Up) Then
  481.         If CurrPos = Low Then CurrPos := High
  482.         Else Dec(CurrPos)
  483. END;
  484.  
  485.  
  486. DESTRUCTOR DBF.Done;
  487. VAR
  488.     EOFMarker : Byte;
  489.     Z : BYTE;
  490. BEGIN
  491.      WriteDBHeader;
  492.      EOFMarker := $1A;
  493.       Seek(DBFile,Header^.Location+(Header^.RecCount*Header^.RecordLen));
  494.      BlockWrite(DBFile,EOFMarker,1);
  495.      Close(DBFile);
  496.      Dec(FilesOpen);
  497.      If not MAlloc then
  498.      BEGIN
  499.           Dispose(Header);
  500.           Dispose(Fields);
  501.           Dispose(Positions);
  502.       END;
  503.       IF Allocated THEN
  504.       BEGIN
  505.           DISPOSE(DBRecord);
  506.       END;
  507.       DBFOpen := FALSE;
  508.       FOR Z := 1 to MaxInds DO
  509.       BEGIN
  510.             IF Indexes^[Z].Open THEN
  511.             BEGIN
  512.             CloseDBIndex(Z);
  513.             Indexes^[Z].Open := FALSE;
  514.             END;
  515.       END;
  516.       IF FromPack THEN
  517.             FromPack := FALSE
  518.       ELSE
  519.            Dispose(Indexes);
  520. END;
  521.  
  522. PROCEDURE DBF.CloseDBIndex(NdxID : BYTE);
  523. BEGIN
  524.       IF Indexes^[NdxID].Open THEN
  525.       BEGIN
  526.       CloseIndex(Indexes^[NdxID].Ndx);
  527.       Indexes^[NdxID].Open := FALSE;
  528.       END;
  529.       DEC(FilesOpen);
  530. END;
  531.  
  532. PROCEDURE CopyFile(Source,Dest : FileName);
  533. { Copies a .DBF file to another .DBF file }
  534. TYPE
  535.   FileBuffer = ARRAY[1..65521] OF BYTE;
  536. VAR
  537.   Buffer           : ^BYTE;
  538.   InFile,OutFile   : File;
  539.   ErrorCode,
  540.   BlocksRead,
  541.   BlocksWritten    : WORD;
  542.   Time             : LONGINT;
  543.   BufferSize       : WORD;
  544. Begin
  545.   BufferSize := SizeOf(FileBuffer);
  546.   IF (BufferSize > MaxAvail) THEN BufferSize := MaxAvail;
  547.   GetMem(Buffer,BufferSize);
  548.   Assign(InFile,Source);
  549.   Reset(InFile,1);
  550.   ErrorCode := IOResult;
  551.   GetFTime(InFile,Time);
  552.   If ErrorCode = 0 then
  553.   Begin
  554.      Assign(OutFile,Dest);
  555.      Rewrite(OutFile,1);
  556.     ErrorCode := IOResult;
  557.     If ErrorCode = 0 Then
  558.     Begin
  559.       Repeat
  560.           BlockRead(InFile,Buffer^,BufferSize,BlocksRead);
  561.           BlockWrite(OutFile,Buffer^,BlocksRead,BlocksWritten);
  562.           If BlocksWritten < BlocksRead Then ErrorCode := 81;
  563.       Until ((ErrorCode <> 0) OR (BlocksRead < BufferSize));
  564.         SetFTime(OutFile,Time);
  565.         Close(OutFile);
  566.         If ErrorCode <> 0 Then Erase(OutFile);
  567.     End;
  568.      Close(InFile);
  569.   End;
  570.   FreeMem(Buffer,BufferSize);
  571. End; { CopyFile }
  572.  
  573.  
  574. PROCEDURE DBF.DBReset; {Reset dBASE file.}
  575. BEGIN
  576.      {$I-} Reset(DBFile,1); {$I+}
  577.      If TPDBErr=0 then TPDBErr := IOResult;
  578.       If (TPDBErr<>0) and (not GotOne) then
  579.       BEGIN
  580.       TErrorName := DBFName;
  581.       BailOut;
  582.       END;
  583. END;
  584.  
  585. PROCEDURE DBF.DelDBKey(KeyStr : DBKey;NdxID : BYTE);
  586. BEGIN
  587.      If UCKey then KeyStr := Upper(KeyStr);
  588.       DeleteKey(Indexes^[NdxID].Ndx,DBRecNum,KeyStr);
  589. END;
  590.  
  591. FUNCTION DBF.Deleted : Boolean;
  592. BEGIN
  593.      If DBRecord^[1] = Chr(Ord($2A)) then
  594.         Deleted := TRUE
  595.      else
  596.          Deleted := FALSE;
  597. END;
  598.  
  599. PROCEDURE DBF.Display;
  600. VAR
  601.     FNo : Byte;
  602.     K   : Integer;
  603.  
  604. BEGIN
  605.      ClrScr;
  606.      For FNo := 1 to NumFields do
  607.      BEGIN
  608.           For K := 1 to 11 do
  609.              Write(Fields^[FNo].FieldName[K]);
  610.           Write(': ');
  611.           If Chr(Ord(Fields^[FNo].FieldType)) = 'D' then
  612.           Write(FormDate(Field(FNo)))
  613.           else Write(Field(FNo));
  614.           Writeln;
  615.       If FNo mod 23 = 0 then
  616.       BEGIN
  617.       Wait;
  618.       ClrScr;
  619.       END;
  620.      END;
  621. END;
  622.  
  623. FUNCTION DBF.Divide(Field1,Field2 : Byte):string;
  624.     (* Divide field1 BY field 2 *)
  625. VAR
  626.         T1,T2,T3 : String;
  627.         D1,D2,D3 : Real;
  628. BEGIN
  629.         T1 := RTrim(Field(Field1));
  630.         T2 := RTrim(Field(Field2));
  631.         Val(T1,D1,ErrCode);
  632.         Val(T2,D2,ErrCode);
  633.         D3 := D1/D2;
  634.         Str(D3 : Max(Fields^[Field1].FieldLen,Fields^[Field2].FieldLen) :
  635.                 Max(Fields^[Field1].FieldDec,Fields^[Field2].FieldDec),T3);
  636.         Divide := LTrim(T3);
  637. END;
  638.  
  639. FUNCTION DBF.DBEOF : BOOLEAN;
  640. BEGIN
  641.       If DBRecNum >= TotalRecs then
  642.           DBEOF := TRUE
  643.       else DBEOF := FALSE;
  644. END;
  645.  
  646. FUNCTION DBF.Field(FNo : Byte) : string;
  647. VAR
  648.    Temp : String;
  649. BEGIN
  650.      Temp[0] := Chr(Ord(Fields^[FNo].FieldLen));
  651.      Move(DBRecord^[Positions^[1,FNo]],Temp[1],Fields^[FNo].FieldLen);
  652.      Temp := PadR(Temp,Fields^[FNo].FieldLen);
  653.      Field := Temp;
  654. END;
  655.  
  656. PROCEDURE DBF.FillRecs(NumRecs : LongInt);
  657. VAR
  658.    J : LongInt;
  659. BEGIN
  660.       If TotalRecs>0 then GoBottom;
  661.      For J := 1 to NumRecs do
  662.      BEGIN
  663.           NewDBRec;
  664.           AddDBRec;
  665.      END;
  666. END;
  667.  
  668. PROCEDURE DBF.Find(NdxID : BYTE;SearchStr : string);
  669. BEGIN
  670.       FindKey(Indexes^[NdxID].Ndx,DBRecNum,SearchStr);
  671.      If OK then
  672.      BEGIN
  673.           GetDBRec(DBRecNum);
  674.           Found := TRUE;
  675.      END
  676.      else
  677.      Found := FALSE;
  678. END;
  679.  
  680. PROCEDURE FlashFill(Row,Col,Rows,Cols,Attr : Byte;Ch : Char);
  681. VAR
  682.    Z : Byte;
  683.    Temp : String;
  684. BEGIN
  685.      Temp := Replicate(Ch,Cols);
  686.      For Z := Row to Row + Rows-1 do
  687.          Flash(Z,Col,Attr,Temp);
  688. END;
  689.  
  690.  
  691.  
  692. PROCEDURE DBF.FlushDB;
  693. BEGIN
  694.      MAlloc := TRUE;
  695.       Done;
  696.      MAlloc := FALSE;
  697.      DBReset;
  698. END;
  699.  
  700. PROCEDURE DBF.Get(FNo,X,Y : Byte);
  701. VAR
  702.    TempStr1 : string;
  703.  
  704.          PROCEDURE Character;
  705.          BEGIN
  706.          TempStr1 := Field(FNo);
  707.          BC := GetString(TempStr1,Fields^[FNo].FieldLen,Y,X);
  708.          Repl(FNo,TempStr1);
  709.          TempStr1 := PadR(TempStr1,Fields^[FNo].FieldLen);
  710.          Flash(X,Y,Normal,Tempstr1);
  711.          END; {PROCEDURE Character}
  712.  
  713.          PROCEDURE Numeric;
  714.          VAR
  715.             NumLen : Byte;
  716.             TempInt : LongInt;
  717.             TempReal : Real;
  718.             RealStr,IntStr : String;
  719.          BEGIN
  720.               NumLen := Fields^[FNo].FieldLen;
  721.            Decimals := Fields^[FNo].FieldDec;
  722.               {If field is a real number}
  723.               If Decimals>0 then
  724.               BEGIN
  725.            RealStr := '';
  726.               TempReal := 0;
  727.               RealStr := Field(FNo);
  728.            Val(RealStr,TempReal,ErrCode);
  729.               BC := GetReal(TempReal,MinReal,MaxReal,NumLen,Y,X);
  730.               Str(TempReal : NumLen : Decimals,RealStr);
  731.               Repl(FNo,RealStr);
  732.               Flash(X,Y,Normal,RealStr);
  733.               END
  734.               else
  735.               {Otherwise, it's an integer value}
  736.               BEGIN
  737.               IntStr := '';
  738.               TempInt := 0;
  739.               IntStr := Field(FNo);
  740.            Val(IntStr,TempInt,ErrCode);
  741.               BC := GetLongInt(TempInt,MinLong,MaxLong,NumLen,Y,X);
  742.               Str(TempInt : NumLen,IntStr);
  743.               Repl(FNo,IntStr);
  744.               Flash(X,Y,Normal,IntStr);
  745.               END;
  746.          END; {PROCEDURE Numeric}
  747.  
  748.          PROCEDURE Dates;
  749.          VAR
  750.             TempDate,TmpDat2 : String[8];
  751.             MM,DD,DC : Byte;
  752.             YY,GG : Integer;
  753.             TM,TD,TY,Month,Day : String[2];
  754.             Year : String[4];
  755.          BEGIN
  756.               TempDate := '';
  757.               TempDate := Field(FNo);
  758.               Repeat
  759.               Year := Copy(TempDate,1,4);
  760.               Month := Copy(TempDate,5,2);
  761.               Day := Copy(TempDate,7,2);
  762.               Val(Year,YY,ErrCode);
  763.               Val(Month,MM,ErrCode);
  764.               Val(Day,DD,ErrCode);
  765.                       If YY>=1900 then YY := YY-1900;
  766.                       Case DateFormat of
  767.                       American : BEGIN
  768.                                             BC := GetByte(MM,0,12,2,Y,X);
  769.                                             BC := GetByte(DD,0,31,2,Y+3,X);
  770.                                             BC := GetInteger(YY,0,99,2,Y+6,X);
  771.                                             END;
  772.                              French   : BEGIN
  773.                                             BC := GetByte(DD,0,31,2,Y,X);
  774.                                             BC := GetByte(MM,0,12,2,Y+3,X);
  775.                                             BC := GetInteger(YY,0,99,2,Y+6,X);
  776.                                             END;
  777.                              Italian  : BEGIN
  778.                                      BC := GetByte(DD,0,31,2,Y,X);
  779.                                             BC := GetByte(MM,0,12,2,Y+3,X);
  780.                                             BC := GetInteger(YY,0,99,2,Y+6,X);
  781.                                             END;
  782.                              German   : BEGIN
  783.                                       BC := GetByte(DD,0,31,2,Y,X);
  784.                                             BC := GetByte(MM,0,12,2,Y+3,X);
  785.                                             BC := GetInteger(YY,0,99,2,Y+6,X);
  786.                                             END;
  787.                       Ansi     : BEGIN
  788.                                             BC := GetInteger(YY,0,99,2,Y,X);
  789.                                             BC := GetByte(MM,0,12,2,Y+3,X);
  790.                                             BC := GetByte(DD,0,31,2,Y+6,X);
  791.                                             END;
  792.                              British  : BEGIN
  793.                                      BC := GetByte(DD,0,31,2,Y,X);
  794.                                             BC := GetByte(MM,0,12,2,Y+3,X);
  795.                                             BC := GetInteger(YY,0,99,2,Y+6,X);
  796.                                             END;
  797.                       END;
  798.               Str(MM,Month);
  799.               Str(DD,Day);
  800.               YY := YY + 1900;
  801.               Str(YY:4,Year);
  802.               If DD<10 then Day := '0'+Day;
  803.               If MM<10 then Month := '0'+Month;
  804.               TempDate :=Year+Month+Day;
  805.                       If not ValidDate(TempDate) then Beep;
  806.                       Case DateFormat of
  807.                       American : BEGIN
  808.                                    TmpDat2 := Copy(TempDate,5,2)+'/'+Copy(TempDate,7,2)+'/'+
  809.                                    Copy(TempDate,3,2);
  810.                                    END;
  811.                       French   : BEGIN
  812.                                  TmpDat2 := Copy(TempDate,7,2)+'/'+Copy(TempDate,5,2)+
  813.                                               '/'+Copy(TempDate,3,2)
  814.                                             END;
  815.                              Italian  : BEGIN
  816.                                  TmpDat2 := Copy(TempDate,7,2)+'-'+Copy(TempDate,5,2)+
  817.                                               '-'+Copy(TempDate,3,2)
  818.                                             END;
  819.                              German   : BEGIN
  820.                                  TmpDat2 := Copy(TempDate,7,2)+'.'+Copy(TempDate,5,2)+
  821.                                               '.'+Copy(TempDate,3,2)
  822.                                             END;
  823.                              Ansi     : BEGIN
  824.                                  TmpDat2 := Copy(TempDate,3,2)+'.'+Copy(TempDate,5,2)+
  825.                                               '.'+Copy(TempDate,7,2)
  826.                                             END;
  827.                              British  : BEGIN
  828.                                  TmpDat2 := Copy(TempDate,7,2)+'/'+Copy(TempDate,5,2)+
  829.                                               '/'+Copy(TempDate,3,2)
  830.                                             END;
  831.  
  832.                       END;
  833.               Flash(X,Y,Normal,TmpDat2);
  834.               Until ValidDate(TempDate);
  835.               Repl(FNo,TempDate);
  836.          END; {PROCEDURE Dates}
  837.  
  838.          PROCEDURE Logical;
  839.          VAR
  840.             BoolVAR : Byte;
  841.          TF : String[1];
  842.       BEGIN
  843.             Case DBRecord^[Positions^[1,FNo]] of
  844.                  'Y' : BoolVAR := 1;
  845.                  'N' : BoolVAR := 2
  846.                  else BoolVAR := 0;
  847.                  END;
  848.          BC := GetBoolean(BoolVAR,'Y','N',Y,X);
  849.          TF := BoolToStr(BoolVAR,'Y','N');
  850.          DBRecord^[Positions^[1,FNo]] := TF[1];
  851.             Flash(X,Y,Normal,TF);
  852.          END;
  853.  
  854. VAR
  855.    Z : Byte;
  856.  
  857.      BEGIN {PROCEDURE Get}
  858.                 Case Chr(Ord(Fields^[FNo].FieldType)) of
  859.           'C'     : Character;
  860.           'L'     : Logical;
  861.           'N'     : Numeric;
  862.           'D'     : Dates;
  863.           END;
  864.      END;{PROCEDURE Get}
  865.  
  866.  
  867. FUNCTION GetBoolean(VAR Param:Byte;IfTRUE,IfFALSE:Char;X,Y:Byte):Char;
  868. VAR
  869.   BC    : Char;
  870.   Temp  : String;
  871.   Value : Byte;
  872. BEGIN
  873.   Value := Param;
  874.   Temp := BoolToStr(Value,IfTRUE,IfFALSE);
  875.   UpperCase := TRUE;
  876.   Temp := Input(Temp,[IfTRUE,IfFALSE],1,X,Y,BC);
  877.   If Length(Temp) =  0 Then
  878.   BEGIN
  879.     Param := 0;
  880.     Flash(Y,X,Normal,BoolToStr(Param,IfTRUE,IfFALSE));
  881.   END
  882.   Else
  883.   BEGIN
  884.     If Temp = Filler  Then Param := 0;
  885.     If Temp = IfTRUE  Then Param := 1;
  886.     If Temp = IfFALSE Then Param := 2;
  887.   END;
  888.   UpperCase := FALSE;
  889.   GetBoolean := BC;
  890. END;
  891.  
  892. FUNCTION GetByte(VAR Param:Byte;LowLim,UpLim,Len,X,Y:Byte):Char;
  893. VAR
  894.   BC : Char;
  895.   WW,WL,WH : LongInt;
  896. BEGIN
  897.   WW := LongInt(Param);
  898.   WL := LongInt(LowLim);
  899.   WH := LongInt(UpLim);
  900.   BC := GetLongInt(WW,WL,WH,Len,X,Y);
  901.   Param := Byte(WW);
  902.   GetByte := BC;
  903. END;
  904.  
  905. PROCEDURE DBF.GetDBRec(RecordNumber : LongInt);
  906. BEGIN
  907.      If not Allocated then
  908.      BEGIN
  909.           New(DBRecord);
  910.      END
  911.      else
  912.       BEGIN
  913.              Dispose(DBRecord);
  914.           New(DBRecord);
  915.      END;
  916.      DBRecNum := RecordNumber;
  917.      RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  918.      Seek(DBFile,RecordNumber);
  919.      BlockRead(DBFile,DBRecord^,Header^.RecordLen,ErrCode);
  920. END;
  921.  
  922. FUNCTION DBF.GetField(RecordNo : LongInt;FNo : Byte) : String;
  923.  
  924. Type
  925.     FldArray = Array[1..254] of Char;
  926.  
  927. VAR
  928.     TempArray : FldArray;
  929.  
  930.     FldAddr,RecordNumber : LongInt;
  931.     Temp : String[254];
  932.     K : Byte;
  933.  
  934. BEGIN
  935.     If FNo = 1 then FldAddr := 1
  936.     else
  937.     BEGIN
  938.         FldAddr := 1;
  939.         For K := 1 to FNo-1 do
  940.         FldAddr := FldAddr+Fields^[K].FieldLen;
  941.     END;
  942.     RecordNumber := (RecordNo - 1) * Header^.RecordLen + Header^.Location+FldAddr;
  943.     Seek(DBFile,RecordNumber);
  944.     BlockRead(DBFile,TempArray,Fields^[FNo].FieldLen,ErrCode);
  945.     Temp := '';
  946.     For K := 1 to Fields^[FNo].FieldLen do
  947.         Temp := Temp+TempArray[K];
  948.     GetField := Temp;
  949. END;
  950.  
  951.  
  952. FUNCTION GetInteger(VAR Param:Integer;LowLim,UpLim:Integer;Len,X,Y:Byte):Char;
  953. VAR
  954.   BC : Char;
  955.   WW,WL,WH : LongInt;
  956. BEGIN
  957.   WW := LongInt(Param);
  958.   WL := LongInt(LowLim);
  959.   WH := LongInt(UpLim);
  960.   BC := GetLongInt(WW,WL,WH,Len,X,Y);
  961.   Param := Integer(WW);
  962.   GetInteger := BC;
  963. END;
  964.  
  965. FUNCTION GetLongInt(VAR Param:LongInt;LowLim,UpLim:LongInt;Len,X,Y:Byte):Char;
  966. VAR
  967.   Temp     : String;
  968.   P, Value : LongInt;
  969.   I        : Integer;
  970.   Err      : Boolean;
  971.   BC       : Char;
  972. BEGIN
  973.   Repeat
  974.     Err := FALSE;
  975.      Str(Param, Temp);
  976.     Temp := Input(Temp, ['0'..'9'], Len, X, Y, BC);
  977.     Val(Temp, P, I);
  978.     If length(Temp) = 0 Then Value := 0
  979.     Else If I = 0 Then Value := P
  980.          Else
  981.          BEGIN
  982.            Value := Param;
  983.            Beep;
  984.            Err := TRUE;
  985.          END;
  986.     If (Not((Value >= LowLim) And (Value <= UpLim))) Then Beep;
  987.   Until (Value >= LowLim) And (Value <= UpLim) And (Not(Err));
  988.   Param := Value;
  989.   GetLongInt := BC;
  990. END;
  991.  
  992.  
  993. FUNCTION GetReal(VAR Param : Real; LowLim, UpLim : Real; Len, X, Y : Word) : Char;
  994. VAR
  995.    Temp : String;
  996.    P, Value : Real;
  997.    I : Word;
  998.    Err : Boolean;
  999.    BC : Char;
  1000. BEGIN
  1001.    Repeat
  1002.          Err := FALSE;
  1003.          Temp := RealToStr(Param);
  1004.          Temp := Input(Temp, ['0'..'9', '.','-'], Len, X, Y, BC);
  1005.          Val(Temp, P, I);
  1006.          If Length(Temp) = 0 Then Value := 0.0
  1007.             Else If I = 0 Then Value := P
  1008.             Else
  1009.             BEGIN
  1010.                  Value := Param;
  1011.                  Beep;
  1012.                  Err := TRUE;
  1013.             END;
  1014.          If (Not((Value >= LowLim) And (Value <= UpLim))) Then Beep;
  1015.    Until (Value >= LowLim) And (Value <= UpLim) And (Not(Err));
  1016.    Param := Value;
  1017.    GetReal := BC;
  1018. END;
  1019.  
  1020. FUNCTION GetString(VAR Param : String; Len, X, Y : Byte) : Char;
  1021. VAR
  1022.    Temp : String;
  1023.    BC : Char;
  1024. BEGIN
  1025.    Temp := Param;
  1026.    Temp := Input(Temp, [#32..#126], Len, X, Y, BC);
  1027.    Param := Temp;
  1028.    GetString := BC;
  1029. END;
  1030.  
  1031. FUNCTION GetWord(VAR Param:Word;LowLim,UpLim:Word;Len,X,Y:Byte):Char;
  1032. VAR
  1033.    BC : Char;
  1034.    WW,WL,WH : LongInt;
  1035. BEGIN
  1036.    WW := LongInt(Param);
  1037.    WL := LongInt(LowLim);
  1038.    WH := LongInt(UpLim);
  1039.    BC := GetLongInt(WW,WL,WH,Len,X,Y);
  1040.    Param := Word(WW);
  1041.    GetWord := BC;
  1042. END;
  1043.  
  1044. PROCEDURE DBF.GoBottom;
  1045. BEGIN
  1046.      GetDBRec(Header^.RecCount);
  1047. END;
  1048.  
  1049. PROCEDURE DBF.GoTop;
  1050. BEGIN
  1051.      GetDBRec(1);
  1052. END;
  1053.  
  1054. FUNCTION DBF.IIF(BoolVAR : Boolean;IfTRUE,IfFALSE : String) : String;
  1055. BEGIN
  1056.      If BoolVAR then IIF := IfTRUE
  1057.      else IIF := IfFALSE;
  1058. END;
  1059.  
  1060. PROCEDURE DBF.IndexOn(NdxID : BYTE;NdxName : FileName;NdxField : BYTE;DupFlag : BYTE);
  1061. VAR
  1062.     RecNumber : LONGINT;
  1063. BEGIN
  1064.     MakeDBIndex(NdxID,NdxName,Fields^[NdxField].FieldLen,DupFlag);
  1065.     OpenDBIndex(NdxID,NdxName,Fields^[NdxField].FieldLen,DupFlag);
  1066.     FOR RecNumber := 1 TO TotalRecs DO
  1067.     BEGIN
  1068.         GetDBRec(RecNo);
  1069.         AddDBKey(NdxID,Field(NdxField));
  1070.     END;
  1071. END;
  1072.  
  1073. CONSTRUCTOR DBF.Init(DBName : FileName);
  1074. VAR
  1075.     NdxID : BYTE;
  1076. BEGIN
  1077.       NEW(DBRecord);
  1078.      Inc(FilesOpen);
  1079.      New(Header);
  1080.      New(Fields);
  1081.       New(Positions);
  1082.       NEW(Indexes);
  1083.       DBFName := RTrim(LTrim(DBName));
  1084.       Assign(DBFile,DBFName);
  1085.      {$I-} Reset(DBFile,1); {$I+}
  1086.      TPDBErr := IOResult;
  1087.      If (TPDBErr<>0) and (not GotOne) then
  1088.      BEGIN
  1089.      TErrorName := DBName;
  1090.      BailOut;
  1091.      END;
  1092.      DBFOpen := TRUE;
  1093.       DBRecNum := 1;
  1094.       FOR NdxID := 1 TO MaxInds DO
  1095.       BEGIN
  1096.         Indexes^[NdxID].NdxName := '';
  1097.         Indexes^[NdxID].Open := FALSE;
  1098.         Indexes^[NdxID].NdxID := 0;
  1099.       END;
  1100.      ReadDBHeader;
  1101. END;
  1102.  
  1103.  
  1104. FUNCTION Input(VAR S:String;Term:CharSet;L,X,Y:Byte;VAR BC:Char):String;
  1105. Const
  1106.   Next : CharSet = [Return,CursorUp,CursorDown,PageUp,PageDown,Escape];
  1107. VAR
  1108.   P    : Byte;
  1109.   Ch   : Char;
  1110.   Temp : String;
  1111. BEGIN
  1112.   CursorOn;
  1113.   If S = '0' Then S[0] := #0;
  1114.   Temp:= Replicate(Filler,L-Length(S));
  1115.   Temp := Concat(S,Temp);
  1116.   Flash(Y,X,Reverse,Temp);
  1117.   P := 0;
  1118.   Repeat
  1119.     GoToXY(X+P,Y);
  1120.     Ch := ReadChar;
  1121.     If UpperCase Then CH := UpCase(CH);
  1122.     If (CH In Term) Then
  1123.     BEGIN
  1124.       If P < L Then
  1125.       BEGIN
  1126.         If Length(S) = L Then Delete(S, L, 1);
  1127.         Inc(P);
  1128.         Insert(CH, S, P);
  1129.         Write(Copy(S, P, L));
  1130.         If AutoWrap AND (P = L) Then Ch := Return;
  1131.       END
  1132.       Else If Not(AutoWrap) Then Beep;
  1133.     END
  1134.     Else
  1135.     Case CH Of
  1136.           ^H, #127 : If P > 0 Then
  1137.                    BEGIN
  1138.                      Delete(S, P, 1);
  1139.                      Write(^H, Copy(S, P, L), Filler);
  1140.                      Dec(P);
  1141.                    END
  1142.                    Else Beep;
  1143.           DelKey : If P < Length(S) Then
  1144.                    BEGIN
  1145.                      Delete(S, Succ(P), 1);
  1146.                      Write(Copy(S, Succ(P), L), Filler);
  1147.                    END;
  1148.         CursorLeft : If P > 0 Then Dec(P)
  1149.                    Else Beep;
  1150.         CursorRight: If P < Length(S) Then Inc(P)
  1151.                    Else Beep;
  1152.       CursorHome : P := 0;
  1153.        CursorEND : P := Length(S);
  1154.                   ^Y : BEGIN
  1155.                             Write(Replicate(Filler, Length(S)-P));
  1156.                      Delete(S, Succ(P), L);
  1157.                          END;
  1158.     END;
  1159.   Until CH In Next;
  1160.   P := Length(S);
  1161.   Input := S;
  1162.   BC := CH;
  1163.   CursorOff;
  1164. END;
  1165.  
  1166.  
  1167. FUNCTION IntToStr(Number : LongInt): String;
  1168. VAR
  1169.   Temp : String;
  1170. BEGIN
  1171.   Str(Number,Temp);
  1172.   IntToStr := RTrim(LTrim(Temp));
  1173. END;
  1174.  
  1175. FUNCTION DBF.Locate(FieldNo : BYTE;SearchStr : String) : BOOLEAN;
  1176. VAR
  1177.     RecNumber : LONGINT;
  1178. BEGIN
  1179.     DBReset;
  1180.     RecNumber := 1;
  1181.     WHILE RecNumber <= TotalRecs DO
  1182.     BEGIN
  1183.         GetDBRec(RecNumber);
  1184.         IF Pos(SearchStr,IIF(UCKey,Upper(Field(FieldNo)),Field(FieldNo))) > 0 THEN
  1185.             BEGIN
  1186.                 Locate := TRUE;
  1187.                 EXIT;
  1188.             END;
  1189.         RecNumber := RecNumber + 1;
  1190.     END;
  1191.     Locate := FALSE;
  1192. END;
  1193.  
  1194.  
  1195. PROCEDURE DBF.LookUp(SearchStr : string;NdxID : BYTE);
  1196. BEGIN
  1197.       SearchKey(Indexes^[NdxID].Ndx,DBRecNum,SearchStr);
  1198.      If OK then
  1199.      BEGIN
  1200.           GetDBRec(DBRecNum);
  1201.           Found := TRUE;
  1202.      END
  1203.      else
  1204.      Found := FALSE;
  1205. END;
  1206.  
  1207. PROCEDURE DBF.MakeDBIndex(NdxID : BYTE;DBIndexName : FileName;KeyLen,Status : Integer);
  1208. BEGIN
  1209.       MakeIndex(Indexes^[NdxID].Ndx,DBIndexName,KeyLen,Status);
  1210.       Indexes^[NdxID].NdxName := DBIndexName;
  1211.       Indexes^[NdxID].NdxID := NdxID;
  1212.       Indexes^[NdxID].Open := TRUE;
  1213.       CloseDBIndex(NdxID);
  1214. END;
  1215.  
  1216. PROCEDURE DBF.Mark;
  1217. BEGIN
  1218.      DBRecord^[1] := Chr(Ord($2A));
  1219. END;{Mark}
  1220.  
  1221. FUNCTION Max(N1,N2 : Integer) : Integer;
  1222. BEGIN
  1223.         If N1>N2 then Max := N1
  1224.         else Max := N2;
  1225. END;{Max}
  1226.  
  1227. FUNCTION Min(N1,N2 : Integer) : Integer;
  1228. BEGIN
  1229.         If N1<N2 then Min := N1
  1230.         else Min := N2;
  1231. END;{Min}
  1232.  
  1233. FUNCTION DBF.Mul(Field1,Field2 : Byte):string;
  1234.     (* Multiply field 1 and field2 *)
  1235. VAR
  1236.         T1,T2,T3 : String;
  1237.         M1,M2,M3 : Real;
  1238.         ErrCode : Integer;
  1239. BEGIN
  1240.         T1 := RTrim(Field(Field1));
  1241.         T2 := RTrim(Field(Field2));
  1242.         Val(T1,M1,ErrCode);
  1243.         Val(T2,M2,ErrCode);
  1244.         M3 := M1*M2;
  1245.         Str(M3 : Max(Fields^[Field1].FieldLen,Fields^[Field2].FieldLen) :
  1246.                 Max(Fields^[Field1].FieldDec,Fields^[Field2].FieldDec),T3);
  1247.         Mul := LTrim(T3);
  1248. END;{Mul}
  1249.  
  1250. PROCEDURE DBF.NewDBRec;
  1251. BEGIN
  1252.      If not Allocated then
  1253.      BEGIN
  1254.           New(DBRecord);
  1255.      END
  1256.      else
  1257.      BEGIN
  1258.           Dispose(DBRecord);
  1259.           New(DBRecord);
  1260.      END;
  1261.      FillChar(DBRecord^,SizeOf(DBRecord^),#32);
  1262.      DBRecNum := TotalRecs + 1;
  1263. END;{NewDBRec}
  1264.  
  1265. PROCEDURE DBF.NextDBKey(NdxID : BYTE;KeyStr : DBKey);
  1266. BEGIN
  1267.      If UCKey then KeyStr := Upper(KeyStr);
  1268.       NextKey(Indexes^[NdxID].Ndx,DBRecNum,KeyStr);
  1269.      GetDBRec(DBRecNum);
  1270. END;{NextDBKey}
  1271.  
  1272. PROCEDURE DBF.NextRec;
  1273. BEGIN
  1274.      GetDBRec(DBRecNum+1);
  1275. END;{NextRec}
  1276.  
  1277.  
  1278. PROCEDURE DBF.OpenDBIndex(NdxID : BYTE;DBIndexName : FileName;KeyLen,Status : Integer);
  1279. BEGIN
  1280.       OpenIndex(Indexes^[NdxID].Ndx,DBIndexName,KeyLen,Status);
  1281.       Indexes^[NdxId].NdxName := DBIndexName;
  1282.       Indexes^[NdxID].NdxID := NdxId;
  1283.       Indexes^[NdxID].Open := TRUE;
  1284.       INC(FilesOpen);
  1285. END;{OpenDBIndex}
  1286.  
  1287. PROCEDURE DBF.Pack;
  1288. VAR
  1289.    FNo : Byte;
  1290.    J,TRec   : LongInt;
  1291.  
  1292.    PROCEDURE PutTempRec(RecordNumber : LongInt); {Add new record, no index open.}
  1293.    BEGIN
  1294.         DBRecNum := RecordNumber;
  1295.         RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  1296.         Seek(TempFile,RecordNumber);
  1297.         BlockWrite(TempFile,DBRecord^,Header^.RecordLen,ErrCode);
  1298.    END;
  1299.  
  1300.    BEGIN
  1301.         MAlloc := TRUE;
  1302.           Done;
  1303.           Malloc := FALSE;
  1304.           FromPack := TRUE;
  1305.         DBReset;
  1306.         ReadDBHeader;
  1307.         Assign(TempFile,'temp.$$$');
  1308.         ReWrite(TempFile,1);
  1309.         BlockWrite(TempFile,Header^,32,ErrCode);
  1310.         For FNo := 1 to NumFields do
  1311.         BEGIN
  1312.            BlockWrite(TempFile,Fields^[FNo],32,ErrCode);
  1313.         END;
  1314.         Header^.Terminator := Chr(Ord($0D));
  1315.         BlockWrite(TempFile,Header^.Terminator,1,ErrCode);
  1316.         TRec := 1;
  1317.         For J := 1 to TotalRecs do
  1318.         BEGIN
  1319.              GetDBRec(J);
  1320.              If not Deleted then
  1321.                 BEGIN
  1322.                 PutTempRec(TRec);
  1323.                 TRec := TRec + 1;
  1324.                 END;
  1325.         END;
  1326.           Done;
  1327.         Close(TempFile);
  1328.         Erase(DBFile);
  1329.           Rename(TempFile,DBFName);
  1330.           Init(DBFName);
  1331.         TotalRecs := TRec-1;
  1332.         WriteDBHeader;
  1333. END;{Pack}
  1334.  
  1335. PROCEDURE DBF.PrevDBKey(NdxID : BYTE;KeyStr : DBKey);
  1336. BEGIN
  1337.      If UCKey then KeyStr := Upper(KeyStr);
  1338.       PrevKey(Indexes^[NdxID].Ndx,DBRecNum,KeyStr);
  1339.      GetDBRec(DBRecNum);
  1340. END;{PrevDBKey}
  1341.  
  1342. PROCEDURE DBF.PrevRec;
  1343. BEGIN
  1344.      GetDBRec(DBRecNum-1);
  1345. END;{PrevRec}
  1346.  
  1347. PROCEDURE Prompt(Row,Col : Byte;PromptStr : Str80);
  1348. BEGIN
  1349.      Flash(Row,Col,Normal,PromptStr);
  1350. END;{Prompt}
  1351.  
  1352. PROCEDURE DBF.PutDBRec(RecordNumber : LongInt);
  1353. BEGIN
  1354.      DBRecNum := RecordNumber;
  1355.      RecordNumber := (RecordNumber - 1) * Header^.RecordLen + Header^.Location;
  1356.      Seek(DBFile,RecordNumber);
  1357.      BlockWrite(DBFile,DBRecord^,Header^.RecordLen,ErrCode);
  1358.       Dispose(DBRecord);
  1359. END;{PutDBRec}
  1360.  
  1361. FUNCTION ReadChar : Char;
  1362. VAR
  1363.    CH : Char;
  1364. BEGIN
  1365.     ReadKb(ExtKey, CH);
  1366.     If ExtKey Then
  1367.    BEGIN
  1368.    Case CH Of
  1369.         #75 : CH := CursorLeft;
  1370.         #77 : CH := CursorRight;
  1371.         #72 : CH := CursorUp;
  1372.         #80 : CH := CursorDown;
  1373.         #73 : CH := PageUp;
  1374.         #81 : CH := PageDown;
  1375.         #71 : CH := CursorHome;
  1376.         #79 : CH := CursorEND;
  1377.         #83 : CH := DelKey;
  1378.         Else  CH := #0;
  1379.      END;
  1380.     If CH = #9  Then CH := TabKey;
  1381.   END;
  1382.   ReadChar := CH;
  1383. END;{ReadChar}
  1384.  
  1385. PROCEDURE DBF.ReadDBHeader;
  1386. {Read .DBF header.}
  1387. VAR
  1388.    FNo : Byte;
  1389.    BEGIN
  1390.         BlockRead(DBFile,Header^,32,ErrCode);
  1391.         TotalRecs := Header^.RecCount;
  1392.         NumFields := (Header^.Location - 33) div 32;
  1393.         For FNo := 1 to NumFields do
  1394.         BEGIN
  1395.            BlockRead(DBFile,Fields^[FNo],32,ErrCode);
  1396.         END;
  1397.         For K := 1 to NumFields do
  1398.     BEGIN
  1399.          Positions^[1,K] := 0;
  1400.          Positions^[2,K] := 0;
  1401.         END;
  1402.         Start := 2;
  1403.     For FNo := 1 to NumFields do
  1404.     BEGIN
  1405.          Stop := Start+Fields^[FNo].FieldLen-1;
  1406.          Positions^[1,FNo] := Start;
  1407.          Positions^[2,FNo] := Stop;
  1408.          Start := Stop+1;
  1409.     END;
  1410. END;{ReadDBHeader}
  1411.  
  1412. PROCEDURE ReadKB (VAR ExtKey: Boolean; VAR Ch: Char);
  1413. BEGIN
  1414.   ExtKey := FALSE;
  1415.   Ch := ReadKey;
  1416.   If Ch = #0 Then
  1417.   BEGIN
  1418.     ExtKey := TRUE;
  1419.     Ch := ReadKey;
  1420.   END;
  1421. END;{ReadKB}
  1422.  
  1423. FUNCTION RealToStr(Number : Real): String;
  1424. VAR
  1425.   Temp : String;
  1426.   I    : Word;
  1427. BEGIN
  1428.   Str(Number:NumLen:Decimals, Temp);
  1429.   Temp := LTrim(Temp);
  1430.   I := Length(Temp);
  1431.   While Temp[I] = '0' Do Dec(I);
  1432.   If Temp[I] = '.' Then Dec(I);
  1433.   RealToStr := Copy(Temp, 1, I);
  1434. END;{RealToStr}
  1435.  
  1436.  
  1437. PROCEDURE DBF.Recall;
  1438. BEGIN
  1439.      DBRecord^[1] := Chr(Ord($20));
  1440. END;{Recall}
  1441.  
  1442. FUNCTION DBF.RecCount : LONGINT;
  1443. BEGIN
  1444.     RecCount := TotalRecs;
  1445. END;
  1446.  
  1447. FUNCTION DBF.RecNo : LONGINT;
  1448. BEGIN
  1449.     RecNo := DBRecNum;
  1450. END;
  1451.  
  1452. PROCEDURE DBF.Repl(FNo : Byte;InStr : string);
  1453. VAR
  1454.    Temp : String;
  1455. BEGIN
  1456.      Temp := PadR(InStr,Fields^[FNo].FieldLen);
  1457.      Move(Temp[1],DBRecord^[Positions^[1,FNo]],Fields^[FNo].FieldLen);
  1458. END;{Repl}
  1459.  
  1460. PROCEDURE DBF.ReplEach(FNo : Byte;InStr : String);
  1461. VAR
  1462.    J : LongInt;
  1463.  
  1464. BEGIN
  1465.      DBReset;
  1466.      For J := 1 to TotalRecs do
  1467.      BEGIN
  1468.         GetDBrec(J);
  1469.         Repl(FNo,InStr);
  1470.         PutDBRec(J);
  1471.      END;
  1472. END;{ReplEach}
  1473.  
  1474.  
  1475. PROCEDURE DBF.Save;
  1476. BEGIN
  1477.     PutDBRec(DBRecNum);
  1478. END;{Save}
  1479.  
  1480.  
  1481. PROCEDURE DBF.Say(FNo,Row,Col : Byte);
  1482. VAR
  1483.    GG : Integer;
  1484.    TempStr : String;
  1485.    Bool : Char;
  1486.    TempDate : String[8];
  1487.    Month,Day,Year : String[2];
  1488.    YY : Integer;
  1489.     MM,DD : Byte;
  1490.     Slush : String[8];
  1491. BEGIN
  1492.      Case Chr(Ord(Fields^[FNo].FieldType)) of
  1493.           'C','N' : BEGIN
  1494.                TempStr :='';
  1495.             For GG := Positions^[1,FNo] to Positions^[2,FNo] do
  1496.             TempStr := TempStr+DBRecord^[GG];
  1497.             Flash(Row,Col,Normal,TempStr);
  1498.           END;
  1499.        'L' : BEGIN
  1500.               Bool := DBRecord^[Positions^[1,FNo]];
  1501.               Flash(Row,Col,Normal,Bool);
  1502.        END;
  1503.          'D' : BEGIN
  1504.                  TempDate := '';
  1505.                  Slush := '';
  1506.                  Case DateFormat of
  1507.                  American : BEGIN
  1508.                                 Slush := Field(FNo);
  1509.                                 TempDate := Copy(Slush,5,2)+'/'+Copy(Slush,7,2)+
  1510.                                 '/'+Copy(Slush,3,2);
  1511.                                 END;
  1512.                  Ansi     : BEGIN
  1513.                             Slush := Field(FNo);
  1514.                                 TempDate := Copy(Slush,3,2)+'.'+Copy(Slush,5,2)+
  1515.                                 '.'+Copy(Slush,7,2);
  1516.                                 END;
  1517.                  British  : BEGIN
  1518.                             Slush := Field(FNo);
  1519.                                 TempDate := Copy(Slush,7,2)+'/'+Copy(Slush,5,2)+
  1520.                                 '/'+Copy(Slush,3,2);
  1521.                                 END;
  1522.                  French   : BEGIN
  1523.                         Slush := Field(FNo);
  1524.                                 TempDate := Copy(Slush,7,2)+'/'+Copy(Slush,5,2)+
  1525.                                 '/'+Copy(Slush,3,2);
  1526.                                 END;
  1527.                  German   : BEGIN
  1528.                              Slush := Field(FNo);
  1529.                                 TempDate := Copy(Slush,7,2)+'.'+Copy(Slush,5,2)+
  1530.                                 '.'+Copy(Slush,3,2);
  1531.                                 END;
  1532.                  Italian  : BEGIN
  1533.                              Slush := Field(FNo);
  1534.                                 TempDate := Copy(Slush,7,2)+'-'+Copy(Slush,5,2)+
  1535.                                 '-'+Copy(Slush,3,2);
  1536.                                 END;
  1537.                  END;
  1538.                  Flash(Row,Col,Normal,TempDate);
  1539.                  END;
  1540.        END;
  1541. END;{Say}
  1542.  
  1543.  
  1544. PROCEDURE SetDateFormat(Format : BYTE);
  1545. BEGIN
  1546.      DateFormat := Format;
  1547. END;
  1548.  
  1549.  
  1550. PROCEDURE SetDBColor(FG,BG : Byte);
  1551. BEGIN
  1552.      TextColor(FG);
  1553.      TextBackGround(BG);
  1554. END;{SetDBColor}
  1555.  
  1556. PROCEDURE DBF.ShowStatus; {Display .DBF status.}
  1557. VAR
  1558.    FNo,K : Byte;
  1559. BEGIN
  1560.      ClrScr;
  1561.       WriteLn('File name is ',Upper(DBFName),'.');
  1562.      WriteLn('Last update was on ',Header^.Month,'/',Header^.Day,'/',Header^.Year,'.');
  1563.      WriteLn('Number of records is ',Header^.RecCount,'.');
  1564.      WriteLn('Data starts at byte # ',Header^.Location,'.');
  1565.      WriteLn('Record length is ',Header^.RecordLen,' bytes.');
  1566.      WriteLn('There are ',NumFields,' fields.');
  1567.      Wait;
  1568.      For FNo := 1 to NumFields do
  1569.      BEGIN
  1570.           Write('Field # ',FNo:2,': ');
  1571.           For K := 1 to 11 do
  1572.           Write(Fields^[FNo].FieldName[K]);
  1573.           Write(' Type: ',Chr(Fields^[FNo].FieldType));
  1574.           Write('     Length: ',Fields^[FNo].FieldLen:3);
  1575.           If Chr(Ord(Fields^[FNo].FieldType))='N' then
  1576.              Write('     Decimals: ',Fields^[FNo].FieldDec:2);
  1577.           WriteLn;
  1578.           If FNo mod 20 = 0 then Wait;
  1579.      END;
  1580.      Wait;
  1581.      DBReset;
  1582. END;{ShowStatus}
  1583.  
  1584. PROCEDURE DBF.Skip;
  1585. BEGIN
  1586.     GetDBRec(DBRecNum+1);
  1587. END;{Skip}
  1588.  
  1589.  
  1590. FUNCTION DBF.Sub(Field1,Field2 : Byte) : string;
  1591.     (* Subtract field 2 FROM field 1 *)
  1592. VAR
  1593.         T1,T2,T3 : String;
  1594.         S1,S2,S3 : Real;
  1595.         ErrCode : Integer;
  1596. BEGIN
  1597.         T1 := RTrim(Field(Field1));
  1598.         T2 := RTrim(Field(Field2));
  1599.         Val(T1,S1,ErrCode);
  1600.         Val(T2,S2,ErrCode);
  1601.         S3 := S1-S2;
  1602.         Str(S3 : Max(Fields^[Field1].FieldLen,Fields^[Field2].FieldLen) :
  1603.                 Max(Fields^[Field1].FieldDec,Fields^[Field2].FieldDec),T3);
  1604.         Sub := LTrim(T3);
  1605. END;{Sub}
  1606.  
  1607. FUNCTION DBF.Sum(FNo : Byte) : Real;
  1608. {Sums a numeric field.  If specified field is not numeric returns 0.}
  1609. VAR
  1610.    J : LongInt;
  1611.    TempStr : String;
  1612.    TempReal : Real;
  1613.    EC : Integer;
  1614.    TotalSum : Real;
  1615. BEGIN
  1616.      If Chr(Ord(Fields^[FNo].FieldType))<>'N' then
  1617.      BEGIN
  1618.           Sum := 0;
  1619.       Exit;
  1620.      END
  1621.      else
  1622.      BEGIN
  1623.           DBReset;
  1624.       TotalSum := 0;
  1625.       For J := 1 to TotalRecs do
  1626.       BEGIN
  1627.         GetDBRec(J);
  1628.         TempStr := RTrim(LTrim(Field(FNo)));
  1629.         Val(TempStr,TempReal,EC);
  1630.         TotalSum := TotalSum + TempReal;
  1631.       END;
  1632.       END;
  1633.     Sum := TotalSum;
  1634. END;{Sum}
  1635.  
  1636. PROCEDURE Wait;
  1637. BEGIN
  1638.      Writeln('Press any key to continue...');
  1639.      Ch := ReadKey;
  1640. END;{Wait}
  1641.  
  1642.  
  1643. PROCEDURE DBF.WriteDBHeader;
  1644. {Update .DBF header.}
  1645. BEGIN
  1646.      DBReset;
  1647.      GetDate(Y,M,D,DW);
  1648.      Y := Y-1900;
  1649.      Header^.Year := Y;
  1650.      Header^.Month := M;
  1651.      Header^.Day := D;
  1652.      Header^.RecCount := TotalRecs;
  1653.      BlockWrite(DBFile,Header^,32,ErrCode);
  1654. END;{WriteDBHeader}
  1655.  
  1656. PROCEDURE DBF.Zap;
  1657. VAR
  1658.    FNo : Byte;
  1659. BEGIN
  1660.      ReWrite(DBFile,1);
  1661.      TotalRecs := 0;
  1662.      Header^.RecCount := 0;
  1663.      BlockWrite(DBFile,Header^,32,ErrCode);
  1664.      For FNo := 1 to NumFields do
  1665.      BEGIN
  1666.      BlockWrite(DBFile,Fields^[FNo],32,ErrCode);
  1667.      END;
  1668.      Header^.Terminator := Chr(Ord($0D));
  1669.      BlockWrite(DBFile,Header^.Terminator,1,ErrCode);
  1670.      DBReset;
  1671. END;{Zap}
  1672.  
  1673. BEGIN {TPDB}
  1674.       SetDateFormat(American);
  1675.       FromPack := FALSE;
  1676.       TAErrorProc := @DBF.BailOut;
  1677.      TErrorName := '';
  1678.      TPDBErr := 0;
  1679.      FilesOpen := 0;
  1680. END. {TPDB}
  1681.  
  1682. {END of Source Code - TPDB.pas Version 3.11  Copyright 1989 Brian Corll }
  1683.  
  1684. CHANGES and ADDITIONS in this version -
  1685. Version 3.2 {September 1989}
  1686.     - Procedure SetColor changed to SetDBColor to prevent conflicts
  1687.       when the Graph unit is used.
  1688.  
  1689.     - Procedure SetDateFormat was added to allow use of foreign date formats.
  1690.  
  1691.       Supported date formats are as follows:
  1692.       CONST
  1693.      French   = 1; {dd/mm/yy}
  1694.       German   = 2; {dd.mm.yy}
  1695.       Italian  = 3; {dd-mm-yy}
  1696.       American = 4; {mm/dd/yy}
  1697.       British  = 5; {dd/mm/yy}
  1698.       Ansi     = 99;{yy.mm.dd}
  1699.  
  1700.     - Added procedures ChAttr and ChAllAttr to change displayed screen
  1701.       attributes.
  1702.  
  1703.     - Added RecNo and RecCount functions.
  1704.  
  1705.     - Added SaveScreen and RestoreScreen procedures.  Moved most screen-handling
  1706.       code to TPDBScrn.tpu.
  1707.  
  1708.     - Added sorting routines, creating TPDBSort.pas.
  1709.  
  1710.     - Added BinSearch routine, for searching sorted files of unique keys.
  1711.  
  1712.     - Moved all string functions into TPDBStr.pas.
  1713.  
  1714.