dbf.pas

很管用的GIS控件

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

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db,  DsgnIntf, ExptIntf;
// 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}

//====================================================================
// 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;Create: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(Create: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 Name: string);
    property IndexName: string read _GetIndexName write _SetIndexName;
    function Deleted: Boolean;
    procedure Recall;

{$ifdef DELPHI_3}
    procedure AddIndex(const IndexName, Fields: String; Options: TIndexOptions);
{$else}
    procedure AddIndex(const IndexName, Fields: String; Options: TIndexOptions; const DescFields: String='');
{$endif}
    procedure CloseIndexFile(const IndexFileName: string);
    procedure OpenIndexFile(IndexName: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; Append: Boolean); override; {virtual abstract}
    procedure InternalClose; override; {virtual abstract}
    procedure InternalDelete; override; {virtual abstract}
    procedure InternalFirst; override; {virtual abstract}
    procedure InternalGotoBookmark(Bookmark: 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;