adodb.pas

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

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{       ADO Components                                  }
{                                                       }
{       Copyright (c) 1999 Inprise Corporation          }
{                                                       }
{*******************************************************}

unit ADODB;

interface

{$R-,Q-}

uses
  Windows, Variants, ActiveX, SysUtils, Classes, TypInfo, DB, OleDB, ADOInt;

type

{ Forward declarations }

  TADOCommand = class;
  TCustomADODataSet = class;
  TADODataSet = class;
  TParameters = class;
  TADOConnection = class;

{ Redclare ADO types exposed by this unit }

  _Connection = ADOInt._Connection;
{$EXTERNALSYM _Connection}
  _Command = ADOInt._Command;
{$EXTERNALSYM _Command}
  _Recordset = ADOInt.Recordset;
{$EXTERNALSYM _Recordset}
  Error = ADOInt.Error;
{$EXTERNALSYM Error}
  Errors = ADOInt.Errors;
{$EXTERNALSYM Errors}
  _Parameter = ADOInt._Parameter;
{$EXTERNALSYM _Parameter}
  Parameters = ADOInt.Parameters;
{$EXTERNALSYM Parameters}
  Property_ = ADOInt.Property_;
{$EXTERNALSYM Property_}
  Properties = ADOInt.Properties;
{$EXTERNALSYM Properties}

{ Errors }

  EADOError = class(EDatabaseError);

{ TADOConnection }

  TConnectMode = (cmUnknown, cmRead, cmWrite, cmReadWrite, cmShareDenyRead,
    cmShareDenyWrite, cmShareExclusive, cmShareDenyNone);

  TConnectOption = (coConnectUnspecified, coAsyncConnect);

  TCursorLocation = (clUseServer, clUseClient);

  TCursorType = (ctUnspecified, ctOpenForwardOnly, ctKeyset, ctDynamic,
    ctStatic);

  TEventStatus = (esOK, esErrorsOccured, esCantDeny, esCancel, esUnwantedEvent);

  TExecuteOption = (eoAsyncExecute, eoAsyncFetch, eoAsyncFetchNonBlocking,
    eoExecuteNoRecords);
  TExecuteOptions = set of TExecuteOption;

  TIsolationLevel = (ilUnspecified, ilChaos, ilReadUncommitted, ilBrowse,
    ilCursorStability, ilReadCommitted, ilRepeatableRead, ilSerializable,
    ilIsolated);

  TADOLockType = (ltUnspecified, ltReadOnly, ltPessimistic, ltOptimistic,
    ltBatchOptimistic);

  TObjectState = (stClosed, stOpen, stConnecting, stExecuting, stFetching);
  TObjectStates = set of TObjectState;

  TSchemaInfo = (siAsserts, siCatalogs, siCharacterSets, siCollations,
    siColumns, siCheckConstraints, siConstraintColumnUsage,
    siConstraintTableUsage, siKeyColumnUsage, siReferentialConstraints,
    siTableConstraints, siColumnsDomainUsage, siIndexes, siColumnPrivileges,
    siTablePrivileges, siUsagePrivileges, siProcedures, siSchemata,
    siSQLLanguages, siStatistics, siTables, siTranslations, siProviderTypes,
    siViews, siViewColumnUsage, siViewTableUsage, siProcedureParameters,
    siForeignKeys, siPrimaryKeys, siProcedureColumns, siDBInfoKeywords,
    siDBInfoLiterals, siCubes, siDimensions, siHierarchies, siLevels,
    siMeasures, siProperties, siMembers, siProviderSpecific);

  TXactAttribute = (xaCommitRetaining, xaAbortRetaining);
  TXactAttributes = set of TXactAttribute;

  TBeginTransCompleteEvent = procedure(Connection: TADOConnection;
    TransactionLevel: Integer; const Error: Error;
    var EventStatus: TEventStatus) of object;

  TCommandType = (cmdUnknown, cmdText, cmdTable, cmdStoredProc, cmdFile, cmdTableDirect);

  TConnectErrorEvent = procedure(Connection: TADOConnection;
    const Error: Error; var EventStatus: TEventStatus) of object;

  TDisconnectEvent = procedure(Connection: TADOConnection;
    var EventStatus: TEventStatus) of object;

  TExecuteCompleteEvent = procedure(Connection: TADOConnection;
    RecordsAffected: Integer; const Error: Error;  var EventStatus: TEventStatus;
    const Command: _Command; const Recordset: _Recordset) of object;

  TWillConnectEvent = procedure(Connection: TADOConnection;
    var ConnectionString, UserID, Password: WideString;
    var ConnectOptions: TConnectOption; var EventStatus: TEventStatus) of object;

  TWillExecuteEvent = procedure(Connection: TADOConnection;
    var CommandText: WideString; var CursorType: TCursorType;
    var LockType: TADOLockType; var CommandType: TCommandType;
    var ExecuteOptions: TExecuteOptions; var EventStatus: TEventStatus;
    const Command: _Command; const Recordset: _Recordset) of object;

  TInfoMessageEvent = procedure(Connection: TADOConnection; const Error: Error;
    var EventStatus: TEventStatus) of object;

  TADOConnection = class(TCustomConnection, IUnknown, ConnectionEventsVT)
  private
    FCommands: TList;
    FConnectionObject: _Connection;
    FConnEventsID: Integer;
    FConnectionString: WideString;
    FDefaultDatabase: WideString;
    FUserID: WideString;
    FPassword: WideString;
    FConnectOptions: TConnectOption;
    FIsolationLevel: TIsolationLevel;
    FTransactionLevel: Integer;
    FKeepConnection: Boolean;
    FOnBeginTransComplete: TBeginTransCompleteEvent;
    FOnConnectComplete: TConnectErrorEvent;
    FOnCommitTransComplete: TConnectErrorEvent;
    FOnRollbackTransComplete: TConnectErrorEvent;
    FOnDisconnect: TDisconnectEvent;
    FOnInfoMessage: TInfoMessageEvent;
    FOnWillConnect: TWillConnectEvent;
    FOnExecuteComplete: TExecuteCompleteEvent;
    FOnWillExecute: TWillExecuteEvent;
    procedure ClearRefs;
    function IsProviderStored: Boolean;
    function IsDefaultDatabaseStored: Boolean;
    function GetADODataSet(Index: Integer): TCustomADODataSet;
    function GetAttributes: TXactAttributes;
    function GetCommand(Index: Integer): TADOCommand;
    function GetCommandCount: Integer;
    function GetCommandTimeout: Integer;
    function GetConnectionString: WideString;
    function GetConnectionTimeout: Integer;
    function GetCursorLocation: TCursorLocation;
    function GetDefaultDatabase: WideString;
    function GetIsolationLevel: TIsolationLevel;
    function GetMode: TConnectMode;
    function GetProperties: Properties;
    function GetProvider: WideString;
    function GetState: TObjectStates;
    function GetVersion: WideString;
    procedure SetAttributes(const Value: TXactAttributes);
    procedure SetCommandTimeout(const Value: Integer);
    procedure SetConnectionString(const Value: WideString);
    procedure SetConnectionTimeout(const Value: Integer);
    procedure SetCursorLocation(const Value: TCursorLocation);
    procedure SetDefaultDatabase(const Value: WideString);
    procedure SetIsolationLevel(const Value: TIsolationLevel);
    procedure SetMode(const Value: TConnectMode);
    procedure SetProvider(const Value: WideString);
    procedure SetConnectOptions(const Value: TConnectOption);
    function GetInTransaction: Boolean;
    procedure SetConnectionObject(const Value: _Connection);
    procedure SetKeepConnection(const Value: Boolean);
  protected
    { ConnectionEvents }
    function ConnectionPoint: IConnectionPoint;
    procedure InfoMessage(const pError: Error; var adStatus: EventStatusEnum;
      const pConnection: _Connection); safecall;
    procedure BeginTransComplete(TransactionLevel: Integer; const pError: Error;
      var adStatus: EventStatusEnum; const pConnection: _Connection); safecall;
    procedure CommitTransComplete(const pError: Error; var adStatus: EventStatusEnum;
      const pConnection: _Connection); safecall;
    procedure RollbackTransComplete(const pError: Error; var adStatus: EventStatusEnum;
      const pConnection: _Connection); safecall;
    procedure WillExecute(var Source: WideString; var CursorType: CursorTypeEnum;
      var LockType: LockTypeEnum; var Options: Integer;
      var adStatus: EventStatusEnum; const pCommand: _Command;
      const pRecordset: _Recordset; const pConnection: _Connection); safecall;
    procedure ExecuteComplete(RecordsAffected: Integer; const pError: Error;
      var adStatus: EventStatusEnum; const pCommand: _Command;
      const pRecordset: _Recordset; const pConnection: _Connection); safecall;
    procedure WillConnect(var ConnectionString: WideString; var UserID: WideString;
      var Password: WideString; var Options: Integer;
      var adStatus: EventStatusEnum; const pConnection: _Connection); safecall;
    procedure ConnectComplete(const pError: Error; var adStatus: EventStatusEnum;
      const pConnection: _Connection); safecall;
    procedure Disconnect(var adStatus: EventStatusEnum; const pConnection: _Connection); safecall;
  protected
    procedure CheckActive;
    procedure CheckDisconnect; virtual;
    procedure CheckInactive;
    procedure DoConnect; override;
    procedure DoDisconnect; override;
    function GetConnected: Boolean; override;
    function GetErrors: Errors;
    procedure Loaded; override;
    procedure RegisterClient(Client: TObject; Event: TConnectChangeEvent = nil); override;
    procedure UnRegisterClient(Client: TObject); override;
    procedure WaitForConnectComplete; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function BeginTrans: Integer;
    procedure Cancel;
    procedure CommitTrans;
    procedure Execute(const CommandText: WideString; var RecordsAffected: Integer;
      const ExecuteOptions: TExecuteOptions = [eoExecuteNoRecords]); overload;
    function Execute(const CommandText: WideString;
      const CommandType: TCommandType = cmdText; const ExecuteOptions: TExecuteOptions = []): _Recordset; overload;
    procedure GetProcedureNames(List: TStrings);
    procedure GetFieldNames(const TableName: string; List: TStrings);
    procedure GetTableNames(List: TStrings; SystemTables: Boolean = False);
    procedure Open(const UserID: WideString; const Password: WideString); overload;
    procedure OpenSchema(const Schema: TSchemaInfo; const Restrictions: OleVariant;
      const SchemaID: OleVariant; DataSet: TADODataSet);
    procedure RollbackTrans;
    property ConnectionObject: _Connection read FConnectionObject write SetConnectionObject;
    property CommandCount: Integer read GetCommandCount;
    property Commands[Index: Integer]: TADOCommand read GetCommand;
    property DataSets[Index: Integer]: TCustomADODataSet read GetADODataSet;
    property Errors: Errors read GetErrors;
    property InTransaction: Boolean read GetInTransaction;
    property Properties: Properties read GetProperties;
    property State: TObjectStates read GetState;
    property Version: WideString read GetVersion;
  published
    property Attributes: TXactAttributes read GetAttributes write SetAttributes default [];
    property CommandTimeout: Integer read GetCommandTimeout write SetCommandTimeout default 30;
    property Connected;
    property ConnectionString: WideString read GetConnectionString write SetConnectionString;
    property ConnectionTimeout: Integer read GetConnectionTimeout write SetConnectionTimeout default 15;
    property ConnectOptions: TConnectOption read FConnectOptions write SetConnectOptions default coConnectUnspecified;
    property CursorLocation: TCursorLocation read GetCursorLocation write SetCursorLocation default clUseClient;
    property DefaultDatabase: WideString read GetDefaultDatabase write SetDefaultDatabase stored IsDefaultDatabaseStored;
    property IsolationLevel: TIsolationLevel read GetIsolationLevel write SetIsolationLevel default ilCursorStability;
    property KeepConnection: Boolean read FKeepConnection write SetKeepConnection default True;
    property LoginPrompt default True;
    property Mode: TConnectMode read GetMode write SetMode default cmUnknown;
    property Provider: WideString read GetProvider write SetProvider stored IsProviderStored;
    { Events }
    property AfterConnect;
    property BeforeConnect;
    property AfterDisconnect;
    property BeforeDisconnect;
    property OnDisconnect: TDisconnectEvent read FOnDisconnect write FOnDisconnect;
    property OnInfoMessage: TInfoMessageEvent read FOnInfoMessage write FOnInfoMessage;
    property OnBeginTransComplete: TBeginTransCompleteEvent read FOnBeginTransComplete write FOnBeginTransComplete;
    property OnCommitTransComplete: TConnectErrorEvent read FOnCommitTransComplete write FOnCommitTransComplete;
    property OnRollbackTransComplete: TConnectErrorEvent read FOnRollbackTransComplete write FOnRollbackTransComplete;
    property OnConnectComplete: TConnectErrorEvent read FOnConnectComplete write FOnConnectComplete;
    property OnWillConnect: TWillConnectEvent read FOnWillConnect write FOnWillConnect;
    property OnExecuteComplete: TExecuteCompleteEvent read FOnExecuteComplete write FOnExecuteComplete;
    property OnWillExecute: TWillExecuteEvent read FOnWillExecute write FOnWillExecute;
    property OnLogin;
  end;

{ TRDSConnection }

  TRDSConnection = class(TCustomConnection)
  private
    FDataSpace: DataSpace;
    FComputerName: WideString;
    FServerName: WideString;
    FAppServer: OleVariant;
    FInternetTimeout: Integer;
    FIsAppServer: Boolean;
    procedure CheckInactive;
    procedure ClearRefs;
    procedure SetServerName(const Value: WideString);
    procedure SetComputerName(const Value: WideString);
  protected
    procedure DoConnect; override;
    procedure DoDisconnect; override;
    function GetConnected: Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetRecordset(const CommandText: WideString;
      ConnectionString: WideString = ''): _Recordset;
    property AppServer: OleVariant read FAppServer;
    property DataSpaceObject: DataSpace read FDataSpace;
  published
    property ComputerName: WideString read FComputerName write SetComputerName;
    property Connected;
    property InternetTimeout: Integer read FInternetTimeout write FInternetTimeout default 0;
    property ServerName: WideString read FServerName write SetServerName stored FIsAppServer;
    property AfterConnect;
    property AfterDisconnect;
    property BeforeConnect;
    property BeforeDisconnect;
  end;

{ TParameter }

  TDataType = TFieldType;
  TParameterAttribute = (paSigned, paNullable, paLong);
  TParameterAttributes = set of TParameterAttribute;
  TParameterDirection = (pdUnknown, pdInput, pdOutput, pdInputOutput,
    pdReturnValue);

  TParameter = class(TCollectionItem)
  private
    FParameter: _Parameter;
    function GetAttributes: TParameterAttributes;
    function GetDataType: TDataType;
    function GetName: WideString;