unit uDAADODriver; {----------------------------------------------------------------------------} { Data Abstract Library - Driver Library { { compiler: Delphi 6 and up { platform: Win32 { { (c)opyright RemObjects Software. all rights reserved. { { Using this code requires a valid license of the Data Abstract { which can be obtained at http://www.remobjects.com. {----------------------------------------------------------------------------} {$IFDEF MSWINDOWS} {$I ..\DataAbstract.inc} {$ELSE} {$I ../DataAbstract.inc} {$ENDIF} {$R DataAbstract_ADODriver_Glyphs.res} // with included option, you can receive errors like // Access violation at address 6BD7297F in module 'msado15.dll'. Read of address 00000068. {.$DEFINE ADOMONITOR_SHOWPARAMVALUES} interface uses Windows, Classes, DB, uDAEngine, uDAInterfaces, uDAADOInterfaces, uROClasses, ADODB, uDAInterfacesEx, uDAUtils, uDAOracleInterfaces; type { TDAADODriver } TDAADODriver = class(TDADriverReference) end; TDAEADODriver = class; TDAADOMonitor = class private FDriver: TDAEADODriver; FEnabled: Boolean; FOnCallback: TDALogTraceEvent; FTraceFlags: TDATraceOptions; procedure SetEnabled(const Value: Boolean); procedure SetTraceFlags(const Value: TDATraceOptions); procedure SetOnCallback(const Value: TDALogTraceEvent); procedure ADOConnectionBeginTransComplete(Connection: TADOConnection; TransactionLevel: Integer; const Error: Error; var EventStatus: TEventStatus); procedure ADOConnectionCommitTransComplete(Connection: TADOConnection; const Error: Error; var EventStatus: TEventStatus); procedure ADOConnectionConnectComplete(Connection: TADOConnection; const Error: Error; var EventStatus: TEventStatus); procedure ADOConnectionExecuteComplete(Connection: TADOConnection; RecordsAffected: Integer; const Error: Error; var EventStatus: TEventStatus; const Command: _Command; const Recordset: _Recordset); procedure ADOConnectionInfoMessage(Connection: TADOConnection; const Error: Error; var EventStatus: TEventStatus); procedure ADOConnectionRollbackTransComplete( Connection: TADOConnection; const Error: Error; var EventStatus: TEventStatus); procedure ADOConnectionDisconnect(Connection: TADOConnection; var EventStatus: TEventStatus); procedure ADOConnectionWillConnect(Connection: TADOConnection; var ConnectionString, UserID, Password: WideString; var ConnectOptions: TConnectOption; var EventStatus: TEventStatus); procedure ADOConnectionWillExecute(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); public constructor Create(ADriver: TDAEADODriver); procedure ReAssignEvents; procedure AssignEvents(AConnection:TADOConnection); procedure UnAssignEvents(AConnection:TADOConnection); property Enabled : Boolean read FEnabled write SetEnabled; property TraceFlags: TDATraceOptions read FTraceFlags write SetTraceFlags; property OnCallback: TDALogTraceEvent read FOnCallback write SetOnCallback; end; { TDAEADODriver } TDAEADODriver = class(TDAEDriver, IDADriver40) private FConnectionList: TThreadList; FMonitor: TDAADOMonitor; protected procedure DoSetTraceOptions(TraceActive: boolean; TraceFlags: TDATraceOptions; Callback: TDALogTraceEvent); override; procedure RegisterConnection(AConnection: TADOConnection); procedure UnregisterConnection(AConnection: TADOConnection); protected function GetConnectionClass: TDAEConnectionClass; override; procedure CustomizeConnectionObject(aConnection: TDAEConnection); override; // IDADriver function GetDriverID: string; override; function GetDescription: string; override; procedure GetAuxDrivers(out List: IROStrings); override; procedure GetAuxParams(const AuxDriver: string; out List: IROStrings); override; function GetAvailableDriverOptions: TDAAvailableDriverOptions; override; function GetProviderDefaultCustomParameters(Provider: string): string; safecall; function GetDefaultConnectionType(const AuxDriver: string): string;override; safecall; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; { TDAEADOConnection } TDAEADOConnection = class(TDAEConnection, IDAADOConnection, IDAConnectionModelling, IDACanQueryDatabaseNames,IDAFileBasedDatabase,IDAUseGenerators,IDAOracleConnection) private fProviderName: string; fSchemaEnabled: Boolean; fProviderType: TDAOleDBProviderType; fADOConnection: TADOConnection; fQuery_CursorType: TCursorType; fQuery_CursorLocation: TCursorLocation; fQuery_ADOLockType: TADOLockType; procedure GetViewOrTableNames(const aType: string; const aSystemTables: boolean; List: IROStrings); function CreateCompatibleQuery: IDADataset; protected function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall; function CreateCustomConnection: TCustomConnection; override; function CreateMacroProcessor: TDASQLMacroProcessor; override; function GetDatasetClass: TDAEDatasetClass; override; function GetStoredProcedureClass: TDAEStoredProcedureClass; override; procedure DoApplyConnectionString(aConnStrParser: TDAConnectionStringParser; aConnectionObject: TCustomConnection); override; function DoBeginTransaction: integer; override; procedure DoCommitTransaction; override; procedure DoRollbackTransaction; override; function DoGetInTransaction: boolean; override; procedure DoGetTableNames(out List: IROStrings); override; procedure DoGetTableFields(const aTableName: string; out Fields: TDAFieldCollection); override; procedure DoGetViewNames(out List: IROStrings); override; procedure DoGetStoredProcedureNames(out List: IROStrings); override; procedure DoGetStoredProcedureParams(const aStoredProcedureName: string; out Params: TDAParamCollection); override; procedure DoGetForeignKeys(out ForeignKeys: TDADriverForeignKeyCollection); override; function DoGetLastAutoInc(const GeneratorName: string): integer; override; function GetQuoteChars: TDAQuoteCharArray; override; function isAlive: Boolean; override; safecall; // IADOConnection function GetProviderName: string; safecall; function GetProviderType: TDAOleDBProviderType; safecall; function GetCommandTimeout: Integer; safecall; procedure SetCommandTimeout(const Value: Integer); safecall; // IDAConnectionModelling function BuildCreateTableSQL(aDataSet: TDADataSet; const aOverrideName: string = ''): string; safecall; procedure CreateTable(aDataSet: TDADataSet; const aOverrideName: string = ''); safecall; function FieldToDeclaration(aField: TDAField): string; safecall; // IDACanQueryDatabaseNames function GetDatabaseNames: IROStrings; function GetSPSelectSyntax(HasArguments: Boolean): String; override; safecall; // IDAFileBasedDatabase function GetFileExtensions: IROStrings; function IdentifierNeedsQuoting(const iIdentifier: string): boolean; override; safecall; { IDAUseGenerators } function GetNextAutoinc(const GeneratorName: string): integer; safecall; public constructor Create(aDriver: TDAEDriver; aName: string = ''); override; destructor Destroy; override; property SchemaEnabled: Boolean read fSchemaEnabled write fSchemaEnabled; end; { TDAEADOQuery } TDAEADOQuery = class(TDAEDataset, IDAMustSetParams) private protected procedure ClearParams; override; function CreateDataset(aConnection: TDAEConnection): TDataset; override; function DoExecute: integer; override; function DoGetSQL: string; override; procedure DoSetSQL(const Value: string); override; // IDAMustSetParams procedure SetParamValues(Params: TDAParamCollection); override;safecall; procedure RefreshParams; override; safecall; procedure GetParamValues(Params: TDAParamCollection); override;safecall; public end; { TDAEADOStoredProcedure } TDAEADOStoredProcedure = class(TDAEStoredProcedure, IDAMustSetParams) protected function CreateDataset(aConnection: TDAEConnection): TDataset; override; procedure RefreshParams; override; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} function GetStoredProcedureName: string; override; procedure SetStoredProcedureName(const Name: string); override; function DoExecute: integer; override; function Execute: integer; override; // IDAMustSetParams procedure SetParamValues(Params: TDAParamCollection); override;safecall; procedure GetParamValues(Params: TDAParamCollection); override;safecall; end; procedure Register; function GetDriverObject: IDADriver; stdcall; implementation uses SysUtils, uDADriverManager, uDARes, Variants, ADOInt, uDAMacroProcessors, Math, uDAHelpers, uROBinaryHelpers, uDAPostgresInterfaces; const Default_CursorType = ctOpenForwardOnly; Default_CursorLocation = clUseServer; Default_ADOLockType = ltReadOnly; const TConnectOptionStr: array[TConnectOption] of string = ('coConnectUnspecified', 'coAsyncConnect'); TCursorLocationStr: array[TCursorLocation] of string = ('clUseServer', 'clUseClient'); TCursorTypeStr: array[TCursorType] of string = ('ctUnspecified', 'ctOpenForwardOnly', 'ctKeyset', 'ctDynamic','ctStatic'); TEventStatusStr: array[TEventStatus] of string = ('esOK', 'esErrorsOccured', 'esCantDeny', 'esCancel', 'esUnwantedEvent'); TADOLockTypeStr: array[TADOLockType] of string = ('ltUnspecified', 'ltReadOnly', 'ltPessimistic', 'ltOptimistic', 'ltBatchOptimistic'); TCommandTypeStr: array[TCommandType] of string = ('cmdUnknown', 'cmdText', 'cmdTable', 'cmdStoredProc', 'cmdFile', 'cmdTableDirect'); TExecuteOptionStr: array[TExecuteOption] of string = ('eoAsyncExecute', 'eoAsyncFetch', 'eoAsyncFetchNonBlocking','eoExecuteNoRecords'); var _driver: TDAEDriver = nil; procedure Register; begin RegisterComponents(DAPalettePageName, [TDAADODriver]); end; function GetDriverObject: IDADriver; begin if (_driver = nil) then _driver := TDAEADODriver.Create(nil); result := _driver; end; type TDecimalVariant = packed record VarType: TVarType; scale: Byte; sign: Byte; Hi32: Cardinal; Lo32: Cardinal; Mid32: Cardinal; Dummy: Cardinal; end; function DecimalToInt64(const V: Variant): Int64; var vData: TDecimalVariant absolute V; begin if (vData.VarType = 14) and (vData.scale = 0) and (vData.Hi32 = 0) then begin Result := Int64(vData.Lo32) or (Int64(vData.Mid32) shl 32); if vData.sign <> 0 then result := -Result; end else result := v; end; function Int64ToDecimal(Data: Int64): Variant; var vd: TDecimalVariant absolute Result; begin VarClear(Result); vd.scale := 0; if data < 0 then begin vd.Sign := 128; data := -data; end else vd.sign := 0; vd.Hi32 := 0; vd.Mid32 := int64(data shr 32); vd.Lo32 := data; vd.VarType := 14; end; { TDAEADOConnection } procedure TDAEADOConnection.DoApplyConnectionString(aConnStrParser: TDAConnectionStringParser; aConnectionObject: TCustomConnection); var lConnectionString: string; i: Integer; sName,sValue: string; begin inherited; with aConnStrParser do begin lConnectionString := ''; if AuxDriver <> '' then lConnectionString := lConnectionString + 'Provider=' + AuxDriver + ';' else raise EDADriverException.Create('No aux driver specified for ADO connection'); fProviderName := AuxDriver; fProviderType := OleDBDriverIdToOleDBProviderType(fProviderName); if (Self.UserID <> '') then lConnectionString := lConnectionString + 'User ID=' + Self.UserID + ';' else if (UserID <> '') then lConnectionString := lConnectionString + 'User ID=' + UserID + ';'; if (Self.Password <> '') then lConnectionString := lConnectionString + 'Password=' + Self.Password + ';' else if (Password <> '') then lConnectionString := lConnectionString + 'Password=' + Password + ';'; if fProviderType = oledb_Jet then begin lConnectionString := lConnectionString + 'Data Source=' + Database+';'; end else begin if Database <> '' then begin if fProviderType = oledb_Postgresql then lConnectionString := lConnectionString + 'Location=' + Database + ';' else lConnectionString := lConnectionString + 'Initial Catalog=' + Database + ';'; end; if Server <> '' then lConnectionString := lConnectionString + 'Data Source=' + Server + ';'; if fProviderType <> oledb_Postgresql then lConnectionString := lConnectionString + 'OLE DB SERVICES=-2;'; end; fSchemaEnabled := false; for i := 0 to AuxParamsCount -1 do begin sName := AuxParamNames[i]; if sName = '' then Continue; sValue := AuxParams[AuxParamNames[i]]; if AnsiSameText('SCHEMAS',sName) then fSchemaEnabled := sValue = '1' else if AnsiSameText(sName, 'CursorLocation') then begin if AnsiSameText('clUseServer',sValue) then fQuery_CursorLocation:= clUseServer else if AnsiSameText('clUseClient',sValue) then fQuery_CursorLocation:= clUseClient; end else if AnsiSameText(sName,'CursorType') then begin if AnsiSameText('ctUnspecified',sValue) then fQuery_CursorType:=ctUnspecified else if AnsiSameText('ctOpenForwardOnly',sValue) then fQuery_CursorType:=ctOpenForwardOnly else if AnsiSameText('ctKeyset',sValue) then fQuery_CursorType:=ctKeyset else if AnsiSameText('ctDynamic',sValue) then fQuery_CursorType:=ctDynamic else if AnsiSameText('ctStatic',sValue) then fQuery_CursorType:=ctStatic; end else if AnsiSameText(sName, 'LockType') then begin if AnsiSameText('ltUnspecified',sValue) then fQuery_ADOLockType:= ltUnspecified else if AnsiSameText('ltReadOnly',sValue) then fQuery_ADOLockType:= ltReadOnly else if AnsiSameText('ltPessimistic',sValue) then fQuery_ADOLockType:= ltPessimistic else if AnsiSameText('ltOptimistic',sValue) then fQuery_ADOLockType:= ltOptimistic else if AnsiSameText('ltBatchOptimistic',sValue) then fQuery_ADOLockType:= ltBatchOptimistic; end else begin if sName[1] = '@' then sName:= Pchar(sName)+1; lConnectionString := lConnectionString + sName + '=' + sValue +';'; end; end; fADOConnection.ConnectionString := lConnectionString; end; SchemaEnabled := fSchemaEnabled or ((UpperCase(GetProviderName) = 'SQLNCLI') or (UpperCase(GetProviderName) ='SQLNCLI.1')); if fProviderType = oledb_Postgresql then fQuery_CursorLocation:=clUseClient; // ADOQuery can't process correctly "name" datatype of Postgres if fProviderType = oledb_Oracle then fQuery_CursorLocation:=clUseClient; // Oracle don't work correctly without clUseClient end; function TDAEADOConnection.DoBeginTransaction: integer; begin result := fADOConnection.BeginTrans end; procedure TDAEADOConnection.DoCommitTransaction; begin fADOConnection.CommitTrans end; function TDAEADOConnection.CreateCustomConnection: TCustomConnection; begin fSchemaEnabled := true; fADOConnection := TADOConnection.Create(nil); fADOConnection.LoginPrompt := FALSE; if Assigned(fADOConnection) then TDAEADODriver(Driver).RegisterConnection(fADOConnection); result := fADOConnection; end; function TDAEADOConnection.GetDatasetClass: TDAEDatasetClass; begin result := TDAEADOQuery; end; function TDAEADOConnection.GetStoredProcedureClass: TDAEStoredProcedureClass; begin result := TDAEADOStoredProcedure; end; procedure TDAEADOConnection.DoGetStoredProcedureNames(out List: IROStrings); var Schema, NameField: TField; DataSet: TADODataSet; lName: string; p: integer; begin inherited; case fProviderType of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: MSSQL_DoGetNames(CreateCompatibleQuery,List,dotProcedure,SchemaEnabled); oledb_Postgresql: Postgres_DoGetNames(CreateCompatibleQuery,List,dotProcedure); oledb_Oracle: Oracle_DoGetNames(CreateCompatibleQuery,List,dotProcedure); else fADOConnection.Open(); DataSet := TADODataSet.Create(nil); try fADOConnection.OpenSchema(siProcedures, EmptyParam, EmptyParam, DataSet); NameField := DataSet.FieldByName('PROCEDURE_NAME'); Schema := DataSet.Findfield('PROCEDURE_SCHEMA'); while not DataSet.EOF do begin lName := NameField.AsString; if (Schema <> nil) and (Schema.Value = 'sys') then begin dataset.Next; continue; end; p := Pos(';', lName); if p > 1 then begin if P+1 >= length(lName) then begin if lName[p+1] = '0' then // function begin Dataset.Next; continue; end; end; SetLength(lName, p-1); end; if fSchemaEnabled and (Schema <> nil) and not (VarIsNull(Schema.Value)) then List.Add(Schema.AsString + '.' + lName) else List.Add(lName); DataSet.Next; end; finally DataSet.Free; end; end; end; function ADOTypeToFieldType(const ADOType: DataTypeEnum; EnableBCD: Boolean = False): TFieldType; begin case ADOType of adEmpty: Result := ftUnknown; adTinyInt, adSmallInt: Result := ftSmallint; adError, adInteger, adUnsignedInt: Result := ftInteger; adBigInt, adUnsignedBigInt: Result := ftLargeInt; adUnsignedTinyInt, adUnsignedSmallInt: Result := ftWord; adSingle, adDouble: Result := ftFloat; adCurrency: Result := ftCurrency; adBoolean: Result := ftBoolean; adDBDate: Result := ftDate; adDBTime: Result := ftTime; adDate, adDBTimeStamp, adFileTime, adDBFileTime: Result := ftDateTime; adChar: Result := ftFixedChar; adVarChar: Result := ftString; adBSTR, adWChar, adVarWChar: Result := ftWideString; adLongVarChar, adLongVarWChar: Result := ftMemo; adLongVarBinary: Result := ftBlob; adBinary: Result := ftBytes; adVarBinary: Result := ftVarBytes; adChapter: Result := ftDataSet; adPropVariant, adVariant: Result := ftVariant; adIUnknown: Result := ftInterface; adIDispatch: Result := ftIDispatch; adGUID: Result := ftGUID; adDecimal, adNumeric, adVarNumeric: if EnableBCD then Result := ftBCD else Result := ftFloat; else Result := ftUnknown; end; end; (*procedure TDAEADOConnection.DoGetStoredProcedureParams(const aStoredProcedureName: string; out Params: TDAParamCollection); var DataSet: TADODataSet; begin fADOConnection.Open(); DataSet := TADODataSet.Create(nil); try fADOConnection.OpenSchema(siProcedureParameters, VarArrayOf([Null, Null, aStoredProcedureName]), EmptyParam, DataSet); //NameField := DataSet.FieldByName('PROCEDURE_NAME'); { do not localize } Params := TDAParamCollection.Create(NIL); while not DataSet.EOF do begin with Params.Add() do begin Name := DataSet.FieldByName('PARAMETER_NAME').AsString; ParamType := TDAParamType(DataSet.FieldByName('PARAMETER_TYPE').AsInteger); //DataType := TDADataType(DataSet.FieldByName('DATA_TYPE').AsInteger); DataType := VCLTypeToDAType(ADOTypeToFieldType(DataSet.FieldByName('DATA_TYPE').AsInteger)); Size := DataSet.FieldByName('CHARACTER_MAXIMUM_LENGTH').AsInteger //more info available: //'PARAMETER_HASDEFAULT' //'PARAMETER_DEFAULT' //'IS_NULLABLE' //'DATA_TYPE' //'CHARACTER_MAXIMUM_LENGTH' //'CHARACTER_OCTET_LENGTH' //'DESCRIPTION' //'TYPE_NAME' //'LOCAL_TYPE_NAME' end; //List.Add(NameField.AsString); DataSet.Next; end; finally DataSet.Free; end; end;*) procedure TDAEADOConnection.DoGetTableFields(const aTableName: string; out Fields: TDAFieldCollection); var lField: TDAField; //i: Integer; DataSet: TADODataSet; begin case fProviderType of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: MSSQL_DoGetTableFields(QuoteIdentifierIfNeeded(aTableName),CreateCompatibleQuery,Fields); oledb_Postgresql: Postgres_DoGetTableFields(QuoteIdentifierIfNeeded(aTableName),CreateCompatibleQuery,Fields); oledb_Oracle: Oracle_DoGetTableFields(QuoteIdentifierIfNeeded(aTableName),CreateCompatibleQuery,Fields); else fADOConnection.Open(); DataSet := TADODataSet.Create(nil); try if (pos('.', aTableName) > 0) and (SchemaEnabled) then fADOConnection.OpenSchema(siColumns, VarArrayOf([Unassigned, Copy(aTableName, 1, Pos('.', aTableName)-1), Copy(aTableName, Pos('.', aTableName)+1, MaxInt)]), EmptyParam, DataSet) else fADOConnection.OpenSchema(siColumns, VarArrayOf([Unassigned, Unassigned, aTableName]), EmptyParam, DataSet); //NameField := DataSet.FieldByName('PROCEDURE_NAME'); { do not localize } if DataSet.EOF then begin inherited DoGetTableFields(QuoteIdentifierIfNeeded(aTableName), Fields); exit ; end; Fields := TDAFieldCollection.Create(nil); {for i := 0 to DataSet.FieldCount-1 do begin DebugServer.Wre(DataSet.Fields[i].FieldName); end; { for } while not DataSet.EOF do begin with Fields.Add() do begin Name := DataSet.FieldByName('COLUMN_NAME').AsString; DataType := VCLTypeToDAType(ADOTypeToFieldType(DataSet.FieldByName('DATA_TYPE').AsInteger)); Size := DataSet.FieldByName('CHARACTER_MAXIMUM_LENGTH').AsInteger; Description := DataSet.FieldByName('DESCRIPTION').AsString; // NotNull := DataSet.FieldByName('IS_NULLABLE').AsBoolean; Required := not DataSet.FieldByName('IS_NULLABLE').AsBoolean; { Hack: for Memo fields ADO seems to return datString, with a lenght of $7fffffff } //if (DataType = datString) and (Size = $7FFFFFFF) then if (DataType = datString) and (Size > $100000) then DataType := datMemo; if (DAtaType = datWideString) and (Size > $100000) then DataType := datWideMemo; if DataSet.FieldByName('COLUMN_HASDEFAULT').AsBoolean then begin DefaultValue := DataSet.FieldByName('COLUMN_DEFAULT').AsString; if not TestDefaultValue(DefaultValue, DataType) then DefaultValue := ''; end; if ADOTypeToFieldType(DataSet.FieldByName('DATA_TYPE').AsInteger) = ftGUID then begin Size := 38; { Quickhack, until we have proper GUID support in 3.0 } if DefaultValue = 'newid()' then DefaultValue := Unassigned; end; //more info available: //'COLUMN_HASDEFAULT' //'COLUMN_DEFAULT' //'IS_NULLABLE' //'DATA_TYPE' //'CHARACTER_MAXIMUM_LENGTH' end; //List.Add(NameField.AsString); DataSet.Next; end; if (pos('.', aTableName) > 0) and (SchemaEnabled) then fADOConnection.OpenSchema(siPrimaryKeys, VarArrayOf([Unassigned, Copy(aTableName, 1, Pos('.', aTableName)-1), Copy(aTableName, Pos('.', aTableName)+1, MaxInt)]), EmptyParam, DataSet) else fADOConnection.OpenSchema(siPrimaryKeys, VarArrayOf([Unassigned, Unassigned, aTableName]), EmptyParam, DataSet); {for i := 0 to DataSet.FieldCount-1 do begin DebugServer.Write(DataSet.Fields[i].FieldName); end; { for } while not DataSet.EOF do begin lField := Fields.FieldByName(DataSet.FieldByName('COLUMN_NAME').AsString); if Assigned(lField) then lField.InPrimaryKey := true; DataSet.Next(); end; finally DataSet.Free; end; end; end; procedure TDAEADOConnection.DoGetForeignKeys(out ForeignKeys: TDADriverForeignKeyCollection); var //i: Integer; DataSet: TADODataSet; s: string; PKSchema,FKSchema: TField; begin inherited; case fProviderType of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: MSSQL_DoGetForeignKeys(CreateCompatibleQuery, ForeignKeys, SchemaEnabled); oledb_Postgresql: Postgres_DoGetForeignKeys(CreateCompatibleQuery, ForeignKeys); oledb_Oracle: Oracle_DoGetForeignKeys(CreateCompatibleQuery, ForeignKeys); else s := UpperCase(GetProviderName); fADOConnection.Open(); DataSet := TADODataSet.Create(nil); try fADOConnection.OpenSchema(siForeignKeys, EmptyParam, EmptyParam, DataSet); {for i := 0 to DataSet.FieldCount-1 do begin DebugServer.Write(DataSet.Fields[i].FieldName); end; { for } PKSchema := DataSet.FindField('PK_TABLE_SCHEMA'); FKSchema := DataSet.FindField('FK_TABLE_SCHEMA'); while not DataSet.EOF do begin {lField := Fields.FieldByName(DataSet.FieldByName('COLUMN_NAME').AsString); if Assigned(lField) then lField.InPrimaryKey := true;} with ForeignKeys.Add() do begin FKField := DataSet.FieldByName('FK_COLUMN_NAME').AsString; PKField := DataSet.FieldByName('PK_COLUMN_NAME').AsString; //FKTable := DataSet.FieldByName('FK_TABLE_NAME').AsString; //PKTable := DataSet.FieldByName('PK_TABLE_NAME').AsString; if fSchemaEnabled and (PKSchema <> nil) and not (VarIsNull(PKSchema.Value)) then PKTable := PKSchema.AsString + '.' + DataSet.FieldByName('PK_TABLE_NAME').AsString else PKTable := DataSet.FieldByName('PK_TABLE_NAME').AsString; if fSchemaEnabled and (FKSchema <> nil) and not (VarIsNull(FKSchema.Value)) then FKTable := FKSchema.AsString + '.' + DataSet.FieldByName('FK_TABLE_NAME').AsString else FKTable := DataSet.FieldByName('FK_TABLE_NAME').AsString; end; {DebugServer.Write(DataSet.FieldByName('FK_TABLE_NAME').AsString+'.'+DataSet.FieldByName('FK_COLUMN_NAME').AsString+' => '+ DataSet.FieldByName('PK_COLUMN_NAME').AsString);} DataSet.Next(); end; finally DataSet.Free; end; end; end; procedure TDAEADOConnection.GetViewOrTableNames(const aType: string; const aSystemTables: boolean; List: IROStrings); var SchemaField, TypeField, NameField: TField; TableType: string; DataSet: TADODataSet; begin fADOConnection.Open(); DataSet := TADODataSet.Create(nil); try fADOConnection.OpenSchema(siTables, EmptyParam, EmptyParam, DataSet); TypeField := DataSet.FieldByName('TABLE_TYPE'); { do not localize } NameField := DataSet.FieldByName('TABLE_NAME'); { do not localize } SchemaField := DataSet.FindField('TABLE_SCHEMA'); while not DataSet.EOF do begin TableType := TypeField.AsString; if (TableType = aType) or ((aType = 'TABLE') and (TableType ='ACCESS TABLE')) or (aSystemTables and (TableType = 'SYSTEM TABLE')) then begin if fSchemaEnabled and (SchemaField <> nil) and not (VarIsNull(SchemaField.Value)) then List.Add(SchemaField.AsString + '.' + NameField.AsString) else List.Add(NameField.AsString); end; DataSet.Next; end; finally DataSet.Free; end; end; procedure TDAEADOConnection.DoGetViewNames(out List: IROStrings); var Schema,NameField: TField; DataSet: TADODataSet; lName: string; p: integer; begin inherited; case fProviderType of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: MSSQL_DoGetNames(CreateCompatibleQuery,List,dotView,SchemaEnabled); oledb_Postgresql: Postgres_DoGetNames(CreateCompatibleQuery,List,dotView); oledb_Oracle: Oracle_DoGetNames(CreateCompatibleQuery,List,dotView); else GetViewOrTableNames('VIEW', false, List); fADOConnection.Open(); DataSet := TADODataSet.Create(nil); try fADOConnection.OpenSchema(siProcedures, EmptyParam, EmptyParam, DataSet); NameField := DataSet.FieldByName('PROCEDURE_NAME'); { do not localize } Schema := DataSet.Findfield('PROCEDURE_SCHEMA'); if List = nil then List := NewROStrings(); while not DataSet.EOF do begin lName := NameField.AsString; if (Schema <> nil) and (Schema.Value = 'sys') then begin dataset.Next; continue; end; p := Pos(';', lName); if p > 1 then begin if P+1 >= length(lName) then begin if lName[p+1] = '1' then // procedure begin Dataset.Next; continue; end; end; SetLength(lName, p-1); end; if fSchemaEnabled and (Schema <> nil) and not (VarIsNull(Schema.Value)) then List.Add(Schema.AsString + '.' + lName) else List.Add(lName); DataSet.Next; end; finally DataSet.Free; end; end; end; procedure TDAEADOConnection.DoGetTableNames(out List: IROStrings); begin inherited; case fProviderType of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: MSSQL_DoGetNames(CreateCompatibleQuery,List,dotTable,SchemaEnabled); oledb_Postgresql: Postgres_DoGetNames(CreateCompatibleQuery,List,dotTable); oledb_Oracle: Oracle_DoGetNames(CreateCompatibleQuery,List,dotTable); else GetViewOrTableNames('TABLE', false, List); end; end; procedure TDAEADOConnection.DoRollbackTransaction; begin fADOConnection.RollbackTrans end; function TDAEADOConnection.GetQuoteChars: TDAQuoteCharArray; begin case fProviderType of oledb_Oracle: Result:= Oracle_GetQuoteChars; else result:=MSSQL_GetQuoteChars; end; end; function TDAEADOConnection.DoGetInTransaction: boolean; begin result := fADOConnection.InTransaction end; function TDAEADOConnection.DoGetLastAutoInc( const GeneratorName: string): integer; var ds: IDADataset; begin case fProviderType of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: begin Result := MSSQL_DoGetLastAutoInc(GeneratorName,CreateCompatibleQuery); end; oledb_Jet: begin ds := NewDataset('SELECT @@Identity', ''); // Returns 0 by default ds.Open; result := ds.Fields[0].Value; end; oledb_Postgresql: Result := Postgres_DoGetLastAutoInc(GeneratorName,CreateCompatibleQuery); oledb_Oracle: Result := Oracle_DoGetLastAutoInc(GeneratorName,CreateCompatibleQuery); else result := inherited DoGetLastAutoInc(GeneratorName); end; end; function TDAEADOConnection.GetProviderName: string; begin result := fProviderName; end; function TDAEADOConnection.GetProviderType: TDAOleDBProviderType; begin result := fProviderType; end; function TDAEADOConnection.CreateMacroProcessor: TDASQLMacroProcessor; begin case fProviderType of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: Result := MSSQL_CreateMacroProcessor; oledb_Jet: result := MSSQL_CreateMacroProcessor; oledb_Oracle: Result := Oracle_CreateMacroProcessor; else Result:= inherited CreateMacroProcessor; end; end; procedure TDAEADOConnection.CreateTable(aDataSet: TDADataSet; const aOverrideName: string); var lSQL: string; begin lSQL := BuildCreateTableSQL(aDataSet, aOverrideName); with NewCommand(lSQL, stSQL) do begin Execute(); end; { with } end; function TDAEADOConnection.BuildCreateTableSQL(aDataSet: TDADataSet; const aOverrideName: string): string; var lName: string; begin lName := aOverrideName; if lName = '' then lName := aDataSet.Name; result := uDAHelpers.BuildCreateStatementForTable(aDataSet, lName, self); end; function TDAEADOConnection.FieldToDeclaration(aField: TDAField): string; begin case aField.DataType of datUnknown: result := 'unknown'; datString: result := Format('varchar(%d)', [aField.Size]); datDateTime: result := 'datetime'; datFloat: result := 'float'; datCurrency: result := 'money'; datAutoInc: result := 'int IDENTITY(1,1)'; datInteger: result := 'int'; datLargeInt: result := 'largeint'; datBoolean: result := 'bit'; datMemo: result := 'text'; datBlob: result := 'image'; //datGuid:result := 'uniqueidentifier'; end; { case } end; function TDAEADOConnection.GetDatabaseNames: IROStrings; begin case fProviderType of oledb_Jet: Result := NewROStrings; oledb_Postgresql: Result:= Postgres_GetDatabaseNames(Self); else Result := MSSQL_GetDatabaseNames(Self); end; end; function TDAEADOConnection.GetSPSelectSyntax( HasArguments: Boolean): String; begin case fProviderType of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: Result := MSSQL_GetSPSelectSyntax(HasArguments); oledb_Oracle: Result := Oracle_GetSPSelectSyntax(HasArguments); oledb_Postgresql: Result:= Postgres_GetSPSelectSyntax(HasArguments); else Result := inherited GetSPSelectSyntax(HasArguments); end; end; function TDAEADOConnection.GetCommandTimeout: Integer; begin if fADOConnection <> nil then Result:= fADOConnection.CommandTimeout else Result:=0; end; procedure TDAEADOConnection.SetCommandTimeout(const Value: Integer); begin if fADOConnection <> nil then fADOConnection.CommandTimeout:= Value; end; function TDAEADOConnection.IdentifierNeedsQuoting( const iIdentifier: string): boolean; begin Result := inherited IdentifierNeedsQuoting(iIdentifier); if not Result then case fProviderType of oledb_Oracle: Result:= Oracle_IdentifierNeedsQuoting(iIdentifier); oledb_Postgresql: Result:= Postgres_IdentifierNeedsQuoting(iIdentifier); else Result:= MSSQL_IdentifierNeedsQuoting(iIdentifier); end; end; function TDAEADOConnection.GetFileExtensions: IROStrings; begin case fProviderType of oledb_Jet: Result:=MSACCESS_GetFileExtensions; else result := NewROStrings; end; end; function TDAEADOConnection.QueryInterface(const IID: TGUID; out Obj): HResult; begin Result := E_NOINTERFACE; if IsEqualGUID(IID, IDAFileBasedDatabase) then begin if not (fProviderType in [oledb_Jet]) then Exit; end else if IsEqualGUID(IID, IDACanQueryDatabaseNames) then begin if (fProviderType in [oledb_Jet]) then Exit; end else if IsEqualGUID(IID, IDAUseGenerators) then begin if not (fProviderType in [oledb_Oracle, oledb_Postgresql]) then Exit; end else if IsEqualGUID(IID, IDAOracleConnection) then begin if (fProviderType <> oledb_Oracle) then Exit; end; Result := inherited QueryInterface(IID, Obj); end; function TDAEADOConnection.isAlive: Boolean; begin Result:=(ConnectionObject <> nil) and not (stClosed in fADOConnection.State); end; constructor TDAEADOConnection.Create(aDriver: TDAEDriver; aName: string); begin inherited Create(aDriver, aName); fQuery_CursorType := Default_CursorType; fQuery_CursorLocation := Default_CursorLocation; fQuery_ADOLockType := Default_ADOLockType; end; function TDAEADOConnection.GetNextAutoinc(const GeneratorName: string): integer; begin case fProviderType of oledb_Oracle: Result:=Oracle_GetNextAutoinc(GeneratorName,CreateCompatibleQuery); oledb_Postgresql: Result := Postgres_GetNextAutoInc(GeneratorName,CreateCompatibleQuery); else Result:=-1; end; end; function TDAEADOConnection.CreateCompatibleQuery: IDADataset; begin Result := GetDatasetClass.Create(Self); TADOQuery(Result.Dataset).CursorLocation:=clUseClient; end; procedure TDAEADOConnection.DoGetStoredProcedureParams( const aStoredProcedureName: string; out Params: TDAParamCollection); begin case fProviderType of oledb_Postgresql: Postgres_DoGetStoredProcedureParams(aStoredProcedureName, CreateCompatibleQuery, Params); oledb_Oracle: Oracle_DoGetStoredProcedureParams(aStoredProcedureName, CreateCompatibleQuery, Params); oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008: MSSQL_DoGetStoredProcedureParams(aStoredProcedureName, CreateCompatibleQuery, Params); else inherited; end; end; destructor TDAEADOConnection.Destroy; begin if Assigned(fADOConnection) then TDAEADODriver(Driver).UnregisterConnection(fADOConnection); inherited; end; { TDAEADODriver } function TDAEADODriver.GetAvailableDriverOptions: TDAAvailableDriverOptions; begin result := [doAuxDriver, doServerName, doDatabaseName, doLogin, doCustom]; end; function TDAEADODriver.GetConnectionClass: TDAEConnectionClass; begin result := TDAEADOConnection; end; function TDAEADODriver.GetDefaultConnectionType( const AuxDriver: string): string; begin case OleDBDriverIdToOleDBProviderType(AuxDriver) of oledb_MSSQL, oledb_MSSQL2005, oledb_MSSQL2008 :Result:=MSSQL_DriverType; oledb_Jet: Result := Access_DriverType; oledb_Oracle: Result := Oracle_DriverType; oledb_ODBC: Result := ODBC_DriverType; oledb_Postgresql : Result := PostgreSQL_DriverType; oleDb_VisualFoxPro: Result := FoxPro_DriverType; else Result:= inherited GetDefaultConnectionType(AuxDriver); end; end; function TDAEADODriver.GetDescription: string; begin result := 'Borland ADOExpress Driver'; end; function TDAEADODriver.GetDriverID: string; begin result := 'ADO'; end; procedure TDAEADODriver.GetAuxDrivers(out List: IROStrings); var i: TDAOleDBProviderType; begin inherited; for i := Low(TDAOleDBProviderType) to High(TDAOleDBProviderType) do if (i <> oledb_Unknown) {// Redundant but safe if I change the enum later...} then List.Add(OleDBProviders[i]); end; function TDAEADODriver.GetProviderDefaultCustomParameters( Provider: string): string; begin if Sametext(Trim(Provider), oledb_MSSQL2005id) or Sametext(Trim(Provider), oledb_MSSQL2008id) then Result := 'Schemas=1;Integrated Security=SSPI;' else if SameText(Trim(Provider), oledb_MSSQLId) then Result := 'Integrated Security=SSPI;'; end; procedure TDAEADODriver.GetAuxParams(const AuxDriver: string; out List: IROStrings); begin inherited; if Sametext(Trim(AuxDriver), oledb_MSSQL2005id) or SameText(Trim(AuxDriver), oledb_MSSQLId) or Sametext(Trim(AuxDriver), oledb_MSSQL2008id) then MSSQL_GetAuxParams(List); List.Add('CursorLocation=(clUseServer,clUseClient)'); List.Add('CursorType=(ctUnspecified,ctOpenForwardOnly,ctKeyset,ctDynamic,ctStatic)'); List.Add('LockType=(ltUnspecified,ltReadOnly,ltPessimistic,ltOptimistic,ltBatchOptimistic)'); List.Add(''); List.Add('You can pass any parameters directly to driver. Use the prefix ''@'' for this, e.g.:'); List.Add('CursorLocation=clUseServer;@Mode=Read'); end; procedure TDAEADODriver.CustomizeConnectionObject( aConnection: TDAEConnection); begin inherited; if Assigned(FMonitor) then fMonitor.AssignEvents(TDAEADOConnection(aConnection).fADOConnection); end; constructor TDAEADODriver.Create(AOwner: TComponent); begin FConnectionList:= TThreadList.Create; inherited; end; destructor TDAEADODriver.Destroy; begin inherited; FConnectionList.Free; end; procedure TDAEADODriver.DoSetTraceOptions(TraceActive: boolean; TraceFlags: TDATraceOptions; Callback: TDALogTraceEvent); begin inherited; if TraceActive then begin if (FMonitor = nil) then fMonitor := TDAADOMonitor.Create(Self); fMonitor.Enabled := FALSE; fMonitor.TraceFlags := TraceFlags; FMonitor.OnCallback := Callback; fMonitor.Enabled := TRUE; end else begin if (FMonitor <> nil) then begin fMonitor.Enabled:=False; FreeAndNIL(fMonitor); end; end; end; procedure TDAEADODriver.RegisterConnection(AConnection: TADOConnection); begin FConnectionList.Add(AConnection); if FMonitor <> nil then FMonitor.AssignEvents(AConnection); end; procedure TDAEADODriver.UnregisterConnection(AConnection: TADOConnection); begin FConnectionList.Remove(AConnection); if FMonitor <> nil then FMonitor.UnAssignEvents(AConnection); end; { TDAEADOQuery } procedure TDAEADOQuery.ClearParams; begin inherited; TADOQuery(Dataset).Parameters.Clear; end; function TDAEADOQuery.CreateDataset(aConnection: TDAEConnection): TDataset; begin result := TADOQuery.Create(nil); TADOQuery(result).LockType := TDAEADOConnection(aConnection).fQuery_ADOLockType;// ltReadOnly; TADOQuery(result).CursorLocation :=TDAEADOConnection(aConnection).fQuery_CursorLocation; // clUseClient; TADOQuery(result).CursorType := TDAEADOConnection(aConnection).fQuery_CursorType; //ctOpenForwardOnly; TADOQuery(result).Connection := TDAEADOConnection(aConnection).fADOConnection; TADOQuery(result).EnableBCD := False; TADOQuery(result).CacheSize := 25; // TADOQuery(result).Prepared := TRUE; if TADOQuery(result).Connection <> nil then TADOQuery(result).CommandTimeout := TADOQuery(result).Connection.CommandTimeout; end; function TDAEADOQuery.DoExecute: integer; begin result := TADOQuery(Dataset).ExecSQL; if TADOQuery(Dataset).Connection.Errors.Count>0 then raise Exception.Create(TADOQuery(Dataset).Connection.Errors.Item[0].Description); end; function TDAEADOQuery.DoGetSQL: string; begin result := TADOQuery(Dataset).SQL.Text; end; procedure TDAEADOQuery.DoSetSQL(const Value: string); begin TADOQuery(Dataset).SQL.Text := Value; end; procedure TDAEADOQuery.GetParamValues(Params: TDAParamCollection); var i: integer; par: TDAParam; inpar: TParameter; ds: TADOQuery; begin ds := TADOQuery(Dataset); if not Assigned(ds.Parameters) then Exit; for i := 0 to (ds.Parameters.Count - 1) do begin inpar := ds.Parameters[i]; par := Params.ParamByName(inpar.Name); if par.ParamType in [daptOutput, daptInputOutput, daptResult] then begin if inpar.DataType = ftLargeint then par.Value := DecimalToInt64(inpar.Value) else par.Value := inpar.Value; end; end; end; procedure TDAEADOQuery.RefreshParams; var i: Integer; par: TDAParam; outpar: TParameter; ds: TADOQuery; begin inherited; ds := TADOQuery(Dataset); if not Assigned(ds.Parameters) then Exit; for i := 0 to ds.Parameters.Count -1 do begin outpar := ds.Parameters[i]; par := self.ParamByName(outpar.Name); if outpar.DataType <> ftUnknown then begin par.DataType := VCLTypeToDAType(outpar.DataType); par.Size := outpar.Size; par.DecimalPrecision := outpar.Precision; par.DecimalScale := outpar.NumericScale; case outpar.Direction of pdInput: par.ParamType := daptInput; pdOutput: par.ParamType := daptOutput; pdInputOutput: par.ParamType := daptInputOutput; pdReturnValue: par.ParamType := daptResult; end; end; end; end; procedure TDAEADOQuery.SetParamValues(Params: TDAParamCollection); var i: integer; par: TDAParam; outpar: TParameter; ds: TADOQuery; ft: TFieldType; begin ds := TADOQuery(Dataset); if not Assigned(ds.Parameters) then Exit; for i := 0 to (ds.Parameters.Count - 1) do begin outpar := ds.Parameters[i]; par := Params.ParamByName(outpar.Name); ft := DATypeToVCLType(par.DataType); case par.ParamType of daptInput: outpar.Direction := pdInput; daptOutput: outpar.Direction := pdOutput; daptInputOutput: outpar.Direction := pdInputOutput; daptResult: outpar.Direction := pdReturnValue; end; if par.DataType = datBlob then begin outpar.DataType := ftBlob; if not (par.ParamType in [daptOutput, daptResult]) then begin if VarIsEmpty(par.Value) or VarIsNull(par.Value) then outpar.Value := NULL else outpar.Value := VariantBinaryToString(par.Value); end; end else begin if (outpar.DataType <> ft) and (ft <> ftUnknown) then outpar.DataType := ft; if not (par.ParamType in [daptOutput, daptResult]) then begin if outpar.DataType = ftLargeint then Outpar.Value := Int64ToDecimal(par.Value) else outpar.Value := par.Value; end; end; if (VarIsEmpty(par.Value) or VarIsNull(par.Value)) and (par.DataType <> datUnknown) then begin if (outpar.DataType <> ft) and (ft <> ftUnknown) then outpar.DataType := ft; end; end; end; { TDAEADOStoredProcedure } function TDAEADOStoredProcedure.CreateDataset(aConnection: TDAEConnection): TDataset; begin result := TADOStoredProc.Create(nil); TADOStoredProc(result).Connection := TDAEADOConnection(aConnection).fADOConnection; if TADOStoredProc(result).Connection <> nil then TADOStoredProc(result).CommandTimeout := TADOStoredProc(result).Connection.CommandTimeout; end; procedure TDAEADOStoredProcedure.SetParamValues(Params: TDAParamCollection); var i: integer; par: TDAParam; outpar: TParameter; ds: TADOStoredProc; ft: TFieldType; begin ds := TADOStoredProc(Dataset); if not Assigned(ds.Parameters) then Exit; for i := 0 to (ds.Parameters.Count - 1) do begin outpar := ds.Parameters[i]; par := Params.ParamByName(outpar.Name); ft := DATypeToVCLType(par.DataType); case par.ParamType of daptInput: outpar.Direction := pdInput; daptOutput: outpar.Direction := pdOutput; daptInputOutput: outpar.Direction := pdInputOutput; daptResult: outpar.Direction := pdReturnValue; end; if par.DataType = datBlob then begin outpar.DataType := ftBlob; if not (par.ParamType in [daptOutput, daptResult]) then begin if VarIsEmpty(par.Value) or VarIsNull(par.Value) then outpar.Value := NULL else outpar.Value := VariantBinaryToString(par.Value); end; end else begin if (outpar.DataType <> ft) and (ft <> ftUnknown) then outpar.DataType := ft; if not (par.ParamType in [daptOutput, daptResult]) then begin if outpar.DataType = ftLargeint then Outpar.Value := Int64ToDecimal(par.Value) else outpar.Value := par.Value; end; end; if (VarIsEmpty(par.Value) or VarIsNull(par.Value)) and (par.DataType <> datUnknown) then begin if (outpar.DataType <> ft) and (ft <> ftUnknown) then outpar.DataType := ft; end; end; end; procedure TDAEADOStoredProcedure.GetParamValues(Params: TDAParamCollection); var i: integer; par: TDAParam; inpar: TParameter; ds: TADOQuery; begin ds := TADOQuery(Dataset); if not Assigned(ds.Parameters) then Exit; for i := 0 to (ds.Parameters.Count - 1) do begin inpar := ds.Parameters[i]; par := Params.ParamByName(inpar.Name); if par.ParamType in [daptOutput, daptInputOutput, daptResult] then begin if inpar.DataType = ftLargeint then par.Value := DecimalToInt64(inpar.Value) else par.Value := inpar.Value; end; end; end; type TADOStoredProcHack = class(TADOStoredProc); function TDAEADOStoredProcedure.Execute: integer; var i: integer; pstr: string; params: TDAParamCollection; ds: TADOStoredProc; lParam: TParameter; begin params := GetParams; if (Connection as TDAEADOConnection).fProviderType = oledb_Oracle then pstr := '' else pstr := '@'; ds := TADOStoredProc(Dataset); for i := ds.Parameters.Count -1 downto 0 do begin if (ds.Parameters[i].DataType = ftInterface) and (ds.Parameters[i].Direction in [pdOutput, pdInputOutput, pdReturnValue]) then ds.Parameters.Delete(i); end; if (ds.Parameters.Count<>Params.Count) then begin ds.Parameters.Refresh; end; {for i := 0 to (Parameters.Count - 1) do if (Parameters[i].Direction in [pdInput, pdInputOutput]) then Parameters.ParamByName('@'+params[i].Name) [i].Value := params[i].Value;} for i := 0 to (params.Count-1) do begin lParam:= ds.Parameters.ParamByName(pstr+params[i].Name); if (params[i].ParamType = daptOutput) and (lParam.Direction <> pdOutput) then lParam.Direction := pdOutput // ado sometimes doesn't set the direction properly else if (params[i].ParamType in [daptInput, daptInputOutput]) then lParam.Value := params[i].Value; end; Result := DoExecute; {TADOStoredProcHack(Dataset).InitializeMasterFields(Self); Command.Execute;} {for i := 0 to (Parameters.Count - 1) do if (Parameters[i].Direction in [pdOutput, pdInputOutput, pdReturnValue]) then params[i].Value := Parameters[i].Value;} for i := 0 to (params.Count-1) do if (params[i].ParamType in [daptOutput, daptInputOutput, daptResult]) then params[i].Value := ds.Parameters.ParamByName(pstr+params[i].Name).Value; end; function TDAEADOStoredProcedure.GetStoredProcedureName: string; begin result := TADOStoredProc(Dataset).ProcedureName; end; procedure TDAEADOStoredProcedure.SetStoredProcedureName( const Name: string); begin TADOStoredProc(Dataset).ProcedureName := Name; end; procedure TDAEADOStoredProcedure.RefreshParams; var dsparams: TParameters; dPar: TParameter; i: integer; par: TDAParam; params: TDAParamCollection; nme: string; begin dsparams := TADOStoredProc(Dataset).Parameters; dsparams.Refresh; params := GetParams; params.Clear; for i := 0 to (dsparams.Count - 1) do begin par := params.Add; dPar:=dsparams[i]; nme := dPar.Name; if Pos('@', nme) > 0 then System.Delete(nme, Pos('@', nme), 1); par.Name := nme; if (dPar.DataType = ftInterface) then par.DataType := datUnknown else par.DataType := VCLTypeToDAType(dPar.DataType); par.ParamType := TDAParamType(dPar.Direction); par.Size := dPar.Size; end; end; exports GetDriverObject name func_GetDriverObject; function TDAEADOStoredProcedure.DoExecute: integer; begin TADOStoredProcHack(TADOStoredProc(Dataset)).Command.Execute(result, EmptyParam); if TADOStoredProc(Dataset).Connection.Errors.Count >0 then raise Exception.Create(TADOStoredProc(Dataset).Connection.Errors.Item[0].Description); end; { TDAADOMonitor } function ParseError(const AError: Error):string; begin if aError = nil then begin Result:='' end else begin Result:= 'Error.Number: ' + IntToStr(AError.Number) + sLineBreak + 'Error.NativeError: ' + IntToStr(AError.NativeError) + sLineBreak + 'Error.Source: ' + AError.Source+sLineBreak + 'Error.Description: ' + AError.Description + sLineBreak + 'Error.SQLState: ' + AError.SQLState + sLineBreak; end; end; function ParseCommand(Const Command: _Command): string; var i: integer; {$IFDEF ADOMONITOR_SHOWPARAMVALUES} v: Variant; {$ENDIF} lItem: _Parameter; s: String; begin if Command = nil then begin Result:=sLineBreak; end else begin s:= PWideChar(Command.CommandText); Result:= 'Command.CommandText: ' + StringReplace(s, sLineBreak,' ',[rfReplaceAll]) + sLineBreak + 'Command.Parameters.Count: ' + IntToStr(Command.Parameters.Count) + sLineBreak; for i:= 0 to Command.Parameters.Count-1 do begin lItem:=Command.Parameters.Item[i]; Result := Result + 'Command.Parameters['+intToStr(i)+ ']: '+ lItem.Name; {$IFDEF ADOMONITOR_SHOWPARAMVALUES} Result:= Result + ' = '; v:=lItem.Value; if VarIsNull(v) then Result := Result+ '' else if VarIsEmpty(v) then Result := Result+ '' else if lItem.Type_ in [adBinary, adVarBinary, adLongVarBinary, adLongVarChar] then Result:= Result + '' else Result:= Result + VarToStr(v); {$ENDIF} Result:=Result+sLineBreak; end; Result:=Result+sLineBreak; end; end; function ParseEventStatus(const EventStatus: TEventStatus): string; begin Result := 'EventStatus: ' + TEventStatusStr[EventStatus]+sLineBreak; end; procedure TDAADOMonitor.ADOConnectionBeginTransComplete( Connection: TADOConnection; TransactionLevel: Integer; const Error: Error; var EventStatus: TEventStatus); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Begin transaction'+sLineBreak+ '-----------------'+sLineBreak+ 'TransactionLevel: ' +IntToStr(TransactionLevel)+sLineBreak+ ParseError(Error)+ ParseEventStatus(EventStatus), 0); end; procedure TDAADOMonitor.ADOConnectionCommitTransComplete( Connection: TADOConnection; const Error: Error; var EventStatus: TEventStatus); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Commit transaction'+sLineBreak+ '------------------'+sLineBreak+ ParseError(Error)+ ParseEventStatus(EventStatus), 0); end; procedure TDAADOMonitor.ADOConnectionConnectComplete( Connection: TADOConnection; const Error: Error; var EventStatus: TEventStatus); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Connect'+sLineBreak+ '-------'+sLineBreak+ ParseError(Error)+ ParseEventStatus(EventStatus), 0); end; procedure TDAADOMonitor.ADOConnectionDisconnect(Connection: TADOConnection; var EventStatus: TEventStatus); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Disconnect'+sLineBreak+ '----------'+sLineBreak+ ParseEventStatus(EventStatus), 0); end; procedure TDAADOMonitor.ADOConnectionExecuteComplete( Connection: TADOConnection; RecordsAffected: Integer; const Error: Error; var EventStatus: TEventStatus; const Command: _Command; const Recordset: _Recordset); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Execute'+sLineBreak+ '-------'+sLineBreak+ 'RecordsAffected: ' +IntToStr(RecordsAffected)+sLineBreak+ ParseError(Error)+ ParseEventStatus(EventStatus)+ ParseCommand(Command), 0); end; procedure TDAADOMonitor.ADOConnectionInfoMessage( Connection: TADOConnection; const Error: Error; var EventStatus: TEventStatus); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Info message'+sLineBreak+ '------------'+sLineBreak+ ParseError(Error)+ ParseEventStatus(EventStatus), 0); end; procedure TDAADOMonitor.ADOConnectionRollbackTransComplete( Connection: TADOConnection; const Error: Error; var EventStatus: TEventStatus); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Rollback transaction'+sLineBreak+ '-------------------'+sLineBreak+ ParseError(Error)+ ParseEventStatus(EventStatus), 0); end; procedure TDAADOMonitor.ADOConnectionWillConnect( Connection: TADOConnection; var ConnectionString, UserID, Password: WideString; var ConnectOptions: TConnectOption; var EventStatus: TEventStatus); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Will connect'+sLineBreak+ '------------'+sLineBreak+ 'Connection string: ' + ConnectionString +sLineBreak+ 'UserID: ' + UserID +sLineBreak+ 'Password: ' + Password +sLineBreak+ 'ConnectOptions: ' + TConnectOptionStr[ConnectOptions]+sLineBreak+ ParseEventStatus(EventStatus), 0); end; function getExecuteOptionStr(const ExecuteOptions: TExecuteOptions): string; var i: TExecuteOption; begin Result:=''; for i:= low(TExecuteOption) to High(TExecuteOption) do if i in ExecuteOptions then Result:= Result + TExecuteOptionStr[i]+','; if Length(Result) > 0 then SetLength(Result, Length(Result)-1); end; procedure TDAADOMonitor.ADOConnectionWillExecute( 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); begin if Assigned(FOnCallback) then FOnCallback(Self, 'Will execute' + sLineBreak+ '------------' + sLineBreak+ 'CommandText: ' + CommandText + sLineBreak+ 'CursorType: ' + TCursorTypeStr[CursorType] + sLineBreak + 'LockType: ' + TADOLockTypeStr[LockType] + sLineBreak + 'CommandType: ' + TCommandTypeStr[CommandType] + sLineBreak + 'ExecuteOptions: ' + getExecuteOptionStr(ExecuteOptions) + sLineBreak + ParseEventStatus(EventStatus)+ ParseCommand(Command), 0); end; procedure TDAADOMonitor.AssignEvents(AConnection: TADOConnection); begin if (AConnection <> nil) and FEnabled and Assigned(FOnCallback) then begin // if toPrepare in FTraceFlags then AConnection. if toExecute in FTraceFlags then begin AConnection.OnExecuteComplete := ADOConnectionExecuteComplete; AConnection.OnWillExecute := ADOConnectionWillExecute; end; // if toFetch in FTraceFlags then AConnection. if toError in FTraceFlags then begin AConnection.OnInfoMessage := ADOConnectionInfoMessage; end; // if toStmt in FTraceFlags then AConnection. if toConnect in FTraceFlags then begin AConnection.OnConnectComplete := ADOConnectionConnectComplete; AConnection.OnWillConnect := ADOConnectionWillConnect; AConnection.OnDisconnect := ADOConnectionDisconnect; end; if toTransact in FTraceFlags then begin AConnection.OnBeginTransComplete := ADOConnectionBeginTransComplete; AConnection.OnCommitTransComplete := ADOConnectionCommitTransComplete; AConnection.OnRollbackTransComplete := ADOConnectionRollbackTransComplete; end; // if toBlob in FTraceFlags then AConnection. // if toService in FTraceFlags then AConnection. // if toMisc in FTraceFlags then AConnection. // if toParams in FTraceFlags then AConnection. end; end; constructor TDAADOMonitor.Create(ADriver: TDAEADODriver); begin inherited Create; FDriver := ADriver; FEnabled := False; end; procedure TDAADOMonitor.ReAssignEvents; var i: integer; lmode: boolean; begin lMode:=FEnabled and (fTraceFlags <> []) and Assigned(FOnCallback); with FDriver.FConnectionList.LockList do try for i:= 0 to Count-1 do if lMode then AssignEvents(TADOConnection(Items[i])) else UnAssignEvents(TADOConnection(Items[i])); finally FDriver.FConnectionList.UnLockList; end; end; procedure TDAADOMonitor.SetEnabled(const Value: Boolean); begin if FEnabled <> Value then begin FEnabled := Value; if FEnabled and (fTraceFlags <> []) and Assigned(FOnCallback) then ReAssignEvents; end; end; procedure TDAADOMonitor.SetOnCallback(const Value: TDALogTraceEvent); begin if @fOnCallback <> @Value then begin FOnCallback := Value; if FEnabled and (fTraceFlags <> []) and Assigned(FOnCallback) then ReAssignEvents; end; end; procedure TDAADOMonitor.SetTraceFlags(const Value: TDATraceOptions); begin if FTraceFlags <> Value then begin FTraceFlags := Value; if FEnabled and (fTraceFlags <> []) and Assigned(FOnCallback) then ReAssignEvents; end; end; procedure TDAADOMonitor.UnAssignEvents(AConnection: TADOConnection); begin if AConnection <> nil then begin // toTransact AConnection.OnBeginTransComplete := nil; AConnection.OnCommitTransComplete := nil; AConnection.OnRollbackTransComplete := nil; //toConnect AConnection.OnConnectComplete := nil; AConnection.OnWillConnect := nil; AConnection.OnDisconnect := nil; //toExecute AConnection.OnExecuteComplete := nil; AConnection.OnWillExecute := nil; //toError AConnection.OnInfoMessage := nil; end; end; initialization _driver := nil; RegisterDriverProc(GetDriverObject); finalization UnregisterDriverProc(GetDriverObject); FreeAndNIL(_driver); end.