fpc/fcl/db/dbase/dbf.pas

unit dbf;
{===============================================================================
||         TDbf Component         ||         http://tdbf.netfirms.com         ||
===============================================================================}
interface

uses
{$ifdef fpc}
  SysUtils, Classes, db;
{$else}
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db,  DsgnIntf, ExptIntf;
{$endif}
// If you got a compilation error here or asking for dsgntf.pas, then just add
// this file in your project:
// dsgnintf.pas in 'C:\Program Files\Borland\Delphi5\Source\Toolsapi\dsgnintf.pas'

const
  _MAJOR_VERSION = 3;
  _MINOR_VERSION = 007;


{$ifdef VER100}      // Delphi 3
   {$define DELPHI_3}
{$endif}

{$ifdef VER110}      // CBuilder 3
   {$define DELPHI_3}
{$endif}

{$ifdef unix}
  DirSeparator = '/';
{$else}
  DirSeparator = '\';
{$endif}

//====================================================================
// Delphi is a bit to permissive for me,  I mean protected doesn't work within
// one unit. So i decided that convention:
//    private member begins by '_'
// It's forbidden to access any '_something' except from the class where it
// is defined. To check that, I just have to look for '._' anywhere in the code.
//====================================================================
type

//====================================================================
//=== Common exceptions and constants
//====================================================================
  EBinaryDataSetError = class (Exception);
  EFieldToLongError = class (Exception);

  xBaseVersion = (xBaseIII,xBaseIV,xBaseV);

//====================================================================
//=== Utility classes
//====================================================================
  TPagedFile = class(TObject)
  protected
    Stream : TStream;
    HeaderSize : Integer;
    RecordSize : Integer;
    _cntuse:integer;
    _Filename:string;
  public
    constructor Create(const FileName: string; Mode: Word);
    destructor Destroy; override;

    procedure Release;
    function CalcRecordCount:Integer;
    procedure _Seek(page:Integer);
    procedure ReadRecord(IntRecNum:Integer;Buffer:Pointer);
    procedure WriteRecord(IntRecNum:Integer;Buffer:Pointer);
  end;
//====================================================================
//=== Dbf support (first part)
//====================================================================
  rDbfHdr = record
    VerDBF      : byte;   // 0
    Year        : byte;   // 1
    Month       : byte;   // 2
    Day         : byte;   // 3
    RecordCount : Integer;  // 4-7
    FullHdrSize : word;   // 8-9
    RecordSize  : word;   // 10-11
    Dummy1      : Word;   // 12-13
    IncTrans    : byte;   // 14
    Encrypt     : byte;   // 15
    Dummy2      : Integer; // 16-19
    Dummy3      : array[20..27] of byte; // 20-27
    MDXFlag     : char; // 28
    Language    : char; // 29
    dummy4      : word; // 30-31
  end;
//====================================================================
  TMyFieldInfo = class
  public
    FieldName:string;
    Size:Integer;
    Prec:Integer;
    Offset:Integer;
  end;
//====================================================================
  TDbfFile = class(TPagedFile)
  protected
    _RecordBufferSize:integer;
    _DataHdr : rDbfHdr;
    _DbfVersion : xBaseVersion;
    _MyFieldInfos: TList;
  public
    constructor Create(const FileName: string; Mode: Word);
    destructor Destroy; override;
    function RecordCount:integer;
    procedure CreateFieldDefs(FieldDefs:TFieldDefs);
    procedure ClearMyFieldInfos;
    procedure DbfFile_CreateTable(FieldDefs:TFieldDefs);
    procedure DbfFile_PackTable;
    function GetFieldInfo(FieldName:string):TMyFieldInfo;
    function GetFieldData(Column:Integer;DataType:TFieldType; Src,Dst: Pointer): Boolean;
    procedure SetFieldData(Column:integer;DataType:TFieldType; Src,Dst: Pointer);
    procedure WriteHeader;

  end;
//====================================================================
//=== Index support
//====================================================================
  TIndex = class;
//====================================================================
  rNdxHdr = record
    startpage : Integer; // 0..3
    nbPage : Integer; // 4..7
    keyformat: Char; //8
    keytype : char; //9
    dummy : Word; // 10..11
    keylen : Word; // 12..13
    nbkey : Word; // 14..15
    skeytype : Word; // 16..17
    keyreclen : Word; // 18..19
    dummy2 : Word; // 20..21
    dummy3 : Byte; // 22
    Unique : Byte; // 23
    KeyDesc : array[0..255] of char; // 24...
  end;

  rMdxTag = record
    pageno      : Integer; // 0..3
    tagname      : array [0..11] of char; // 4..14
    keyformat    : byte; // 15
    forwardTag1  : char; // 16
    forwardTag2 : byte; // 17
    backwardTag : byte; // 18
    dummy       : byte; // 19
    keytype     : byte; // 20
  end;

  NdxKeyType = (N,C);
  PNdxPage  = ^rNdxPage;
  rNdxPage  = record
    NbEntries : longint;  //  0..3 lower page
    Entries   : ARRAY [0..507] OF char;
  end;

  PNdxentry  = ^rNdxentry;
  rNdxentry  = record
    _LowerPage : longint;  //  0..3 lower page
    RecNo     : Longint;  //  4..7 recno
    case NdxKeyType of
      N: ( NKey: double);
      C: ( CKey: array [0..503] of char);
  end;
//====================================================================
  rMdxHdr = record
    MdxHdr   : byte;       // 0
    Year        : byte;       // 1
    Month       : byte;       // 2
    Day         : byte;      // 3
    FileName    : array[0..15] of char; // 4..19 of byte
    BlockSize    : word; // 20 21
    BlockAdder  : word; // 22 23
    IndexFlag   : byte; // 24
    NoTag       : byte; // 25
    TagSize     : byte; // 26
    Dummy1      : byte; // 27
    TagUsed     : word; // 28..29
    Dummy2      : word; // 30..31
    NbPage      : Integer; // 32..35
    FreePage    : Integer; // 36..39
    BlockFree   : Integer; // 40..43
    UpdYear     : byte; // 44
    UpdMonth    : byte; // 45
    UpdDay      : byte; // 46
  end;
//====================================================================
  TIndexFile = class(TPagedFile)
  protected
    _IndexVersion : xBaseVersion;
    _MdxHdr : rMdxHdr;
  public
    constructor Create(const FileName: string; Mode: Word);
    destructor Destroy; override;
  end;
//====================================================================
  PIndexPosInfo = ^TIndexPage;
  TIndexPage = class
  protected
    _Index : TIndex;
    _PageNo : Integer;
    _EntryNo : Integer;
    Entry : PNdxentry;
    _LowerLevel : TIndexPage;
    _UpperLevel : TIndexPage;
    _PageBuff:rNdxPage;

    procedure LocalFirst;
    procedure LocalLast;
    function  LocalPrev:boolean;
    function  LocalNext:boolean;
    function  LastEntryNo:integer;
    function  LocalInsert(Recno:Integer; Buffer:PChar; LowerPage:integer):boolean;
    function  LocalDelete:boolean;

    function  GetPEntry(EntryNo:integer):PNdxEntry;
    procedure First;
    procedure Last;
    function Prev:boolean;
    function Next:boolean;
    procedure Write;
    procedure AddNewLevel;
  public
    constructor Create(Parent:TIndex);
    destructor Destroy; override;

    procedure SetPageNo(page:Integer);
    procedure SetEntryNo(entryno:Integer);
    procedure WritePage(Page:integer);
    function FindNearest(Recno:integer; Key:PChar):integer;
    function Insert(Recno:integer; Buffer:pchar; LowerPage:integer):boolean;
    procedure SetEntry(Recno:integer; key:pchar; LowerPage:integer);
    function Delete:boolean;
    function LowerLevel : TIndexPage;
  end;
//====================================================================
  TIndex = class(TObject)
  protected
    _IndexFile:TIndexFile;
    _NdxHdr:rNdxHdr;
    _Root:TIndexPage;
    _TagPosition:Integer;
    _FieldPos : integer;
    _FieldLen : integer;
    _NbLevel : integer;
    _RootPage: integer;

    function Pos:TIndexPage;
  public
    IndexRecNo:integer;
    function Prev:boolean;
    function Next:boolean;
    procedure First;
    procedure Last;
    function Find(Recno:integer; Buffer:PChar; var pPos:TIndexPage):integer;
    procedure Insert(Recno:integer; Buffer:PChar);
    function Delete:boolean;
    procedure GotoKey(Recno:integer; Buffer:PChar);
    procedure Update(Recno: integer; PrevBuffer,NewBuffer: PChar);
//    procedure ResyncInd;
    function GetRealRecNo: Integer;
    constructor Create(Parent:TIndexFile; RootPage:integer;CreateIt:boolean);
    procedure InitFieldDef(dbfFile:TDbfFile;FieldDesc:string);
    destructor Destroy; override;
// optionnal
    function GuessRecordCount: Integer;
    function GuessRecNo: Integer;
  end;
//====================================================================
//=== Memo and binary fields support
//====================================================================
  rDbtHdr = record
    NextBlock:Longint;
    Dummy : array [4..7] of byte;
    _dbfFile : array [0..7] of Byte; //8..15
    bVer : Byte; //16
    Dummy2 : array [17..19] of byte;
    BlockLen:  Word;
  end;
//====================================================================
  TDbtFile = class(TPagedFile)
  protected
    _DbtVersion:xBaseVersion;
    _MemoHdr:rDbtHdr;
  public
    constructor Create(const FileName: string; Mode: Word; Ver:xBaseVersion);
    procedure ReadMemo(recno:Integer;Dst:TStream);
    procedure WriteMemo(var MemoRecno:Integer;ReadSize:Integer;Src:TStream);
  end;
//====================================================================
  TMyBlobFile = class(TMemoryStream)
  public
    Mode: TBlobStreamMode;
    Field:TField;
    MemoRecno:Integer;
    ReadSize:Integer;
    constructor Create(ModeVal:TBlobStreamMode; FieldVal:TField);
    destructor destroy;  override;
  end;
//====================================================================
//=== Dbf support 2
//====================================================================
  rFieldHdrIII = record
    FieldName   : array[0..10] of char;
    FieldType   : char; // 11
    Dummy        : array[12..15] of byte;
    FieldSize   : byte; // 16
    FieldPrecision  : byte; //17
    dummy2      : array[18..31] of byte;
  end;
//====================================================================
  rFieldHdrV = record
    FieldName   : array[0..10] of char;
    Dummy0        : array[11..31] of byte;
    FieldType   : char; // 32
    FieldSize   : byte; // 33
    FieldPrecision  : byte; //34
    dummy2      : array[35..47] of byte;
  end;
//====================================================================
  PBookMarkData = ^rBookMarkData;
  rBookmarkData = record
    RecNo:longint;
  end;
//====================================================================
  rBeforeRecord = record
    BookmarkData: rBookmarkData;
    BookmarkFlag: TBookmarkFlag;
    //... record come here
  end;
//====================================================================
  pDbfRecord = ^rDbfRecord;
  rDbfRecord = record
    BookmarkData: rBookmarkData;
    BookmarkFlag: TBookmarkFlag;
    DeletedFlag : char;
    Fields : array[0..4000] of char;
  end;
//====================================================================
  PRecInfo = ^TRecInfo;
  TRecInfo = record
    Bookmark: Longint;
    IdxBookmark: Longint;
    BookmarkFlag: TBookmarkFlag;
  end;
//====================================================================
  pRecordHdr = ^tRecordHdr;
  tRecordHdr = record
    DeletedFlag : char;
  end;

// and at LEAST the most useful class : TDbf
//====================================================================
  TDbf = class(TDataSet)
  private
    _ShowDeleted:boolean;
    _TableName: string;    // table path and file name
    _RunTimePath: string;    // table path and file name
    _DesignTimePath: string;    // table path and file name
    _ReadOnly : Boolean;
    _FilterBuffer:pchar;
    _PrevBuffer:pchar;
    _IndexFiles:TStrings;
  protected
    function _FullRecordSize:integer;
    function _FilterRecord(Buffer: PChar): Boolean;
    procedure _OpenFiles(CreateIt:boolean);
    procedure _CloseFiles;
    procedure _ResyncIndexes(Buffer: PChar);
    function _GetIndexName: string;
    procedure _SetIndexName(const Value: string);
    function _GetIndex(filename:string):TIndex;
    function _GetPath:string;
    function _ComponentInfo:string;
  public
    { my own methods and properties}
    { most looks like ttable functions but they are not tdataset related
     I use the same syntax to facilitate the conversion between bde and tdbf  }
    easyfilter:string;
    procedure CreateTable; //(FieldDefs:TFieldDefs);
    procedure DeleteIndex(const AName: string);
    property IndexName: string read _GetIndexName write _SetIndexName;

{$ifdef DELPHI_3}
    procedure AddIndex(const IndexName, Fields: String; Options: TIndexOptions);
{$else}
{$ifndef FPC}
    procedure AddIndex(const IndexName, Fields: String; Options: TIndexOptions; const DescFields: String='');
{$else}
    procedure AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions);
    procedure AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions; const DescFields: String);

{$endif}
{$endif}
    procedure CloseIndexFile(const IndexFileName: string);
    procedure OpenIndexFile(AnIndexName:string);
    procedure PackTable;
  public
    { abstract methods }
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; {virtual abstract}
    {virtual methods (mostly optionnal) }
    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; {virtual}
{$ifdef DELPHI_3}
    procedure Translate(Src, Dest: PChar; ToOem: Boolean); override; {virtual}
{$else}
    function Translate(Src, Dest: PChar; ToOem: Boolean): Integer; override; {virtual}
{$endif}
    procedure ClearCalcFields(Buffer : PChar); override;
  protected
    { abstract methods }
    function AllocRecordBuffer: PChar; override; {virtual abstract}
    procedure FreeRecordBuffer(var Buffer: PChar); override; {virtual abstract}
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; {virtual abstract}
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; {virtual abstract}
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; {virtual abstract}
    function GetRecordSize: Word; override; {virtual abstract}
    procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override; {virtual abstract}
    procedure InternalClose; override; {virtual abstract}
    procedure InternalDelete; override; {virtual abstract}
    procedure InternalFirst; override; {virtual abstract}
    procedure InternalGotoBookmark(ABookmark: Pointer); override; {virtual abstract}
    procedure InternalHandleException; override; {virtual abstract}
    procedure InternalInitFieldDefs; override; {virtual abstract}
    procedure InternalInitRecord(Buffer: PChar); override; {virtual abstract}
    procedure InternalLast; override; {virtual abstract}
    procedure InternalOpen; override; {virtual abstract}
    procedure InternalPost; override; {virtual abstract}
    procedure InternalSetToRecord(Buffer: PChar); override; {virtual abstract}
    function IsCursorOpen: Boolean; override; {virtual abstract}
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; {virtual abstract}
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; {virtual abstract}
    procedure SetFieldData(Field: TField; Buffer: Pointer); override; {virtual abstract}
    {virtual methods (mostly optionnal) }

    function GetRecordCount: Integer; override; {virtual}
    function GetRecNo: Integer; override; {virtual}
    procedure SetRecNo(Value: Integer); override; {virual}

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

  published
    property ComponentInfo: string  read _ComponentInfo;
    property TableName: string  read _TableName write _TableName;
    property RunTimePath: string  read _RunTimePath write _RunTimePath;
    property DesignTimePath: string  read _DesignTimePath write _DesignTimePath;
    property ReadOnly : Boolean read _ReadOnly write _Readonly default False;
    property ShowDeleted:boolean read _ShowDeleted write _ShowDeleted;
    // redeclared data set properties
    property Active;
    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 OnFilterRecord;
    property OnNewRecord;
    property OnPostError;

//my datas....
  protected
    _IsCursorOpen:boolean;
    _PhysicalRecno:integer;
    _CurIndex: TIndex;
    _Indexes:TList;      // index
    _indexFile : TIndexFile;
    _dbtFile : TDbtFile;
  public
    _dbfFile:TDbfFile;
    property PhysicalRecno:integer read _PhysicalRecno;
    function _RecordDataSize:integer;
  end;

{$ifndef fpc}
procedure Register;
{$endif}

var
  tDbf_TrimFields : boolean;

implementation

var
    _PagedFiles : TList;

//====================================================================
// Some types and consts which are not useful in the interface.
//====================================================================
(*
 * tSmallint  16 bits = -32768 to 32767
 *                      123456 = 6 digit max
 * ftInteger  32 bits = -2147483648 to 2147483647
 *                      12345678901 = 11 digits max
 * ftLargeInt 64 bits = -9223372036854775808 to 9223372036854775807
 *                      12345678901234567890 = 20 digits max
 *)
const
  DIGITS_SMALLINT = 6;
  DIGITS_INTEGER = 11;
  DIGITS_LARGEINT = 20;
  sDBF_DEC_SEP= '.';

type
  rAfterHdrIII = record // Empty
  end;

  rAfterHdrV = record
    Dummy   : array[32..67] of byte;
  end;

  PMdxTag = ^rMdxTag;

  rMdxTagHdr = record
    RootPage        : longint;// 0..3
    FilePages        : longint;// 4..7
    KeyFormat        : byte;   // 8
    KeyType          : char;   // 9
    dummy            : word;   // 10..11
    IndexKeyLength   : word;   // 12..13
    MaxNbKeys       : word;   // 14..15
    SecondKeyType   : word;   // 16..17
    IndexKeyItemLen  : word;   // 18..19
    dummy2           : array [20..22] of byte;
    UniqueFlag      : byte;   // 23
  end;


  rAfterHdrV3 = record
    Dummy   : array[12..31] of byte;
  end;

  rAfterHdrV4 = record
    Dummy   : array[12..67] of byte;
  end;

  rFieldHdrV3 = record
    FieldName   : array[0..10] of char;
    FieldType   : char; // 11
    Dummy        : array[12..15] of byte;
    FieldSize   : byte; // 16
    FieldPrecision  : byte; //17
    dummy2      : array[18..31] of byte;
  end;

  rFieldHdrV4 = record
    FieldName   : array[0..10] of char;
    Dummy0        : array[11..31] of byte;
    FieldType   : char; // 32
    FieldSize   : byte; // 33
    FieldPrecision  : byte; //34
    dummy2      : array[35..47] of byte;
  end;
  PDouble = ^double;
//====================================================================
// Now some common functions and procedure
//====================================================================
// ****************************************************************************
// International separator
// thanks to Bruno Depero from Italy
// and Andreas Wöllenstein from Denmark

function DbfStrToFloat(s: string): Extended;
var iPos: integer;
     eValue: extended;
begin
    iPos:= Pos(sDBF_DEC_SEP, s);
    if iPos> 0 then
      s[iPos]:= DecimalSeparator;
{$ifndef fpc}
    if TextToFloat(pchar(s), eValue, fvExtended) then
{$else}
                Val(s,eValue,Ipos);
                If Ipos=0 then
{$endif}
      Result:= eValue
    else Result:= 0;
end;

function FloatToDbfStr(f: Extended; size, prec: integer): string;
var iPos: integer;
begin
    Result:= FloatToStrF(f, ffFixed, Size, prec);
    iPos:= Pos(DecimalSeparator, Result);
    if iPos> 0 then
      Result[iPos]:= sDBF_DEC_SEP;
end;

procedure MyMove(Source, Dest:PChar; Count: Integer);
var
  c:char;
  i:integer;
begin
  i:=0;
  while i<Count do begin
    c:=PChar(Source)[i];
    if c=#0 then break;
    PChar(Dest)[i]:=c;
    Inc(i);
  end;
  while i<Count do begin
    PChar(Dest)[i]:=' ';
    Inc(i);
  end;
end;
//====================================================================
// TPagedFile
//====================================================================
function GetPagedFile(FileName: string):TPagedFile;
var
  idx:integer;
  idf:TPagedFile;
begin
  FileName:=LowerCase(FileName);
  for idx:=0 to _PagedFiles.Count-1 do begin
    idf:= TPagedFile(_PagedFiles[idx]);
    if idf._FileName=FileName then begin
      result:=idf;
      exit;
    end;
  end;
  result:=nil;
end;

procedure TPagedFile.Release;
var
    i: integer;
begin
  dec(_cntuse);
  if _cntuse<=0 then begin
    i:=_PagedFiles.IndexOf(self);
    if i>=0 then _PagedFiles.Delete(i);
    Free;
  end;
end;

function TPagedFile.CalcRecordCount:Integer;
begin
  if RecordSize = 0 then Result:=0
  else Result:=(Stream.Size - HeaderSize) div RecordSize;
end;

constructor TPagedFile.Create(const FileName: string; Mode: Word);
begin
  if filename='' then Stream:=TMemoryStream.Create()
  else begin
    Stream:=TFileStream.Create(FileName,Mode);
  end;
  HeaderSize:=0;
  RecordSize:=0;
  _cntuse:=0;
  _filename:=lowercase(filename);
  _PagedFiles.Add(Self);
end;

destructor TPagedFile.Destroy;
begin
  Stream.Free;
  Stream:=nil;
  inherited;
end;

procedure TPagedFile._Seek(page:Integer);
var
  p:Integer;
begin
  p:=HeaderSize + (RecordSize * page );
  Stream.Position := p;
end;

Procedure TPagedFile.ReadRecord(IntRecNum:Integer; Buffer:Pointer);
begin
  _Seek(IntRecNum);
  Stream.Read(Buffer^,RecordSize);
end;

procedure TPagedFile.WriteRecord(IntRecNum:Integer; Buffer:Pointer);
begin
  _Seek(IntRecNum);
  Stream.Write(Buffer^, RecordSize);
end;

//====================================================================
// TDbfFile
//====================================================================
constructor TDbfFile.Create(const FileName: string; Mode: Word);
var
  lRecordCount:Integer;
begin
  _MyFieldInfos:=TList.Create;
  // check if the file exists
  inherited Create(Filename, Mode);


  if Mode = fmCreate then begin
    FillChar(_DataHdr,sizeof(_DataHdr),0);
    HeaderSize:=0;
    RecordSize:=0;
    _DataHdr.VerDBF:=$03; // Default version xBaseIV without memo
    _DataHdr.Language:='X';
  end else begin
    Stream.Seek(0,soFromBeginning);
    Stream.ReadBuffer (_DataHdr, SizeOf(_DataHdr));
    case _DataHdr.VerDBF of
    $03,$83:          _DbfVersion:=xBaseIII;
    $04,$8B,$8E,$7B:  _DbfVersion:=xBaseIV;
    $05 :             _DbfVersion:=xbaseV;
    else
      _DbfVersion:=xBaseIV; // My favorite...
    end;
    HeaderSize:=_DataHdr.FullHdrSize;
    RecordSize:=_DataHdr.RecordSize;
    lRecordCount:=CalcRecordCount;
    if _DataHdr.RecordCount <> lRecordCount then begin
{$ifndef fpc}
      ShowMessage('Invalid Record Count,'+^M+
      'RecordCount in Hdr : '+IntToStr(_DataHdr.RecordCount)+^M+
      'expected : '+IntToStr(lRecordCount));
{$endif}
      _DataHdr.RecordCount := lRecordCount;
    end;
  end;

end;


destructor TDbfFile.Destroy;
begin
  inherited;
  ClearMyFieldInfos;
  _MyFieldInfos.Free;
  _MyFieldInfos:=nil;

end;

function TDbfFile.RecordCount:integer;
begin
  if RecordSize=0 then result:=0
  else result:=(Stream.Size - HeaderSize) div RecordSize;
  if result<0 then result:=0;
end;

procedure TDbfFile.ClearMyFieldInfos;
var
  i:Integer;
begin
  for i:=0 to _MyFieldInfos.Count-1 do begin
    TMyFieldInfo(_MyFieldInfos.Items[i]).Free;
  end;
  _MyFieldInfos.Clear;
end;

procedure TDbfFile.CreateFieldDefs(FieldDefs:TFieldDefs);
var
  lColumnCount,lHeaderSize,lFieldSize:Integer;
  Il : Integer;
  lFieldOffset : Integer;
  fn:string;
  ft:TFieldType;
  fs,nfs,fd:Integer;
  MyFieldInfo:TMyFieldInfo;
  lFieldHdrIII:rFieldHdrIII;
  lFieldHdrV:rFieldHdrV;

  function ToFieldType(dbasetype:char;fs,fd:Integer):TFieldType;
  begin
    case dbasetype of
    'C' :
      begin
        Result:=ftString;
      end;
    'L' :
      begin
        Result:=ftBoolean;
      end;
    'F' :
      begin
        Result:=ftFloat;
      end;
    'N' :
      begin
        if fd=0 then begin
          if fs <= DIGITS_SMALLINT then begin
            Result:=ftSmallInt;
          end else begin
{$ifdef DELPHI_3}
            Result:=ftInteger;
{$else}
            if fs <= DIGITS_INTEGER then Result:=ftInteger
            else Result:=ftLargeInt;
{$endif}
          end;
        end else begin
          Result:=ftFloat;
        end;
      end;
    'D' :
      begin
        Result:=ftDate;
      end;
    'M' :
      begin
        Result:=ftMemo;
      end;
    else
      begin
        Result:=ftString;
      end;
    end; //case
  end;
begin
  ClearMyFieldInfos;

  if _DbfVersion>=xBaseV then begin
    lHeaderSize:=SizeOf(rAfterHdrV) + SizeOf(rDbfHdr);
    lFieldSize:=SizeOf(rFieldHdrV);
  end else begin
    lHeaderSize:=SizeOf(rAfterHdrIII) + SizeOf(rDbfHdr);
    lFieldSize:=SizeOf(rFieldHdrIII);
  end;
  lColumnCount:= (_DataHdr.FullHdrSize - lHeaderSize) div lFieldSize;

  if (lColumnCount <= 0) or (lColumnCount > 255) then
      Raise eBinaryDataSetError.Create('Invalid field count : ' + IntToStr(lColumnCount) + ' (must be between 1 and 255)');

  lFieldOffset := 1;

  Stream.Position := lHeaderSize;
  for Il:=0 to lColumnCount-1 do begin
    if _DbfVersion>=xBaseV then begin
      Stream.ReadBuffer(lFieldHdrV,SizeOf(lFieldHdrV));
      fn:=PCHAR(@lFieldHdrV.FieldName[0]);
      fs:=lFieldHdrV.FieldSize;
      fd:=lFieldHdrV.FieldPrecision;
      nfs:=fs;
      ft:=ToFieldType(lFieldHdrV.FieldType,nfs,fd);
    end else begin
      Stream.ReadBuffer(lFieldHdrIII,SizeOf(lFieldHdrIII));
      fn:=PCHAR(@lFieldHdrIII.FieldName[0]);
      fs:=lFieldHdrIII.FieldSize;
      fd:=lFieldHdrIII.FieldPrecision;
      nfs:=fs;
      ft:=ToFieldType(lFieldHdrIII.FieldType,nfs,fd);

    end;
    // first create the bde field
    if ft in [ftString,ftBCD] then fieldDefs.Add(fn,ft,fs,false)
    else fieldDefs.Add(fn,ft,0,false);
    // then create the for our own fieldinfo
    MyFieldInfo:=TMyFieldInfo.Create;
    MyFieldInfo.Offset:=lFieldOffset;
    MyFieldInfo.Size:=fs;
    MyFieldInfo.Prec:=fd;
    MyFieldInfo.FieldName:=lowercase(fn);

    _MyFieldInfos.Add(MyFieldInfo);
    Inc(lFieldOffset,fs);
  end;
  if (lFieldOffset <> _DataHdr.RecordSize) then begin
{$ifndef fpc}
    ShowMessage('Invalid Record Size,'+^M+
                                     'Record Size in Hdr : '+IntToStr(_DataHdr.RecordSize)+^M+
                                     'Expected : '+IntToStr(lFieldOffset));
{$endif}
    _DataHdr.RecordSize := lFieldOffset;
  end;
end;

procedure TDbfFile.DbfFile_CreateTable(FieldDefs:TFieldDefs);
var
  ix:Integer;
  lFieldHdrIII:rFieldHdrIII;
  lType:Char;
  lSize,lPrec:Integer;
  Offs:Integer;
  lterminator:Byte;
begin
  // first reset file.
  Stream.Size:= 0;
  Stream.Position:=SizeOf(rDbfHdr) + SizeOf(rAfterHdrIII);
  Offs:=1; // deleted mark count 1.
  for Ix:=0 to FieldDefs.Count-1 do
  begin
    with FieldDefs.Items[Ix] do
    begin
      FillChar(lFieldHdrIII,SizeOf(lFieldHdrIII),#0);
      lPrec:=0;
      case DataType of
        ftString:
          begin
            ltype:='C';
            lSize := Size;
          end;
        ftBoolean:
          begin
            ltype:='L';
            lSize := 1;
          end;
        ftSmallInt:
          begin
            ltype:='N';
            lSize := 6;
          end;
        ftInteger:
          begin
            ltype:='N';
            lSize := 11;
          end;
        ftCurrency:
          begin
            ltype:='N';
            lSize := 20;
            lPrec := 2;
          end;
{$ifndef DELPHI_3}
        ftLargeInt:
          begin
            ltype:='N';
            lSize := 20;
            lPrec := 0;
          end;
{$endif}
        ftFloat:
          begin
            ltype:='N';
            lSize := 20;
            lPrec := 4;
          end;
        ftDate:
          begin
            ltype:='D';
            lSize := 8;
          end;
        ftMemo:
          begin
            ltype:='M';
            lSize := 10;
          end;
        else
          begin
            raise EBinaryDataSetError.Create(
             'InitFieldDefs: Unsupported field type');
          end;
      end; // case

      lFieldHdrIII.FieldType:=ltype; //DataType;
      StrPCopy(lFieldHdrIII.FieldName,FieldDefs.Items[Ix].Name);
      lFieldHdrIII.FieldSize:=lSize;
      lFieldHdrIII.FieldPrecision:=lPrec;

      Stream.Write(lFieldHdrIII,SizeOf(lFieldHdrIII));
      Inc(Offs,lSize);
    end;
  end;
  // end of header
  lterminator := $0d;
  Stream.Write(lterminator,SizeOf(lterminator));

  // update header
  _DataHdr.RecordSize := Offs;
  _DataHdr.FullHdrSize := Stream.Position;
  RecordSize := _DataHdr.RecordSize;
  HeaderSize := _DataHdr.FullHdrSize;
  // write the updated header
  WriteHeader;
end;

procedure TDbfFile.DbfFile_PackTable;
var
  first,last:integer;
  p: Pointer;
begin
  // Non tested.
  if (RecordSize <> 0) then
  begin
    first:=0;
    last:=CalcRecordCount-1;
    GetMem(p, RecordSize);
    try
      while first<last do begin
        // first find the first hole
        while first<last do begin
          ReadRecord(first, p);
          if (pRecordHdr(p)^.DeletedFlag <> ' ') then break;
          inc(first);
        end;
        // now find last one non deleted.
        while first<last do begin
          ReadRecord(last, p);
          if (pRecordHdr(p)^.DeletedFlag = ' ') then break;
          dec(last);
        end;
        if first<last then begin
          // found a non deleted record to put in the hole.
          WriteRecord(first, p);
          inc(first);
          dec(last);
        end;
      end;
    last:=CalcRecordCount;
      Stream.Size:=(last+1) * RecordSize + HeaderSize;
    finally
      FreeMem(p);
    end;
  end;
end;

function TDbfFile.GetFieldInfo(FieldName:string):TMyFieldInfo;
var
  i:Integer;
  lfi:TMyFieldInfo;
begin
  FieldName:=LowerCase(FieldName);
  for i:=0 to _MyFieldInfos.Count-1 do begin
    lfi:=TMyFieldInfo(_MyFieldInfos.Items[i]);
    if lfi.FieldName = FieldName then begin
      result:=lfi;
      exit;
    end;
  end;
  result:=nil;
end;

function TDbfFile.GetFieldData(Column:Integer;DataType:TFieldType; Src,Dst:Pointer): Boolean;
var
  FieldOffset: Integer;
  FieldSize: Integer;
  s:string;
  d:TDateTime;
  ld,lm,ly: word;
  MyFieldInfo:TMyFieldInfo;
  function TrimStr(const s: string): string;
  var
    iPos: integer;
  begin
    if DataType=ftString then
    begin
      if tDbf_TrimFields then Result:=Trim(s)
      else Result:=TrimRight(s);
    end
    else Result:= Trim(s);
  end;
  procedure CorrectYear(var wYear: word);
  var wD, wM, wY, CenturyBase: word;
{$ifdef DELPHI_3}
  // Delphi 3 standard-behavior no change possible
  const TwoDigitYearCenturyWindow= 0;
{$endif}
  begin
     if wYear>= 100 then
       Exit;
     DecodeDate(Date, wY, wm, wD);
     // use Delphi-Date-Window
     CenturyBase := wY{must be CurrentYear} - TwoDigitYearCenturyWindow;
     Inc(wYear, CenturyBase div 100 * 100);
     if (TwoDigitYearCenturyWindow > 0) and (wYear < CenturyBase) then
        Inc(wYear, 100);
  end;
begin
  MyFieldInfo:=TMyFieldInfo(_MyFieldInfos.Items[Column]);
  FieldOffset := MyFieldInfo.Offset;
  FieldSize := MyFieldInfo.Size;
  SetString(s, PChar(Src) + FieldOffset, FieldSize );
  s:=TrimStr(s);
  result:=length(s)>0; // return if field is empty
  if Result and (Dst<>nil) then// data not needed if Result= FALSE or Dst=nil
    case DataType of
    ftBoolean:
      begin
        // in DBase- FileDescription lowercase t is allowed too
        // with asking for Result= TRUE s must be longer then 0
        // else it happens an AV, maybe field is NULL
        if (UpCase(s[1])='T') then Word(Dst^) := 1
        else Word(Dst^) := 0;
      end;
    ftInteger, ftSmallInt{$ifndef DELPHI_3},ftLargeInt{$endif}:
      begin
        case DataType of
        ftSmallInt : SmallInt(Dst^):= StrToIntDef(s, 0);
        {$ifndef DELPHI_3}
        ftLargeint : LargeInt(Dst^):= StrToInt64Def(s, 0);
        {$endif}
        else // ftInteger :
          Integer(Dst^):= StrToIntDef(s, 0);
        end; // case
      end;
    ftFloat:
      begin
        Extended(Dst^) := DBFStrToFloat(s);
      end;
    ftCurrency:
      begin
        Extended(Dst^) := DBFStrToFloat(s);
      end;
    ftDate:
      begin
        ld:=StrToIntDef(Copy(s,7,2),1);
        lm:=StrToIntDef(Copy(s,5,2),1);
        ly:=StrToIntDef(Copy(s,1,4),0);
        if ld=0 then ld:=1;
        if lm=0 then lm:=1;
//           if (ly<1900) or (ly>2100) then ly:=1900;
//           Year from 0001 to 9999 is possible
//           everyting else is an error, an empty string too
//           Do DateCorrection with Delphis possibillities for one or two digits
        if (ly< 100) and (Length(Trim(Copy(s,1,4)))in [1, 2]) then CorrectYear(ly);
        try
          d:=EncodeDate(ly,lm,ld);
          if Assigned(Dst) then  Integer(Dst^) := DateTimeToTimeStamp(d).Date;
        except
          Integer(Dst^) := 0;
        end;
      end;
        ftString: begin
        StrPCopy(Dst,s);
      end;
   end;
end;

procedure TDbfFile.SetFieldData(Column:integer;DataType:TFieldType; Src,Dst:Pointer);
var
  FieldSize,FieldPrec: Integer;
  s:string;
  fl:Double;
  ts:TTimeStamp;
  MyFieldInfo:TMyFieldInfo;
begin
  MyFieldInfo:=TMyFieldInfo(_MyFieldInfos.Items[Column]);
  FieldSize := MyFieldInfo.Size;
  FieldPrec := MyFieldInfo.Prec;

  Dst:=PChar(Dst)+MyFieldInfo.Offset;
  if src<>nil then begin
    case DataType of
    ftBoolean:
      begin
        if Word(Src^) = 1 then s:='T'
        else s:='F';
      end;
    ftInteger, ftSmallInt {$ifndef DELPHI_3},ftLargeInt{$endif}:
      begin
        case DataType of
        ftSmallInt : s:= IntToStr(SmallInt(Src^));
        {$ifndef DELPHI_3}
        ftLargeInt: s:= IntToStr(LargeInt(Src^));
        {$endif}
        else //ftInteger
          s:= IntToStr(Integer(Src^));
        end;
        // left filling
        if Length(s)<FieldSize then s:=StringOfChar(' ',FieldSize-Length(s)) + s;
      end;
    ftFloat,ftCurrency:
      begin
        fl := Double(Src^);
        s:=FloatToDbfStr(fl,FieldSize,FieldPrec);
        if Length(s)<FieldSize then s:=StringOfChar(' ',FieldSize-Length(s)) + s;
      end;
    ftDate:
      begin
        ts.Time:=0;
        ts.Date:=Integer(Src^);
        s:= FormatDateTime('yyyymmdd', TimeStampToDateTime(ts));
      end;
    ftString:
      begin
        s:=PChar(Src); // finish with first 0
      end;
    end; // case
  end; // if src<>nil (thanks andreas)
  if Length(s)<FieldSize then begin
    s:=s+StringOfChar(' ',FieldSize-Length(s));
  end else if (Length(s)>FieldSize) then begin
    if DataType= ftString then begin
      // never raise for strings to long, its not customary
      // TTable never raises
      SetLength(s, FieldSize)
    end else begin
      raise eFieldToLongError.Create('Fielddata too long :' + IntToStr(Length(s))
        + ' (must be between 1 and ' + IntToStr(FieldSize) + ').');
    end;
  end;
  Move(PChar(s)^, Dst^, FieldSize);
end;


procedure TDbfFile.WriteHeader;
var
  SystemTime: TSystemTime;
  lAfterHdrIII:rAfterHdrIII;
  lAfterHdrV:rAfterHdrV;
  lterminator:Byte;
begin
  Assert(Stream<>nil,'_dbfFile=Nil');

  Stream.Position:=0;
  GetLocalTime(SystemTime);
{$ifndef fpc}
  _DataHdr.Year := SystemTime.wYear - 1900;
  _DataHdr.Month := SystemTime.wMonth;
  _DataHdr.Day := SystemTime.wDay;
{$else}
  _DataHdr.Year := SystemTime.Year - 1900;
  _DataHdr.Month := SystemTime.Month;
  _DataHdr.Day := SystemTime.Day;
{$endif}
  Stream.Seek(0,soFromBeginning);
  Stream.WriteBuffer (_DataHdr, SizeOf(_DataHdr));
  _DataHdr.RecordCount := CalcRecordCount;

  if _DbfVersion >= xBaseV then begin
    FillChar(lAfterHdrV,SizeOf(lAfterHdrV),0);
    Stream.WriteBuffer (lAfterHdrV, SizeOf(lAfterHdrV));
  end else begin
    FillChar(lAfterHdrIII,SizeOf(lAfterHdrIII),0);
    Stream.WriteBuffer (lAfterHdrIII, SizeOf(lAfterHdrIII));
  end;
  _Seek(_DataHdr.RecordCount); // last byte usually...
  lterminator := $1A;
  Stream.Write(lterminator,SizeOf(lterminator));
end;

function TDbf._ComponentInfo:string;
begin
  Result:='TDbf V' + IntToStr(_MAJOR_VERSION) + '.' + IntToStr(_MINOR_VERSION);
end;

procedure TDbf._OpenFiles(CreateIt:boolean);
var
  fileopenmode : integer;
  lPath,lFilename,lIndexName,lMemoName : string;
  isAbsolute:boolean;
  design,doreadonly:boolean;

begin
  design:=(csDesigning in ComponentState);
  doreadonly:=design or _ReadOnly;

  lPath:=_GetPath;
  isAbsolute:=((length(_TableName)>=1) and (_TableName[1]='\'))
    or ((length(_TableName)>=2) and (_TableName[2]=':'));
  if isAbsolute then lfilename:=_TableName
  else lFilename:=lPath+_TableName;
  lFilename:=ChangeFileExt(lFilename,'.dbf');
  lIndexName:=ChangeFileExt(lFilename,'.mdx');
  lMemoName:=ChangeFileExt(lFilename,'.dbt');

  // check if the file exists
  _dbfFile:=TDbfFile(GetPagedFile(lFileName));
  _indexFile:=TIndexFile(GetPagedFile(lIndexName));
  _dbtFile:=TDbtFile(GetPagedFile(lMemoName));

  if CreateIt then begin
    if _dbfFile=nil then _dbfFile:=TDbfFile.Create(lFileName,fmCreate);
    //if _indexfile=nil then _indexFile := TIndexFile.Create(lIndexName, fmCreate);
    if _dbtfile=nil then _dbtFile := TDbtFile.Create(lMemoName, fmCreate,_dbfFile._DbfVersion);
  end else if not FileExists(lFileName) then begin
    raise eBinaryDataSetError.Create ('Open: Table file not found : ' + lFileName);
  end else begin
    if DoReadOnly  then
      fileopenmode := fmOpenRead + fmShareDenyNone
    else
      fileopenmode := fmOpenReadWrite + fmShareDenyWrite;

    if _dbfFile=nil then _dbfFile := TDBFFile.Create(lFileName, fileopenmode);
    if (_indexFile=nil) and FileExists (lIndexName) then begin
      _indexFile := TIndexFile.Create(lIndexName, fileopenmode);
    end;
    if (_dbtFile=nil) and FileExists (lMemoName) then begin
      _dbtFile := TDbtFile.Create(lMemoName, fileopenmode,_dbfFile._DbfVersion);
    end;
  end;
  _PrevBuffer:=AllocRecordBuffer;
  _IsCursorOpen:=true;

end;

function TDbf._GetPath:string;
var
  lPath:string;
begin
  if (csDesigning in ComponentState) then begin
    lPath:=_DesignTimePath;
  end else begin
    if ((length(_RunTimePath)>=1) and (_RunTimePath[1]=DirSeparator))
      or ((length(_RunTimePath)>=2) and (_RunTimePath[2]=':'))
      then begin
      // if the _RunTimePath is absolute...
      // it is either \ or \blahblah or c:\
      lPath:=_RunTimePath;
    end else begin
{$ifndef fpc}
      lPath:=extractfilepath(Application.Exename)+_RunTimePath;
{$else}
      lPath:=extractfilepath(paramstr(0))+_RunTimePath;
{$endif}
    end;
  end;
  lPath:=ExpandFileName(trim(lPath));
  if (length(lPath)>0) and (lPath[length(lPath)]<>DirSeparator) then lPath:=lPath+DirSeparator;
  result:=lPath;
end;

procedure TDbf._CloseFiles;
var
  i:integer;
begin
  if _dbfFile<>nil then begin
    if not _ReadOnly then _dbfFile.WriteHeader;
    _dbfFile.Release;
    _dbfFile:=nil;
  end;
  if _indexFile<>nil then begin
    _indexFile.Release;
    _indexFile:=nil;
  end;

  if _dbtFile<>nil then begin
    _dbtFile.Release;
    _dbtFile:=nil;
  end;

  if _indexes<>nil then begin
    for i:=0 to _Indexes.Count-1 do begin
      TIndex(_Indexes[i]).Free;
    end;
    _Indexes.Clear;
    _CurIndex:=nil;
  end;
  if (_PrevBuffer<>nil) then begin
    FreeRecordBuffer(_PrevBuffer);
    _PrevBuffer:=nil;
  end;
  _IsCursorOpen:=false;
end;

procedure TDbf._SetIndexName(const Value: string);
begin
  _CurIndex:=_GetIndex(Value);
  Resync([]);
end;

function TDbf._GetIndexName: string;
begin
  if _CurIndex=nil then Result:=''
  else Result:=_CurIndex._IndexFile._Filename;
end;

function TDbf._GetIndex(filename:string):TIndex;
var
  i:integer;
  lindex:TIndex;
begin
  result:=nil;
  filename:=lowercase(_GetPath + filename);
  for i:=0 to _indexes.Count-1 do begin
    lindex:=TIndex(_indexes.Items[i]);
    if lindex._IndexFile._Filename=filename then begin
      result:=lindex;
      exit;
    end;
  end;
end;


//==========================================================
//============ TMyBlobFile
//==========================================================
constructor TMyBlobFile.Create(ModeVal:TBlobStreamMode;FieldVal:TField);
begin
  Mode:=ModeVal;
  Field:=FieldVal;
end;

destructor TMyBlobFile.destroy;
var
  Dbf:TDbf;
begin
  if (Mode=bmWrite) then begin
    Size:=Position; // Strange but it leave tailing trash bytes if I do not write that.
    Dbf:=TDbf(Field.DataSet);
    Dbf._dbtFile.WriteMemo(MemoRecno,ReadSize,Self);

    Dbf._dbfFile.SetFieldData(Field.FieldNo-1,
      ftInteger,@MemoRecno,@pDbfRecord(TDbf(Field.DataSet).ActiveBuffer)^.deletedflag);
    // seems not bad
{$ifndef fpc}
    // FPC doesn't allow to call protected methods ?!!
    Dbf.SetModified(true);
{$endif}
    // but would that be better
    //if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
    //  DataEvent(deFieldChange, Longint(Field));
    //end;
  end;
  inherited;
end;

//====================================================================
// TDbf = TDataset Descendant.
//====================================================================
constructor TDbf.Create(AOwner: TComponent); {override;}
begin
  inherited create(aOwner);
  BookmarkSize:=sizeof(rBookmarkData);

  _RunTimePath:='.';
  _IsCursorOpen:=false;
  _Indexes:=TList.Create;
  _CurIndex:=nil;
  _IndexFiles:=TStringList.Create;
end;

destructor TDbf.Destroy; {override;}
var
  i:integer;
begin
  inherited;
  _CurIndex:=nil;
  for i:=0 to _Indexes.Count-1 do begin
    TIndex(_Indexes[i]).Free;
  end;
  _Indexes.Free;
  _IndexFiles.Free;
//  _MemIndex.Free;
end;


function TDbf._FilterRecord(Buffer: PChar): Boolean;
var
  SaveState: TDatasetState;
  s:string;
begin
  Result:=True;
  if Length(easyfilter)<>0 then begin
    SetString(s,buffer,RecordSize);
    s:=LowerCase(s);
    if Pos(easyfilter,s)=0 then begin
      Result:=False;
      Exit;
    end;
  end;
  if not Assigned(OnFilterRecord) then Exit;
  if not Filtered then Exit;
  _FilterBuffer:=buffer;
  SaveState:=SetTempState(dsFilter);
  OnFilterRecord(self,Result);
  RestoreState(SaveState);
end;

function TDbf._RecordDataSize:integer;
begin
  if _dbfFile=nil then result:=0
  else result:=_dbfFile.RecordSize;
end;

function TDbf._FullRecordSize:integer;
begin
  result:=sizeof(rBeforeRecord) + _RecordDataSize + CalcFieldsSize;
end;

function TDbf.AllocRecordBuffer: PChar; {override virtual abstract from TDataset}
begin
  result:=StrAlloc(_FullRecordSize);
  InternalInitRecord(result);
end;

procedure TDbf.FreeRecordBuffer(var Buffer: PChar); {override virtual abstract from TDataset}
begin
  StrDispose(Buffer);
end;

procedure TDbf.GetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
var
  prec:pDbfRecord;
begin
  prec:=pDbfRecord(Buffer);
  pBookMarkData(Data)^:=prec^.BookMarkData;
end;

function TDbf.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; {override virtual abstract from TDataset}
var
  prec:pDbfRecord;
begin
  prec:=pDbfRecord(Buffer);
  result:=prec^.BookMarkFlag;
end;

function TDbf.GetFieldData(Field: TField; Buffer: Pointer): Boolean; {override virtual abstract from TDataset}
var
  ptr:pointer;
begin
  Result := False;
  if State=dsFilter then begin
    Ptr:=_FilterBuffer;
  end else   if State = dsCalcFields then  begin
    // ***** calc fields *****  set correct buffer
    ptr := @(pDbfRecord(CalcBuffer)^.deletedflag);
  end else begin
    if IsEmpty then exit;
    ptr:=@(pDbfRecord(ActiveBuffer)^.deletedflag);
  end;

  if Field.FieldNo>0 then begin
    Result:=_dbfFile.GetFieldData(Field.FieldNo - 1,Field.DataType,ptr,Buffer);
  end else begin { calculated fields.... }
    Inc(PChar(Ptr), Field.Offset + GetRecordSize);
{$ifndef fpc}
    Result := Boolean(PChar(Ptr)[0]);
{$else}
    Result := (Pchar(ptr)[0]<>#0);
{$endif}
    if Result and (Buffer <> nil) then
      Move(PChar(Ptr)[1], Buffer^, Field.DataSize);
  end;
end;


function TDbf.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; {override virtual abstract from TDataset}
var
  Acceptable : Boolean;
  prec:pDBFRecord;
begin
  prec:=pDBFRecord(Buffer);
  if _dbfFile.RecordCount < 1 then
    Result := grEOF
  else repeat
    result := grOk;
    case GetMode of
      gmCurrent :
        begin
          if prec^.BookmarkData.Recno=_PhysicalRecno then begin
            exit;    // try to fasten a bit...
          end;
        end;
      gmNext :
        begin
          if _curIndex<>nil then begin
            Acceptable:=_curIndex.Next;
          end else begin
            inc(_PhysicalRecno);
            Acceptable:=(_PhysicalRecno<_dbfFile.RecordCount);
          end;
          if Acceptable then begin
            result:= grOk;
          end else begin
            InternalLast;
            result:= grEOF
          end;
        end;
      gmPrior :
        begin
          if _curIndex<>nil then begin
            Acceptable:=_curIndex.Prev;
          end else begin
            dec(_PhysicalRecno);
            Acceptable:=(_PhysicalRecno>=0);
          end;
          if Acceptable then begin
            result:= grOk;
          end else begin
            InternalFirst;
            result:= grBOF
          end;
        end;
    end;
    if result=grOk then begin
      if _curIndex<>nil then _PhysicalRecno:=_CurIndex.GetRealRecNo;
      if (_PhysicalRecno>=_dbfFile.RecordCount)
        or (_PhysicalRecno<0) then begin
        result:=grError;
      end else begin
        _dbfFile.ReadRecord(_PhysicalRecno,@prec^.DeletedFlag);
        result:=grOk;
      end;
      if Result = grOK then begin
        ClearCalcFields(Buffer);
        GetCalcFields(Buffer);
        prec^.BookmarkFlag := bfCurrent;
        prec^.BookmarkData.Recno:=PhysicalRecno;
      end else if (Result = grError) and DoCheck then
          raise eBinaryDataSetError.Create ('GetRecord: Invalid record');
    end;
    Acceptable := (_ShowDeleted or (prec^.DeletedFlag = ' '))
      and _FilterRecord(Buffer);
    if (GetMode=gmCurrent) and Not Acceptable then Result := grError;
  until (Result <> grOK) or Acceptable;
end;

function TDbf.GetRecordSize: Word; {override virtual abstract from TDataset}
begin
  Result := _RecordDataSize; // data only
end;

procedure TDbf.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); {override virtual abstract from TDataset}
begin
end;

procedure TDbf.InternalClose; {override virtual abstract from TDataset}
begin
  _CloseFiles;

  // disconnect field objects
  BindFields(False);
  // destroy field object (if not persistent)
  if DefaultFields then
    DestroyFields;
end;

procedure TDbf.InternalDelete; {override virtual abstract from TDataset}
begin
//  CheckActive;
  pRecordHdr(ActiveBuffer)^.DeletedFlag := '*'; //_DataHdr.LastDeleted;
  _dbfFile.WriteRecord(_PhysicalRecNo,ActiveBuffer);
  Resync([]);
end;

procedure TDbf.InternalFirst; {override virtual abstract from TDataset}
begin
  if _dbfFile.RecordCount=0 then InternalLast
  else if _curindex=nil then _PhysicalRecno:=-1
  else _curIndex.First;
end;

procedure TDbf.InternalGotoBookmark(ABookmark: Pointer); {override virtual abstract from TDataset}
var
  RecInfo: TRecInfo;
begin
  RecInfo := TRecInfo(ABookmark^);
  if (RecInfo.Bookmark >= 0) and (RecInfo.Bookmark < _dbfFile.RecordCount) then begin
    _PhysicalRecno:=RecInfo.Bookmark;
  end else
    raise eBinaryDataSetError.Create ('Bookmark ' +
      IntToStr (RecInfo.Bookmark) + ' not found');
end;

procedure TDbf.InternalHandleException; {override virtual abstract from TDataset}
begin
{$ifndef fpc}
  Application.HandleException(Self);
{$endif}
end;

procedure TDbf.InternalInitFieldDefs; {override virtual abstract from TDataset}
begin
  FieldDefs.Clear;
  with FieldDefs do
  begin
    if IsCursorOpen  then begin
      _dbfFile.CreateFieldDefs(FieldDefs);
    end else begin
      _OpenFiles(false);
      _dbfFile.CreateFieldDefs(FieldDefs);
      Close();
    end;
  end;
end;

procedure TDbf.InternalInitRecord(Buffer: PChar); {override virtual abstract from TDataset}
var
  prec:pDbfRecord;
begin
  prec:=pDbfRecord(Buffer);
  prec^.BookmarkData.RecNo:=-1;
  prec^.BookmarkFlag:=TBookmarkFlag(0);
  fillchar(prec^.DeletedFlag,_RecordDataSize,' ');
end;

procedure TDbf.InternalLast; {override virtual abstract from TDataset}
begin
  if _curindex=nil then _PhysicalRecno:=_dbfFile.RecordCount
  else _curIndex.Last;
end;

procedure TDbf.InternalOpen; {override virtual abstract from TDataset}
begin
  _OpenFiles(false);
  // if there are no persistent field objects,
  InternalInitFieldDefs;
  // create the fields dynamically
  if DefaultFields then begin
    CreateFields;
  end;
  BindFields (True);
  // connect the TField objects with the actual fields

  InternalFirst;
end;

procedure TDbf.InternalPost; {override virtual abstract from TDataset}
var
  prec:pDbfRecord;
  lIndex:TIndex;
  i:integer;
begin
  CheckActive;
  prec:=pDbfRecord(ActiveBuffer);
  prec^.DeletedFlag:=' ';

  if State = dsEdit then
  begin
    // replace data with new data
    if _indexes.Count>0 then begin
      _dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
      for i:=0 to _indexes.Count-1 do begin
        lindex:=TIndex(_indexes.Items[i]);
        lindex.Update(_PhysicalRecno,_PrevBuffer,@prec^.DeletedFlag);
      end;
    end;
  end else begin
    // append
    _PhysicalRecno:=_dbfFile._DataHdr.RecordCount;
    inc(_dbfFile._DataHdr.RecordCount);
    if _indexes.Count>0 then begin
      _dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
      for i:=0 to _indexes.Count-1 do begin
        lindex:=TIndex(_indexes.Items[i]);
        lindex.Insert(_PhysicalRecno,@prec^.DeletedFlag);
      end;
    end;
  end;
  _dbfFile.WriteRecord(_PhysicalRecno,@prec^.DeletedFlag);
end;


procedure TDbf.CreateTable; //(FieldDefs:TFieldDefs);
var
  ix:integer;
begin
  CheckInactive;
  //  InternalInitFieldDefs;
  if FieldDefs.Count = 0 then
  begin
    for Ix := 0 to FieldCount - 1 do
    begin
      with Fields[Ix] do
      begin
        if FieldKind = fkData then
          FieldDefs.Add(FieldName,DataType,Size,Required);
      end;
    end;
  end;
  _OpenFiles(true);
  try
    _dbfFile.DbfFile_CreateTable(FieldDefs);
  finally
    // close the file
    _CloseFiles;
  end;
end;

procedure TDbf.PackTable;
begin
  _dbfFile.dbfFile_PackTable;
  Resync([]);
end;


function TDbf.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; {override virtual}
var
  Memoi:array[1..32] of char;
  lBlob:TMyBlobFile;
begin
  lBlob:=TMyBlobFile.Create(Mode,Field);
  if _dbfFile.GetFieldData(Field.FieldNo-1, ftString,@pDbfRecord(ActiveBuffer)^.deletedflag,@Memoi[1]) then begin
    lBlob.MemoRecno:=StrToIntDef(Memoi,0);
    _dbtFile.ReadMemo(lBlob.MemoRecno,lBlob);
    lBlob.ReadSize:=lBlob.Size;
  end else lBlob.MemoRecno:=0;
  Result:=lBlob;
end;

{$ifdef DELPHI_3}
procedure TDbf.Translate(Src, Dest: PChar; ToOem: Boolean); {override virtual}
begin
  if (Src <> nil) and (Dest<>nil) then begin
    if ToOem then CharToOem(Src,Dest)
    else OemToChar(Src,Dest);
  end;
end;
{$else}
{$ifndef fpc}
function TDbf.Translate(Src, Dest: PChar; ToOem: Boolean): Integer; {override virtual}
begin
  if (Src <> nil) and (Dest<>nil) then begin
    if ToOem then CharToOem(Src,Dest)
    else OemToChar(Src,Dest);
    result:= StrLen(Dest);
  end else result:=0;
end;
{$else}
function TDbf.Translate(Src, Dest: PChar; ToOem: Boolean): Integer; {override virtual}
begin
end;
{$endif}
{$endif}

procedure TDbf.ClearCalcFields(Buffer: PChar);
begin
  FillChar(Buffer[_dbfFile.RecordSize], CalcFieldsSize, 0);
end;

procedure TDbf.InternalSetToRecord(Buffer: PChar); {override virtual abstract from TDataset}
var
  prec:pDbfRecord;
begin
  if Buffer=nil then exit;
  prec:=pDbfRecord(Buffer);
  _PhysicalRecno:=prec^.BookmarkData.RecNo;
  _ResyncIndexes(Buffer);
end;

procedure TDbf._ResyncIndexes(Buffer: PChar);
var
  i:integer;
  lindex:TIndex;
begin
  if _indexes.Count>0 then begin
    _dbfFile.ReadRecord(_PhysicalRecno,_PrevBuffer);
    for i:=0 to _indexes.Count-1 do begin
      lindex:=TIndex(_indexes.Items[i]);
      lindex.GotoKey(_physicalRecno,nil);
    end;
  end;
end;

function TDbf.IsCursorOpen: Boolean; {override virtual abstract from TDataset}
begin
  result:=_IsCursorOpen;
end;

procedure TDbf.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); {override virtual abstract from TDataset}
var
  prec:pDbfRecord;
begin
  prec:=pDbfRecord(Buffer);
  prec^.BookMarkFlag:=Value;
end;

procedure TDbf.SetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
var
  prec:pDbfRecord;
begin
  prec:=pDbfRecord(Buffer);
  prec^.BookMarkData:=pBookMarkData(Data)^;
end;

procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer); {override virtual abstract from TDataset}
var
  prec:pDbfRecord;
  dst:pointer;
begin
  if (Field.FieldNo >= 0) then begin
    prec:=pDbfRecord(ActiveBuffer);
    dst:=@prec^.DeletedFlag;
    _dbfFile.SetFieldData(Field.FieldNo - 1,Field.DataType,Buffer,Dst);
  end else begin    { ***** fkCalculated, fkLookup ***** }
    prec:=pDbfRecord(CalcBuffer);
    dst:=@prec^.DeletedFlag;
    Inc(integer(dst), GetRecordSize + Field.Offset);
    Boolean(dst^) := LongBool(Buffer);
    if Boolean(dst^) then begin
      Inc(integer(dst), 1);
      Move(Buffer^, dst^, Field.DataSize);
    end;
  end;     { end of ***** fkCalculated, fkLookup ***** }
  if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
    DataEvent(deFieldChange, Longint(Field));
  end;
end;


// this function is just for the grid scrollbars
// it doesn't have to be perfectly accurate, but fast.
function TDbf.GetRecordCount: Integer; {override virtual}
begin
  if _curIndex=nil then begin
    result:=_dbfFile.RecordCount;
  end else begin
    result:=_curIndex.GuessRecordCount;
  end;
end;

// this function is just for the grid scrollbars
// it doesn't have to be perfectly accurate, but fast.
function TDbf.GetRecNo: Integer; {override virtual}
begin
  UpdateCursorPos;
  if _curIndex=nil then begin
    result:=_PhysicalRecno+1;
  end else begin
    result:=_curIndex.GuessRecNo;
  end;
end;

procedure TDbf.SetRecNo(Value: Integer); {override virual}
begin
  if _curIndex=nil then begin
    _PhysicalRecno:=Value-1;
  end else begin
    //result:=_curIndex.GuessRecNo;
  end;
  Resync([rmExact]);
end;

procedure TDBf.DeleteIndex(const AName: string);

begin
  // I must admit that is seems a bit expeditive.
  // but I does implement this method because TTable does
  DeleteFile(_GetPath + Name);
end;

procedure TDbf.CloseIndexFile(const IndexFileName: string);
var
  lindex:tindex;
begin
  lindex:=_GetIndex(IndexFileName);
  if lindex<>nil then begin
    lindex.Free;
    _indexes.Delete(_indexes.IndexOf(lindex));
    if _curindex = lindex then begin
      _curindex:=nil;
      resync([]);
    end;
  end;
end;

procedure TDbf.OpenIndexFile(AnIndexName:string);
var
  lIndexFile:TIndexFile;
  lIndex:TIndex;
begin
  lindex:=_GetIndex(IndexName);
  if lindex=nil then begin
    IndexName:=lowercase(_GetPath + IndexName);
    lIndexFile:=TIndexFile(GetPagedFile(IndexName));
    if lIndexFile=nil then begin
      lIndexFile:=TIndexFile.Create(IndexName,fmOpenReadWrite + fmShareDenyWrite);
    end;
    lIndex:=TIndex.Create(lIndexFile,0,false);
    _Indexes.Add(lIndex);
    lIndex.InitFieldDef(_DbfFile,lIndex._NdxHdr.KeyDesc);
  end;
end;

(*
procedure TDbfFile.DbfFile_PackTable;
var
begin
end;
*)
{$ifdef fpc}
procedure TDbf.AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions);

begin
  AddIndex(indexName,IndexFields,options,'');
end;
{$endif}

{$ifdef DELPHI_3}
procedure TDbf.AddIndex(const IndexName, Fields: String; Options: TIndexOptions);
var
  DescFields:string;
{$else}
{$ifndef fpc}
procedure TDbf.AddIndex(const IndexName, Fields: String; Options: TIndexOptions; const DescFields: String='');
var
{$else}
procedure TDbf.AddIndex(const AnIndexName, IndexFields: String; Options: TIndexOptions; const DescFields: String);
var
{$endif}
{$endif}
  lfilename:string;
  lIndexFile:TIndexFile;
  lIndex:TIndex;
  cur,thelast:integer;
begin
  lfilename:=lowercase(_GetPath+IndexName);
  lIndexFile:=TIndexFile(GetPagedFile(lfilename));
  if lIndexFile<>nil then exit;
  lIndexFile:=TIndexFile.Create(lfilename,fmCreate);
  lIndex:=TIndex.Create(lIndexFile,0,true);
{$ifndef fpc}
  lIndex.InitFieldDef(_DbfFile,Fields);
{$else}
  lIndex.InitFieldDef(_DbfFile,IndexFields);
{$endif}
  with lIndex._NdxHdr do begin
    startpage:=1;
    nbPage:=1;
    keyformat:=#0;
    keytype:='C';
    dummy:=$5800;
    keylen:=lindex._FieldLen;
    nbkey:=(512-8) div (lindex._FieldLen+8);
    keyreclen:=lindex._FieldLen+8;
    Unique:=0;
    KeyDesc[0]:=' ';
{$ifndef fpc}
    StrLCopy(KeyDesc,PChar(UpperCase(Fields)),255);
{$else}
    StrLCopy(KeyDesc,PChar(UpperCase(IndexFields)),255);
{$endif}
  end;
  lindex._IndexFile._Seek(lindex._RootPage);
  lindex._IndexFile.Stream.Write(lindex._NdxHdr,SizeOf(lindex._NdxHdr));

  cur:=0;
  thelast:=_DbfFile.CalcRecordCount;

  while cur<thelast do begin
    _DbfFile.ReadRecord(cur, _PrevBuffer);
    lIndex.Insert(cur,_PrevBuffer);
    inc(cur);
  end;
  _Indexes.Add(lIndex);
end;
//==========================================================
//============ dbtfile
//==========================================================
constructor TDbtFile.Create(const FileName: string; Mode: Word; Ver:xBaseVersion);
begin
  inherited Create(FileName,Mode);
  _DbtVersion:=Ver;
  if mode = fmCreate then begin
    FillChar(_MemoHdr,sizeof(_MemoHdr),0);
  end else begin
    Stream.Position:=0;
    Stream.read(_MemoHdr,SizeOf(_MemoHdr));
  end;
  HeaderSize:=0;
  RecordSize:=_MemoHdr.BlockLen;

  if (RecordSize=0) or ((RecordSize mod 128)<>0) then begin
    _MemoHdr.BlockLen := $200;
    RecordSize := $200;
  end;
  // Can you tell me why the header of dbase3 memo contains 1024 and it 512 ?
  if _DbtVersion=xBaseIII then RecordSize:=512;
end;

procedure TDbtFile.ReadMemo(recno:Integer;Dst:TStream);
var
  Buff:array[0..511] of char;
  i,lsize:integer;
  finish:boolean;
  lastc:char;
begin
  if recno=0 then Exit;
  Stream.Position:= RecordSize * recno;
  if _DbtVersion >= xBaseIV then begin // dBase4 memofiles
    Stream.read(Buff[0],8);
    if (Buff[0]=#$ff) and  (Buff[1]=#$ff) and
      (Buff[2]=#$08) and (Buff[3]=#$00) then begin
          // dbase IV memo
      lsize:=(PInteger(@Buff[4])^)-8;
    end else begin
      lsize:=0;
    end;
    repeat
      if lsize>SizeOf(Buff) then begin
        Stream.read(Buff,SizeOf(Buff));
        Dst.Write(buff,SizeOf(Buff));
        Dec(lsize,SizeOf(Buff));
      end else if lsize>0 then begin
        Stream.read(Buff,lsize);
        Dst.Write(buff,lsize);
        lsize:=0;
      end;
    until lsize=0;
  end else begin
    finish:=False;
    Stream.read(Buff,SizeOf(Buff));
    lastc:=#0;
    repeat
      for i:=0 to SizeOf(Buff)-2 do begin
        if ((Buff[i]=#$1A) and
          ((Buff[i+1]=#$1A) or ((i=0) and (lastc=#$1A))))
          or (Buff[i]=#$0)
          then begin
          if i>0 then Dst.Write(buff,i);
          finish:=True;
          break;
        end;
      end;
      if finish then Break;
      Dst.Write(buff,512);
      lastc:=Buff[511];
      Stream.read(Buff,SizeOf(Buff));
    until finish;
  end;
  Dst.Seek(0,0);
end;

procedure TDbtFile.WriteMemo(var MemoRecno:Integer;ReadSize:Integer;Src:TStream);
var
  ByteBefore:Integer;
  ByteAfter:Integer;
  Buff:array[0..511] of char;
  i:Integer;
  c:Byte;
  Append:Boolean;
begin
  if _DbtVersion >= xBaseIV then begin // dBase4 memofiles
    ByteBefore:=8;
    ByteAfter:=0;
  end else begin // stupid files
    ByteBefore:=0;
    ByteAfter:=2;
  end;
  if Src.Size = 0 then begin
    MemoRecno:=0;
  end else begin
    if ((ByteBefore+Src.Size+ByteAfter+_MemoHdr.BlockLen-1) div _MemoHdr.BlockLen)
      <= ((ReadSize+_MemoHdr.BlockLen-1) div _MemoHdr.BlockLen)
      then begin
      Append:=false;
      //MemoRecno:=MemoRecno;
    end else begin
      Append:=True;
      MemoRecno:=_MemoHdr.NextBlock;
      if MemoRecno=0 then begin
        _MemoHdr.NextBlock:=1;
        MemoRecno:=1;
      end;
    end;
    Stream.Seek(_MemoHdr.BlockLen * MemoRecno,0);
    i:=Src.Position;
    Src.Seek(0,0);
    if ByteBefore=8 then begin
      i:=$0008ffff;
      Stream.Write(i,4);
      i:=Src.Size+ByteBefore+ByteAfter;
      Stream.Write(i,4);
    end;
    repeat
      i:=Src.Read(buff,512);
      if i=0 then break;
      Inc(_MemoHdr.NextBlock);
      Stream.Write(Buff,i);
    until i<512;
    if ByteAfter=2 then begin
      c:=$1A;
      Stream.Write(c,1);
      Stream.Write(c,1);
    end;
    if Append then begin
      Stream.Seek(0,0);
      Stream.Write(_MemoHdr,SizeOf(_MemoHdr))
    end;
  end;
end;

//==========================================================
//============ TIndexFile
//==========================================================
constructor TIndexFile.Create(const FileName: string; Mode: Word);
var
  ext:string;
  i:Integer;
begin
  inherited Create(FileName,Mode);
  HeaderSize:=0;
  RecordSize:=512;

  ext:=ExtractFileExt(FileName);
  if (ext='.mdx') then begin
    _IndexVersion:=xBaseIV;
    if Mode = fmCreate then begin
      FillChar(_MdxHdr,sizeof(_MdxHdr),0);
    end else begin
      Stream.read(_MdxHdr,SizeOf(_MdxHdr));
    end;
    for i:= 0 to _MdxHdr.TagUsed-1 do begin
//      Stream.Position :=544 + i * _MdxHdr.TagSize;
//      Stream.read(lMdxTag,SizeOf(rMdxTag));
//      lIndex:=TIndex.Create(Self,lMdxTag.pageno);
//      _Indexes.Add(lIndex);
//      if i=0 then lIndex.ReadPage(lIndex._NdxHdr.startpage);
    end;
  end else begin
    _IndexVersion:=xBaseIII;
(*
      _IndexFile._Seek(Pos);
      _IndexFile.Stream.Read(_NdxHdr,SizeOf(_NdxHdr));
      _Root:=TIndexPage.Create(Self);
      _Root.SetPageNo(_NdxHdr.startpage);
      lPos:=_Root;
      _nblevel:=1;
      repeat
        lPos.LocalFirst;
        if lPos.Entry._LowerPage=0 then break;
        inc(_nblevel);
    lChild:=TIndexPage.Create(Self);
    lChild._UpperLevel:=lPos;
    lPos._LowerLevel:=lChild;
    lChild.SetPageNo(lPos.Entry._LowerPage);
    lPos:=lChild;
  until false;

  _Spare:=TIndexPage.Create(Self);
//  _Field:=_IndexFile._Dbf.FindField(_NdxHdr.KeyDesc);
  First;
*)
  end;
end;

destructor TIndexFile.Destroy;
begin
  inherited;
end;

//==========================================================
//============ TIndexPage
//==========================================================
constructor TIndexPage.Create(Parent:TIndex);
begin
  _LowerLevel:=nil;
  _UpperLevel:=nil;
  _Index:=Parent;
  _PageNo:=-1;
  _EntryNo:=-1;
end;

destructor TIndexPage.Destroy;
begin
  if _LowerLevel<>nil then _LowerLevel.Free;
end;

function  TIndexPage.GetPEntry(EntryNo:integer):PNdxEntry;
begin
  Result:=PNdxentry(@_PageBuff.Entries[_Index._NdxHdr.keyreclen*entryno]);
end;

function  TIndexPage.LocalInsert(Recno:integer; Buffer:Pchar;LowerPage:integer):boolean;
var
  src,dst:pointer;
  siz:integer;
begin
  if _PageBuff.NbEntries < _Index._NdxHdr.nbkey then begin
    src:=Entry;
    dst:=GetPEntry(_EntryNo+1);
    siz:=(_PageBuff.NbEntries - _EntryNo)
      * _Index._NdxHdr.keyreclen + 8;
    Move(Src^, Dst^, Siz);
    inc(_PageBuff.NbEntries);
    SetEntry(Recno,Buffer,LowerPage);
    Write;
    Result:=true;
  end else begin
    Result:=false;
  end;
end;


function  TIndexPage.LocalDelete:boolean;
var
  src,dst:pointer;
  siz:integer;
begin
  if _PageBuff.NbEntries >=0 then begin
    if _EntryNo<_PageBuff.NbEntries then begin
      src:=GetPEntry(_EntryNo+1);
      dst:=Entry;
      siz:=(_PageBuff.NbEntries - _EntryNo - 1)
        * _Index._NdxHdr.keyreclen + 8;
      Move(Src^, Dst^, Siz);
    end;
    dec(_PageBuff.NbEntries);
    Write;
    if ((_PageBuff.NbEntries=0) and (_lowerlevel=nil))
      or (_PageBuff.NbEntries<0) then begin
      if _UpperLevel<>nil then begin
        _UpperLevel.LocalDelete;
      end;
    end else if (_EntryNo>LastEntryNo) then begin
      SetEntryNo(LastEntryNo); // We just removed the last on this page.
      if (_UpperLevel<>nil)  then begin
        _UpperLevel.SetEntry(0,Entry^.CKey,_PageNo);
      end;
    end;
    Result:=true;
  end else begin
    Result:=false;
  end;
end;

function  TIndexPage.LastEntryNo:integer;
begin
  if (_LowerLevel=nil) then begin
    result := _PageBuff.NbEntries - 1;
  end else begin
    result := _PageBuff.NbEntries;
  end;
end;

procedure TIndexPage.LocalFirst;
begin
  SetEntryNo(0);
end;

procedure TIndexPage.LocalLast;
begin
  SetEntryNo(LastEntryNo);
end;

function TIndexPage.LocalPrev:boolean;
begin
  if _EntryNo>0 then begin
    SetEntryNo(_EntryNo-1);
    Result:=true;
  end else begin
    Result:=false;
  end;
end;

function TIndexPage.LocalNext:boolean;
begin
  if (_EntryNo<LastEntryNo) then begin
    SetEntryNo(_EntryNo+1);
    Result:=true;
  end else begin
    Result:=false;
  end;
end;

procedure TIndexPage.First;
begin
  LocalFirst;
  if (_LowerLevel<>nil) then LowerLevel.First;
end;

procedure TIndexPage.Last;
begin
  LocalLast;
  if (_LowerLevel<>nil) then LowerLevel.Last;
end;

function TIndexPage.Prev:boolean;
begin
  if (_LowerLevel<>nil) and LowerLevel.Prev then begin
    result:=true;
    exit;
  end;
  Result:=LocalPrev;
  if Result and (Entry^._LowerPage>0) then LowerLevel.Last;
end;

function TIndexPage.Next:boolean;
begin
  if (_LowerLevel<>nil) and LowerLevel.next then begin
    result:=true;
    exit;
  end;
  Result:=LocalNext;
  if Result and (Entry^._LowerPage>0) then LowerLevel.First;
end;


function TIndexPage.FindNearest(Recno:integer; Key:pchar):integer;
var
  cmpres:integer;
  v1,v2:double;
  p:TIndexPage;
begin
  Result:=-1;
  if @Key=nil then begin
    Exit;
  end;
  SetEntryNo(0);
  while _EntryNo<=_PageBuff.NbEntries do begin
    if _EntryNo=_PageBuff.NbEntries then break;
    if _Index._NdxHdr.keytype='C' then begin
      cmpres:=StrLIComp(PChar(Key),Entry^.CKey,_Index._FieldLen);
    end else begin
      // Numeric field... to do
      v1:=PDouble(Key)^;
      v2:=Entry^.NKey;
      if v1>v2 then cmpres:=1
      else if v1<v2 then cmpres:=-1
      else cmpres:=0;
    end;
    if cmpres=0 then begin
      if _LowerLevel=nil then begin
        if (Entry^.RecNo=Recno) then begin
          result:=0;
          Exit;
        end else if (Entry^.Recno>Recno) then begin
          result:=-1;
          Exit;
        end;
      end else begin
        p:=self;
        while p._LowerLevel<>nil do begin
          p:=p.LowerLevel;
          p.LocalLast;
        end;
        if (p.Entry^.Recno>=Recno) then begin
          result:=-1;
          Exit;
        end;
      end;
    end else if cmpres<0 then begin
      result:=-1;
      exit;
    end;
    SetEntryNo(_EntryNo+1);
  end;
  result:=1;
  Exit;
end;

procedure TIndexPage.SetEntry(Recno:Integer; key:PChar; LowerPage:integer);
begin
  assert((_EntryNo>=0) and (_EntryNo<=_PageBuff.NbEntries));
  if (_EntryNo=self._PageBuff.NbEntries) then begin
    if (_UpperLevel<>nil)  then begin
      _UpperLevel.SetEntry(0,key,Self._PageNo);
    end;
  end else begin
    if _Index._NdxHdr.keytype='C' then begin
      mymove(key,Entry^.CKey,_Index._NdxHdr.keylen);
    end else begin
      Entry^.NKey:=PDouble(key)^;
    end;
  end;
  Entry^.RecNo:=RecNo;
  Entry^._LowerPage:=LowerPage;
  Write;
end;
function TIndexPage.LowerLevel : TIndexPage;
begin
  if (_LowerLevel<>nil) and (_LowerLevel._PageNo<>Entry^._LowerPage) then begin
    _LowerLevel.SetPageNo(Entry^._LowerPage);
  end;
  result:=_LowerLevel;
end;

function TIndexPage.Insert(Recno:Integer; Buffer:PChar; LowerPage:integer):boolean;
var
  src,dst:PNdxEntry;
  siz:integer;
  split,old_entry:integer;
  lSpare:TIndexPage;
begin
  if not LocalInsert(recno,buffer,lowerpage) then begin
    // The entry is FULL so we will split this page
    // 1 - Check parent exist
    if _UpperLevel=nil then begin
      AddNewLevel;
    end;

    old_entry:=_EntryNo;
    split:=_EntryNo;
    if split < _Index._NdxHdr.nbkey div 2 then begin
      split:=_Index._NdxHdr.nbkey div 2;
    end;
    lSpare:=TIndexPage.Create(_Index);
    try
      // 2 - Create new page with first part
      inc(_Index._NdxHdr.nbPage);
      lSpare._PageNo:=_Index._NdxHdr.nbPage;
      _Index._IndexFile._Seek(_Index._RootPage);
      _Index._IndexFile.Stream.WriteBuffer (_Index._NdxHdr, SizeOf(_Index._NdxHdr));

      if _lowerlevel=nil then begin
        lSpare._PageBuff.NbEntries:=split;
      end else begin
        lSpare._PageBuff.NbEntries:=split-1;
      end;
      siz:=split*_Index._NdxHdr.keyreclen+8;
      src:=@_PageBuff.Entries;
      dst:=@lSpare._PageBuff.Entries;
      Move(src^,dst^,siz);
      lSpare.Write;

      // 3 - Keep only end-part in this page
      siz:=(_PageBuff.NbEntries-Split);
      _PageBuff.NbEntries:=siz;

      siz:=siz*_Index._NdxHdr.keyreclen+8;
      SetEntryNo(split);
      src:=Entry;
      SetEntryNo(0);
      dst:=Entry;
      Move(src^,dst^,siz);

      // 3 - Update upper level
      lSpare.SetEntryNo(split-1);
      _UpperLevel.Insert(0,lSpare.Entry^.CKey,lSpare._PageNo);

      // We just need to go on inserted record now

      if old_entry>=split then begin
        _UpperLevel.LocalNext;
        SetEntryNo(old_entry - split);
        LocalInsert(Recno,Buffer,LowerPage);
        lSpare.Write;
      end else begin
        lSpare.SetEntryNo(old_entry);
        lSpare.LocalInsert(Recno,Buffer,LowerPage);
        Write;
      end;
    finally
      lspare.free;
    end;
  end;
    Result:=true;
end;

function TIndexPage.Delete:boolean;
begin
  Result:=LocalDelete;
end;

procedure TIndexPage.SetPageNo(page:Integer);
begin
  if (_PageNo<>page) and (page>0) then begin
    _Index._IndexFile.ReadRecord(Page,@_PageBuff);
    _PageNo:=page;
    _EntryNo:=-1;
  end;
end;

procedure TIndexPage.AddNewLevel;
var
  lNewPage:TIndexPage;
begin
  lNewPage:=TIndexPage.Create(_Index);
  inc(_Index._NdxHdr.nbPage);
  lNewPage._PageNo:= _Index._NdxHdr.nbPage;
  _Index._NdxHdr.startpage:= _Index._NdxHdr.nbPage;
  _Index._IndexFile._Seek(_Index._RootPage);
  _Index._IndexFile.Stream.WriteBuffer (_Index._NdxHdr, SizeOf(_Index._NdxHdr));

  lNewPage._PageBuff.NbEntries:=0;
  lNewPage._UpperLevel:=nil;
  lNewPage._LowerLevel:=_Index._Root;
  lNewPage.SetEntryNo(0);
  lNewPage.SetEntry(0,nil,_PageNo);
  _Index._Root._UpperLevel:=lNewPage;
  _Index._Root:=lNewPage;
  lNewPage:=nil;
end;

procedure TIndexPage.Write;
begin
  _Index._IndexFile.WriteRecord(_PageNo,@_PageBuff);
end;

procedure TIndexPage.SetEntryNo(entryno:Integer);
begin
  if (_EntryNo<>entryno) then begin
    _EntryNo:=entryno;
    if _EntryNo>=0 then Entry:=PNdxentry(@_PageBuff.Entries[_Index._NdxHdr.keyreclen*entryno]);
  end;
end;

procedure TIndexPage.WritePage(Page:integer);
begin
  _Index._IndexFile.WriteRecord(Page,@_PageBuff);
end;

//==========================================================
//============ TIndex
//==========================================================
constructor TIndex.Create(Parent:TIndexFile; RootPage:integer;CreateIt:boolean);
var
  lPos:TIndexPage;
  lChild:TIndexPage;
begin
  _RootPage:=RootPage;
  _IndexFile:=Parent;
  //_IndexOrder:=TList.Create;
  if CreateIt then begin
    FillChar(_NdxHdr,sizeof(_NdxHdr),0);
    _NdxHdr.startpage:=1;
    _NdxHdr.nbPage:=2;
    _NdxHdr.keyformat:=#0;
    _NdxHdr.keytype:='C';

    _IndexFile._Seek(RootPage);
    _IndexFile.Stream.Write(_NdxHdr,SizeOf(_NdxHdr));
    _FieldPos := 0;
    _FieldLen := 0;
  end else begin
    _IndexFile._Seek(RootPage);
    _IndexFile.Stream.Read(_NdxHdr,SizeOf(_NdxHdr));
  end;

  _Root:=TIndexPage.Create(Self);
  _Root.SetPageNo(_NdxHdr.startpage);
  lPos:=_Root;
  _nblevel:=1;
  repeat
    lPos.LocalFirst;
    if lPos.Entry^._LowerPage=0 then break;
    inc(_nblevel);
    lChild:=TIndexPage.Create(Self);
    lChild._UpperLevel:=lPos;
    lPos._LowerLevel:=lChild;
    lChild.SetPageNo(lPos.Entry^._LowerPage);
    lPos:=lChild;
  until false;

  inc(_IndexFile._cntuse);
  First;
end;

destructor TIndex.Destroy;
begin
  _IndexFile.Release;
   _Root.Free;
end;


function TIndex.Find(Recno:integer; Buffer:PChar; var pPos:TIndexPage):integer;
var
  res:integer;
begin
  pPos:=_Root;
  repeat
    res:=pPos.FindNearest(Recno,Buffer);
    if res<>0 then begin
      if pPos.Entry^._LowerPage<>0 then begin
        pPos:=pPos.LowerLevel;
        res:=2;
      end;
    end;
  until res<>2;
  Result:=res;
end;

procedure TIndex.Update(Recno: integer; PrevBuffer,NewBuffer: PChar);
var
  lPos:TIndexPage;
begin
  if _FieldLen=0 then exit;

  inc(PrevBuffer,_FieldPos);
  inc(NewBuffer,_FieldPos);

  if StrLIComp(PrevBuffer,NewBuffer,_FieldLen)<>0 then begin
    Delete;
    Find(Recno+1,NewBuffer,lPos);
    lPos.Insert(Recno+1,NewBuffer,0);
  end;
end;

procedure TIndex.Insert(Recno:integer; Buffer:PChar);
var
  lPos:TIndexPage;
begin
  if _FieldLen=0 then exit;

  inc(Buffer,_FieldPos);

  Find(Recno+1,Buffer,lPos);
  lPos.Insert(Recno+1,Buffer,0);
end;

function TIndex.Delete:boolean;
var
  lPos:TIndexPage;
begin
  lpos:=_root;
  while lpos._LowerLevel<>nil do begin
    lPos:=lPos.LowerLevel;
  end;
  lPos.Delete;
  Result:=true;
end;


function TIndex.Pos:TIndexPage;
var
  p:TIndexPage;
begin
  p:=_Root;
  while p.Entry^._LowerPage>0 do begin
    p:=p.LowerLevel;
  end;
  result:=p;
end;

procedure TIndex.First;
begin
  _Root.First;
  dec(Pos._EntryNo);
end;

procedure TIndex.Last;
begin
  _Root.Last;
  inc(Pos._EntryNo);
end;

function TIndex.Prev:boolean;
begin
  result:=_Root.Prev;
end;

function TIndex.Next:boolean;
begin
  result:=_Root.Next;
end;

(*
procedure TIndex.SetRecNo(Value: Integer);
var
  pos:integer;
  p:TIndexPage;
  i:integer;
  ldiv:integer;
begin
  p:=_Root;
  ldiv:=1;
  while p.Entry^._LowerPage>0 do begin
    ldiv:=ldiv*(_NdxHdr.nbkey+1);
    p:=p._LowerLevel;
  end;
  pos:=value div ldiv;
  p:=_Root;
  while p.Entry^._LowerPage>0 do begin
    p._EntryNo:=pos;
    value:=value - pos * (_NdxHdr.nbkey+1);
    ldiv:=ldiv div (_NdxHdr.nbkey+1);
    pos:=value div ldiv;
    p:=p._LowerLevel;
  end;
{
  pos:=1;
  First;
  While pos<value do begin
    if Next = false then break;
    inc(pos);
  end;
}
end;
*)
function TIndex.GuessRecordCount: Integer;
var
  lPos:TIndexPage;
  nbrecord:integer;
begin
  // I just read first level and Guess an approximate record count...
  nbrecord:=_Root._PageBuff.NbEntries;
  lPos:=_Root.LowerLevel;
  while lpos<>nil do begin
    nbrecord:=nbrecord*(_NdxHdr.nbkey+1);
    lPos:=lPos.LowerLevel;
  end;
  result:=nbrecord;
end;


function TIndex.GuessRecNo:Integer;
var
  p:TIndexPage;
begin
  p:=_Root;
  result:=p._EntryNo;
  while p.Entry^._LowerPage>0 do begin
    p:=p.LowerLevel;
    Result:=Result*(_NdxHdr.nbkey+1) + p._EntryNo;
  end;
end;

function TIndex.GetRealRecNo:integer;
var
  ippos : TIndexPage;
begin
  ippos:=_Root;
  while ippos._LowerLevel<>nil do begin
    ippos:=pos.LowerLevel;
  end;
  if (ippos._EntryNo<0) or (ippos._EntryNo>=ippos._PageBuff.NbEntries) then Result:=-1
  else Result:=ippos.Entry^.RecNo-1;
end;

procedure TIndex.GotoKey(recno:integer; buffer:pchar);
begin
  // very temporary implementation
  // could definitely be a bit faster.
  _Root.First;
  repeat
    if self.Pos.Entry^.RecNo=(recno+1) then begin
      exit;
    end;
  until Next=false;
end;

procedure TIndex.InitFieldDef(dbfFile:TDbfFile;FieldDesc:string);
var
  FieldInfo:TMyFieldInfo;
begin
  FieldInfo:=DbfFile.GetFieldInfo(FieldDesc);
  if FieldInfo<>nil then begin
    _FieldPos:=FieldInfo.Offset;
    _FieldLen:=FieldInfo.Size;
  end;
end;

//==========================================================
//============ initialization
//==========================================================

{$ifndef fpc}
type

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

procedure TTableNameProperty.Edit; {override;}
var
  FileOpen: TOpenDialog;
  Dbf: TDbf;
begin
  FileOpen := TOpenDialog.Create(Application);
  try
    with fileopen do begin
      Dbf:=GetComponent(0) as TDbf;
      Filename := Dbf.DesignTimePath + GetValue;
      Filter := 'Dbf table|*.dbf';
      if Execute then begin
        SetValue(ExtractFilename(Filename));
        Dbf.DesignTimePath:=ExtractFilePath(Filename);
      end;
    end;
  finally
    Fileopen.free;
  end;
end;

function TTableNameProperty.GetAttributes: TPropertyAttributes; {override;}
begin
  Result := [paDialog, paRevertable];
end;



type
  TRunTimePathProperty = class(TStringProperty)
  end;

  TDesignTimePathProperty = class(TStringProperty)
  end;

//==========================================================
//============ initialization
//==========================================================

procedure Register;
begin
  RegisterComponents('Exemples', [TDbf]);
  RegisterPropertyEditor(TypeInfo(string), TDbf, 'TableName', TTableNameProperty);
  RegisterPropertyEditor(TypeInfo(string), TDbf, 'RunTimePath', TRunTimePathProperty);
  RegisterPropertyEditor(TypeInfo(string), TDbf, 'DesignTimePath', TDesignTimePathProperty);
//  RegisterPropertyEditor(TypeInfo(TStrings), TDbf, 'IndexFiles', TIndexFilesProperty);
//  ShowMessage(ToolServices.GetProjectName);
end;
{$endif fpc}

initialization
    _PagedFiles := TList.Create;
    tDbf_TrimFields := true;

finalization
    _PagedFiles.free;

end.