fastdbvar.pas

俄国人写的内存数据库的delphi封装

{-< FastDbVar.pas >------------------------------------------------*
  FastDbSession Version 1.0
    (c) 2002 Serge Aleynikov ([e-mail])
  Main Memory Database Management System
  Created:     11/11/2002 Serge Aleynikov ([e-mail])
  Last update:
    9/12/2003  Fixed a problem with TFastDbField.Assign() missing
               indexes.
    5/11/2003  Fixed a problem with GetArrayAsSingle/Double fetching
               wrong data from array and occasuonally causing index
               out of bounds error.
    5/09/2003  Fixed a compilation issue on Linux/Kylix3
               It turns out that Kylix3 doesn't like Pointer of Object
               declarations. 
    5/8/2003   Added TFieldBufferItem.FetchData property to control
               conditional fetching of Array/inverseRef fields
               during selects.
               Added TFieldBufferItem.Capacity property to be able
               to reserve a large pool of memory for speeding up
               inverse reference array copying without requiring
               to reallocate memory.
    4/2/2003   Fixed an AV bug in
               Fields[4].asArraySingle[]
               Fields[4].asArrayInteger[]
    12/06/2002 Fixed the field type conversion in BindToStatement()
               which caused the error in working with ctDateTime
               field type.
-------------------------------------------------------------------*
  Field structures for column/parameter binding
-------------------------------------------------------------------*}
unit FastDbVar;

{$I FastDbConfig.inc}

interface
uses
  FastDbCLI,
  TypInfo,
  Classes,
  {$IFDEF LINUX}
  Libc,
  {$ENDIF}
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF}
  SysUtils;

const
  FastDbUnilitializedHandle = -1;  // Value assigned to session/statement/field handles

  DATE_FORMAT_STRING        = 'mm/dd/yyyy hh:nn:ss';
  {$IFDEF MSWINDOWS}
  EOL   = #10;
  {$ELSE}
  EOL   = #13#10;
  {$ENDIF}

type
{$Align Off}
  TProcedureOfObjectThunk = record
    PopEAX:    Byte;
    PushImm:   Byte; InstPtr: Pointer;
    PushEAX:   Byte;
    MovEAXImm: Byte; ProcPtr: Pointer;
    JmpEAX:    Word;
  end;
{$Align On}

  TFieldBufferItem    = class;
  TArrayFieldSetValue = function(Sender: TFieldBufferItem;
                                 DestinationPtr: Pointer;
                                 const SourcePtr: Pointer;
                                 Len: Integer;
                                 const Statement: Integer
                                //): Pointer of Object;  // Note: for some reason Kylix3 compliler crashes when it sees declaration of Pointer of Object
                                ): Integer of Object;
  TArrayFieldGetValue = function(Sender: TFieldBufferItem;
                                 DestinationPtr: Pointer;
                                 var Len: Integer;
                                 const Statement: Integer
                                //): Pointer of Object;  // Note: for some reason Kylix3 compliler crashes when it sees declaration of Pointer of Object
                                ): Integer of Object;

  TFieldBufferItem=class(TCollectionItem)
  private
    FPData           : Pointer;
    FData            : array of Char;
    FDataSize        : Integer;
    FCapacity        : Integer;
    FName            : string;
    FFieldType       : TCliVarType;
    FBoundToStatement: Integer;
    FDateFormat      : string;
    FFetchData       : Boolean;
    FOnArraySetValue : TArrayFieldSetValue;
    FOnArrayGetValue : TArrayFieldGetValue;

    function  GetFieldTypeName: string;
    function  GetFieldSize: Integer;
    procedure SetFieldSize(const Value: Integer);

    function  GetAsPointer: Pointer;
    function  GetAsBoolean: Boolean;
    function  GetAsInteger(const Index: Integer): Integer;
    function  GetAsInt64: TCliInt8;
    function  GetAsSingle: Single;
    function  GetAsDouble(const Index: Integer): Double;
    function  GetAsString: string;

    procedure SetAsBoolean(const Value: Boolean);
    procedure SetAsInteger(const Index, Value: Integer);
    procedure SetAsSingle(const Value: Single);
    procedure SetAsDouble(const Index: Integer; const Value: Double);
    procedure SetAsString(const Value: string); virtual;
    procedure SetAsInt64(const Value: TCliInt8);

    procedure SetFieldType(Value: TCliVarType); virtual;
    procedure SetCapacity(const Value: Integer);
  protected
    procedure SetBufferTypeAndSize(const NewType: TCliVarType; const NewSize: Integer=0; const CopyExact: Boolean=False);
    function  GetDisplayName: string; override;
    property  OnArraySetValue: TArrayFieldSetValue read FOnArraySetValue write FOnArraySetValue;
    property  OnArrayGetValue: TArrayFieldGetValue read FOnArrayGetValue write FOnArrayGetValue;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure  Assign(Source: TPersistent); override;
    procedure  ReadFromStream(Stream: TStream); overload; virtual;
    procedure  ReadFromStream(Stream: TStream; const AJustData: Boolean); overload; virtual;
    procedure  WriteToStream(Stream: TStream); overload; virtual;
    procedure  WriteToStream(Stream: TStream; const AJustData: Boolean); overload; virtual;

    procedure FreeBuffer;
    property  FieldSize: Integer              read GetFieldSize;
    property  FieldTypeName: string           read GetFieldTypeName;
    procedure SetValue(const AValue: Pointer; const Size: Integer; const CopyExact: Boolean=False);
    procedure ClearValue;
    function  BindToStatement(const AStatement: Integer): Boolean; virtual;
    procedure UnBindFromStatement;
    procedure CopyTypeAndValue(FromField: TFieldBufferItem);

    property asByte:    Integer  index 1 read GetAsInteger write SetAsInteger;
    property asOID:     Integer  index 2 read GetAsInteger write SetAsInteger;
    property asInteger: Integer  index 3 read GetAsInteger write SetAsInteger;
    property asInt8:    TCliInt8         read GetAsInt64   write SetAsInt64;
    property asString:  string           read GetAsString  write SetAsString;
    property asSingle:  Single           read GetAsSingle  write SetAsSingle;
    property asDouble:  Double   index 1 read GetAsDouble  write SetAsDouble;
    property asDateTime:Double   index 2 read GetAsDouble  write SetAsDouble;
    property asPointer: Pointer          read GetAsPointer;
    property asBoolean: Boolean          read GetAsBoolean write SetAsBoolean;
  published
    property FieldType: TCliVarType  read FFieldType  write SetFieldType;
    property Name: string            read FName       write FName;
    property DateFormat: string      read FDateFormat write FDateFormat;
    property Capacity:  Integer      read FCapacity   write SetCapacity;
    property FetchData: Boolean      read FFetchData  write FFetchData;
  end;

  TFastDbField=class(TFieldBufferItem)
  private
    FRefTable       : string;
    FInverseRefField: string;
    FIndexType     : TIndexTypes;

    procedure SetFieldFlags(const Value: Integer);
    function  GetFieldFlags: Integer;
    function  GetArraySize: Integer;
    procedure SetArraySize(const Value: Integer);

    function  GetArrayAsBoolean(Idx: Integer): Boolean;
    function  GetArrayAsInteger(Idx: Integer; Index: Integer): Integer;
    function  GetArrayAsInt64(Idx: Integer): TCliInt8;
    function  GetArrayAsSingle(Idx: Integer): Single;
    function  GetArrayAsDouble(Idx: Integer; Index: Integer): Double;
    function  GetArrayAsString(Idx: Integer): string;

    procedure SetArrayAsBoolean(Idx: Integer; const Value: Boolean);
    procedure SetArrayAsInteger(Idx: Integer; Index: Integer; const Value: Integer);
    procedure SetArrayAsInt64(Idx: Integer; const Value: TCliInt8);
    procedure SetArrayAsSingle(Idx: Integer; const Value: Single);
    procedure SetArrayAsDouble(Idx: Integer; Index: Integer; const Value: Double);
    procedure SetArrayAsString(Idx: Integer; const Value: string);
  public
    function BindToStatement(const AStatement: Integer): Boolean; override;
    property FieldFlags: Integer read GetFieldFlags write SetFieldFlags;
    property ArraySize: Integer  read GetArraySize  write SetArraySize;
    procedure Assign(Source: TPersistent); override;

    property asArrayByte[Idx: Integer]:    Integer  index 1 read GetArrayAsInteger write SetArrayAsInteger;
    property asArrayOID[Idx: Integer]:     Integer  index 2 read GetArrayAsInteger write SetArrayAsInteger;
    property asArrayInteger[Idx: Integer]: Integer  index 3 read GetArrayAsInteger write SetArrayAsInteger;
    property asArrayInt8[Idx: Integer]:    TCliInt8         read GetArrayAsInt64   write SetArrayAsInt64;
    property asArrayString[Idx: Integer]:  string           read GetArrayAsString  write SetArrayAsString;
    property asArraySingle[Idx: Integer]:  Single           read GetArrayAsSingle  write SetArrayAsSingle;
    property asArrayDouble[Idx: Integer]:  Double   index 1 read GetArrayAsDouble  write SetArrayAsDouble;
    property asArrayDateTime[Idx: Integer]:Double   index 2 read GetArrayAsDouble  write SetArrayAsDouble;
    property asArrayBoolean[Idx: Integer]: Boolean          read GetArrayAsBoolean write SetArrayAsBoolean;
  published
    property IndexType: TIndexTypes  read FIndexType       write FIndexType;
    property RefTable: string        read FRefTable        write FRefTable;
    property InverseRefField: string read FInverseRefField write FInverseRefField;
    property OnArraySetValue;
    property OnArrayGetValue;
  end;

  TFastDbVariable=class(TFieldBufferItem)
  private
    procedure SetAsString(const Value: string); override;
  public
    // OnSubstitutedValueChange is for internal use to notify a Query component that
    // SQL changed.
    function GetSubstitudeValue: string;
    function DisplayString(AQuery: TObject): string;
    function BindToStatement(const AStatement: Integer): Boolean; override;
  end;

  TFieldBufferCollection = class(TOwnedCollection)
  protected
    function Add(const AName: string; AType: TCliVarType): TFieldBufferItem;
  public
    procedure Delete(const AName: string);
    procedure UnBindFromStatement;
    function  asText: string;
    procedure ClearValues;
    procedure ReadFromStream(Stream: TStream); virtual;
    procedure WriteToStream(Stream: TStream); virtual;
  end;

  TFastDbFields = class(TFieldBufferCollection)
  private
    function  GetField(Index: Integer): TFastDbField;
    procedure SetField(Index: Integer; const Value: TFastDbField);
  public
    constructor Create(AOwner: TComponent);
    function Add(const AName: string;
                 const AType: TCliVarType;
                 const AIndexType: TIndexTypes=[];
                 const ARefTable: string='';
                 const AInverseRefField: string=''): TFastDbField;
    property Fields[Index: Integer]: TFastDbField read GetField write SetField; default;
  end;

  TFastDbVariables = class(TFieldBufferCollection)
  private
    function  GetVariable(Index: Integer): TFastDbVariable;
    procedure SetVariable(Index: Integer; const Value: TFastDbVariable);
  public
    constructor Create(AOwner: TComponent);
    function Add(const AName: string; const AType: TCliVarType; AValue: Pointer=nil): TFastDbVariable;
    property Variables[Index: Integer]: TFastDbVariable read GetVariable write SetVariable; default;
  end;

  function CreateProcedureOfObjectThunk (Instance, Proc: Pointer): TProcedureOfObjectThunk;
  function CliTypeToOrd(const CliType: TCliVarType): Integer;
  function OrdToCliType(const CliOrdType: Integer): TCliVarType;
  function CliVarTypeAsStr(const CliType: TCliVarType; const ExtendedSyntax: Boolean=False): string;
  function FieldFlagsToIndexTypes(const FieldFlags: Integer): TIndexTypes;
  function IndexTypesToFieldFlags(const IndexTypes: TIndexTypes): Integer;
  function FastDbFieldToFieldDescriptor(Field: TFastDbField): TCliFieldDescriptor;

  function IsArrayType(const CliType: TCliVarType): Boolean;
  function iif(b: Boolean; true, false: string): string;

implementation
  uses FastDbSession, FastDbQuery;

  //function GetValueAsStr(const CliType: TCliVarType; Value: Pointer): string;

//---------------------------------------------------------------------------
function iif(b: Boolean; true, false: string): string;
begin
  if b then Result := true else Result := false;
end;

//---------------------------------------------------------------------------
function CreateProcedureOfObjectThunk (Instance, Proc: Pointer): TProcedureOfObjectThunk;
begin
  with result do begin
    PopEAX    := $58;                      { Pop EAX }
    PushImm   := $68;  InstPtr:= Instance; { Push Instance }
    PushEAX   := $50;                      { Push EAX }
    MovEAXImm := $B8;  ProcPtr:= Proc;     { Mov EAX, Proc }
    JmpEAX    := $E0FF;                    { Jmp EAX }
  end
end;

//---------------------------------------------------------------------------
function CliVarTypeAsStr(const CliType: TCliVarType; const ExtendedSyntax: Boolean=False): string;
var
  ct : TCliVarType;
begin
  Result := '';
  ct := CliType;
  if ExtendedSyntax and (CliType in [ctArrayOfOID..ctArrayOfString]) then
    begin
      Result := 'array of ';
      ct := TCliVarType(Ord(ct) - Ord(ctArrayOfOID));
    end;

  case ct of
    ctOID          : Result := Result + iif(ExtendedSyntax, 'reference', '(oid)');
    ctBOOL         : Result := Result + iif(ExtendedSyntax, 'int1', 'Boolean');
    ctInt1         : Result := Result + iif(ExtendedSyntax, 'int1', 'Byte');
    ctInt2         : Result := Result + iif(ExtendedSyntax, 'int2', 'SmallInt');
    ctAutoInc,
    ctInt4         : Result := Result + iif(ExtendedSyntax, 'int4', 'Integer');
    ctInt8         : Result := Result + iif(ExtendedSyntax, 'int8', 'Int64');
    ctReal4        : Result := Result + iif(ExtendedSyntax, 'real4', 'Single');
    ctDateTime     : Result := Result + iif(ExtendedSyntax, 'real8', 'DateTime');
    ctReal8        : Result := Result + iif(ExtendedSyntax, 'real8', 'Double');
    ctString       ,
    ctPString      : Result := Result + iif(ExtendedSyntax, 'string', 'String');
  else
    if not ExtendedSyntax then
      begin
        Result := GetEnumName(TypeInfo(TCliVarType), Ord(ct));
        Delete(Result, 1, 2);
      end;
  end;
end;

//---------------------------------------------------------------------------
function IsArrayType(const CliType: TCliVarType): Boolean;
begin
  Result := not (CliType in [ctOID..ctPString, ctDateTime, ctSubst]);
end;

//---------------------------------------------------------------------------
function CliTypeToOrd(const CliType: TCliVarType): Integer;
begin
  case CliType of
    ctDateTime : Result := Ord(ctReal8);
    ctString   : Result := Ord(ctPString);
  else
    Result := Ord(CliType);
  end;
end;

//---------------------------------------------------------------------------
function OrdToCliType(const CliOrdType: Integer): TCliVarType;
begin
  case CliOrdType of