ddhdsone.pas

Delphi高级开发指南是开发程序的好帮手

unit DdhDsOne;

interface

uses
  SysUtils, Classes, Db;

type
  EDataSetOneError = class (Exception);

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

type
  TDdhDataSetOne = class(TDataSet)
  protected
    FStream: TStream; // the physical table
    FTableName: string; // table path and file name

    // record data
    FRecordCount, // current number of record
    FRecordSize, // the size of the actual data
    FRecordBufferSize, // data + housekeeping (TRecInfo)
    FRecordInfoOffset, // offset of RecInfo in record buffer
    FCurrentRecord, // current record (0 to FRecordCount - 1)
    BofCrack, // before the first record (crack)
    EofCrack: Integer; // after the last record (crack)

    // file header size (optionally used by subclasses)
    FDataFileHeaderSize: Integer;

    // status
    FIsTableOpen: Boolean;

    // field offsets in record
    FFieldOffset: TList;

  protected
    // TDataSet virtual abstract method
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar;
      Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar):
      TBookmarkFlag; override;
    function GetFieldData(Field: TField;
      Buffer: Pointer): Boolean; override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode;
      DoCheck: Boolean): TGetResult; override;
    function GetRecordSize: Word; override;
    procedure InternalAddRecord(Buffer: Pointer;
      Append: Boolean); override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalFirst; override;
    procedure InternalGotoBookmark(
      Bookmark: Pointer); override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    function IsCursorOpen: Boolean; override;
    procedure SetBookmarkFlag(Buffer: PChar;
      Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar;
      Data: Pointer); override;
    procedure SetFieldData(Field: TField;
      Buffer: Pointer); override;

    // TDataSet virtual method (optional)
    function GetRecordCount: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    function GetRecNo: Integer; override;
  public
    procedure CreateTable;
  published
    property TableName: string
      read FTableName write FTableName;
    // redeclared data set properties
    property Active;
    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;
  end;

procedure Register;

implementation

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

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

// I: open the table/file
procedure TDdhDataSetOne.InternalOpen;
begin
  // check if the file exists
  if not FileExists (FTableName) then
    raise EDataSetOneError.Create ('Open: Table file not found');

  // create a stream for the file
  FStream := TFileStream.Create (FTableName, fmOpenReadWrite);

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

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

  // get the number of records and check size
  FRecordCount := FStream.Size div FRecordSize;
  if (FStream.Size mod FRecordSize) <> 0 then
    raise EDataSetOneError.Create ('Open: Invalid table size');

  // sets cracks and record position
  BofCrack := -1;
  EofCrack := FRecordCount;
  FCurrentRecord := BofCrack;

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

  // the file of this version has no header
  FDataFileHeaderSize := 0;

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

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

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

// I: define the fields
procedure TDdhDataSetOne.InternalInitFieldDefs;
var
  IniFileName, FieldName: string;
  IniFile: TIniFile;
  nFields, I, TmpFieldOffset, nSize: Integer;
  FieldType: TFieldType;
begin
  FFieldOffset := TList.Create;
  FieldDefs.Clear;
  TmpFieldOffset := 0;
  IniFilename := ChangeFileExt(FTableName, '.ini');
  Inifile := TIniFile.Create (IniFilename);
  // protect ini file
  try
    nFields := IniFile.ReadInteger ('Fields', 'Number', 0);
    if nFields = 0 then
      raise EDataSetOneError.Create ('InitFieldsDefs: 0 fields?');
    for I := 1 to nFields do
    begin
      // create the field
      FieldType := TFieldType (GetEnumValue (
        TypeInfo (TFieldType),
        IniFile.ReadString (
          'Field' + IntToStr (I), 'Type', '')));
      FieldName := IniFile.ReadString (
        'Field' + IntToStr (I), 'Name', '');
      if FieldName = '' then
        raise EDataSetOneError.Create (
          'InitFieldsDefs: No name for field ' +
          IntToStr (I));
      nSize := IniFile.ReadInteger (
         'Field' + IntToStr (I), 'Size', 0);
      FieldDefs.Add (FieldName,
        FieldType, nSize, False);
      // save offset and compute size
      FFieldOffset.Add (Pointer (TmpFieldOffset));
      case FieldType of
        ftString:
          Inc (TmpFieldOffset, nSize + 1);
        ftBoolean, ftSmallInt, ftWord:
          Inc (TmpFieldOffset, 2);
        ftInteger, ftDate, ftTime:
          Inc (TmpFieldOffset, 4);
        ftFloat, ftCurrency, ftDateTime:
          Inc (TmpFieldOffset, 8);
      else
        raise EDataSetOneError.Create (
           'InitFieldsDefs: Unsupported field type');
      end;
    end; // for
  finally
    IniFile.Free;
  end;
  FRecordSize := TmpFieldOffset;
end;

// I: close the table/file
procedure TDdhDataSetOne.InternalClose;
begin
  // free the internal list field offsets
  if Assigned (FFieldOffset) then
    FFieldOffset.Free;

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

  // close the file
  FIsTableOpen := False;
  FStream.Free;
end;

// I: is table open
function TDdhDataSetOne.IsCursorOpen: Boolean;
begin
  Result := FIsTableOpen;
end;

// I: Create a new table/file
procedure TDdhDataSetOne.CreateTable;
begin
  CheckInactive;
  InternalInitFieldDefs;

  // create the new file
  if FileExists (FTableName) and
    (MessageDlg ('File ' + FTableName +
      ' already exists. OK to override?',
      mtConfirmation, [mbYes, mbNo], 0) = mrNo) then
    Exit;
  FStream := TFileStream.Create (FTableName,
    fmCreate or fmShareExclusive);
  // close the file
  FStream.Free;
end;

////////////////////////////////////////
////// Part II:
////// Bookmarks management and movement
////////////////////////////////////////

// II: set the requested bookmark as current record
procedure TDdhDataSetOne.InternalGotoBookmark (Bookmark: Pointer);
var
  ReqBookmark: Integer;