Archivado/Componentes.Terceros.RemObjects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
e4d0fcb01d
Componentes.Terceros.RemObj.../internal/5.0.29.665/1/Data Abstract for Delphi/Source/uDAEngine.pas

2270 lines
73 KiB
ObjectPascal
Raw Blame History

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, IDAMustSetParams)
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;
procedure SetDynamicWhereParams;
procedure RemoveDynamicWhereParams;
protected
// Internal
procedure OnWhereChange(Sender: TObject);
procedure PrepareSQLStatement; virtual;
function GenerateDynamicWhereStatement: string;
function SQLContainsDynamicWhere: boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetParamValuesStd(Params1: TDAParamCollection;Params2: TParams);
procedure SetParamValuesStd(Params1: TDAParamCollection;Params2: TParams);
procedure ClearParams; virtual;
function FindParameter(const AParams: TParams;const AParamName: string): TParam;
// To be overridden
function CreateDataset(aConnection: TDAEConnection): TDataset; virtual; abstract;
procedure DoPrepare(Value: boolean); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function DoExecute: integer; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} abstract;
procedure DoSetSQL(const Value: string); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} abstract;
function DoGetSQL: string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}abstract;
// IDASQLCommand
function GetDataset: TDataset; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetPrepared: boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetPrepared(Value: boolean); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetParams: TDAParamCollection; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure RefreshParams; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function Execute: integer; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetWhere: TDAWhere; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} deprecated;
function GetDynamicWhere: TDAWhereBuilder; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetDynamicWhere(const Value: TDAWhereBuilder); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetSQL: string; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetSQL(const Value: string); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetName: string; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function ParamByName(const aName: string): TDAParam; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
property Dataset: TDataset read GetDataset;
property Changed: boolean read fChanged write fChanged;
property Connection: TDAEConnection read fConnection;
function GetOnAfterExecute: TDAAfterExecuteCommandEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnBeforeExecute: TDABeforeExecuteCommandEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnAfterExecute(const Value: TDAAfterExecuteCommandEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnBeforeExecute(const Value: TDABeforeExecuteCommandEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnExecuteError: TDAExecuteCommandErrorEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnExecuteError(const Value: TDAExecuteCommandErrorEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function intVCLTypeToDAType(aFieldType: TFieldType): TDADataType;virtual;
procedure SetParamValues(AParams: TDAParamCollection); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} abstract;
procedure GetParamValues(AParams: TDAParamCollection); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} abstract;
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 IsNeedToFixFMTBCDIssue: Boolean; virtual;
procedure FixKnownIssues;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; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetFieldCount: integer; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetFields: TDAFieldCollection; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetActive: boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetActive(Value: boolean); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetBOF: boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetEOF: boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetFieldValues(Index: integer): Variant; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetNames(Index: integer): string; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetIsEmpty : boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetState : TDatasetState; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure Open; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure Close; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure EnableControls; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure DisableControls; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function ControlsDisabled: Boolean;{$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure Next; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure Refresh; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function FieldByName(const aName: string): TDAField; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function FindField(const aName: string): TDAField; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetBookMark: pointer; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GotoBookmark(Bookmark: TBookmark); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure FreeBookmark(Bookmark: TBookmark); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetLogicalName : string; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetLogicalName(aName : string); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnAfterOpen: TDAAfterOpenDatasetEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnBeforeOpen: TDABeforeOpenDatasetEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnAfterOpen(const Value: TDAAfterOpenDatasetEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnBeforeOpen(const Value: TDABeforeOpenDatasetEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnOpenError: TDAOpenDatasetErrorEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnOpenError(const Value: TDAOpenDatasetErrorEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetRowRecIdValue: integer;
function GetCurrentRecIdValue: integer;
procedure SetCurrentRecIdValue(Value: integer);
procedure EnableConstraints; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure DisableConstraints; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
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
procedure RefreshParamsStd(AParams: TParams);
// Internal
procedure DoPrepare(Value: boolean); override;
procedure RefreshParams; override; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
// IDAStoredProcedure
function GetStoredProcedureName: string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} abstract;
procedure SetStoredProcedureName(const Name: string); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} 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; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetConnectionPool(const Value: IDAConnectionPool); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
// 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; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetConnectionProperties(const aPropertyName: string): Variant; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetConnectionProperties(const aPropertyName: string; const aValue: Variant); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
// IDATestableObject
procedure Test; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
// IDAConnection
function GetConnectionString: string; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetConnectionString(Value: string); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetConnected: boolean; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetConnected(Value: boolean); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetName: string; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnAfterExecuteCommand: TDAAfterExecuteCommandEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnAfterOpenDataset: TDAAfterOpenDatasetEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnBeforeExecuteCommand: TDABeforeExecuteCommandEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnBeforeOpenDataset: TDABeforeOpenDatasetEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnExecuteCommandError: TDAExecuteCommandErrorEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetOnOpenDatasetError: TDAOpenDatasetErrorEvent; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnAfterExecuteCommand(const Value: TDAAfterExecuteCommandEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnAfterOpenDataset(const Value: TDAAfterOpenDatasetEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnBeforeExecuteCommand(const Value: TDABeforeExecuteCommandEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnBeforeOpenDataset(const Value: TDABeforeOpenDatasetEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnExecuteCommandError(const Value: TDAExecuteCommandErrorEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetOnOpenDatasetError(const Value: TDAOpenDatasetErrorEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure Open(const aUserID: string = ''; const aPassword: string = ''); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure Close; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
// UserID/Password
function GetUserID: string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetUserID(const Value: string); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetPassword: string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetPassword(const Value: string); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function BeginTransaction: integer; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure CommitTransaction; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure RollbackTransaction; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetInTransaction: boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetTableNames(out List: IROStrings); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetViewNames(out List: IROStrings); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetStoredProcedureNames(out List: IROStrings); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetTableFields(const aTableName: string; out Fields: TDAFieldCollection); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetQueryFields(const aSQL: string; aParamsIfNeeded: TDAParamCollection; out Fields: TDAFieldCollection); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetViewFields(const aViewName: string; out Fields: TDAFieldCollection); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetStoredProcedureParams(const aStoredProcedureName: string; out Params: TDAParamCollection); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetForeignKeys(out ForeignKeys: TDADriverForeignKeyCollection); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetSPSelectSyntax(HasArguments: Boolean): string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetQuoteChars: TDAQuoteCharArray; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function IdentifierIsQuoted(const iIdentifier: string): boolean; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function IdentifierNeedsQuoting(const iIdentifier: string): boolean; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function QuoteIdentifierIfNeeded(const iIdentifier: string): string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function QuoteIdentifier(const iIdentifier: string): string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function QuoteFieldNameIfNeeded(const aTableName, aFieldName: string): string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function QuoteFieldName(const aTableName, aFieldName: string): string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function NewCommand(const Text: string; CommandType: TDASQLStatementType; const aCommandName: string = ''): IDASQLCommand; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function NewDataset(const SQL: string; const aDatasetName: string = ''): IDADataset; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetLastAutoInc(const GeneratorName: string = ''): integer; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
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; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetConnectionType: string; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
property ConnectionType: string read GetConnectionType;
function GetQueryBuilder: TDAQueryBuilder; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetWhereBuilder: TDASQLWhereBuilder; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetUseMacroProcessor: Boolean; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetUseMacroProcessor(Value:Boolean); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
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; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} abstract;
function GetDescription: string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF} abstract;
function GetMajVersion: byte; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetMinVersion: byte; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetAuxDrivers(out List: IROStrings); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure GetAuxParams(const AuxDriver: string; out List: IROStrings); virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetDefaultConnectionType(const AuxDriver: string): string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure SetTraceOptions(TraceActive: boolean; TraceFlags: TDATraceOptions; Callback: TDALogTraceEvent); {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function NewConnection(const aName: string = ''; const aConnectionType: string = ''): IDAConnection; overload; {deprecated;} {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function NewConnection(const aConnectionManager: IDAConnectionManager; aConnectionDefinition: TDAConnection): IDAConnection; overload; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure Initialize; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
procedure Finalize; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetAvailableDriverOptions: TDAAvailableDriverOptions; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
function GetDefaultCustomParameters: string; virtual; {$IFNDEF FPC_SAFECALL_BUG}safecall;{$ENDIF}
{ 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,{$IFDEF FPC}dbconst,{$ELSE}DBConsts,{$ENDIF}
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;
if (iIdentifier <> '') then begin
i := pos('.',iIdentifier);
if (i < Length(iIdentifier)) and (iIdentifier[i+1] in ['0'..'9']) then Result := True;
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;
startTick: Cardinal;
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;
SetDynamicWhereParams;
SetSQL(fConnection.fMacroProcessor.Eval(GetSQL));
end;
// Writes the parameter values
if (fParams.Count > 0) then SetParamValues(fParams) else ClearParams;
startTick := ROGetTickCount;
if Assigned(fOnBeforeOpen) then fOnBeforeOpen(Self);
// Opens the dataset
fAutoFields := (fFields.Count = 0);
try
fDataset.Open;
FixKnownIssues;
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);
GetParamValues(fParams);
RemoveDynamicWhereParams;
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
case fld.DataType of
{$IFNDEF FPC}
ftFMTBcd: begin
DecimalPrecision:= TFMTBCDField(fld).Precision;
DecimalScale:= TFMTBCDField(fld).Size;
end;
{$ENDIF}
ftBCD: begin
DecimalPrecision:= TBCDField(fld).Precision;
DecimalScale:= TBCDField(fld).Size;
end;
else
DataType := datFloat;
end;
end;
// Fix ZEOS issue
{$IFDEF DELPHI2006UP}
if (DataType = datWideString) and (Size = MaxInt div 2) then begin
DataType:= datWideMemo;
Size := 0;
end;
{$ENDIF}
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;
{$IFNDEF FPC}
// FPC doesn't support ftFMTBcd
ftFMTBcd: Result:= BCDToVariant(BindedField.AsBCD,True);
{$ENDIF}
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;
{
procedure TDAEDataset.CreateFieldDefs;
var
i: integer;
fld: TFieldDef;
dafld: TDAField;
lNeedtoCreateFieldDefs: Boolean;
lFMTBCDPresent: Boolean;
begin
lNeedtoCreateFieldDefs:=fDataset.FieldDefs.Count=0;
lFMTBCDPresent:=False;
// 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
if lNeedtoCreateFieldDefs then begin
fld := fDataset.FieldDefs.AddFieldDef;
fld.Name := dafld.Name;
fld.DataType := DATypeToVCLType(dafld.DataType);
end
else begin
fld := TFieldDef(fDataset.FieldDefs.Find(dafld.Name));
end;
// (autoinc)
if (dafld.DataType=datLargeAutoInc) then fld.DataType := ftLargeint
else if (dafld.DataType=datAutoInc) then fld.DataType := ftInteger;
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;
lFMTBCDPresent:= True;
end;
end;
if not lFMTBCDPresent then fDataset.FieldDefs.Clear;
// 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;
{$IFNDEF FPC}
var
i: integer;
lNeedToFix: Boolean;
fld: TFieldDef;
dafld: TDAField;
{$ENDIF}
begin
{$IFNDEF FPC}
// FPC doesn't support ftFMTBcd
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;
fDataset.Close;
for i := 0 to (fDataset.FieldDefs.Count - 1) do begin
fld := fDataset.FieldDefs[i];
if (fld.DataType = ftFMTBcd) then begin
dafld:= fFields.FindField(fld.Name);
if (fld.Precision = 15 ) and (fld.Size=4) then begin
if (dafld <> nil) and (dafld.DataType = datDecimal) then begin
fld.Precision := dafld.DecimalPrecision;
fld.Size := dafld.DecimalScale;
end else begin
fld.Precision := 24;
fld.Size := 8;
end;
end;
end;
end;
fDataset.Open;
{$ENDIF}
end;
procedure TDAEDataset.FixKnownIssues;
begin
if IsNeedToFixFMTBCDIssue then FixFMTBCDIssue;
end;
function TDAEDataset.ControlsDisabled: Boolean;
begin
Result := fDataset.ControlsDisabled;
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.ParamByName(const aName: string): TDAParam;
begin
result := fParams.ParamByName(aName)
end;
procedure TDAESQLCommand.RefreshParams;
var
lParams: TParams;
i: integer;
par: TDAParam;
begin
//dsparams := GetProviderSupport.PSGetParams;
lParams := TParams.Create;
try
Params_ParseSQL(lParams, fSQL, True, fConnection.GetQuoteChars);
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
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 SetParamValues(fParams) else ClearParams;
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;
GetParamValues(fParams);
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;
SetDynamicWhereParams;
sql := fConnection.fMacroProcessor.Eval(sql);
end;
DoSetSQL(sql);
DoPrepare(fPrepared);
Changed := false;
end;
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;
if fDataset <> nil then fDataset.FieldDefs.Clear;
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;
procedure TDAESQLCommand.SetDynamicWhereParams;
var
i: integer;
k: TDAParam;
begin
if fDynamicWhere <> nil then
For i:=0 to fDynamicWhere.Params.Count-1 do begin
k:=Self.GetParams.FindParam(fDynamicWhere.Params[i].Name);
if k = nil then k:= Self.GetParams.Add;
k.AssignField(fDynamicWhere.Params[i]);
end;
end;
procedure TDAESQLCommand.RemoveDynamicWhereParams;
var
i: integer;
k: TDAParam;
begin
if fDynamicWhere <> nil then
For i:=0 to fDynamicWhere.Params.Count-1 do begin
k := Self.GetParams.FindParam(fDynamicWhere.Params[i].Name);
if k <> nil then Self.GetParams.Delete(k.Index);
end;
end;
procedure TDAESQLCommand.SetParamValuesStd(Params1: TDAParamCollection;
Params2: TParams);
var
i: integer;
par: TDAParam;
outpar: TParam;
ft: TFieldType;
lParIsEmpty: Boolean;
begin
for i := 0 to (Params1.Count - 1) do begin
par := Params1[i];
outpar := FindParameter(Params2,par.Name);
ft := DATypeToVCLType(par.DataType);
if ft = ftAutoInc then ft := ftInteger;
case par.ParamType of
daptInput: outpar.ParamType := ptInput;
daptOutput: outpar.ParamType := ptOutput;
daptInputOutput: outpar.ParamType := ptInputOutput;
daptResult: outpar.ParamType := ptResult;
end;
lParIsEmpty := VarIsEmpty(par.Value) or VarIsNull(par.Value);
if par.DataType = datBlob then begin
outpar.DataType := ftBlob;
if not (par.ParamType in [daptOutput, daptResult]) then begin
if lParIsEmpty 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 outpar.Value := par.Value;
end;
if lParIsEmpty and (par.DataType <> datUnknown) then begin
if (outpar.DataType <> ft) and (ft <> ftUnknown) then outpar.DataType := ft;
end;
end;
end;
procedure TDAESQLCommand.GetParamValuesStd(Params1: TDAParamCollection;
Params2: TParams);
var
i: integer;
par1: TDAParam;
begin
for i := 0 to Params1.Count-1 do begin
par1 := Params1[i];
if Par1.ParamType in [daptOutput, daptInputOutput, daptResult] then
Par1.Value := FindParameter(Params2,Par1.Name).Value;
end;
end;
function TDAESQLCommand.FindParameter(const AParams: TParams;
const AParamName: string): TParam;
begin
Result := AParams.FindParam(AParamName);
if Result = nil then
Result := AParams.FindParam('@'+AParamName);
if Result = nil then begin
if AParams.Owner is TDataSet then
DatabaseErrorFmt(SParameterNotFound, [AParamName], TComponent(AParams.Owner))
else
DatabaseErrorFmt(SParameterNotFound, [AParamName])
end;
end;
procedure TDAESQLCommand.ClearParams;
begin
// nothing
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;
begin
raise Exception.Create('RefreshParams must be implemented in descendant.');
end;
procedure TDAEStoredProcedure.RefreshParamsStd(AParams: TParams);
var
par: TDAParam;
i: integer;
lname:string;
begin
fParams.Clear;
for i := 0 to (AParams.Count - 1) do begin
if (AParams[i].DataType = ftInterface) and (AParams[I].ParamType in [ptOutput, ptInputOutput, ptResult]) then Continue;
par := fParams.Add;
lName :=AParams[i].Name;
if Pos('@', lname) = 1 then lName:=copy(lName,2, Length(lName)-1);
par.Name := lName;
par.DataType := intVCLTypeToDAType(AParams[i].DataType);
par.ParamType := TDAParamType(AParams[i].ParamType);
par.Size := AParams[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.
Reference in New Issue View Git Blame Copy Permalink