dbtables.pas

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

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{       BDE Data Access                                 }
{                                                       }
{       Copyright (c) 1995,99 Inprise Corporation       }
{                                                       }
{*******************************************************}

unit DBTables;

{$R-,T-,H+,X+}

interface

uses Variants, Windows, SysUtils, Classes, DB, DBCommon, BDE, SMINTF;

const

{$HPPEMIT ''}
{$HPPEMIT '/* automatically link to dblogdlg.obj so that the login dialog is automatically shown */'}
{$HPPEMIT '#pragma link "dblogdlg.obj"'}
{$HPPEMIT '/* automatically link to dbrtl and vcldb as well */'}
{$HPPEMIT '#ifdef USEPACKAGES'}
{$HPPEMIT '#pragma link "dbrtl.bpi"'}
{$HPPEMIT '#pragma link "vcldb.bpi"'}
{$HPPEMIT '#else'}
{$HPPEMIT '#pragma link "dbrtl.lib"'}
{$HPPEMIT '#pragma link "vcldb.lib"'}
{$HPPEMIT '#endif'}
{$HPPEMIT ''}

{ SQL Trace buffer size }

  smTraceBufSize = 32767 + SizeOf(TraceDesc);

{ TDBDataSet flags }

  dbfOpened     = 0;
  dbfPrepared   = 1;
  dbfExecSQL    = 2;
  dbfTable      = 3;
  dbfFieldList  = 4;
  dbfIndexList  = 5;
  dbfStoredProc = 6;
  dbfExecProc   = 7;
  dbfProcDesc   = 8;
  dbfDatabase   = 9;
  dbfProvider   = 10;

{ FieldType Mappings }

const
  FldTypeMap: TFieldMap = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
    fldBLOB, fldBLOB, fldCURSOR, fldZSTRING, fldZSTRING, fldINT64, fldADT,
    fldArray, fldREF, fldTABLE, fldBLOB, fldBLOB, fldUNKNOWN, fldUNKNOWN,
    fldUNKNOWN, fldZSTRING, fldDATETIME,fldBCD);

  FldSubTypeMap: array[TFieldType] of Word = (
    0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstAUTOINC,
    fldstBINARY, fldstMEMO, fldstGRAPHIC, fldstFMTMEMO, fldstOLEOBJ,
    fldstDBSOLEOBJ, fldstTYPEDBINARY, 0, fldstFIXED, fldstUNICODE,
    0, 0, 0, 0, 0, fldstHBINARY, fldstHMEMO, 0, 0, 0, 0, 0, 0);

  DataTypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
    ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
    ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
    ftWord, ftInteger, ftUnknown, ftVarBytes, ftUnknown, ftUnknown,
    ftLargeInt, ftLargeInt, ftADT, ftArray, ftReference, ftDataSet, 
    ftTimeStamp);

  BlobTypeMap: array[fldstMEMO..fldstBFILE] of TFieldType = (
    ftMemo, ftBlob, ftFmtMemo, ftParadoxOle, ftGraphic, ftDBaseOle,
    ftTypedBinary, ftBlob, ftBlob, ftBlob, ftBlob, ftOraClob, ftOraBlob,
    ftBlob, ftBlob);

type

{ Forward declarations }

  TDBError = class;
  TSession = class;
  TDatabase = class;
  TBDEDataSet = class;
  TDBDataSet = class;
  TTable = class;

{ Exception classes }

  EDBEngineError = class(EDatabaseError)
  private
    FErrors: TList;
    function GetError(Index: Integer): TDBError;
    function GetErrorCount: Integer;
  public
    constructor Create(ErrorCode: DBIResult);
    destructor Destroy; override;
    property ErrorCount: Integer read GetErrorCount;
    property Errors[Index: Integer]: TDBError read GetError;
  end;

  ENoResultSet = class(EDatabaseError);

{ BDE error information type }

  TDBError = class
  private
    FErrorCode: DBIResult;
    FNativeError: Longint;
    FMessage: string;
    function GetCategory: Byte;
    function GetSubCode: Byte;
  public
    constructor Create(Owner: EDBEngineError; ErrorCode: DBIResult;
      NativeError: Longint; Message: PChar);
    property Category: Byte read GetCategory;
    property ErrorCode: DBIResult read FErrorCode;
    property SubCode: Byte read GetSubCode;
    property Message: string read FMessage;
    property NativeError: Longint read FNativeError;
  end;

{ TLocale }

  TLocale = Pointer;

{ TBDECallback }

  TBDECallbackEvent = function(CBInfo: Pointer): CBRType of Object;

  TBDECallback = class
  private
    FHandle: hDBICur;
    FOwner: TObject;
    FCBType: CBType;
    FOldCBData: Longint;
    FOldCBBuf: Pointer;
    FOldCBBufLen: Word;
    FOldCBFunc: pfDBICallBack;
    FInstalled: Boolean;
    FCallbackEvent: TBDECallbackEvent;
  protected
    function Invoke(CallType: CBType; CBInfo: Pointer): CBRType;
  public
    constructor Create(AOwner: TObject; Handle: hDBICur; CBType: CBType;
      CBBuf: Pointer; CBBufSize: Integer; CallbackEvent: TBDECallbackEvent;
      Chain: Boolean);
    destructor Destroy; override;
  end;

{ TSessionList }

  TSessionList = class(TObject)
  private
    FSessions: TThreadList;
    FSessionNumbers: TBits;
    procedure AddSession(ASession: TSession);
    procedure CloseAll;
    function GetCount: Integer;
    function GetSession(Index: Integer): TSession;
    function GetCurrentSession: TSession;
    function GetSessionByName(const SessionName: string): TSession;
    procedure SetCurrentSession(Value: TSession);
  public
    constructor Create;
    destructor Destroy; override;
    property CurrentSession: TSession read GetCurrentSession write SetCurrentSession;
    function FindSession(const SessionName: string): TSession;
    procedure GetSessionNames(List: TStrings);
    function OpenSession(const SessionName: string): TSession;
    property Count: Integer read GetCount;
    property Sessions[Index: Integer]: TSession read GetSession; default;
    property List[const SessionName: string]: TSession read GetSessionByName;
  end;

{ TSession }

  TConfigModes = (cfmVirtual, cfmPersistent, cfmSession);
  TConfigMode = set of TConfigModes;

  TPasswordEvent = procedure(Sender: TObject; var Continue: Boolean) of Object;

  TDatabaseEvent = (dbOpen, dbClose, dbAdd, dbRemove, dbAddAlias, dbDeleteAlias,
    dbAddDriver, dbDeleteDriver);

  TDatabaseNotifyEvent = procedure(DBEvent: TDatabaseEvent; const Param) of object;

  TBDEInitProc = procedure(Session: TSession);

  TTraceFlag = (tfQPrepare, tfQExecute, tfError, tfStmt, tfConnect,
    tfTransact, tfBlob, tfMisc, tfVendor, tfDataIn, tfDataOut);

  TTraceFlags = set of TTraceFlag;

  TSession = class(TComponent, IDBSession)
  private
    FHandle: HDBISes;
    FDatabases: TList;
    FCallbacks: TList;
    FLocale: TLocale;
    FSMClient: ISMClient;
    FSMBuffer: PTraceDesc;
    FTraceFlags: TTraceFlags;
    FSMLoadFailed: Boolean;
    FStreamedActive: Boolean;
    FKeepConnections: Boolean;
    FDefault: Boolean;
    FSQLHourGlass: Boolean;
    FAutoSessionName: Boolean;
    FUpdatingAutoSessionName: Boolean;
    FDLLDetach: Boolean;
    FBDEOwnsLoginCbDb: Boolean;
    FSessionName: string;
    FSessionNumber: Integer;
    FNetFileDir: string;
    FPrivateDir: string;
    FCBSCType: CBSCType;
    FLockCount: Integer;
    FReserved: Integer;
    FCBDBLogin: TCBDBLogin;
    FOnPassword: TPasswordEvent;
    FOnStartup: TNotifyEvent;
    FOnDBNotify: TDatabaseNotifyEvent;
    procedure AddDatabase(Value: TDatabase);
    procedure CallBDEInitProcs;
    procedure CheckInactive;
    procedure CheckConfigMode(CfgMode: TConfigMode);
    procedure CloseDatabaseHandle(Database: TDatabase);
    function DBLoginCallback(CBInfo: Pointer): CBRType;
    procedure DBNotification(DBEvent: TDatabaseEvent; const Param);
    procedure DeleteConfigPath(const Path, Node: string);
    function DoFindDatabase(const DatabaseName: string; AOwner: TComponent): TDatabase;
    function DoOpenDatabase(const DatabaseName: string; AOwner: TComponent): TDatabase;
    function FindDatabaseHandle(const DatabaseName: string): HDBIDB;
    function GetActive: Boolean;
    function GetConfigMode: TConfigMode;
    function GetDatabase(Index: Integer): TDatabase;
    function GetDatabaseCount: Integer;
    function GetHandle: HDBISes;
    function GetNetFileDir: string;
    function GetPrivateDir: string;
    procedure InitializeBDE;
    procedure InternalAddAlias(const Name, Driver: string; List: TStrings;
      CfgMode: TConfigMode; RestoreMode: Boolean);
    procedure InternalDeleteAlias(const Name: string; CfgMode: TConfigMode;
      RestoreMode: Boolean);
    function SessionNameStored: Boolean;
    procedure LoadSMClient(DesignTime: Boolean);
    procedure LockSession;
    procedure MakeCurrent;
    procedure RegisterCallbacks(Value: Boolean);
    procedure RemoveDatabase(Value: TDatabase);
    function ServerCallback(CBInfo: Pointer): CBRType;
    procedure SetActive(Value: Boolean);
    procedure SetAutoSessionName(Value: Boolean);
    procedure SetConfigMode(Value: TConfigMode);
    procedure SetConfigParams(const Path, Node: string; List: TStrings);
    procedure SetNetFileDir(const Value: string);
    procedure SetPrivateDir(const Value: string);
    procedure SetSessionName(const Value: string);
    procedure SetSessionNames;
    procedure SetTraceFlags(Value: TTraceFlags);
    procedure SMClientSignal(Sender: TObject; Data: Integer);
    function SqlTraceCallback(CBInfo: Pointer): CBRType;
    procedure StartSession(Value: Boolean);
    procedure UnlockSession;
    procedure UpdateAutoSessionName;
    procedure ValidateAutoSession(AOwner: TComponent; AllSessions: Boolean);
  protected
    procedure Loaded; override;
    procedure ModifyConfigParams(const Path, Node: string; List: TStrings);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property OnDBNotify: TDatabaseNotifyEvent read FOnDBNotify write FOnDBNotify;
    property BDEOwnsLoginCbDb: Boolean read FBDEOwnsLoginCbDb write FBDEOwnsLoginCbDb;
    procedure SetName(const NewName: TComponentName); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddAlias(const Name, Driver: string; List: TStrings);
    procedure AddDriver(const Name: string; List: TStrings);
    procedure AddStandardAlias(const Name, Path, DefaultDriver: string);
    property ConfigMode: TConfigMode read GetConfigMode write SetConfigMode;
    procedure AddPassword(const Password: string);
    procedure Close;
    procedure CloseDatabase(Database: TDatabase);
    procedure DeleteAlias(const Name: string);
    procedure DeleteDriver(const Name: string);
    procedure DropConnections;
    function FindDatabase(const DatabaseName: string): TDatabase;
    procedure GetAliasNames(List: TStrings);
    procedure GetAliasParams(const AliasName: string; List: TStrings);
    function GetAliasDriverName(const AliasName: string): string;
    procedure GetConfigParams(const Path, Section: string; List: TStrings);
    procedure GetDatabaseNames(List: TStrings);
    procedure GetDriverNames(List: TStrings);
    procedure GetDriverParams(const DriverName: string; List: TStrings);
    procedure GetFieldNames(const DatabaseName, TableName: string;
      List: TStrings);
    function GetPassword: Boolean;
    procedure GetTableNames(const DatabaseName, Pattern: string;
      Extensions, SystemTables: Boolean; List: TStrings);
    procedure GetStoredProcNames(const DatabaseName: string; List: TStrings);
    function IsAlias(const Name: string): Boolean;
    procedure ModifyAlias(Name: string; List: TStrings);
    procedure ModifyDriver(Name: string; List: TStrings);
    procedure Open;
    function OpenDatabase(const DatabaseName: string): TDatabase;
    procedure RemoveAllPasswords;
    procedure RemovePassword(const Password: string);
    procedure SaveConfigFile;
    property DatabaseCount: Integer read GetDatabaseCount;
    property Databases[Index: Integer]: TDatabase read GetDatabase;
    property Handle: HDBISES read GetHandle;
    property Locale: TLocale read FLocale;
    property TraceFlags: TTraceFlags read FTraceFlags write SetTraceFlags;
  published
    property Active: Boolean read GetActive write SetActive default False;
    property AutoSessionName: Boolean read FAutoSessionName write SetAutoSessionName default False;
    property KeepConnections: Boolean read FKeepConnections write FKeepConnections default True;
    property NetFileDir: string read GetNetFileDir write SetNetFileDir;
    property PrivateDir: string read GetPrivateDir write SetPrivateDir;
    property SessionName: string read FSessionName write SetSessionName stored SessionNameStored;
    property SQLHourGlass: Boolean read FSQLHourGlass write FSQLHourGlass default True;
    property OnPassword: TPasswordEvent read FOnPassword write FOnPassword;
    property OnStartup: TNotifyEvent read FOnStartup write FOnStartup;
  end;

{ TParamList }

  TFieldDescList = array of FLDDesc;

  TParamList = class(TObject)
  private
    FFieldCount: Integer;
    FFieldDescs: TFieldDescList;
    FBuffer: PChar;
    FBufSize: Word;
  public
    constructor Create(Params: TStrings);
    destructor Destroy; override;
    property Buffer: PChar read FBuffer;
    property FieldCount: Integer read FFieldCount;
    property FieldDescs: TFieldDescList read FFieldDescs;
  end;

{ TDatabase }

  TTransIsolation = (tiDirtyRead, tiReadCommitted, tiRepeatableRead);