dbtables.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

  TDatabaseLoginEvent = procedure(Database: TDatabase;
    LoginParams: TStrings) of object;

  TDatabase = class(TCustomConnection)
  private
    FTransIsolation: TTransIsolation;
    FKeepConnection: Boolean;
    FTemporary: Boolean;
    FSessionAlias: Boolean;
    FLocaleLoaded: Boolean;
    FAliased: Boolean;
    FSQLBased: Boolean;
    FAcquiredHandle: Boolean;
    FPseudoIndexes: Boolean;
    FHandleShared: Boolean;
    FExclusive: Boolean;
    FReadOnly: Boolean;
    FRefCount: Integer;
    FHandle: HDBIDB;
    FLocale: TLocale;
    FSession: TSession;
    FParams: TStrings;
    FStmtList: TList;
    FSessionName: string;
    FDatabaseName: string;
    FDatabaseType: string;
    FOnLogin: TDatabaseLoginEvent;
    procedure CheckActive;
    procedure CheckInactive;
    procedure CheckDatabaseName;
    procedure CheckDatabaseAlias(var Password: string);
    procedure CheckSessionName(Required: Boolean);
    procedure ClearStatements;
    procedure EndTransaction(TransEnd: EXEnd);
    function GetAliasName: string;
    function GetDirectory: string;
    function GetDriverName: string;
    function GetInTransaction: Boolean;
{$HPPEMIT '#ifdef GetObjectContext'}
{$HPPEMIT '#undef GetObjectContext'}
{$HPPEMIT '#endif'}
    function GetObjectContext: IUnknown;
    function GetTraceFlags: TTraceFlags;
    procedure LoadLocale;
    procedure Login(LoginParams: TStrings);
    function OpenFromExistingDB: Boolean;
    procedure ParamsChanging(Sender: TObject);
    procedure SetAliasName(const Value: string);
    procedure SetDatabaseFlags;
    procedure SetDatabaseName(const Value: string);
    procedure SetDatabaseType(const Value: string; Aliased: Boolean);
    procedure SetDirectory(const Value: string);
    procedure SetDriverName(const Value: string);
    procedure SetExclusive(Value: Boolean);
    procedure SetHandle(Value: HDBIDB);
    procedure SetKeepConnection(Value: Boolean);
    procedure SetParams(Value: TStrings);
    procedure SetReadOnly(Value: Boolean);
    procedure SetTraceFlags(Value: TTraceFlags);
    procedure SetSessionName(const Value: string);
  protected
    procedure DoConnect; override;
    procedure DoDisconnect; override;
    function GetConnected: Boolean; override;
    function GetDataSet(Index: Integer): TDBDataSet; reintroduce;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ApplyUpdates(const DataSets: array of TDBDataSet);
    procedure CloseDataSets;
    procedure Commit; 
    function Execute(const SQL: string; Params: TParams = nil;
      Cache: Boolean = False; Cursor: phDBICur = nil): Integer;
    procedure FlushSchemaCache(const TableName: string);
    procedure GetFieldNames(const TableName: string; List: TStrings);
    procedure GetTableNames(List: TStrings; SystemTables: Boolean = False);
    procedure Rollback; 
    procedure StartTransaction;
    procedure ValidateName(const Name: string);
    property DataSets[Index: Integer]: TDBDataSet read GetDataSet;
    property Directory: string read GetDirectory write SetDirectory;
    property Handle: HDBIDB read FHandle write SetHandle;
    property IsSQLBased: Boolean read FSQLBased;
    property InTransaction: Boolean read GetInTransaction;
    property Locale: TLocale read FLocale;
    property Session: TSession read FSession;
    property Temporary: Boolean read FTemporary write FTemporary;
    property SessionAlias: Boolean read FSessionAlias;
    property TraceFlags: TTraceFlags read GetTraceFlags write SetTraceFlags;
  published
    property AliasName: string read GetAliasName write SetAliasName;
    property Connected;
    property DatabaseName: string read FDatabaseName write SetDatabaseName;
    property DriverName: string read GetDriverName write SetDriverName;
    property Exclusive: Boolean read FExclusive write SetExclusive default False;
    property HandleShared: Boolean read FHandleShared write FHandleShared default False;
    property KeepConnection: Boolean read FKeepConnection write SetKeepConnection default True;
    property LoginPrompt default True;
    property Params: TStrings read FParams write SetParams;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
    property SessionName: string read FSessionName write SetSessionName;
    property TransIsolation: TTransIsolation read FTransIsolation write FTransIsolation default tiReadCommitted;
    property AfterConnect;
    property AfterDisconnect;
    property BeforeConnect;
    property BeforeDisconnect;
    property OnLogin: TDatabaseLoginEvent read FOnLogin write FOnLogin;
  end;

{ TBDEDataSet }

  TRecNoStatus = (rnDbase, rnParadox, rnNotSupported);
  
  TDataSetUpdateObject = class(TComponent)
  protected
    function GetDataSet: TDataSet; virtual; abstract;
    procedure SetDataSet(ADataSet: TDataSet); virtual; abstract;
    procedure Apply(UpdateKind: TUpdateKind); virtual; abstract;
    property DataSet: TDataSet read GetDataSet write SetDataSet;
  end;

  TSQLUpdateObject = class(TDataSetUpdateObject)
  protected
     function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; abstract;
  end;

  TKeyIndex = (kiLookup, kiRangeStart, kiRangeEnd, kiCurRangeStart,
    kiCurRangeEnd, kiSave);

  PKeyBuffer = ^TKeyBuffer;
  TKeyBuffer = packed record
    Modified: Boolean;
    Exclusive: Boolean;
    FieldCount: Integer;
  end;

  PRecInfo = ^TRecInfo;
  TRecInfo = packed record
    RecordNumber: Longint;
    UpdateStatus: TUpdateStatus;
    BookmarkFlag: TBookmarkFlag;
  end;

  TBlobDataArray = array of TBlobData;

  TBDEDataSet = class(TDataSet)
  private
    FHandle: HDBICur;
    FStmtHandle: HDBIStmt;
    FRecProps: RecProps;
    FLocale: TLocale;
    FExprFilter: HDBIFilter;
    FFuncFilter: HDBIFilter;
    FFilterBuffer: PChar;
    FIndexFieldMap: DBIKey;
    FExpIndex: Boolean;
    FCaseInsIndex: Boolean;
    FCachedUpdates: Boolean;
    FInUpdateCallback: Boolean;
    FCanModify: Boolean;
    FCacheBlobs: Boolean;
    FKeySize: Word;
    FUpdateCBBuf: PDELAYUPDCbDesc;
    FUpdateCallback: TBDECallback;
    FKeyBuffers: array[TKeyIndex] of PKeyBuffer;
    FKeyBuffer: PKeyBuffer;
    FRecNoStatus: TRecNoStatus;
    FIndexFieldCount: Integer;
    FConstDisableCount: Integer;
    FRecordSize: Word;
    FBookmarkOfs: Word;
    FRecInfoOfs: Word;
    FBlobCacheOfs: Word;
    FRecBufSize: Word;
    FConstraintLayer: Boolean;
    FBlockBufSize: Integer;
    FBlockBufOfs: Integer;
    FBlockBufCount: Integer;
    FBlockReadCount: Integer;
    FLastParentPos: Integer;
    FBlockReadBuf: PChar;
    FParentDataSet: TBDEDataSet;
    FUpdateObject: TDataSetUpdateObject;
    FOnUpdateError: TUpdateErrorEvent;
    FOnUpdateRecord: TUpdateRecordEvent;
    procedure ClearBlobCache(Buffer: PChar);
    function GetActiveRecBuf(var RecBuf: PChar): Boolean;
    function GetBlobData(Field: TField; Buffer: PChar): TBlobData;
    function GetOldRecord: PChar;
    procedure InitBufferPointers(GetProps: Boolean);
    function RecordFilter(RecBuf: Pointer; RecNo: Integer): Smallint; stdcall;
    procedure SetBlobData(Field: TField; Buffer: PChar; Value: TBlobData);
    function HasConstraints: Boolean;
  protected
    { IProviderSupport }
    function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override;
    function PSIsSQLSupported: Boolean; override;
    procedure PSReset; override;
    function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
  protected
    procedure ActivateFilters;
    procedure AddFieldDesc(FieldDescs: TFieldDescList; var DescNo: Integer;
      var FieldID: Integer; RequiredFields: TBits; FieldDefs: TFieldDefs);
    procedure AllocCachedUpdateBuffers(Allocate: Boolean);
    procedure AllocKeyBuffers;
    function AllocRecordBuffer: PChar; override;
    function CachedUpdateCallBack(CBInfo: Pointer): CBRType;
    procedure CheckCachedUpdateMode;
    procedure CheckSetKeyMode;
    procedure ClearCalcFields(Buffer: PChar); override;
    procedure CloseCursor; override;
    procedure CloseBlob(Field: TField); override;
    function CreateExprFilter(const Expr: string;
      Options: TFilterOptions; Priority: Integer): HDBIFilter;
    function CreateFuncFilter(FilterFunc: Pointer;
      Priority: Integer): HDBIFilter;
    function CreateHandle: HDBICur; virtual;
    function CreateLookupFilter(Fields: TList; const Values: Variant;
      Options: TLocateOptions; Priority: Integer): HDBIFilter;
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    procedure DeactivateFilters;
    procedure DestroyHandle; virtual;
    procedure DestroyLookupCursor; virtual;
    function FindRecord(Restart, GoForward: Boolean): Boolean; override;
    function ForceUpdateCallback: Boolean;
    procedure FreeKeyBuffers;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    function GetCanModify: Boolean; override;
    function GetFieldFullName(Field: TField): string; override;
    function GetHandle: HDBICur;
    function GetIndexField(Index: Integer): TField;
    function GetIndexFieldCount: Integer;
    function GetIsIndexField(Field: TField): Boolean; override;
    function GetKeyBuffer(KeyIndex: TKeyIndex): PKeyBuffer;
    function GetKeyExclusive: Boolean;
    function GetKeyFieldCount: Integer;
    function GetLookupCursor(const KeyFields: string;
      CaseInsensitive: Boolean): HDBICur; virtual;
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
    function GetRecordCount: Integer; override;
    function GetRecNo: Integer; override;
    function GetRecordSize: Word; override;
    function GetStateFieldValue(State: TDataSetState; Field: TField): Variant; override;
    procedure GetObjectTypeNames(Fields: TFields);
    function GetUpdatesPending: Boolean;
    function GetUpdateRecordSet: TUpdateRecordTypes;
    function InitKeyBuffer(Buffer: PKeyBuffer): PKeyBuffer;
    procedure InitRecord(Buffer: PChar); override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalCancel; override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalEdit; override;
    procedure InternalFirst; override;
    procedure InternalGotoBookmark(Bookmark: TBookmark); override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalInsert; override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalRefresh; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    function IsCursorOpen: Boolean; override;
    function LocateRecord(const KeyFields: string; const KeyValues: Variant;
      Options: TLocateOptions; SyncCursor: Boolean): Boolean;
    function MapsToIndex(Fields: TList; CaseInsensitive: Boolean): Boolean;
    procedure OpenCursor(InfoQuery: Boolean); override;
    procedure PostKeyBuffer(Commit: Boolean);
    procedure PrepareCursor; virtual;
    function ProcessUpdates(UpdCmd: DBIDelayedUpdCmd): DBIResult;
    function ResetCursorRange: Boolean;
    procedure BlockReadNext; override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetCachedUpdates(Value: Boolean);
    function SetCursorRange: Boolean;
    procedure SetBlockReadSize(Value: Integer); override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    procedure SetFilterData(const Text: string; Options: TFilterOptions);
    procedure SetFilterHandle(var Filter: HDBIFilter; Value: HDBIFilter);
    procedure SetFiltered(Value: Boolean); override;
    procedure SetFilterOptions(Value: TFilterOptions); override;
    procedure SetFilterText(const Value: string); override;
    procedure SetIndexField(Index: Integer; Value: TField);
    procedure SetKeyBuffer(KeyIndex: TKeyIndex; Clear: Boolean);
    procedure SetKeyExclusive(Value: Boolean);
    procedure SetKeyFieldCount(Value: Integer);
    procedure SetKeyFields(KeyIndex: TKeyIndex; const Values: array of const);
    procedure SetLinkRanges(MasterFields: TList);
    procedure SetLocale(Value: TLocale);
    procedure SetStateFieldValue(State: TDataSetState; Field: TField; const Value: Variant); override;
    procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override;
    procedure SetOnUpdateError(UpdateEvent: TUpdateErrorEvent);
    procedure SetRecNo(Value: Integer); override;
    procedure SetupCallBack(Value: Boolean);
    procedure SetUpdateRecordSet(RecordTypes: TUpdateRecordTypes);
    procedure SetUpdateObject(Value: TDataSetUpdateObject);
    procedure SwitchToIndex(const IndexName, TagName: string);
    function UpdateCallbackRequired: Boolean;
    property StmtHandle: HDBIStmt read FStmtHandle write FStmtHandle;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ApplyUpdates;
    function BookmarkValid(Bookmark: TBookmark): Boolean; override;
    procedure Cancel; override;
    procedure CancelUpdates;
    property CacheBlobs: Boolean read FCacheBlobs write FCacheBlobs default True;
    function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
    procedure CommitUpdates;
    function ConstraintCallBack(Req: DsInfoReq; var ADataSources: DataSources): DBIResult; stdcall;
    function ConstraintsDisabled: Boolean;
    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
    procedure DisableConstraints;
    procedure EnableConstraints;
    procedure FetchAll;
    procedure FlushBuffers;
    function GetCurrentRecord(Buffer: PChar): Boolean; override;
    function GetBlobFieldData(FieldNo: Integer; var Buffer: TBlobByteData): Integer; override;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; overload; override;
    function GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean; overload; override;
    procedure GetIndexInfo;
    function Locate(const KeyFields: string; const KeyValues: Variant;
      Options: TLocateOptions): Boolean; override;
    function Lookup(const KeyFields: string; const KeyValues: Variant;
      const ResultFields: string): Variant; override;
    function IsSequenced: Boolean; override;
    procedure Post; override;
    procedure RevertRecord;
    function UpdateStatus: TUpdateStatus; override;
    function Translate(Src, Dest: PChar; ToOem: Boolean): Integer;  override;
    property ExpIndex: Boolean read FExpIndex;
    property Handle: HDBICur read FHandle;
    property KeySize: Word read FKeySize;
    property Locale: TLocale read FLocale;
    property UpdateObject: TDataSetUpdateObject read FUpdateObject write SetUpdateObject;
    property UpdatesPending: Boolean read GetUpdatesPending;
    property UpdateRecordTypes: TUpdateRecordTypes read GetUpdateRecordSet write SetUpdateRecordSet;
  published
    property Active;
    property AutoCalcFields;
    property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates default False;
    property ObjectView default False;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;