unit uDAEngine; {----------------------------------------------------------------------------} { Data Abstract Library - Core Library } { } { compiler: Delphi 6 and up, Kylix 3 and up } { platform: Win32, Linux } { } { (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. } {----------------------------------------------------------------------------} {$I DataAbstract.inc} interface uses Classes, DB, SysUtils, {$IFDEF MSWINDOWS} ActiveX, ComObj,{$ENDIF} // for ISupportErrorInfo, EOleSysError uDAInterfaces, uROClasses, uDARes, uROTypes, uDAMacros, uDAUtils; type { Misc } TCustomConnectionClass = class of TCustomConnection; TDatasetClass = class of TDataset; TDAEConnection = class; TDAEDriver = class; { Exceptions } EDAException = class(EROException); EDADriverException = class(EDAException); { TDAConnectionWrapper Internal wrapper class for frameworks whose connections don't inherit from TCustomConnection or require additional supporting components. See IBO and DBISAM drivers for an example. This class provides an implementation for DoConnect and DoDisconnect removing the need to further override them. } TDAConnectionWrapper = class(TCustomConnection) protected procedure DoConnect; override; procedure DoDisconnect; override; end; {$IFDEF MSWINDOWS} TDAEngineBaseObject = class(TROInterfacedObject, ISupportErrorInfo)//, IServerExceptionHandler) protected function InterfaceSupportsErrorInfo(const iid: TGUID): HRESULT; stdcall; procedure OnException(const ServerClass: WideString; const ExceptionClass: WideString; const ErrorMessage: WideString; ExceptAddr: Integer; const ErrorIID: WideString; const ProgID: WideString; var Handled: Integer; var Result: HRESULT); public function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override; end; {$ELSE} TDAEngineBaseObject = TROInterfacedObject; {$ENDIF} { TDASQLMacroProcessor } TDASQLMacroProcessor = class(TROMacroParser) private fStoredProcedurePrefix, fDateFormat, fStoredProcParamPrefix, fDateTimeFormat: string; fDoubleQuoteStrings: boolean; function MyUnknownIdentifier(Sender: TObject; const Name, OrgName: string; var Value: string): Boolean; protected // Internal procedure RegisterMacros; virtual; // SQL Functions function DateTime(Sender: TObject; const Parameters: array of string): string; virtual; abstract; function Date(Sender: TObject; const Parameters: array of string): string; virtual; function AddTime(Sender: TObject; const Parameters: array of string): string; virtual; abstract; function FormatDateTime(Sender: TObject; const Parameters: array of string): string; virtual; function FormatDate(Sender: TObject; const Parameters: array of string): string; virtual; function Length(Sender: TObject; const Parameters: array of string): string; virtual; abstract; function LowerCase(Sender: TObject; const Parameters: array of string): string; virtual; abstract; function UpperCase(Sender: TObject; const Parameters: array of string): string; virtual; abstract; function TrimLeft(Sender: TObject; const Parameters: array of string): string; virtual; abstract; function TrimRight(Sender: TObject; const Parameters: array of string): string; virtual; abstract; function Copy(Sender: TObject; const Parameters: array of string): string; virtual; abstract; function Nolock(Sender: TObject; const Parameters: array of string): string; virtual;abstract; public constructor Create(const aDateFormat, aDateTimeFormat: string; aDoubleQuoteStrings: boolean; const aStoredProcParamsPrefix: string = '');overload; constructor Create;overload; property StoredProcedurePrefix: string read fStoredProcedurePrefix; property DateFormat: string read fDateFormat; property StoredProcParamPrefix: string read fStoredProcParamPrefix; property DateTimeFormat: string read fDateTimeFormat; property DoubleQuoteStrings: boolean read fDoubleQuoteStrings; end; IDAHasMacroProcessor = interface(IDAConnection) ['{C18B417F-C698-4BB1-8F57-C3952E1046D1}'] function GetMacroProcessor: TDASQLMacroProcessor; end; { TDAESQLCommand } {$WARN SYMBOL_DEPRECATED OFF} TDAESQLCommand = class(TDAEngineBaseObject, IDASQLCommand) private fConnection: TDAEConnection; fDataset: TDataset; fParams: TDAParamCollection; fWhere: TDAWhere; fDynamicWhere: TDASQLWhereBuilder; fChanged: boolean; fSQL: string; fName: string; fPrepared: boolean; //fOrderBy : string; fOnAfterExecute: TDAAfterExecuteCommandEvent; fOnBeforeExecute: TDABeforeExecuteCommandEvent; fOnExecuteError: TDAExecuteCommandErrorEvent; FIsPresentDynWhereVariable: Boolean; function UnknownIdentifier(Sender: TObject; const Name, OrgName: string; var Value: string): Boolean; protected // Internal function GetProviderSupport: IProviderSupport; procedure OnWhereChange(Sender: TObject); procedure PrepareSQLStatement; virtual; function GenerateDynamicWhereStatement: string; function SQLContainsDynamicWhere: boolean;safecall; // To be overridden function CreateDataset(aConnection: TDAEConnection): TDataset; virtual; abstract; procedure DoPrepare(Value: boolean); virtual; safecall; function DoExecute: integer; virtual; safecall; procedure DoSetSQL(const Value: string); virtual; safecall; abstract; function DoGetSQL: string; virtual; safecall;abstract; // IDASQLCommand function GetDataset: TDataset; safecall; function GetPrepared: boolean; safecall; procedure SetPrepared(Value: boolean); safecall; function GetParams: TDAParamCollection; safecall; procedure RefreshParams; virtual; safecall; function Execute: integer; virtual; safecall; function GetWhere: TDAWhere; safecall; deprecated; function GetDynamicWhere: TDAWhereBuilder; safecall; procedure SetDynamicWhere(const Value: TDAWhereBuilder);safecall; function GetSQL: string; safecall; procedure SetSQL(const Value: string); safecall; function GetName: string; safecall; function ParamByName(const aName: string): TDAParam; safecall; property Dataset: TDataset read GetDataset; property Changed: boolean read fChanged write fChanged; property Connection: TDAEConnection read fConnection; function GetOnAfterExecute: TDAAfterExecuteCommandEvent; safecall; function GetOnBeforeExecute: TDABeforeExecuteCommandEvent; safecall; procedure SetOnAfterExecute(const Value: TDAAfterExecuteCommandEvent); safecall; procedure SetOnBeforeExecute(const Value: TDABeforeExecuteCommandEvent); safecall; function GetOnExecuteError: TDAExecuteCommandErrorEvent; safecall; procedure SetOnExecuteError(const Value: TDAExecuteCommandErrorEvent); safecall; function intVCLTypeToDAType(aFieldType: TFieldType): TDADataType;virtual; public constructor Create(aConnection: TDAEConnection; const aName: string = ''); virtual; destructor Destroy; override; end; { TDAEDataset } TDAEDataset = class(TDAESQLCommand, IDASQLCommand, IDADataset) private fAutoFields: boolean; fFields: TDAFieldCollection; fLogicalName : string; fOnAfterOpen: TDAAfterOpenDatasetEvent; fOnBeforeOpen: TDABeforeOpenDatasetEvent; fOnOpenError: TDAOpenDatasetErrorEvent; protected function IsNeedCreateFieldDefs: Boolean; virtual; procedure CreateFieldDefs;virtual; function IsNeedToFixFMTBCDIssue: Boolean; virtual; procedure FixFMTBCDIssue; // To be overridden function DoGetRecordCount: integer; dynamic; function DoGetActive: boolean; dynamic; procedure DoSetActive(Value: boolean); dynamic; function DoGetBOF: boolean; dynamic; function DoGetEOF: boolean; dynamic; procedure DoNext; dynamic; function DoLocate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; dynamic; // IDADataset function GetRecordCount: integer; safecall; function GetFieldCount: integer; safecall; function GetFields: TDAFieldCollection; safecall; function GetActive: boolean; safecall; procedure SetActive(Value: boolean); safecall; function GetBOF: boolean; safecall; function GetEOF: boolean; safecall; function GetFieldValues(Index: integer): Variant; safecall; function GetNames(Index: integer): string; safecall; function GetIsEmpty : boolean; safecall; function GetState : TDatasetState; safecall; procedure Open; safecall; procedure Close; safecall; procedure EnableControls; safecall; procedure DisableControls; safecall; procedure Next; safecall; procedure Refresh; safecall; function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; safecall; function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; safecall; function FieldByName(const aName: string): TDAField; safecall; function FindField(const aName: string): TDAField; safecall; function GetBookMark: pointer; safecall; procedure GotoBookmark(Bookmark: TBookmark); safecall; procedure FreeBookmark(Bookmark: TBookmark); safecall; function GetLogicalName : string; safecall; procedure SetLogicalName(aName : string); safecall; function GetOnAfterOpen: TDAAfterOpenDatasetEvent; safecall; function GetOnBeforeOpen: TDABeforeOpenDatasetEvent; safecall; procedure SetOnAfterOpen(const Value: TDAAfterOpenDatasetEvent); safecall; procedure SetOnBeforeOpen(const Value: TDABeforeOpenDatasetEvent); safecall; function GetOnOpenError: TDAOpenDatasetErrorEvent; safecall; procedure SetOnOpenError(const Value: TDAOpenDatasetErrorEvent); safecall; function GetRowRecIdValue: integer; function GetCurrentRecIdValue: integer; procedure SetCurrentRecIdValue(Value: integer); procedure EnableConstraints; safecall; procedure DisableConstraints; safecall; public constructor Create(aConnection: TDAEConnection; const aName: string = ''); override; destructor Destroy; override; end; {$WARN SYMBOL_DEPRECATED ON} TDAEDatasetClass = class of TDAEDataset; {$WARN SYMBOL_DEPRECATED OFF} { TDAEStoredProcedure } TDAEStoredProcedure = class(TDAESQLCommand, IDASQLCommand, IDAStoredProcedure) private protected // Internal procedure DoPrepare(Value: boolean); override; procedure RefreshParams; override; safecall; // IDAStoredProcedure function GetStoredProcedureName: string; virtual; safecall; abstract; procedure SetStoredProcedureName(const Name: string); virtual; safecall; abstract; procedure PrepareSQLStatement; override; public end; {$WARN SYMBOL_DEPRECATED ON} TDAEStoredProcedureClass = class of TDAEStoredProcedure; { TDAEConnection } TDAEConnection = class(TDAEngineBaseObject, IDAConnection, IDAConnectionObjectAccess, IDATestableObject, IDAHasMacroProcessor) private fConnectionObject: TCustomConnection; fConnectionString: string; fConnectionManager: IDAConnectionManager; fConnectionDefinition: TDAConnection; fDriver: TDAEDriver; fUserID, fPassword, fName: string; fMacroProcessor: TDASQLMacroProcessor; fOnAfterExecuteCommand: TDAAfterExecuteCommandEvent; fOnAfterOpenDataset: TDAAfterOpenDatasetEvent; fOnBeforeOpenDataset: TDABeforeOpenDatasetEvent; fOnBeforeExecuteCommand: TDABeforeExecuteCommandEvent; fOnExecuteCommandError: TDAExecuteCommandErrorEvent; fOnOpenDatasetError: TDAOpenDatasetErrorEvent; fConnectionPool: IDAConnectionPool; fReleasing: Boolean; fUseMacroProcessor:Boolean; function CreateConnectionObject: TCustomConnection; protected fConnectionType: string; property ConnectionName: string read fName; property ConnectionManager: IDAConnectionManager read fConnectionManager; property ConnectionDefinition: TDAConnection read fConnectionDefinition; function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall; function GetConnectionPool: IDAConnectionPool; safecall; procedure SetConnectionPool(const Value: IDAConnectionPool); safecall; // To be overridden function CreateCustomConnection: TCustomConnection; virtual; abstract; function CreateMacroProcessor: TDASQLMacroProcessor; virtual; function GetDatasetClass: TDAEDatasetClass; virtual; function GetStoredProcedureClass: TDAEStoredProcedureClass; virtual; procedure DoApplyConnectionString(aConnStrParser: TDAConnectionStringParser; aConnectionObject: TCustomConnection); virtual; function DoBeginTransaction: integer; virtual; abstract; procedure DoCommitTransaction; virtual; abstract; procedure DoRollbackTransaction; virtual; abstract; function DoGetInTransaction: boolean; virtual; abstract; procedure DoGetTableNames(out List: IROStrings); virtual; procedure DoGetViewNames(out List: IROStrings); virtual; procedure DoGetStoredProcedureNames(out List: IROStrings); virtual; procedure DoGetTableFields(const aTableName: string; out Fields: TDAFieldCollection); virtual; procedure DoGetQueryFields(const aSQL: string; aParamsIfNeeded: TDAParamCollection; out Fields: TDAFieldCollection); virtual; procedure DoGetViewFields(const aViewName: string; out Fields: TDAFieldCollection); virtual; procedure DoGetStoredProcedureParams(const aStoredProcedureName: string; out Params: TDAParamCollection); virtual; procedure DoGetForeignKeys(out ForeignKeys: TDADriverForeignKeyCollection); virtual; function DoGetLastAutoInc(const GeneratorName: string): integer; virtual; // Misc procedure ApplyConnectionString(const aConnectionString: string; aConnectionObject: TCustomConnection); procedure AssignCommandEventHandlers(const aCommand: IDASQLCommand); procedure AssignDatasetEventHandlers(const aDataset: IDADataset); // IDAConnectionObjectAccess function GetConnectionObject: TObject; safecall; function GetConnectionProperties(const aPropertyName: string): Variant; safecall; procedure SetConnectionProperties(const aPropertyName: string; const aValue: Variant); safecall; // IDATestableObject procedure Test; virtual; safecall; // IDAConnection function GetConnectionString: string; safecall; procedure SetConnectionString(Value: string); safecall; function GetConnected: boolean; virtual; safecall; procedure SetConnected(Value: boolean); virtual; safecall; function GetName: string; safecall; function GetOnAfterExecuteCommand: TDAAfterExecuteCommandEvent; safecall; function GetOnAfterOpenDataset: TDAAfterOpenDatasetEvent; safecall; function GetOnBeforeExecuteCommand: TDABeforeExecuteCommandEvent; safecall; function GetOnBeforeOpenDataset: TDABeforeOpenDatasetEvent; safecall; function GetOnExecuteCommandError: TDAExecuteCommandErrorEvent; safecall; function GetOnOpenDatasetError: TDAOpenDatasetErrorEvent; safecall; procedure SetOnAfterExecuteCommand(const Value: TDAAfterExecuteCommandEvent); safecall; procedure SetOnAfterOpenDataset(const Value: TDAAfterOpenDatasetEvent); safecall; procedure SetOnBeforeExecuteCommand(const Value: TDABeforeExecuteCommandEvent); safecall; procedure SetOnBeforeOpenDataset(const Value: TDABeforeOpenDatasetEvent); safecall; procedure SetOnExecuteCommandError(const Value: TDAExecuteCommandErrorEvent); safecall; procedure SetOnOpenDatasetError(const Value: TDAOpenDatasetErrorEvent); safecall; procedure Open(const aUserID: string = ''; const aPassword: string = ''); safecall; procedure Close; safecall; // UserID/Password function GetUserID: string; virtual; safecall; procedure SetUserID(const Value: string); virtual; safecall; function GetPassword: string; virtual; safecall; procedure SetPassword(const Value: string); virtual; safecall; function BeginTransaction: integer; safecall; procedure CommitTransaction; safecall; procedure RollbackTransaction; safecall; function GetInTransaction: boolean; safecall; procedure GetTableNames(out List: IROStrings); safecall; procedure GetViewNames(out List: IROStrings); safecall; procedure GetStoredProcedureNames(out List: IROStrings); safecall; procedure GetTableFields(const aTableName: string; out Fields: TDAFieldCollection); safecall; procedure GetQueryFields(const aSQL: string; aParamsIfNeeded: TDAParamCollection; out Fields: TDAFieldCollection); safecall; procedure GetViewFields(const aViewName: string; out Fields: TDAFieldCollection); safecall; procedure GetStoredProcedureParams(const aStoredProcedureName: string; out Params: TDAParamCollection); safecall; procedure GetForeignKeys(out ForeignKeys: TDADriverForeignKeyCollection); safecall; function GetSPSelectSyntax(HasArguments: Boolean): string; virtual; safecall; function GetQuoteChars: TDAQuoteCharArray; virtual; safecall; function IdentifierIsQuoted(const iIdentifier: string): boolean; virtual; safecall; function IdentifierNeedsQuoting(const iIdentifier: string): boolean; virtual; safecall; function QuoteIdentifierIfNeeded(const iIdentifier: string): string; virtual; safecall; function QuoteIdentifier(const iIdentifier: string): string; virtual; safecall; function QuoteFieldNameIfNeeded(const aTableName, aFieldName: string): string; virtual;safecall; function QuoteFieldName(const aTableName, aFieldName: string): string; virtual; safecall; function NewCommand(const Text: string; CommandType: TDASQLStatementType; const aCommandName: string = ''): IDASQLCommand; virtual; safecall; function NewDataset(const SQL: string; const aDatasetName: string = ''): IDADataset; virtual; safecall; function GetLastAutoInc(const GeneratorName: string = ''): integer; safecall; property UserID: string read GetUserID write SetUserID; property Password: string read GetPassword write SetPassword; property ConnectionObject: TCustomConnection read fConnectionObject write fConnectionObject; function GetMacroProcessor: TDASQLMacroProcessor; function _Release: Integer; override; stdcall; function isAlive: Boolean; virtual; safecall; function GetConnectionType: string; safecall; property ConnectionType: string read GetConnectionType; function GetQueryBuilder: TDAQueryBuilder; virtual; safecall; function GetWhereBuilder: TDASQLWhereBuilder; virtual; safecall; function GetUseMacroProcessor: Boolean; safecall; procedure SetUseMacroProcessor(Value:Boolean); safecall; public constructor Create(aDriver: TDAEDriver; aName: string = ''); virtual; destructor Destroy; override; property ConnectionPool: IDAConnectionPool read GetConnectionPool write SetConnectionPool; property Driver: TDAEDriver read fDriver; property MacroProcessor: TDASQLMacroProcessor read GetMacroProcessor; end; TDAEConnectionClass = class of TDAEConnection; { TDAEDriver } TDAEDriver = class(TComponent, IDADriver, IDADriver30) private protected // To be overridden function GetConnectionClass: TDAEConnectionClass; virtual; abstract; procedure CustomizeConnectionObject(aConnection: TDAEConnection); dynamic; procedure DoSetTraceOptions(TraceActive: boolean; TraceFlags: TDATraceOptions; Callback: TDALogTraceEvent); virtual; { IDADriver } function GetDriverID: string; virtual; safecall; abstract; function GetDescription: string; virtual; safecall; abstract; function GetMajVersion: byte; virtual; safecall; function GetMinVersion: byte; virtual; safecall; procedure GetAuxDrivers(out List: IROStrings); virtual; safecall; procedure GetAuxParams(const AuxDriver: string; out List: IROStrings); virtual; safecall; function GetDefaultConnectionType(const AuxDriver: string): string; virtual; safecall; procedure SetTraceOptions(TraceActive: boolean; TraceFlags: TDATraceOptions; Callback: TDALogTraceEvent); safecall; function NewConnection(const aName: string = ''; const aConnectionType: string = ''): IDAConnection; overload; {deprecated;} safecall; function NewConnection(const aConnectionManager: IDAConnectionManager; aConnectionDefinition: TDAConnection): IDAConnection; overload; safecall; procedure Initialize; virtual; safecall; procedure Finalize; virtual; safecall; function GetAvailableDriverOptions: TDAAvailableDriverOptions; virtual; safecall; function GetDefaultCustomParameters: string; virtual; safecall; { IDADriver30 } function GetDriverHelp(aType: TDADriverHelpType): string; public destructor Destroy; override; end; TDAEDriverClass = class of TDAEDriver; { TDADriverReference } TDADriverReference = class(TComponent) end; {$IFDEF MSWINDOWS} function DAHandleSafeCallException(aObject:TObject; ExceptObject: TObject; ExceptAddr: Pointer): HResult; {$ENDIF MSWINDOWS} function Engine_GetDatabaseNames(aConnection:TDAEConnection; aMasterDatabase, aGetDatabaseNamesSQL: String): IROStrings; implementation uses {$IFDEF MSWINDOWS}Windows,{$ENDIF} Variants, TypInfo, uDAHelpers, uROClient, uDASQL92QueryBuilder, uROBinaryHelpers; function Engine_GetDatabaseNames(aConnection:TDAEConnection; aMasterDatabase, aGetDatabaseNamesSQL: String): IROStrings; var connStrParser : TDAConnectionStringParser; conn : IDAConnection; ds : IDAdataset; begin Result := NewROStrings; connStrParser := TDAConnectionStringParser.Create((aConnection as IDAConnection).ConnectionString); try connStrParser.Database := aMasterDatabase; conn := TDAEConnectionClass(aConnection.ClassType).Create(aConnection.Driver); conn.ConnectionString := connStrParser.BuildString; conn.Open; ds := conn.NewDataset(aGetDatabaseNamesSQL); ds.Open; while not ds.EOF do begin result.Add(VarToStr(ds.FieldValues[0])); ds.Next; end; finally connStrParser.Free; conn := nil; ds := nil; end; end; { TDAEDriver } destructor TDAEDriver.Destroy; begin SetTraceOptions(FALSE, [], nil); inherited; end; procedure TDAEDriver.Initialize; begin end; procedure TDAEDriver.Finalize; begin end; function TDAEDriver.GetMajVersion: byte; begin result := 1 end; function TDAEDriver.GetMinVersion: byte; begin result := 0 end; function TDAEDriver.NewConnection(const aName: string = '';const aConnectionType: string = ''): IDAConnection; var conn: TDAEConnection; begin conn := GetConnectionClass.Create(Self, aName); conn.FConnectionType := aConnectionType; CustomizeConnectionObject(conn); // In some cases the driver might need to do additional customization result := conn; end; function TDAEDriver.NewConnection(const aConnectionManager: IDAConnectionManager; aConnectionDefinition: TDAConnection): IDAConnection; var conn: TDAEConnection; begin conn := GetConnectionClass.Create(Self, aConnectionDefinition.Name); conn.fConnectionType := aConnectionDefinition.ConnectionType; conn.fConnectionManager := aConnectionManager; conn.fConnectionDefinition := aConnectionDefinition; CustomizeConnectionObject(conn); // In some cases the driver might need to do additional customization result := conn; end; function TDAEDriver.GetAvailableDriverOptions: TDAAvailableDriverOptions; begin //result := [doAuxDriver,doServerName,doDatabaseName,doLogin,doCustom]; result := [doServerName, doDatabaseName, doLogin]; end; function TDAEDriver.GetDefaultConnectionType(const AuxDriver: string): string; begin result := ''; end; function TDAEDriver.GetDefaultCustomParameters: string; begin result := ''; end; procedure TDAEDriver.SetTraceOptions(TraceActive: boolean; TraceFlags: TDATraceOptions; Callback: TDALogTraceEvent); begin if (csDesigning in ComponentState) then Exit; DoSetTraceOptions(TraceActive, TraceFlags, Callback); end; procedure TDAEDriver.CustomizeConnectionObject(aConnection: TDAEConnection); begin end; procedure TDAEDriver.DoSetTraceOptions(TraceActive: boolean; TraceFlags: TDATraceOptions; Callback: TDALogTraceEvent); begin end; procedure TDAEDriver.GetAuxDrivers(out List: IROStrings); begin List := NewROStrings(); end; procedure TDAEDriver.GetAuxParams(const AuxDriver: string; out List: IROStrings); begin List := NewROStrings(); end; function TDAEDriver.GetDriverHelp(aType: TDADriverHelpType): string; begin result := LoadHtmlFromResource(hInstance, 'DRIVER_HELP'); end; { TDAEConnection } constructor TDAEConnection.Create(aDriver: TDAEDriver; aName: string = ''); begin inherited Create; fName := aName; fDriver := aDriver; fConnectionObject := CreateConnectionObject; FUseMacroProcessor := True; end; destructor TDAEConnection.Destroy; begin if Assigned(fConnectionObject) then begin try if fConnectionObject.Connected then fConnectionObject.Close; except end; FreeAndNIL(fConnectionObject); end; if Assigned(fMacroProcessor) then fMacroProcessor.Free; inherited; end; function TDAEConnection.GetConnected: boolean; begin result := assigned(fConnectionObject) and fConnectionObject.Connected; end; function TDAEConnection.GetConnectionString: string; begin result := fConnectionString; end; procedure TDAEConnection.SetConnected(Value: boolean); begin if fConnectionObject <> nil then fConnectionObject.Connected := Value; end; procedure TDAEConnection.SetConnectionString(Value: string); begin if (Value = fConnectionString) then Exit; ApplyConnectionString(Value, fConnectionObject); end; function TDAEConnection.GetConnectionObject: TObject; begin result := fConnectionObject; end; function TDAEConnection.GetConnectionProperties( const aPropertyName: string): Variant; begin if assigned(fConnectionObject) then result := GetPropValue(fConnectionObject, aPropertyName, FALSE) else result := Unassigned; end; procedure TDAEConnection.SetConnectionProperties( const aPropertyName: string; const aValue: Variant); begin if assigned(fConnectionObject) then SetPropValue(fConnectionObject, aPropertyName, aValue); end; procedure TDAEConnection.Close; begin SetConnected(FALSE); // Exceptions are handled there end; procedure TDAEConnection.Open(const aUserID: string = ''; const aPassword: string = ''); begin if (aUserID <> '') then UserID := aUserID; if (aPassword <> '') then Password := aPassword; SetConnected(TRUE); // Exceptions are handled there end; function TDAEConnection.CreateConnectionObject: TCustomConnection; begin result := CreateCustomConnection; end; function TDAEConnection.NewDataset(const SQL: string; const aDatasetName: string = ''): IDADataset; begin result := GetDatasetClass.Create(Self, aDatasetName); result.SQL := SQL; AssignDatasetEventHandlers(result); // Propagates the event handlers to all datasets end; function TDAEConnection.NewCommand(const Text: string; CommandType: TDASQLStatementType; const aCommandName: string = ''): IDASQLCommand; var sp: IDAStoredProcedure; ds: IDADataset; begin result := nil; case CommandType of stStoredProcedure: begin sp := GetStoredProcedureClass.Create(Self, aCommandName); sp.StoredProcedureName := Text; result := sp; end; stSQL: begin ds := GetDatasetClass.Create(Self, aCommandName); ds.SQL := Text; result := ds; end; end; if Result <> nil then Result.RefreshParams; AssignCommandEventHandlers(result); // Propagates the event handlers to all commands end; function TDAEConnection.BeginTransaction: integer; begin result := -1; DoBeginTransaction; end; procedure TDAEConnection.CommitTransaction; begin DoCommitTransaction; end; procedure TDAEConnection.RollbackTransaction; begin DoRollbackTransaction; end; procedure TDAEConnection.GetStoredProcedureNames(out List: IROStrings); begin DoGetStoredProcedureNames(List); end; procedure TDAEConnection.GetStoredProcedureParams( const aStoredProcedureName: string; out Params: TDAParamCollection); begin DoGetStoredProcedureParams(aStoredProcedureName, Params); end; procedure TDAEConnection.GetForeignKeys(out ForeignKeys: TDADriverForeignKeyCollection); begin DoGetForeignKeys(ForeignKeys); end; procedure TDAEConnection.GetTableFields(const aTableName: string; out Fields: TDAFieldCollection); begin DoGetTableFields(aTableName, Fields); end; procedure TDAEConnection.GetQueryFields(const aSQL: string; aParamsIfNeeded: TDAParamCollection; out Fields: TDAFieldCollection); begin DoGetQueryFields(aSQL, aParamsIfNeeded, Fields); end; procedure TDAEConnection.GetTableNames(out List: IROStrings); begin DoGetTableNames(List); end; procedure TDAEConnection.GetViewFields(const aViewName: string; out Fields: TDAFieldCollection); begin DoGetViewFields(aViewName, Fields); end; procedure TDAEConnection.GetViewNames(out List: IROStrings); begin DoGetViewNames(List); end; function TDAEConnection.GetWhereBuilder: TDASQLWhereBuilder; begin Result:= TDASQL92WhereBuilder.Create(Self); end; function TDAEConnection.GetDatasetClass: TDAEDatasetClass; begin result := nil; end; function TDAEConnection.GetStoredProcedureClass: TDAEStoredProcedureClass; begin result := nil; end; procedure TDAEConnection.DoGetTableFields(const aTableName: string; out Fields: TDAFieldCollection); var qry: IDADataset; begin Fields := TDAFieldCollection.Create(nil); qry := GetDatasetClass.Create(Self); try qry.SQL := 'SELECT * FROM ' + QuoteIdentifierIfNeeded(aTableName) + ' WHERE 1=0'; qry.Open; Fields.Assign(qry.Fields); finally qry := nil; end; end; procedure TDAEConnection.DoGetQueryFields(const aSQL: string; aParamsIfNeeded: TDAParamCollection; out Fields: TDAFieldCollection); var qry: IDADataset; begin Fields := TDAFieldCollection.Create(nil); qry := GetDatasetClass.Create(Self); try qry.SQL := aSQL; if assigned(aParamsIfNeeded) then qry.Params.AssignParamCollection(aParamsIfNeeded); qry.Open; Fields.Assign(qry.Fields); finally qry := nil; end; end; procedure TDAEConnection.DoGetStoredProcedureParams(const aStoredProcedureName: string; out Params: TDAParamCollection); var cmd: IDASQLCommand; begin //Params := nil; cmd := NewCommand(aStoredProcedureName, stStoredProcedure); cmd.RefreshParams; {if (Params = nil) then} Params := TDAParamCollection.Create(nil); Params.AssignParamCollection(cmd.Params); end; procedure TDAEConnection.DoGetForeignKeys(out ForeignKeys: TDADriverForeignKeyCollection); begin ForeignKeys := TDADriverForeignKeyCollection.Create(nil); end; function TDAEConnection.GetName: string; begin result := fName; end; procedure TDAEConnection.DoGetViewFields(const aViewName: string; out Fields: TDAFieldCollection); begin DoGetTableFields(aViewName, Fields); end; function TDAEConnection.GetQuoteChars: TDAQuoteCharArray; begin result[0] := '"'; result[1] := '"'; end; procedure TDAEConnection.DoGetViewNames(out List: IROStrings); begin List := NewROStrings; // Changed from NIL. end; procedure TDAEConnection.DoGetStoredProcedureNames(out List: IROStrings); begin List := NewROStrings; // Changed from NIL. end; procedure TDAEConnection.DoGetTableNames(out List: IROStrings); begin List := NewROStrings; // Changed from NIL. end; function TDAEConnection.GetInTransaction: boolean; begin result := DoGetInTransaction; end; function TDAEConnection.GetPassword: string; begin result := fPassword; end; function TDAEConnection.GetUserID: string; begin result := fUserID; end; procedure TDAEConnection.SetPassword(const Value: string); begin fPassword := Value; ApplyConnectionString(GetConnectionString, ConnectionObject); // Refreshes it end; procedure TDAEConnection.SetUserID(const Value: string); begin fUserID := Value; ApplyConnectionString(GetConnectionString, ConnectionObject); // Refreshes it end; function TDAEConnection.GetLastAutoInc( const GeneratorName: string): integer; begin result := DoGetLastAutoInc(GeneratorName); end; function TDAEConnection.DoGetLastAutoInc( const GeneratorName: string): integer; begin result := -1; end; function TDAEConnection.IdentifierIsQuoted(const iIdentifier: string): boolean; var lQuoteChars: TDAQuoteCharArray; lLength:integer; begin lQuoteChars := GetQuoteChars(); lLength := Length(iIdentifier); result := (lLength > 2) and (iIdentifier[1] = lQuoteChars[0]) and (iIdentifier[lLength] = lQuoteChars[1]); end; function TDAEConnection.IdentifierNeedsQuoting(const iIdentifier: string): boolean; var i: integer; begin result := false; if IdentifierIsQuoted(iIdentifier) then Exit; for i := 1 to Length(iIdentifier) do begin if not (iIdentifier[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '.']) then begin result := true; exit; end; end; end; function TDAEConnection.QuoteIdentifierIfNeeded(const iIdentifier: string): string; begin if IdentifierNeedsQuoting(iIdentifier) then result := QuoteIdentifier(iIdentifier) else result := iIdentifier; end; function TDAEConnection.QuoteIdentifier(const iIdentifier: string): string; var lQuoteChars: TDAQuoteCharArray; begin lQuoteChars := GetQuoteChars(); if (Pos('.', iIdentifier)>0) then result := lQuoteChars[0] + StringReplace(iIdentifier, '.', lQuoteChars[1]+'.'+ lQuoteChars[0], [rfReplaceAll]) + lQuoteChars[1] else result := lQuoteChars[0] + iIdentifier + lQuoteChars[1]; end; function TDAEConnection.CreateMacroProcessor: TDASQLMacroProcessor; begin {$WARNINGS OFF} result := TDASQLMacroProcessor.Create; {$WARNINGS ON} end; procedure TDAEConnection.ApplyConnectionString( const aConnectionString: string; aConnectionObject: TCustomConnection); var i: Integer; lParamName: String; lConnStrParser: TDAConnectionStringParser; begin FreeAndNIL(fMacroProcessor); lConnStrParser := TDAConnectionStringParser.Create(aConnectionString); try fConnectionString := aConnectionString; DoApplyConnectionString(lConnStrParser, aConnectionObject); //with lConnStrParser do if aConnectionObject <> nil then begin for i := 0 to lConnStrParser.AuxParamsCount - 1 do begin lParamName := lConnStrParser.AuxParamNames[i]; if Assigned(GetPropInfo(aConnectionObject, lParamName)) then begin SetConnectionProperties(lParamName, lConnStrParser.AuxParams[lParamName]); end; end; end; finally lConnStrParser.Free; end; fMacroProcessor := CreateMacroProcessor; end; procedure TDAEConnection.DoApplyConnectionString( aConnStrParser: TDAConnectionStringParser; aConnectionObject: TCustomConnection); begin if (aConnectionObject <> nil) then aConnectionObject.Close; end; function TDAEConnection.GetOnAfterExecuteCommand: TDAAfterExecuteCommandEvent; begin result := fOnAfterExecuteCommand end; function TDAEConnection.GetOnAfterOpenDataset: TDAAfterOpenDatasetEvent; begin result := fOnAfterOpenDataset end; function TDAEConnection.GetOnBeforeExecuteCommand: TDABeforeExecuteCommandEvent; begin result := fOnBeforeExecuteCommand end; function TDAEConnection.GetOnBeforeOpenDataset: TDABeforeOpenDatasetEvent; begin result := fOnBeforeOpenDataset end; function TDAEConnection.GetOnExecuteCommandError: TDAExecuteCommandErrorEvent; begin result := fOnExecuteCommandError end; function TDAEConnection.GetOnOpenDatasetError: TDAOpenDatasetErrorEvent; begin result := fOnOpenDatasetError end; procedure TDAEConnection.SetOnAfterExecuteCommand( const Value: TDAAfterExecuteCommandEvent); begin fOnAfterExecuteCommand := Value; end; procedure TDAEConnection.SetOnAfterOpenDataset( const Value: TDAAfterOpenDatasetEvent); begin fOnAfterOpenDataset := Value; end; procedure TDAEConnection.SetOnBeforeExecuteCommand( const Value: TDABeforeExecuteCommandEvent); begin fOnBeforeExecuteCommand := Value; end; procedure TDAEConnection.SetOnBeforeOpenDataset( const Value: TDABeforeOpenDatasetEvent); begin fOnBeforeOpenDataset := Value; end; procedure TDAEConnection.SetOnExecuteCommandError( const Value: TDAExecuteCommandErrorEvent); begin fOnExecuteCommandError := Value; end; procedure TDAEConnection.SetOnOpenDatasetError( const Value: TDAOpenDatasetErrorEvent); begin fOnOpenDatasetError := Value; end; procedure TDAEConnection.AssignCommandEventHandlers( const aCommand: IDASQLCommand); begin if aCommand=NIL then Exit; aCommand.OnBeforeExecute := fOnBeforeExecuteCommand; aCommand.OnAfterExecute := fOnAfterExecuteCommand; aCommand.OnExecuteError := fOnExecuteCommandError; end; procedure TDAEConnection.AssignDatasetEventHandlers( const aDataset: IDADataset); begin if aDataset=NIL then Exit; aDataset.OnBeforeOpen := fOnBeforeOpenDataset; aDataset.OnAfterOpen := fOnAfterOpenDataset; aDataset.OnOpenError := fOnOpenDatasetError; end; procedure TDAEConnection.Test; begin Open; Close; end; function TDAEConnection.GetSPSelectSyntax(HasArguments: Boolean): string; begin Result := 'EXEC {0} {1}'; end; function TDAEConnection.GetMacroProcessor: TDASQLMacroProcessor; begin if FUseMacroProcessor then result := fMacroProcessor else Result := nil; end; function TDAEConnection._Release: Integer; begin Result := InterlockedDecrement(FRefCount); if (Result = 0) and not (fReleasing) then begin fReleasing := True; InterlockedIncrement(fRefCount); if assigned(fConnectionPool) then fConnectionPool.ReleaseConnection(self); Result := InterlockedDecrement(fRefCount); fReleasing := False; end; if Result = 0 then Destroy; end; function TDAEConnection.GetConnectionPool: IDAConnectionPool; begin result := fConnectionPool; end; procedure TDAEConnection.SetConnectionPool(const Value: IDAConnectionPool); begin fConnectionPool := Value; end; function TDAEConnection.QuoteFieldName(const aTableName, aFieldName: string): string; begin Result:= QuoteIdentifier(aFieldName); end; function TDAEConnection.QuoteFieldNameIfNeeded(const aTableName, aFieldName: string): string; begin if IdentifierNeedsQuoting(aFieldName) then result := QuoteFieldName(aTableName,aFieldName) else result := aFieldName; end; function TDAEConnection.isAlive: Boolean; begin Result:= (ConnectionObject <> nil) and ConnectionObject.Connected; end; function TDAEConnection.GetConnectionType: string; begin Result:= FConnectionType; end; function TDAEConnection.GetQueryBuilder: TDAQueryBuilder; begin Result:= TDASQL92QueryBuilder.Create; Result.Connection:=Self; end; function TDAEConnection.GetUseMacroProcessor: Boolean; begin Result := FUseMacroProcessor; end; procedure TDAEConnection.SetUseMacroProcessor(Value: Boolean); begin FUseMacroProcessor := Value; end; function TDAEConnection.QueryInterface(const IID: TGUID; out Obj): HResult; begin Result:= E_NOINTERFACE; if IsEqualGUID(IID, IDAHasMacroProcessor) then begin if not FUseMacroProcessor then Exit; end; Result := inherited QueryInterface(IID, Obj) end; { TDAEDataset } constructor TDAEDataset.Create(aConnection: TDAEConnection; const aName: string = ''); begin inherited; fLogicalName := aName; if (fLogicalName='') then fLogicalName := NewGuidAsString; fChanged := true; fFields := TDAFieldCollection.Create(nil); {$WARN SYMBOL_DEPRECATED OFF} GetWhere.Fields := fFields; // So it can find the mappings! {$WARN SYMBOL_DEPRECATED ON} end; destructor TDAEDataset.Destroy; begin FreeAndNil(fDataset); FreeAndNil(fFields); FreeAndNil(fWhere); inherited; end; function TDAEDataset.GetActive: boolean; begin result := DoGetActive end; function TDAEDataset.GetBOF: boolean; begin result := DoGetBOF end; function TDAEDataset.GetEOF: boolean; begin result := DoGetEOF; end; function TDAEDataset.GetFieldCount: integer; begin result := fFields.Count; end; function TDAEDataset.GetRecordCount: integer; begin result := DoGetRecordCount; end; function TDAEDataset.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; begin result := DoLocate(KeyFields, KeyValues, Options); end; procedure TDAEDataset.Next; begin DoNext; end; procedure TDAEDataset.Open; begin SetActive(TRUE); // Handles the exception there end; procedure TDAEDataset.Close; begin SetActive(FALSE); // Handles the exception there end; procedure TDAEDataset.SetActive(Value: boolean); begin DoSetActive(Value); end; function TDAEDataset.GetFields: TDAFieldCollection; begin result := fFields end; function TDAEDataset.DoGetActive: boolean; begin result := fDataset.Active end; function TDAEDataset.DoGetBOF: boolean; begin result := fDataset.BOF end; function TDAEDataset.DoGetEOF: boolean; begin result := fDataset.EOF end; function TDAEDataset.DoGetRecordCount: integer; begin result := fDataset.RecordCount end; function TDAEDataset.DoLocate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; begin result := fDataset.Locate(KeyFields, KeyValues, Options); end; procedure TDAEDataset.DoNext; begin fDataset.Next end; procedure TDAEDataset.DoSetActive(Value: boolean); var i: integer; fld: TField; ps: IProviderSupport; dsparams: TParams; mspars: IDAMustSetParams; startTick: Cardinal; FNeedToFixFMTBCDIssue: Boolean; s: string; begin if (Value = GetActive) then Exit; // Opens the dataset if Value then begin // Combines the custom WHERE statement and modifies the inner SQL if fChanged or (fWhere.Changed) then PrepareSQLStatement; if Assigned(fConnection.fMacroProcessor) then begin i := fConnection.fMacroProcessor.IndexOfName('Where'); s := GenerateDynamicWhereStatement; if i = -1 then fConnection.fMacroProcessor.AddVariable('Where').Value:=s else fConnection.fMacroProcessor.Variable[i].Value:=s; if fDynamicWhere <> nil then For i:=0 to fDynamicWhere.Params.Count-1 do Self.GetParams.Add.AssignField(fDynamicWhere.Params[i]); SetSQL(fConnection.fMacroProcessor.Eval(GetSQL)); end; // Writes the parameter values if (fParams.Count > 0) then begin if Supports(Self, IDAMustSetParams, mspars) then mspars.SetParamValues(fParams) else begin ps := GetProviderSupport; if not Assigned(ps) then RaiseError(err_LAMEDataset, [fDataset.ClassName]); dsparams := ps.PSGetParams; if not Assigned(dsparams) then RaiseError(err_LAMEDataset, [fDataset.ClassName]); fParams.WriteValues(dsparams); end; end; startTick := ROGetTickCount; if Assigned(fOnBeforeOpen) then fOnBeforeOpen(Self); if IsNeedCreateFieldDefs then CreateFieldDefs; FNeedToFixFMTBCDIssue := (fDataset.FieldDefs.Count=0) and IsNeedToFixFMTBCDIssue; // Opens the dataset fAutoFields := (fFields.Count = 0); try fDataset.Open; if FNeedToFixFMTBCDIssue then FixFMTBCDIssue; except on E:Exception do begin if Assigned(fOnOpenError) then fOnOpenError(Self, DoGetSQL, E); raise; end; end; if Assigned(fOnAfterOpen) then fOnAfterOpen(Self, DoGetSQL, ROGetTickCount-startTick); if Supports(Self, IDAMustSetParams, mspars) then mspars.GetParamValues(fParams) else begin for i := 0 to fParams.Count-1 do begin if fParams[i].ParamType in [daptOutput, daptInputOutput, daptResult] then begin ps := GetProviderSupport; if not Assigned(ps) then RaiseError(err_LAMEDataset, [fDataset.ClassName]); dsparams := ps.PSGetParams; if not Assigned(dsparams) then RaiseError(err_LAMEDataset, [fDataset.ClassName]); fParams[i].Value := dsparams.ParamByName(fParams[i].Name).Value; end; end; end; if fAutoFields and (fFields.Count = 0)then begin for i := 0 to (fDataset.FieldCount - 1) do begin fld := fDataset.Fields[i]; with fFields.Add(fld.FieldName, intVCLTypeToDAType(fld.DataType), fld.Size) do begin if DataType = datDecimal then begin DecimalPrecision:= TFMTBCDField(fld).Precision; DecimalScale:= TFMTBCDField(fld).Size; end; Bind(fld); end; end; end else fFields.Bind(fDataset); end else begin if fAutoFields then fFields.Clear else fFields.Unbind; fDataset.Close; end; end; function TDAEDataset.GetFieldValues(Index: integer): Variant; begin With fFields[Index] do if (BindedField = nil) or (BindedField.IsNull) then Result:=Null else case BindedField.DataType of ftTimeStamp: result := BindedField.AsDateTime; ftFMTBcd: Result:= BCDToVariant(BindedField.AsBCD,True); ftBytes: Result := BindedField.Value; else result := fFields[Index].Value; end; end; function TDAEDataset.GetNames(Index: integer): string; begin result := fDataset.Fields[Index].Name end; procedure TDAEDataset.DisableControls; begin fDataset.DisableControls end; procedure TDAEDataset.EnableControls; begin fDataset.EnableControls end; function TDAEDataset.FieldByName(const aName: string): TDAField; begin result := fFields.FieldByName(aName) as TDAField; end; procedure TDAEDataset.FreeBookmark(Bookmark: TBookmark); begin Dataset.FreeBookmark(Bookmark); end; function TDAEDataset.GetBookMark: pointer; begin result := Dataset.GetBookmark end; procedure TDAEDataset.GotoBookmark(Bookmark: TBookmark); begin Dataset.GotoBookmark(Bookmark); end; procedure TDAEDataset.Refresh; begin end; function TDAEDataset.GetIsEmpty: boolean; begin result := fDataset.IsEmpty end; function TDAEDataset.GetState: TDatasetState; begin result := fDataset.State end; function TDAEDataset.Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; begin result := fDataset.Lookup(KeyFields, KeyValues, ResultFields); end; function TDAEDataset.GetLogicalName: string; begin result := fLogicalName; end; function TDAEDataset.FindField(const aName: string): TDAField; begin result := fFields.FindField(aName) as TDAField; end; procedure TDAEDataset.SetLogicalName(aName: string); begin fLogicalName := aName end; function TDAEDataset.GetOnAfterOpen: TDAAfterOpenDatasetEvent; begin result := fOnAfterOpen end; function TDAEDataset.GetOnBeforeOpen: TDABeforeOpenDatasetEvent; begin result := fOnBeforeOpen end; procedure TDAEDataset.SetOnAfterOpen( const Value: TDAAfterOpenDatasetEvent); begin fOnAfterOpen := Value end; procedure TDAEDataset.SetOnBeforeOpen( const Value: TDABeforeOpenDatasetEvent); begin fOnBeforeOpen := Value end; function TDAEDataset.GetOnOpenError: TDAOpenDatasetErrorEvent; begin result := fOnOpenError; end; procedure TDAEDataset.SetOnOpenError( const Value: TDAOpenDatasetErrorEvent); begin fOnOpenError := Value; end; function TDAEDataset.GetCurrentRecIdValue: integer; begin result := -1; end; procedure TDAEDataset.SetCurrentRecIdValue(Value: integer); begin end; function TDAEDataset.GetRowRecIdValue: integer; begin result := -1 end; procedure TDAEDataset.DisableConstraints; begin // do nothing end; procedure TDAEDataset.EnableConstraints; begin // do nothing end; function TDAEDataset.IsNeedCreateFieldDefs: Boolean; begin Result:=False; end; procedure TDAEDataset.CreateFieldDefs; var i: integer; fld: TFieldDef; dafld: TDAField; begin fDataset.FieldDefs.Clear; // Adds the data fields (non calculated) to the FieldDefs for i := 0 to (fFields.Count - 1) do begin dafld:=fFields[i]; if dafld.Calculated or dafld.Lookup then Continue; // Added as fields later fld := fDataset.FieldDefs.AddFieldDef; // (autoinc) if (dafld.DataType=datLargeAutoInc) then fld.DataType := ftLargeint else if (dafld.DataType=datAutoInc) then fld.DataType := ftInteger else fld.DataType := DATypeToVCLType(dafld.DataType); fld.Name := dafld.Name; {if not (fld.DataType in [ftFloat, ftCurrency, ftBlob, ftInteger]) then fld.Size := Fields[i].Size;} if (fld.DataType = ftString) or (fld.DataType = ftWideString) then fld.Size := dafld.Size; if (fld.DataType = ftGuid) then fld.Size := 38; if (fld.DataType = ftFMTBcd) then begin fld.Size:=dafld.DecimalScale; fld.Precision:=dafld.DecimalPrecision; end; end; // Creates the data fields for i := 0 to (fDataset.FieldDefs.Count - 1) do fDataset.FieldDefs[i].CreateField(fDataset).DataSet := fDataset; end; function TDAEDataset.IsNeedToFixFMTBCDIssue: Boolean; begin Result:= False; end; procedure TDAEDataset.FixFMTBCDIssue; var i: integer; lNeedToFix: Boolean; fld: TField; begin lNeedToFix:= False; for i:=0 to fDataset.Fields.Count-1 do if (fDataset.Fields[i].DataType = ftFMTBcd) and (TFMTBCDField(fDataset.Fields[i]).Precision=15) and (TFMTBCDField(fDataset.Fields[i]).Size=4) then begin lNeedToFix:=True; Break; end; if not lNeedToFix then Exit; for i := 0 to (fDataset.FieldCount - 1) do begin fld := fDataset.Fields[i]; with fFields.Add(fld.FieldName, intVCLTypeToDAType(fld.DataType), fld.Size) do if DataType = datDecimal then begin DecimalPrecision:= TFMTBCDField(fld).Precision; DecimalScale:= TFMTBCDField(fld).Size; if (DecimalPrecision =15 ) and (DecimalScale=4) then begin DecimalPrecision:=24; DecimalScale:=8; end; end; end; fDataset.Close; CreateFieldDefs; fDataset.Open; end; { TDAESQLCommand } constructor TDAESQLCommand.Create(aConnection: TDAEConnection; const aName: string = ''); var id: TGUID; begin inherited Create; fName := aName; if (fName = '') then begin CreateGUID(id); fName := GUIDToString(id); end; fWhere := TDAWhere.Create(nil, FALSE); fDynamicWhere:= nil;// aConnection.GetWhereBuilder; fConnection := aConnection; fParams := TDAParamCollection.Create(nil); fDataset := CreateDataset(fConnection); end; destructor TDAESQLCommand.Destroy; begin fDataset.Free; fParams.Free; fWhere.Free; fDynamicWhere.Free; inherited; end; function TDAESQLCommand.GetWhere: TDAWhere; begin result := fWhere; end; function TDAESQLCommand.GetParams: TDAParamCollection; begin result := fParams; end; function TDAESQLCommand.GetProviderSupport: IProviderSupport; begin result := uDAUtils.GetProviderSupport(fDataset); end; function TDAESQLCommand.ParamByName(const aName: string): TDAParam; begin result := fParams.ParamByName(aName) end; procedure TDAESQLCommand.RefreshParams; var lParams: TParams; lSQL: string; i: integer; par: TDAParam; begin //dsparams := GetProviderSupport.PSGetParams; lParams := TParams.Create; try { Bug in ParseSQL modified passed in string; use UniqueString to prevent corrupting the original! } lSQL := fSQL; UniqueString(lSQL); lParams.ParseSQL(lSQL, TRUE); fParams.Clear; for i := 0 to (lParams.Count - 1) do begin if fParams.FindParam(lParams[i].Name) <> nil then Continue; par := fParams.Add; par.Name := lParams[i].Name; par.DataType := intVCLTypeToDAType(lParams[i].DataType); par.ParamType := TDAParamType(lParams[i].ParamType); par.Size := lParams[i].Size; end; finally lParams.Free; end; end; procedure TDAESQLCommand.SetPrepared(Value: boolean); begin if (fPrepared <> Value) then begin fPrepared := Value; if fPrepared then PrepareSQLStatement(); end; end; function TDAESQLCommand.GetPrepared: boolean; begin result := fPrepared; end; procedure TDAESQLCommand.OnWhereChange(Sender: TObject); begin Changed := true; PrepareSQLStatement(); end; function TDAESQLCommand.Execute: integer; var ps: IProviderSupport; dsparams: TParams; mspars: IDAMustSetParams; startTick: cardinal; begin //result := -1; // Combines the custom WHERE statement and modifies the inner SQL if fChanged then PrepareSQLStatement; // Writes the parameter values if (fParams.Count > 0) then begin // ADOExpress does not use TParams so we mush use this trick if Supports(Self, IDAMustSetParams, mspars) then mspars.SetParamValues(fParams) // All the others instead return a reference to the TParams object else begin ps := GetProviderSupport; dsparams := ps.PSGetParams; fParams.WriteValues(dsparams); end; end; startTick := ROGetTickCount; if Assigned(fOnBeforeExecute) then fOnBeforeExecute(Self); try result := DoExecute; except on E:Exception do begin if Assigned(fOnExecuteError) then fOnExecuteError(Self, DoGetSQL, E); raise; end; end; if Supports(Self, IDAMustSetParams, mspars) then mspars.GetParamValues(fParams) else begin ps := GetProviderSupport; dsparams := ps.PSGetParams; fParams.ReadValues(dsparams); end; if Assigned(fOnAfterExecute) then fOnAfterExecute(Self, DoGetSQL, ROGetTickCount-startTick); end; procedure TDAESQLCommand.PrepareSQLStatement; var temp, sql, wheretext: string; orderbypos, wherepos: integer; i: integer; s: string; begin // Commented out because done above now //if not fChanged then Exit; // Avoids resetting it or repreparing sql := fSQL; try fWhere.Changed := False; if (fWhere.Clause = '') then Exit; temp := UpperCase(sql); // TODO: Not exactly the best way to do it. Might conflict with a field name that contains WHERE and might // not work if the user writes "ORDER BY"... We'll fix later with a tokenizer or a real parser of some sort orderbypos := Pos('GROUP BY', temp); if (orderbypos = 0) then orderbypos := Pos('ORDER BY', temp); wherepos := Pos('WHERE', temp); if (wherepos > 0) then wheretext := ' AND (' + fWhere.Clause + ') ' else wheretext := ' WHERE ' + fWhere.Clause + ' '; if (orderbypos > 0) then Insert(wheretext, sql, orderbypos) // Adds it before the Order By else Insert(wheretext, sql, Length(sql) + 1); // Adds it at the end since there's no Order By finally // Sets the SQL of the wrapped dataset if Assigned(fConnection.fMacroProcessor) then begin i := fConnection.fMacroProcessor.IndexOfName('Where'); s := GenerateDynamicWhereStatement; if i = -1 then fConnection.fMacroProcessor.AddVariable('Where').Value:=s else fConnection.fMacroProcessor.Variable[i].Value:=s; if fDynamicWhere <> nil then For i:=0 to fDynamicWhere.Params.Count-1 do Self.GetParams.Add.AssignField(fDynamicWhere.Params[i]); sql := fConnection.fMacroProcessor.Eval(sql); end; DoSetSQL(sql); DoPrepare(fPrepared); Changed := false; end; end; function TDAESQLCommand.DoExecute: integer; begin // Default implementation that should work for every dataset result := 0; GetProviderSupport.PSExecute; end; function TDAESQLCommand.GetSQL: string; begin result := fSQL end; procedure TDAESQLCommand.SetSQL(const Value: string); begin if Value <> fSQL then begin fSQL := Value; fChanged := true; PrepareSQLStatement(); end; end; function TDAESQLCommand.GetDataset: TDataset; begin result := fDataset; end; function TDAESQLCommand.GetName: string; begin result := fName; end; procedure TDAESQLCommand.DoPrepare(Value: boolean); begin SetPropValue(fDataset, 'Prepared', Value); // Works with ADO and IBX for now end; function TDAESQLCommand.GetOnAfterExecute: TDAAfterExecuteCommandEvent; begin result := fOnAfterExecute end; function TDAESQLCommand.GetOnBeforeExecute: TDABeforeExecuteCommandEvent; begin result := fOnBeforeExecute end; procedure TDAESQLCommand.SetOnAfterExecute( const Value: TDAAfterExecuteCommandEvent); begin fOnAfterExecute := Value end; procedure TDAESQLCommand.SetOnBeforeExecute( const Value: TDABeforeExecuteCommandEvent); begin fOnBeforeExecute := Value end; function TDAESQLCommand.GetOnExecuteError: TDAExecuteCommandErrorEvent; begin result := fOnExecuteError; end; procedure TDAESQLCommand.SetOnExecuteError( const Value: TDAExecuteCommandErrorEvent); begin fOnExecuteError := Value; end; function TDAESQLCommand.intVCLTypeToDAType( aFieldType: TFieldType): TDADataType; begin Result := VCLTypeToDAType(aFieldType); end; function TDAESQLCommand.GetDynamicWhere: TDAWhereBuilder; begin if fDynamicWhere = nil then fDynamicWhere := Connection.GetWhereBuilder; Result:=fDynamicWhere; end; procedure TDAESQLCommand.SetDynamicWhere(const Value: TDAWhereBuilder); begin if Value <> nil then GetDynamicWhere.Xml := Value.Xml else if fDynamicWhere <> nil then FDynamicWhere.Clear; end; function TDAESQLCommand.GenerateDynamicWhereStatement: string; begin if (fDynamicWhere <> nil) and not fDynamicWhere.IsEmpty then Result := fDynamicWhere.CreateWhereClause; if Result = '' then Result:= ' (1=1)'; end; function TDAESQLCommand.SQLContainsDynamicWhere: boolean; var mac: IDAHasMacroProcessor; lmp: TDASQLMacroProcessor; begin FIsPresentDynWhereVariable:=False; if Supports(fConnection, IDAHasMacroProcessor, mac) and (mac.GetMacroProcessor <> nil) then begin lmp:=TDASQLMacroProcessor(mac.GetMacroProcessor.NewInstance).Create; With lmp do try OnUnknownIdentifier := UnknownIdentifier; Eval(GetSQL); finally Free; end; end; Result:= FIsPresentDynWhereVariable; end; function TDAESQLCommand.UnknownIdentifier(Sender: TObject; const Name, OrgName: string; var Value: string): Boolean; begin if SameText(OrgName,'WHERE') then FIsPresentDynWhereVariable:=True; Value := OrgName; Result := True; end; { TDAEStoredProcedure } procedure TDAEStoredProcedure.DoPrepare(Value: boolean); begin // Stored procs don't need to be prepared end; procedure TDAEStoredProcedure.PrepareSQLStatement; begin // Stored procs don't need to be prepared end; procedure TDAEStoredProcedure.RefreshParams; var lParams: TParams; i: integer; par: TDAParam; begin lParams := GetProviderSupport.PSGetParams; fParams.Clear; for i := 0 to (lParams.Count - 1) do begin par := fParams.Add; par.Name := lParams[i].Name; par.DataType := intVCLTypeToDAType(lParams[i].DataType); par.ParamType := TDAParamType(lParams[i].ParamType); par.Size := lParams[i].Size; end; end; { TDASQLMacroProcessor } constructor TDASQLMacroProcessor.Create(const aDateFormat, aDateTimeFormat: string; aDoubleQuoteStrings: boolean; const aStoredProcParamsPrefix: string = ''); begin Create; fDateFormat := aDateFormat; fDateTimeFormat := aDateTimeFormat; fDoubleQuoteStrings := aDoubleQuoteStrings; fStoredProcParamPrefix := aStoredProcParamsPrefix; RegisterMacros; end; function TDASQLMacroProcessor.FormatDate(Sender: TObject; const Parameters: array of string): string; var dte: TDateTime; begin dte := StrToDate(StringReplace(Parameters[0], '''', '', [rfReplaceAll])); if fDoubleQuoteStrings then result := '"' + SysUtils.FormatDateTime(fDateFormat, dte) + '"' else result := '''' + SysUtils.FormatDateTime(fDateFormat, dte) + ''''; end; function TDASQLMacroProcessor.FormatDateTime(Sender: TObject; const Parameters: array of string): string; var dte: TDateTime; begin dte := StrToDateTime(StringReplace(Parameters[0], '''', '', [rfReplaceAll])); if fDoubleQuoteStrings then result := '"' + SysUtils.FormatDateTime(fDateTimeFormat, dte) + '"' else result := '''' + SysUtils.FormatDateTime(fDateTimeFormat, dte) + ''''; end; procedure TDASQLMacroProcessor.RegisterMacros; begin RegisterProc('Date', Date, 0); RegisterProc('DateTime', DateTime, 0); RegisterProc('AddTime', AddTime, 3); RegisterProc('FormatDateTime', FormatDateTime, 1); RegisterProc('FormatDate', FormatDate, 1); RegisterProc('Length', Length, 1); RegisterProc('LowerCase', LowerCase, 1); RegisterProc('UpperCase', UpperCase, 1); RegisterProc('TrimLeft', TrimLeft, 1); RegisterProc('TrimRight', TrimRight, 1); RegisterProc('Copy', Copy, 3); RegisterProc('NoLockHint', NoLock, 0); end; constructor TDASQLMacroProcessor.Create; begin inherited Create; OnUnknownIdentifier := MyUnknownIdentifier; end; function TDASQLMacroProcessor.Date(Sender: TObject; const Parameters: array of string): string; begin result := Self.DateTime(Sender, Parameters); end; function TDASQLMacroProcessor.MyUnknownIdentifier(Sender: TObject; const Name, OrgName: string; var Value: string): Boolean; begin Value := OrgName; Result := True; end; { TDAConnectionWrapper } procedure TDAConnectionWrapper.DoConnect; begin SetConnected(TRUE); end; procedure TDAConnectionWrapper.DoDisconnect; begin SetConnected(FALSE); end; {$IFDEF MSWINDOWS} { TDAEngineBaseObject } function TDAEngineBaseObject.InterfaceSupportsErrorInfo(const iid: TGUID): HRESULT; begin if GetInterfaceEntry(iid) <> nil then Result := S_OK else Result := S_FALSE; end; procedure TDAEngineBaseObject.OnException(const ServerClass, ExceptionClass, ErrorMessage: WideString; ExceptAddr: Integer; const ErrorIID, ProgID: WideString; var Handled: Integer; var Result: HRESULT); begin end; const DA_ERROR_ID : TGUID = '{E479A438-2640-41D2-9DC6-1560C1D08B79}'; function StringToWidestring(const aString: string): WideString; var I: Integer; begin SetLength(Result, Length(aString)); for i := 1 to Length(aString)-1 do Result[i] := WideChar(aString[I]); end; function DAHandleSafeCallException(aObject:TObject; ExceptObject: TObject; ExceptAddr: Pointer): HResult; var lClassName: string; E: TObject; CreateError: ICreateErrorInfo; ErrorInfo: IErrorInfo; begin Result := E_UNEXPECTED; E := ExceptObject; if Succeeded(CreateErrorInfo(CreateError)) then begin CreateError.SetGUID(DA_ERROR_ID); lClassName := aObject.ClassName; if MainInstance <> HInstance then lClassname := Format('%s in %s',[lClassName,ExtractFileName({$IFDEF FPC}ParamStr(0){$ELSE}GetModuleName(hInstance){$ENDIF})]); CreateError.SetSource(PWideChar(StringToWidestring(E.ClassName+': '+lClassName))); if E is Exception then begin CreateError.SetDescription(PWideChar(WideString(Exception(E).Message))); CreateError.SetHelpContext(Exception(E).HelpContext); if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then Result := EOleSysError(E).ErrorCode; end; if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then SetErrorInfo(0, ErrorInfo); end; end; function TDAEngineBaseObject.SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; begin Result := DAHandleSafeCallException(self, ExceptObject, ExceptAddr); end; procedure DASafeCallError(ErrorCode: Integer; ErrorAddr: Pointer); var lExceptionClass: ExceptClass; p: Integer; lSource: WideString; ErrorInfo: IErrorInfo; lDescription: WideString; lGuid: TGUID; begin if GetErrorInfo(0, ErrorInfo) = S_OK then begin ErrorInfo.GetDescription(lDescription); ErrorInfo.GetGUID(lGuid); if IsEqualGUID(lGuid,DA_ERROR_ID) then begin ErrorInfo.GetSource(lSource); p := Pos(':', lSource); if p > 0 then begin lExceptionClass := GetExceptionClass(copy(lSource,1,p-1)); if Assigned(lExceptionClass) then raise lExceptionClass.Create(lDescription); end; end; raise Exception.Create(lDescription) at ErrorAddr; end else begin raise Exception.Create('A "safecall" error occured, but the source object did not provide the proper error information. Sorry we cannot be more helpful at this time.') at ErrorAddr; end; end; initialization SafeCallErrorProc := @DASafeCallError; RegisterExceptionClass(EAbort); finalization UnregisterExceptionClass(EAbort); SafeCallErrorProc := nil; {$ENDIF} end.