unit DBF;
(* ===========================================================================
 * dbf.dcu - tDBF : A custom data set which uses a flat binary
 *             structured datafile for single client usage only.
 *
 * Author:  Horacio Jamilis
 * Copyright (C) 1998, Terabyte Computacion
 *
 * ===========================================================================
 * v 0.91
 * - Fixed error on deleting records
 * - Added filtering capabilities (work wrong when there are no records within
 *   the filter expresion - Only support expresion with one field like
 *   "NUMFIELD>10" or "TEXTFIELD<='TEST'" or "DATEFIELD=19980626"
 *   (in yyyymmdd format)).
 * ===========================================================================
 * FOR C++ Builder users:
 * Use the file named DBF_C instead of this one.
 * Especial thanks to Michael Beauregard (Michael_Beauregard@mck.com).
 * ===========================================================================
 *)

interface

uses
  SysUtils, Classes, Db, DsgnIntf;

type
  TFilenameProperty = class(TStringProperty)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
  end;

  EDBFError = class (Exception);

  pDateTime = ^TDateTime;
  pBoolean = ^Boolean;
  pInteger = ^Integer;

  PRecInfo = ^TRecInfo;
  TRecInfo = record
    Bookmark: Longint;
    BookmarkFlag: TBookmarkFlag;
  end;

  TdbfHeader = record  { Dbase III + header definition        }
     VersionNumber    :byte;  { version number (03h or 83h ) }
     LastUpdateYear   :byte;  { last update YY MM DD         }
     LastUpdateMonth  :byte;
     LastUpdateDay    :byte;
     NumberOfRecords  :longint; { number of record in database }
     BytesInHeader    :smallint;{ number of bytes in header }
     BytesInRecords   :smallint;{ number of bytes in records }
     ReservedInHeader :array[1..20] of char;   { reserved bytes in header }
  end;

  TdbfField = record
     FieldName   :array[1..11] of char; { Name of this record             }
     FieldType   :char;           { type of record - C,N,D,L,etc.         }
     fld_addr    :longint;        { not used }
     Width       :byte;           { total field width of this record      }
     Decimals    :byte;           { number of digits to right of decimal  }
     MultiUser   :smallint;       { reserved for multi user }
     WorkAreaID  :byte;           { Work area ID }
     MUser       :smallint;       { reserved for multi_user }
     SetFields   :byte;           { SET_FIELDS flag }
     Reserved    :array[1..4] of byte;      { 8 bytes reserved }
  end;                           { record starts                         }

Type
  pRecordHeader = ^tRecordHeader;
  tRecordHeader = record
    DeletedFlag : char;
  end;

type
  TDBF = class(TDataSet)
  protected
    FStream: TStream; // the physical table
    FTableName: string; // table path and file name
    fDBFHeader : TdbfHeader;
    // record data
    fRecordHeaderSize : Integer;   // The size of the record header
    FRecordCount,                  // current number of record
    FRecordSize,                   // the size of the actual data
    FRecordBufferSize,             // data + housekeeping (TRecInfo)
    FRecordInfoOffset,             // offset of RecInfo in record buffer
    FCurrentRecord,                // current record (0 to FRecordCount - 1)
    BofCrack,                      // before the first record (crack)
    EofCrack: Integer;             // after the last record (crack)
    FIsTableOpen: Boolean;         // status
    FFileWidth,                    // field widths in record
    FFileDecimals,                 // field decimals in record
    FFileOffset: TList;            // field offsets in record
    fReadOnly : Boolean;           // Enhancements
    fStartData : Integer;          // Position in file where data starts
    function FFieldType(F : char):TFieldType;
    function FFieldSize(FType:char;FWidth:integer):integer;
  protected
    // TDataSet virtual abstract method
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
    function GetRecordSize: Word; override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalFirst; override;
    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    function IsCursorOpen: Boolean; override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    // TDataSet virtual method (optional)
    function GetRecordCount: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    function GetRecNo: Integer; override;
    Procedure WriteHeader;
  private
    Procedure _ReadRecord(Buffer:PChar;IntRecNum:Integer);
    Procedure _WriteRecord(Buffer:PChar;IntRecNum:Integer);
    Procedure _AppendRecord(Buffer:PChar);
    Procedure _SwapRecords(Rec1,REc2:Integer);
    Function _CompareRecords(SortFields:Array of String;Rec1,Rec2:Integer):Integer;
    Function _ProcessFilter(Buffer:PChar):boolean;
  public
    constructor Create(AOwner:tComponent); override;
    procedure CreateTable;
    Procedure PackTable;
    Procedure SortTable(SortFields : Array of String);
    Procedure UnsortTable;
  published
    property TableName: string read FTableName write FTableName;
    property ReadOnly : Boolean read fReadOnly write fReadonly default False;
    property DBFHeader : tDBFHeader read fDBFHeader;
    // redeclared data set properties
    property Active;
    property Filter;
    property Filtered;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnNewRecord;
    property OnPostError;
  end;

procedure Register;

implementation

uses
  TypInfo, Dialogs, Windows, Forms, Controls, IniFiles;

Const
  dfhVersionNumber = 13;

TYPE
  PBufArray = ^BufArray;
  BufArray = Array[0..0] of Char;

// ****************************************************************************
// Low Level Routines for accessing an internal record

// ____________________________________________________________________________
// TDBF._ReadRecord
Procedure TDBF._ReadRecord(Buffer:PChar;IntRecNum:Integer);
  {-Read a record based on the internal record number (absolute)}
BEGIN
  FStream.Position := FStartData + (FRecordSize * IntRecNum);
 try
  FStream.ReadBuffer(Buffer^, FRecordSize);
 except
 end;
END;

// ____________________________________________________________________________
// TDBF._WriteRecord
Procedure TDBF._WriteRecord(Buffer:PChar;IntRecNum:Integer);
  {-Write a record based on the internal record number (absolute)}
BEGIN
  FStream.Position := FStartData + (FRecordSize * IntRecNum);
  FStream.WriteBuffer (Buffer^, FRecordSize);
END;

// ____________________________________________________________________________
// TDBF._AppendRecord
Procedure TDBF._AppendRecord(Buffer:PChar);
BEGIN
  FStream.Position := FStartData + (FRecordSize * (FRecordCount{+FDeletedCount}));
  FStream.WriteBuffer (Buffer^, FRecordSize);
END;

/////////////////////////////////////////////////
////// Part I:
////// Initialization, opening, and closing
/////////////////////////////////////////////////

// ____________________________________________________________________________
// TDBF.InternalOpen
// I: open the table/file
procedure TDBF.InternalOpen;
var
  Field : TField;
  i,j : integer;
  d : string;
begin
  // check if the file exists
  if not FileExists (FTableName) then
    raise eDBFError.Create ('Open: Table file not found');

  // create a stream for the file
  if fReadOnly then
    fStream := tFileStream.Create( fTableName, fmOpenRead + fmShareDenyWrite)
  else
    FStream := TFileStream.Create (FTableName, fmOpenReadWrite + fmShareExclusive);
  fStream.ReadBuffer(fDBFHeader,SizeOf(TDBFHeader));

  // sets cracks and record position
  BofCrack := -1;
  EofCrack := fRecordCount{+fDeletedCount};
  FCurrentRecord := BofCrack;

  // set the bookmark size
  BookmarkSize := sizeOf (Integer);

  if not (assigned(FFileOffset)) then
    FFileOffset := TList.Create;
  if not (assigned(FFileWidth)) then
    FFileWidth := TList.Create;
  if not (assigned(FFileDecimals)) then
    FFileDecimals := TList.Create;

  // initialize the field definitions
  // (another virtual abstract method of TDataSet)
  InternalInitFieldDefs;

  FRecordInfoOffset := FRecordSize;
  FRecordBufferSize := FRecordSize + sizeof (TRecInfo);

  // if there are no persistent field objects,
  // create the fields dynamically
  if DefaultFields then
    CreateFields;
  // connect the TField objects with the actual fields
  BindFields (True);

  for i := 0 to FieldCount-1 do
    begin
      Field := Fields[i];
      if (Field.DataType = ftFloat) and (Integer(FFileDecimals[i])>0) then
        begin
          d := '0.';
          for j := 1 to Integer(FFileDecimals[i]) do
            d := d + '0';
          (Field as TFloatField).DisplayFormat := d;
        end;
    end;

  // get the number of records and check size
  fRecordCount := fDBFHeader.NumberOfRecords;

  // everything OK: table is now open
  FIsTableOpen := True;

  // ShowMessage ('InternalOpen: RecCount: ' + IntToStr (FRecordCount));
end;

// Returns the Type of the field
function TDBF.FFieldType(F : char):TFieldType;
begin
  if F = 'C' then
    FFieldType := ftString
  else if (F = 'N') or (F = 'F') then
    FFieldType := ftFloat
  else if F = 'L' then
    FFieldType := ftBoolean
  else if F = 'D' then
    FFieldType := ftDate
//    FFieldType := ftString
  else
    FFieldType := ftUnknown;
end;

function TDBF.FFieldSize(FType:char;FWidth:integer):integer;
begin
  if FType = 'C' then
    FFieldSize := FWidth
  else if (FType = 'N') or (FType = 'F') then
    FFieldSize := 0
  else if FType = 'L' then
    FFieldSize := 0
  else if FType = 'D' then
    FFieldSize := 0
//    FFieldSize := 8
  else
    FFieldSize := 0;
end;

// ____________________________________________________________________________
// TDBF.InternalInitFieldDefs
// I: define the fields
procedure TDBF.InternalInitFieldDefs;
var
  Il : Integer;
  TmpFileOffset : Integer;
  NumberOfFields : integer;
  Fld : TDBFField;
  FldName : PChar;
begin
  FieldDefs.Clear;
  FStream.Seek(SizeOf(TDbfHeader),soFromBeginning);
  NumberOfFields := ((fDbfHeader.BytesInHeader-sizeof(DbfHeader))div 32);
  if not (assigned(FFileOffset)) then
    FFileOffset := TList.Create;
  FFileOffset.Clear;
  if not (assigned(FFileWidth)) then
    FFileWidth := TList.Create;
  FFileWidth.Clear;
  if not (assigned(FFileDecimals)) then
    FFileDecimals := TList.Create;
  FFileDecimals.Clear;
  TmpFileOffset := 0;
  if (NumberOfFields>0) then
    begin
      for Il:=0 to NumberOfFields-1 do
        begin
          FStream.Read(Fld,SizeOf(Fld));
          GetMem(FldName,Length(Fld.FieldName)+1);
          CharToOem(PChar(@Fld.FieldName),FldName);
          TFieldDef.Create(FieldDefs, FldName,FFieldType(Fld.FieldType){DescribF.DataType},
                           FFieldSize(Fld.FieldType,Fld.Width){DescribF.Size},False,Il+1);
          FreeMem(FldName);
          FFileOffset.Add(Pointer(TmpFileOffset));
          FFileWidth.Add(Pointer(Fld.Width));
          FFileDecimals.Add(Pointer(Fld.Decimals));
          Inc(tmpFileOffset,Fld.Width);
        end;
      fRecordSize := tmpFileOffset+FrecordHeaderSize;
      FStartData := FStream.Position+1;
    end;
end;

// ____________________________________________________________________________
// TDBF.InternalClose
// I: close the table/file
procedure TDBF.InternalClose;
begin
  // if required, save updated header
  if (fDBFHeader.NumberOfRecords <> fRecordCount) or
    (fDBFHeader.BytesInRecords = 0) then