david
fff1b2a4dc
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.SDAC@3 6f543ec7-021b-7e4c-98c9-62eafc7fb9a8
11172 lines
325 KiB
ObjectPascal
11172 lines
325 KiB
ObjectPascal
|
|
//////////////////////////////////////////////////
|
|
// 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.
|