////////////////////////////////////////////////// // DB Access Components // Copyright © 1998-2007 Core Lab. All right reserved. // DB Access // Created: 01.07.00 ////////////////////////////////////////////////// {$J+} {$IFNDEF CLR} {$I Dac.inc} unit DBAccess; {$ENDIF} interface uses SysUtils, Classes, DB, MemData, MemDS, CRAccess, CRParser, TypInfo, MemUtils, {$IFDEF VER6P}Variants, SqlTimSt,{$ENDIF} {$IFDEF MSWINDOWS} Windows, Registry, {$IFDEF CLR} ExtCtrls, System.XML, {$ELSE} Win32Timer, {$ENDIF} {$ENDIF} {$IFDEF CLR} System.Runtime.InteropServices, System.Text, Contnrs, {$ELSE} CLRClasses, CRXml, {$ENDIF} SyncObjs; const OperationsStackDelta = 50; type TCustomDAConnection = class; TCustomDASQL = class; TCustomDADataSet = class; TCustomDASQLClass = class of TCustomDASQL; TCustomDADataSetClass = class of TCustomDADataSet; TCustomDAUpdateSQL = class; TMacro = class; TMacros = class; TCustomConnectDialog = class; TConnectDialogClass = class of TCustomConnectDialog; TCRConnectionClass = class of TCRConnection; TCRCommandClass = class of TCRCommand; TCRRecordSetClass = class of TCRRecordSet; { EDAError } EDAError = class (EDatabaseError) protected FErrorCode: integer; FComponent: TObject; public constructor Create(ErrorCode: integer; Msg: string); property ErrorCode: integer read FErrorCode; property Component: TObject read FComponent write FComponent; end; { TCustomDAConnection } TRetryMode = (rmRaise, rmReconnect, rmReconnectExecute); TFailOverOperation = record Operation: TConnLostCause; AllowFailOver: boolean; end; TOperationsStack = array of TFailOverOperation;// executed operations stack used to track dowm connection lost cause TDAConnectionErrorEvent = procedure (Sender: TObject; E: EDAError; var Fail: boolean) of object; TConnectionLostEvent = procedure (Sender: TObject; Component: TComponent; ConnLostCause: TConnLostCause; var RetryMode: TRetryMode) of object; TDAConnectionOptions = class (TPersistent) protected FKeepDesignConnected: boolean; FOwner: TCustomDAConnection; FDisconnectedMode: boolean; FLocalFailover: boolean; procedure SetDisconnectedMode(Value: boolean); virtual; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Owner: TCustomDAConnection); property DisconnectedMode: boolean read FDisconnectedMode write SetDisconnectedMode default False; property KeepDesignConnected: boolean read FKeepDesignConnected write FKeepDesignConnected default True; property LocalFailover: boolean read FLocalFailover write FLocalFailover default False; end; TPoolingOptions = class(TPersistent) protected FOwner: TCustomDAConnection; FMaxPoolSize: integer; FMinPoolSize: integer; FConnectionLifetime: integer; FValidate: boolean; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Owner: TCustomDAConnection); virtual; published property MaxPoolSize: integer read FMaxPoolSize write FMaxPoolSize default 100; property MinPoolSize: integer read FMinPoolSize write FMinPoolSize default 0; property ConnectionLifetime: integer read FConnectionLifetime write FConnectionLifetime default 0; property Validate: boolean read FValidate write FValidate default False; end; TCustomDAConnection = class (TCustomConnection) private FUsername: string; FAutoCommit: boolean; FInProcessError: boolean; FConnectDialog: TCustomConnectDialog; FOnError: TDAConnectionErrorEvent; FConvertEOL: boolean; FOptions: TDAConnectionOptions; FPoolingOptions: TPoolingOptions; FPooling: boolean; FOnConnectionLost: TConnectionLostEvent; hRegisterClient: TCriticalSection; procedure ClearRefs; procedure SetUsername(const Value: string); procedure SetPassword(const Value: string); procedure SetAutoCommit(Value: boolean); procedure SetConnectDialog(Value: TCustomConnectDialog); procedure SetPooling(Value: boolean); procedure DoAfterConnect; protected FConnectCount: integer; FSQLs: TDAList; FIConnection: TCRConnection; FStreamedConnected: boolean; FServer: string; FPassword: string; FTransactionID: string; FShouldShowPrompt: boolean; //Disconnect mode flag that allow to avoid unnecessary Login porompt showing FOperationsStack: TOperationsStack ; //FailOver support FOperationsStackLen: integer; function GetTransactionID: string; virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); override; function GetIConnectionClass: TCRConnectionClass; virtual; function GetICommandClass: TCRCommandClass; virtual; function GetIRecordSetClass: TCRRecordSetClass; virtual; procedure CreateIConnection; virtual; function CreateICommand: TCRCommand; function CreateIRecordSet: TCRRecordSet; procedure FreeIConnection; procedure SetIConnection(Value: TCRConnection); virtual; procedure Loaded; override; procedure RegisterClient(Client: TObject; Event: TConnectChangeEvent = nil); override; procedure UnRegisterClient(Client: TObject); override; function SQLMonitorClass: TClass; virtual; // TDASQLMonitorClass function ConnectDialogClass: TConnectDialogClass; virtual; procedure DoConnect; override; procedure DoDisconnect; override; function CommitOnDisconnect: boolean; virtual; procedure InternalConnect; virtual; procedure InternalDisconnect; virtual; function IsConnectedStored: boolean; virtual; function NeedPrompt: boolean; virtual; //Operations stack functionality function PushOperation(Operation: TConnLostCause; AllowFailOver: boolean = true): integer; virtual; function PopOperation: TConnLostCause; virtual; function IsFatalError(E: EDAError): boolean; virtual; procedure ResetOnFatalError; virtual; procedure RestoreAfterFailOver; virtual; function DetectConnLostCause(Component: TObject): TConnLostCause; virtual; procedure DoError(E: Exception; var Fail, Reconnect, Reexecute: boolean; ReconnectAttempt: integer; var ConnLostCause: TConnLostCause); virtual; function IsKeyViolation(E: EDAError): boolean; virtual; procedure AssignTo(Dest: TPersistent); override; function GetConnected: boolean; override; procedure SetConnected(Value: boolean); override; function GetConnectString: string; virtual; procedure SetConnectString(Value: string); virtual; procedure SetServer(const Value: string); virtual; procedure SuppressAutoCommit; procedure RestoreAutoCommit; function GetInTransaction: boolean; virtual; procedure SetConvertEOL(Value: boolean); { Transaction control } procedure InternalStartTransaction; virtual; function CreateOptions: TDAConnectionOptions; virtual; procedure SetOptions(Value: TDAConnectionOptions); function CreatePoolingOptions: TPoolingOptions; virtual; procedure SetPoolingOptions(Value: TPoolingOptions); function IsCaseSensitive: boolean; virtual; property AutoCommit: boolean read FAutoCommit write SetAutoCommit default True; property ConnectString: string read GetConnectString write SetConnectString stored False; public constructor Create(Owner: TComponent); override; destructor Destroy; override; procedure Connect; procedure Disconnect; procedure PerformConnect(Retry: boolean = False); function ExecSQL(Text: string; const Params: array of variant): variant; virtual; abstract; procedure GetTableNames(List: TStrings); virtual; procedure GetDatabaseNames(List: TStrings); virtual; procedure GetStoredProcNames(List: TStrings); virtual; { Transaction control } procedure StartTransaction; virtual; procedure Commit; virtual; procedure Rollback; virtual; procedure ApplyUpdates; overload; virtual; procedure ApplyUpdates(DataSets: array of TCustomDADataSet); overload; virtual; function CreateDataSet: TCustomDADataSet; virtual; function CreateSQL: TCustomDASQL; virtual; procedure RemoveFromPool; procedure MonitorMessage(const Msg: string); property Username: string read FUsername write SetUsername; property Password: string read FPassword write SetPassword; property Server: string read FServer write SetServer; property InTransaction: boolean read GetInTransaction; property ConnectDialog: TCustomConnectDialog read FConnectDialog write SetConnectDialog; property OnError: TDAConnectionErrorEvent read FOnError write FOnError; property OnConnectionLost: TConnectionLostEvent read FOnConnectionLost write FOnConnectionLost; property LoginPrompt default True; property ConvertEOL: boolean read FConvertEOL write SetConvertEOL default False; property Options: TDAConnectionOptions read FOptions write SetOptions; property PoolingOptions: TPoolingOptions read FPoolingOptions write SetPoolingOptions; property Pooling: boolean read FPooling write SetPooling default False; end; { TDAParam } TDAParams = class; TDAParamInfoClass = class of TDAParamInfo; TDAParamInfo = class(TCollectionItem) protected FField: TField; FOld: boolean; FParamIndex: integer; public property Field: TField read FField write FField; property Old: boolean read FOld write FOld; property ParamIndex: integer read FParamIndex write FParamIndex; end; TDAParamsInfo = class(TCollection) protected function GetItem(Index: Integer): TDAParamInfo; procedure SetItem(Index: Integer; Value: TDAParamInfo); public property Items[Index: Integer]: TDAParamInfo read GetItem write SetItem; default; end; TDAParam = class (TParam) private FSize: integer; function IsDataTypeStored: boolean; function IsValueStored: boolean; procedure SetParamObject(Value: TSharedObject); protected FParamObject: TSharedObject; function IsObjectDataType(DataType: TFieldType): boolean; overload; virtual; function IsObjectDataType: boolean; overload; function IsBlobDataType: boolean; virtual; function GetDataType: TFieldType; virtual; procedure SetDataType(Value: TFieldType); virtual; function GetSize: integer; virtual; procedure SetSize(Value: integer); virtual; function GetAsString: string; virtual; procedure SetAsString(Value: string); virtual; function GetAsWideString: WideString; virtual; procedure SetAsWideString(Value: WideString); virtual; function GetAsInteger: integer; virtual; procedure SetAsInteger(Value: integer); virtual; function GetAsFloat: double; virtual; procedure SetAsFloat(Value: double); virtual; procedure SetAsBlob(Value: TBlobData); virtual; procedure SetAsMemo(Value: string); virtual; function GetAsBlobRef: TBlob; virtual; procedure SetAsBlobRef(const Value: TBlob); virtual; function GetAsMemoRef: TBlob; virtual; procedure SetAsMemoRef(const Value: TBlob); virtual; function GetAsVariant: variant; virtual; procedure SetAsVariant(const Value: variant); virtual; {$IFDEF VER6P} function GetAsSQLTimeStamp: TSQLTimeStamp; virtual; procedure SetAsSQLTimeStamp(const Value: TSQLTimeStamp); virtual; {$ENDIF} procedure SetText(const Value: string); virtual; function GetIsNull: boolean; virtual; procedure DefineProperties(Filer: TFiler); override; procedure ReadExtDataType(Reader: TReader); procedure WriteExtDataType(Writer: TWriter); procedure CreateObject; virtual; procedure FreeObject; virtual; procedure AssignParam(Param: TParam); procedure AssignTo(Dest: TPersistent); override; property ParamObject: TSharedObject read FParamObject write SetParamObject; public destructor Destroy; override; procedure Clear; virtual; procedure Assign(Source: TPersistent); override; procedure AssignField(Field: TField); procedure AssignFieldValue(Field: TField; const Value: Variant); virtual; procedure LoadFromFile(const FileName: string; BlobType: TBlobType); procedure LoadFromStream(Stream: TStream; BlobType: TBlobType); virtual; procedure SetBlobData(Buffer: TBytes; Size: Integer); overload; procedure SetBlobData(Buffer: TValueBuffer); overload; property AsString: TBlobData read GetAsString write SetAsString; property AsWideString: WideString read GetAsWideString write SetAsWideString; property AsInteger: integer read GetAsInteger write SetAsInteger; property AsFloat: double read GetAsFloat write SetAsFloat; property AsBlob: TBlobData read GetAsString write SetAsBlob; property AsMemo: string read GetAsString write SetAsMemo; property AsBlobRef: TBlob read GetAsBlobRef write SetAsBlobRef; property AsMemoRef: TBlob read GetAsMemoRef write SetAsMemoRef; {$IFDEF VER6P} property AsSQLTimeStamp: TSQLTimeStamp read GetAsSQLTimeStamp write SetAsSQLTimeStamp; {$ENDIF} property IsNull: boolean read GetIsNull; property Text: string read GetAsString write SetText; published property DataType: TFieldType read GetDataType write SetDataType stored IsDataTypeStored; property ParamType default DB.ptUnknown; property Size: integer read GetSize write SetSize default 0; property Value: variant read GetAsVariant write SetAsVariant stored IsValueStored; end; { TDAParams } TDAParams = class (TParams) private function GetItem(Index: integer): TDAParam; procedure SetItem(Index: integer; Value: TDAParam); protected FOwner: TPersistent; FNeedsUpdateItem: boolean; procedure Update(Item: TCollectionItem); override; public constructor Create(Owner: TPersistent); overload; function ParamByName(const Value: string): TDAParam; function FindParam(const Value: string): TDAParam; function CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType): TDAParam; property Items[Index: integer]: TDAParam read GetItem write SetItem; default; end; { TDADetailDataLink } TDADetailDataLink = class (TDetailDataLink) private FDataSet: TCustomDADataSet; protected procedure ActiveChanged; override; procedure RecordChanged(Field: TField); override; procedure CheckBrowseMode; override; function GetDetailDataSet: TDataSet; override; public constructor Create(DataSet: TCustomDADataSet); end; { TDASQLGenerator } TFieldArray = array of TField; TFieldDescArray = array of TCRFieldDesc; TKeyAndDataFields = record KeyFieldDescs: TFieldDescArray; DataFieldDescs: TFieldDescArray; end; TStatementType = (stQuery, stInsert, stUpdate, stDelete, stLock, stRefresh, stCheck, stCustom, stRefreshQuick, stRefreshCheckDeleted, stBatchUpdate); TStatementTypes = set of TStatementType; TDASQLGenerator = class protected FOwner: TCustomDADataSet; // stInsert stUpdate stDelete stRefresh FHeaderSB, // INSERT INTO Tbl( UPDATE Tbl SET DELETE FROM Tbl WHERE SELECT FFldSB, // f1, f2, f3, ... f1 = :p1, f2 = :p2, ... f1, f2, f3, ... FMiddleSB, // ) VALUES ( WHERE FROM Tbl WHERE FFldParamSB, // :p1, :p2, :p3, ... FCondSB, // f0 = :p0 f0 = :p0 f0 = :p0 FFooterSB: StringBuilder; // ) FOldRecBuf, FNewRecBuf: IntPtr; FParams: TDAParams; FParamsInfo: TDAParamsInfo; FTableInfo: TCRTableInfo; procedure Clear; virtual; function AssembleSB(const StatementType: TStatementType): string; virtual; function Data: TData; function OldRecBuf: IntPtr; function NewRecBuf: IntPtr; function IsBlobDataType(DataType: word): boolean; virtual; function IsObjectDataType(DataType: word): boolean; virtual; function FieldIsNull(FieldDesc: TCRFieldDesc; OldValue: boolean; Data: TData; OldRecBuf, NewRecBuf: IntPtr): boolean; overload; virtual; function FieldIsNull(FieldDesc: TCRFieldDesc; OldValue: boolean): boolean; overload; virtual; function FieldModified(FieldDesc: TCRFieldDesc; Data: TData; OldRecBuf, NewRecBuf: IntPtr): boolean; overload; virtual; function FieldModified(FieldDesc: TCRFieldDesc): boolean; overload; virtual; function GetActualFieldNameEx(FieldDesc: TCRFieldDesc; TableInfo: TCRTableInfo): string; virtual; function GetActualFieldName(FieldDesc: TCRFieldDesc; IsRefresh: boolean): string; virtual; function IndexedPrefix: string; function GenerateIndexName(Name: string): string; virtual; function DecodeFieldIndex(FieldName: string): integer; virtual; function QuoteName(const AName: string): string; function UnQuoteName(AName: string): string; function IsSubstituteParamName: boolean; virtual; procedure AddParam(SB: StringBuilder; FieldDesc: TFieldDesc; const StatementType: TStatementType; const ParamType: TParamType; Index: integer = -1; Old: boolean = False); virtual; procedure AddFieldToInsertSQL(FieldDesc: TCRFieldDesc; const Index: integer = -1); virtual; procedure AddFieldToUpdateSQL(FieldDesc: TCRFieldDesc; const ModifiedFieldsOnly: boolean; const Index: integer = -1); virtual; procedure AddFieldToRefreshSQL(FieldDesc: TCRFieldDesc); virtual; procedure AddFieldToCondition(SB: StringBuilder; FieldDesc: TCRFieldDesc; const StatementType: TStatementType; const ModifiedFieldsOnly: boolean; const Index: integer = -1); virtual; procedure GenerateInsertSQL( const KeyAndDataFields: TKeyAndDataFields; const ModifiedFieldsOnly: boolean; const Index: integer = -1); virtual; procedure GenerateUpdateSQL( const KeyAndDataFields: TKeyAndDataFields; const ModifiedFieldsOnly: boolean; const Index: integer = -1); virtual; procedure GenerateDeleteSQL( const KeyAndDataFields: TKeyAndDataFields; const ModifiedFieldsOnly: boolean; const Index: integer = -1); virtual; procedure GenerateLockSQL( const KeyAndDataFields: TKeyAndDataFields; const Index: integer = -1); virtual; procedure GenerateRefreshSQLSelectPart(const KeyAndDataFields: TKeyAndDataFields); virtual; procedure GenerateRefreshSQLFromPart; virtual; procedure GenerateRefreshSQL( const KeyAndDataFields: TKeyAndDataFields; const ModifiedFieldsOnly: boolean); virtual; procedure GenerateRefreshQuickSQL(const KeyAndDataFields: TKeyAndDataFields); virtual; procedure GenerateRefreshCheckDeletedSQL(const KeyAndDataFields: TKeyAndDataFields); virtual; procedure GenerateConditions(SB: StringBuilder; const StatementType: TStatementType; const ModifiedFieldsOnly: boolean; const KeyAndDataFields: TKeyAndDataFields; const Index: integer = -1); virtual;// Generate WHERE part for UPDATE, DELETE, REFRESH SQLs function GetParamInfoClass: TDAParamInfoClass; virtual; public constructor Create(Owner: TCustomDADataSet); destructor Destroy; override; // Generate insert, update, delete or refresh SQL statements function GenerateSQLforUpdTable(TableInfo: TCRTableInfo; const KeyAndDataFields: TKeyAndDataFields; const StatementType: TStatementType; const ModifiedFieldsOnly: boolean; Params: TDAParams; const Index: integer = -1): string; virtual; function GenerateSQL(const StatementType: TStatementType; const ModifiedFieldsOnly: boolean; Params: TDAParams; const Index: Integer = -1): string; virtual; property ParamsInfo: TDAParamsInfo read FParamsInfo; end; { TCustomDADataSet } TRefreshOption = (roAfterInsert, roAfterUpdate, roBeforeEdit); TRefreshOptions = set of TRefreshOption; TAfterExecuteEvent = procedure (Sender: TObject; Result: boolean) of object; TUpdateExecuteEvent = procedure (Sender: TDataSet; StatementTypes: TStatementTypes; Params: TDAParams) of object; TBeforeFetchEvent = procedure (DataSet: TCustomDADataSet; var Cancel: boolean) of object; TAfterFetchEvent = procedure (DataSet: TCustomDADataSet) of object; TLocalMDLink = record IsNull: boolean; Buffer: IntPtr; BufferType: integer; NativeBuffer: boolean; FieldNo: integer; end; TLocalMDLinks = array of TLocalMDLink; TDADataSetOptions = class (TPersistent) private FSetFieldsReadOnly: boolean; FRequiredFields: boolean; FStrictUpdate: boolean; FNumberRange: boolean; FQueryRecCount: boolean; FAutoPrepare: boolean; FReturnParams: boolean; FTrimFixedChar: boolean; FTrimVarChar: boolean; FLongStrings: boolean; FRemoveOnRefresh: boolean; FFlatBuffers: boolean; FQuoteNames: boolean; FDetailDelay: integer; {$IFDEF HAVE_COMPRESS} FCompressBlobMode: TCompressBlobMode; {$ENDIF} FFullRefresh: boolean; FLocalMasterDetail: boolean; FFieldsOrigin: boolean; FUpdateBatchSize: integer; FUpdateAllFields: boolean; procedure SetRequiredFields(Value: boolean); procedure SetNumberRange(Value: boolean); procedure SetTrimFixedChar(Value: boolean); procedure SetTrimVarChar(Value: boolean); procedure SetLongStrings(Value: boolean); procedure SetAutoPrepare(Value: boolean); procedure SetFlatBuffers(const Value: boolean); procedure SetDetailDelay(Value: integer); {$IFDEF HAVE_COMPRESS} procedure SetCompressBlobMode(Value: TCompressBlobMode); {$ENDIF} procedure SetLocalMasterDetail(Value: boolean); function GetCacheCalcFields: boolean; procedure SetCacheCalcFields(Value: boolean); protected FOwner: TCustomDADataSet; procedure AssignTo(Dest: TPersistent); override; property FullRefresh: boolean read FFullRefresh write FFullRefresh default False; property TrimVarChar: boolean read FTrimVarChar write SetTrimVarChar default False; public constructor Create(Owner: TCustomDADataSet); property SetFieldsReadOnly: boolean read FSetFieldsReadOnly write FSetFieldsReadOnly default False; property RequiredFields: boolean read FRequiredFields write SetRequiredFields default True; property StrictUpdate: boolean read FStrictUpdate write FStrictUpdate default True; property NumberRange: boolean read FNumberRange write SetNumberRange default False; property QueryRecCount: boolean read FQueryRecCount write FQueryRecCount default False; property AutoPrepare: boolean read FAutoPrepare write SetAutoPrepare default False; property ReturnParams: boolean read FReturnParams write FReturnParams default False; property TrimFixedChar: boolean read FTrimFixedChar write SetTrimFixedChar default True; property LongStrings: boolean read FLongStrings write SetLongStrings default True; property FlatBuffers: boolean read FFlatBuffers write SetFlatBuffers default False; property RemoveOnRefresh: boolean read FRemoveOnRefresh write FRemoveOnRefresh default True; property QuoteNames: boolean read FQuoteNames write FQuoteNames default False; property DetailDelay: integer read FDetailDelay write SetDetailDelay default 0; {$IFDEF HAVE_COMPRESS} property CompressBlobMode: TCompressBlobMode read FCompressBlobMode write SetCompressBlobMode default cbNone; {$ENDIF} property LocalMasterDetail: boolean read FLocalMasterDetail write SetLocalMasterDetail default False; property CacheCalcFields: boolean read GetCacheCalcFields write SetCacheCalcFields default False; property FieldsOrigin: boolean read FFieldsOrigin write FFieldsOrigin stored False default False; property UpdateBatchSize: Integer read FUpdateBatchSize write FUpdateBatchSize default 1; property UpdateAllFields: boolean read FUpdateAllFields write FUpdateAllFields default False; end; TCustomDADataSet = class (TMemDataSet) private FConnection: TCustomDAConnection; FParams: TDAParams; // for easy reference of FCommand.Params FMacros: TMacros; // for easy reference of FCommand.Macros FFetchRows: integer; FDataLink: TDADetailDataLink; FDebug: boolean; FReadOnly: boolean; FUniDirectional: boolean; FAutoCommit: boolean; FUpdateObject: TCustomDAUpdateSQL; FRefreshOptions: TRefreshOptions; FOptions: TDADataSetOptions; FActiveRecRefresh: boolean; // ActiveBufLevelRecordRefresh FBaseSQL: string; {$IFDEF MSWINDOWS} FDetailRefreshTimer: {$IFDEF CLR}TTimer{$ELSE}TWin32Timer{$ENDIF}; {$ENDIF} FLocalMDLinks: TLocalMDLinks; FAfterExecute: TAfterExecuteEvent; FBeforeFetch: TBeforeFetchEvent; FAfterFetch: TAfterFetchEvent; FBeforeUpdateExecute: TUpdateExecuteEvent; FAfterUpdateExecute: TUpdateExecuteEvent; FFindKeyOptions: TLocateExOptions; function GetSQL: TStrings; procedure SetSQL(Value: TStrings); procedure SetFetchRows(Value: integer); procedure SetMasterSource(Value: TDataSource); function GetParams: TDAParams; procedure SetParams(Value: TDAParams); function GetParamCount: word; function GetParamCheck: boolean; procedure SetParamCheck(Value: boolean); function GetMacros: TMacros; procedure SetMacros(Value: TMacros); function GetMacroCount: word; function GetRowsAffected: integer; procedure SetUniDirectional(Value: boolean); procedure SetAutoCommit(Value: boolean); //procedure SetUpdateMode(const Value: TUpdateMode); procedure SetUpdateObject(Value: TCustomDAUpdateSQL); procedure SetOptions(Value: TDADataSetOptions); procedure SetMasterFields(Value: string); procedure SetForeignKeyFields(Value: string); procedure SaveModifiedSQL(NewSQL: string); function GetBaseSQL: string; {$IFDEF MSWINDOWS} procedure CheckRefreshDetailTimer; {$ENDIF} {$IFDEF VER5P} protected { IProviderSupport } FOldKeyFields: string; // To PSGetKeyFields after closing table (see SDAC 3034) FOldTableName: string; // PSGetTableName must return right value even after DataSet.Close procedure PSEndTransaction(Commit: Boolean); override; procedure PSExecute; override; function PSExecuteStatement(const ASQL: string; AParams: TParams; {$IFDEF CLR}var ResultSet: TObject{$ELSE}ResultSet: Pointer = nil{$ENDIF}): Integer; override; function PSGetParams: DB.TParams; override; function PSGetQuoteChar: string; override; function PSGetTableName: string; override; function PSInTransaction: Boolean; override; function PSIsSQLBased: Boolean; override; function PSIsSQLSupported: Boolean; override; procedure PSReset; override; procedure PSSetParams(AParams: DB.TParams); override; procedure PSSetCommandText(const CommandText: string); override; procedure PSStartTransaction; override; function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override; function PSGetDefaultOrder: TIndexDef; override; function PreventPSKeyFields(var PSKeyFields: string): boolean; virtual; function PSGetKeyFields: string; override; {$ENDIF} protected FRowsAffected: integer; FIRecordSet: TCRRecordSet; FICommand: TCRCommand; // for perf FCommand: TCustomDASQL; FFilterSQL: string; //CR ODAC (8387) vs (8751) FCachedKeyAndDataFields: array [boolean] of TKeyAndDataFields; FSQLGenerator: TDASQLGenerator; FIdentityField: TField; FUpdatingTableInfoIdx: integer; FUpdatingTable: string;//Can not delete because FTablesInfo created only on ~open FMasterFields: string; FDetailFields: string; FDesignCreate: boolean; FNonBlocking: boolean; FLockDebug: boolean; // locking trans debug info FUpdateQuery: TComponent; FUpdateComponents: array [TStatementType] of TComponent; FUpdateSQL: array [TStatementType] of TStrings; // SQLInsert, SQLUpdate etc FRecordCount: integer; FFetchAll: boolean; FFetchCanceled: boolean; FLeftQuote: char; FRightQuote: char; FStreamedOpen: Boolean; FBatchSQLs: StringBuilder; FBatchParams: TDAParams; FBatchStatements: integer; function GetFieldObject(Field: TField): TSharedObject; overload; function GetFieldObject(FieldDesc: TFieldDesc): TSharedObject; overload; function BatchUpdate: boolean; override; function CanFlushBatch: boolean; override; function PrepareBatch(SQL: string): string; virtual; procedure FlushBatch; override; procedure ClearBatch; function QuoteName(const AName: string): string; virtual; function UnQuoteName(AName: string): string; virtual; procedure CheckInactive; override; procedure CreateIRecordSet; override; procedure FreeIRecordSet; procedure SetIRecordSet(Value: TData{TRecordSet}); override; procedure CheckIRecordSet; procedure CreateCommand; virtual; procedure FreeCommand; procedure SetCommand(Value: TCustomDASQL); function CreateOptions: TDADataSetOptions; virtual; procedure Loaded; override; procedure SetConnection(Value: TCustomDAConnection); function UsedConnection: TCustomDAConnection; virtual; procedure CheckConnection; virtual; procedure BeginConnection(NoConnectCheck: boolean = True); virtual; procedure EndConnection; virtual; procedure Disconnect; virtual; procedure ConnectChange(Sender: TObject; Connecting: boolean); virtual; { TablesInfo } function GetTablesInfo: TCRTablesInfo; procedure SetUpdatingTable(Value: string); virtual; procedure InitUpdatingTable; procedure DetectIdentityField; virtual; function ReadOnlyFieldsEnabled: boolean; virtual; { Open/Close } procedure SetActive(Value: Boolean); override; procedure BeforeOpenCursor(InfoQuery: boolean); virtual; procedure OpenCursor(InfoQuery: boolean); override; procedure AfterOpenCursor(InfoQuery: boolean); virtual; procedure CloseCursor; override; function OpenCursorAllowFailOver: boolean; virtual; function GetActualFieldName(FieldDesc: TFieldDesc): string; overload; function GetActualFieldName(Field: TField): string; overload; procedure GetCurrentKeys(out KeyFields: TFieldArray; out Values: variant); procedure DataReopen; override; procedure InternalRefresh; override; procedure InternalRefreshQuick(const CheckDeleted: boolean); virtual; procedure InternalExecute; virtual; procedure InternalClose; override; function GetRecCount: longint; virtual; procedure SetRefreshOptions(Value: TRefreshOptions); virtual; procedure SetFetchAll(Value: boolean); virtual; procedure BeforeExecute; virtual; { Edit } function IsNeedEditPreconnect: boolean; virtual; function IsNeedInsertPreconnect: boolean; virtual; procedure SetReadOnly(Value: boolean); virtual; function IsPreconnected : boolean; virtual; procedure InternalBeforeEdit; virtual; procedure InternalEdit; override; procedure InternalInsert; override; procedure InternalCancel; override; procedure InternalPost; override; procedure InternalDeferredPost; override; procedure InternalApplyUpdates(AllowFailOver: boolean); procedure CreateSQLGenerator; virtual; procedure FreeSQLGenerator; procedure SetSQLGenerator(Value: TDASQLGenerator); function GetUpdateStatement(const StatementType: TStatementType): string; virtual; function GetUpdateSQLStatementTypes: TStatementTypes; virtual; function GetUpdateSQLIndex(Index: integer): TStrings; procedure SetUpdateSQLIndex(Index: integer; Value: TStrings); procedure SetFilterSQL(Value: string); virtual; //CR ODAC (8387) vs (8751) procedure SetFiltered(Value: boolean); override; function PerformAppend: boolean; override; function PerformDelete: boolean; override; function PerformUpdate: boolean; override; procedure InternalRefreshRecord; virtual; procedure CheckUpdateQuery(const StatementType: TStatementType); virtual; procedure UpdateExecute(const StatementTypes: TStatementTypes); virtual; procedure CheckUpdateSQL(const SQL: string; const StatementTypes: TStatementTypes; out ParamsInfo: TDAParamsInfo); virtual; function UseParamType: boolean; virtual; //This function indicates ParamType using in PerformSQL function FieldByParamName(var ParamName: string; var Old: boolean; var AFieldNo: integer): TField; virtual; function PerformSQL(const SQL: string; const StatementTypes: TStatementTypes): boolean; virtual; function RefreshAfterInsertAllowed: boolean; virtual; { RefreshQuick } function IsRefreshQuickField(FieldDesc: TFieldDesc): boolean; virtual; procedure SaveMaxRefreshQuickValue(FieldDesc: TFieldDesc; const Value: variant); virtual; function IsAutoCommit: boolean; virtual; function ShouldPrepareUpdateSQL: boolean; virtual; function GetCanModify: boolean; override; procedure SetStateFieldValue(State: TDataSetState; Field: TField; const Value: Variant); override; // Need to support int64 fields on PerformSQL in RefreshRecord function CanRefreshField(Field: TField): boolean; virtual; function NeedReturnParams: boolean; virtual; procedure AssignFieldValue(Param: TDAParam; Field: TField; Old: boolean); overload; virtual; procedure AssignFieldValue(Param: TDAParam; FieldDesc: TFieldDesc; Old: boolean); overload; virtual; procedure GetIdentityField; virtual; procedure GetKeyAndDataFields(out KeyAndDataFields: TKeyAndDataFields; const ForceUseAllKeyFields: boolean); virtual; procedure ClearCachedKeyAndDataFields; { Master/Detail } procedure RefreshParams; function NeedDetailRefresh(Param: TDAParam; FieldValue: TSharedObject): boolean; virtual; procedure RefreshDetail(Sender: TObject); function SetMasterParams(AParams: TDAParams): boolean; function IsConnectedToMaster: boolean; procedure RefreshDetailSQL; function LocalDetailFilter(RecBuf: IntPtr): boolean; procedure AssembleSQL; procedure ScanMacros(Sender: TObject = nil); virtual; procedure DefineProperties(Filer: TFiler); override; procedure AssignTo(Dest: TPersistent); override; procedure DoAfterExecute(Result: boolean); virtual; procedure DoAfterExecFetch(Result: boolean); procedure DoAfterFetchAll(Result: boolean); procedure DoAfterScroll; override; procedure DoOnBeforeFetch(out Cancel: boolean); virtual; procedure DoOnAfterFetch; virtual; procedure DoOnDataChanged; procedure DoOnNewRecord; override; function GetDataSource: TDataSource; override; function GetRecordCount: integer; override; function GetIsQuery: boolean; virtual; { Before / After UpdateExecute } function AssignedBeforeUpdateExecute: boolean; virtual; procedure DoBeforeUpdateExecute(Sender: TDataSet; StatementTypes: TStatementTypes; Params: TDAParams); virtual; function AssignedAfterUpdateExecute: boolean; virtual; procedure DoAfterUpdateExecute(Sender: TDataSet; StatementTypes: TStatementTypes; Params: TDAParams); virtual; { KeySequence } procedure InternalOpen; override; { SQL Modifications } function SQLAddWhere(SQLText, Condition: string): string; virtual; function SQLDeleteWhere(SQLText: string): string; virtual; function SQLGetWhere(SQLText: string): string; virtual; function SQLSetOrderBy(SQLText: string; Fields: string): string; virtual; function SQLGetOrderBy(SQLText: string): string; virtual; function GetFinalSQL: string; virtual; { TablesInfo } property TablesInfo: TCRTablesInfo read GetTablesInfo; property IdentityField: TField read FIdentityField; property UpdatingTableInfoIdx: integer read FUpdatingTableInfoIdx; property UpdatingTable: string read FUpdatingTable write SetUpdatingTable; // Does not need for public use { XML } procedure WriteFieldXMLAttributeType(Field: TField; FieldDesc: TFieldDesc; const FieldAlias: string; XMLWriter: XMLTextWriter); override; property AutoCommit: boolean read FAutoCommit write SetAutoCommit default True; property UpdateObject: TCustomDAUpdateSQL read FUpdateObject write SetUpdateObject; public constructor Create(Owner: TComponent); override; destructor Destroy; override; { Open/Close } procedure Prepare; override; procedure UnPrepare; override; procedure Execute; virtual; function Executing: boolean; function Fetching: boolean; function FetchingAll: boolean; function Fetched: boolean; virtual; procedure Resync(Mode: TResyncMode); override; procedure GetDetailLinkFields(MasterFields, DetailFields: {$IFDEF CLR}TObjectList{$ELSE}TList{$ENDIF}); override; {for BDE compatibility} function FindKey(const KeyValues: array of const): Boolean; procedure FindNearest(const KeyValues: array of const); procedure GotoCurrent(DataSet: TCustomDADataSet); function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; { Edit } procedure ApplyUpdates; override; property SQLInsert: TStrings index stInsert read GetUpdateSQLIndex write SetUpdateSQLIndex; property SQLDelete: TStrings index stDelete read GetUpdateSQLIndex write SetUpdateSQLIndex; property SQLUpdate: TStrings index stUpdate read GetUpdateSQLIndex write SetUpdateSQLIndex; property SQLRefresh: TStrings index stRefresh read GetUpdateSQLIndex write SetUpdateSQLIndex; procedure RefreshRecord; //procedure Lock; //procedure Unlock; function FindParam(const Value: string): TDAParam; function ParamByName(const Value: string): TDAParam; function FindMacro(const Value: string): TMacro; function MacroByName(const Value: string): TMacro; { SQL Modifications } procedure SaveSQL; procedure RestoreSQL; function SQLSaved: boolean; procedure AddWhere(Condition: string); procedure DeleteWhere; procedure SetOrderBy(Fields: string); function GetOrderBy: string; { Additional data types } function GetField(FieldDesc: TFieldDesc): TField; function GetDataType(const FieldName: string): integer; virtual; function GetFieldDesc(const FieldName: string): TFieldDesc; overload; function GetFieldDesc(const FieldNo: integer): TFieldDesc; overload; virtual; function GetFieldPrecision(const FieldName: string): integer; function GetFieldScale(const FieldName: string): integer; function GetFieldObject(const FieldName: string): TSharedObject; overload; property Connection: TCustomDAConnection read FConnection write SetConnection; property ParamCheck: boolean read GetParamCheck write SetParamCheck default True; // before SQL property SQL: TStrings read GetSQL write SetSQL; property FetchRows: integer read FFetchRows write SetFetchRows default 25; property FetchAll: boolean read FFetchAll write SetFetchAll default False; property Debug: boolean read FDebug write FDebug default False; property MasterSource: TDataSource read GetDataSource write SetMasterSource; property Params: TDAParams read GetParams write SetParams stored False; property ParamCount: word read GetParamCount; property Macros: TMacros read GetMacros write SetMacros stored False; property MacroCount: word read GetMacroCount; property UniDirectional: boolean read FUniDirectional write SetUniDirectional default False; property ReadOnly: boolean read FReadOnly write SetReadOnly default False; property RowsAffected: integer read GetRowsAffected; property IsQuery: boolean read GetIsQuery; property RefreshOptions: TRefreshOptions read FRefreshOptions write SetRefreshOptions default []; property Options: TDADataSetOptions read FOptions write SetOptions; property BaseSQL: string read GetBaseSQL; property FinalSQL: string read GetFinalSQL; property FilterSQL: string read FFilterSQL write SetFilterSQL; property MasterFields: string read FMasterFields write SetMasterFields; property DetailFields: string read FDetailFields write SetForeignKeyFields; // ForeignKeyFields property AfterExecute: TAfterExecuteEvent read FAfterExecute write FAfterExecute; property BeforeUpdateExecute: TUpdateExecuteEvent read FBeforeUpdateExecute write FBeforeUpdateExecute; property AfterUpdateExecute: TUpdateExecuteEvent read FAfterUpdateExecute write FAfterUpdateExecute; property BeforeFetch: TBeforeFetchEvent read FBeforeFetch write FBeforeFetch; property AfterFetch: TAfterFetchEvent read FAfterFetch write FAfterFetch; end; { TCustomDASQL } TCustomDASQL = class (TComponent) private FConnection: TCustomDAConnection; FSQL: TStrings; FParams: TDAParams; FParamCheck: boolean; FMacros: TMacros; FDebug: boolean; FChangeCursor: boolean; FAfterExecute: TAfterExecuteEvent; {FOnDisconnect: TNotifyEvent; FGetFinalSQL: TGetFinalSQLEvent; FOnScanMacros: TNotifyEvent;} procedure SetSQL(Value: TStrings); function GetPrepared: boolean; procedure SetPrepared(Value: boolean); procedure SetParams(Value: TDAParams); function GetParamCount: word; procedure SetParamCheck(Value: boolean); function GetParamValues(ParamName: string): variant; procedure SetParamValues(ParamName: string; Value: variant); procedure SetMacros(Value: TMacros); function GetMacroCount: word; function GetRowsAffected: integer; protected FAutoCommit: boolean; FICommand: TCRCommand; FDataSet: TCustomDADataSet; // dataset that owns FDesignCreate: boolean; // for design-time only FNonBlocking: boolean; FLockDebug, FLockAssembleSQL, FLockMacros: boolean; // locking trans debug info FNativeSQL: string; procedure CreateICommand; virtual; procedure FreeICommand; procedure SetICommand(Value: TCRCommand); virtual; procedure CheckICommand; function CreateParamsObject: TDAParams; virtual; procedure Loaded; override; procedure SetAutoCommit(Value: boolean); procedure SetConnection(Value: TCustomDAConnection); function UsedConnection: TCustomDAConnection; virtual; procedure CheckConnection; virtual; procedure BeginConnection(NoConnectCheck: boolean = True); virtual; procedure EndConnection; virtual; procedure Disconnect; virtual; procedure ConnectChange(Sender: TObject; Connecting: boolean); virtual; procedure InternalPrepare; virtual; procedure InternalUnPrepare; virtual; procedure InternalExecute(Iters: integer); virtual; procedure DoAfterExecute(Result: boolean); /// Parse SQL and replace ':ParamName' by '?' /// Params may be nil function ParseSQL(const SQL: string; Params: TDAParams; RenamePrefix: string = ''): string; overload; virtual; function ParseSQL(Params: TDAParams): string; overload; procedure ParseSQLParam(ParsedSQL: StringBuilder; Parser: TParser; Params: TDAParams; const LeftQuote, RightQuote: char; RenamePrefix: string); virtual; function CreateParser(const Text: string): TParser; virtual; procedure SQLChanged(Sender: TObject); virtual; procedure ScanMacros; virtual; function GetFinalSQL: string; virtual; procedure AssembleSQL; virtual; procedure CreateParams; virtual; procedure WriteParams(WriteValue: boolean = True); virtual; procedure ReadParams; virtual; procedure DefineProperties(Filer: TFiler); override; procedure ReadParamData(Reader: TReader); procedure WriteParamData(Writer: TWriter); procedure ReadMacroData(Reader: TReader); procedure WriteMacroData(Writer: TWriter); procedure AssignTo(Dest: TPersistent); override; property AutoCommit: boolean read FAutoCommit write SetAutoCommit default False; public constructor Create(Owner: TComponent); override; destructor Destroy; override; procedure Prepare; virtual; procedure UnPrepare; virtual; procedure Execute; overload; virtual; procedure Execute(Iters: integer); overload; virtual; function Executing: boolean; function WaitExecuting(TimeOut: integer = 0): boolean; function FindParam(const Value: string): TDAParam; function ParamByName(const Value: string): TDAParam; function FindMacro(const Value: string): TMacro; function MacroByName(const Value: string): TMacro; property Connection: TCustomDAConnection read FConnection write SetConnection; property ParamCheck: boolean read FParamCheck write SetParamCheck default True; // before SQL property SQL: TStrings read FSQL write SetSQL; property Prepared: boolean read GetPrepared write SetPrepared; property Params: TDAParams read FParams write SetParams stored False; property ParamCount: word read GetParamCount; property ParamValues[ParamName: string]: variant read GetParamValues write SetParamValues; default; property Macros: TMacros read FMacros write SetMacros stored False; property MacroCount: word read GetMacroCount; property Debug: boolean read FDebug write FDebug default False; property ChangeCursor: boolean read FChangeCursor write FChangeCursor; property RowsAffected: integer read GetRowsAffected; property FinalSQL: string read GetFinalSQL; property AfterExecute: TAfterExecuteEvent read FAfterExecute write FAfterExecute; end; { TCustomDAUpdateSQL } TCustomDAUpdateSQL = class (TComponent) private FDataSet: TCustomDADataSet; FSQLText: array [TStatementType] of TStrings; FUpdateObject: array [TStatementType] of TComponent; protected FDesignCreate: boolean; // for design-time only // get/set FSQLText by TStatementType function GetSQLIndex(Index: integer): TStrings; procedure SetSQLIndex(Index: integer; Value: TStrings); // get/set FSQLText by TUpdateKind function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings); // get/set FUpdateObject by TStatementType function GetObjectIndex(Index: integer): TComponent; procedure SetObjectIndex(Index: integer; Value: TComponent); function GetDataSet: TCustomDADataSet; virtual; procedure SetDataSet(DataSet: TCustomDADataSet); virtual; procedure Loaded; override; procedure AssignTo(Dest: TPersistent); override; function DataSetClass: TCustomDADataSetClass; virtual; function SQLClass: TCustomDASQLClass; virtual; procedure CheckUpdateComponent(Component: TComponent); overload; procedure CheckUpdateComponent(Component: TComponent; NewDataset: TCustomDADataset); overload; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(Owner: TComponent); override; destructor Destroy; override; procedure Apply(UpdateKind: TUpdateKind); virtual; procedure ExecSQL(UpdateKind: TUpdateKind); property DataSet: TCustomDADataSet read GetDataSet write SetDataSet; property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL; published property InsertSQL: TStrings index stInsert read GetSQLIndex write SetSQLIndex; property DeleteSQL: TStrings index stDelete read GetSQLIndex write SetSQLIndex; property ModifySQL: TStrings index stUpdate read GetSQLIndex write SetSQLIndex; property RefreshSQL: TStrings index stRefresh read GetSQLIndex write SetSQLIndex; property InsertObject: TComponent index stInsert read GetObjectIndex write SetObjectIndex; property DeleteObject: TComponent index stDelete read GetObjectIndex write SetObjectIndex; property ModifyObject: TComponent index stUpdate read GetObjectIndex write SetObjectIndex; property RefreshObject: TComponent index stRefresh read GetObjectIndex write SetObjectIndex; end; { TMacro } TMacro = class (TCollectionItem) private FName: string; FValue: string; FActive: boolean; //FOwner: TComponent; procedure SetValue(Value: string); procedure SetActive(Value: boolean); function GetAsDateTime: TDateTime; procedure SetAsDateTime(Value: TDateTime); function GetAsFloat: double; procedure SetAsFloat(Value: double); function GetAsInteger: integer; procedure SetAsInteger(Value: integer); function GetAsString: string; procedure SetAsString(Value: string); protected procedure AssignTo(Dest: TPersistent); override; function IsEqual(Value: TMacro): boolean; function GetDisplayName: string; override; public constructor Create(Collection: TCollection); override; property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime; property AsFloat: double read GetAsFloat write SetAsFloat; property AsInteger: integer read GetAsInteger write SetAsInteger; property AsString: string read GetAsString write SetAsString; published property Name: string read FName write FName; property Value: string read FValue write SetValue; property Active: boolean read FActive write SetActive default True; end; { TMacros } TMacros = class (TCollection) private FOwner: TPersistent; procedure ReadBinaryData(Stream: TStream); //procedure WriteBinaryData(Stream: TStream); function GetItem(Index: integer): TMacro; procedure SetItem(Index: integer; Value: TMacro); function GetUpdateCount: integer; protected FParserClass: TParserClass; procedure AssignTo(Dest: TPersistent); override; procedure DefineProperties(Filer: TFiler); override; function GetOwner: TPersistent; override; procedure Update(Item: TCollectionItem); override; function GetMacroValue(Macro: TMacro): string; virtual; property UpdateCount: integer read GetUpdateCount; public constructor Create(Owner: TPersistent); procedure Scan(SQL: string); // ParseSQL procedure AssignValues(Value: TMacros); function IsEqual(Value: TMacros): boolean; function FindMacro(const Value: string): TMacro; function MacroByName(const Value: string): TMacro; procedure Expand(var SQL: string); procedure SetParserClass(Value: TParserClass); property Items[Index: integer]: TMacro read GetItem write SetItem; default; end; { TCustomConnectDialog } TLabelSet = (lsCustom, lsEnglish, lsFrench, lsGerman, lsItalian, lsPolish, lsPortuguese, lsRussian, lsSpanish); TCustomConnectDialog = class(TComponent) private FConnection: TCustomDAConnection; FRetries: word; FDialogClass: string; FSavePassword: boolean; FStoreLogInfo: boolean; FLabelSet: TLabelSet; FCaption: string; FUsernameLabel: string; FPasswordLabel: string; FServerLabel: string; FConnectButton: string; FCancelButton: string; procedure SetCaption(Value: string); procedure SetUsernameLabel(Value: string); procedure SetPasswordLabel(Value: string); procedure SetServerLabel(Value: string); procedure SetConnectButton(Value: string); procedure SetCancelButton(Value: string); protected {$IFDEF WIN32} function GetString(Id: integer): string; {$ENDIF} procedure SetLabelSet(Value: TLabelSet); virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); override; function DefDialogClass: TClass; virtual; function GetKeyPath: string; virtual; function GetServerStoreName: string; virtual; {$IFDEF MSWINDOWS} procedure SaveInfoToRegistry(Registry: TRegistry); virtual; procedure LoadInfoFromRegistry(Registry: TRegistry); virtual; {$ENDIF} //class function AcceptBlankPassword: boolean; virtual; public constructor Create(Owner: TComponent); override; function Execute: boolean; virtual; procedure GetServerList(List: TStrings); virtual; property Connection: TCustomDAConnection read FConnection; property Retries: word read FRetries write FRetries default 3; property SavePassword: boolean read FSavePassword write FSavePassword default False; property StoreLogInfo: boolean read FStoreLogInfo write FStoreLogInfo default True; property DialogClass: string read FDialogClass write FDialogClass; property Caption: string read FCaption write SetCaption; property UsernameLabel: string read FUsernameLabel write SetUsernameLabel; property PasswordLabel: string read FPasswordLabel write SetPasswordLabel; property ServerLabel: string read FServerLabel write SetServerLabel; property ConnectButton: string read FConnectButton write SetConnectButton; property CancelButton: string read FCancelButton write SetCancelButton; property LabelSet: TLabelSet read FLabelSet write SetLabelSet default lsEnglish; end; TTableInfo = record Name: string; Alias: string; end; TTablesInfo = array of TTableInfo; {$IFDEF MSWINDOWS} { TCRNetManager } TCRServiceStatus = (ssStopped, ssStartPending, ssStopPending, ssRunning, ssContinuePending, ssPausePending, ssPaused); // equal to TCurrentStatus from SvcMgr TCRServiceInfo = record ServiceName, DisplayName: string; Status: TCRServiceStatus; end; TCRServicesInfo = array of TCRServiceInfo; TCRServiceNamesThread = class; TCRServicesThread = class(TThread) private FList: TStrings; FKeywords: string; protected property Terminated; procedure Execute; override; public constructor Create(List: TStrings; const Keywords: string); end; TCRServiceNamesThread = class(TThread) protected FKeywords: string; FServices: TCRServicesThread; FServer: string; FServiceNames: TCRServicesInfo; procedure Execute; override; public constructor Create(const Server: string; Services: TCRServicesThread; const Keywords: string); end; SC_HANDLE = THandle; TCRNetManager = class protected FServicesCS: TCriticalSection; FCachedServerList: TStringList; FLastTickCount: LongWord; class procedure ServiceManagerOpen(const Server: string; const ReadOnly: boolean; out sch: SC_HANDLE); class procedure ServiceManagerClose(const sch: SC_HANDLE); class procedure ServiceOpen(const Server: string; const ServiceName: string; const ReadOnly: boolean; out sch: SC_HANDLE; out sh: SC_HANDLE); class procedure ServiceClose(const sch: SC_HANDLE; const sh: SC_HANDLE); procedure ClearCachedServerList; procedure AddToCachedServerList(const Keywords: string; const Server: string); public constructor Create; destructor Destroy; override; // Service Control class function GetServiceNames(const Server: string): TCRServicesInfo; class function GetServiceStatus(const Server: string; const ServiceName: string): TCRServiceStatus; class procedure ServiceStart(const Server: string; const ServiceName: string; ParamStr: string = ''); class procedure ServiceStop(const Server: string; const ServiceName: string); // Net control class procedure GetServerList(List: TStrings); overload; procedure GetServerList(List: TStrings; const Keywords: string; const Timeout: Longword = 1; const CacheTimeout: Longword = 120); overload; end; var CRNetManager: TCRNetManager; type {$ENDIF} TDADataSetUtils = class protected FCount: integer; FDataSet: TCustomDADataSet; FOldActive: boolean; FOldDebug: boolean; FOldFetchAll: boolean; FOldFetchRows: integer; public procedure QuickOpen(DataSet: TCustomDADataSet; Refresh: boolean = False); virtual; procedure Restore(RestoreActive: boolean = True); virtual; procedure QuickOpenAndRestore(DataSet: TCustomDADataSet; Refresh: boolean = False); end; { TCRDataSource } TCRDataSource = class (TDataSource) protected FDesignCreate: boolean; procedure Loaded; override; procedure AssignTo(Dest: TPersistent); override; public constructor Create(Owner: TComponent); override; end; TDBAccessUtils = class public class function IsKeyViolation(Obj: TCustomDAConnection; E: EDAError): boolean; class function IsObjectDataType(Obj: TDAParam; DataType: TFieldType): boolean; class procedure CheckConnection(Obj: TCustomDADataSet); overload; class procedure CheckConnection(Obj: TCustomDASQL); overload; class function UsedConnection(Obj: TCustomDADataSet): TCustomDAConnection; overload; class function UsedConnection(Obj: TCustomDASQL): TCustomDAConnection; overload; class procedure SetAutoCommit(Obj: TComponent; Value: boolean); class function GetAutoCommit(Obj: TComponent): boolean; class procedure SetDesignCreate(Obj: TCustomDADataSet; Value: boolean); overload; class function GetDesignCreate(Obj: TCustomDADataSet): boolean; overload; class procedure SetDesignCreate(Obj: TCustomDASQL; Value: boolean); overload; class function GetDesignCreate(Obj: TCustomDASQL): boolean; overload; class procedure SetDesignCreate(Obj: TCustomDAUpdateSQL; Value: boolean); overload; class function GetDesignCreate(Obj: TCustomDAUpdateSQL): boolean; overload; class procedure SetDesignCreate(Obj: TCRDataSource; Value: boolean); overload; class function GetDesignCreate(Obj: TCRDataSource): boolean; overload; class function CreateIRecordSet(Obj: TCustomDAConnection): TCRRecordSet; class function GetIConnection(Obj: TCustomDAConnection): TCRConnection; class function GetUpdateQuery(Obj: TCustomDADataSet): TComponent; class function GetTablesInfo(Obj: TCustomDADataSet): TCRTablesInfo; class function GetUpdatingTable(Obj: TCustomDADataSet): string; class procedure SetUpdatingTable(Obj: TCustomDADataSet; Value: string); class function GetUpdatingTableIdx(Obj: TCustomDADataSet): integer; class procedure SetUpdatingTableIdx(Obj: TCustomDADataSet; Value: integer); class procedure InternalConnect(Obj: TCustomDAConnection); class procedure InternalDisconnect(Obj: TCustomDAConnection); class procedure SuppressAutoCommit(Obj: TCustomDAConnection); class procedure RestoreAutoCommit(Obj: TCustomDAConnection); class procedure Disconnect(Obj: TCustomDASQL); class function SQLGenerator(Obj: TCustomDADataSet): TDASQLGenerator; class function GetSQLs(Obj: TCustomDAConnection): TDAList; class procedure GetKeyAndDataFields( Obj: TCustomDADataSet; out KeyAndDataFields: TKeyAndDataFields; const ForceUseAllKeyFields: boolean); class function GetLockDebug(Obj: TComponent): boolean; class procedure SetLockDebug(Obj: TComponent; Value: boolean); class function FOwner(Obj: TDAConnectionOptions): TCustomDAConnection; overload; class function FOwner(Obj: TDADataSetOptions): TCustomDADataSet; overload; class function SQLMonitorClass(Obj: TCustomDAConnection): TClass; class function QuoteName(Obj: TCustomDADataSet; const AName: string): string; class function UnQuoteName(Obj: TCustomDADataSet; AName: string): string; class procedure RegisterClient(Obj: TCustomDAConnection; Client: TObject; Event: TConnectChangeEvent = nil); class procedure UnRegisterClient(Obj: TCustomDAConnection; Client: TObject); class function GetIdentityField(Obj: TCustomDADataSet): TField; class function GetSQL(Obj: TComponent): TStrings; class procedure SetSQL(Obj: TComponent; Value: TStrings); class procedure SetSQLText(Obj: TComponent; const SQLText: string; const LockAssembleSQL, LockMacros: boolean; const DisableScanParams: boolean = True); class function GetParams(Obj: TComponent): TDAParams; class procedure Execute(Obj: TComponent); class procedure Open(Obj: TComponent); class function GetRowsAffected(Obj: TComponent): integer; class function GetUpdateSQLStatementTypes(Obj: TCustomDADataSet): TStatementTypes; class function GetUpdateSQLIndex(Obj: TCustomDADataSet; StatementType: TStatementType): TStrings; class function ParseSQL(Obj: TCustomDASQL; const SQL: string; Params: TDAParams; RenamePrefix: string = ''): string; class function CreateParamsObject(Obj: TCustomDASQL): TDAParams; class procedure SetDesigning(Obj: TComponent; Value: Boolean; SetChildren: Boolean = True); class function GetIRecordSet(Obj: TCustomDADataSet): TCRRecordSet; class function GetDataSetClass(Obj: TCustomDAUpdateSQL): TCustomDADataSetClass; class function GetSQLClass(Obj: TCustomDAUpdateSQL): TCustomDASQLClass; class function GetParserClass(Obj: TMacros): TParserClass; end; const crSQLArrow = -30; procedure SetCursor(Value: integer); var ChangeCursor: boolean; MacroChar: char; SetCursorProc: procedure(Value: integer); ShowConnectFormProc: function(ConnectDialog: TCustomConnectDialog): boolean; BaseSQLOldBehavior: boolean; SQLGeneratorCompatibility: boolean; function _AddWhere( const SQL: string; Condition: string; ParserClass: TParserClass; // TOraParser, TMSparser, TMyParser OmitComment: boolean; SelectCode, WhereCode: integer ): string; function _SetWhere( const SQL: string; Condition: string; ParserClass: TParserClass; // TOraParser, TMSparser, TMyParser OmitComment: boolean; SelectCode, WhereCode: integer ): string; function _GetWhere( const SQL: string; ParserClass: TParserClass; // TOraParser, TMSparser, TMyParser OmitComment: boolean; SelectCode, WhereCode: integer ): string; function _SetOrderBy( const SQL: string; Fields: string; ParserClass: TParserClass; // TOraParser, TMSparser, TMyParser SelectCode, OrderCode, ByCode: Integer ): string; function _GetOrderBy( const SQL: string; ParserClass: TParserClass; // TOraParser, TMSparser, TMyParser SelectCode, OrderCode, ByCode: Integer ): string; function UpdateKindToStatementType(const UpdateKind: TUpdateKind): TStatementType; function StatementTypeToUpdateKind(const StatementType: TStatementType): TUpdateKind; implementation uses {$IFDEF PERF_COUNTER} Debug, {$ENDIF} {$IFDEF CLR} System.Security, {$ENDIF} {$IFNDEF LINUX} Messages, {$ENDIF} DBCommon, DBConsts, DAConsts, DASQLMonitor, CRConnectionPool; {$IFDEF WIN32} {$R *.res} {$ENDIF} procedure SetCursor(Value: integer); begin if Assigned(SetCursorProc) then SetCursorProc(Value); end; function _AddWhere( const SQL: string; Condition: string; ParserClass: TParserClass; // TOraParser, TMSparser, TMyParser OmitComment: boolean; SelectCode, WhereCode: integer ): string; var Parser: TParser; IsWhere: boolean; Code: integer; PrevCode: integer; St: string; StLex: string; BracketCount: integer; WherePos: integer; NeedBracket: boolean; Bracket: string; IsMacro: boolean; MacroSt: string; begin Result := SQL; if Trim(Condition) = '' then Exit; Parser := ParserClass.Create(PChar(SQL)); Parser.OmitComment := OmitComment; WherePos := 0; IsMacro := False; MacroSt := MacroChar; try if Parser.ToLexem(SelectCode) <> lcEnd then begin IsWhere := False; NeedBracket := False; Code := 0; BracketCount := 0; repeat PrevCode := Code; Code := Parser.GetNext(StLex); //+++ char instead of string if (Code = WhereCode) and (not IsMacro) and (BracketCount = 0) then begin IsWhere := True; WherePos := Parser.CurrPos + 2; NeedBracket := True; end else if Code = lcSymbol then if StLex = '(' then Inc(BracketCount) else if StLex = ')' then Dec(BracketCount); IsMacro := (Code <> lcString) and (StLex = MacroSt); if (BracketCount = 0) and Parser.IsClauseLexem(Code) and (Code <> WhereCode) then Break; until Code = lcEnd; if NeedBracket then begin if PrevCode = lcComment then Bracket := LineSeparator + ')' else Bracket := ')'; end; if not IsWhere then St := LineSeparator + 'WHERE ' + Condition + ' ' else if (PrevCode = lcComment) and not NeedBracket then St := LineSeparator +'AND ' + Condition + ' ' else St := ' AND ' + Condition + ' '; if Code = lcEnd then begin if NeedBracket then begin Insert('(', Result, WherePos); Result := Trim(Result) + Bracket + St; end else if not Parser.IsSemicolon(PrevCode) then Result := Trim(Result) + St else Insert(St, Result, Parser.PrevPos); end else if NeedBracket then begin Insert(Bracket + St, Result, Parser.PrevPos + 1); Insert('(', Result, WherePos); end else Insert(St, Result, Parser.PrevPos + 1); end; finally Parser.Free; end; end; //++ Must be merged with _AddWhere function _SetWhere( const SQL: string; Condition: string; ParserClass: TParserClass; // TOraParser, TMSparser, TMyParser OmitComment: boolean; SelectCode, WhereCode: integer ): string; var Parser: TParser; FirstPos: integer; LastPos: integer; Code: integer; StLex: string; BracketCount: integer; begin Result := SQL; Parser := ParserClass.Create(PChar(SQL)); Parser.OmitBlank := False; Parser.OmitComment := True; try if Parser.ToLexem(SelectCode) <> lcEnd then begin FirstPos := 0; LastPos := 0; BracketCount := 0; Code := Parser.GetNext(StLex); //+++ char instead of string repeat if Code = lcBlank then begin if LastPos = 0 then LastPos := Parser.PrevPos; end else begin LastPos := 0; if Code = WhereCode then begin if BracketCount = 0 then begin if Condition = '' then FirstPos := Parser.PrevPrevPos + 1 else begin Parser.GetNext(StLex); // blank FirstPos := Parser.CurrPos + 1; end; end; end else if Code = lcSymbol then begin if StLex = '(' then Inc(BracketCount) else if StLex = ')' then Dec(BracketCount); end; end; Code := Parser.GetNext(StLex); until (Code = lcEnd) or (Parser.IsClauseLexem(Code) and (Code <> WhereCode)) and (BracketCount = 0); if LastPos = 0 then LastPos := Length(Result); if FirstPos > 0 then Delete(Result, FirstPos, LastPos - FirstPos + 1); if Condition <> '' then begin if FirstPos = 0 then begin FirstPos := LastPos + 1; Condition := ' WHERE ' + Condition; if Pos(#13, Copy(Result, 1, FirstPos)) > 0 then Condition := LineSeparator + ' ' + Condition; end; Insert(Condition, Result, FirstPos); end; end; finally Parser.Free; end; end; function _GetWhere( const SQL: string; ParserClass: TParserClass; // TOraParser, TMSparser, TMyParser OmitComment: boolean; SelectCode, WhereCode: integer ): string; var Parser: TParser; IsWhere: boolean; Code: integer; StLex: string; BracketCount: integer; WherePos: integer; IsMacro: boolean; MacroSt: string; begin Result := ''; Parser := ParserClass.Create(PChar(SQL)); Parser.OmitComment := OmitComment; WherePos := 0; IsMacro := False; MacroSt := MacroChar; try if Parser.ToLexem(SelectCode) <> lcEnd then begin IsWhere := False; BracketCount := 0; repeat Code := Parser.GetNext(StLex); //+++ char instead of string if (Code = WhereCode) and (not IsMacro) and (BracketCount = 0) then begin IsWhere := True; WherePos := Parser.CurrPos + 2; end else if Code = lcSymbol then if StLex = '(' then Inc(BracketCount) else if StLex = ')' then Dec(BracketCount); IsMacro := (Code <> lcString) and (StLex = MacroSt); if (BracketCount = 0) and Parser.IsClauseLexem(Code) and (Code <> WhereCode) then begin Parser.Back; Break; end; until Code = lcEnd; if IsWhere then Result := Copy(SQL, WherePos, Parser.CurrPos - WherePos + 1); end; finally Parser.Free; end; end; function _SetOrderBy( const SQL: string; Fields: string; ParserClass: TParserClass; SelectCode, OrderCode, ByCode: Integer ): string; var Parser: TParser; FirstPos: integer; LastPos: integer; Code: integer; i, p, pOrder: integer; begin for i := 1 to Length(Fields) do if Fields[i] = ';' then Fields[i] := ','; Result := SQL; Parser := ParserClass.Create(PChar(Result)); Parser.OmitBlank := False; Parser.OmitComment := True; try if Parser.ToLexem(SelectCode) <> lcEnd then begin FirstPos := 0; LastPos := 0; Code := Parser.GetNextCode; pOrder := Parser.PosClauseLexem(OrderCode); repeat if Code = OrderCode then begin if Fields = '' then FirstPos := Parser.PrevPrevPos + 1; Parser.GetNextCode; // blank if Parser.GetNextCode = ByCode then begin if Fields <> '' then begin Parser.GetNextCode; // blank FirstPos := Parser.CurrPos + 1; end; end else FirstPos := 0; end; if (Code = lcBlank) or (Code = lcComment) then begin if LastPos = 0 then LastPos := Parser.PrevPos; end else LastPos := 0; Code := Parser.GetNextCode; p := Parser.PosClauseLexem(Code); if p > pOrder then Break; until (Code = lcEnd); if LastPos = 0 then LastPos := Length(Result); if FirstPos > 0 then Delete(Result, FirstPos, LastPos - FirstPos + 1); if Fields <> '' then begin if FirstPos = 0 then begin FirstPos := LastPos + 1; Fields := ' ORDER BY ' + Fields; if Pos(#13, Copy(Result, 1, FirstPos)) > 0 then Fields := LineSeparator + ' ' + Fields; end; Insert(Fields, Result, FirstPos); end; end; finally Parser.Free; end; end; function _GetOrderBy( const SQL: string; ParserClass: TParserClass; SelectCode, OrderCode, ByCode: Integer ): string; var Parser: TParser; FirstPos: integer; LastPos: integer; Code: integer; begin Result := ''; Parser := ParserClass.Create(PChar(SQL)); try FirstPos := 0; LastPos := Length(SQL); if Parser.ToLexem(SelectCode) <> lcEnd then begin if Parser.ToLexem(OrderCode) <> lcEnd then if Parser.GetNextCode = ByCode then FirstPos := Parser.CurrPos + 1 else FirstPos := 0; if FirstPos <> 0 then begin Result := Copy(SQL, FirstPos, LastPos - FirstPos + 1); Parser.SetText(Result); repeat Code := Parser.GetNextCode; if Parser.IsClauseLexem(Code) then Result := Copy(Result, 0, Parser.PrevPos); until Code = lcEnd; end; end; finally Parser.Free; end; end; function UpdateKindToStatementType(const UpdateKind: TUpdateKind): TStatementType; begin case UpdateKind of DB.ukModify: Result := stUpdate; DB.ukInsert: Result := stInsert; DB.ukDelete: Result := stDelete; else begin Result := stCustom; // To prevent compiler warning Assert(False); end; end; end; function StatementTypeToUpdateKind(const StatementType: TStatementType): TUpdateKind; begin case StatementType of stUpdate: Result := DB.ukModify; stInsert: Result := DB.ukInsert; stDelete: Result := DB.ukDelete; else begin Result := DB.ukInsert; // To prevent compiler warning Assert(False); end; end; end; { EDAError } constructor EDAError.Create(ErrorCode: integer; Msg: string); begin inherited Create(Msg); FErrorCode := ErrorCode; end; { TDAConnectionOptions } constructor TDAConnectionOptions.Create(Owner: TCustomDAConnection); begin inherited Create; FOwner := Owner; KeepDesignConnected := True; end; procedure TDAConnectionOptions.AssignTo(Dest: TPersistent); begin if Dest is TDAConnectionOptions then begin TDAConnectionOptions(Dest).KeepDesignConnected := KeepDesignConnected; TDAConnectionOptions(Dest).DisconnectedMode := DisconnectedMode; end else inherited; end; procedure TDAConnectionOptions.SetDisconnectedMode(Value: boolean); begin if Value <> DisconnectedMode then begin FOwner.Disconnect; FDisconnectedMode := Value; if FOwner.FIConnection <> nil then FOwner.FIConnection.SetProp(prDisconnectedMode, Value); end; end; { TPoolingOptions } constructor TPoolingOptions.Create(Owner: TCustomDAConnection); begin inherited Create; FOwner := Owner; FMaxPoolSize := 100; end; procedure TPoolingOptions.AssignTo(Dest: TPersistent); begin if Dest is TPoolingOptions then begin TPoolingOptions(Dest).FMaxPoolSize := FMaxPoolSize; TPoolingOptions(Dest).FMinPoolSize := FMinPoolSize; TPoolingOptions(Dest).FConnectionLifetime := FConnectionLifetime; TPoolingOptions(Dest).FValidate := FValidate; end else inherited; end; { TCustomDAConnection } constructor TCustomDAConnection.Create(Owner: TComponent); begin inherited Create(Owner); FSQLs := TDAList.Create; FAutoCommit := True; LoginPrompt := True; FOptions := CreateOptions; FPoolingOptions := CreatePoolingOptions; FShouldShowPrompt := True; hRegisterClient := TCriticalSection.Create; end; destructor TCustomDAConnection.Destroy; begin try Disconnect; finally ClearRefs; inherited; FSQLs.Free; // placed after inherited for successful UnregisterClient on destroy FreeIConnection; FPoolingOptions.Free; FOptions.Free; hRegisterClient.Free; end; end; procedure TCustomDAConnection.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (Operation = opRemove) and (FConnectDialog = AComponent) then FConnectDialog := nil; end; function TCustomDAConnection.GetIConnectionClass: TCRConnectionClass; begin Assert(False, 'Must be overrided'); Result := TCRConnection; end; function TCustomDAConnection.GetICommandClass: TCRCommandClass; begin Assert(False, 'Must be overrided'); Result := TCRCommand; end; function TCustomDAConnection.GetIRecordSetClass: TCRRecordSetClass; begin Assert(False, 'Must be overrided'); Result := TCRRecordSet; end; procedure TCustomDAConnection.CreateIConnection; begin SetIConnection(nil); end; function TCustomDAConnection.CreateICommand: TCRCommand; begin Result := GetICommandClass.Create; Result.SetConnection(nil); end; function TCustomDAConnection.CreateIRecordSet: TCRRecordSet; begin Result := GetIRecordSetClass.Create; Result.SetConnection(FIConnection); end; procedure TCustomDAConnection.FreeIConnection; begin if FIConnection = nil then exit; if FIConnection.Pool <> nil then FIConnection.ReturnToPool else FIConnection.Free; SetIConnection(nil); end; procedure TCustomDAConnection.SetIConnection(Value: TCRConnection); var i: integer; begin if Value <> nil then begin FIConnection := Value; FIConnection.OnError := DoError; FIConnection.OnReconnectError := Disconnect; FIConnection.OnReconnectSuccess := DoAfterConnect; FIConnection.Component := Self; for i := 0 to FSQLs.Count - 1 do begin TCustomDASQL(FSQLs[i]).CheckICommand; TCustomDASQL(FSQLs[i]).FICommand.SetConnection(FIConnection); end; for i := 0 to DataSetCount - 1 do begin (DataSets[i] as TCustomDADataSet).CheckIRecordSet; (DataSets[i] as TCustomDADataSet).FIRecordSet.SetConnection(FIConnection); end; end else begin if (FIConnection <> nil) and not (csDestroying in ComponentState) then begin for i := 0 to FSQLs.Count - 1 do if TCustomDASQL(FSQLs[i]).FICommand <> nil then TCustomDASQL(FSQLs[i]).FICommand.SetConnection(Value {nil}); for i := 0 to DataSetCount - 1 do if (DataSets[i] as TCustomDADataSet).FIRecordSet <> nil then TCustomDADataSet(DataSets[i]).FIRecordSet.SetConnection(Value {nil}); end; FIConnection := Value; end; end; function TCustomDAConnection.CreateDataSet: TCustomDADataSet; begin Result := TCustomDADataSet.Create(nil); // Self ??? Result.Connection := Self; end; function TCustomDAConnection.CreateSQL: TCustomDASQL; begin Result := TCustomDASQL.Create(nil); Result.Connection := Self; end; procedure TCustomDAConnection.RemoveFromPool; begin if FIConnection <> nil then FIConnection.IsValid := False; end; procedure TCustomDAConnection.MonitorMessage(const Msg: string); var MessageID: cardinal; begin TDASQLMonitorClass(SQLMonitorClass).CustomMessage(Self, Msg, MessageID); end; procedure TCustomDAConnection.Loaded; begin inherited; try try if FStreamedConnected then SetConnected(True); except on E: Exception do if csDesigning in ComponentState then ShowException(E, ExceptAddr) else raise; end; finally FStreamedConnected := False; end; end; procedure TCustomDAConnection.ClearRefs; begin while FSQLs.Count > 0 do TCustomDASQL(FSQLs[0]).Connection := nil; while DataSetCount > 0 do (DataSets[0] as TCustomDADataSet).Connection := nil; end; procedure TCustomDAConnection.RegisterClient(Client: TObject; Event: TConnectChangeEvent = nil); begin hRegisterClient.Enter; try inherited; if Client is TCustomDASQL then FSQLs.Add(Client); finally hRegisterClient.Leave; end; end; procedure TCustomDAConnection.UnRegisterClient(Client: TObject); begin hRegisterClient.Enter; try inherited; if Client is TCustomDASQL then FSQLs.Remove(Client); finally hRegisterClient.Leave; end; end; function TCustomDAConnection.SQLMonitorClass: TClass; begin Result := TCustomDASQLMonitor; end; function TCustomDAConnection.ConnectDialogClass: TConnectDialogClass; begin Result := TCustomConnectDialog; end; function TCustomDAConnection.NeedPrompt: boolean; begin Result := (LoginPrompt or (csDesigning in ComponentState) and ((Username = '') or (Password = ''))) and not ((csDesigning in ComponentState) and ((csReading in ComponentState) or FStreamedConnected)); end; function TCustomDAConnection.IsConnectedStored: boolean; begin Result := Connected and not Options.DisconnectedMode; //In disconnect mode Design-time connection disabled end; procedure TCustomDAConnection.DoConnect; var MessageID: cardinal; begin TDASQLMonitorClass(SQLMonitorClass).DBConnect(Self, MessageID, True); CreateIConnection; PushOperation(clConnect); StartWait; try FIConnection.SetUsername(FUsername); FIConnection.SetPassword(FPassword); FIConnection.SetServer(FServer); FIConnection.Connect(''); finally StopWait; PopOperation; end; TDASQLMonitorClass(SQLMonitorClass).DBConnect(Self, MessageID, False); end; procedure TCustomDAConnection.DoDisconnect; var MessageID: cardinal; begin try try if InTransaction and not FInProcessError {to prevent call Commit(Rollback) on fatal error} then if CommitOnDisconnect then Commit else Rollback; finally if Connected then begin //disconnect was done in Commit or Rollback TDASQLMonitorClass(SQLMonitorClass).DBDisconnect(Self, MessageID, True); if (FIConnection.Pool <> nil) and FIConnection.IsValid then begin FIConnection.ReturnToPool; SetIConnection(nil); end else FIConnection.Disconnect; TDASQLMonitorClass(SQLMonitorClass).DBDisconnect(Self, MessageID, False); end; end; except on E: EDAError do begin if not((csDestroying in ComponentState) and IsFatalError(E)) then raise; end else raise; end; end; function TCustomDAConnection.CommitOnDisconnect: boolean; begin Result := True; end; procedure TCustomDAConnection.InternalConnect; var StoredConnectCount: integer; StoredLoginPrompt: boolean; begin Inc(FConnectCount); StoredConnectCount := FConnectCount; StoredLoginPrompt := LoginPrompt; LoginPrompt := LoginPrompt and FShouldShowPrompt; try try Connect; except on EFailOver do; else begin if not Connected then Dec(StoredConnectCount);//Restore ConnectCount in case of Connection Failure raise; end; end; finally FConnectCount := StoredConnectCount; LoginPrompt := StoredLoginPrompt; FShouldShowPrompt := not Connected; //in case of Connect Exception LogPrompt appears again end; end; procedure TCustomDAConnection.InternalDisconnect; begin Dec(FConnectCount); if FConnectCount < 0 then //This could happen in case of Commit/RollBack after Execute with AutoCommit = False FConnectCount := 0; if (FConnectCount = 0) and Options.DisconnectedMode then if not InTransaction then //Execute with AutoCommit = False, after execute InTransaction = True, so wait for Commit/RollBack or for //execute with AutoCommit = True Disconnect; FShouldShowPrompt := False; end; procedure TCustomDAConnection.Connect; begin SetConnected(True); end; procedure TCustomDAConnection.Disconnect; begin SetConnected(False); end; procedure TCustomDAConnection.PerformConnect(Retry: boolean); begin if csReading in ComponentState then FStreamedConnected := True else begin if GetConnected then Exit; if not Retry and Assigned(BeforeConnect) then BeforeConnect(Self); DoConnect; Inc(FConnectCount); SendConnectEvent(True); if Assigned(AfterConnect) then AfterConnect(Self); end; end; procedure TCustomDAConnection.GetTableNames(List: TStrings); begin List.Clear; end; procedure TCustomDAConnection.GetDatabaseNames(List: TStrings); begin List.Clear; end; procedure TCustomDAConnection.GetStoredProcNames(List: TStrings); begin List.Clear; end; { Transaction control } procedure TCustomDAConnection.SuppressAutoCommit; var Temp: boolean; begin Temp := False; FIConnection.SetProp(prAutoCommit, Temp); end; procedure TCustomDAConnection.RestoreAutoCommit; begin FIConnection.SetProp(prAutoCommit, FAutoCommit); end; procedure TCustomDAConnection.InternalStartTransaction; begin FIConnection.StartTransaction; FTransactionID := 'Local'; end; procedure TCustomDAConnection.StartTransaction; var MessageID: cardinal; ReStart: boolean; begin if Options.DisconnectedMode then InternalConnect; if not Connected then DatabaseError(SConnectionIsClosed); if InTransaction then DatabaseError(STransactionInProgress); TDASQLMonitorClass(SQLMonitorClass).TRStart(Self, MessageID, True); PushOperation(clTransStart); try repeat ReStart := False; try InternalStartTransaction; FTransactionID := 'Local'; SuppressAutoCommit; except on E: EFailOver do ReStart := True; end until not ReStart; finally PopOperation; end; TDASQLMonitorClass(SQLMonitorClass).TRStart(Self, MessageID, False); end; procedure TCustomDAConnection.Commit; var MessageID: cardinal; WasInTransaction: boolean; begin if not Connected then DatabaseError(SConnectionIsClosed); WasInTransaction := InTransaction; TDASQLMonitorClass(SQLMonitorClass).TRCommit(Self, MessageID, True); FIConnection.Commit; FTransactionID := ''; RestoreAutocommit; TDASQLMonitorClass(SQLMonitorClass).TRCommit(Self, MessageID, False); if WasInTransaction and Options.DisconnectedMode then //Only in case of explicit transaction start InternalDisconnect; end; procedure TCustomDAConnection.Rollback; var MessageID: cardinal; WasInTransaction: boolean; begin if not Connected then DatabaseError(SConnectionIsClosed); WasInTransaction := InTransaction; TDASQLMonitorClass(SQLMonitorClass).TRRollback(Self, MessageID, True); FIConnection.Rollback; FTransactionID := ''; RestoreAutoCommit; TDASQLMonitorClass(SQLMonitorClass).TRRollback(Self, MessageID, False); if WasInTransaction and Options.DisconnectedMode then //Only in case of explicit transaction start InternalDisconnect; end; procedure TCustomDAConnection.ApplyUpdates(DataSets: array of TCustomDADataSet); var DataSet: TCustomDADataSet; i: integer; ReApply: boolean; begin PushOperation(clConnectionApply); try repeat ReApply := False; for i := 0 to High(DataSets) do begin DataSet := DataSets[i]; if DataSet.Connection <> Self then DatabaseError(Format(SUpdateWrongDB, [DataSet.Name, Name])); end; try StartTransaction; try for i := 0 to High(DataSets) do begin DataSet := DataSets[i]; if DataSet.Active and DataSet.CachedUpdates then DataSet.ApplyUpdates; end; Commit; except on EFailOver do raise; else begin Rollback; raise; end; end; for i := 0 to High(DataSets) do begin DataSet := DataSets[i]; if (DataSet.Connection = Self) and DataSet.Active and DataSet.CachedUpdates then DataSet.CommitUpdates; end; except on EFailOver do ReApply := True; end; until (not ReApply); finally PopOperation; end; end; procedure TCustomDAConnection.ApplyUpdates; var i: integer; DataSetArray: array of TCustomDADataSet; begin SetLength(DataSetArray, DataSetCount); for i := 0 to DataSetCount - 1 do DataSetArray[i] := TCustomDADataSet(DataSets[i]); ApplyUpdates(DataSetArray); end; //Operations stack function TCustomDAConnection.PushOperation(Operation: TConnLostCause; AllowFailOver: boolean = true): integer; var FOOperation: TFailOverOperation; begin Result := 0; if Options.LocalFailover then begin if FOperationsStackLen = Length(FOperationsStack) then SetLength(FOperationsStack, FOperationsStackLen + OperationsStackDelta); Result := FOperationsStackLen; FOOperation.Operation := Operation; FOOperation.AllowFailOver := AllowFailOver; FOperationsStack[Result] := FOOperation; Inc(FOperationsStackLen); end; end; function TCustomDAConnection.PopOperation: TConnLostCause; begin Result := clUnknown; if Options.LocalFailover then begin Result := FOperationsStack[FOperationsStackLen].Operation; Dec(FOperationsStackLen); end; end; function TCustomDAConnection.IsFatalError(E: EDAError): boolean; begin Result := False; end; procedure TCustomDAConnection.ResetOnFatalError; begin //should be ovveriden on product level end; procedure TCustomDAConnection.RestoreAfterFailOver; begin //should be ovveriden on product level end; function TCustomDAConnection.DetectConnLostCause(Component: TObject): TConnLostCause; var i: integer; AllowFailOver: boolean; begin Result := clUnknown; AllowFailOver := True; for i := FOperationsStackLen - 1 downto 0 do begin if Result < FOperationsStack[i].Operation then begin Result := FOperationsStack[i].Operation; AllowFailOver := FOperationsStack[i].AllowFailOver; end; case Result of clConnect: begin if TCustomDAConnection(Component).FShouldShowPrompt then Result := clUnknown;// This is the first connect or non DisconnectedMode - so we should raise exception break; end; clOpen, clExecute: begin if ((Component is TCustomDADataSet) and not TCustomDADataSet(Component).IsQuery) or (Component is TCustomDASQL) then Inc(FConnectCount); // Add ConnectCount - > cause of EndConnection in TCustomDADataSet.DoAfterExecute end; end; end; if not AllowFailOver then Result := clUnknown; end; procedure TCustomDAConnection.DoError(E: Exception; var Fail, Reconnect, Reexecute: boolean; ReconnectAttempt: integer; var ConnLostCause: TConnLostCause); var i: integer; FatalError: boolean; RetryMode: TRetryMode; begin ConnLostCause := clUnknown; TDASQLMonitorClass(SQLMonitorClass).DBError(EDAError(E)); FatalError := IsFatalError(EDAError(E)); if FatalError then begin with EDAError(E) do begin ConnLostCause := DetectConnLostCause(Component); Reconnect := (Connected or ((ReconnectAttempt > 0) and Options.LocalFailover) // After first abortive attempt Connected = False or (ConnLostCause = clConnect) and Options.DisconnectedMode) // For disconnect mode TODO: and ((FTransactionID = '') or (ConnLostCause = clConnectionApply)); // and not InTransaction - ODAC specific: InTransaction can raise exception if Reconnect then for i := 0 to DataSetCount - 1 do begin Assert(DataSets[i] is TCustomDADataSet); if TCustomDADataSet(DataSets[i]).Prepared or ((DataSets[i].Active and not TCustomDADataSet(DataSets[i]).FetchAll and not TCustomDADataSet(DataSets[i]).Fetched) and not ((ConnLostCause = clRefresh) and (DataSets[i] = Component))) //In case of Refresh and Active dataset with unfetched data. then begin Reconnect := False; Break; end; end; if Reconnect then for i := 0 to FSQLs.Count - 1 do begin Assert(TObject(FSQLs[i]) is TCustomDASQL); if TCustomDASQL(FSQLs[i]).Prepared and not TCustomDASQL(FSQLs[i]).Executing then begin Reconnect := False; Break; end; end; end; end; if Reconnect then if Options.LocalFailover then begin if (ConnLostCause = clUnknown) or (ConnLostCause = clExecute) then RetryMode := rmRaise else RetryMode := rmReconnectExecute; if Assigned(FOnConnectionLost) then FOnConnectionLost(Self, TComponent(EDAError(E).Component), ConnLostCause, RetryMode); Reconnect := RetryMode > rmRaise; Reexecute := ((RetryMode > rmReconnect) and not (ConnLostCause = clUnknown)) or ((ConnLostCause = clConnect) and (RetryMode >= rmReconnect)); Fail := not Reexecute; end; if not Options.LocalFailover or not Reconnect then if Assigned(FOnError) then FOnError(Self, EDAError(E), Fail); if FatalError and (FIConnection <> nil) then begin FIConnection.IsValid := False; if FIConnection.Pool <> nil then TCRConnectionPool(FIConnection.Pool).Invalidate; end; if FatalError and (ReconnectAttempt = 0) then ResetOnFatalError; if not FInProcessError and not Reconnect and FatalError and (ReconnectAttempt = 0) // If Attempt > 0 disconnect was called on CRAccess level then begin FInProcessError := True; try Disconnect; except // don't raise exception end; FInProcessError := False; end; end; function TCustomDAConnection.IsKeyViolation(E: EDAError): boolean; begin Result := False; end; procedure TCustomDAConnection.AssignTo(Dest: TPersistent); begin if Dest is TCustomDAConnection then begin TCustomDAConnection(Dest).Username := Username; TCustomDAConnection(Dest).Password := Password; TCustomDAConnection(Dest).Server := Server; TCustomDAConnection(Dest).LoginPrompt := LoginPrompt; PoolingOptions.AssignTo(TCustomDAConnection(Dest).PoolingOptions); TCustomDAConnection(Dest).Pooling := Pooling; TCustomDAConnection(Dest).ConnectDialog := ConnectDialog; TCustomDAConnection(Dest).OnError := OnError; TCustomDAConnection(Dest).ConvertEOL := ConvertEOL; Options.AssignTo(TCustomDAConnection(Dest).Options); TCustomDAConnection(Dest).AutoCommit := AutoCommit; TCustomDAConnection(Dest).AfterConnect := AfterConnect; TCustomDAConnection(Dest).BeforeConnect := BeforeConnect; TCustomDAConnection(Dest).AfterDisconnect := AfterDisconnect; TCustomDAConnection(Dest).BeforeDisconnect := BeforeDisconnect; TCustomDAConnection(Dest).OnLogin := OnLogin; end else inherited; end; function TCustomDAConnection.GetConnected: boolean; begin Result := (FIConnection <> nil) and FIConnection.GetConnected; end; procedure TCustomDAConnection.SetConnected(Value: boolean); var Dialog: TCustomConnectDialog; DialogResult: boolean; OldBeforeDisconnect: TNotifyEvent; StoredConnectCount: integer; begin OldBeforeDisconnect := nil; try if Value <> GetConnected then begin try // ignore exceptions to disconnect all client if not Value then begin FConnectCount := 0; //Explicit disconnect FShouldShowPrompt := True; if Assigned(BeforeDisconnect) then BeforeDisconnect(Self); while True do try SendConnectEvent(False); break; except on E: EDAError do if not IsFatalError(E) then raise end; end else if not FStreamedConnected then //DFM loading issue Inc(FConnectCount); finally if csReading in ComponentState then begin if FOptions.KeepDesignConnected or (csDesigning in ComponentState) then FStreamedConnected := Value; end else if not Value then begin OldBeforeDisconnect := BeforeDisconnect; if Assigned(BeforeDisconnect) then //Design-time event lose fix BeforeDisconnect := nil; inherited SetConnected(False); //There is no server operations FTransactionID := ''; end; end; if not (csReading in ComponentState) and Value then begin if NeedPrompt and (ConnectDialogClass <> nil) then begin if FConnectDialog = nil then Dialog := ConnectDialogClass.Create(nil) else Dialog := FConnectDialog; StoredConnectCount := FConnectCount; DialogResult := False; try Dialog.FConnection := Self; DialogResult := Dialog.Execute; finally if not DialogResult then Dec(StoredConnectCount); FConnectCount := StoredConnectCount; if FConnectDialog = nil then Dialog.Free; end; if not DialogResult then begin if FStreamedConnected or (csDesigning in ComponentState) then DatabaseError(SCannotConnect) else Abort; end; end else begin StoredConnectCount := FConnectCount; try try PerformConnect; except if not Connected then Dec(StoredConnectCount);//Restore ConnectCount in case of Connection Failure raise; end; finally FConnectCount := StoredConnectCount; end; end; end; end; finally if Assigned(OldBeforeDisconnect) then BeforeDisconnect := OldBeforeDisconnect; end; end; procedure TCustomDAConnection.SetUsername(const Value: string); begin if Value <> FUsername then begin Disconnect; FUsername := Value; end; end; procedure TCustomDAConnection.SetPassword(const Value: string); begin if Value <> FPassword then begin Disconnect; FPassword := Value; end; end; procedure TCustomDAConnection.SetServer(const Value: string); begin if Value <> FServer then begin Disconnect; FServer := Value; end; end; function TCustomDAConnection.GetConnectString: string; begin Result := ''; end; procedure TCustomDAConnection.SetConnectString(Value: string); begin end; procedure TCustomDAConnection.SetAutoCommit(Value: boolean); begin FAutoCommit := Value; if FIConnection <> nil then FIConnection.SetProp(prAutoCommit, FAutoCommit); end; function TCustomDAConnection.GetInTransaction: boolean; begin Result := GetTransactionID <> ''; end; function TCustomDAConnection.GetTransactionID: string; begin Result := FTransactionID; end; procedure TCustomDAConnection.SetConvertEOL(Value: boolean); begin FConvertEOL := Value; if FIConnection <> nil then FIConnection.SetProp(prConvertEOL, Value); end; function TCustomDAConnection.CreateOptions: TDAConnectionOptions; begin Result := TDAConnectionOptions.Create(Self); end; procedure TCustomDAConnection.SetOptions(Value: TDAConnectionOptions); begin FOptions.Assign(Value); end; function TCustomDAConnection.CreatePoolingOptions: TPoolingOptions; begin Result := TPoolingOptions.Create(Self); end; procedure TCustomDAConnection.SetPoolingOptions(Value: TPoolingOptions); begin FPoolingOptions.Assign(Value); end; function TCustomDAConnection.IsCaseSensitive: boolean; begin Result := True; end; procedure TCustomDAConnection.SetConnectDialog(Value: TCustomConnectDialog); begin if Value <> FConnectDialog then begin if FConnectDialog <> nil then begin RemoveFreeNotification(FConnectDialog); if FConnectDialog.FConnection = Self then FConnectDialog.FConnection := nil; end; FConnectDialog := Value; if FConnectDialog <> nil then begin FreeNotification(FConnectDialog); FConnectDialog.FConnection := Self; end; end; end; procedure TCustomDAConnection.SetPooling(Value: boolean); begin if FPooling <> Value then begin SetConnected(False); FreeIConnection; end; FPooling := Value; end; procedure TCustomDAConnection.DoAfterConnect; begin if Assigned(AfterConnect) then AfterConnect(Self); end; { TDAParamsInfo } function TDAParamsInfo.GetItem(Index: Integer): TDAParamInfo; begin Result := TDAParamInfo(inherited GetItem(Index)); end; procedure TDAParamsInfo.SetItem(Index: Integer; Value: TDAParamInfo); begin inherited SetItem(Index, Value); end; { TDAParam } destructor TDAParam.Destroy; begin FreeObject; inherited; end; procedure TDAParam.Clear; begin if IsBlobDataType then TBlob(FParamObject).Clear else inherited Clear; end; procedure TDAParam.Assign(Source: TPersistent); {$IFDEF VER6P} var StreamPersist: IStreamPersist; {$ENDIF} {$IFDEF VER6P} procedure Load(const StreamPersist: IStreamPersist); var MS: TMemoryStream; begin if not (DataType in [ftBlob, ftMemo{$IFDEF VER10P}, ftWideMemo{$ENDIF}, ftOraBlob, ftOraClob]) then raise Exception.Create(SDataTypeNotSupported); MS := TMemoryStream.Create; try StreamPersist.SaveToStream(MS); LoadFromStream(MS, DataType); finally MS.Free; end; end; {$ENDIF} begin if Source is TDAParam then begin AssignParam(TParam(Source)); {$IFDEF VER6P} TParam(Self).Size := TParam(Source).Size; // CR11511 {$ENDIF} FSize := TDAParam(Source).FSize; // CR11511 ParamObject := TDAParam(Source).ParamObject; end else if Source is TParam then AssignParam(TParam(Source)) else if Source is TField then AssignField(TField(Source)) else if Source is TStrings then AsMemo := TStrings(Source).Text else {$IFDEF VER6P} if Supports(Source, IStreamPersist, StreamPersist) then Load(StreamPersist) else {$ENDIF} inherited Assign(Source); end; procedure TDAParam.AssignParam(Param: TParam); begin if Param <> nil then begin DataType := Param.DataType; if Param.IsNull then Clear else if IsBlobDataType and not (Param is TDAParam) then // in MIDAS we need to do such assignment // as TDAParam.Value = TParam.Value Value := Param.Value else inherited Value := Param.Value; Name := Param.Name; if ParamType = ptUnknown then ParamType := Param.ParamType; end; end; procedure TDAParam.AssignTo(Dest: TPersistent); begin if Dest is TField then TField(Dest).Value := Value else inherited AssignTo(Dest); end; procedure TDAParam.AssignField(Field: TField); begin if Field <> nil then begin AssignFieldValue(Field, Field.Value); Name := Field.FieldName; end; end; procedure TDAParam.AssignFieldValue(Field: TField; const Value: Variant); begin if Field <> nil then begin if (Field.DataType = ftString) and TStringField(Field).FixedChar then DataType := ftFixedChar else if (Field.DataType = ftMemo) and (Field.Size > 255) then DataType := ftString else {$IFDEF VER10P} if (Field.DataType = ftWideMemo) and (Field.Size > 255) then DataType := ftWideString else {$ENDIF} DataType := Field.DataType; if VarIsNull(Value) {$IFDEF CLR} or ((Field is TBytesField) and Field.IsNull) // See d7 TField.GetAsByteArray and d8 TVarBytesField(TField).GetAsByteArray for details {$ENDIF} then Clear else Self.Value := Value; end; end; procedure TDAParam.LoadFromFile(const FileName: string; BlobType: TBlobType); var Stream: TStream; begin Stream := TFileStream.Create(FileName, fmOpenRead); try LoadFromStream(Stream, BlobType); finally Stream.Free; end; end; procedure TDAParam.LoadFromStream(Stream: TStream; BlobType: TBlobType); begin if not (BlobType in [ftBlob, ftMemo{$IFDEF VER10P}, ftWideMemo{$ENDIF}, ftOraBlob, ftOraClob]) then raise Exception.Create(SDataTypeNotSupported); with Stream do begin DataType := BlobType; Position := 0; Assert(FParamObject <> nil, SDataTypeNotSupported); TBlob(FParamObject).LoadFromStream(Stream); end; end; procedure TDAParam.SetBlobData(Buffer: TBytes; Size: Integer); begin AsBlob := Encoding.Default.GetString(Buffer, 0, Size); end; procedure TDAParam.SetBlobData(Buffer: TValueBuffer); begin AsBlob := Marshal.PtrToStringAnsi(Buffer); end; procedure TDAParam.CreateObject; begin Assert(FParamObject = nil); if DataType in [ftBlob, ftMemo{$IFDEF VER10P}, ftWideMemo{$ENDIF}] then begin FParamObject := TBlob.Create; {$IFDEF VER10P} if DataType = ftWideMemo then TBlob(FParamObject).IsUnicode := True; {$ENDIF} end; end; procedure TDAParam.FreeObject; begin if FParamObject <> nil then begin FParamObject.Free; FParamObject := nil; end; end; procedure TDAParam.SetParamObject(Value: TSharedObject); begin FreeObject; FParamObject := Value; if FParamObject <> nil then begin FParamObject.AddRef; inherited Value := 'Object'; // for IsNull = False end; end; function TDAParam.IsDataTypeStored: boolean; begin Result := Integer(DataType) <= Integer(High(TFieldType)); end; function TDAParam.IsValueStored: boolean; begin Result := Bound and not VarIsArray(Value); end; procedure TDAParam.DefineProperties(Filer: TFiler); function WriteData: boolean; begin Result := not IsDataTypeStored; end; begin inherited DefineProperties(Filer); Filer.DefineProperty('ExtDataType', ReadExtDataType, WriteExtDataType, WriteData); end; procedure TDAParam.ReadExtDataType(Reader: TReader); begin DataType := TFieldType(Reader.ReadInteger); end; procedure TDAParam.WriteExtDataType(Writer: TWriter); begin Writer.WriteInteger(Integer(DataType)); end; function TDAParam.IsObjectDataType(DataType: TFieldType): boolean; begin Result := DataType in [ftMemo{$IFDEF VER10P}, ftWideMemo{$ENDIF}, ftBlob]; end; function TDAParam.IsObjectDataType: boolean; begin Result := IsObjectDataType(DataType); end; function TDAParam.IsBlobDataType: boolean; begin Result := DataType in [ftMemo{$IFDEF VER10P}, ftWideMemo{$ENDIF}, ftBlob]; end; function TDAParam.GetDataType: TFieldType; begin Result := inherited DataType; end; procedure TDAParam.SetDataType(Value: TFieldType); begin if Value <> inherited DataType then begin if IsObjectDataType then FreeObject; inherited DataType := Value; if IsObjectDataType then CreateObject; end; end; function TDAParam.GetSize: integer; begin Result := FSize; end; procedure TDAParam.SetSize(Value: integer); begin FSize := Value; end; function TDAParam.GetAsString: string; begin if IsNull then Result := '' else if IsBlobDataType then begin Assert(FParamObject is TBlob); Result := TBlob(FParamObject).AsString; end else {$IFNDEF CLR} if DataType in [ftDate, ftDateTime] then Result := DateToStr(TVarData(Value).VDate) else {$ENDIF} Result := inherited AsString; end; procedure TDAParam.SetAsString(Value: string); begin if IsBlobDataType then TBlob(FParamObject).AsString := Value else if DataType = ftWideString then AsWideString := Value else inherited AsString := Value; end; function TDAParam.GetAsWideString: WideString; begin if IsNull then Result := '' else if IsBlobDataType then begin Assert(FParamObject is TBlob); Result := TBlob(FParamObject).AsWideString; end else Result := inherited Value; end; procedure TDAParam.SetAsWideString(Value: WideString); begin if IsBlobDataType then TBlob(FParamObject).AsWideString := Value else inherited Value := Value; end; function TDAParam.GetAsInteger: integer; begin Result := inherited AsInteger; end; procedure TDAParam.SetAsInteger(Value: integer); begin inherited AsInteger := Value; end; function TDAParam.GetAsFloat: double; begin Result := inherited AsFloat; end; procedure TDAParam.SetAsFloat(Value: double); begin inherited AsFloat := Value; end; procedure TDAParam.SetAsBlob(Value: TBlobData); begin DataType := ftBlob; TBlob(FParamObject).AsString := Value end; procedure TDAParam.SetAsMemo(Value: string); begin DataType := ftMemo; Assert(FParamObject <> nil); TBlob(FParamObject).AsString := Value end; function TDAParam.GetAsBlobRef: TBlob; begin if DataType = ftUnknown then DataType := ftBlob; if IsBlobDataType then Result := FParamObject as TBlob else Result := nil; end; procedure TDAParam.SetAsBlobRef(const Value: TBlob); begin FreeObject; inherited DataType := ftBlob; ParamObject := Value; end; function TDAParam.GetAsMemoRef: TBlob; begin if DataType = ftUnknown then begin {$IFDEF VER10P} if IsBlobDataType and (FParamObject is TBlob) and TBlob(FParamObject).IsUnicode then DataType := ftWideMemo else {$ENDIF} DataType := ftMemo; end; if IsBlobDataType then Result := FParamObject as TBlob else Result := nil; end; procedure TDAParam.SetAsMemoRef(const Value: TBlob); begin FreeObject; {$IFDEF VER10P} if Value.IsUnicode then inherited DataType := ftWideMemo else {$ENDIF} inherited DataType := ftMemo; ParamObject := Value; end; function TDAParam.GetAsVariant: variant; begin if IsBlobDataType then Result := TBlob(FParamObject).AsString else Result := inherited Value; end; procedure TDAParam.SetAsVariant(const Value: variant); begin if IsBlobDataType then TBlob(FParamObject).AsString := Value else inherited Value := Value; end; {$IFDEF VER6P} function TDAParam.GetAsSQLTimeStamp: TSQLTimeStamp; begin Result := inherited AsSQLTimeStamp; end; procedure TDAParam.SetAsSQLTimeStamp(const Value: TSQLTimeStamp); begin inherited AsSQLTimeStamp := Value; end; {$ENDIF} procedure TDAParam.SetText(const Value: string); begin if IsBlobDataType then TBlob(FParamObject).AsString := Value else inherited SetText(Value); end; function TDAParam.GetIsNull: boolean; begin if IsBlobDataType then Result := TBlob(FParamObject).Size = 0 else Result := inherited IsNull; end; { TDAParams } constructor TDAParams.Create(Owner: TPersistent); begin inherited Create(TDAParam); FOwner := Owner; FNeedsUpdateItem := True; end; procedure TDAParams.Update(Item: TCollectionItem); begin if FNeedsUpdateItem then inherited; end; function TDAParams.GetItem(Index: integer): TDAParam; begin Result := TDAParam(inherited Items[Index]); end; procedure TDAParams.SetItem(Index: integer; Value: TDAParam); begin inherited Items[Index] := Value; end; function TDAParams.ParamByName(const Value: string): TDAParam; begin Result := TDAParam(inherited ParamByName(Value)); end; function TDAParams.FindParam(const Value: string): TDAParam; begin Result := TDAParam(inherited FindParam(Value)); end; function TDAParams.CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType): TDAParam; begin Result := TDAParam(inherited CreateParam(ftUnknown, ParamName, ParamType)); Result.DataType := FldType; end; { TDADetailDataLink } constructor TDADetailDataLink.Create(DataSet: TCustomDADataSet); begin inherited Create; FDataSet := DataSet; end; procedure TDADetailDataLink.ActiveChanged; begin if FDataSet.Active and not (csDestroying in FDataSet.ComponentState) and Active then FDataSet.RefreshParams; end; procedure TDADetailDataLink.RecordChanged(Field: TField); begin if ((Field = nil) or (DataSet.Fields.IndexOf(Field) >= 0)) and FDataSet.Active and not ((Field <> nil) and (FDataSet.State in [dsEdit, dsInsert])) then FDataSet.RefreshParams; end; procedure TDADetailDataLink.CheckBrowseMode; begin if FDataSet.Active and not((DataSet.State in [dsInsert]) and (FDataSet.State in [dsEdit,dsInsert])) then // Prevent post detail before post master FDataSet.CheckBrowseMode; end; function TDADetailDataLink.GetDetailDataSet: TDataSet; begin Result := FDataSet; end; { TCustomDADataSet } constructor TCustomDADataSet.Create(Owner: TComponent); var stIdx: TStatementType; begin inherited Create(Owner); FDataLink := TDADetailDataLink.Create(Self); for stIdx := Low(TStatementType) to High(TStatementType) do if stIdx in GetUpdateSQLStatementTypes then begin Assert(FUpdateSQL[stIdx] = nil); FUpdateSQL[stIdx] := TStringList.Create; TStringList(FUpdateSQL[stIdx]).OnChange := ScanMacros; end; FFetchRows := 25; FAutoCommit := True; FRowsAffected := -1; FRefreshOptions := []; FLeftQuote := '"'; FRightQuote := '"'; FBatchSQLs := StringBuilder.Create(100); CreateCommand; CreateSQLGenerator; SetIRecordSet(FIRecordSet); // TODO - SetIRecordSet called twice FDesignCreate := csDesigning in ComponentState; FOptions := CreateOptions; FUpdatingTableInfoIdx := -1; end; destructor TCustomDADataSet.Destroy; var stIdx: TStatementType; begin Close; UnPrepare; if UsedConnection <> nil then UsedConnection.UnregisterClient(Self); FreeCommand; FreeSQLGenerator; /// CR11636 FOptions.Free; FDataLink.Free; FBatchParams.Free; FBatchSQLs.Free; for stIdx := Low(FUpdateComponents) to High(FUpdateComponents) do begin FUpdateComponents[stIdx].Free; FUpdateComponents[stIdx] := nil; FUpdateSQL[stIdx].Free; FUpdateSQL[stIdx] := nil; end; {$IFDEF MSWINDOWS} FDetailRefreshTimer.Free; {$ENDIF} inherited; SetUpdateObject(nil); end; function TCustomDADataSet.QuoteName(const AName: string): string; begin if FOptions.FQuoteNames and (AName <> '') then Result := Concat(FLeftQuote, AName, FRightQuote) else Result := AName; end; function TCustomDADataSet.UnQuoteName(AName: string): string; var l: integer; begin AName := Trim(AName); l := Length(AName); if FOptions.FQuoteNames and (l >= 3) and (AName[1] = FLeftQuote) and (AName[l] = FRightQuote) then Result := Copy(AName, 2, l - 2) else Result := AName; end; procedure TCustomDADataSet.CheckInactive; begin inherited CheckInactive; end; procedure TCustomDADataSet.CreateIRecordSet; begin if UsedConnection <> nil then SetIRecordSet(UsedConnection.CreateIRecordSet) else SetIRecordSet(nil); end; procedure TCustomDADataSet.FreeIRecordSet; begin FIRecordSet.Free; SetIRecordSet(nil); end; procedure TCustomDADataSet.SetIRecordSet(Value: TData); var stIdx: TStatementType; begin inherited; FIRecordSet := TCRRecordSet(Value); // Value as TCRRecordSet; if FIRecordSet <> nil then begin FICommand := FIRecordSet.GetCommand; FIRecordSet.SetProp(prUniDirectional, FUniDirectional); FIRecordSet.SetProp(prFetchRows, FFetchRows); FIRecordSet.SetProp(prFetchAll, FFetchAll); if FOptions <> nil then begin FIRecordSet.SetProp(prLongStrings, FOptions.FLongStrings); FIRecordSet.SetProp(prFlatBuffers, FOptions.FFlatBuffers); FIRecordSet.TrimFixedChar := FOptions.TrimFixedChar; FIRecordSet.TrimVarChar := FOptions.TrimVarChar; end; FIRecordSet.AfterExecFetch := DoAfterExecFetch; FIRecordSet.AfterFetchAll := DoAfterFetchAll; FIRecordSet.OnBeforeFetch := DoOnBeforeFetch; FIRecordSet.OnAfterFetch := DoOnAfterFetch; FIRecordSet.OnDataChanged := DoOnDataChanged; FIRecordSet.Component := Self; end else FICommand := nil; if FCommand <> nil then FCommand.SetICommand(FICommand); if FICommand <> nil then begin FICommand.SetProp(prAutoCommit, FAutoCommit); FICommand.AfterExecute := DoAfterExecute; end; for stIdx := Low(FUpdateComponents) to High(FUpdateComponents) do FreeAndNil(FUpdateComponents[stIdx]); FUpdateQuery := nil; end; procedure TCustomDADataSet.CheckIRecordSet; var ClassType: TClass; begin if (UsedConnection <> nil) then ClassType := UsedConnection.GetIRecordSetClass else ClassType := nil; if (ClassType = nil) or not IsClass(FIRecordSet, ClassType) then begin FreeIRecordSet; CreateIRecordSet; end; end; procedure TCustomDADataSet.CreateCommand; begin SetCommand(TCustomDASQL.Create(Self)); end; procedure TCustomDADataSet.FreeCommand; begin FCommand.Free; FCommand := nil; end; procedure TCustomDADataSet.SetCommand(Value: TCustomDASQL); begin //FreeCommand; FCommand := Value; if FCommand <> nil then begin FCommand.SetICommand(FICommand); FCommand.FDataSet := Self; FParams := FCommand.Params; FMacros := FCommand.Macros; end; end; function TCustomDADataSet.CreateOptions: TDADataSetOptions; begin Result := TDADataSetOptions.Create(Self); end; procedure TCustomDADataSet.Loaded; begin FStreamedOpen := True; try inherited; FDesignCreate := False; finally FStreamedOpen := False; end; end; function TCustomDADataSet.UsedConnection: TCustomDAConnection; begin Result := FConnection end; procedure TCustomDADataSet.CheckConnection; begin BeginConnection(False); end; procedure TCustomDADataSet.BeginConnection(NoConnectCheck: boolean); function HasDataSet(DAConnection: TCustomDAConnection; DataSet: TDataSet): boolean; var i: integer; begin for i := 0 to DAConnection.DataSetCount - 1 do begin if DAConnection.DataSets[i] = DataSet then begin Result := True; exit; end; end; Result := False; end; begin if UsedConnection = nil then DatabaseError(SConnectionNotDefined); if NoConnectCheck then UsedConnection.InternalConnect // We should call connect each time to update ConnectCount else if not UsedConnection.Connected then UsedConnection.Connect; // use default session if (FConnection = nil) and not HasDataSet(UsedConnection, Self) // FDataSets then begin UsedConnection.RegisterClient(Self, ConnectChange); CheckIRecordSet; FIRecordSet.SetConnection(UsedConnection.FIConnection) end; end; procedure TCustomDADataSet.EndConnection; begin if UsedConnection <> nil then UsedConnection.InternalDisconnect; end; procedure TCustomDADataSet.Disconnect; begin Close; UnPrepare; FieldDefs.Updated := False; end; procedure TCustomDADataSet.ConnectChange(Sender: TObject; Connecting: boolean); begin if not Connecting then begin if not TCustomDAConnection(Sender).Options.DisconnectedMode then Disconnect else FIRecordSet.Disconnect; end else if not (Sender is TCustomDAConnection) then begin // Dll call Assert(FIRecordSet <> nil); Assert(UsedConnection <> nil); Assert(UsedConnection.FIConnection <> nil); FIRecordSet.SetConnection(UsedConnection.FIConnection); end; end; { TablesInfo } function TCustomDADataSet.GetTablesInfo: TCRTablesInfo; begin Result := FIRecordSet.TablesInfo; end; procedure TCustomDADataSet.SetUpdatingTable(Value: string); var i, j: integer; KeyAndDataFields: TKeyAndDataFields; OldUpdatingTable: string; FieldDesc: TFieldDesc; UpdatingTableIsEmpty: boolean; function GetRootParent(FieldDesc: TFieldDesc): TFieldDesc; begin Result := FieldDesc; while Result.ParentField <> nil do Result := Result.ParentField; end; begin Value := TablesInfo.TableInfoClass.NormalizeName(Value); OldUpdatingTable := FUpdatingTable; FUpdatingTable := Value; // Clear FCachedKeyAndDataFields if FUpdatingTable <> OldUpdatingTable then ClearCachedKeyAndDataFields; // Count can be equal to 0 in case: select t.a from (select a from table) t // if TablesInfo.Count = 0 then // Exit; // TablesInfo is not avaible (DataSet is not open)} if not FIRecordSet.Active then Exit; //Assert(Length(FSQLObjects) > 0, 'Function TCustomMSDataSet.SetUpdatingTable cannot be called for non-select query!'); UpdatingTableIsEmpty := False; if TablesInfo.Count = 0 then i := -1 else if Value = '' then // Select default updating table i := 0 else begin i := TablesInfo.IndexByName(Value); if i = -1 then i := TablesInfo.IndexByAlias(Value); if i = - 1 then begin if FUpdatingTable <> OldUpdatingTable then begin FUpdatingTable := OldUpdatingTable; DatabaseErrorFmt(SBadUpdatingTable, [Value]); end else begin UpdatingTable := ''; UpdatingTableIsEmpty := True; // All properties must be setted by previous command end; end; end; if not UpdatingTableIsEmpty then begin FUpdatingTableInfoIdx := i; DetectIdentityField; if not ReadOnly then begin // Set Fields[i].ReadOnly Values if Options.SetFieldsReadOnly and ReadOnlyFieldsEnabled then begin for i := 0 to Fields.Count - 1 do if Fields[i].FieldKind = fkData then Fields[i].ReadOnly := True; GetKeyAndDataFields(KeyAndDataFields, False); for i := 0 to Fields.Count - 1 do begin FieldDesc := GetFieldDesc(Fields[i]); for j := 0 to High(KeyAndDataFields.DataFieldDescs) do if (FieldDesc = KeyAndDataFields.DataFieldDescs[j]) or (GetRootParent(FieldDesc) = KeyAndDataFields.DataFieldDescs[j]) then begin Fields[i].ReadOnly := False; Break; end; end; end; end; end; if TablesInfo.Count > 0 then FOldKeyFields := PSGetKeyFields; end; { Open/Close } procedure TCustomDADataSet.Prepare; var MessageID: cardinal; begin if not Prepared and not Active then begin BeginConnection; // Get param values from master dataset to avoid bug with master/detail and // Execute method on detail dataset. if (FDataLink.DataSource <> nil) and (FDataLink.DataSource.DataSet <> nil) and (FDataLink.DataSource.DataSet.Active) then SetMasterParams(Params); if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLPrepare(Self, FinalSQL, FParams, MessageID, True); StartWait; FCommand.WriteParams(False); inherited; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLPrepare(Self, FinalSQL, FParams, MessageID, False); end; end; procedure TCustomDADataSet.UnPrepare; var NeedDisconnect: boolean; MessageID: cardinal; UnpreparePending: boolean; begin NeedDisconnect := Prepared; UnpreparePending := False; if Prepared and (UsedConnection <> nil) then if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then begin TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLUnprepare(Self, FinalSQL, FParams, MessageID, True); UnpreparePending := True; end; try inherited; finally if NeedDisconnect then EndConnection; end; FIRecordSet.TablesInfo.Clear; FUpdatingTableInfoIdx := -1; if UnpreparePending and (UsedConnection <> nil) then if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLUnprepare(Self, FinalSQL, FParams, MessageID, False); end; procedure TCustomDADataSet.SetActive(Value: Boolean); begin if not FStreamedOpen or (csDesigning in ComponentState) or (FConnection = nil) or FConnection.Options.KeepDesignConnected then inherited; if Value then FOldTableName := PSGetTableName; end; procedure TCustomDADataSet.BeforeOpenCursor(InfoQuery: boolean); begin end; procedure TCustomDADataSet.AfterOpenCursor(InfoQuery: boolean); begin end; function TCustomDADataSet.OpenCursorAllowFailOver: boolean; begin Result := True; end; procedure TCustomDADataSet.OpenCursor(InfoQuery: boolean); var ReOpen: boolean; begin if UsedConnection <> nil then UsedConnection.PushOperation(clOpen, OpenCursorAllowFailOver); try FOldKeyFields := ''; BeginConnection; if Active then Exit; // for open OnChangeConnect repeat ReOpen := False; BeforeOpenCursor(InfoQuery); // get param values from master dataset if (FDataLink.DataSource <> nil) and (FDataLink.DataSource.DataSet <> nil) and (FDataLink.DataSource.DataSet.Active) and (not Foptions.LocalMasterDetail) then SetMasterParams(Params); if FOptions.QueryRecCount then FRecordCount := GetRecCount else FRecordCount := 0; if FNonBlocking then begin if not InfoQuery then begin SetCursor(crSQLArrow); DisableControls; end; end else StartWait; try FCommand.WriteParams; inherited; except on E: TObject do begin if FNonBlocking then begin EnableControls; StopWait; end; if E is EFailOver then begin UsedConnection.RestoreAfterFailOver; Reopen := True end else begin EndConnection; raise; end; end; end; FRowsAffected := -1; AfterOpenCursor(InfoQuery); until (not ReOpen); finally if UsedConnection <> nil then UsedConnection.PopOperation; end; end; procedure TCustomDADataset.CloseCursor; var stIdx: TStatementType; NeedDisconnect: boolean; begin NeedDisconnect := (FICommand.GetCursorState <> csInactive) and (not FIRecordSet.CanDisconnect); // if command is active and we doesn't //already substract ConnectCount after all data fetch inherited; /// FUpdateQuery may be prepared for optimization purposes for stIdx := Low(FUpdateComponents) to High(FUpdateComponents) do if FUpdateComponents[stIdx] is TCustomDADataSet then TCustomDADataSet(FUpdateComponents[stIdx]).UnPrepare; if NeedDisconnect then //If there is opened cursor then we should disconnect EndConnection; end; procedure TCustomDADataset.InternalExecute; var MessageID: cardinal; begin if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, '', MessageID, True); FIRecordSet.ExecCommand; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, '', MessageID, False); end; procedure TCustomDADataSet.BeforeExecute; begin ; //This routine should be used for actions that performed before execute and //affected by local failover feature (like PrepareSQL in stored proc) end; procedure TCustomDADataSet.Execute; var ReExecute: boolean; begin if UsedConnection <> nil then UsedConnection.PushOperation(clExecute); try if Executing then Exit; BeginConnection; if Active then Close; repeat ReExecute := False; BeforeExecute; if not FNonBlocking then StartWait; try if Options.AutoPrepare then Prepare; if IsQuery then begin Open; EndConnection; //Here we decrement UsedConection.FConnectCount that was incremented in InternalExecute and then //in OpenCursor, also we make disconection in case of all data fetched during Opening (Less or equal to one fetch block) end else begin // get param values from master dataset if (FDataLink.DataSource <> nil) and (FDataLink.DataSource.DataSet <> nil) and (FDataLink.DataSource.DataSet.Active) then SetMasterParams(Params); if FNonBlocking then SetCursor(crSQLArrow); FCommand.WriteParams; InternalExecute; if IsQuery then begin Open; EndConnection; //Here we decrement UsedConection.FConnectCount that was incremented in InternalExecute and then //in OpenCursor, also we make disconection in case of all data fetched during Opening (Less or equal to one fetch block) end; end; except on E: TObject do begin if FNonBlocking then begin StopWait; end; if (E is EFailOver) and (EFailOver(E).FConnLostCause = clExecute) then begin UsedConnection.RestoreAfterFailOver; //Restore all read transactions ReExecute := True; //We should pass clConnectionApplyUpdates FailOver end else begin EndConnection; raise; end; end; end; until (not ReExecute); finally if UsedConnection <> nil then UsedConnection.PopOperation; end; end; procedure TCustomDADataSet.DoAfterExecute(Result: boolean); var Value: variant; begin if Result then begin FCommand.ReadParams; FICommand.GetProp(prRowsProcessed, Value); FRowsAffected := Value; end; if FNonBlocking then StopWait; if not IsQuery then begin//Leave connection alive in case of SELECT .Execute instead of .Open to perform Fetch if UsedConnection.Options.DisconnectedMode and Connection.Connected then begin //AutoCommit control if not (UsedConnection.AutoCommit and AutoCommit) and (UsedConnection.FTransactionID = '') then begin //Connection.GetInTransaction are not allowed here since it could be setted to True on // Product level during Execuion without AutoCommit (ODAC, IBDAC) //There is uncommitted transaction that was implicitly started by server UsedConnection.FTransactionID := 'CRImplicitTransaction'; //Set default value UsedConnection.FTransactionID := UsedConnection.GetTransactionID; //To return product specific TransactionId //or even reset InTransaction in case of transaction-free server operation end else if UsedConnection.AutoCommit and AutoCommit then begin UsedConnection.FTransactionID := UsedConnection.GetTransactionID; //To return product specific TransactionId end; end; EndConnection; //we should read all Out parameters before disconnect //In NonBlocking Mode this event must be called exactly after server execute end; if Assigned(FAfterExecute) then FAfterExecute(Self, Result); end; procedure TCustomDADataSet.DoAfterExecFetch(Result: boolean); begin if Result then FCommand.ReadParams; if FNonBlocking then begin if Result then begin if State <> dsInactive then Resync([]) end else Close; if not(FetchAll and Result) then StopWait; EnableControls; end; if Assigned(FAfterExecute) then FAfterExecute(Self, Result); end; procedure TCustomDADataSet.DoAfterFetchAll(Result: boolean); begin if FNonBlocking then begin StopWait; if Trim(IndexFieldNames) <> '' then Resync([]); end; end; procedure TCustomDADataSet.DoAfterScroll; begin if FFetchCanceled then begin Resync([]); FFetchCanceled := False; end; inherited; end; procedure TCustomDADataSet.DoOnBeforeFetch(out Cancel: boolean); begin if not FNonBlocking then StartWait; if Assigned(FBeforeFetch) then FBeforeFetch(Self, Cancel); FFetchCanceled := Cancel; end; procedure TCustomDADataSet.DoOnAfterFetch; begin if not FFetchAll or (FICommand.GetCursorState = csFetched) then if Assigned(FAfterFetch) then FAfterFetch(Self); if FIRecordSet.CanDisconnect then EndConnection; //Close connection after all data was fetched. end; procedure TCustomDADataSet.DoOnDataChanged; begin Resync([]); end; function TCustomDADataSet.Executing: boolean; var Value: variant; begin FICommand.GetProp(prExecuting, Value); Result := Value; end; function TCustomDADataSet.Fetching: boolean; begin Result := FICommand.GetCursorState in [csFetching, csFetchingAll]; end; function TCustomDADataSet.FetchingAll: boolean; begin Result := FICommand.GetCursorState = csFetchingAll; end; function TCustomDADataSet.Fetched: boolean; begin Result := (FICommand.GetCursorState >= csFetched) or Active and (FICommand.GetCursorState = csInactive); end; procedure TCustomDADataSet.DoOnNewRecord; var DataSet: TDataSet; MasterField, DetailField: TField; MasterName: string; DetailName: string; MasterPos: integer; DetailPos: integer; procedure LinkMDFields(const MasterName, DetailName: string); begin MasterField := DataSet.FindField(MasterName); if Assigned(MasterField) then begin DetailField := FindField(DetailName); if Assigned(DetailField) and not DetailField.ReadOnly then // CR 11917 DetailField.Assign(MasterField); end; end; begin if (DataSource <> nil) then begin DataSet := DataSource.DataSet; if (DataSet <> nil) and DataSet.Active then begin //MD link by MasteFields and DetailFields if (FMasterFields <> '') and (FDetailFields <> '') then begin MasterPos := 1; DetailPos := 1; while True do begin MasterName := ExtractFieldName(FMasterFields, MasterPos); DetailName := ExtractFieldName(FDetailFields, DetailPos); if (MasterName <> '') and (DetailName <> '') then LinkMDFields(MasterName, DetailName) else break; end; end; //We couldn't link MD fields in case of undefined FMasterFields or FDetailFields //cause there is could be field names mismatch end; end; inherited; end; { Before / After UpdateExecute } function TCustomDADataSet.AssignedBeforeUpdateExecute: boolean; begin Result := Assigned(FBeforeUpdateExecute); end; procedure TCustomDADataSet.DoBeforeUpdateExecute(Sender: TDataSet; StatementTypes: TStatementTypes; Params: TDAParams); begin if AssignedBeforeUpdateExecute then FBeforeUpdateExecute(Sender, StatementTypes, Params); end; function TCustomDADataSet.AssignedAfterUpdateExecute: boolean; begin Result := Assigned(FAfterUpdateExecute); end; procedure TCustomDADataSet.DoAfterUpdateExecute(Sender: TDataSet; StatementTypes: TStatementTypes; Params: TDAParams); begin if AssignedAfterUpdateExecute then FAfterUpdateExecute(Sender, StatementTypes, Params); end; function TCustomDADataSet.GetActualFieldName(Field: TField): string; var FieldDesc: TFieldDesc; begin FieldDesc := GetFieldDesc(Field); Result := GetActualFieldName(FieldDesc); end; function TCustomDADataSet.GetActualFieldName(FieldDesc: TFieldDesc): string; begin Result := FieldDesc.Name; if Result = '' then Result := FieldDesc.ActualName; Result := QuoteName(Result); end; procedure TCustomDADataSet.GetCurrentKeys(out KeyFields: TFieldArray; out Values: variant); var KeyAndDataFields: TKeyAndDataFields; KeyFieldsCount, DataFieldsCount: integer; i, j: integer; RecBuf: TRecordBuffer; TmpVar: variant; Delta: integer; EmptyRecBuf: boolean; begin GetKeyAndDataFields(KeyAndDataFields, False); KeyFieldsCount := Length(KeyAndDataFields.KeyFieldDescs); DataFieldsCount := Length(KeyAndDataFields.DataFieldDescs); SetLength(KeyFields, KeyFieldsCount); Values := Unassigned; EmptyRecBuf := not GetActiveRecBuf(RecBuf); if KeyFieldsCount = 1 then begin KeyFields[0] := GetField(KeyAndDataFields.KeyFieldDescs[0]); if not EmptyRecBuf then Data.GetFieldAsVariant(KeyAndDataFields.KeyFieldDescs[0].FieldNo, RecBuf, Values); end else if KeyFieldsCount > 1 then begin Values := VarArrayCreate([0, KeyFieldsCount - 1], varVariant); for i := 0 to KeyFieldsCount - 1 do begin KeyFields[i] := GetField(KeyAndDataFields.KeyFieldDescs[i]); Values[i] := Unassigned; if not EmptyRecBuf then begin Data.GetFieldAsVariant(KeyAndDataFields.KeyFieldDescs[i].FieldNo, RecBuf, TmpVar); Values[i] := TmpVar; end; end; end else if (KeyFieldsCount = 0) and (DataFieldsCount > 0) then begin Delta := 0; Assert(FSQLGenerator <> nil); for i := DataFieldsCount - 1 downto 0 do if FSQLGenerator.IsBlobDataType(KeyAndDataFields.DataFieldDescs[i].DataType) or FSQLGenerator.IsObjectDataType(KeyAndDataFields.DataFieldDescs[i].DataType) then begin Inc(Delta); for j := i to DataFieldsCount - Delta - 1 do KeyAndDataFields.DataFieldDescs[j] := KeyAndDataFields.DataFieldDescs[j + 1]; end; SetLength(KeyFields, DataFieldsCount - Delta); Values := VarArrayCreate([0, DataFieldsCount - Delta - 1], varVariant); for i := 0 to DataFieldsCount - Delta - 1 do begin KeyFields[i] := GetField(KeyAndDataFields.DataFieldDescs[i]); Values[i] := Unassigned; if not EmptyRecBuf then begin Data.GetFieldAsVariant(KeyAndDataFields.DataFieldDescs[i].FieldNo, RecBuf, TmpVar); Values[i] := TmpVar; end; end; end; end; procedure TCustomDADataSet.DataReopen; begin if Data.IsFullReopen then ClearCachedKeyAndDataFields; Data.Reopen; end; procedure TCustomDADataSet.InternalRefresh; var MessageID: cardinal; KeyFields: TFieldArray; Values: variant; KeyFieldsReaded, Retry: boolean; begin if UsedConnection <> nil then UsedConnection.PushOperation(clRefresh, OpenCursorAllowFailOver); try KeyFieldsReaded := False; BeginConnection; repeat Retry := False; try if not KeyFieldsReaded then GetCurrentKeys(KeyFields, Values); KeyFieldsReaded := True; //this will allow us to restore active record after failover if FOptions.QueryRecCount then FRecordCount := GetRecCount else FRecordCount := 0; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, 'Refresh', MessageID, True); StartWait; FCommand.WriteParams; inherited; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, 'Refresh', MessageID, False); FRowsAffected := -1; if Length(KeyFields) = 0 then // CR N 11512 First else begin DoBeforeScroll; if not LocateRecord(KeyFields, Values, [], False) then First else begin Resync([]); DoAfterScroll; end; end; except on E: Exception do begin { if FNonBlocking then begin EnableControls; StopWait; end;} if E is EFailOver then begin UsedConnection.RestoreAfterFailOver; Retry := True end else raise; end; end; until not Retry; finally if UsedConnection <> nil then UsedConnection.PopOperation; end; end; procedure TCustomDADataSet.InternalRefreshQuick(const CheckDeleted: boolean); var KeyAndDataFields: TKeyAndDataFields; var OldStrictUpdate, OldFiltered: boolean; KeyFields: TFieldArray; Values: variant; KeyFieldsCount: integer; begin DoBeforeRefresh; BeginConnection; try CheckActive; GetKeyAndDataFields(KeyAndDataFields, False); KeyFieldsCount := Length(KeyAndDataFields.KeyFieldDescs); if KeyFieldsCount = 0 then DatabaseError(SKeyFieldsReq); CheckBrowseMode; if FUpdatingTableInfoIdx = - 1 then Exit; OldStrictUpdate := Options.StrictUpdate; OldFiltered := Filtered; DisableControls; try Filtered := False; Options.StrictUpdate := False; GetCurrentKeys(KeyFields, Values); if CheckDeleted and not IsEmpty then PerformSQL('', [stRefreshCheckDeleted]); PerformSQL('', [stRefreshQuick]); if not Locate(KeyFields, Values, []) then First; finally Options.StrictUpdate := OldStrictUpdate; Filtered := OldFiltered; EnableControls; DoAfterRefresh; end; finally EndConnection; end; end; procedure TCustomDADataSet.InternalClose; var i: integer; begin try try inherited; except on E: EDAError do // Borland's bug in DoInternalClose with FBufferCount if not(UsedConnection.IsFatalError(E)) then raise; else raise; end; finally FIdentityField := nil; if not Prepared then begin // In case that User doesn't call Prepare directly FIRecordSet.TablesInfo.Clear; FUpdatingTableInfoIdx := -1; end; ClearCachedKeyAndDataFields; for i := 0 to Length(FLocalMDLinks) - 1 do if not FLocalMDLinks[i].NativeBuffer then Marshal.FreeHGlobal(FLocalMDLinks[i].Buffer); SetLength(FLocalMDLinks, 0); end; end; function TCustomDADataSet.GetRecCount: longint; begin Result := 0; end; procedure TCustomDADataSet.SetRefreshOptions(Value: TRefreshOptions); begin FRefreshOptions := Value; end; { Edit } procedure TCustomDADataSet.SetReadOnly(Value: boolean); begin FReadOnly := Value; end; function TCustomDADataSet.IsNeedEditPreconnect: boolean; begin Result := False; end; function TCustomDADataSet.IsNeedInsertPreconnect: boolean; begin Result := False; end; procedure TCustomDADataSet.InternalBeforeEdit; begin end; procedure TCustomDADataSet.InternalEdit; begin if IsNeedEditPreconnect then BeginConnection; try InternalBeforeEdit; inherited; except if IsNeedEditPreconnect then EndConnection; raise; end; end; procedure TCustomDADataSet.InternalInsert; begin if IsNeedInsertPreconnect then BeginConnection; try inherited; except if IsNeedInsertPreconnect then EndConnection; end; end; function TCustomDADataSet.IsPreconnected : boolean; begin Result := ((State = dsEdit) and IsNeedEditPreconnect) or ((State = dsInsert) and IsNeedInsertPreconnect); end; procedure TCustomDADataSet.InternalCancel; begin try inherited; finally if IsPreconnected then EndConnection; end; end; procedure TCustomDADataSet.InternalPost; var DataSet: TDataSet; MasterField, DetailField: TField; MasterName: string; DetailName: string; MasterPos: integer; DetailPos: integer; RemoveRecord: Boolean; begin try inherited; if IsConnectedToMaster then begin DataSet := DataSource.DataSet; if (DataSet <> nil) and (DataSet.Active) then begin MasterPos := 1; DetailPos := 1; While True do begin MasterName := ExtractFieldName(FMasterFields, MasterPos); DetailName := ExtractFieldName(FDetailFields, DetailPos); if (MasterName <> '') and (DetailName <> '') then begin MasterField := DataSet.FindField(MasterName); if Assigned(MasterField) then begin DetailField := FindField(DetailName); if Assigned(DetailField) then begin // Fixed bug with case insensitive master/detail if (not UsedConnection.IsCaseSensitive) and (VarType(DetailField.AsVariant) = {$IFDEF CLR} varChar {$ELSE} varString {$ENDIF}) and (VarType(MasterField.AsVariant) = {$IFDEF CLR} varChar {$ELSE} varString {$ENDIF}) then RemoveRecord := AnsiCompareTextS(DetailField.AsVariant, MasterField.AsVariant) <> 0 else if (not UsedConnection.IsCaseSensitive) and (VarType(DetailField.AsVariant) = {$IFDEF CLR} varChar {$ELSE} varOleStr {$ENDIF}) and (VarType(MasterField.AsVariant) = {$IFDEF CLR} varChar {$ELSE} varOleStr {$ENDIF}) then RemoveRecord := AnsiStrICompWS(DetailField.AsVariant, MasterField.AsVariant) <> 0 else RemoveRecord := not VarEqual(DetailField.AsVariant, MasterField.AsVariant); if RemoveRecord then begin Assert(not CachedUpdates, 'Can not use Master/Detail with CachedUpdates'); FIRecordSet.RemoveRecord; Exit; end; end; end; end else break; end; end; end; if (State = dsInsert) and not CachedUpdates and (roAfterInsert in RefreshOptions) and RefreshAfterInsertAllowed then InternalRefreshRecord; finally if IsPreconnected then EndConnection; end; end; procedure TCustomDADataSet.InternalDeferredPost; begin FActiveRecRefresh := True; try inherited; if (State = dsInsert) and not CachedUpdates and (roAfterInsert in RefreshOptions) and RefreshAfterInsertAllowed then InternalRefreshRecord; finally FActiveRecRefresh := False; end; end; procedure TCustomDADataSet.CreateSQLGenerator; begin SetSQLGenerator(TDASQLGenerator.Create(Self)); end; procedure TCustomDADataSet.FreeSQLGenerator; begin FSQLGenerator.Free; FSQLGenerator := nil; end; procedure TCustomDADataSet.SetSQLGenerator(Value: TDASQLGenerator); begin FreeSQLGenerator; FSQLGenerator := Value; end; function TCustomDADataSet.GetUpdateStatement(const StatementType: TStatementType): string; var UpdateSQL: TStrings; SelectSQL: string; begin UpdateSQL:= FUpdateSQL[StatementType]; if UpdateSQL = nil then Result := '' else begin Result := UpdateSQL.Text; if StatementType = stRefresh then begin Result := Trim(Result); if Pos('WHERE', AnsiUpperCase(Result)) = 1 then begin if SQLGeneratorCompatibility then SelectSQL := BaseSQL else SelectSQL := Self.SQL.Text; Result := SQLAddWhere(SelectSQL, Trim(Copy(Result, 6, Length(Result)))); end; end; end; end; function TCustomDADataSet.GetUpdateSQLStatementTypes: TStatementTypes; begin Result := [stInsert, stDelete, stUpdate, stRefresh]; end; procedure TCustomDADataSet.SetUpdateSQLIndex(Index: integer; Value: TStrings); begin with FUpdateSQL[TStatementType(Index)] do begin BeginUpdate; try Assign(Value); finally EndUpdate; end; end; end; function TCustomDADataSet.GetUpdateSQLIndex(Index: integer): TStrings; begin Result := FUpdateSQL[TStatementType(Index)]; end; procedure TCustomDADataSet.GetIdentityField; begin end; procedure TCustomDADataSet.GetKeyAndDataFields(out KeyAndDataFields: TKeyAndDataFields; const ForceUseAllKeyFields: boolean); begin end; procedure TCustomDADataSet.ClearCachedKeyAndDataFields; begin SetLength(FCachedKeyAndDataFields[False].KeyFieldDescs, 0); SetLength(FCachedKeyAndDataFields[False].DataFieldDescs, 0); SetLength(FCachedKeyAndDataFields[True].KeyFieldDescs, 0); SetLength(FCachedKeyAndDataFields[True].DataFieldDescs, 0); end; function TCustomDADataSet.PerformAppend: boolean; begin Result := PerformSQL('', [stInsert]); if Result then begin GetIdentityField; // Additional InternalRefreshRecord (for CachedUpdates = False) call is // moved to InternalPost in order to avoid bug with TMemData.PutRecord in // PerformSQL. if (roAfterInsert in RefreshOptions) and FInCacheProcessing and RefreshAfterInsertAllowed then InternalRefreshRecord; end; end; function TCustomDADataSet.PerformDelete: boolean; begin Result := PerformSQL('', [stDelete]); end; function TCustomDADataSet.PerformUpdate: boolean; begin Result := PerformSQL('', [stUpdate]); if Result and (roAfterUpdate in RefreshOptions) then InternalRefreshRecord; end; procedure TCustomDADataSet.InternalRefreshRecord; begin if CachedUpdates and (UpdateStatus = usModified) and (not FInCacheProcessing) then RevertRecord; {TODO -cMemoryLeak: cause memory leak and DisposeBuf failed} FreeRefComplexFields(ActiveBuffer); PerformSQL('', [stRefresh]); end; procedure TCustomDADataSet.Resync(Mode: TResyncMode); begin // this need if Resync called for closed dataset (AV BUG !!!) if Active then inherited; end; procedure TCustomDADataSet.GetDetailLinkFields(MasterFields, DetailFields: {$IFDEF CLR}TObjectList{$ELSE}TList{$ENDIF}); function AddFieldToList(const FieldName: string; DataSet: TDataSet; List: TList): Boolean; var Field: TField; begin Field := DataSet.FindField(FieldName); if (Field <> nil) then List.Add(Field); Result := Field <> nil; end; var i: Integer; DataSet: TDataSet; MasterName: string; DetailName: string; MasterPos: integer; DetailPos: integer; begin MasterFields.Clear; DetailFields.Clear; if (DataSource <> nil) and (DataSource.DataSet <> nil) then begin if Params.Count > 0 then begin for i := 0 to Params.Count - 1 do if AddFieldToList(Params[i].Name, DataSource.DataSet, MasterFields) then AddFieldToList(Params[i].Name, Self, DetailFields) end else if (Self.MasterFields <> '') and (Self.DetailFields <> '') then begin DataSet := DataSource.DataSet; if (DataSet <> nil) and DataSet.Active then begin MasterPos := 1; DetailPos := 1; while True do begin MasterName := ExtractFieldName(FMasterFields, MasterPos); DetailName := ExtractFieldName(FDetailFields, DetailPos); if (MasterName = '') or (DetailName = '') then Break; if AddFieldToList(MasterName, DataSource.DataSet, MasterFields) then AddFieldToList(DetailName, Self, DetailFields); end; end; end; end; end; function TCustomDADataSet.FindKey(const KeyValues: array of const): Boolean; function GetKeyValue(Index: integer): variant; // nearly copied from TField.AssignValue procedure Error; begin DatabaseErrorFmt(SFieldValueError, [IntToStr(Index)]); end; {$IFDEF CLR} var Value: Variant; {$ENDIF} begin Result := Unassigned; {$IFDEF CLR} Value := Variant(KeyValues[Index]); case VarType(Value) of varInteger, varSmallInt, varShortInt, varByte, varWord, varLongWord, varInt64, varUInt64: Result := Integer(Value); varBoolean: Result := Boolean(Value); varChar, varString: Result := String(Value); varDouble, varSingle: Result := Double(Value); varObject: Result := Value; varEmpty, varNull: {Clear}; varDateTime, varDate: Result := TDateTime(Value); {varDecimal: AsBcd := Value;} varCurrency: Result := Currency(Value); else Error; end; {$ELSE} with KeyValues[Index] do case VType of vtInteger: Result := Integer(VInteger); vtInt64: begin /// CR-D12558 {$IFDEF VER6P} Result := VInt64^; {$ELSE} TVarData(Result).VType := varDecimal; TVarDataD6(Result).VInt64 := VInt64^; {$ENDIF} end; vtBoolean: Result := Boolean(VBoolean); vtChar: Result := String(VChar); vtExtended: Result := Extended(VExtended^); vtString: Result := String(VString^); vtPointer, vtObject: if VPointer <> nil then Error; vtPChar: Result := String(VPChar); vtAnsiString: Result := String(VAnsiString); vtCurrency: Result := Currency(VCurrency^); vtVariant: if not {$IFDEF VER6P}VarIsClear{$ELSE}VarIsEmpty{$ENDIF}(VVariant^) then Result := Variant(VVariant^); vtWideString: Result := WideString(VWideString); else Error; end; {$ENDIF} end; var KeyAndDataFields: TKeyAndDataFields; Values: variant; KeyFieldsCount: integer; KeyFields: TFieldArray; i: integer; begin CheckBrowseMode; GetKeyAndDataFields(KeyAndDataFields, False); Values := Unassigned; // To prevent warning KeyFieldsCount := Length(KeyAndDataFields.KeyFieldDescs); SetLength(KeyFields, KeyFieldsCount); case KeyFieldsCount of 0: DatabaseError(SKeyFieldsRequired); 1: begin KeyFields[0] := GetField(KeyAndDataFields.KeyFieldDescs[0]); Values := GetKeyValue(0); end; else begin Values := VarArrayCreate([0, KeyFieldsCount - 1], varVariant); for i := 0 to KeyFieldsCount - 1 do begin KeyFields[i] := GetField(KeyAndDataFields.KeyFieldDescs[i]); if i <= High(KeyValues) then Values[i] := GetKeyValue(i) else Values[i] := Unassigned; end; end; end; Result := LocateEx(KeyFields, Values, FFindKeyOptions); end; procedure TCustomDADataSet.FindNearest(const KeyValues: array of const); begin FFindKeyOptions := [lxNearest]; try FindKey(KeyValues); finally FFindKeyOptions := []; end; end; procedure TCustomDADataSet.GotoCurrent(DataSet: TCustomDADataSet); var KeyFields: TFieldArray; Values: variant; begin DataSet.GetCurrentKeys(KeyFields, Values); if (Length(KeyFields) = 0) or not Locate(KeyFields, Values, []) then First; end; procedure TCustomDADataSet.InternalApplyUpdates(AllowFailOver: boolean); var ReApply: boolean; begin if (UsedConnection <> nil) then UsedConnection.PushOperation(clApply, AllowFailOver); //Add ApplyUpdates Operation to Operations Stack (FailOver) try repeat ReApply := False; try inherited ApplyUpdates; except on E: EFailOver do if E.FConnLostCause = clApply then begin UsedConnection.RestoreAfterFailOver; ReApply := True; end else raise; end; until (not ReApply); finally if UsedConnection <> nil then UsedConnection.PopOperation; //Remove ApplyUpdates Operation from Operations Stack end; end; procedure TCustomDADataSet.ApplyUpdates; begin if UsedConnection = nil then DatabaseError(SConnectionNotDefined); InternalApplyUpdates(not UsedConnection.InTransaction and not AutoCommit); end; procedure TCustomDADataSet.RefreshRecord; begin CheckActive; case State of dsInsert: begin Cancel; Exit; end; dsEdit: Cancel; dsSetKey: Post; end; if not IsEmpty then begin UpdateCursorPos; InternalRefreshRecord; if FRowsAffected = 0 then begin // remove deleted record from dataset if Options.RemoveOnRefresh then FIRecordSet.RemoveRecord; Resync([]); end else if FRowsAffected > 0 then Resync([]); //DataEvent(deRecordChange, 0); end; end; procedure TCustomDADataSet.AssignFieldValue(Param: TDAParam; Field: TField; Old: boolean); begin if Param.IsObjectDataType(Field.DataType) then begin Param.DataType := Field.DataType; Param.ParamObject := GetFieldObject(Field); end else if Old then Param.AssignFieldValue(Field, Field.OldValue) else Param.AssignFieldValue(Field, Field.NewValue); end; procedure TCustomDADataSet.AssignFieldValue(Param: TDAParam; FieldDesc: TFieldDesc; Old: boolean); var FieldType: TFieldType; begin FieldType := GetFieldType(FieldDesc.DataType); if Param.IsObjectDataType(FieldType) then begin Param.DataType := FieldType; Param.ParamObject := GetFieldObject(FieldDesc); end else Assert(False, 'This overload should be used only for object fields'); end; procedure TCustomDADataSet.CheckUpdateQuery(const StatementType: TStatementType); begin FUpdateQuery := FUpdateComponents[StatementType]; if FUpdateQuery = nil then begin Assert(UsedConnection <> nil); FUpdateQuery := UsedConnection.CreateDataSet; TCustomDADataSet(FUpdateQuery).FIRecordSet.Component := Self; end else if FUpdateQuery is TCustomDADataSet then TCustomDADataSet(FUpdateQuery).Connection := UsedConnection else if FUpdateQuery is TCustomDASQL then TCustomDASQL(FUpdateQuery).Connection := UsedConnection else Assert(False, 'FUpdateQuery is ' + FUpdateQuery.ClassName); TDBAccessUtils.SetLockDebug(FUpdateQuery, True); if FUpdateQuery is TCustomDADataSet then begin TCustomDADataSet(FUpdateQuery).Close; // To prevent exception raising on setting properties TCustomDADataSet(FUpdateQuery).Options.TrimFixedChar := Options.TrimFixedChar; TCustomDADataSet(FUpdateQuery).Options.TrimVarChar := Options.TrimVarChar; TCustomDADataSet(FUpdateQuery).Options.FlatBuffers := True; TCustomDADataSet(FUpdateQuery).Options.FullRefresh := Options.FullRefresh; {$IFDEF HAVE_COMPRESS} TCustomDADataSet(FUpdateQuery).Options.CompressBlobMode := Options.CompressBlobMode; if StatementType in [stRefresh, stRefreshQuick, stRefreshCheckDeleted] then TCustomDADataSet(FUpdateQuery).Options.LongStrings := Options.LongStrings; {$ENDIF} if StatementType = stBatchUpdate then begin TCustomDADataSet(FUpdateQuery).ParamCheck := False; TCustomDADataSet(FUpdateQuery).Params.Clear; end; end; FUpdateComponents[StatementType] := FUpdateQuery; end; /// UpdateExecute performes execute of the UpdateQuery. We need this procedure /// to get two update models: with and without explicit prepare. procedure TCustomDADataSet.UpdateExecute; var MessageID: cardinal; i: integer; St: string; begin if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then begin St := ''; for i := 0 to Integer(High(TStatementType)) do if TStatementType(i) in StatementTypes then begin if St <> '' then St := St + ','; St := St + Copy(GetEnumName(TypeInfo(TStatementType), i), 3, Length(GetEnumName(TypeInfo(TStatementType), i))); end; TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, TDBAccessUtils.GetSQL(FUpdateQuery).Text, TDBAccessUtils.GetParams(FUpdateQuery), St, MessageID, True); end; TDBAccessUtils.Execute(FUpdateQuery); if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, TDBAccessUtils.GetSQL(FUpdateQuery).Text, TDBAccessUtils.GetParams(FUpdateQuery), St, MessageID, False); end; function TCustomDADataSet.IsAutoCommit: boolean; begin Result := AutoCommit; end; function TCustomDADataSet.ShouldPrepareUpdateSQL: boolean; begin //this function must be overriden on the product level if Upate sql preparation is allowed Result := False; end; procedure TCustomDADataSet.CheckUpdateSQL(const SQL: string; const StatementTypes: TStatementTypes; out ParamsInfo: TDAParamsInfo); var NewSQL, OldSQL: string; StatementType: TStatementType; stIdx: TStatementType; CheckSQLNeeded: boolean; UpdateObjectSQL: TStrings; IsSQLAutoGenerated: boolean; Index: Integer; LockMacros: boolean; LockAssembleSQL: boolean; DisableScanParams: boolean; begin IsSQLAutoGenerated := False; CheckSQLNeeded := True; StatementType := stCustom; for stIdx := Low(TStatementType) to High(TStatementType) do if stIdx in StatementTypes then begin if StatementType <> stCustom then StatementType := stCustom else StatementType := stIdx; if StatementType = stCustom then Break; end; FUpdateQuery := nil; try if Assigned(UpdateObject) then begin FUpdateQuery := UpdateObject.GetObjectIndex(Ord(StatementType)); if FUpdateQuery <> nil then begin CheckSQLNeeded := False; if TDBAccessUtils.GetSQL(FUpdateQuery).Count = 0 then DatabaseError(SUpdateObjectEmptySQL); end; end; if FUpdateQuery = nil then CheckUpdateQuery(StatementType); finally Assert(FUpdateQuery <> nil, 'FUpdateQuery = nil. StatementTypes = ' + IntToStr(Word(StatementTypes))); end; if CheckSQLNeeded then begin TDBAccessUtils.SetAutoCommit(FUpdateQuery, (StatementTypes * [stInsert, stUpdate, stDelete, stBatchUpdate] <> []) and IsAutoCommit); NewSQL := SQL; if StatementType = stBatchUpdate then NewSQL := PrepareBatch(FBatchSQLs.ToString) else if NewSQL = '' then begin if Assigned(UpdateObject) then UpdateObjectSQL := UpdateObject.GetSQLIndex(Ord(StatementType)) else UpdateObjectSQL := nil; if Assigned(UpdateObjectSQL) then NewSQL := UpdateObjectSQL.Text; if NewSQL = '' then begin NewSQL := GetUpdateStatement(StatementType); if (NewSQL <> '') and (Macros.Count > 0) then Macros.Expand(NewSQL); if NewSQL = '' then begin IsSQLAutoGenerated := True; if BatchUpdate then Index := FBatchStatements else Index := -1; NewSQL := FSQLGenerator.GenerateSQL(StatementType, not (csDesigning in ComponentState) and not Options.UpdateAllFields, TDBAccessUtils.GetParams(FUpdateQuery), Index); case StatementType of stInsert, stUpdate, stDelete: LockMacros := True; else LockMacros := False; end; LockAssembleSQL := (StatementType <> stRefreshQuick) and not (((Params.Count > 0) or Options.FullRefresh) and (StatementType = stRefresh)); DisableScanParams := LockAssembleSQL; TDBAccessUtils.SetSQLText(FUpdateQuery, NewSQL, LockAssembleSQL, LockMacros, DisableScanParams); ParamsInfo := FSQLGenerator.ParamsInfo; end; end; end; // Check whether SQL text is the same. For multiple update operations. if BatchUpdate and not ((StatementType = stBatchUpdate) or (StatementType = stLock) or (StatementType = stRefresh)) then begin if not IsSQLAutoGenerated then NewSQL := FCommand.ParseSQL(NewSQL, nil, ':' + FSQLGenerator.IndexedPrefix + IntToStr(FBatchStatements) + '_'); if NewSQL <> '' then begin if FBatchSQLs.Length <> 0 then FBatchSQLs.Append(#13#10); FBatchSQLs.Append(NewSQL); FBatchSQLs.Append(';'); inc(FBatchStatements); end; end; Assert(FUpdateQuery <> nil); if not IsSQLAutoGenerated then begin OldSQL := TDBAccessUtils.GetSQL(FUpdateQuery).Text; NewSQL := NewSQL; if OldSQL <> NewSQL then begin TDBAccessUtils.GetParams(FUpdateQuery).Clear; /// Performance optimization - skipping reassigning old params values on changing SQL TDBAccessUtils.GetSQL(FUpdateQuery).Text := NewSQL; end; end; //Used user defined SQL and internal update object used so we could prepare Update object to obtain some performance gain if ShouldPrepareUpdateSQL and not UsedConnection.Options.DisconnectedMode and not BatchUpdate then begin if FUpdateQuery is TCustomDADataSet then TCustomDADataSet(FUpdateQuery).Options.AutoPrepare := not IsSQLAutoGenerated and (SQL = '') else if FUpdateQuery is TCustomDASQL then TCustomDASQL(FUpdateQuery).Prepared := not IsSQLAutoGenerated and (SQL = ''); end; end; end; function TCustomDADataSet.UseParamType: boolean; begin Result := False; end; function TCustomDADataSet.FieldByParamName(var ParamName: string; var Old: boolean; var AFieldNo: integer): TField; // Returns field that corresponds to ParamName function FindFieldByFieldNo(FieldNo: integer): TField; var i: integer; begin for i := 0 to Fields.Count - 1 do begin Result := Fields[i]; if Result.FieldNo = FieldNo then Exit; end; Result := nil; end; var e: integer; begin Old := CompareText(Copy(ParamName, 1, 4), 'OLD_') = 0; Result := nil; if Old then begin Result := FindField(ParamName); if Result <> nil then Old := False // fieldname is starting with OLD_ else ParamName := Copy(ParamName, 5, Length(ParamName) - 4); end; if Result = nil then begin Val(ParamName, AFieldNo, e); if e = 0 then Result := FindFieldByFieldNo(AFieldNo) else AFieldNo := -1; end else begin AFieldNo := -1; end; if Result = nil then Result := FindField(ParamName); end; function TCustomDADataSet.BatchUpdate: boolean; begin Result := FInCacheProcessing and (FOptions.UpdateBatchSize > 1) and not Assigned(UpdateObject); end; function TCustomDADataSet.CanFlushBatch: boolean; begin Result := BatchUpdate and (FBatchStatements > 0) and (FBatchStatements >= FOptions.UpdateBatchSize); end; procedure TCustomDADataSet.ClearBatch; begin FBatchSQLs.Length := 0; FBatchParams.Clear; FBatchStatements := 0; end; procedure TCustomDADataSet.FlushBatch; begin if FBatchStatements > 0 then try PerformSQL('', [stBatchUpdate]); finally ClearBatch; end; end; function TCustomDADataSet.PrepareBatch(SQL: string): string; begin Result := SQL; end; {$IFNDEF CLR} type _TParam = class(TCollectionItem) private FParamRef: TParam; end; {$ENDIF} function TCustomDADataSet.PerformSQL(const SQL: string; const StatementTypes: TStatementTypes): boolean; function FindFieldByFieldNo(FieldNo: integer): TField; var i: integer; begin for i := 0 to Fields.Count - 1 do begin Result := Fields[i]; if Result.FieldNo = FieldNo then Exit; end; Result := nil; end; function FindFieldDescByFieldNo(FieldNo: integer): TFieldDesc; var i: integer; begin for i := 0 to FIRecordSet.Fields.Count - 1 do begin Result := FIRecordSet.Fields[i]; if Result.FieldNo = FieldNo then Exit; end; Result := nil; end; function SuppressBatchPrefix(Value: string): string; var i,e: integer; begin Result := Value; if BatchUpdate then begin i := Pos(FSQLGenerator.IndexedPrefix, Value); if i > 0 then begin e := i + 2; while (e <= Length(Result)) and (Result[e] <> '_') do inc(e); {$IFDEF CLR}Borland.Delphi.{$ENDIF}System.Delete(Result, i, e - i + 1); end; end; end; procedure WriteUQParams(ParamsInfo: TDAParamsInfo); var i: integer; Param, Param1: TDAParam; ParamName: string; Old: boolean; Field: TField; AFieldNo: integer; AFieldDesc: TFieldDesc; Params: TDAParams; LowIndex: integer; procedure AssignFieldValueEx(Param: TDAParam; Field: TField; Old: boolean); begin if UseParamType and ((Param.ParamType = ptOutput) or (Param.ParamType = ptResult)) then begin Param.DataType := Field.DataType; Param.Value := Null; end else AssignFieldValue(Param, Field, Old); end; begin {$IFDEF PERF_COUNTER} PerfCounters[5].Start; {$ENDIF} // assigning parameter values from fields of the same name if BatchUpdate then begin // copy parameters from UpdateQuery to common collection if FBatchParams = nil then FBatchParams := FCommand.CreateParamsObject; Params := TDBAccessUtils.GetParams(FUpdateQuery); FBatchParams.BeginUpdate; try for i := 0 to Params.Count - 1 do begin Param := FBatchParams.CreateParam(Params[i].DataType, Params[i].Name, Params[i].ParamType); //FBatchParams.AddParam(Param); {$IFNDEF CLR} _TParam(Param).FParamRef := Param; {$ENDIF} end; finally FBatchParams.FNeedsUpdateItem := False; FBatchParams.EndUpdate; FBatchParams.FNeedsUpdateItem := True; end; Params := FBatchParams; LowIndex := Params.Count - TDBAccessUtils.GetParams(FUpdateQuery).Count; end else begin Params := TDBAccessUtils.GetParams(FUpdateQuery); LowIndex := 0; end; for i := LowIndex to Params.Count - 1 do begin Param := Params[i]; AFieldNo := -1; ParamName := ''; Field := nil; if (ParamsInfo <> nil) and not (stRefreshQuick in StatementTypes) and not ((Self.Params.Count > 0) and (stRefresh in StatementTypes)) then begin Old := ParamsInfo.Items[i - LowIndex].Old; Field := ParamsInfo.Items[i - LowIndex].Field; end; if (ParamsInfo = nil) or (Field = nil) then begin // should remove additional index before assigning value from field ParamName := SuppressBatchPrefix(Param.Name); if (MasterSource <> nil) and (MasterFields = '') and (DetailFields = '') and (Self.Params.Count > 0) and (stRefresh in StatementTypes) then begin if FindParam(ParamName) = nil then Field := FieldByParamName(ParamName, Old, AFieldNo) end else Field := FieldByParamName(ParamName, Old, AFieldNo); end; if Field <> nil then AssignFieldValueEx(Param, Field, Old and (not ((State = dsInsert) and not FInDeferredPost))) // OldValue is Null on Insert else begin Assert(ParamName <> ''); AFieldDesc := nil; if AFieldNo >= 0 then AFieldDesc := FindFieldDescByFieldNo(AFieldNo); if AFieldDesc = nil then AFieldDesc := FIRecordSet.FindField(ParamName); if (AFieldDesc <> nil) and (AFieldDesc.DataType in [dtObject,dtArray]) then // object fields in not objectview AssignFieldValue(Param, AFieldDesc, False) else begin Param1 := FindParam(ParamName); if (Param1 <> nil) and ((stRefresh in StatementTypes) or (stRefreshQuick in StatementTypes)) then Param.Assign(Param1) // assign param from param of SQL else if not AssignedBeforeUpdateExecute then DatabaseError(Format(SNoCorrespondParam, [Param.Name])); end; end; if stRefreshQuick in StatementTypes then SetMasterParams(Params); if not UseParamType then Param.ParamType := ptInput; end; {$IFDEF PERF_COUNTER} PerfCounters[5].Stop; {$ENDIF} end; procedure ReadUQParams(RecordSet: TCRRecordSet; Buffer: TValueBuffer; ParamsInfo: TDAParamsInfo); var i: integer; Param: TDAParam; ParamName: string; Old: boolean; Field: TField; AFieldNo: integer; FieldDesc: TFieldDesc; RecBuf: TRecordBuffer; IsBlank: boolean; SharedObject: TSharedObject; ReadOnly: boolean; begin {$IFDEF PERF_COUNTER} PerfCounters[5].Start; {$ENDIF} for i := 0 to TDBAccessUtils.GetParams(FUpdateQuery).Count - 1 do begin Param := TDBAccessUtils.GetParams(FUpdateQuery)[i]; if UseParamType then if Param.ParamType < ptOutput then Continue; if ParamsInfo <> nil then begin Old := ParamsInfo.Items[i].Old; Field := ParamsInfo.Items[i].Field; end else begin ParamName := Param.Name; Field := FieldByParamName(ParamName, Old, AFieldNo); end; if Assigned(Field) and not Old and CanRefreshField(Field) then begin ReadOnly := Field.ReadOnly; if Field.ReadOnly then begin SetTempState(State); // DisableControls Field.ReadOnly := False; end; FieldDesc := FIRecordSet.Fields[Field.FieldNo - 1]; if (Param.ParamObject <> nil) and (RecordSet <> nil) and (RecordSet.IsComplexFieldType(FieldDesc.DataType) and not((FieldDesc.DataType = dtExtString) or (FieldDesc.DataType = dtExtWideString) or (FieldDesc.DataType = dtExtVarBytes) {$IFDEF VER5P}or (FieldDesc.DataType = dtVariant){$ENDIF})) then begin // pass SharedObject from parameter to recordset if FInCacheProcessing then RecBuf := FIRecordSet.NewCacheRecBuf else RecBuf := ActiveBuffer; FIRecordSet.GetField(FieldDesc.FieldNo, RecBuf, Buffer, IsBlank); SharedObject := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(Buffer))); if SharedObject <> nil then SharedObject.Free; SharedObject := Param.ParamObject; SharedObject.AddRef; if Param.IsNull then begin FIRecordSet.PutField(FieldDesc.FieldNo, RecBuf, Buffer); FIRecordSet.SetNull(FieldDesc.FieldNo, RecBuf, True); end else FIRecordSet.PutField(FieldDesc.FieldNo, RecBuf, Buffer); if (FieldDesc.DataType in [dtBlob, dtMemo, dtWideMemo]) and (State in [dsInsert,dsEdit]) then TBlob(SharedObject).EnableRollback; end else if Param.IsNull then Field.NewValue := Null else if not VarEqual(Field.Value, Param.Value) then Field.NewValue := Param.Value; if ReadOnly then begin Field.ReadOnly := True; RestoreState(State); end end; end; {$IFDEF PERF_COUNTER} PerfCounters[5].Stop; {$ENDIF} end; procedure CopyRecBuf(SrcRecordSet: TData; SrcRecBuf: TRecordBuffer; Buffer: TValueBuffer); var i: integer; RecBuf: TRecordBuffer; FieldDesc: TFieldDesc; FieldName: string; FieldDescIdx: integer; AFieldDesc: TFieldDesc; RecordSetFieldNo: integer; IsBlank: boolean; SharedObject: TSharedObject; Value, NewValue: variant; Field: TField; UQFieldDesc: TFieldDesc; begin if FInCacheProcessing then RecBuf := FIRecordSet.NewCacheRecBuf else RecBuf := ActiveBuffer; for i := 0 to SrcRecordSet.FieldCount - 1 do if not SrcRecordSet.Fields[i].HasParent then begin FieldDesc := SrcRecordSet.Fields[i]; FieldName := FieldDesc.Name; // FindField optimization AFieldDesc := nil; FieldDescIdx := FSQLGenerator.DecodeFieldIndex(FieldName); if FieldDescIdx >= 0 then AFieldDesc := FIRecordSet.Fields[FieldDescIdx]; if AFieldDesc = nil then AFieldDesc := FIRecordSet.FindField(FieldDesc.Name); if (AFieldDesc <> nil){ and CanRefreshField(Field) and} then if SrcRecordSet.IsComplexFieldType(FieldDesc.DataType) and not((FieldDesc.DataType = dtExtString) or (FieldDesc.DataType = dtExtWideString) or (FieldDesc.DataType = dtExtVarBytes) {$IFDEF VER5P}or (FieldDesc.DataType = dtVariant){$ENDIF}) then begin if (stRefresh in StatementTypes) or (stRefreshQuick in StatementTypes) then begin RecordSetFieldNo := AFieldDesc.FieldNo; FIRecordSet.GetField(RecordSetFieldNo, RecBuf, Buffer, IsBlank); SharedObject := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(Buffer))); if SharedObject <> nil then SharedObject.Free; SrcRecordSet.GetField(FieldDesc.FieldNo, SrcRecBuf, Buffer, IsBlank); SharedObject := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(Buffer))); SharedObject.AddRef; FIRecordSet.PutField(RecordSetFieldNo, RecBuf, Buffer); if IsBlank then begin FIRecordSet.SetNull(RecordSetFieldNo, RecBuf, True); if IsClass(SharedObject, TBlob) then // After RefreshRecord for Null Blob fields TBlobUtils.SetModified(TBlob(SharedObject), False); // TBlob.Modified is True end; if (FieldDesc.DataType in [dtBlob, dtMemo, dtWideMemo]) and (State in [dsInsert,dsEdit]) then TBlob(SharedObject).EnableRollback; end; end {$IFDEF VER5P} else if FieldDesc.DataType = dtVariant then begin RecordSetFieldNo := AFieldDesc.FieldNo; UQFieldDesc := FIRecordSet.Fields[RecordSetFieldNo - 1]; CopyBuffer(IntPtr(Integer(RecBuf) + UQFieldDesc.Offset), Buffer, sizeof(TVariantObject)); SharedObject := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(Buffer))); if SharedObject <> nil then SharedObject.Free; IsBlank := SrcRecordSet.GetNull(FieldDesc.FieldNo, SrcRecBuf); UQFieldDesc := SrcRecordSet.Fields[FieldDesc.FieldNo - 1]; CopyBuffer(IntPtr(Integer(SrcRecBuf) + UQFieldDesc.Offset), Buffer, sizeof(TVariantObject)); SharedObject := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(Buffer))); SharedObject.AddRef; UQFieldDesc := FIRecordSet.Fields[RecordSetFieldNo - 1]; CopyBuffer(Buffer, IntPtr(Integer(RecBuf) + UQFieldDesc.Offset), sizeof(TVariantObject)); FIRecordSet.SetNull(RecordSetFieldNo, RecBuf, IsBlank); end {$ENDIF} else begin SrcRecordSet.GetFieldAsVariant(FieldDesc.FieldNo, SrcRecBuf, NewValue); {This code raises AV with disposed ExtStrings if FieldDesc.DataType in [dtExtString, dtExtWideString, dtExtVarBytes] then SrcRecordSet.PutFieldData(FieldDesc, SrcRecBuf, nil);} Field := FindFieldByFieldNo(AFieldDesc.FieldNo); if Field <> nil then begin if stCheck in StatementTypes then begin // check if State in dsEditModes then Value := Field.OldValue else Value := Field.NewValue; if not VarEqual(Value, NewValue) then DatabaseError(SRecordChanged); end else // refresh if FActiveRecRefresh or FInCacheProcessing then begin // DeferredPost and CachedUpdates if Field.ReadOnly then begin SetTempState(State); // DisableControls Field.ReadOnly := False; Field.NewValue := NewValue; Field.ReadOnly := True; RestoreState(State); end else Field.NewValue := NewValue; end else FIRecordSet.PutFieldAsVariant(AFieldDesc.FieldNo, RecBuf, NewValue) end; end; end; if ((stRefresh in StatementTypes) or (stRefreshQuick in StatementTypes)) and not FActiveRecRefresh and not FInCacheProcessing then begin {if CachedUpdates then FIRecordSet.RevertRecord; } /// ??? problem with one record FIRecordSet.PutRecord(RecBuf); Data.AddRefComplexFields(RecBuf); PRecInfo(IntPtr(integer(RecBuf) + FRecInfoOfs)).RefComplexFields := True; end; end; procedure GetUQFields(const KeyFields: TFieldArray; out KeyFieldsUQ: TFieldArray); var i: integer; begin Assert(FUpdateQuery is TCustomDADataSet); SetLength(KeyFieldsUQ, Length(KeyFields)); for i := 0 to Length(KeyFields) - 1 do KeyFieldsUQ[i] := TCustomDADataSet(FUpdateQuery).Fields.FindField(KeyFields[i].FieldName); end; var i: integer; RecordSet: TCRRecordSet; RefreshRecBuf: TRecordBuffer; RecBuf: TRecordBuffer; Buffer: TValueBuffer; s, OldIndexFieldNames: string; KeyFields, KeyFieldsUQ: TFieldArray; v: variant; RQFieldDesc: TFieldDesc; NewValue: variant; OldOnAppend: TOnModifyRecord; ParamsInfo: TDAParamsInfo; TempParams: TDAParams; begin BeginConnection; try CheckUpdateSQL(SQL, StatementTypes, ParamsInfo); if TDBAccessUtils.GetSQL(FUpdateQuery).Count = 0 then begin Result := False; Exit; end; if FUpdateQuery is TCustomDADataSet then RecordSet := TCustomDADataSet(FUpdateQuery).FIRecordSet else RecordSet := nil; if StatementTypes = [stBatchUpdate] then begin TempParams := TDBAccessUtils.GetParams(FUpdateQuery); TempParams.Assign(FBatchParams); {$IFNDEF CLR} for i := 0 to TempParams.Count - 1 do _TParam(TCollection(TempParams).Items[i]).FParamRef := TParam(TCollection(TempParams).Items[i]); {$ENDIF} end else // assigning parameter values from fields of the same name WriteUQParams(ParamsInfo); // No need to call events and UpdateExecute when collecting statemets if not BatchUpdate or (StatementTypes = [stBatchUpdate]) then begin DoBeforeUpdateExecute(Self, StatementTypes, TDBAccessUtils.GetParams(FUpdateQuery)); if AssignedBeforeUpdateExecute then begin for i:= 0 to TDBAccessUtils.GetParams(FUpdateQuery).Count - 1 do if TDBAccessUtils.GetParams(FUpdateQuery)[i].DataType = ftUnknown then DatabaseError(Format(SUnknownParamDataType, [TDBAccessUtils.GetParams(FUpdateQuery)[i].Name])); end; UpdateExecute(StatementTypes); end; Buffer := Marshal.AllocHGlobal(sizeof(integer)); try if (StatementTypes = [stRefreshCheckDeleted]) and (FUpdateQuery is TCustomDADataSet) then begin UpdateCursorPos; First; GetCurrentKeys(KeyFields, v); GetUQFields(KeyFields, KeyFieldsUQ); s := ''; for i := Low(KeyFields) to High(KeyFields) do begin if s <> '' then s := s + ';' + GetActualFieldName(KeyFields[i]) else s := GetActualFieldName(KeyFields[i]); end; OldIndexFieldNames := TCustomDADataSet(FUpdateQuery).IndexFieldNames; try TCustomDADataSet(FUpdateQuery).IndexFieldNames := s; while not Eof do begin GetCurrentKeys(KeyFields, v); if not TCustomDADataSet(FUpdateQuery).Locate(KeyFieldsUQ, v, []) then FIRecordSet.RemoveRecord; Next; end; finally TCustomDADataSet(FUpdateQuery).Close; TCustomDADataSet(FUpdateQuery).IndexFieldNames := OldIndexFieldNames; end; Resync([]); end else if (StatementTypes = [stRefreshQuick]) and (FUpdateQuery is TCustomDADataSet) then begin // Refresh from fields and check FRowsAffected := TCustomDADataSet(FUpdateQuery).RecordCount; UpdateCursorPos; RecordSet.AllocRecBuf(IntPtr(RefreshRecBuf)); try TCustomDADataSet(FUpdateQuery).First; // Get key fields list from base DataSet GetCurrentKeys(KeyFields, v); GetUQFields(KeyFields, KeyFieldsUQ); while not TCustomDADataSet(FUpdateQuery).Eof do begin // And get values from FUpdateQuery v := VarArrayCreate([0, Length(KeyFieldsUQ) - 1], varVariant); for i := 0 to Length(KeyFieldsUQ) - 1 do v[i] := KeyFieldsUQ[i].Value; if not LocateEx(KeyFields, v, []) then begin FIRecordSet.AllocRecBuf(IntPtr(RecBuf)); OldOnAppend := FIRecordSet.OnAppend; try FIRecordSet.OnAppend := nil; FIRecordSet.InitRecord(RecBuf); FIRecordSet.AppendRecord(RecBuf); Resync([]); finally FIRecordSet.OnAppend := OldOnAppend; FIRecordSet.FreeRecBuf(RecBuf); end; end; RecordSet.GetRecord(RefreshRecBuf); CopyRecBuf(RecordSet, RefreshRecBuf, Buffer); for i := 0 to RecordSet.Fields.Count - 1 do begin RQFieldDesc := RecordSet.Fields[i]; if IsRefreshQuickField(RQFieldDesc) then begin RecordSet.GetFieldAsVariant(RQFieldDesc.FieldNo, RefreshRecBuf, NewValue); SaveMaxRefreshQuickValue(RQFieldDesc, NewValue); end; end; TCustomDADataSet(FUpdateQuery).Next; end; finally Data.FreeRecBuf(RefreshRecBuf); end; FIRecordSet.SortItems; Resync([]); end else if ([stRefresh, stCheck] * StatementTypes <> []) and (FUpdateQuery is TCustomDADataSet) and TCustomDADataSet(FUpdateQuery).IsQuery then begin // Refresh from fields and check FRowsAffected := TCustomDADataSet(FUpdateQuery).RecordCount; if FOptions.StrictUpdate and (FRowsAffected <> 1) then DatabaseError(Format(SRefreshFailed, [FRowsAffected])); RecordSet.AllocRecBuf(IntPtr(RefreshRecBuf)); try RecordSet.SetToBegin; // temp RecordSet.GetNextRecord(RefreshRecBuf); if not RecordSet.EOF then CopyRecBuf(RecordSet, RefreshRecBuf, Buffer); finally Data.FreeRecBuf(RefreshRecBuf); end; end else // strict update and DMLRefresh don't work in BatchUpdate mode if not BatchUpdate then begin FRowsAffected := TDBAccessUtils.GetRowsAffected(FUpdateQuery); if FOptions.StrictUpdate and //(Command.SQLType in [SQL_INSERT,SQL_UPDATE,SQL_DELETE]) and /// for ODAC ((FRowsAffected = 0) or (FRowsAffected > 1)) then DatabaseError(Format(SUpdateFailed, [FRowsAffected])); // Refresh fields from params of the same name if NeedReturnParams or (stRefresh in StatementTypes) then // DML Refresh ReadUQParams(RecordSet, Buffer, ParamsInfo); end; // No need to call events and UpdateExecute when collecting statemets if not BatchUpdate or (StatementTypes = [stBatchUpdate]) then DoAfterUpdateExecute(Self, StatementTypes, TDBAccessUtils.GetParams(FUpdateQuery)); Result := True; finally Marshal.FreeHGlobal(Buffer); if FUpdateQuery is TCustomDADataSet then TCustomDADataSet(FUpdateQuery).Close; end; finally EndConnection; end; end; function TCustomDADataSet.RefreshAfterInsertAllowed: boolean; begin Result := True; end; function TCustomDADataSet.IsRefreshQuickField(FieldDesc: TFieldDesc): boolean; begin Result := False; end; procedure TCustomDADataSet.SaveMaxRefreshQuickValue(FieldDesc: TFieldDesc; const Value: variant); begin end; function TCustomDADataSet.GetCanModify: boolean; begin Result := not (ReadOnly or UniDirectional) and (LocalUpdate or CachedUpdates and Assigned(OnUpdateRecord) or Assigned(UpdateObject)); end; procedure TCustomDADataSet.SetStateFieldValue(State: TDataSetState; Field: TField; const Value: Variant); // Need to support int64 fields on PerformSQL in RefreshRecord var SaveState: TDataSetState; {$IFNDEF VER6P} i64: int64; {$ENDIF} begin if not (Field is TLargeintField) then inherited else begin // Nearly copied from inherited if Field.FieldKind <> fkData then Exit; {$IFNDEF VER6P} if not TVarDataD6(Value).VType in [varSmallint, varInteger, varByte, $12{vt_ui2}, $13{vt_ui4}] then begin inherited; exit; end; i64 := TVarDataD6(Value).VInt64; {$ENDIF} SaveState := SetTempState(State); try {$IFDEF VER6P} if VarIsNull(Value) then Field.Clear else TLargeintField(Field).AsLargeInt := Value; {$ELSE} TLargeintField(Field).AsLargeInt := i64; {$ENDIF} finally RestoreState(SaveState); end; end; end; function TCustomDADataSet.CanRefreshField(Field: TField): boolean; begin Result := True; end; function TCustomDADataSet.NeedReturnParams: boolean; begin Result := FOptions.ReturnParams; end; { Master/Detail } procedure TCustomDADataSet.RefreshParams; var DataSet: TDataSet; begin FreeRefBuffers; if FDataLink.DataSource <> nil then begin DataSet := FDataLink.DataSource.DataSet; if DataSet <> nil then if DataSet.Active and (DataSet.State <> dsSetKey) then begin if SetMasterParams(Params) then begin // need refresh {$IFDEF MSWINDOWS} if (FDetailRefreshTimer = nil) or (FDetailRefreshTimer.Interval = 0) then RefreshDetail(nil) else begin FDetailRefreshTimer.Enabled := False; //reset time period FDetailRefreshTimer.Enabled := True; end; {$ELSE} RefreshDetail(nil) {$ENDIF} end; end; end; end; {$IFDEF MSWINDOWS} procedure TCustomDADataSet.CheckRefreshDetailTimer; begin if FDetailRefreshTimer = nil then begin FDetailRefreshTimer := {$IFDEF CLR}TTimer{$ELSE}TWin32Timer{$ENDIF}.Create(Self); FDetailRefreshTimer.Enabled := False; FDetailRefreshTimer.OnTimer := RefreshDetail; end; end; {$ENDIF} procedure TCustomDADataSet.RefreshDetail(Sender: TObject); var MessageID: cardinal; begin {$IFDEF MSWINDOWS} if FDetailRefreshTimer <> nil then FDetailRefreshTimer.Enabled := False; {$ENDIF} if FOptions.LocalMasterDetail then begin FIRecordSet.FilterUpdated; Resync([]); First; end else begin if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, 'Refresh', MessageID, True); BeginConnection; DisableControls; try StartWait; // Refresh FCommand.WriteParams; {$IFDEF VER5P} DoBeforeRefresh; {$ENDIF} CheckBrowseMode; UpdateCursorPos; try DataReopen; if FIRecordSet.IndexFields.Count > 0 then FIRecordSet.SortItems; finally Resync([]); {$IFDEF VER5P} DoAfterRefresh; if not IsEmpty then DoAfterScroll; {$ENDIF} end; finally EnableControls; end; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, 'Refresh', MessageID, False); if FOptions.QueryRecCount then FRecordCount := GetRecCount else FRecordCount := 0; FRowsAffected := -1; end; end; function TCustomDADataSet.NeedDetailRefresh(Param: TDAParam; FieldValue: TSharedObject): boolean; begin Result := False; Param.ParamObject := FieldValue; end; function TCustomDADataSet.SetMasterParams(AParams: TDAParams): boolean; var DataSet: TDataSet; DADataSet: TCustomDADataSet; Field: TField; i: integer; RecBuf: TRecordBuffer; Buffer: IntPtr; SharedObject: TSharedObject; IsBlank: boolean; MasterField: TField; MasterFieldDesc: TFieldDesc; DetailField: TField; DetailFieldDesc: TFieldDesc; MasterPos: integer; DetailPos: integer; MasterName: string; DetailName: string; LinksCount: integer; begin Result := False; if FOptions.LocalMasterDetail then begin Result := True; Assert(DataSource.DataSet is TCustomDADataSet); if Length(FLocalMDLinks) > 0 then for i := 0 to Length(FLocalMDLinks) - 1 do if not FLocalMDLinks[i].NativeBuffer then Marshal.FreeHGlobal(FLocalMDLinks[i].Buffer); LinksCount := 0; if (DataSource <> nil) and (FMasterFields <> '') and (FDetailFields <> '') then begin DADataSet := TCustomDADataSet(DataSource.DataSet); if (DADataSet <> nil) and DADataSet.Active then begin MasterPos := 1; DetailPos := 1; while True do begin MasterName := ExtractFieldName(FMasterFields, MasterPos); DetailName := ExtractFieldName(FDetailFields, DetailPos); if (MasterName <> '') and (DetailName <> '') then begin MasterField := DADataSet.FindField(MasterName); if Assigned(MasterField) then begin DetailField := FindField(DetailName); if Assigned(DetailField) then begin SetLength(FLocalMDLinks, LinksCount + 1); with FLocalMDLinks[LinksCount] do begin DetailFieldDesc := Data.FindField(DetailField.FieldName); MasterFieldDesc := DADataSet.GetFieldDesc(MasterField); if DetailFieldDesc = nil then raise Exception.Create(Format(SFieldNotFound, [DetailField.FieldName])); if MasterFieldDesc = nil then raise Exception.Create(Format(SFieldNotFound, [MasterField.FieldName])); //TODO: Field : cannot be used for local master/detail link FieldNo := DetailFieldDesc.FieldNo; Buffer := nil; IsNull := MasterField.IsNull; NativeBuffer := False; if not IsNull then if DetailFieldDesc.DataType = MasterFieldDesc.DataType then begin if DADataSet.GetActiveRecBuf(RecBuf) then FLocalMDLinks[LinksCount].Buffer := DADataSet.Data.GetFieldBuf(RecBuf, MasterFieldDesc, BufferType, IsNull, NativeBuffer); end else CopyFieldValue(MasterField.Value, Buffer, BufferType, DetailFieldDesc); end; Inc(LinksCount); end; end; end else break; end; end; end; end else if FDataLink.DataSource <> nil then begin DataSet := FDataLink.DataSource.DataSet; if DataSet <> nil then begin for i := 0 to AParams.Count - 1 do begin Field := DataSet.FindField(AParams[i].Name); if not Assigned(Field) then Continue; AParams[i].DataType := Field.DataType; // set datatype for null Field value if AParams[i].IsObjectDataType then begin SharedObject := nil; if (DataSet is TCustomDADataset) then with TCustomDADataset(DataSet) do if Field.FieldNo <> 0 then begin if GetActiveRecBuf(RecBuf) then begin Buffer := Marshal.AllocHGlobal(sizeof(IntPtr)); try Data.GetField(Field.FieldNo, RecBuf, Buffer, IsBlank); SharedObject := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(Buffer))); finally Marshal.FreeHGlobal(Buffer); end; end; end else SharedObject := GetFieldObject(Field); Result := NeedDetailRefresh(AParams[i], SharedObject); end else if (VarIsEmpty(AParams[i].Value) or not VarEqual(AParams[i].Value, Field.Value)) and not (VarIsEmpty(AParams[i].Value) and Field.IsNull) then begin AParams[i].AssignField(Field); Result := True; end; AParams[i].ParamType := ptInput; end; end; end; end; function TCustomDADataSet.IsConnectedToMaster: boolean; begin Result := (MasterSource <> nil) and (FMasterFields <> '') and (FDetailFields <> ''); end; procedure TCustomDADataSet.RefreshDetailSQL; var OldActive: boolean; begin OldActive := Active; Close; UnPrepare; AssembleSQL; if OldActive then Open; end; function TCustomDADataSet.LocalDetailFilter(RecBuf: IntPtr): boolean; var i: Integer; begin Result := True; for i := 0 to Length(FLocalMDLinks) - 1 do with FLocalMDLinks[i] do begin if not Result then Break; if (IsNull) or (TMemData(Data).GetNull(FieldNo, RecBuf)) then Result := not ((IsNull) or (TMemData(Data).GetNull(FieldNo, RecBuf))) else Result := TMemData(Data).CompareFieldValue(Buffer, BufferType, Data.Fields[FieldNo - 1], RecBuf, []) = 0; end; end; procedure TCustomDADataSet.AssembleSQL; begin FCommand.AssembleSQL; // close and unprepare to apply new sql UnPrepare; end; procedure TCustomDADataSet.ScanMacros(Sender: TObject = nil); var AllSQL: string; stIdx: TStatementType; begin AllSQL := SQL.Text; for stIdx := Low(FUpdateSQL) to High(FUpdateSQL) do if Assigned(FUpdateSQL[stIdx]) then AllSQL := AllSQL + FUpdateSQL[stIdx].Text; Macros.Scan(AllSQL); end; {function TCustomDADataSet.DoGetFinalSQL: string; begin Result := GetFinalSQL; end; procedure TCustomDADataSet.DoScanMacros(Sender: TObject); begin ScanMacros; end;} procedure TCustomDADataSet.DefineProperties(Filer: TFiler); function WriteParams: boolean; begin if Filer.Ancestor <> nil then Result := not FParams.IsEqual(TCustomDADataSet(Filer.Ancestor).FParams) else Result := FParams.Count > 0; end; function WriteMacros: boolean; begin if Filer.Ancestor <> nil then Result := not FMacros.IsEqual(TCustomDADataSet(Filer.Ancestor).FMacros) else Result := FMacros.Count > 0; end; begin inherited DefineProperties(Filer); Filer.DefineProperty('ParamData', FCommand.ReadParamData, FCommand.WriteParamData, WriteParams); Filer.DefineProperty('MacroData', FCommand.ReadMacroData, FCommand.WriteMacroData, WriteMacros); end; function TCustomDADataSet.FindParam(const Value: string): TDAParam; begin Result := FParams.FindParam(Value); end; function TCustomDADataSet.ParamByName(const Value: string): TDAParam; begin Result := FParams.ParamByName(Value); end; function TCustomDADataSet.FindMacro(const Value: string): TMacro; begin Result := FMacros.FindMacro(Value); end; function TCustomDADataSet.MacroByName(const Value: string): TMacro; begin Result := FMacros.MacroByName(Value); end; { Additional data types } function TCustomDADataSet.GetField(FieldDesc: TFieldDesc): TField; var i: integer; begin Assert(FieldDesc <> nil); Result := nil; for i := 0 to Fields.Count - 1 do if Fields[i].FieldNo = FieldDesc.FieldNo then begin Result := Fields[i]; Break; end; end; function TCustomDADataSet.GetDataType(const FieldName: string): integer; begin Result := FIRecordSet.FieldByName(FieldName).DataType; end; function TCustomDADataSet.GetFieldDesc(const FieldName: string): TFieldDesc; begin Result := FIRecordSet.FieldByName(FieldName); end; function TCustomDADataSet.GetFieldDesc(const FieldNo: integer): TFieldDesc; begin if FieldNo <= 0 then {fkCalculated, fkLookup} Result := nil else Result := TFieldDesc(FIRecordSet.Fields[FieldNo - 1]) end; function TCustomDADataSet.GetFieldPrecision(const FieldName: string): integer; var Field: TFieldDesc; begin Field := FIRecordSet.FieldByName(FieldName); if (Field <> nil) and (Field.DataType in [dtInteger,dtFloat]) then Result := Field.Length else Result := 0; end; function TCustomDADataSet.GetFieldScale(const FieldName: string): integer; var Field: TFieldDesc; begin Field := FIRecordSet.FieldByName(FieldName); if (Field <> nil) and (Field.DataType in [dtInteger,dtFloat]) then Result := Field.Scale else Result := 0; end; function TCustomDADataSet.GetFieldObject(FieldDesc: TFieldDesc): TSharedObject; var RecBuf: TRecordBuffer; begin if GetActiveRecBuf(RecBuf) then begin if not FIRecordSet.IsComplexFieldType(FieldDesc.DataType) then DatabaseError(SNeedBlobType); Result := TSharedObject(GetGCHandleTarget(Marshal.ReadIntPtr(RecBuf, FieldDesc.Offset))); end else Result := nil; end; function TCustomDADataSet.GetFieldObject(Field: TField): TSharedObject; var FieldDesc: TFieldDesc; begin FieldDesc := GetFieldDesc(Field); Result := GetFieldObject(FieldDesc); end; function TCustomDADataSet.GetFieldObject(const FieldName: string): TSharedObject; var FieldDesc: TFieldDesc; begin FieldDesc := FIRecordSet.FieldByName(FieldName); Result := GetFieldObject(FieldDesc); end; {$IFDEF VER5P} { IProviderSupport } procedure TCustomDADataSet.PSEndTransaction(Commit: Boolean); begin if (UsedConnection <> nil) and AutoCommit and UsedConnection.AutoCommit then if Commit then UsedConnection.Commit else UsedConnection.Rollback; end; procedure TCustomDADataSet.PSExecute; begin Execute; end; function TCustomDADataSet.PSExecuteStatement(const ASQL: string; AParams: TParams; {$IFDEF CLR}var ResultSet: TObject{$ELSE}ResultSet: Pointer = nil{$ENDIF}): Integer; procedure SetSQL(SQL: TStrings); var St: StringBuilder; i, j: integer; begin // replace parameters in SQL St := StringBuilder.Create(Length(ASQL) + Length(ASQL) div 2); try j := 1; for i := 1 to Length(ASQL) do if ASQL[i] = '?' then begin St.Append(':'); St.Append(IntToStr(j)); Inc(j) end else St.Append(ASQL[i]); SQL.Text := St.ToString; finally St.Free; end; end; procedure SetParams(Params: TDAParams); var i: integer; begin //FQuery.Params.Assign(AParams); // params doesn't name for i := 0 to Params.Count - 1 do begin Params[i].Assign(AParams[i]); Params[i].Name := IntToStr(i + 1); if Params[i].ParamType = ptUnknown then Params[i].ParamType := ptInput; end; end; var Command: TCustomDASQL; Query: TCustomDADataSet; begin if Assigned(ResultSet) then begin Query := UsedConnection.CreateDataSet; try Query.Debug := Debug; SetSQL(Query.SQL); SetParams(Query.Params); Query.Execute; Result := Query.RowsAffected; {$IFDEF CLR} ResultSet := Query; {$ELSE} TDataSet(ResultSet^) := Query; {$ENDIF} except Query.Free; raise; end; end else begin Command := UsedConnection.CreateSQL; try Command.Debug := Debug; SetSQL(Command.SQL); SetParams(Command.Params); Command.Execute; Result := Command.RowsAffected; finally Command.Free; end; end; end; function TCustomDADataSet.PSGetParams: DB.TParams; begin Result := Params; end; function TCustomDADataSet.PSGetQuoteChar: string; begin Result := '"'; end; function TCustomDADataSet.PSGetTableName: string; begin if Active then begin if (FUpdatingTableInfoIdx < 0) or (FUpdatingTableInfoIdx >= TablesInfo.Count) then Result := FUpdatingTable else Result := TablesInfo[FUpdatingTableInfoIdx].TableName; end else begin Result := FOldTableName; if Result = '' then Result := TablesInfo.TableInfoClass.NormalizeName(FUpdatingTable); if Result = '' then Result := TablesInfo.TableInfoClass.NormalizeName(GetTableNameFromSQL(SQL.Text)); end; end; function TCustomDADataSet.PSInTransaction: Boolean; begin if UsedConnection <> nil then Result := UsedConnection.InTransaction else Result := False; end; function TCustomDADataSet.PSIsSQLBased: Boolean; begin Result := True; end; function TCustomDADataSet.PSIsSQLSupported: Boolean; begin Result := True; end; procedure TCustomDADataSet.PSReset; begin inherited PSReset; if Active then begin Close; Open; end; end; procedure TCustomDADataSet.PSSetParams(AParams: DB.TParams); begin if AParams.Count <> 0 then Params.Assign(AParams); end; procedure TCustomDADataSet.PSSetCommandText(const CommandText: string); begin if CommandText <> '' then SQL.Text := CommandText; end; procedure TCustomDADataSet.PSStartTransaction; begin if (UsedConnection <> nil) and AutoCommit and UsedConnection.AutoCommit then UsedConnection.StartTransaction; end; function TCustomDADataSet.PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; var UpdateAction: TUpdateAction; I: Integer; Old: Boolean; Param: TDAParam; Params: TDAParams; PName: string; Field: TField; Value: Variant; begin Result := False; if Assigned(OnUpdateRecord) then begin UpdateAction := uaFail; OnUpdateRecord(Delta, UpdateKind, UpdateAction); Result := UpdateAction = uaApplied; end; if not Result and Assigned(FUpdateObject) and Assigned(Delta) then begin CheckUpdateQuery(UpdateKindToStatementType(UpdateKind)); TDBAccessUtils.SetAutoCommit(FUpdateQuery, AutoCommit); Params := TDBAccessUtils.GetParams(FUpdateQuery); // Nearly copied from TUpdateSQL.SetParams with FUpdateQuery do for I := 0 to Params.Count - 1 do begin Param := Params[I]; PName := Param.Name; Old := CompareText(Copy(PName, 1, 4), 'OLD_') = 0; if Old then {$IFDEF CLR}Borland.Delphi.{$ENDIF}System.Delete(PName, 1, 4); Field := Delta.FindField(PName); if not Assigned(Field) then Continue; if Old then Param.AssignFieldValue(Field, Field.OldValue) else begin Value := Field.NewValue; if {$IFNDEF VER6P} VarIsEmpty {$ELSE}VarIsClear{$ENDIF}(Value) then Value := Field.OldValue; Param.AssignFieldValue(Field, Value); end; end; TDBAccessUtils.Execute(FUpdateQuery); Result := True; end; end; function TCustomDADataSet.PSGetDefaultOrder: TIndexDef; function AddField(const Fields, NewField: string): string; begin if Fields <> '' then Result := Fields + ';' + NewField else Result := NewField; end; var S, Token, SaveField: string; Parser: TBoolParser; Code, Index: integer; begin Result := nil; S := GetOrderBy; if S = '' then Exit; Parser := TBoolParser.Create(S); Parser.DecSeparator := '.'; try Result := TIndexDef.Create(nil); Parser.ToBegin(); Code := Parser.GetNext(Token); while Code <> lcEnd do begin case Code of lcIdent, lcString: begin if 'DESC' = UpperCase(Token) then begin Result.DescFields := AddField(Result.DescFields, SaveField); end else if Assigned(FindField(Token)) then begin Result.Fields := AddField(Result.Fields, Token); SaveField := Token; end; end; lcNumber: begin try Index := StrToInt(Token); SaveField := FieldDefs[Index - 1].Name; except // float number Code := Parser.GetNext(Token); //to prevent freezeng on errors. CR continue; end; Result.Fields := AddField(Result.Fields, SaveField); end; end; Code := Parser.GetNext(Token); end; finally Parser.Free; end; end; function TCustomDADataSet.PreventPSKeyFields(var PSKeyFields: string): boolean; begin Result := False; end; function TCustomDADataSet.PSGetKeyFields: string; var OldDebug: boolean; OldFetchAll: boolean; OldFetchRows: integer; procedure QuickOpen; begin OldDebug := Debug; OldFetchAll := FetchAll; OldFetchRows := FetchRows; Debug := False; FetchAll := False; FetchRows := 1; Execute; end; procedure Restore; begin Close; Debug := OldDebug; FetchAll := OldFetchAll; FetchRows := OldFetchRows; end; var i: integer; KeyAndDataFields: TKeyAndDataFields; QO: boolean; begin Result := inherited PSGetKeyFields; if Result = '' then if FOldKeyFields = '' then begin if not PreventPSKeyFields(Result) then begin //Set product specific KeyField values or omit Server roundtrip on DS opening QO := not Active and (Connection <> nil) and (FIRecordSet <> nil) and (FIRecordSet.FieldCount = 0); if QO then QuickOpen; try GetKeyAndDataFields(KeyAndDataFields, False); for i := 0 to High(KeyAndDataFields.KeyFieldDescs) do if Result = '' then Result := KeyAndDataFields.KeyFieldDescs[i].Name else Result := Result + ';' + KeyAndDataFields.KeyFieldDescs[i].Name; finally if QO then Restore; end; end; FOldKeyFields := Result; end else Result := FOldKeyFields; end; {$ENDIF} procedure TCustomDADataSet.AssignTo(Dest: TPersistent); var stIdx: TStatementType; begin inherited; if Dest is TCustomDADataSet then begin TCustomDADataSet(Dest).Connection := Connection; TCustomDADataSet(Dest).MasterSource := MasterSource; TCustomDADataSet(Dest).MasterFields := MasterFields; TCustomDADataSet(Dest).DetailFields := DetailFields; TCustomDADataSet(Dest).ParamCheck := ParamCheck; // before SQL TCustomDADataSet(Dest).SQL.Text := SQL.Text; for stIdx := Low(FUpdateSQL) to High(FUpdateSQL) do if Assigned(TCustomDADataSet(Dest).FUpdateSQL[stIdx]) and Assigned(FUpdateSQL[stIdx]) then TCustomDADataSet(Dest).FUpdateSQL[stIdx].Text := FUpdateSQL[stIdx].Text; TCustomDADataSet(Dest).FilterSQL := FilterSQL; TCustomDADataSet(Dest).Macros.Assign(Macros); TCustomDADataSet(Dest).Params.Assign(Params); TCustomDADataSet(Dest).Debug := Debug; TCustomDADataSet(Dest).FetchRows := FetchRows; TCustomDADataSet(Dest).UniDirectional := UniDirectional; TCustomDADataSet(Dest).AutoCommit := AutoCommit; TCustomDADataSet(Dest).RefreshOptions := RefreshOptions; TCustomDADataSet(Dest).UpdatingTable := UpdatingTable; TCustomDADataSet(Dest).Options.Assign(Options); end; end; procedure TCustomDADataSet.SetConnection(Value: TCustomDAConnection); begin if (Value <> FConnection) or (Value <> UsedConnection) then begin if UsedConnection <> nil then begin Disconnect; UsedConnection.UnregisterClient(Self); end; FConnection := Value; if FConnection <> nil then begin Value.RegisterClient(Self, ConnectChange); CheckIRecordSet; FIRecordSet.SetConnection(FConnection.FIConnection) end else FIRecordSet.SetConnection(nil); {$IFDEF CLR} DataEvent(dePropertyChange, nil); {$ELSE} DataEvent(dePropertyChange, 0); {$ENDIF} end; end; function TCustomDADataSet.GetSQL: TStrings; begin Result := FCommand.SQL; end; procedure TCustomDADataSet.SetSQL(Value: TStrings); begin FCommand.SQL := Value; end; procedure TCustomDADataSet.SetFetchRows(Value: integer); begin if FFetchRows <> Value then begin CheckInactive; if (Value < 1) or (Value > 10000) then DatabaseError(SInvalidFetchRows); FFetchRows := Value; FIRecordSet.SetProp(prFetchRows, FetchRows); end; end; procedure TCustomDADataSet.SetFetchAll(Value: boolean); begin FFetchAll := Value; FIRecordSet.SetProp(prFetchAll, FetchAll); if FFetchAll then begin UniDirectional := False; if Active then begin FIRecordSet.FetchAll; Resync([]); end; end; end; function TCustomDADataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; var Blob: TBlob; OldModified: boolean; begin if Field.DataSet = Self then Blob := GetBlob(Field) else Blob := GetBlob(Field.FieldName); if (Blob <> nil) and (Mode <> bmWrite) and UsedConnection.ConvertEOL and (Field.DataType in [ftMemo{$IFDEF VER10P}, ftWideMemo{$ENDIF}, ftOraClob]) then begin OldModified := Blob.Modified; Blob.AddCR; TBlobUtils.SetModified(Blob, OldModified); end; Result := inherited CreateBlobStream(Field, Mode); end; function TCustomDADataSet.GetDataSource: TDataSource; begin Result := FDataLink.DataSource; end; procedure TCustomDADataSet.SetMasterSource(Value: TDataSource); var NeedRefresh: boolean; begin if FDataLink.DataSource <> Value then begin if IsLinkedTo(Value) then DatabaseError(SCircularDataLink); NeedRefresh := IsConnectedToMaster; FDataLink.DataSource := Value; NeedRefresh := NeedRefresh or IsConnectedToMaster; if NeedRefresh then RefreshDetailSQL; end; end; function TCustomDADataSet.GetParams: TDAParams; begin Result := FCommand.Params; end; procedure TCustomDADataSet.SetParams(Value: TDAParams); begin FCommand.Params := Value; end; function TCustomDADataSet.GetParamCount: word; begin Result := FParams.Count; end; function TCustomDADataSet.GetParamCheck: boolean; begin Result := FCommand.ParamCheck; end; procedure TCustomDADataSet.SetParamCheck(Value: boolean); begin FCommand.ParamCheck := Value; end; function TCustomDADataSet.GetMacros: TMacros; begin Result := FCommand.Macros; end; procedure TCustomDADataSet.SetMacros(Value: TMacros); begin FCommand.Macros := Value; end; function TCustomDADataSet.GetMacroCount: word; begin Result := FMacros.Count; end; function TCustomDADataSet.GetRecordCount: integer; var RowsFetched: variant; begin if not Active or Fetched or not Options.QueryRecCount or (FRecordCount = 0) then Result := inherited GetRecordCount else begin FICommand.GetProp(prRowsProcessed, RowsFetched); Result := FRecordCount - RowsFetched + Data.RecordCount; end; end; function TCustomDADataSet.GetRowsAffected: integer; begin Result := FRowsAffected; end; procedure TCustomDADataSet.SetUniDirectional(Value: boolean); begin if Value <> FUniDirectional then begin CheckInactive; FUniDirectional := Value; FIRecordSet.SetProp(prUniDirectional, FUniDirectional); if FUniDirectional then FetchAll := False; end; end; procedure TCustomDADataSet.SetAutoCommit(Value: boolean); begin FAutoCommit := Value; FICommand.SetProp(prAutoCommit, FAutoCommit); end; function TCustomDADataSet.GetIsQuery: boolean; begin Result := TCRRecordSet(Data).RowsReturn; end; //------------------------------------------------------------------------------ // SQL Modification methods //------------------------------------------------------------------------------ procedure TCustomDADataSet.SaveSQL; begin FBaseSQL := SQL.Text; end; procedure TCustomDADataSet.RestoreSQL; begin if FBaseSQL <> '' then begin SQL.Text := FBaseSQL; FBaseSQL := ''; end; end; function TCustomDADataSet.SQLSaved: boolean; begin Result := FBaseSQL <> ''; end; /// SaveModifiedSQL is used to back up original sql text before modification. procedure TCustomDADataSet.SaveModifiedSQL(NewSQL: string); var BaseSQL: string; begin if NewSQL <> Trim(SQL.Text) then begin if FBaseSQL = '' then FBaseSQL := SQL.Text; if not BaseSQLOldbehavior then BaseSQL := FBaseSQL; SQL.Text := NewSQL; if not BaseSQLOldbehavior then FBaseSQL := BaseSQL; end; end; procedure TCustomDADataSet.InitUpdatingTable; begin if (FUpdatingTable <> '') and (TablesInfo.IndexByName(TablesInfo.TableInfoClass.NormalizeName(FUpdatingTable)) = - 1) then FUpdatingTable := ''; SetUpdatingTable(FUpdatingTable); end; procedure TCustomDADataSet.DetectIdentityField; begin FIdentityField := nil; end; function TCustomDADataSet.ReadOnlyFieldsEnabled: boolean; begin Result := True; end; procedure TCustomDADataSet.WriteFieldXMLAttributeType(Field: TField; FieldDesc: TFieldDesc; const FieldAlias: string; XMLWriter: XMLTextWriter); begin inherited; if (FieldDesc is TCRFieldDesc) and (TCRFieldDesc(FieldDesc).TableInfo <> nil) and (TCRFieldDesc(FieldDesc).TableInfo.TableName <> '') then XmlWriter.WriteAttributeString('rs:basetable', TCRFieldDesc(FieldDesc).TableInfo.TableName); end; procedure TCustomDADataSet.InternalOpen; var MessageID: cardinal; begin if Options.AutoPrepare then Prepare; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) and (FIRecordSet.GetCommand.GetCursorState <> csExecuted) {To prevent multiple calls on DataSet.Execute} then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, '', MessageID, True); inherited; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, '', MessageID, False); ClearCachedKeyAndDataFields; InitUpdatingTable; if (FDataLink.DataSource <> nil) and (FDataLink.DataSource.DataSet <> nil) and (FDataLink.DataSource.DataSet.Active) and (FOptions.LocalMasterDetail) then begin SetMasterParams(Params); Data.FilterUpdated; end; end; /// SQLAddWhere, SQLDeleteWhere, SQLSetOrderBy, SQlGetOrderBy are SQL-server /// specific functions and they should be overriden in descendants. They operate /// with strings only. Return value is new SQL text or it's part being /// requested. function TCustomDADataSet.SQLAddWhere(SQLText, Condition: string): string; begin Result := ''; end; function TCustomDADataSet.SQLDeleteWhere(SQLText: string): string; begin Result := ''; end; function TCustomDADataSet.SQLGetWhere(SQLText: string): string; begin Result := ''; end; function TCustomDADataSet.SQLSetOrderBy(SQLText: string; Fields: string): string; begin Result := ''; end; function TCustomDADataSet.SQLGetOrderBy(SQLText: string): string; begin Result := ''; end; /// AddWhere, DeleteWhere, SetOrderBy, GetOrderBy are public SQL-server /// indepedant methods. They can modify SQL property value of the dataset. Each /// method calls it's internal equivalent with 'SQL' prefix. procedure TCustomDADataSet.AddWhere(Condition: string); begin SaveModifiedSQL(SQLAddWhere(Trim(SQL.Text), Condition)); end; procedure TCustomDADataSet.DeleteWhere; begin SaveModifiedSQL(SQLDeleteWhere(Trim(SQL.Text))); end; procedure TCustomDADataSet.SetOrderBy(Fields: string); begin SaveModifiedSQL(SQLSetOrderBy(Trim(SQL.Text), Fields)); end; function TCustomDADataSet.GetOrderBy: string; begin Result := SQLGetOrderBy(Trim(SQL.Text)); end; /// GetBaseSQL returns original sql text with expanded macros. function TCustomDADataSet.GetBaseSQL: string; begin if FBaseSQL <> '' then Result := FBaseSQL else Result := SQL.Text; if Macros.Count > 0 then Macros.Expand(Result); end; function TCustomDADataSet.GetFinalSQL: string; var Str, Where: string; MasterName: string; DetailName: string; MasterPos: integer; DetailPos: integer; begin Str := FCommand.FinalSQL; if FFilterSQL <> '' then Str := SQLAddWhere(Str, FilterSQL); if (DataSource <> nil) and (FMasterFields <> '') and (FDetailFields <> '') and not (FOptions.LocalMasterDetail) then begin MasterPos := 1; DetailPos := 1; Where := ''; while True do begin MasterName := ExtractFieldName(FMasterFields, MasterPos); DetailName := ExtractFieldName(FDetailFields, DetailPos); if (MasterName <> '') and (DetailName <> '') then begin if Where <> '' then Where := Where + ' and '; Where := Where + TablesInfo.TableInfoClass.NormalizeName(DetailName, Options.QuoteNames) + ' = :' + TablesInfo.TableInfoClass.NormalizeName(MasterName, Options.QuoteNames); end else break; end; if Where <> '' then Str := SQLAddWhere(Str, Where); end; Result := Str; end; procedure TCustomDADataSet.SetUpdateObject(Value: TCustomDAUpdateSQL); begin if Value <> nil then begin Value.CheckUpdateComponent(Value.ModifyObject, Self); Value.CheckUpdateComponent(Value.InsertObject, Self); Value.CheckUpdateComponent(Value.DeleteObject, Self); Value.CheckUpdateComponent(Value.RefreshObject, Self); end; if Value <> FUpdateObject then begin if Assigned(FUpdateObject) and (FUpdateObject.DataSet = Self) then FUpdateObject.DataSet := nil; FUpdateObject := Value; if Assigned(FUpdateObject) then begin if Assigned(FUpdateObject.DataSet) and (FUpdateObject.DataSet <> Self) then FUpdateObject.DataSet.UpdateObject := nil; FUpdateObject.DataSet := Self; end; end; end; procedure TCustomDADataSet.SetOptions(Value: TDADataSetOptions); begin FOptions.Assign(Value); end; procedure TCustomDADataSet.SetFilterSQL(Value: string); var OldFilter: string; OldActive: boolean; begin if Value <> FFilterSQL then begin OldFilter := FFilterSQL; FFilterSQL := Trim(Value); OldActive := Active; if not (csReading in ComponentState) then begin Close; UnPrepare; end; AssembleSQL; if OldActive then try Open; if Filtered and (Filter <> '') then begin Data.FilterUpdated; Resync([]); First; end; except FFilterSQL := OldFilter; AssembleSQL; raise; end; end; end; procedure TCustomDADataSet.SetFiltered(Value: boolean); var KeyFields: TFieldArray; Values: variant; begin if Value <> Filtered then begin if Active then GetCurrentKeys(KeyFields, Values); inherited; if Active and (Length(KeyFields) <> 0) then Locate(KeyFields, Values, []); end; end; procedure TCustomDADataSet.SetMasterFields(Value: string); var NeedRefresh: boolean; begin if Value <> FMasterFields then begin NeedRefresh := IsConnectedToMaster; FMasterFields := Value; NeedRefresh := NeedRefresh or IsConnectedToMaster; if NeedRefresh then RefreshDetailSQL; end; end; procedure TCustomDADataSet.SetForeignKeyFields(Value: string); var NeedRefresh: boolean; begin if Value <> FDetailFields then begin NeedRefresh := IsConnectedToMaster; FDetailFields := Value; NeedRefresh := NeedRefresh or IsConnectedToMaster; if NeedRefresh then RefreshDetailSQL; end; end; { TDADataSetOptions } constructor TDADataSetOptions.Create(Owner: TCustomDADataSet); begin inherited Create; FOwner := Owner; RequiredFields := True; StrictUpdate := True; TrimFixedChar := True; LongStrings := True; FlatBuffers := False; RemoveOnRefresh := True; FDetailDelay := 0; UpdateBatchSize := 1; end; procedure TDADataSetOptions.AssignTo(Dest: TPersistent); begin if Dest is TDADataSetOptions then begin TDADataSetOptions(Dest).RequiredFields := RequiredFields; TDADataSetOptions(Dest).StrictUpdate := StrictUpdate; TDADataSetOptions(Dest).NumberRange := NumberRange; TDADataSetOptions(Dest).QueryRecCount := QueryRecCount; TDADataSetOptions(Dest).AutoPrepare := AutoPrepare; TDADataSetOptions(Dest).ReturnParams := ReturnParams; TDADataSetOptions(Dest).TrimFixedChar := TrimFixedChar; TDADataSetOptions(Dest).TrimVarChar := TrimVarChar; TDADataSetOptions(Dest).LongStrings := LongStrings; TDADataSetOptions(Dest).FlatBuffers := FlatBuffers; TDADataSetOptions(Dest).DetailDelay := DetailDelay; TDADataSetOptions(Dest).SetFieldsReadOnly := SetFieldsReadOnly; TDADataSetOptions(Dest).QuoteNames := QuoteNames; {$IFDEF HAVE_COMPRESS} TDADataSetOptions(Dest).CompressBlobMode := CompressBlobMode; {$ENDIF} TDADataSetOptions(Dest).LocalMasterDetail := LocalMasterDetail; TDADataSetOptions(Dest).CacheCalcFields := CacheCalcFields; TDADataSetOptions(Dest).FullRefresh := FullRefresh; TDADataSetOptions(Dest).UpdateAllFields := UpdateAllFields; end else inherited; end; procedure TDADataSetOptions.SetRequiredFields(Value: boolean); begin if FRequiredFields <> Value then begin FRequiredFields := Value; FOwner.FLocalConstraints := FRequiredFields; FOwner.FieldDefs.Updated := False; if FOwner.Active then // for change RequiredFields in runtime FOwner.FieldDefs.Update; end; end; procedure TDADataSetOptions.SetNumberRange(Value: boolean); begin FNumberRange := Value; FOwner.FNumberRange := FNumberRange; end; procedure TDADataSetOptions.SetTrimFixedChar(Value: boolean); begin FTrimFixedChar := Value; FOwner.Data.TrimFixedChar := FTrimFixedChar; end; procedure TDADataSetOptions.SetTrimVarChar(Value: boolean); begin FTrimVarChar := Value; FOwner.Data.TrimVarChar := FTrimVarChar; end; procedure TDADataSetOptions.SetLongStrings(Value: boolean); begin FOwner.CheckInactive; FLongStrings := Value; FOwner.FIRecordSet.SetProp(prLongStrings, FLongStrings); FOwner.FieldDefs.Updated := False; end; procedure TDADataSetOptions.SetAutoPrepare(Value: boolean); begin if FAutoPrepare = Value then Exit; FOwner.Unprepare; FAutoPrepare := Value; end; procedure TDADataSetOptions.SetFlatBuffers(const Value: boolean); begin FOwner.CheckInactive; FFlatBuffers := Value; FOwner.FIRecordSet.SetProp(prFlatBuffers, Value); end; procedure TDADataSetOptions.SetDetailDelay(Value: integer); begin FDetailDelay := Value; {$IFDEF MSWINDOWS} FOwner.CheckRefreshDetailTimer; FOwner.FDetailRefreshTimer.Interval := Value; {$ENDIF} end; procedure TDADataSetOptions.SetLocalMasterDetail(Value: boolean); begin if Value <> FLocalMasterDetail then begin FOwner.CheckInactive; FLocalMasterDetail := Value; if FLocalMasterDetail then FOwner.FIRecordSet.FilterMDFunc := FOwner.LocalDetailFilter else FOwner.FIRecordSet.FilterMDFunc := nil; if Value then FOwner.AssembleSQL; end; end; function TDADataSetOptions.GetCacheCalcFields: boolean; begin Result := FOwner.FCacheCalcFields; end; procedure TDADataSetOptions.SetCacheCalcFields(Value: boolean); begin if Value <> CacheCalcFields then begin FOwner.CheckInactive; FOwner.FCacheCalcFields := Value; end; end; {$IFDEF HAVE_COMPRESS} procedure TDADataSetOptions.SetCompressBlobMode(Value: TCompressBlobMode); begin if FCompressBlobMode <> Value then begin TCustomDADataSet(FOwner).CheckInactive; FCompressBlobMode := Value; FOwner.FIRecordSet.SetProp(prCompressBlobMode, Integer(Value)); FOwner.FieldDefs.Updated := False; end; end; {$ENDIF} { TDASQLGenerator } constructor TDASQLGenerator.Create(Owner: TCustomDADataSet); begin inherited Create; Assert(Owner <> nil); FOwner := Owner; FHeaderSB := StringBuilder.Create(100); FFldSB := StringBuilder.Create(100); FMiddleSB := StringBuilder.Create(100); FFldParamSB := StringBuilder.Create(100); FCondSB := StringBuilder.Create(100); FFooterSB := StringBuilder.Create(100); FParamsInfo := TDAParamsInfo.Create(GetParamInfoClass); end; destructor TDASQLGenerator.Destroy; begin FParamsInfo.Free; FHeaderSB.Free; FFldSB.Free; FMiddleSB.Free; FFldParamSB.Free; FCondSB.Free; FFooterSB.Free; inherited; end; function TDASQLGenerator.GetParamInfoClass: TDAParamInfoClass; begin Result := TDAParamInfo; end; procedure TDASQLGenerator.Clear; begin FHeaderSB.Length := 0; FFldSB.Length := 0; FMiddleSB.Length := 0; FFldParamSB.Length := 0; FCondSB.Length := 0; FFooterSB.Length := 0; FOldRecBuf := nil; FNewRecBuf := nil; end; function TDASQLGenerator.AssembleSB(const StatementType: TStatementType): string; begin // TODO: may be optimized for Win32 Result := FHeaderSB.ToString + FFldSB.ToString + FMiddleSB.ToString + FFldParamSB.ToString + FCondSB.ToString + FFooterSB.ToString; end; function TDASQLGenerator.Data: TData; begin Result := FOwner.Data; end; function TDASQLGenerator.OldRecBuf: IntPtr; begin if FOldRecBuf <> nil then Result := FOldRecBuf else begin // Old buffer if FOwner.FInDeferredPost then Result := FOwner.OldDeferredPostBuf else if FOwner.FInCacheProcessing then Result := FOwner.OldCacheRecBuf else Result := FOwner.GetOldRecord; FOldRecBuf := Result; end end; function TDASQLGenerator.NewRecBuf: IntPtr; begin if FNewRecBuf <> nil then Result := FNewRecBuf else begin // New buffer if FOwner.FInCacheProcessing then Result := FOwner.NewCacheRecBuf else Result := FOwner.ActiveBuffer; FNewRecBuf := Result; end end; function TDASQLGenerator.IsBlobDataType(DataType: word): boolean; begin Result := DataType in [dtBlob, dtMemo, dtWideMemo]; //Data.IsBlobFieldType end; function TDASQLGenerator.IsObjectDataType(DataType: word): boolean; begin Result := DataType in [dtObject, dtArray]; end; function TDASQLGenerator.FieldIsNull(FieldDesc: TCRFieldDesc; OldValue: boolean; Data: TData; OldRecBuf, NewRecBuf: IntPtr): boolean; //This function added for Expand fields support var i: integer; begin Result := not FOwner.Active; if Result then Exit; if IsObjectDataType(FieldDesc.DataType) then begin i := FieldDesc.FieldNo; while (i < Data.FieldCount) and (Data.Fields[i].ParentField = FieldDesc) do begin Result := FieldIsNull(TCRFieldDesc(Data.Fields[i]), OldValue); inc(i); if not Result then Break; end; end else if OldValue then Result := Data.GetNull(FieldDesc.FieldNo, OldRecBuf) else Result := Data.GetNull(FieldDesc.FieldNo, NewRecBuf); end; function TDASQLGenerator.FieldIsNull(FieldDesc: TCRFieldDesc; OldValue: boolean): boolean; begin Result := not FOwner.Active; if Result then Exit; Result := FieldIsNull(FieldDesc, OldValue, Data, OldRecBuf, NewRecBuf); end; function TDASQLGenerator.FieldModified(FieldDesc: TCRFieldDesc; Data: TData; OldRecBuf, NewRecBuf: IntPtr): boolean; //This function added for Expand fields support var i: integer; begin if IsBlobDataType(FieldDesc.DataType) then begin if FOwner.FInCacheProcessing then Result := Data.GetObject(FieldDesc.FieldNo, NewRecBuf) <> Data.GetObject(FieldDesc.FieldNo, OldRecBuf) else Result := TBlob(Data.GetObject(FieldDesc.FieldNo, NewRecBuf)).Modified end else if IsObjectDataType(FieldDesc.DataType) then begin Result := False; i := FieldDesc.FieldNo; while (i < Data.FieldCount) and (Data.Fields[i].ParentField = FieldDesc) do begin //Child FieldDescs always next to parent FielDescs Result := FieldModified(TCRFieldDesc(Data.Fields[i])); inc(i); if Result then break; end; end else Result := TMemData(Data).CompareFields(OldRecBuf, NewRecBuf, FieldDesc) <> 0; end; function TDASQLGenerator.FieldModified(FieldDesc: TCRFieldDesc): boolean; begin Result := FieldModified(FieldDesc, Data, OldRecBuf, NewRecBuf); end; function TDASQLGenerator.GetActualFieldName(FieldDesc: TCRFieldDesc; IsRefresh: boolean): string; begin Result := QuoteName(GetActualFieldNameEx(FieldDesc, FieldDesc.TableInfo)); if IsRefresh and FOwner.Options.FullRefresh or FOwner.ReadOnly then begin//Use original Select part, so we could use Field aliasess if (FieldDesc.TableInfo <> nil) then if FieldDesc.TableInfo.TableAlias <> '' then Result := FieldDesc.TableInfo.NormalizeName(FieldDesc.TableInfo.TableAlias, FOwner.FOptions.FQuoteNames) + '.' + Result else Result := FieldDesc.TableInfo.NormalizeName(FieldDesc.TableInfo.TableName, FOwner.FOptions.FQuoteNames) + '.' + Result; end; end; function TDASQLGenerator.GetActualFieldNameEx(FieldDesc: TCRFieldDesc; TableInfo: TCRTableInfo): string; var p: integer; begin Result := FieldDesc.ActualName; if (FieldDesc.TableInfo = TableInfo) or (FieldDesc.TableInfo.TableName = TableInfo.TableName) then begin p := Pos('.', Result); if (p <> 0) and (Pos(FieldDesc.TableInfo.TableName, Result) = 1) then //Here we should detremine that Result is not something like "Dot.FieldName" Result := Copy(Result, p + 1, MaxInt);{Delete table name from fieldname} end; end; function TDASQLGenerator.GenerateIndexName(Name: string): string; begin Result := '_' + Name; end; function TDASQLGenerator.DecodeFieldIndex(FieldName: string): integer; var e: integer; begin Result := -1; if (Length(FieldName) >= 2) and (FieldName[1] = '_') then begin Val(Copy(FieldName, 2, MaxInt), Result, e); if e <> 0 then Result := -1; end; end; function TDASQLGenerator.IndexedPrefix: string; begin Result := 'P_'; end; function TDASQLGenerator.QuoteName(const AName: string): string; begin Assert(FOwner <> nil); Result := FOwner.QuoteName(AName); end; function TDASQLGenerator.UnQuoteName(AName: string): string; begin Assert(FOwner <> nil); Result := FOwner.UnQuoteName(AName); end; function TDASQLGenerator.IsSubstituteParamName: boolean; begin Result := True; end; procedure TDASQLGenerator.AddParam(SB: StringBuilder; FieldDesc: TFieldDesc; const StatementType: TStatementType; const ParamType: TParamType; Index: integer = -1; Old: boolean = False); var ParamName: string; ParamInfo: TDAParamInfo; Param: TDAParam; begin { Nonsense after adding ParamsInfo support if not (csDesigning in FOwner.ComponentState) and (FieldDesc.FieldNo <> 0) then ParamName := IntToStr(FieldDesc.FieldNo) else} ParamName := FieldDesc.Name; if Old then ParamName := 'Old_' + ParamName; if Index > - 1 then ParamName := IndexedPrefix + IntToStr(Index) + '_' + ParamName; // if csDesigning in FOwner.ComponentState then // Don't call QuoteName IntToStr(FieldDesc.FieldNo) ParamName := QuoteName(ParamName); //TODO:???? QuoteName if ((FParams = nil) or not IsSubstituteParamName) or (((FOwner.Params.Count > 0) or FOwner.Options.FullRefresh) and (StatementType = stRefresh)) then begin SB.Append(':'); SB.Append(ParamName); end else SB.Append('?'); if FParams <> nil then begin Param := TDAParam(FParams.Add); Param.Name := ParamName; Param.ParamType := ParamType; {$IFNDEF CLR} _TParam(Param).FParamRef := Param; {$ENDIF} ParamInfo := TDAParamInfo(FParamsInfo.Add); ParamInfo.Field := FOwner.GetField(FieldDesc); ParamInfo.Old := Old; ParamInfo.ParamIndex := Index; end; end; procedure TDASQLGenerator.AddFieldToCondition(SB: StringBuilder; FieldDesc: TCRFieldDesc; const StatementType: TStatementType; const ModifiedFieldsOnly: boolean; const Index: integer = -1); var ActualName: string; begin if SB.Length > 0 then SB.Append(' AND '); Assert(FieldDesc <> nil); ActualName := GetActualFieldName(FieldDesc, StatementType = stRefresh); SB.Append(ActualName); if ModifiedFieldsOnly and FieldIsNull(FieldDesc, StatementType <> stRefresh) then //Refresh generated with current field values SB.Append(' IS NULL') else begin SB.Append(' = '); AddParam(SB,FieldDesc, StatementType, ptInput, Index, (StatementType <> stRefresh) or (FOwner.CachedUpdates and (StatementType = stRefresh))); //Refresh generated with current field values end; end; procedure TDASQLGenerator.GenerateConditions(SB: StringBuilder; const StatementType: TStatementType; const ModifiedFieldsOnly: boolean; const KeyAndDataFields: TKeyAndDataFields; const Index: integer = -1); var i: integer; begin if Length(KeyAndDataFields.KeyFieldDescs) > 0 then for i := 0 to High(KeyAndDataFields.KeyFieldDescs) do AddFieldToCondition(SB, KeyAndDataFields.KeyFieldDescs[i], StatementType, ModifiedFieldsOnly, Index) else begin if FOwner.FIdentityField <> nil then AddFieldToCondition(SB, TCRFieldDesc(FOwner.GetFieldDesc(FOwner.FIdentityField)), StatementType, ModifiedFieldsOnly, Index) else begin if Length(KeyAndDataFields.DataFieldDescs) = 0 then DatabaseError(SNoKeyFields); for i := 0 to High(KeyAndDataFields.DataFieldDescs) do if not IsBlobDataType(KeyAndDataFields.DataFieldDescs[i].DataType) then AddFieldToCondition(SB, KeyAndDataFields.DataFieldDescs[i], StatementType, ModifiedFieldsOnly, Index); end; end; end; procedure TDASQLGenerator.AddFieldToInsertSQL(FieldDesc: TCRFieldDesc; const Index: integer = -1); begin if FFldSB.Length > 0 then begin FFldSB.Append(', '); FFldParamSB.Append(', '); end; FFldSB.Append(FieldDesc.ActualNameQuoted(TCRRecordSet(FOwner.Data), FOwner.Options.QuoteNames)); AddParam(FFldParamSB, FieldDesc, stInsert, ptInput, Index); end; procedure TDASQLGenerator.GenerateInsertSQL( const KeyAndDataFields: TKeyAndDataFields; const ModifiedFieldsOnly: boolean; const Index: integer = -1); var i: integer; FieldDesc: TCRFieldDesc; begin for i := 0 to High(KeyAndDataFields.DataFieldDescs) do begin FieldDesc := KeyAndDataFields.DataFieldDescs[i]; // Insert all(!) field values if not ModifiedFieldsOnly or not FieldIsNull(FieldDesc, False) then AddFieldToInsertSQL(FieldDesc, Index); end; FHeaderSB.Append('INSERT INTO '); FHeaderSB.Append(FTableInfo.NormalizeName(FTableInfo.TableNameFull, FOwner.FOptions.FQuoteNames)); FHeaderSB.Append(SLLineSeparator); FHeaderSB.Append(' ('); // Append FFldSB FMiddleSB.Append(')'); FMiddleSB.Append(SLLineSeparator); FMiddleSB.Append('VALUES'); FMiddleSB.Append(SLLineSeparator); FMiddleSB.Append(' ('); // Append FFldParamSB FFooterSB.Append(')'); end; procedure TDASQLGenerator.AddFieldToUpdateSQL(FieldDesc: TCRFieldDesc; const ModifiedFieldsOnly: boolean; const Index: integer = -1); begin if FFldSB.Length > 0 then FFldSB.Append(', '); FFldSB.Append(FieldDesc.ActualNameQuoted(TCRRecordSet(FOwner.Data), FOwner.Options.QuoteNames)); FFldSB.Append(' = '); AddParam(FFldSB, FieldDesc, stUpdate, ptInput, Index); end; procedure TDASQLGenerator.GenerateUpdateSQL( const KeyAndDataFields: TKeyAndDataFields; const ModifiedFieldsOnly: boolean; const Index: integer = -1); var i: integer; FieldDesc: TCRFieldDesc; begin for i := 0 to High(KeyAndDataFields.DataFieldDescs) do begin FieldDesc := KeyAndDataFields.DataFieldDescs[i]; if not ModifiedFieldsOnly or FieldModified(FieldDesc) then AddFieldToUpdateSQL(FieldDesc, ModifiedFieldsOnly, Index); end; if FFldSB.Length > 0 then begin FHeaderSB.Append('UPDATE '); FHeaderSB.Append(FTableInfo.NormalizeName(FTableInfo.TableNameFull, FOwner.FOptions.FQuoteNames)); FHeaderSB.Append(SLLineSeparator); FHeaderSB.Append('SET'); FHeaderSB.Append(SLLineSeparator); FHeaderSB.Append(' '); // Append FFldSB FMiddleSB.Append(SLLineSeparator); FMiddleSB.Append('WHERE'); FMiddleSB.Append(SLLineSeparator); FMiddleSB.Append(' '); // Append FParamSB GenerateConditions(FCondSB, stUpdate, ModifiedFieldsOnly, KeyAndDataFields, Index); end; end; procedure TDASQLGenerator.GenerateDeleteSQL( const KeyAndDataFields: TKeyAndDataFields; const ModifiedFieldsOnly: boolean; const Index: integer = -1); begin FHeaderSB.Append('DELETE FROM '); FHeaderSB.Append(FTableInfo.NormalizeName(FTableInfo.TableNameFull, FOwner.FOptions.FQuoteNames)); FHeaderSB.Append(SLLineSeparator); FHeaderSB.Append('WHERE'); FHeaderSB.Append(SLLineSeparator); FHeaderSB.Append(' '); GenerateConditions(FCondSB, stDelete, ModifiedFieldsOnly, KeyAndDataFields, Index); end; procedure TDASQLGenerator.GenerateLockSQL( const KeyAndDataFields: TKeyAndDataFields; const Index: integer = -1); begin end; procedure TDASQLGenerator.AddFieldToRefreshSQL(FieldDesc: TCRFieldDesc); begin if FFldSB.Length > 0 then FFldSB.Append(', '); if FieldDesc.TableInfo = nil then FFldSB.Append(FieldDesc.ActualNameQuoted(TCRRecordSet(FOwner.Data), FOwner.Options.QuoteNames)) else if FieldDesc.TableInfo.TableAlias <> '' then FFldSB.Append(FieldDesc.TableInfo.NormalizeName(FieldDesc.TableInfo.TableAlias, FOwner.FOptions.FQuoteNames) + '.' + FieldDesc.ActualNameQuoted(TCRRecordSet(FOwner.Data), FOwner.Options.QuoteNames)) else FFldSB.Append(FieldDesc.TableInfo.NormalizeName(FieldDesc.TableInfo.TableName, FOwner.FOptions.FQuoteNames) + '.' + FieldDesc.ActualNameQuoted(TCRRecordSet(FOwner.Data), FOwner.Options.QuoteNames)); if not (csDesigning in FOwner.ComponentState) then FFldSB.Append(' AS ' + GenerateIndexName(IntToStr(FOwner.FIRecordSet.Fields.IndexOf(FieldDesc)))); end; procedure TDASQLGenerator.GenerateRefreshSQLSelectPart(const KeyAndDataFields: TKeyAndDataFields); var i: integer; FieldArrHigh: integer; UseDataFields: boolean; FieldDesc: TCRFieldDesc; begin FHeaderSB.Append('SELECT '); UseDataFields := Length(KeyAndDataFields.DataFieldDescs) > 0; if UseDataFields then FieldArrHigh := Length(KeyAndDataFields.DataFieldDescs) - 1 else FieldArrHigh := High(KeyAndDataFields.KeyFieldDescs); // SELECT ... FROM .... {WITH NOLOCK} // Add SELECT section for i := 0 to FieldArrHigh do begin if UseDataFields then FieldDesc := KeyAndDataFields.DataFieldDescs[i] else FieldDesc := KeyAndDataFields.KeyFieldDescs[i]; AddFieldToRefreshSQL(FieldDesc); end; end; procedure TDASQLGenerator.GenerateRefreshSQLFromPart; begin FMiddleSB.Append(FTableInfo.NormalizeName(FTableInfo.TableName, FOwner.FOptions.FQuoteNames)); if FTableInfo.TableAlias <> '' then begin FMiddleSB.Append(' '); FMiddleSB.Append(FTableInfo.NormalizeName(FTableInfo.TableAlias, FOwner.FOptions.FQuoteNames)); end; end; procedure TDASQLGenerator.GenerateRefreshSQL( const KeyAndDataFields: TKeyAndDataFields; const ModifiedFieldsOnly: boolean); begin GenerateConditions(FCondSB, stRefresh, ModifiedFieldsOnly, KeyAndDataFields); if FOwner.Options.FullRefresh or FOwner.ReadOnly then begin if FCondSB.Length = 0 then FHeaderSB.Append(FOwner.SQL.Text) else begin FHeaderSB.Append(FOwner.SQLAddWhere(FOwner.SQL.Text, SLLineSeparator + ' ' + FCondSB.ToString)); FCondSB.Length := 0; // WHERE clause already added to FHeaderSB end; end else begin GenerateRefreshSQLSelectPart(KeyAndDataFields); FMiddleSB.Append(' FROM '); GenerateRefreshSQLFromPart; FMiddleSB.Append(SLLineSeparator); FMiddleSB.Append('WHERE'); FMiddleSB.Append(SLLineSeparator); FMiddleSB.Append(' '); end; end; procedure TDASQLGenerator.GenerateRefreshQuickSQL(const KeyAndDataFields: TKeyAndDataFields); begin GenerateConditions(FCondSB, stRefreshQuick, False{ignored}, KeyAndDataFields); FHeaderSB.Append(FOwner.SQLAddWhere(FOwner.FinalSQL, FCondSB.ToString)); FCondSB.Length := 0; // WHERE clause already added to FHeaderSB end; procedure TDASQLGenerator.GenerateRefreshCheckDeletedSQL(const KeyAndDataFields: TKeyAndDataFields); var i: integer; FieldDesc: TFieldDesc; ActualFieldName: string; Condition: string; function ForceUnQuoteName(AName: string): string; var l: integer; begin AName := Trim(AName); l := Length(AName); if (l >= 3) and (AName[1] = FOwner.FLeftQuote) and (AName[l] = FOwner.FRightQuote) then Result := Copy(AName, 2, l - 2) else Result := AName; end; begin FHeaderSB.Append('SELECT '); for i:= 0 to Length(KeyAndDataFields.KeyFieldDescs) - 1 do begin FieldDesc := KeyAndDataFields.KeyFieldDescs[i]; if i > 0 then begin FFldSB.Append(', '); FFooterSB.Append(', '); end; ActualFieldName := GetActualFieldName(TCRFieldDesc(FieldDesc), False); FFldSB.Append(ActualFieldName); FFooterSB.Append(ActualFieldName); if UpperCase(ForceUnQuoteName(ActualFieldName)) <> UpperCase(ForceUnQuoteName(FieldDesc.Name)) then FFldSB.Append(' AS ' + FieldDesc.Name); end; FMiddleSB.Append(' FROM '); FMiddleSB.Append(FTableInfo.NormalizeName(FTableInfo.TableNameFull, FOwner.FOptions.FQuoteNames)); Condition := FOwner.SQLGetWhere(FOwner.FinalSQL); if Condition <> '' then FMiddleSB.Append(' WHERE ' + Condition); FMiddleSB.Append(' ORDER BY '); end; function TDASQLGenerator.GenerateSQLforUpdTable(TableInfo: TCRTableInfo; const KeyAndDataFields: TKeyAndDataFields; const StatementType: TStatementType; const ModifiedFieldsOnly: boolean; Params: TDAParams; const Index: integer = -1): string; {$IFNDEF CLR} var i: integer; {$ENDIF} begin if TableInfo.TableName = '' then DatabaseError(SBadTableInfoName); Clear; FTableInfo := TableInfo; FParams := Params; if FParams <> nil then begin FParams.BeginUpdate; FParams.Clear; FParamsInfo.Clear; end; try case StatementType of stInsert: GenerateInsertSQL(KeyAndDataFields, ModifiedFieldsOnly, Index); stUpdate: GenerateUpdateSQL(KeyAndDataFields, ModifiedFieldsOnly, Index); stDelete: GenerateDeleteSQL(KeyAndDataFields, ModifiedFieldsOnly, Index); stLock: GenerateLockSQL(KeyAndDataFields, Index); stRefresh: GenerateRefreshSQL(KeyAndDataFields, ModifiedFieldsOnly); stRefreshQuick: GenerateRefreshQuickSQL(KeyAndDataFields); stRefreshCheckDeleted: GenerateRefreshCheckDeletedSQL(KeyAndDataFields); else DatabaseError(SBadStatementType); end; Result := AssembleSB(StatementType); finally if FParams <> nil then begin FParams.EndUpdate; {$IFNDEF CLR} for i := 0 to FParams.Count - 1 do _TParam(TCollection(FParams).Items[i]).FParamRef := TParam(TCollection(FParams).Items[i]); {$ENDIF} end; end; end; function TDASQLGenerator.GenerateSQL(const StatementType: TStatementType; const ModifiedFieldsOnly: boolean; Params: TDAParams; const Index: Integer = -1): string; var KeyAndDataFields: TKeyAndDataFields; begin {$IFDEF PERF_COUNTER} PerfCounters[4].Start; {$ENDIF} if FOwner.FUpdatingTableInfoIdx = -1 then Result := '' else begin FOwner.GetKeyAndDataFields(KeyAndDataFields, (StatementType = stRefresh) and FOwner.Options.FullRefresh); Result := GenerateSQLforUpdTable(FOwner.TablesInfo[FOwner.FUpdatingTableInfoIdx], KeyAndDataFields, StatementType, ModifiedFieldsOnly, Params, Index); end; {$IFDEF PERF_COUNTER} PerfCounters[4].Stop; {$ENDIF} end; { TCustomDASQL } constructor TCustomDASQL.Create(Owner: TComponent); begin inherited Create(Owner); FSQL := TStringList.Create; TStringList(FSQL).OnChange := SQLChanged; FParams := CreateParamsObject; FParamCheck := True; if Owner is TCustomDADataSet then FMacros := TMacros.Create(Owner) else FMacros := TMacros.Create(Self); FChangeCursor := True; FDesignCreate := csDesigning in ComponentState; if not (Owner is TCustomDADataSet) then // temp CreateICommand; end; destructor TCustomDASQL.Destroy; var Owner: TComponent; begin UnPrepare; if UsedConnection <> nil then UsedConnection.UnregisterClient(Self); FMacros.Free; FParams.Clear; // To prevent SharedObj leak on CLR FParams.Free; FSQL.Free; Owner := Self.Owner; inherited; if not (Owner is TCustomDADataSet) then // temp FreeICommand; end; procedure TCustomDASQL.CreateICommand; begin if UsedConnection <> nil then SetICommand(UsedConnection.CreateICommand) else SetICommand(nil); end; procedure TCustomDASQL.FreeICommand; begin FICommand.Free; SetICommand(nil); end; procedure TCustomDASQL.SetICommand(Value: TCRCommand); var ScanParams: variant; begin FICommand := Value; if FICommand <> nil then begin if FConnection <> nil then FICommand.SetConnection(FConnection.FIConnection) else FICommand.SetConnection(nil); FICommand.SetSQL(FNativeSQL); //AssembleSQL; // set FICommand.SQL FICommand.SetProp(prAutoCommit, FAutoCommit); FICommand.AfterExecute := DoAfterExecute; if (Owner is TCustomDADataSet) or (Owner is TCustomDAConnection) then FICommand.Component := Owner else FICommand.Component := Self; FICommand.GetProp(prScanParams, ScanParams); // Write param info if not boolean(ScanParams) then WriteParams(False); end; end; procedure TCustomDASQL.CheckICommand; var ClassType: TClass; begin if (UsedConnection <> nil) then ClassType := UsedConnection.GetICommandClass else ClassType := nil; if (ClassType = nil) or not (FICommand is ClassType) then begin FreeICommand; CreateICommand; end; end; function TCustomDASQL.CreateParamsObject: TDAParams; begin Result := TDAParams.Create(Self); end; procedure TCustomDASQL.Loaded; begin inherited; FDesignCreate := False; end; function TCustomDASQL.UsedConnection: TCustomDAConnection; begin Result := FConnection end; procedure TCustomDASQL.CheckConnection; begin BeginConnection(False); end; procedure TCustomDASQL.BeginConnection(NoConnectCheck: boolean = True); begin if UsedConnection = nil then DatabaseError(SConnectionNotDefined); if NoConnectCheck then UsedConnection.InternalConnect // We should call connect each time to update ConnectCount else if not UsedConnection.Connected then UsedConnection.Connect; // use default session if (FConnection = nil) and (UsedConnection.FSQLs.IndexOf(Self) = -1) then begin UsedConnection.RegisterClient(Self, ConnectChange); CheckICommand; FICommand.SetConnection(UsedConnection.FIConnection) end; end; procedure TCustomDASQL.EndConnection; begin if UsedConnection <> nil then UsedConnection.InternalDisconnect; end; procedure TCustomDASQL.Disconnect; begin if FDataSet = nil then UnPrepare else FDataSet.Disconnect; end; procedure TCustomDASQL.ConnectChange(Sender: TObject; Connecting: boolean); begin if not Connecting then Disconnect; end; procedure TCustomDASQL.InternalPrepare; begin FICommand.Prepare; end; procedure TCustomDASQL.Prepare; var MessageID: cardinal; begin if not Prepared then begin BeginConnection; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLPrepare(Self, FinalSQL, FParams, MessageID, True); InternalPrepare; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLPrepare(Self, FinalSQL, FParams, MessageID, False); end; end; procedure TCustomDASQL.InternalUnPrepare; begin FICommand.Unprepare; end; procedure TCustomDASQL.UnPrepare; begin if Prepared then begin try InternalUnPrepare; finally EndConnection; //Diconnect after no longer prepared end; end; end; procedure TCustomDASQL.InternalExecute(Iters: integer); var ReExecute: boolean; begin if UsedConnection <> nil then UsedConnection.PushOperation(clExecute); try repeat ReExecute := False; try FICommand.Execute(Iters); except on E: EFailOver do if E.FConnLostCause = clExecute then begin Connection.RestoreAfterFailOver; //Restore all read transactions ReExecute := True; //We should pass clConnectionApplyUpdates FailOver end else raise; end; until (not ReExecute); finally if UsedConnection <> nil then UsedConnection.PopOperation; end; end; procedure TCustomDASQL.Execute; begin Execute(1); end; procedure TCustomDASQL.Execute(Iters: integer); var MessageID: cardinal; begin if not Executing then begin BeginConnection; if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, '', MessageID, True); if FChangeCursor then if FNonBlocking then SetCursor(crSQLArrow) else StartWait; WriteParams; InternalExecute(Iters); if not FLockDebug and (TDASQLMonitorClass(UsedConnection.SQLMonitorClass).HasMonitor or Debug) then TDASQLMonitorClass(UsedConnection.SQLMonitorClass).SQLExecute(Self, FinalSQL, FParams, '', MessageID, False); end; end; procedure TCustomDASQL.DoAfterExecute(Result: boolean); var Connection: TCustomDAConnection; begin if Result then ReadParams; if FChangeCursor and FNonBlocking then StopWait; Connection := UsedConnection; if Connection.Options.DisconnectedMode and Connection.Connected then begin //AutoCommit control if not (Connection.AutoCommit and AutoCommit) and (Connection.FTransactionID = '') then begin //Connection.GetInTransaction are not allowed here since it could be setted to True on // Product level during Execuion without AutoCommit (ODAC, IBDAC) //There is uncommitted transaction that was implicitly started by server Connection.FTransactionID := 'CRImplicitTransaction'; //Set default value Connection.FTransactionID := Connection.GetTransactionID; //To return product specific TransactionId //or even reset InTransaction in case of transaction-free server operation end else if Connection.AutoCommit and AutoCommit then begin Connection.FTransactionID := Connection.GetTransactionID; //To return product specific TransactionId end; end; EndConnection; //we should read all Out parameters before disconnect, so //in NonBlocking Mode this event must be called exactly after server execute if Assigned(FAfterExecute) then FAfterExecute(Self, Result); end; function TCustomDASQL.Executing: boolean; var Value: variant; begin FICommand.GetProp(prExecuting, Value); Result := Value; end; function TCustomDASQL.WaitExecuting(TimeOut: integer): boolean; {$IFDEF MSWINDOWS} var Msg: TMSG; T: DWORD; {$ENDIF} begin {$IFDEF MSWINDOWS} T := GetTickCount; while Executing and ((TimeOut = 0) or (GetTickCount - T < DWORD(TimeOut * 1000))) do if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin if Msg.Message <> WM_QUIT then begin TranslateMessage(Msg); DispatchMessage(Msg); end; end; {$ELSE} while Executing do; {$ENDIF} Result := not Executing; end; procedure TCustomDASQL.ScanMacros; begin if FDataSet = nil then FMacros.Scan(FSQL.Text) else FDataSet.ScanMacros; end; function TCustomDASQL.GetFinalSQL: string; var i: Integer; begin Result := FSQL.Text; // Copied from SysUtils i := Length(Result); while (i > 0) and (Result[i] <= ' ') do Dec(i); SetLength(Result, i); if FMacros.Count > 0 then FMacros.Expand(Result); end; function TCustomDASQL.ParseSQL(const SQL: string; Params: TDAParams; RenamePrefix: string = ''): string; var ParsedSQL: StringBuilder; Parser: TParser; StartPos: integer; LeftQuote, RightQuote: char; begin if FDataSet <> nil then begin LeftQuote := FDataSet.FLeftQuote; RightQuote := FDataSet.FRightQuote; end else begin LeftQuote := '"'; RightQuote := '"'; end; ParsedSQL := StringBuilder.Create(Length(SQL) + Length(SQL) div 2); try Parser := CreateParser(SQL); try if Params <> nil then begin Params.BeginUpdate; Params.Clear; end; Parser.OmitBlank := False; Parser.OmitComment := True; Parser.QuotedString := True; Parser.ToBegin; StartPos := Parser.CurrPos; while Parser.ToLexem(':') do begin ParsedSQL.Append(Copy(SQL, StartPos + 1, Parser.CurrPos - StartPos - 1)); ParseSQLParam(ParsedSQL, Parser, Params, LeftQuote, RightQuote, RenamePrefix); StartPos := Parser.CurrPos; end; ParsedSQL.Append(Copy(SQL, StartPos + 1, Parser.CurrPos - StartPos)); finally Parser.Free; if Params <> nil then Params.EndUpdate; end; Result := ParsedSQL.ToString; finally ParsedSQL.Free; end; end; function TCustomDASQL.ParseSQL(Params: TDAParams): string; begin Result := ParseSQL(FNativeSQL, Params, ''); end; procedure TCustomDASQL.ParseSQLParam(ParsedSQL: StringBuilder; Parser: TParser; Params: TDAParams; const LeftQuote, RightQuote: char; RenamePrefix: string); var Code: integer; St: string; DogPresent: boolean; l: integer; ParamName: string; begin Code := Parser.GetNext(St); DogPresent := St = '@'; if DogPresent then Code := Parser.GetNext(St); // Omit '@' in ParamName for BDE compatibility if ((Params <> nil) or (RenamePrefix <> '')) and ((Code = lcIdent) or (Code = lcNumber) or (Parser.KeywordLexems.IndexOf(St) <> -1)) // and (St <> '=') then begin if DogPresent then ParamName := '@' + St else ParamName := St; l := Length(ParamName); // remove quotes if (ParamName[1] = LeftQuote) and (ParamName[l] = RightQuote) then ParamName := Copy(ParamName, 2, l - 2); if Params <> nil then begin TDAParam(Params.Add).Name := ParamName; ParsedSQL.Append('?'); end else ParsedSQL.Append(RenamePrefix + ParamName); end else // Labels in SQL Server, MySQL syntax and PL SQL Blocks (a := b). begin ParsedSQL.Append(':'); if DogPresent then ParsedSQL.Append('@'); ParsedSQL.Append(St); end; end; function TCustomDASQL.CreateParser(const Text: string): TParser; begin Result := TParser.Create(Text); end; procedure TCustomDASQL.AssembleSQL; var InternalScanParams: variant; // scan params by internal layer List: TDAParams; begin {$IFDEF PERF_COUNTER} //PerfCounters[3].Start; {$ENDIF} if FDataSet = nil then FNativeSQL := FinalSQL else FNativeSQL := FDataSet.FinalSQL; FICommand.GetProp(prScanParams, InternalScanParams); if ParamCheck or (csDesigning in ComponentState) then begin List := CreateParamsObject; try if boolean(InternalScanParams) then begin // Internal param parsing List.Assign(FParams); FICommand.SetSQL(FNativeSQL); CreateParams; FParams.AssignValues(List); end else begin List.BeginUpdate; try FNativeSQL := ParseSQL(FNativeSQL, List); List.AssignValues(FParams); finally List.EndUpdate; end; FParams.Clear; FParams.Assign(List); FICommand.SetSQL(FNativeSQL); WriteParams(False); end; finally List.Clear; List.Free; end; end else begin // if not InternalScanParams then // replace parameters // FNativeSQL := FParams.ParseSQL(FNativeSQL, False); // needed only in SDAC FICommand.SetSQL(FNativeSQL); end; {$IFDEF PERF_COUNTER} //PerfCounters[3].Stop; {$ENDIF} end; // creates TDAParam objects if parameters was parsed by FICommand procedure TCustomDASQL.CreateParams; var ParamDesc: TParamDesc; i: integer; begin FParams.BeginUpdate; try FParams.Clear; for i := 0 to FICommand.GetParamCount - 1 do begin ParamDesc := FICommand.GetParam(i); with FParams.Add as TDAParam do begin Name := ParamDesc.GetName; DataType := GetFieldType(ParamDesc.GetDataType); ParamType := TParamType(ParamDesc.GetParamType); end; end; finally FParams.EndUpdate; end; end; // Write values of parameters to FICommand procedure TCustomDASQL.WriteParams(WriteValue: boolean = True); var Param: TDAParam; ParamDesc: CRAccess.TParamDesc; Dt: word; procedure WriteParamValue; var Value: Variant; {$IFDEF CLR} Bytes: TBytes; {$ELSE} l: integer; s: string; {$ENDIF} {$IFNDEF VER6P} tmp: int64; {$ENDIF} begin if Param.IsObjectDataType then begin ParamDesc.SetNull(Param.IsNull); ParamDesc.SetObject(Param.ParamObject); Exit; end; Value := Param.Value; if (Param.DataType = ftDate) and not (VarIsEmpty(Value) or VarIsNull(Value)) then begin {$IFDEF VER6P} Value := Trunc(Value); // drop time info /// CR-D16224 {$ELSE} tmp := Trunc(Value); TVarData(Value).VType := varInt64; TVarDataD6(Value).VInt64 := tmp; {$ENDIF} end; // Convert param values if necessary if ((Dt = dtBytes) or (Dt = dtVarBytes) or (Dt = dtBlob)) and (VarType(Value) <> varArray + varByte) then case VarType(Value) of varString{$IFDEF CLR}, varChar{$ENDIF}: begin {$IFDEF CLR} Bytes := Encoding.Default.GetBytes(String(Value)); Value := Unassigned; Value := Bytes; {$ELSE} s := Value; l := Length(s); Value := Unassigned; Value := VarArrayCreate([0, l - 1], varByte); if l > 0 then Move(s[1], TVarData(Value).VArray.Data^, l); {$ENDIF} end; end; ParamDesc.SetValue(Unassigned); ParamDesc.SetValue(Value); end; var ft: TFieldType; i: integer; begin for i := 0 to Params.Count - 1 do begin Param := Params[i]; if i < FICommand.GetParamCount then ParamDesc := FICommand.GetParam(i) else ParamDesc := FICommand.AddParam; ParamDesc.SetName(Param.Name); ft := Param.DataType; dt := GetDataType(ft); ParamDesc.SetDataType(dt); ParamDesc.SetParamType(TParamDirection(Param.ParamType)); if WriteValue then begin {$IFDEF PERF_COUNTER} PerfCounters[5].Start; {$ENDIF} WriteParamValue; {$IFDEF PERF_COUNTER} PerfCounters[5].Stop; {$ENDIF} end; end; while Params.Count < FICommand.GetParamCount do FICommand.DeleteParam(FICommand.GetParamCount - 1); end; // Read values of parameters from FICommand procedure TCustomDASQL.ReadParams; var i: integer; Param: TDAParam; ParamDesc: TParamDesc; begin for i := 0 to FParams.Count - 1 do begin Param := Params[i]; ParamDesc := FICommand.GetParam(i); if ParamDesc <> nil then if (not Param.IsObjectDataType) and (Param.ParamType in [ptUnknown, ptOutput, ptInputOutput, ptResult]) then Param.Value := ParamDesc.Value; end; end; procedure TCustomDASQL.DefineProperties(Filer: TFiler); function WriteParams: boolean; begin if Filer.Ancestor <> nil then Result := not FParams.IsEqual(TCustomDASQL(Filer.Ancestor).FParams) else Result := FParams.Count > 0; end; function WriteMacros: boolean; begin if Filer.Ancestor <> nil then Result := not FMacros.IsEqual(TCustomDASQL(Filer.Ancestor).FMacros) else Result := FMacros.Count > 0; end; begin inherited DefineProperties(Filer); Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, WriteParams); Filer.DefineProperty('MacroData', ReadMacroData, WriteMacroData, WriteMacros); end; procedure TCustomDASQL.ReadParamData(Reader: TReader); begin Reader.ReadValue; Reader.ReadCollection(FParams); end; procedure TCustomDASQL.WriteParamData(Writer: TWriter); begin Writer.WriteCollection(FParams); end; procedure TCustomDASQL.ReadMacroData(Reader: TReader); begin Reader.ReadValue; Reader.ReadCollection(FMacros); end; procedure TCustomDASQL.WriteMacroData(Writer: TWriter); begin Writer.WriteCollection(FMacros); end; function TCustomDASQL.FindParam(const Value: string): TDAParam; begin Result := FParams.FindParam(Value); end; function TCustomDASQL.ParamByName(const Value: string): TDAParam; begin Result := FParams.ParamByName(Value); end; function TCustomDASQL.FindMacro(const Value: string): TMacro; begin Result := FMacros.FindMacro(Value); end; function TCustomDASQL.MacroByName(const Value: string): TMacro; begin Result := FMacros.MacroByName(Value); end; procedure TCustomDASQL.AssignTo(Dest: TPersistent); begin if Dest is TCustomDASQL then begin TCustomDASQL(Dest).Connection := Connection; TCustomDASQL(Dest).ParamCheck := ParamCheck; // before SQL TCustomDASQL(Dest).SQL.Text := SQL.Text; TCustomDASQL(Dest).Macros.Assign(Macros); TCustomDASQL(Dest).Params.Assign(Params); TCustomDASQL(Dest).Debug := Debug; TCustomDASQL(Dest).AutoCommit := AutoCommit; end else inherited; end; procedure TCustomDASQL.SetConnection(Value: TCustomDAConnection); begin if (Value <> FConnection) or (Value <> UsedConnection) then begin if UsedConnection <> nil then begin Disconnect; UsedConnection.UnregisterClient(Self); end; FConnection := Value; if FConnection <> nil then begin Value.RegisterClient(Self, ConnectChange); CheckICommand; FICommand.SetConnection(FConnection.FIConnection) end else FICommand.SetConnection(nil); end; end; procedure TCustomDASQL.SetSQL(Value: TStrings); begin if FSQL.Text <> Value.Text then begin FSQL.BeginUpdate; try FSQL.Assign(Value); finally FSQL.EndUpdate; end; end; end; procedure TCustomDASQL.SQLChanged(Sender: TObject); var Cmd: TCRCommand; begin //if not (csReading in ComponentState) then begin if FDataSet = nil then UnPrepare else begin if not BaseSQLOldBehavior then FDataSet.FBaseSQL := ''; FDataSet.Close; FDataSet.UnPrepare; FDataSet.FieldDefs.Updated := False; if FDataSet.Data is TCRRecordSet then begin Cmd := TCRRecordSet(FDataSet.Data).GetCommand; if Cmd <> nil then Cmd.SetCursorState(csInactive); TCRRecordSet(FDataSet.Data).CommandType := ctUnknown; end; FDataSet.FOldTableName := ''; FDataSet.FOldKeyFields := ''; end; if not FLockMacros then ScanMacros; if not FLockAssembleSQL then AssembleSQL else FICommand.SetSQL(FSQL.Text); end; function TCustomDASQL.GetPrepared: boolean; begin Result := FICommand.GetPrepared; end; procedure TCustomDASQL.SetPrepared(Value: boolean); begin if Value then Prepare else UnPrepare; end; procedure TCustomDASQL.SetParams(Value: TDAParams); begin FParams.AssignValues(Value); end; function TCustomDASQL.GetParamCount: word; begin Result := FParams.Count; end; procedure TCustomDASQL.SetParamCheck(Value: boolean); begin FParamCheck := Value; Value := Value or (csDesigning in ComponentState); // set value of ScanParams FICommand.SetProp(prScanParams, Value); if Value then AssembleSQL; end; function TCustomDASQL.GetParamValues(ParamName: string): variant; begin Result := FParams.ParamValues[ParamName]; end; procedure TCustomDASQL.SetParamValues(ParamName: string; Value: variant); begin FParams.ParamValues[ParamName] := Value; end; procedure TCustomDASQL.SetMacros(Value: TMacros); begin FMacros.Assign(Value); end; function TCustomDASQL.GetMacroCount: word; begin Result := FMacros.Count; end; procedure TCustomDASQL.SetAutoCommit(Value: boolean); begin FAutoCommit := Value; Assert(FICommand <> nil); FICommand.SetProp(prAutoCommit, FAutoCommit); end; function TCustomDASQL.GetRowsAffected: integer; var Value: variant; begin FICommand.GetProp(prRowsProcessed, Value); Result := Value; end; { TCustomDAUpdateSQL } constructor TCustomDAUpdateSQL.Create(Owner: TComponent); var UpdateKind: TUpdateKind; begin inherited; for UpdateKind := Low(TUpdateKind) to High(TUpdateKind) do FSQLText[UpdateKindToStatementType(UpdateKind)] := TStringList.Create; FSQLText[stRefresh] := TStringList.Create; end; destructor TCustomDAUpdateSQL.Destroy; var StatementType: TStatementType; begin if Assigned(FDataSet) and (FDataSet.UpdateObject = Self) then FDataSet.UpdateObject := nil; for StatementType := Low(TStatementType) to High(TStatementType) do FSQLText[StatementType].Free; inherited; end; procedure TCustomDAUpdateSQL.ExecSQL(UpdateKind: TUpdateKind); var StatementType: TStatementType; begin StatementType := UpdateKindToStatementType(UpdateKind); FDataSet.PerformSQL(FSQLText[StatementType].Text, [StatementType]); end; function TCustomDAUpdateSQL.GetSQL(UpdateKind: TUpdateKind): TStrings; begin Result := GetSQLIndex(Ord(UpdateKindToStatementType(UpdateKind))); end; procedure TCustomDAUpdateSQL.SetSQL(UpdateKind: TUpdateKind; Value: TStrings); begin SetSQLIndex(Ord(UpdateKindToStatementType(UpdateKind)), Value); end; function TCustomDAUpdateSQL.GetSQLIndex(Index: integer): TStrings; begin Result := FSQLText[TStatementType(Index)]; end; procedure TCustomDAUpdateSQL.SetSQLIndex(Index: integer; Value: TStrings); begin FSQLText[TStatementType(Index)].Assign(Value); end; function TCustomDAUpdateSQL.GetDataSet: TCustomDADataSet; begin Result := FDataSet; end; procedure TCustomDAUpdateSQL.SetDataSet(DataSet: TCustomDADataSet); begin FDataSet := DataSet; end; procedure TCustomDAUpdateSQL.SetObjectIndex(Index: integer; Value: TComponent); begin CheckUpdateComponent(Value); FUpdateObject[TStatementType(Index)] := Value; end; function TCustomDAUpdateSQL.GetObjectIndex(Index: integer): TComponent; begin Result := FUpdateObject[TStatementType(Index)]; end; function TCustomDAUpdateSQL.DataSetClass: TCustomDADataSetClass; begin Result := TCustomDADataSet; end; function TCustomDAUpdateSQL.SQLClass: TCustomDASQLClass; begin Result := TCustomDASQL; end; procedure TCustomDAUpdateSQL.CheckUpdateComponent(Component: TComponent; NewDataset: TCustomDADataset); begin if Component <> nil then begin if not ((Component is SQLClass) or (Component is DataSetClass)) then raise Exception.Create(Format(SUpdateComponentInvalidType, [DataSetClass.ClassName, SQLClass.ClassName])); if NewDataSet = Component then raise Exception.Create(SUpdateComponentCircularReferences); end; end; procedure TCustomDAUpdateSQL.CheckUpdateComponent(Component: TComponent); begin CheckUpdateComponent(Component, FDataset); end; procedure TCustomDAUpdateSQL.Notification(AComponent: TComponent; Operation: TOperation); var stIdx: TStatementType; begin inherited; if Operation = opRemove then for stIdx := Low(FUpdateObject) to High(FUpdateObject) do if FUpdateObject[stIdx] = AComponent then FUpdateObject[stIdx] := nil; end; procedure TCustomDAUpdateSQL.Apply(UpdateKind: TUpdateKind); begin ExecSQL(UpdateKind); end; procedure TCustomDAUpdateSQL.Loaded; begin inherited; FDesignCreate := False; end; procedure TCustomDAUpdateSQL.AssignTo(Dest: TPersistent); begin if Dest is TCustomDAUpdateSQL then begin TCustomDAUpdateSQL(Dest).RefreshSQL := RefreshSQL; TCustomDAUpdateSQL(Dest).ModifySQL := ModifySQL; TCustomDAUpdateSQL(Dest).InsertSQL := InsertSQL; TCustomDAUpdateSQL(Dest).DeleteSQL := DeleteSQL; TCustomDAUpdateSQL(Dest).DataSet := DataSet; TCustomDAUpdateSQL(Dest).RefreshObject := RefreshObject; TCustomDAUpdateSQL(Dest).ModifyObject := ModifyObject; TCustomDAUpdateSQL(Dest).InsertObject := InsertObject; TCustomDAUpdateSQL(Dest).DeleteObject := DeleteObject; end else inherited; end; { TMacro } constructor TMacro.Create(Collection: TCollection); begin inherited; FActive := True; end; procedure TMacro.AssignTo(Dest: TPersistent); begin if Dest is TMacro then begin TMacro(Dest).Name := Name; TMacro(Dest).Value := Value; TMacro(Dest).Active := Active; end else inherited; end; function TMacro.IsEqual(Value: TMacro): boolean; begin Result := (Name = Value.Name) and (Self.Value = Value.Value) and (Active = Value.Active); end; function TMacro.GetDisplayName: string; begin if FName = '' then Result := inherited GetDisplayName else Result := FName; end; procedure TMacro.SetValue(Value: string); var Owner: TPersistent; OldBaseSQL: string; begin if Value <> FValue then begin FValue := Value; Owner := TMacros(Collection).FOwner; if (TMacros(Collection).UpdateCount = 0) and (Owner <> nil) then if Owner is TCustomDADataSet then with TCustomDADataSet(Owner) do begin if not Active or (Pos(MacroChar + Self.Name, SQL.Text) <> 0) then begin OldBaseSQL := FBaseSQL; FCommand.SQLChanged(Self); FBaseSQL := OldBaseSQL; end; end else TCustomDASQL(Owner).SQLChanged(Self); end; end; function TMacro.GetAsDateTime: TDateTime; var St: string; iStart: integer; iEnd: integer; Len: integer; begin St := Trim(FValue); Len := Length(FValue); if (Len > 0) and (St[1] = '''') then iStart := 2 else iStart := 1; if (Len > 0) and (St[Length(St)] = '''') then iEnd := Length(St) - 1 else iEnd := Length(St); Result := StrToDateTime(Copy(St, iStart, iEnd - iStart + 1)); end; procedure TMacro.SetAsDateTime(Value: TDateTime); begin Self.Value := '''' + DateTimeToStr(Value) + ''''; end; function TMacro.GetAsFloat: double; begin Result := StrToFloat(FValue); end; procedure TMacro.SetAsFloat(Value: double); begin Self.Value := FloatToStr(Value); end; function TMacro.GetAsInteger: integer; begin Result := StrToInt(FValue); end; procedure TMacro.SetAsInteger(Value: integer); begin Self.Value := IntToStr(Value); end; function TMacro.GetAsString: string; var St: string; iStart: integer; iEnd: integer; Len: integer; begin St := Trim(FValue); Len := Length(FValue); if (Len > 0) and (St[1] = '''') then iStart := 2 else iStart := 1; if (Len > 0) and (St[Length(St)] = '''') then iEnd := Length(St) - 1 else iEnd := Length(St); Result := Copy(St, iStart, iEnd - iStart + 1); end; procedure TMacro.SetAsString(Value: string); begin Self.Value := '''' + Value + ''''; end; procedure TMacro.SetActive(Value: boolean); var Owner: TPersistent; begin if Value <> FActive then begin FActive := Value; Owner := TMacros(Collection).FOwner; if (TMacros(Collection).UpdateCount = 0) and (Owner <> nil) then if Owner is TCustomDADataSet then with TCustomDADataSet(Owner) do begin if not Active or (Pos(MacroChar + Self.Name, SQL.Text) <> 0) then AssembleSQL; end else TCustomDASQL(Owner).AssembleSQL end; end; { TMacros } constructor TMacros.Create(Owner: TPersistent); begin inherited Create(TMacro); FOwner := Owner; FParserClass := TParser; end; procedure TMacros.Scan(SQL: string); var Macro: TMacro; NewMacros: TMacros; Parser: TParser; CodeLexem: integer; St, St2: string; MacroSt: string; // Delphi problem with compare MacroChar = St Changed, NeedNext: boolean; i: integer; begin // performance reason {$IFDEF CLR} if SQL.IndexOf(Char(MacroChar)) = -1 then begin {$ELSE} if StrScan(PChar(SQL), MacroChar) = nil then begin {$ENDIF} Clear; Exit; end; NewMacros := TMacros.Create(nil); NewMacros.BeginUpdate; Parser := FParserClass.Create(SQL); MacroSt := MacroChar; Parser.OmitBlank := False; Parser.Uppered := False; try Parser.ToBegin; repeat repeat CodeLexem := Parser.GetNext(St); //+++ char instead of string until (CodeLexem = lcEnd) or (St = MacroSt); repeat NeedNext := True; if (St = MacroSt) and Parser.IsMacroAllowed(CodeLexem) then begin CodeLexem := Parser.GetNext(St); if (CodeLexem = lcIdent) or Parser.IsNumericMacroNameAllowed and (CodeLexem = lcNumber) or (CodeLexem > Parser.SymbolLexems.Count) and (CodeLexem <= Parser.SymbolLexems.Count + Parser.KeywordLexems.Count) // SQL reserved words are allowed then begin St2 := St; if CodeLexem = lcNumber then begin CodeLexem := Parser.GetNext(St); if (CodeLexem = lcIdent) or (CodeLexem > Parser.SymbolLexems.Count) and (CodeLexem <= Parser.SymbolLexems.Count + Parser.KeywordLexems.Count) then St2 := St2 + St else NeedNext := False end; Macro := NewMacros.FindMacro(St2); if Macro = nil then begin Macro := TMacro(NewMacros.Add); if FindMacro(St2) <> nil then Macro.Assign(FindMacro(St2)) else Macro.Name := St2; end; end; end; until NeedNext; until CodeLexem = lcEnd; if Count <> NewMacros.Count then Changed := True else begin Changed := False; for i := 0 to Count - 1 do if not Items[i].IsEqual(NewMacros.Items[i]) then begin Changed := True; Break; end; end; if Changed then Assign(NewMacros); finally Parser.Free; NewMacros.Free; end; end; function TMacros.GetMacroValue(Macro: TMacro): string; begin if Macro.Active then Result := Macro.Value else Result := ''; end; procedure TMacros.Expand(var SQL: string); var Parser: TParser; CodeLexem: integer; Macro: TMacro; St, St2: string; MacroSt: string; // Delphi problem with compare MacroChar = St Result: string; NeedNext: boolean; begin Parser := FParserClass.Create(SQL); MacroSt := MacroChar; Parser.OmitBlank := False; Parser.Uppered := False; Parser.QuotedString := True; try Result := ''; St := ''; NeedNext := True; CodeLexem := 0; // to prevent warning Parser.ToBegin; while True do begin if NeedNext then CodeLexem := Parser.GetNext(St); if CodeLexem = lcEnd then Break; NeedNext := True; if (St = MacroSt) and Parser.IsMacroAllowed(CodeLexem) then begin CodeLexem := Parser.GetNext(St); if (CodeLexem = lcIdent) or Parser.IsNumericMacroNameAllowed and (CodeLexem = lcNumber) or (CodeLexem > Parser.SymbolLexems.Count) and (CodeLexem <= Parser.SymbolLexems.Count + Parser.KeywordLexems.Count) // SQL reserved words is allowed then begin St2 := St; if CodeLexem = lcNumber then begin CodeLexem := Parser.GetNext(St); if (CodeLexem = lcIdent) or (CodeLexem > Parser.SymbolLexems.Count) and (CodeLexem <= Parser.SymbolLexems.Count + Parser.KeywordLexems.Count) then St2 := St2 + St else NeedNext := False end; Macro := FindMacro(St2); if Macro <> nil then Result := Result + GetMacroValue(Macro); end else Result := Result + MacroSt + St; end else Result := Result + St; end; finally Parser.Free; end; SQL:= Result; end; procedure TMacros.AssignTo(Dest: TPersistent); begin if Dest is TMacros then TMacros(Dest).Assign(Self) else inherited AssignTo(Dest); end; procedure TMacros.AssignValues(Value: TMacros); var i: integer; Macro: TMacro; begin for i := 0 to Value.Count - 1 do begin Macro := FindMacro(Value[i].Name); if Macro <> nil then Macro.Assign(Value[i]); end; end; procedure TMacros.DefineProperties(Filer: TFiler); begin Filer.DefineBinaryProperty('Data', ReadBinaryData, nil, False); end; function TMacros.IsEqual(Value: TMacros): boolean; var i: integer; begin Result := True; if Self = Value then Exit; if Count = Value.Count then begin for i := 0 to Count - 1 do if (Items[i].Name <> Value[i].Name) or (Items[i].Value <> Value[i].Value) or (Items[i].Active <> Value[i].Active) then Result := False; end else Result := False; end; { Structure of Data Version 1 (100) -- !!! Add in 100 ItemCount 1 NameLength 1 Name Length(Name) ValueLength 2 Value Length(Value) Active 1 -- !!! Add in 100 } procedure TMacros.ReadBinaryData(Stream: TStream); const BufLen = 1000; var i, Len: word; Version: byte; B: boolean; Buf: TBytes; St: string; begin SetLength(Buf, BufLen + 1{??? - array [0..BufLen] of byte}); with Stream do begin ReadBuffer(Version, 1); // Version or Count if Version = 100 then begin Len := 0; ReadBuffer(Len, 1); end; for i := 0 to Count - 1 do begin Len := 0; ReadBuffer(Len, 1); if Len > BufLen then Len := BufLen; ReadBuffer(Buf{$IFNDEF CLR}[0]{$ENDIF}, Len); Buf[Len] := 0; St := Encoding.Default.GetString(Buf, 0, Len); with MacroByName(St) do begin ReadBuffer(Len, 2); if Len > BufLen then Len := BufLen; ReadBuffer(Buf{$IFNDEF CLR}[0]{$ENDIF}, Len); Buf[Len] := 0; St := Encoding.Default.GetString(Buf, 0, Len); Value := St; if Version = 100 then begin ReadBuffer(B, 1); // Active Active := B; end; end; end; end; end; function TMacros.GetOwner: TPersistent; begin Result := FOwner; end; procedure TMacros.Update(Item: TCollectionItem); begin inherited; if FOwner <> nil then if FOwner is TCustomDADataSet then TCustomDADataSet(FOwner).AssembleSQL else TCustomDASQL(FOwner).AssembleSQL end; function TMacros.GetItem(Index: integer): TMacro; begin Result := TMacro(inherited Items[Index]); end; procedure TMacros.SetItem(Index: integer; Value: TMacro); begin inherited SetItem(Index, TCollectionItem(Value)); end; function TMacros.GetUpdateCount: integer; begin Result := inherited UpdateCount; end; function TMacros.FindMacro(const Value: string): TMacro; var i: integer; begin for i := 0 to Count - 1 do begin Result := TMacro(inherited Items[i]); if AnsiCompareText(Result.Name, Value) = 0 then Exit; end; Result := nil; end; function TMacros.MacroByName(const Value: string): TMacro; begin Result := FindMacro(Value); if Result = nil then DatabaseErrorFmt(SMacroNotFound, [Value], FOwner as TComponent); end; procedure TMacros.SetParserClass(Value: TParserClass); begin FParserClass := Value; end; { TCustomConnectDialog } constructor TCustomConnectDialog.Create(Owner: TComponent); begin inherited; FRetries := 3; LabelSet := lsEnglish; FStoreLogInfo := True; end; procedure TCustomConnectDialog.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (Operation = opRemove) and (FConnection = AComponent) then FConnection := nil; end; function TCustomConnectDialog.DefDialogClass: TClass; begin Result := nil; end; procedure TCustomConnectDialog.GetServerList(List: TStrings); begin end; function TCustomConnectDialog.GetKeyPath: string; begin Result := ''; end; function TCustomConnectDialog.GetServerStoreName: string; begin Result := 'Server'; end; {$IFDEF MSWINDOWS} procedure TCustomConnectDialog.SaveInfoToRegistry(Registry: TRegistry); begin Registry.WriteString('Username', Connection.Username); Registry.WriteString(GetServerStoreName, Connection.Server); end; procedure TCustomConnectDialog.LoadInfoFromRegistry(Registry: TRegistry); var ServerKey: string; begin ServerKey := GetServerStoreName; if Registry.ValueExists('Username') then Connection.FUsername := Registry.ReadString('Username'); if Registry.ValueExists(ServerKey) then Connection.FServer := Registry.ReadString(ServerKey); end; {$ENDIF} {class function TCustomConnectDialog.AcceptBlankPassword: boolean; begin Result := False; end;} function TCustomConnectDialog.Execute: boolean; var Key: string; OldUsername, OldPassword, OldServer: string; {$IFDEF MSWINDOWS} KeyOpened, IDE: boolean; Registry: TRegistry; procedure SaveServerListToRegistry; var List: TStrings; i,j: integer; begin List := TStringList.Create; try GetServerList(List); Registry.WriteString(Format('%s %d', [ServerLabel, 1]), Connection.Server); i := 2; for j := 0 to List.Count - 1 do if AnsiCompareText(List[j], Connection.Server) <> 0 then begin Registry.WriteString(Format('%s %d', [ServerLabel, i]), List[j]); Inc(i); end; finally List.Free; end; end; {$ENDIF} begin Result := False; if Connection = nil then DatabaseError(SConnectionNotDefined); OldUsername := Connection.Username; OldPassword := Connection.Password; OldServer := Connection.Server; Key := GetKeyPath + 'Connect\' + ApplicationTitle; {$IFDEF MSWINDOWS} Registry := nil; {$ENDIF} try if FStoreLogInfo then begin {$IFDEF MSWINDOWS} Registry := TRegistry.Create; KeyOpened := Registry.OpenKey(Key, False); IDE := (Pos('Delphi', ApplicationTitle) = 1) or (Pos('C++Builder', ApplicationTitle) = 1); if KeyOpened and (not IDE or (Connection.Username = '')) then LoadInfoFromRegistry(Registry); if not SavePassword and not IDE or (AnsiCompareText(Connection.Username, OldUsername) <> 0) then Connection.FPassword := ''; if KeyOpened then Registry.CloseKey; {$ENDIF} end; if Assigned(ShowConnectFormProc) then Result := ShowConnectFormProc(Self) else Result := False; if Result then begin if FStoreLogInfo then begin {$IFDEF MSWINDOWS} // StoreLogInfo can be changed by user since previous check if Registry = nil then Registry := TRegistry.Create; if Registry.OpenKey(Key, True) then begin SaveInfoToRegistry(Registry); Registry.CloseKey; end; if Registry.OpenKey(GetKeyPath + 'Connect', False) then begin SaveServerListToRegistry; Registry.CloseKey; end; {$ENDIF} end; end; finally if not Result then begin Connection.FUsername := OldUsername; Connection.FPassword := OldPassword; Connection.FServer := OldServer; end; {$IFDEF MSWINDOWS} Registry.Free; {$ENDIF} end; end; {$IFDEF WIN32} function TCustomConnectDialog.GetString(Id: integer): string; const BufLen = 50; var Buf: array [0..BufLen] of char; Base: integer; begin case FLabelSet of lsEnglish: Base := 100; lsFrench: Base := 200; lsGerman: Base := 300; lsItalian: Base := 400; lsPolish: Base := 500; lsPortuguese: Base := 600; lsRussian: Base := 0; lsSpanish: Base := 700; else Base := 100; end; Buf[0] := #0; LoadString(hInstance, Id + Base, @Buf, BufLen); Result := Buf; end; {$ENDIF} procedure TCustomConnectDialog.SetLabelSet(Value: TLabelSet); {$IFDEF WIN32} begin FLabelSet := Value; if FLabelSet <> lsCustom then begin FCaption := GetString(0); FUsernameLabel := GetString(1); FPasswordLabel := GetString(2); FServerLabel := GetString(3); FConnectButton := GetString(4); FCancelButton := GetString(5); end; {$ELSE} begin FCaption := 'Connect'; FUsernameLabel := 'Username'; FPasswordLabel := 'Password'; FServerLabel := 'Server'; FConnectButton := 'Connect'; FCancelButton := 'Cancel'; {$ENDIF} end; procedure TCustomConnectDialog.SetCaption(Value: string); begin if not(csLoading in ComponentState) then FLabelSet := lsCustom; FCaption := Value; end; procedure TCustomConnectDialog.SetUsernameLabel(Value: string); begin if not(csLoading in ComponentState) then FLabelSet := lsCustom; FUsernameLabel := Value; end; procedure TCustomConnectDialog.SetPasswordLabel(Value: string); begin if not(csLoading in ComponentState) then FLabelSet := lsCustom; FPasswordLabel := Value; end; procedure TCustomConnectDialog.SetServerLabel(Value: string); begin if not(csLoading in ComponentState) then FLabelSet := lsCustom; FServerLabel := Value; end; procedure TCustomConnectDialog.SetConnectButton(Value: string); begin if not(csLoading in ComponentState) then FLabelSet := lsCustom; FConnectButton := Value; end; procedure TCustomConnectDialog.SetCancelButton(Value: string); begin if not(csLoading in ComponentState) then FLabelSet := lsCustom; FCancelButton := Value; end; {$IFDEF MSWINDOWS} const advapi32 = 'advapi32.dll'; netapi32 = 'netapi32.dll'; // Service State -- for CurrentState SERVICE_STOPPED = $00000001; SERVICE_START_PENDING = $00000002; SERVICE_STOP_PENDING = $00000003; SERVICE_RUNNING = $00000004; SERVICE_CONTINUE_PENDING = $00000005; SERVICE_PAUSE_PENDING = $00000006; SERVICE_PAUSED = $00000007; // Service object specific access type SERVICE_QUERY_CONFIG = $0001; SERVICE_CHANGE_CONFIG = $0002; SERVICE_QUERY_STATUS = $0004; SERVICE_ENUMERATE_DEPENDENTS = $0008; SERVICE_START = $0010; SERVICE_STOP = $0020; SERVICE_PAUSE_CONTINUE = $0040; SERVICE_INTERROGATE = $0080; SERVICE_USER_DEFINED_CONTROL = $0100; SERVICE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED or SERVICE_QUERY_CONFIG or SERVICE_CHANGE_CONFIG or SERVICE_QUERY_STATUS or SERVICE_ENUMERATE_DEPENDENTS or SERVICE_START or SERVICE_STOP or SERVICE_PAUSE_CONTINUE or SERVICE_INTERROGATE or SERVICE_USER_DEFINED_CONTROL); // Service Control Manager object specific access types SC_MANAGER_CONNECT = $0001; SC_MANAGER_CREATE_SERVICE = $0002; SC_MANAGER_ENUMERATE_SERVICE = $0004; SC_MANAGER_LOCK = $0008; SC_MANAGER_QUERY_LOCK_STATUS = $0010; SC_MANAGER_MODIFY_BOOT_CONFIG = $0020; SC_MANAGER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED or SC_MANAGER_CONNECT or SC_MANAGER_CREATE_SERVICE or SC_MANAGER_ENUMERATE_SERVICE or SC_MANAGER_LOCK or SC_MANAGER_QUERY_LOCK_STATUS or SC_MANAGER_MODIFY_BOOT_CONFIG); // Service Types SERVICE_WIN32_OWN_PROCESS = $00000010; SERVICE_WIN32_SHARE_PROCESS = $00000020; SERVICE_WIN32 = (SERVICE_WIN32_OWN_PROCESS or SERVICE_WIN32_SHARE_PROCESS); // Service State -- for Enum Requests (Bit Mask) SERVICE_ACTIVE = $00000001; SERVICE_INACTIVE = $00000002; SERVICE_STATE_ALL = (SERVICE_ACTIVE or SERVICE_INACTIVE); // Controls SERVICE_CONTROL_STOP = $00000001; type // Service Status Enumeration Structure {$IFDEF CLR} [StructLayout(LayoutKind.Sequential)] {$ENDIF} _SERVICE_STATUS = record dwServiceType: DWORD; dwCurrentState: DWORD; dwControlsAccepted: DWORD; dwWin32ExitCode: DWORD; dwServiceSpecificExitCode: DWORD; dwCheckPoint: DWORD; dwWaitHint: DWORD; end; TServiceStatus = _SERVICE_STATUS; {$IFDEF CLR} [StructLayout(LayoutKind.Sequential, CharSet = CharSet.Auto)] _ENUM_SERVICE_STATUS = record [MarshalAs(UnmanagedType.LPTStr)] lpServiceName: string; [MarshalAs(UnmanagedType.LPTStr)] lpDisplayName: string; ServiceStatus: TServiceStatus; end; TEnumServiceStatus = _ENUM_SERVICE_STATUS; {$ELSE} _ENUM_SERVICE_STATUSA = record lpServiceName: PAnsiChar; lpDisplayName: PAnsiChar; ServiceStatus: TServiceStatus; end; TEnumServiceStatus = _ENUM_SERVICE_STATUSA; {$ENDIF} TOpenSCManager = function (lpMachineName: {$IFDEF CLR}string{$ELSE}PChar{$ENDIF}; lpDatabaseName: {$IFDEF CLR}IntPtr{$ELSE}PChar{$ENDIF}; dwDesiredAccess: DWORD): SC_HANDLE;{$IFNDEF CLR} stdcall;{$ENDIF} TCloseServiceHandle = function (hSCObject: SC_HANDLE): BOOL;{$IFNDEF CLR} stdcall;{$ENDIF} TOpenService = function (hSCManager: SC_HANDLE; lpServiceName: PChar; dwDesiredAccess: DWORD): SC_HANDLE;{$IFNDEF CLR} stdcall;{$ENDIF} TEnumServicesStatus = function (hSCManager: SC_HANDLE; dwServiceType, dwServiceState: DWORD;{$IFDEF CLR}lpServices: IntPtr{$ELSE}var lpServices: TEnumServiceStatus{$ENDIF}; cbBufSize: DWORD; {$IFDEF CLR}out{$ELSE}var{$ENDIF} pcbBytesNeeded, lpServicesReturned: DWORD; var lpResumeHandle: DWORD): BOOL;{$IFNDEF CLR} stdcall;{$ENDIF} TQueryServiceStatus = function (hService: SC_HANDLE; {$IFDEF CLR}out{$ELSE}var{$ENDIF} lpServiceStatus: TServiceStatus): BOOL;{$IFNDEF CLR} stdcall;{$ENDIF} TStartService = function (hService: SC_HANDLE; dwNumServiceArgs: DWORD; {$IFNDEF CLR}var{$ENDIF} lpServiceArgVectors: {$IFDEF CLR}IntPtr{$ELSE}PChar{$ENDIF}): BOOL;{$IFNDEF CLR} stdcall;{$ENDIF} TControlService = function (hService: SC_HANDLE; dwControl: DWORD; {$IFDEF CLR}out{$ELSE}var{$ENDIF} lpServiceStatus: TServiceStatus): BOOL;{$IFNDEF CLR} stdcall;{$ENDIF} TNetServerEnum = function (ServerName: IntPtr; Level: longint; var BufPtr: IntPtr; PrefMaxLen: longint; var EntriesRead, TotalEntries: longint; ServType: longint; Domain: {$IFDEF CLR}IntPtr{$ELSE}PWideChar{$ENDIF}; var ResumeHandle: integer): longint;{$IFNDEF CLR} stdcall;{$ENDIF} TNetApiBufferFree = function (BufPtr: IntPtr): longint;{$IFNDEF CLR} stdcall;{$ENDIF} {$IFDEF CLR} [SuppressUnmanagedCodeSecurity, DllImport(advapi32, CharSet = CharSet.Auto, SetLastError = True, EntryPoint = 'OpenSCManager')] function FnOpenSCManager(lpMachineName: string; lpDatabaseName: IntPtr; dwDesiredAccess: DWORD): SC_HANDLE; external; [SuppressUnmanagedCodeSecurity, DllImport(advapi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'CloseServiceHandle')] function FnCloseServiceHandle(hSCObject: SC_HANDLE): BOOL; external; [SuppressUnmanagedCodeSecurity, DllImport(advapi32, CharSet = CharSet.Auto, SetLastError = True, EntryPoint = 'OpenService')] function FnOpenService(hSCManager: SC_HANDLE; lpServiceName: string; dwDesiredAccess: DWORD): SC_HANDLE; external; [SuppressUnmanagedCodeSecurity, DllImport(advapi32, CharSet = CharSet.Auto, SetLastError = True, EntryPoint = 'EnumServicesStatus')] function FnEnumServicesStatus(hSCManager: SC_HANDLE; dwServiceType, dwServiceState: DWORD; lpServices: IntPtr; cbBufSize: DWORD; out pcbBytesNeeded, lpServicesReturned: DWORD; var lpResumeHandle: DWORD): BOOL; external; [SuppressUnmanagedCodeSecurity, DllImport(advapi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'QueryServiceStatus')] function FnQueryServiceStatus(hService: SC_HANDLE; out lpServiceStatus: TServiceStatus): BOOL; external; [SuppressUnmanagedCodeSecurity, DllImport(advapi32, CharSet = CharSet.Auto, SetLastError = True, EntryPoint = 'StartService')] function FnStartService(hService: SC_HANDLE; dwNumServiceArgs: DWORD; lpServiceArgVectors: IntPtr): BOOL; external; [SuppressUnmanagedCodeSecurity, DllImport(advapi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'StartServiceA')] function StartServiceA(hService: SC_HANDLE; dwNumServiceArgs: DWORD; lpServiceArgVectors: IntPtr): BOOL; external; [SuppressUnmanagedCodeSecurity, DllImport(advapi32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'ControlService')] function FnControlService(hService: SC_HANDLE; dwControl: DWORD; out lpServiceStatus: TServiceStatus): BOOL; external; [SuppressUnmanagedCodeSecurity, DllImport(netapi32, CharSet = CharSet.Auto, SetLastError = True, EntryPoint = 'NetServerEnum')] function FnNetServerEnum(ServerName: IntPtr; Level: longint; var BufPtr: IntPtr; PrefMaxLen: longint; var EntriesRead, TotalEntries: longint; ServType: longint; Domain: IntPtr; var ResumeHandle: integer): longint; external; [SuppressUnmanagedCodeSecurity, DllImport(netapi32, CharSet = CharSet.Auto, SetLastError = True, EntryPoint = 'NetApiBufferFree')] function FnNetApiBufferFree(BufPtr: IntPtr): longint; external; {$ENDIF} var hAdvapi32Lib: HMODULE; hNetapi32Lib: HMODULE; OpenSCManager: TOpenSCManager; CloseServiceHandle: TCloseServiceHandle; OpenService: TOpenService; EnumServicesStatus: TEnumServicesStatus; QueryServiceStatus: TQueryServiceStatus; StartService: TStartService; ControlService: TControlService; NetServerEnum: TNetServerEnum; NetApiBufferFree: TNetApiBufferFree; function NotLink: integer; begin raise Exception.Create('function is not linked'); Result := 0; end; procedure LoadNetManagerLib; {$IFNDEF CLR} function GetProc(hLib: HMODULE; Name: string): FARPROC; begin Result := GetProcAddress(hLib, PChar(Name)); if Result = nil then Result := @NotLink; end; {$ENDIF} begin hAdvapi32Lib := LoadLibrary(PChar(advapi32)); if hAdvapi32Lib > 0 then begin {$IFDEF CLR} OpenSCManager := FnOpenSCManager; CloseServiceHandle := FnCloseServiceHandle; OpenService := FnOpenService; EnumServicesStatus := FnEnumServicesStatus; QueryServiceStatus := FnQueryServiceStatus; StartService := FnStartService; ControlService := FnControlService; {$ELSE} OpenSCManager := GetProc(hAdvapi32Lib, 'OpenSCManagerA'); CloseServiceHandle := GetProc(hAdvapi32Lib, 'CloseServiceHandle'); OpenService := GetProc(hAdvapi32Lib, 'OpenServiceA'); EnumServicesStatus := GetProc(hAdvapi32Lib, 'EnumServicesStatusA'); QueryServiceStatus := GetProc(hAdvapi32Lib, 'QueryServiceStatus'); StartService := GetProc(hAdvapi32Lib, 'StartServiceA'); ControlService := GetProc(hAdvapi32Lib, 'ControlService'); {$ENDIF} end; hNetapi32Lib := LoadLibrary(PChar(netapi32)); if hNetapi32Lib > 0 then begin {$IFDEF CLR} if GetProcAddress(hNetapi32Lib, 'NetServerEnum') <> nil then NetServerEnum := FnNetServerEnum; if GetProcAddress(hNetapi32Lib, 'NetApiBufferFree') <> nil then NetApiBufferFree := FnNetApiBufferFree; {$ELSE} NetServerEnum := GetProc(hNetapi32Lib, 'NetServerEnum'); NetApiBufferFree := GetProc(hNetapi32Lib, 'NetApiBufferFree'); {$ENDIF} end; end; procedure FreeNetManagerLib; begin if hAdvapi32Lib > 0 then begin FreeLibrary(hAdvapi32Lib); hAdvapi32Lib := 0; end; if hNetapi32Lib > 0 then begin FreeLibrary(hNetapi32Lib); hNetapi32Lib := 0; end; end; { TCRServiceNamesThread } constructor TCRServiceNamesThread.Create(const Server: string; Services: TCRServicesThread; const Keywords: string); begin inherited Create(True); FServer := Server; FKeywords := Keywords; FServices := Services; Priority := tpHighest; Resume; end; procedure TCRServiceNamesThread.Execute; {var tc: cardinal;} var j, k: integer; sl: TStringList; b: boolean; begin // tc := GetTickCount; try FServiceNames := TCRNetManager.GetServiceNames(FServer); sl := TStringList.Create; try sl.Text := FKeywords; b := False; for j := 0 to Length(FServiceNames) - 1 do begin for k := 0 to sl.Count - 1 do if (Pos(sl[k], LowerCase(FServiceNames[j].ServiceName)) > 0) or (Pos(sl[k], LowerCase(FServiceNames[j].DisplayName)) > 0) then begin b := True; CRNetManager.AddToCachedServerList(FKeywords, FServer); Break; end; if b then Break; end; finally sl.Free; end; except // Silent end; {tc := GetTickCount - tc; OFS(FServer + ' ' + IntToStr(tc) + ' ' + IntToStr(Length(FServices.FServiceNames[FIndex])));} end; constructor TCRServicesThread.Create(List: TStrings; const Keywords: string); begin inherited Create(True); FList := List; FKeywords := Keywords; FreeOnTerminate := True; Resume; end; procedure TCRServicesThread.Execute; var i: integer; Threads: array of TCRServiceNamesThread; begin SetLength(Threads, FList.Count); for i := 0 to FList.Count - 1 do Threads[i] := nil; try for i := 0 to FList.Count - 1 do Threads[i] := TCRServiceNamesThread.Create(FList[i], Self, FKeywords); for i := 0 to FList.Count - 1 do Threads[i].WaitFor; finally for i := 0 to FList.Count - 1 do Threads[i].Free; end; end; { TCRNetManager } function ServiceStatusToCurrentStatus(const CurrentState: DWORD): TCRServiceStatus; begin case CurrentState of SERVICE_STOPPED: Result := ssStopped; SERVICE_START_PENDING: Result := ssStartPending; SERVICE_STOP_PENDING: Result := ssStopPending; SERVICE_RUNNING: Result := ssRunning; SERVICE_CONTINUE_PENDING: Result := ssContinuePending; SERVICE_PAUSE_PENDING: Result := ssPausePending; SERVICE_PAUSED: Result := ssPaused; else begin DatabaseErrorFmt('Unknown service status $%X (%d)', [CurrentState, CurrentState]); Result := ssStopped; end; end; end; constructor TCRNetManager.Create; begin inherited; FServicesCS := TCriticalSection.Create; end; destructor TCRNetManager.Destroy; begin ClearCachedServerList; FServicesCS.Free; inherited; end; class procedure TCRNetManager.ServiceManagerOpen(const Server: string; const ReadOnly: boolean; out sch: SC_HANDLE); var s: string; dwDesiredAccess: DWORD; begin sch := 0; if Trim(LowerCase(Server)) = 'localhost' then s := '' else s := Server; if ReadOnly then dwDesiredAccess := GENERIC_READ else dwDesiredAccess := SC_MANAGER_ALL_ACCESS; sch := OpenSCManager({$IFDEF CLR}s{$ELSE}PChar(s){$ENDIF}, nil, dwDesiredAccess); Win32Check(sch <> 0); end; class procedure TCRNetManager.ServiceManagerClose(const sch: SC_HANDLE); begin if sch <> 0 then CloseServiceHandle(sch); end; class procedure TCRNetManager.ServiceOpen(const Server: string; const ServiceName: string; const ReadOnly: boolean; out sch: SC_HANDLE; out sh: SC_HANDLE); begin ServiceManagerOpen(Server, ReadOnly, sch); try sh := OpenService(sch, {$IFDEF CLR}ServiceName{$ELSE}PChar(ServiceName){$ENDIF}, SERVICE_ALL_ACCESS); Win32Check(sh <> 0); except ServiceManagerClose(sch); raise; end; end; class procedure TCRNetManager.ServiceClose(const sch: SC_HANDLE; const sh: SC_HANDLE); begin if sh <> 0 then CloseServiceHandle(sh); ServiceManagerClose(sch); end; class function TCRNetManager.GetServiceNames(const Server: string): TCRServicesInfo; var sch: SC_HANDLE; {$IFDEF CLR} pService: TEnumServiceStatus; {$ELSE} pService: ^TEnumServiceStatus; {$ENDIF} pServices: IntPtr; pcbBytesNeeded, lpServicesReturned, lpResumeHandle: DWORD; i: integer; SizeOfTEnumServiceStatus: LongWord; begin SetLength(Result, 0); pServices := nil; ServiceManagerOpen(Server, True, sch); try //lpServices := nil; lpResumeHandle := 0; pcbBytesNeeded := 0; lpServicesReturned := 0; EnumServicesStatus(sch, SERVICE_WIN32, SERVICE_STATE_ALL, {$IFDEF CLR}nil{$ELSE}TEnumServiceStatus(pServices^){$ENDIF}, 0, pcbBytesNeeded, lpServicesReturned, lpResumeHandle); SizeOfTEnumServiceStatus := SizeOf(TEnumServiceStatus); lpServicesReturned := 0; pServices := Marshal.AllocHGlobal(pcbBytesNeeded); Win32Check(EnumServicesStatus(sch, SERVICE_WIN32, SERVICE_STATE_ALL, {$IFDEF CLR}pServices{$ELSE}TEnumServiceStatus(pServices^){$ENDIF}, pcbBytesNeeded, pcbBytesNeeded, lpServicesReturned, lpResumeHandle)); // Win32Check(EnumServicesStatus(sch, SERVICE_WIN32, SERVICE_STATE_ALL, Services{$IFNDEF CLR}[0]{$ENDIF}, cbBufSize, pcbBytesNeeded, lpServicesReturned, lpResumeHandle)); SetLength(Result, lpServicesReturned); for i := 0 to lpServicesReturned - 1 do begin {$IFDEF CLR} pService := TEnumServiceStatus(Marshal.PtrToStructure(IntPtr(Integer(pServices) + Integer(SizeOfTEnumServiceStatus) * i), TypeOf(TEnumServiceStatus))); {$ELSE} pService := IntPtr(Integer(pServices) + Integer(SizeOfTEnumServiceStatus) * i); {$ENDIF} Result[i].ServiceName := pService.lpServiceName; Result[i].DisplayName := pService.lpDisplayName; Result[i].Status := ServiceStatusToCurrentStatus(pService.ServiceStatus.dwCurrentState); end; finally ServiceManagerClose(sch); Marshal.FreeHGlobal(pServices); end; end; class function TCRNetManager.GetServiceStatus(const Server: string; const ServiceName: string): TCRServiceStatus; var sch: SC_HANDLE; sh: SC_HANDLE; ss: TServiceStatus; begin ServiceOpen(Server, ServiceName, True, sch, sh); try Win32Check(QueryServiceStatus(sh, ss)); Result := ServiceStatusToCurrentStatus(ss.dwCurrentState); finally ServiceClose(sch, sh); end; end; class procedure TCRNetManager.ServiceStart(const Server: string; const ServiceName: string; ParamStr: string = ''); // based on Delphi7 system.pas GetParamStr function function GetParamStr(Idx: integer; var Param: string): integer; var Len: Integer; StartIdx, SIdx, QIdx: Integer; begin while True do begin while (ParamStr[Idx] <> #0) and (ParamStr[Idx] <= ' ') do Inc(Idx); if (ParamStr[Idx] = '"') and (ParamStr[Idx + 1] = '"') then Inc(Idx, 2) else Break; end; Len := 0; StartIdx := Idx; while ParamStr[Idx] > ' ' do begin if ParamStr[Idx] = '"' then begin Inc(Idx); while (ParamStr[Idx] <> #0) and (ParamStr[Idx] <> '"') do begin QIdx := Idx + 1; Inc(Len, QIdx - Idx); Idx := QIdx; end; if ParamStr[Idx] <> #0 then Inc(Idx); end else begin QIdx := Idx + 1; Inc(Len, QIdx - Idx); Idx := QIdx; end; end; SetLength(Param, Len); Idx := StartIdx; SIdx := 1; while ParamStr[Idx] > ' ' do begin if ParamStr[Idx] = '"' then begin Inc(Idx); while (ParamStr[Idx] <> #0) and (ParamStr[Idx] <> '"') do begin QIdx := Idx + 1; while Idx < QIdx do begin Param[SIdx] := ParamStr[Idx]; Inc(Idx); Inc(SIdx); end; end; if ParamStr[Idx] <> #0 then Inc(Idx); end else begin QIdx := Idx + 1; while Idx < QIdx do begin Param[SIdx] := ParamStr[Idx]; Inc(Idx); Inc(SIdx); end; end; end; Result := Idx; end; var sch: SC_HANDLE; sh: SC_HANDLE; i, Idx: integer; Param: string; Args: array of string; pArgs: array of {$IFDEF CLR}IntPtr{$ELSE}PChar{$ENDIF}; p: {$IFDEF CLR}IntPtr{$ELSE}PChar{$ENDIF}; {$IFDEF CLR} b: TBytes; p1: IntPtr; Len: integer; {$ENDIF} begin ServiceOpen(Server, ServiceName, False, sch, sh); try ParamStr := Trim(ParamStr); if ParamStr <> '' then begin Idx := 1; SetLength(Args, 0); ParamStr := ParamStr + #0; while True do begin Idx := GetParamStr(Idx, Param); if Param = '' then Break; i := Length(Args); SetLength(Args, i + 1); Args[i] := Param; end; SetLength(pArgs, Length(Args)); {$IFDEF CLR} for i := 0 to Length(Args) - 1 do pArgs[i] := nil; p := Marshal.AllocHGlobal(Length(Args) * SizeOf(IntPtr)); try for i := 0 to Length(Args) - 1 do begin Len := Length(Args[i]); SetLength(b, Len + 1); Encoding.Default.GetBytes(Args[i], 0, Len, b, 0); b[Len] := 0; p1 := Marshal.AllocHGlobal(Len + 1); Marshal.Copy(b, 0, p1, Len + 1); pArgs[i] := p1; Marshal.WriteIntPtr(p, i * SizeOf(IntPtr), p1); end; i := Length(Args); Win32Check(StartServiceA(sh, i, p)); finally for i := 0 to Length(Args) - 1 do Marshal.FreeHGlobal(pArgs[i]); Marshal.FreeHGlobal(p); end; {$ELSE} for i := 0 to Length(Args) - 1 do pArgs[i] := @Args[i][1]; i := Length(Args); Win32Check(StartService(sh, i, pArgs[0])); {$ENDIF} end else begin p := nil; Win32Check(StartService(sh, 0, p)); end; finally ServiceClose(sch, sh); end; end; class procedure TCRNetManager.ServiceStop(const Server: string; const ServiceName: string); var sch: SC_HANDLE; sh: SC_HANDLE; ss: TServiceStatus; begin ServiceOpen(Server, ServiceName, False, sch, sh); try Win32Check(ControlService(sh, SERVICE_CONTROL_STOP, ss)); finally ServiceClose(sch, sh); end; end; procedure TCRNetManager.ClearCachedServerList; var i: integer; begin if FCachedServerList = nil then Exit; try for i := 0 to FCachedServerList.Count - 1 do FCachedServerList.Objects[i].Free; finally FreeAndNil(FCachedServerList); end; end; procedure TCRNetManager.AddToCachedServerList(const Keywords: string; const Server: string); var // s: string; i: integer; sl: TStringList; begin { s := ''; for i := Low(Keywords) to High(Keywords) do begin if s <> '' then s := s + #$D#$A; s := s + Keywords[i]; end;} FServicesCS.Acquire; try if FCachedServerList = nil then begin FCachedServerList := TStringList.Create; {$IFDEF VER6P} FCachedServerList.CaseSensitive := False; {$ENDIF} FCachedServerList.Sorted := True; end; i := FCachedServerList.IndexOf(Keywords); if i = - 1 then begin sl := TStringList.Create; {$IFDEF VER6P} sl.CaseSensitive := False; {$ENDIF} sl.Sorted := True; FCachedServerList.AddObject(Keywords, sl); end else sl := FCachedServerList.Objects[i] as TStringList; if sl.IndexOf(Server) = -1 then sl.Add(Server); finally FServicesCS.Release; end; end; class procedure TCRNetManager.GetServerList(List: TStrings); var pData, psvr_Name: IntPtr; EntRead, EntTotal, Resume, i : integer; s: string; Info : integer; begin List.Clear; pData := nil; try Resume := 0; Info := NetServerEnum(nil, 100, pData, -1{MAX_PREFERRED_LENGTH}, EntRead, EntTotal, 1{SV_TYPE_WORKSTATION - All LAN Manager workstations}, nil, Resume); if Info <> 0 then raise Exception.Create('NetServerEnum error ' + IntToStr(Info)); Assert(pData <> nil); for i := 0 to EntRead - 1 do begin psvr_Name := Marshal.ReadIntPtr(pData, i * 8 {sizeof(SERVER_INFO_100 )} + 4); s := Marshal.PtrToStringUni(psvr_Name); List.Add(s); end; finally if pData <> nil then NetApiBufferFree(pData); end; end; procedure TCRNetManager.GetServerList(List: TStrings; const Keywords: string; const Timeout: Longword = 1; const CacheTimeout: Longword = 120); var mList, sl: TStringList; i: integer; tc: LongWord; Threads: TCRServicesThread; {$IFDEF CLR} ReturnValue: LongWord; {$ENDIF} begin List.Clear; if Timeout = 0 then Exit; StartWait; mList := nil; try mList := TStringList.Create; {$IFDEF VER6P} mList.CaseSensitive := False; {$ENDIF} mList.Sorted := True; tc := LongWord(Int64(FLastTickCount) + CacheTimeout * 1000); if (tc < GetTickCount) or (GetTickCount < FLastTickCount) then begin GetServerList(mList); mList.Add('localhost'); Threads := TCRServicesThread.Create(mList, Keywords); {$IFDEF CLR} Threads.WaitFor(Timeout * 1000, ReturnValue); {$ELSE} WaitForSingleObject(Threads.Handle, Timeout * 1000); {$ENDIF} FLastTickCount := GetTickCount; end; if FCachedServerList <> nil then begin mList.Clear; FServicesCS.Acquire; try i := FCachedServerList.IndexOf(Keywords); if i <> -1 then begin sl := FCachedServerList.Objects[i] as TStringList; for i := 0 to sl.Count - 1 do begin if mList.IndexOf(sl[i]) = -1 then mList.Add(sl[i]); end; end; finally FServicesCS.Release; end; end; List.Assign(mList); finally StopWait; mList.Free; end; end; {$ENDIF} { TDADataSetUtils } procedure TDADataSetUtils.QuickOpen(DataSet: TCustomDADataSet; Refresh: boolean = False); begin Inc(FCount); if FCount > 1 then begin Assert(FDataSet = DataSet); Exit; end; Assert(FDataSet = nil, 'TDADataSetUtils.QuickOpen - twice call'); FDataSet := DataSet; FOldActive := DataSet.Active; FOldDebug := DataSet.Debug; FOldFetchAll := DataSet.FetchAll; FOldFetchRows := DataSet.FetchRows; if not DataSet.Active or Refresh then begin DataSet.Debug := False; DataSet.FetchAll := False; DataSet.Close; DataSet.FetchRows := 1; DataSet.Execute; end; end; procedure TDADataSetUtils.Restore(RestoreActive: boolean = True); begin Assert(FDataSet <> nil, 'TDADataSetUtils.Restore without QuickOpen'); Dec(FCount); if FCount > 0 then Exit; FDataSet.Debug := FOldDebug; FDataSet.FetchAll := FOldFetchAll; if RestoreActive then begin if FDataSet.FetchRows <> FOldFetchRows then begin FDataSet.Active := False; FDataSet.FetchRows := FOldFetchRows; end; FDataSet.Active := FOldActive; end; FDataSet := nil; end; procedure TDADataSetUtils.QuickOpenAndRestore(DataSet: TCustomDADataSet; Refresh: boolean = False); begin try QuickOpen(DataSet, Refresh); finally Restore; end; end; { TDBAccessUtils } class function TDBAccessUtils.IsKeyViolation(Obj: TCustomDAConnection; E: EDAError): boolean; begin Result := Obj.IsKeyViolation(E); end; class function TDBAccessUtils.IsObjectDataType(Obj: TDAParam; DataType: TFieldType): boolean; begin Result := Obj.IsObjectDataType(DataType); end; class procedure TDBAccessUtils.CheckConnection(Obj: TCustomDADataSet); begin Obj.CheckConnection; end; class procedure TDBAccessUtils.CheckConnection(Obj: TCustomDASQL); begin Obj.CheckConnection; end; class function TDBAccessUtils.UsedConnection(Obj: TCustomDADataSet): TCustomDAConnection; begin Result := Obj.UsedConnection; end; class function TDBAccessUtils.UsedConnection(Obj: TCustomDASQL): TCustomDAConnection; begin Result := Obj.UsedConnection; end; class procedure TDBAccessUtils.SetAutoCommit(Obj: TComponent; Value: boolean); begin Assert(Obj <> nil); if Obj is TCustomDASQL then TCustomDASQL(Obj).AutoCommit := Value else if IsClass(Obj, TCustomDADataSet) then TCustomDADataSet(Obj).AutoCommit := Value else Assert(False, Obj.ClassName); end; class function TDBAccessUtils.GetAutoCommit(Obj: TComponent): boolean; begin Result := False; Assert(Obj <> nil); if Obj is TCustomDASQL then Result := TCustomDASQL(Obj).AutoCommit else if Obj is TCustomDADataSet then Result := TCustomDADataSet(Obj).AutoCommit else Assert(False, Obj.ClassName); end; class procedure TDBAccessUtils.SetDesignCreate(Obj: TCustomDADataSet; Value: boolean); begin Obj.FDesignCreate := Value; end; class function TDBAccessUtils.GetDesignCreate(Obj: TCustomDADataSet): boolean; begin Result := Obj.FDesignCreate; end; class procedure TDBAccessUtils.SetDesignCreate(Obj: TCustomDASQL; Value: boolean); begin Obj.FDesignCreate := Value; end; class function TDBAccessUtils.GetDesignCreate(Obj: TCustomDASQL): boolean; begin Result := Obj.FDesignCreate; end; class procedure TDBAccessUtils.SetDesignCreate(Obj: TCustomDAUpdateSQL; Value: boolean); begin Obj.FDesignCreate := Value; end; class function TDBAccessUtils.GetDesignCreate(Obj: TCustomDAUpdateSQL): boolean; begin Result := Obj.FDesignCreate; end; class procedure TDBAccessUtils.SetDesignCreate(Obj: TCRDataSource; Value: boolean); begin Obj.FDesignCreate := Value; end; class function TDBAccessUtils.GetDesignCreate(Obj: TCRDataSource): boolean; begin Result := Obj.FDesignCreate; end; class function TDBAccessUtils.CreateIRecordSet(Obj: TCustomDAConnection): TCRRecordSet; begin Result := Obj.CreateIRecordSet; end; class function TDBAccessUtils.GetIConnection(Obj: TCustomDAConnection): TCRConnection; begin Result := Obj.FIConnection; end; class function TDBAccessUtils.GetUpdateQuery(Obj: TCustomDADataSet): TComponent; begin Result := Obj.FUpdateQuery; end; class function TDBAccessUtils.GetTablesInfo(Obj: TCustomDADataSet): TCRTablesInfo; begin Result := Obj.TablesInfo; end; class function TDBAccessUtils.GetUpdatingTable(Obj: TCustomDADataSet): string; begin Result := Obj.UpdatingTable; end; class procedure TDBAccessUtils.SetUpdatingTable(Obj: TCustomDADataSet; Value: string); begin Obj.UpdatingTable := Value; end; class function TDBAccessUtils.GetUpdatingTableIdx(Obj: TCustomDADataSet): integer; begin Result := Obj.FUpdatingTableInfoIdx; end; class procedure TDBAccessUtils.SetUpdatingTableIdx(Obj: TCustomDADataSet; Value: integer); begin Obj.FUpdatingTableInfoIdx := Value; end; class procedure TDBAccessUtils.InternalConnect(Obj: TCustomDAConnection); begin Assert(Obj <> nil); Obj.InternalConnect; end; class procedure TDBAccessUtils.InternalDisconnect(Obj: TCustomDAConnection); begin Assert(Obj <> nil); Obj.InternalDisconnect; end; class procedure TDBAccessUtils.SuppressAutoCommit(Obj: TCustomDAConnection); begin Obj.SuppressAutoCommit; end; class procedure TDBAccessUtils.RestoreAutoCommit(Obj: TCustomDAConnection); begin Obj.RestoreAutoCommit; end; class procedure TDBAccessUtils.Disconnect(Obj: TCustomDASQL); begin Obj.Disconnect; end; class function TDBAccessUtils.SQLGenerator(Obj: TCustomDADataSet): TDASQLGenerator; begin Result := Obj.FSQLGenerator; end; class procedure TDBAccessUtils.GetKeyAndDataFields( Obj: TCustomDADataSet; out KeyAndDataFields: TKeyAndDataFields; const ForceUseAllKeyFields: boolean); begin Obj.GetKeyAndDataFields(KeyAndDataFields, ForceUseAllKeyFields); end; class function TDBAccessUtils.GetLockDebug(Obj: TComponent): boolean; begin if Obj is TCustomDADataSet then Result := TCustomDADataSet(Obj).FLockDebug else if Obj is TCustomDASQL then Result := TCustomDASQL(Obj).FLockDebug else begin Result := False; Assert(False, 'Obj is ' + Obj.ClassName); end; end; class procedure TDBAccessUtils.SetLockDebug(Obj: TComponent; Value: boolean); begin if IsClass(Obj, TCustomDADataSet) then TCustomDADataSet(Obj).FLockDebug := Value else if IsClass(Obj, TCustomDASQL) then TCustomDASQL(Obj).FLockDebug := Value else Assert(False, 'Obj is ' + Obj.ClassName); end; class function TDBAccessUtils.FOwner(Obj: TDAConnectionOptions): TCustomDAConnection; begin Result := Obj.FOwner; end; class function TDBAccessUtils.FOwner(Obj: TDADataSetOptions): TCustomDADataSet; begin Result := Obj.FOwner; end; class function TDBAccessUtils.SQLMonitorClass(Obj: TCustomDAConnection): TClass; begin Result := Obj.SQLMonitorClass; end; class function TDBAccessUtils.QuoteName(Obj: TCustomDADataSet; const AName: string): string; begin Result := Obj.QuoteName(AName); end; class function TDBAccessUtils.UnQuoteName(Obj: TCustomDADataSet; AName: string): string; begin Result := Obj.UnQuoteName(AName); end; class function TDBAccessUtils.GetSQLs(Obj: TCustomDAConnection): TDAList; begin Result := Obj.FSQLs; end; class procedure TDBAccessUtils.RegisterClient(Obj: TCustomDAConnection; Client: TObject; Event: TConnectChangeEvent = nil); begin Obj.RegisterClient(Client, Event); end; class procedure TDBAccessUtils.UnRegisterClient(Obj: TCustomDAConnection; Client: TObject); begin Obj.UnRegisterClient(Client); end; class function TDBAccessUtils.GetIdentityField(Obj: TCustomDADataSet): TField; begin Result := Obj.FIdentityField; end; class function TDBAccessUtils.GetSQL(Obj: TComponent): TStrings; begin Result := nil; Assert(Obj <> nil); if IsClass(Obj, TCustomDASQL) then Result := TCustomDASQL(Obj).SQL else if IsClass(Obj, TCustomDADataSet) then Result := TCustomDADataSet(Obj).SQL else Assert(False, Obj.ClassName); end; class procedure TDBAccessUtils.SetSQL(Obj: TComponent; Value: TStrings); begin Assert(Obj <> nil); if Obj is TCustomDASQL then TCustomDASQL(Obj).SQL := Value else if Obj is TCustomDADataSet then TCustomDADataSet(Obj).SQL := Value else Assert(False, Obj.ClassName); end; class procedure TDBAccessUtils.SetSQLText(Obj: TComponent; const SQLText: string; const LockAssembleSQL, LockMacros: boolean; const DisableScanParams: boolean = True); begin Assert(Obj <> nil); if IsClass(Obj, TCustomDASQL) then try TCustomDASQL(Obj).FLockMacros := LockMacros; TCustomDASQL(Obj).FLockAssembleSQL := LockAssembleSQL; TCustomDASQL(Obj).FICommand.SetProp(prDisableParamScan, Variant(True)); TCustomDASQL(Obj).SQL.Text := SQLText; finally TCustomDASQL(Obj).FLockMacros := False; TCustomDASQL(Obj).FLockAssembleSQL := False; TCustomDASQL(Obj).FICommand.SetProp(prDisableParamScan, Variant(False)); end else if IsClass(Obj, TCustomDADataSet) then try TCustomDADataSet(Obj).FCommand.FLockMacros := LockMacros; TCustomDADataSet(Obj).FCommand.FLockAssembleSQL := LockAssembleSQL; TCustomDADataSet(Obj).FCommand.FICommand.SetProp(prDisableParamScan, Variant(DisableScanParams)); TCustomDADataSet(Obj).SQL.Text := SQLText; finally TCustomDADataSet(Obj).FCommand.FLockMacros := False; TCustomDADataSet(Obj).FCommand.FLockAssembleSQL := False; TCustomDADataSet(Obj).FCommand.FICommand.SetProp(prDisableParamScan, Variant(False)); end else Assert(False, Obj.ClassName); end; class function TDBAccessUtils.GetParams(Obj: TComponent): TDAParams; begin Result := nil; Assert(Obj <> nil); if IsClass(Obj, TCustomDASQL) then Result := TCustomDASQL(Obj).Params else if IsClass(Obj, TCustomDADataSet) then Result := TCustomDADataSet(Obj).Params else Assert(False, Obj.ClassName); end; class procedure TDBAccessUtils.Execute(Obj: TComponent); begin Assert(Obj <> nil); if IsClass(Obj, TCustomDASQL) then TCustomDASQL(Obj).Execute else if IsClass(Obj, TCustomDADataSet) then TCustomDADataSet(Obj).Execute else Assert(False, Obj.ClassName); end; class procedure TDBAccessUtils.Open(Obj: TComponent); begin Assert(Obj <> nil); Assert(Obj is TCustomDADataSet); TCustomDADataSet(Obj).Open; end; class function TDBAccessUtils.GetRowsAffected(Obj: TComponent): integer; begin Result := 0; Assert(Obj <> nil); if IsClass(Obj, TCustomDASQL) then Result := TCustomDASQL(Obj).RowsAffected else if IsClass(Obj, TCustomDADataSet) then Result := TCustomDADataSet(Obj).RowsAffected else Assert(False, Obj.ClassName); end; class function TDBAccessUtils.GetUpdateSQLStatementTypes(Obj: TCustomDADataSet): TStatementTypes; begin Result := Obj.GetUpdateSQLStatementTypes; end; class function TDBAccessUtils.GetUpdateSQLIndex(Obj: TCustomDADataSet; StatementType: TStatementType): TStrings; begin Result := nil; if Assigned(Obj.UpdateObject) then if Obj.UpdateObject.GetObjectIndex(Ord(StatementType)) = nil then Result := Obj.UpdateObject.GetSQLIndex(Ord(StatementType)) else Exit; if Result = nil then Result := Obj.GetUpdateSQLIndex(Ord(StatementType)); end; class function TDBAccessUtils.ParseSQL(Obj: TCustomDASQL; const SQL: string; Params: TDAParams; RenamePrefix: string = ''): string; begin Result := Obj.ParseSQL(SQL, Params, RenamePrefix); end; class function TDBAccessUtils.CreateParamsObject(Obj: TCustomDASQL): TDAParams; begin Result := Obj.CreateParamsObject; end; class procedure TDBAccessUtils.SetDesigning(Obj: TComponent; Value: Boolean; SetChildren: Boolean = True); begin if Obj is TCustomDADataSet then TCustomDADataSet(Obj).SetDesigning(Value, SetChildren) else if Obj is TCustomDASQL then TCustomDASQL(Obj).SetDesigning(Value, SetChildren) else Assert(False, Obj.ClassName); end; class function TDBAccessUtils.GetIRecordSet(Obj: TCustomDADataSet): TCRRecordSet; begin Result := Obj.FIRecordSet; end; class function TDBAccessUtils.GetDataSetClass(Obj: TCustomDAUpdateSQL): TCustomDADataSetClass; begin Result := Obj.DataSetClass; end; class function TDBAccessUtils.GetSQLClass(Obj: TCustomDAUpdateSQL): TCustomDASQLClass; begin Result := Obj.SQLClass; end; class function TDBAccessUtils.GetParserClass(Obj: TMacros): TParserClass; begin Result := Obj.FParserClass; end; { TCRDataSource } constructor TCRDataSource.Create(Owner: TComponent); begin inherited Create(Owner); FDesignCreate := csDesigning in ComponentState; end; procedure TCRDataSource.Loaded; begin inherited; FDesignCreate := False; end; procedure TCRDataSource.AssignTo(Dest: TPersistent); begin if Dest is TDataSource then begin TDataSource(Dest).DataSet := DataSet; TDataSource(Dest).AutoEdit := AutoEdit; TDataSource(Dest).Enabled := Enabled; end else inherited; end; initialization ChangeCursor := True; MacroChar := '&'; SetCursorProc := nil; ShowConnectFormProc := nil; BaseSQLOldBehavior := False; SQLGeneratorCompatibility := False; {$IFDEF MSWINDOWS} {$IFNDEF CLR} OpenSCManager := @NotLink; CloseServiceHandle := @NotLink; OpenService := @NotLink; EnumServicesStatus := @NotLink; QueryServiceStatus := @NotLink; StartService := @NotLink; ControlService := @NotLink; NetServerEnum := @NotLink; NetApiBufferFree := @NotLink; {$ENDIF} LoadNetManagerLib; CRNetManager := TCRNetManager.Create; {$ENDIF} finalization {$IFDEF MSWINDOWS} CRNetManager.Free; FreeNetManagerLib; {$ENDIF} end.