ddhobjds.pas

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

unit DdhObjDs;

interface

uses
  SysUtils, Classes, Db, DdhDsOne, Controls;

type
  EObjDataSetError = class (EDataSetOneError);

  TDataFileHeader = record
    VersionNumber: Integer;
    RecordSize: Integer;
    RecordCount: Integer;
    ClassName: array [0..50] of Char;
  end;

type
  TDdhObjectDataSet = class(TDdhDataSetOne)
  protected
    // file header
    FDataFileHeader: TDataFileHeader;
    // data set definition class
    FDataClass: TPersistentClass;
  protected
    // TDataSet virtual abstract method
    procedure InternalOpen; override;
    procedure InternalClose; override;
    procedure InternalInitFieldDefs; override;
  public
    constructor Create (AOwner: TComponent); override;
    procedure CreateTable (CompClassType: TComponentClass);
    procedure AddObject (Comp: TComponent);
    function CreateObject (Owner: TComponent;
      Parent: TWinControl): TComponent;
  end;

procedure Register;

implementation

uses
  TypInfo, Dialogs, Windows, Forms;

const
  ClassNameString = 'ClassName';

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

// I: constructor
constructor TDdhObjectDataSet.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  FDataFileHeaderSize := sizeOf (TDataFileHeader);
end;

// I: open the table/file -- slightly modified
procedure TDdhObjectDataSet.InternalOpen;
var
  ClassName: string;
begin
  // check if the file exists
  if not FileExists (FTableName) then
    raise EObjDataSetError.Create ('Table file not found');

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

  // initialize local data (loading header)
  FStream.ReadBuffer (FDataFileHeader, FDataFileHeaderSize);
  if FDataFileHeader.VersionNumber <> 10 then
    raise EObjDataSetError.Create ('File version not 10');
  FRecordCount := FDataFileHeader.RecordCount;
  ClassName := StrPas (FDataFileHeader.ClassName);
  FDataClass := FindClass (ClassName);

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

  // initialize the field definitions
  // (another virtual abtract 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);

  // check the record size (if this is not the first time)
  if (FRecordCount > 0) and
      (FDataFileHeader.RecordSize <> FRecordSize) then
    raise EObjDataSetError.Create (
      'InternalOpen: File record size mismatch');
  // check the number of records against the file size
  if (FDataFileHeaderSize + FRecordCount * FRecordSize)
      <> FStream.Size then
    raise EObjDataSetError.Create (
      'InternalOpen: Invalid Record Size');

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

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

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

// I: define the fields -- totally different
procedure TDdhObjectDataSet.InternalInitFieldDefs;
var
  pti: PTypeInfo;
  ppi: PPropInfo;
  pPropertyList: PPropList;
  nProps, I, TmpFieldOffset: Integer;
  ClassName: string;
begin
  // *** added to support the Fields Editor ***
  // if the stream is unassigned read the data from it...
  if not Assigned (FStream) then
  begin
    // check if the file exists
    if not FileExists (FTableName) then
      raise EObjDataSetError.Create ('Table file not found');

    // create a stream for the file
    FStream := TFileStream.Create (FTableName, fmOpenReadWrite);
    try
      // initialize local data (loading header)
      FStream.ReadBuffer (FDataFileHeader, FDataFileHeaderSize);
      if FDataFileHeader.VersionNumber <> 10 then
        raise EObjDataSetError.Create ('File version not 10');
      ClassName := StrPas (FDataFileHeader.ClassName);
      FDataClass := FindClass (ClassName);
    finally
      FStream.Free;
      FStream := nil;
    end;
  end;

  // field offsets
  FFieldOffset := TList.Create;
  FieldDefs.Clear;
  TmpFieldOffset := 0;

  // add the type name as first field
  FieldDefs.Add (ClassNameString, ftString, 50, False);
  FFieldOffset.Add (Pointer (TmpFieldOffset));
  Inc (TmpFieldOffset, 50);

  // add a field for each property of the supported types
  pti := FDataClass.ClassInfo;
  nProps := GetTypeData(pti).PropCount;
  if nProps > 0 then
  begin
    // allocate the required memory
    GetMem (pPropertyList, sizeof (PPropInfo) * nProps);
    // protect the memory allocation
    try
      GetPropInfos(pti, pPropertyList);
      for I := 0 to nProps - 1 do
      begin
        ppi := pPropertyList [I];
        case ppi.PropType^.Kind of
          tkChar:
          begin
            FieldDefs.Add (ppi.Name,
              ftString, 1, False);
            FFieldOffset.Add (Pointer (TmpFieldOffset));
            Inc (TmpFieldOffset, 1);
          end;
          tkInteger, tkEnumeration, tkSet:
          begin
            if ppi.PropType^.Name = 'Boolean' then
            begin
              FieldDefs.Add (ppi.Name,
                ftBoolean, 0, False);
              FFieldOffset.Add (Pointer (TmpFieldOffset));
              Inc (TmpFieldOffset, 2);
            end
            else
            begin
              FieldDefs.Add (ppi.Name,
                ftInteger, 0, False);
              FFieldOffset.Add (Pointer (TmpFieldOffset));
              Inc (TmpFieldOffset, 4);
            end;
          end;
          tkFloat:
          begin
            FieldDefs.Add (ppi.Name,
              ftFloat, 0, False);
            FFieldOffset.Add (Pointer (TmpFieldOffset));
            Inc (TmpFieldOffset, 8);
          end;
          tkString, tkLString:
          begin
            FieldDefs.Add (ppi.Name,
              ftString, 50, False);
            FFieldOffset.Add (Pointer (TmpFieldOffset));
            Inc (TmpFieldOffset, 50);
          end;
          // types ignored (not saved)
          {tkClass, tkVariant, tkArray, tkRecord,
          tkInterface, tkUnknown, tkWChar, tkMethod}
        end; // case
      end; //for
    finally
      // free the allocated memory
      FreeMem (pPropertyList, sizeof (PPropInfo) * nProps);
    end;
    FRecordSize := TmpFieldOffset;
  end;
end;

// I: close the table/file -- modified
procedure TDdhObjectDataSet.InternalClose;
begin
  // if required, save updated header
  if (FDataFileHeader.RecordCount <> FRecordCount) or
      (FDataFileHeader.RecordSize = 0) then
  begin
    FDataFileHeader.RecordSize := FRecordSize;
    FDataFileHeader.RecordCount := FRecordCount;
    if Assigned (FStream) then
    begin
      FStream.Seek (0, soFromBeginning);
      FStream.WriteBuffer (
        FDataFileHeader, FDataFileHeaderSize);
    end;
  end;

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

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

// I: Create a new table/file -- modified
procedure TDdhObjectDataSet.CreateTable (
  CompClassType: TComponentClass);
begin
  CheckInactive;
  FDataClass := CompClassType;
  InternalInitFieldDefs;
  begin
    // 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);
    try
      // save the header
      FDataFileHeader.VersionNumber := 10;
      FDataFileHeader.RecordSize := 0; // used later
      FDataFileHeader.RecordCount := 0; // empty
      StrPCopy (FDataFileHeader.ClassName,
        FDataClass.ClassName);
      FStream.WriteBuffer (
        FDataFileHeader, FDataFileHeaderSize);
    finally
      // close the file
      FStream.Free;
    end;
  end;
end;

////// Object support

procedure TDdhObjectDataSet.AddObject (Comp: TComponent);
var
  PropInfo: PPropInfo;
  I: Integer;
begin
  // add a new record to the table
  Insert;
  // check the class type
  if not Comp.InheritsFrom (FDataClass) then
    raise EObjDataSetError.Create (
      'AddObject: Invalid class type');
  // add the data to each field
  for I := 0 to FieldCount - 1 do
  begin
    if Fields[I].FieldName = ClassNameString then
      Fields[I].AsString := Comp.ClassName
    else
    begin
      PropInfo := GetPropInfo (Comp.ClassInfo,
        Fields[I].FieldName);
      if PropInfo = nil then
        raise EObjDataSetError.Create (
          'AddObject: Invalid Property');
      case PropInfo.PropType^.Kind of
        tkChar, tkInteger, tkEnumeration, tkSet:
          if Fields[I] is TBooleanField then
            Fields[I].AsBoolean := Boolean (GetOrdProp (Comp, PropInfo))
          else
            Fields[I].AsInteger := GetOrdProp (Comp, PropInfo);
        tkFloat:
          Fields[I].AsFloat := GetFloatProp (Comp, PropInfo);
        tkString, tkLString:
          Fields[I].AsString := GetStrProp (Comp, PropInfo);
        // types ignored (not saved)
        {tkClass, tkVariant, tkArray, tkRecord,
        tkInterface, tkUnknown, tkWChar, tkMethod}
      end; // case
    end; // if
  end; // for
  // post the data
  Post;
end;

function TDdhObjectDataSet.CreateObject (Owner: TComponent;
  Parent: TWinControl): TComponent;
var
  PropInfo: PPropInfo;
  I: Integer;
  ClassType: TComponentClass;
  Comp: TComponent;
begin
  // create the component and set its parent
  ClassType := TComponentClass (FindClass (
    FieldByName (ClassNameString).AsString));
  if not ClassType.InheritsFrom (FDataClass) then
    raise EObjDataSetError.Create (
      'CreateObject: Invalid class type');
  Comp := ClassType.Create (Owner);
  try
    if Comp is TControl then
      TControl (Comp).Parent := Parent;
    // retrieve the values of the fields
    for I := 0 to FieldCount - 1 do
    begin
      if Fields[I].FieldName <> ClassNameString then
      begin
        PropInfo := GetPropInfo (Comp.ClassInfo,
          Fields[I].FieldName);
        if PropInfo = nil then
          raise EObjDataSetError.Create (
            'AddObject: Invalid Property');
        case PropInfo.PropType^.Kind of
          tkChar, tkInteger, tkEnumeration, tkSet:
            if Fields[I] is TBooleanField then
              SetOrdProp (Comp, PropInfo, Integer (Fields[I].AsBoolean))
            else
              SetOrdProp (Comp, PropInfo, Fields[I].AsInteger);
          tkFloat:
            SetFloatProp (Comp, PropInfo, Fields[I].AsFloat);
          tkString, tkLString:
            SetStrProp (Comp, PropInfo, Fields[I].AsString);
          // types ignored (not saved)
          {tkClass, tkVariant, tkArray, tkRecord,
          tkInterface, tkUnknown, tkWChar, tkMethod}
        end; // case
      end; // if
    end; // for
    Result := Comp;
  except
    Comp.Free;
    raise;
  end;
end;

procedure Register;
begin
  RegisterComponents('DDHB DB', [TDdhObjectDataSet]);
end;

end.