{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: DB Projects | } { | | } { | Description: Base Database functionality not dependend | } { | on BorlandDB Units, not even on classes. | } { | | } { | Copyright (C) - 2001 - Gerrit Moeller. | } { | | } { | Source code distributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMSql; interface uses {$IFNDEF JEDIAPI}Windows,{$ELSE}jwaWinType,{$ENDIF} GMStrDef, GMCommon, GMIntf, GMCollections, GMUnionValue, GMActiveX, GMPrsStg, SysUtils; type TExploreConnectionFlag = (efDoExecute, efShowSchema); TExploreConnectionFlags = set of TExploreConnectionFlag; TGMSqlStatementKind = (skUnknown, skSelect, skExecute, skInsert, skUpdate, skDelete, skDDL, skSetting); TGMSchemaList = (slTables, slProcedures, slColumns, slProcedureColumns, slStatistics, slPrimaryKeys, slForeignKeys, slTablePrivileges, slColumnPrivileges, slTypeInfo, slUnknown); //TGMSchemaRootList = slTables .. slStatistics; //TGMSchemaRootLists = set of TGMSchemaRootList; TGMSchemaLists = set of TGMSchemaList; TGMDBColumnDataType = (fdtUnknown, fdtBoolean, fdtInt8, fdtUInt8, fdtInt16, fdtUInt16, fdtInt32, fdtUInt32, fdtInt64, fdtUInt64, fdtSingle, fdtDouble, fdtNumeric, fdtDate, fdtTime, fdtDateTime, fdtAnsiString, fdtUnicodeString, fdtAnsiText, fdtUnicodeText, fdtBinary, fdtGUID); TGMAllowNullValues = (nvNullValuesNotAllowed, nvNullValuesAllowed, nvNullableUnknown); const cSqlWhiteSpace = cWhiteSpace; cSqlOperators = '=<>!*+-/'; cSqlSeparators = ',;()' + cSqlWhiteSpace; cSqlParamPrefixChar = ':'; cCnStrEntrySep = ';'; cCnStrValSep = '='; cSqlFrom = 'FROM'; cSqlLeft = 'LEFT'; cSqlRight = 'RIGHT'; cSqlInner = 'INNER'; cSqlOuter = 'OUTER'; cSqlJoin = 'JOIN'; cSqlOn = 'ON'; cSqlWhere = 'WHERE'; cSqlGroupBy = 'GROUP BY'; cSqlHaving = 'HAVING'; cSqlOrderBy = 'ORDER BY'; cSqlParameters = 'PARAMETERS'; cSqlForUpdateOf = 'FOR UPDATE OF'; cSqlSet = 'SET'; cSqlInto = 'INTO'; cSqlValues = 'VALUES'; cSqlSelect = 'SELECT'; cSqlInsert = 'INSERT'; cSqlUpdate = 'UPDATE'; cSqlDelete = 'DELETE'; cSqlExecute = 'EXECUTE'; cSqlCreate = 'CREATE'; cSqlAlter = 'ALTER'; cSqlDrop = 'DROP'; cSqlAsc = 'ASC'; cSqlDesc = 'DESC'; cSqlAscending = 'ASCENDING'; cSqlDescending = 'DESCENDING'; cStrAnd = 'AND'; cStrOr = 'OR'; cStrEqual = '='; cSqlWildcardChar = '%'; CAccessWildcardChar = '*'; cSqlStrQuoteChar = ''''; cAccessDateQuoteChar = '#'; //CFieldNameLeftQuote = '['; //CFieldNameRightQuote = ']'; //CFieldNameQuotes = CFieldNameLeftQuote + CFieldNameRightQuote; cSQLStmtTerm = ';'; cFieldListSeparators = ',;'; cSqlParamMarker = '?'; cSqlQualSep = '.'; cSqlPartSep = cNewLine; cSqlCountAll = 'Count(*)'; cSqlIdQuoteCh = '"'; cSqlSelectAllFmt = cSqlSelect + ' * ' + cSqlFrom + ' %s'; cSqlSelectCountFmt = cSqlSelect + ' ' + cSqlCountAll + ' ' + cSqlFrom + ' %s'; //cSqlAggregatFunctions: array [0..4] of TGMString = ('min', 'max', 'avg', 'count', 'sum'); cStrTGMRecordsetState = 'TGMRecordsetState'; cDfltFieldDisplayWidth = 50; cMaxFieldDisplayWidth = 180; cMinFieldDisplayWidth = 20; CUnknownFieldDisplayWidth = -1; cInvalidColumnPos = -1; cDfltReExecutionDelay = 300; cAvgCharWidth = 10; CBookmarkColPos = 0; cDfltReExecAfterParamValChange = True; cDfltReExecuteAfterSQLChange = False; cDfltTreeNotify = True; cDfltAutoActivate = True; cDfltColumnSeparator = ';'; // #9; cDfltRowSeparator = #13#10; cStrCnStrDriver = 'DRIVER'; cStrCnStrDSN = 'DSN'; cStrCnStrUserName = 'UID'; cStrCnStrPassword = 'PWD'; cStrCnStrDatabase = 'DATABASE'; cStrCnStrFileDSN = 'FILEDSN'; cStrCnStrDBQ = 'DBQ'; cStrCnStrSaveFile = 'SAVEFILE'; cStrCnDir = 'DIR'; cStrCnDefaultDir = 'DEFAULTDIR'; cStrTableKindTable = 'TABLE'; cStrNil = '<nil>'; cDfltSchemaList = slTables; //cDfltSchemaLists = [slTables]; cReExecuteAfterPropertyValueChange = True; cDfltExploreConnectionFlags = [efShowSchema]; cIntegerFieldDataTypes: set of TGMDBColumnDataType = [fdtInt8, fdtUInt8, fdtInt16, fdtUInt16, fdtInt32, fdtUInt32, fdtInt64, fdtUInt64]; cSignedIntFieldDataTypes: set of TGMDBColumnDataType = [fdtInt8, fdtInt16, fdtInt32, fdtInt64]; cStreamedFieldDataTypes: set of TGMDBColumnDataType = [fdtAnsiText, fdtUnicodeText, fdtBinary]; cMemoFieldDataTypes: set of TGMDBColumnDataType = [fdtAnsiText, fdtUnicodeText]; cStringFieldDataTypes: set of TGMDBColumnDataType = [fdtAnsiString, fdtUnicodeString]; cQuotedFieldDataTypes: set of TGMDBColumnDataType = [fdtAnsiText, fdtUnicodeText, fdtAnsiString, fdtUnicodeString]; cDateTimeDataTypes: set of TGMDBColumnDataType = [fdtDate, fdtTime, fdtDateTime]; cVariableLengthDataTypes: set of TGMDBColumnDataType = [fdtAnsiString, fdtUnicodeString, fdtAnsiText, fdtUnicodeText, fdtBinary]; //cStrSelectedPositions = 'SelectedPositions'; cStrSQL = 'SQL'; // <- used for SQL property of TGMSqlStatementBase type TAccessMode = (amReadWrite, amReadOnly); TGMCursorType = (ctUnidirectional, ctStatic, ctKeyset, ctDynamic); TGMRecordsetState = (rsInactive, rsBrowsing, rsInserting, rsEditing); TGMRecordsetOperation = roEdit .. roSetSimplestConfiguration; TGMRecordsetAttribute = (raAutoSaveChanges, raAutoEdit, raConfrimDeletions, raExposeBookmarkColumn, raBookmarksEnabled, raStripTrailingBlanks); TGMRecordsetAttributes = set of TGMRecordsetAttribute; TConnectionStrCompareKind = (cnpExactMatch, cnpLazyMatch); TValueArray = array of RGMUnionValue; RGMFieldCreateData = record Name: TGMString; Position: PtrInt; DataType: TGMDBColumnDataType; AllowNullValues: TGMAllowNullValues; Updatable: Boolean; IsSigned: Boolean; IsAutoincrementing: Boolean; // BlobCompressionType: Integer; // TGMCompressionType; SizeInBytes: PtrInt; // <- must match datatype of ODBC functions! MaxStrLength: PtrUInt; // <- must match datatype of ODBC functions! end; TGMSqlStmtVisitFunc = function(const ASqlStatement: TGMString; const AOpaqueAppData: Pointer = nil): Boolean of object; IGMGetMasterSource = interface(IUnknown) ['{C70F6863-3F6D-4371-BFD7-29F73401C989}'] function GetMasterSource: IUnknown; property MasterSource: IUnknown read GetMasterSource; end; IGMGetSetMasterSource = interface(IGMGetMasterSource) ['{34F5D167-51E2-4F08-9B8D-ACCEC6262AA6}'] procedure SetMasterSource(const AValue: IUnknown); property MasterSource: IUnknown read GetMasterSource write SetMasterSource; end; IGMSqlSyntaxElements = interface(IUnknown) ['{89C93C0F-A433-4818-95D5-C54A95585833}'] function SqlIdentifierQuoteChar: TGMString; function SqlDateTimeFormatStr: TGMString; end; PGMQualifiedDBName = ^RGMQualifiedDBName; RGMQualifiedDBName = record CatalogName: TGMString; SchemaName: TGMString; TableName: TGMString; function QualifiedName(const ASeparator: TGMString = '.'): TGMString; function CompareTo(const AOtherQName: RGMQualifiedDBName): TGMCompareResult; end; TGMQualifiedDBNameArray = Array of RGMQualifiedDBName; function GMInitRQualifiedDBName(const AElementName: TGMString; const ACatalogName: TGMString = ''; const ASchemaName: TGMString = ''): RGMQualifiedDBName; function GMBuildQualifiedDBName(const AElementName: TGMString; const ACatalogName: TGMString = ''; const ASchemaName: TGMString = ''; const ASeparator: TGMString = '.'): TGMString; function GMCompareQualifiedDBName(const AQNameA, AQNameB: RGMQualifiedDBName): TGMCompareResult; function GMSplitSqlQualifiedName(const AQualifiedName: TGMString; const ASeparatorChar: TGMChar = '.'): RGMQualifiedDBName; { -------------------- } { ---- Recordsets ---- } { -------------------- } type IGMGetFieldName = interface(IUnknown) ['{A4650FA2-2522-11d5-AB38-000021DCAD19}'] function GetFieldName: TGMString; property FieldName: TGMString read GetFieldName; end; IGMGetSetFieldName = interface(IGMGetFieldName) ['{E9FB6119-3353-4e77-A555-DB4F4DB8838A}'] procedure SetFieldName(const Value: TGMString); property FieldName: TGMString read GetFieldName write SetFieldName; end; IGMGetValueDefinition = interface(IUnknown) ['{37239761-153F-11d5-A5E4-00E0987755DD}'] function GetDataType: TGMDBColumnDataType; stdcall; function GetNullValuesAllowed: TGMAllowNullValues; stdcall; function GetUpdatable: Boolean; stdcall; property DataType: TGMDBColumnDataType read GetDataType; property NullValuesAllowed: TGMAllowNullValues read GetNullValuesAllowed; property Updatable: Boolean read GetUpdatable; end; TGMEnumItemKind = (eidTableNames, eidFieldNames, eidKeyFieldNames); IGMNamedValueChange = interface(IUnknown) ['{40B69A62-2819-11d5-AB38-000021DCAD19}'] procedure AfterValueChange(const ValueName: TGMString); end; IGMCascadedContentsProperties = interface(IUnknown) ['{56975886-A8AA-452b-A7C6-4C3AA4AE9C32}'] function GetKeyValueName: TGMString; stdcall; function GetParentReferenceValueName: TGMString; stdcall; function ConfigurationIsValid: Boolean; stdcall; property KeyValueName: TGMString read GetKeyValueName; property ParentReferenceValueName: TGMString read GetParentReferenceValueName; end; TGMSortOrderDirection = (soNone, soAscending, soDescending); TGMAllowDuplicates = (adUnknown, adDuplicatesAllowed, adDuplicatesNotAllowed); IGMGetColumnSortOrder = interface(IUnknown) ['{A975D209-850C-4d39-A030-3C0D8A7CF6E7}'] function GetColumnSortOrder(const ColumnName: TGMString): LongInt; stdcall; end; IGMSetColumnSortOrder = interface(IUnknown) ['{5020ABAB-9EB1-4fd0-8CD5-27A73754F0FA}'] procedure SetColumnSortOrder(const ColumnName: TGMString; const SortOrder: LongInt; const Cumulative, ReExecuteWhenChanged: Boolean); stdcall; end; IGMGetSortColumnName = interface(IUnknown) ['{B3F7B46B-C6E7-47c5-B8E1-64309331CC0C}'] function GetSortColumnName(var ColumnName: TGMString): Boolean; stdcall; end; { ---------------------- } { ---- Transactions ---- } { ---------------------- } IGMTransactions = interface(IUnknown) ['{BD7DDC1B-2F93-4294-8E34-669A17342685}'] function GetTransactionLevel: LongInt; stdcall; procedure BeginTransaction; stdcall; procedure CommitTransaction; stdcall; procedure RollbackTransaction; stdcall; property TransactionLevel: LongInt read GetTransactionLevel; end; TGMSqlParameter = class(TGMRefCountedObj, IGMGetName, IGMGetUnionValue, IGMGetSetUnionValue) protected FOwner: TObject; FName: TGMString; FValue: RGMUnionValue; FIsLiteral: Boolean; // ---- IGMGetName ---- function GetName: TGMString; virtual; stdcall; // ---- IGMGetSetUnionValue ---- function GetUnionValue: RGMUnionValue; virtual; procedure SetUnionValue(const AUnionValue: RGMUnionValue); virtual; public constructor Create(const AOwner: TObject; const AName: TGMString; const AValue: RGMUnionValue; const AIsLiteral: Boolean); reintroduce; procedure AssignValue(const AValue: RGMUnionValue; const AIsLiteral: Boolean); virtual; property Owner: TObject read FOwner; property Name: TGMString read GetName; property Value: RGMUnionValue read GetUnionValue write SetUnionValue; property IsLiteral: Boolean read FIsLiteral write FIsLiteral; end; TGMSqlParameterList = class(TGMRefCountedObj, IGMGetCount, IGMGetIntfByName, IGMGetIntfByPosition, IGMAssignFromObj) protected FOwner: TObject; FReExecuteAfterParamValueChange: Boolean; FParameterList: IGMObjArrayCollection; function GetParameter(const AIndex: RGMUnionValue): TGMSqlParameter; //procedure SetParameter(const Idx: RGMUnionValue; const Value: TGMSqlParameter); // ---- IGMGetCount ---- function GetCount: PtrInt; virtual; stdcall; // ---- IGMGetIntfByName ---- function GetIntfByName(const Name: TGMString; const IID: TGUID; out Intf): HResult; stdcall; // ---- IGMGetIntfByPosition ---- function GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; stdcall; public constructor Create(const AOwner: TObject); reintroduce; //destructor Destroy; override; procedure AssignFromObj(const Source: TObject); stdcall; procedure AssignParamValues(const Source: TObject); virtual; procedure ParseForParameters; virtual; procedure OnParameterValueChanged; virtual; function FindParameterByName(const ParameterName: TGMString; var Parameter: TGMSqlParameter): Boolean; property Count: PtrInt read GetCount; property Owner: TObject read FOwner; property ParameterList: IGMObjArrayCollection read FParameterList; property Parameters[const Idx: RGMUnionValue]: TGMSqlParameter read GetParameter; default;//write SetParameter; //published property ReExecuteAfterParamValueChange: Boolean read FReExecuteAfterParamValueChange write FReExecuteAfterParamValueChange default cDfltReExecAfterParamValChange; end; TDoParseSQLXxxxPropFunc = function: Boolean of object; IGMGetTableName = interface(IUnknown) ['{A8689741-25B6-11d5-AB38-000021DCAD19}'] function GetTablename: TGMString; property Tablename: TGMString read GetTablename; end; IGMGetSetTableName = interface(IGMGetTableName) ['{A8689742-25B6-11d5-AB38-000021DCAD19}'] procedure SetTablename(Value: TGMString); property Tablename: TGMString read GetTablename write SetTablename; end; IGMSQLChangeNotifications = interface(IUnknown) ['{139A2141-26B2-11d5-AB38-000021DCAD19}'] procedure AfterSQLChange; end; IGMExecuteSQL = interface(IUnknown) ['{4C1C3F7F-975C-4508-96DA-3AB1417D955E}'] function ExecuteSQL(const ASQL: TGMString): PtrInt; end; IGMSqlStatementParts = interface(IUnknown) ['{94564601-0E67-11d5-A5E4-00E0987755DD}'] // // Partitions of a SQL Statement. // // The class TGMSQLStatmentPartitioner in unit GMDBBase offers a nice // implementation of this interface. It is capable to be used as aggregate // via compiler implements fetaure by another object. // function GetTableName: TGMString; virtual; procedure SetTableName(Value: TGMString); virtual; function GetSQLSelectedFields: TGMString; virtual; procedure SetSQLSelectedFields(Value: TGMString); virtual; function GetSQLWhere: TGMString; virtual; procedure SetSQLWhere(Value: TGMString); virtual; function GetSQLGroupBy: TGMString; virtual; procedure SetSQLGroupBy(Value: TGMString); virtual; function GetSQLHaving: TGMString; virtual; procedure SetSQLHaving(Value: TGMString); virtual; function GetSQLOrderBy: TGMString; virtual; procedure SetSQLOrderBy(Value: TGMString); virtual; function GetSQLForUpdateOf: TGMString; virtual; procedure SetSQLForUpdateOf(Value: TGMString); virtual; property SQLTableName: TGMString read GetTableName write SetTableName; property SQLSelectedFields: TGMString read GetSQLSelectedFields write SetSQLSelectedFields; property SQLWhere: TGMString read GetSQLWhere write SetSQLWhere; property SQLGroupBy: TGMString read GetSQLGroupBy write SetSQLGroupBy; property SQLHaving: TGMString read GetSQLHaving write SetSQLHaving; property SQLOrderBy: TGMString read GetSQLOrderBy write SetSQLOrderBy; property SQLForUpdateOf: TGMString read GetSQLForUpdateOf write SetSQLForUpdateOf; end; TGMSQLStatmentPartitioner = class(TGMAggregatableObj, IGMGetText, IGMGetSetText, IGMGetTableName, IGMGetSetTableName, IGMSqlStatementParts) protected FGetSQLText: TGMGetStringFunc; FSetSQLText: TGMSetStringProc; FParseSQLXxxxPropFunc: TDoParseSQLXxxxPropFunc; function GetText: TGMString; virtual; stdcall; procedure SetText(const Value: TGMString); virtual; stdcall; function GetTableName: TGMString; virtual; procedure SetTableName(Value: TGMString); virtual; function GetSQLSelectedFields: TGMString; virtual; procedure SetSQLSelectedFields(Value: TGMString); virtual; function GetSQLWhere: TGMString; virtual; procedure SetSQLWhere(Value: TGMString); virtual; function GetSQLGroupBy: TGMString; virtual; procedure SetSQLGroupBy(Value: TGMString); virtual; function GetSQLHaving: TGMString; virtual; procedure SetSQLHaving(Value: TGMString); virtual; function GetSQLOrderBy: TGMString; virtual; procedure SetSQLOrderBy(Value: TGMString); virtual; function GetSQLForUpdateOf: TGMString; virtual; procedure SetSQLForUpdateOf(Value: TGMString); virtual; function ParseForSQLXxxxProperties: Boolean; public constructor Create(const AOwner: IUnknown; const AGetSQLText: TGMGetStringFunc; const ASetSQLText: TGMSetStringProc; const ADoParseSQLXxxxPropFunc: TDoParseSQLXxxxPropFunc = nil; const ARefLifeTime: Boolean = False); reintroduce; property SQLTableName: TGMString read GetTableName write SetTableName; property SQLSelectedFields: TGMString read GetSQLSelectedFields write SetSQLSelectedFields; property SQLWhere: TGMString read GetSQLWhere write SetSQLWhere; property SQLGroupBy: TGMString read GetSQLGroupBy write SetSQLGroupBy; property SQLHaving: TGMString read GetSQLHaving write SetSQLHaving; property SQLOrderBy: TGMString read GetSQLOrderBy write SetSQLOrderBy; property SQLForUpdateOf: TGMString read GetSQLForUpdateOf write SetSQLForUpdateOf; //function TerminateSQL(const SQLText: TGMString): TGMString; virtual; //property SQLStrings: TGMStringArray read FSQLStrings; //write SetSQLStrings; end; TGMSqlProperty = class(TGMRefCountedObj, IGMGetTableName, IGMGetSetTableName, IGMSqlStatementParts, IGMGetText, IGMGetSetText, IGMEnumerateItems, IGMAssignFromObj) protected FOwner: TObject; FSQLText: TGMString; FSQLParser: TGMSQLStatmentPartitioner; FParameterList: TGMSqlParameterList; FOnAfterSQLChange: TGMObjNotifyProc; FReExecuteAfterSQLChange: Boolean; procedure SetParameterList(const AValue: TGMSqlParameterList); function GetSQLText: TGMString; virtual; procedure SetSQLText(const AValue: TGMString); virtual; // Published IDE property Get/Set routines cannot be stdcall! function IDEGetTableName: TGMString; virtual; procedure IDESetTableName(Value: TGMString); virtual; function IDEGetSQLSelectedFields: TGMString; virtual; procedure IDESetSQLSelectedFields(Value: TGMString); virtual; function IDEGetSQLWhere: TGMString; virtual; procedure IDESetSQLWhere(Value: TGMString); virtual; function IDEGetSQLGroupBy: TGMString; virtual; procedure IDESetSQLGroupBy(Value: TGMString); virtual; function IDEGetSQLHaving: TGMString; virtual; procedure IDESetSQLHaving(Value: TGMString); virtual; function IDEGetSQLOrderBy: TGMString; virtual; procedure IDESetSQLOrderBy(Value: TGMString); virtual; function IDEGetSQLForUpdateOf: TGMString; virtual; procedure IDESetSQLForUpdateOf(Value: TGMString); virtual; { ---- IGMEnumerateTableNames ---- } procedure EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer = nil); virtual; stdcall; procedure SQLChanged(const ASender: TObject); virtual; public constructor Create(const AOwner: TObject; const ASqlText: TGMString; const AParseSQLXxxxPropFunc: TDoParseSQLXxxxPropFunc = nil; const ARefLifeTime: Boolean = False); reintroduce; destructor Destroy; override; procedure AssignFromObj(const ASource: TObject); stdcall; function BuildResolvedSQLText: TGMString; virtual; property Owner: TObject read FOwner; property SQLParser: TGMSQLStatmentPartitioner read FSQLParser implements IGMSqlStatementParts, IGMGetTableName, IGMGetSetTableName, IGMGetText, IGMGetSetText; property OnAfterSQLChange: TGMObjNotifyProc read FOnAfterSQLChange write FOnAfterSQLChange; //published property SQLText: TGMString read GetSQLText write SetSQLText; property SQLSelectedFields: TGMString read IDEGetSQLSelectedFields write IDESetSQLSelectedFields; property SQLWhere: TGMString read IDEGetSQLWhere write IDESetSQLWhere stored False; property SQLGroupBy: TGMString read IDEGetSQLGroupBy write IDESetSQLGroupBy stored False; property SQLHaving: TGMString read IDEGetSQLHaving write IDESetSQLHaving stored False; property SQLOrderBy: TGMString read IDEGetSQLOrderBy write IDESetSQLOrderBy stored False; property SQLForUpdateOf: TGMString read IDEGetSQLForUpdateOf write IDESetSQLForUpdateOf stored False; property TableName: TGMString read IDEGetTableName write IDESetTableName stored False; property SQLParameter: TGMSqlParameterList read FParameterList write SetParameterList; property ReExecuteAfterSQLChange: Boolean read FReExecuteAfterSQLChange write FReExecuteAfterSQLChange default cDfltReExecuteAfterSQLChange; end; TGMCascadedContentsProperties = class(TGMRefCountedObj, IGMCascadedContentsProperties, IGMEnumerateItems, IGMAssignFromObj) protected FOwner: TObject; FKeyValueName: TGMString; FParentReferenceValueName: TGMString; { ---- IGMEnumerateItems ---- } procedure EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer = nil); stdcall; { ---- IGMCascadedContentsProperties ---- } function GetKeyValueName: TGMString; virtual; stdcall; function GetParentReferenceValueName: TGMString; virtual; stdcall; public constructor Create(const AOwner: TObject); reintroduce; virtual; procedure AssignFromObj(const Source: TObject); stdcall; function ConfigurationIsValid: Boolean; virtual; stdcall; property Owner: TObject read FOwner; //published property KeyValueName: TGMString read FKeyValueName write FKeyValueName; property ParentReferenceValueName: TGMString read FParentReferenceValueName write FParentReferenceValueName; end; TConnectionStringValue = class(TGMNameAndStrValueObj, IGMLoadStoreData) public procedure LoadData(const ASource: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; procedure StoreData(const ADest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; end; TGMConnectionStringStorage = class; IGMConnectionStringStorage = interface(IUnknown) ['{6419C74F-E585-4C36-BF66-EB9BB18314A7}'] function Obj: TGMConnectionStringStorage; end; TGMConnectionStringStorage = class(TGMRefCountedObj, IGMValueStorage, IGMGetText, IGMContainsValue, IGMLoadStoreData, IGMConnectionStringStorage) protected FValues: IGMIntfArrayCollection; FValueStorage: TGMValueStorageImpl; function GetValueByName(const AValueName: TGMString; const ADefaultValue: TGMString = ''): TGMString; stdcall; procedure SetValueByName(const AValueName, AValue: TGMString); stdcall; public constructor Create(const ARefLifeTime: Boolean = True); overload; override; constructor Create(const AConnectionString: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; function Obj: TGMConnectionStringStorage; procedure ParseConnectionString(const AConnectionString: TGMString); virtual; function ContainsValue(const ValueName: TGMString): Boolean; virtual; stdcall; function GetText: TGMString; virtual; stdcall; procedure LoadData(const ASource: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); virtual; stdcall; procedure StoreData(const ADest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); virtual; stdcall; property Values: IGMIntfArrayCollection read FValues; property ValueStorage: TGMValueStorageImpl read FValueStorage implements IGMValueStorage; property Text: TGMString read GetText; end; IGMSchemaProperties = interface(IUnknown) ['{66ECFFC2-4F49-4542-A56E-C5B081DBA9EB}'] //procedure Reset; procedure SetAll(ASchemaList: TGMSchemaList = cDfltSchemaList; ACatalogName: TGMString = cStrNil; ASchemaName: TGMString = cStrNil; ATableName: TGMString = cSqlWildcardChar; ATableKind: TGMString = cStrNil; // ''; // cStrTableKindTable; AColumnName: TGMString = cSqlWildcardChar; AForeignCatalogName: TGMString = cStrNil; AForeignSchemaName: TGMString = cStrNil; AForeignTableName: TGMString = cSqlWildcardChar); function GetSchemaList: TGMSchemaList; function GetCatalogName: TGMString; function GetSchemaName: TGMString; function GetTableName: TGMString; function GetColumnName: TGMString; function GetTableKind: TGMString; function GetForeignCatalogName: TGMString; function GetForeignSchemaName: TGMString; function GetForeignTableName: TGMString; procedure SetSchemaList(const AValue: TGMSchemaList); procedure SetCatalogName(const AValue: TGMString); procedure SetSchemaName(const AValue: TGMString); procedure SetTableName(const AValue: TGMString); procedure SetColumnName(const AValue: TGMString); procedure SetTableKind(const AValue: TGMString); procedure SetForeignCatalogName(const AValue: TGMString); procedure SetForeignSchemaName(const AValue: TGMString); procedure SetForeignTableName(const AValue: TGMString); property SchemaList: TGMSchemaList read GetSchemaList write SetSchemaList default cDfltSchemaList; property CatalogName: TGMString read GetCatalogName write SetCatalogName; property SchemaName: TGMString read GetSchemaName write SetSchemaName; property TableName: TGMString read GetTableName write SetTableName; property ColumnName: TGMString read GetColumnName write SetColumnName; property TableKind: TGMString read GetTableKind write SetTableKind; property ForeignCatalogName: TGMString read GetForeignCatalogName write SetForeignCatalogName; property ForeignSchemaName: TGMString read GetForeignSchemaName write SetForeignSchemaName; property ForeignTableName: TGMString read GetForeignTableName write SetForeignTableName; end; TGMSchemaProperties = class(TGMAggregatableObj, IGMSchemaProperties, IGMAssignFromObj, IGMGetText) protected FSchemaList: TGMSchemaList; FCatalogName: TGMString; FSchemaName: TGMString; FTableName: TGMString; FColumnName: TGMString; FForeignCatalogName: TGMString; FForeignSchemaName: TGMString; FForeignTableName: TGMString; FTableKind: TGMString; FReExecuteAfterPropertyValueChange: Boolean; FOnAfterSchemaDataChange: TGMObjNotifyProc; procedure AfterPropertyValueChange; virtual; public constructor Create(const ARefLifeTime: Boolean = False); override; overload; function GetText: TGMString; virtual; stdcall; procedure AssignFromObj(const Source: TObject); stdcall; //procedure Reset; procedure SetAll(ASchemaList: TGMSchemaList = cDfltSchemaList; ACatalogName: TGMString = cStrNil; ASchemaName: TGMString = cStrNil; ATableName: TGMString = cSqlWildcardChar; ATableKind: TGMString = cStrNil; // ''; // cStrTableKindTable; AColumnName: TGMString = cSqlWildcardChar; AForeignCatalogName: TGMString = cStrNil; AForeignSchemaName: TGMString = cStrNil; AForeignTableName: TGMString = cSqlWildcardChar); function GetSchemaList: TGMSchemaList; function GetCatalogName: TGMString; function GetSchemaName: TGMString; function GetTableName: TGMString; function GetColumnName: TGMString; function GetTableKind: TGMString; function GetForeignCatalogName: TGMString; function GetForeignSchemaName: TGMString; function GetForeignTableName: TGMString; procedure SetSchemaList(const AValue: TGMSchemaList); procedure SetCatalogName(const AValue: TGMString); procedure SetSchemaName(const AValue: TGMString); procedure SetTableName(const AValue: TGMString); procedure SetColumnName(const AValue: TGMString); procedure SetTableKind(const AValue: TGMString); procedure SetForeignCatalogName(const AValue: TGMString); procedure SetForeignSchemaName(const AValue: TGMString); procedure SetForeignTableName(const AValue: TGMString); //property Owner: TObject read FOwner; property SchemaList: TGMSchemaList read GetSchemaList write SetSchemaList default cDfltSchemaList; property CatalogName: TGMString read GetCatalogName write SetCatalogName; property SchemaName: TGMString read GetSchemaName write SetSchemaName; property TableName: TGMString read GetTableName write SetTableName; property ColumnName: TGMString read GetColumnName write SetColumnName; property TableKind: TGMString read GetTableKind write SetTableKind; property ForeignCatalogName: TGMString read GetForeignCatalogName write SetForeignCatalogName; property ForeignSchemaName: TGMString read GetForeignSchemaName write SetForeignSchemaName; property ForeignTableName: TGMString read GetForeignTableName write SetForeignTableName; property ReExecuteAfterPropertyValueChange: Boolean read FReExecuteAfterPropertyValueChange write FReExecuteAfterPropertyValueChange default cReExecuteAfterPropertyValueChange; property OnAfterSchemaDataChange: TGMObjNotifyProc read FOnAfterSchemaDataChange write FOnAfterSchemaDataChange; end; //TGMObjectProc = procedure of object; TGMOperationNotifyEvent = procedure (const Operation: LongInt; const Parameter: IUnknown = nil) of object; TGMFieldValueChangeNotifyEvent = procedure (Sender: IUnknown; const FieldName: TGMString) of object; TGMFieldNameChangeNotifyEvent = procedure (Sender: IUnknown; const OldFieldName, NewFieldName: TGMString) of object; TGMRecordsetIntfSource = class(TGMActivatableIntfSource, IGMPositionChangeNotifications, IGMOperationNotifications, IGMNamedValueChange, IGMSQLChangeNotifications, IGMValidateValues, IGMEnumerateItems {$IFDEF FPC},IGMGetInterfaceSource, IGMGetSetInterfaceSource{$ENDIF}) protected FOnBeforePositionChange: TGMObjectProc; FOnAfterPositionChange: TGMObjectProc; FOnBeforeOperation: TGMOperationNotifyEvent; FOnAfterOperation: TGMOperationNotifyEvent; FOnAfterFieldValueChange: TGMFieldValueChangeNotifyEvent; FOnAfterSQLChange: TGMObjectProc; FOnValidateFieldValues: TGMObjectProc; public constructor Create(const AOwner: TObject; const ANeededInterfaceIDs: array of TGUID; const AIntfIDsToConnect: array of TGMIntfConnectDataRec); function FieldCanModify(const FieldName: TGMString): Boolean; function GetIntfByName(const FieldName: TGMString; const IID: TGUID; out Intf): HResult; function GetIntfByPosition(const Position: LongInt; const IID: TGUID; out Intf): HResult; //function DesignTimeDisplayText: TGMString; virtual; function SourceState: LongInt; override; function CanEdit: Boolean; virtual; function Edit: Boolean; virtual; // ---- IGMEnumerateItems ---- procedure EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer = nil); virtual; stdcall; // ---- IGMPositionChangeNotifications ---- procedure BeforePositionChange; virtual; stdcall; procedure AfterPositionChange; virtual; stdcall; // ---- IGMOperationNotifications ---- procedure BeforeOperation(const Operation: LongInt; const Parameter: IUnknown = nil); virtual; stdcall; procedure AfterOperation(const Operation: LongInt; const Parameter: IUnknown = nil); virtual; stdcall; // ---- IGMNamedValueChange ---- procedure AfterValueChange(const ValueName: TGMString); virtual; // ---- IGMSQLChangeNotification ---- procedure AfterSQLChange; virtual; // ---- IGMValidateValues ---- procedure ValidateValues; virtual; //published property OnBeforePositionChange: TGMObjectProc read FOnBeforePositionChange write FOnBeforePositionChange; property OnAfterPositionChange: TGMObjectProc read FOnAfterPositionChange write FOnAfterPositionChange; property OnBeforeOperation: TGMOperationNotifyEvent read FOnBeforeOperation write FOnBeforeOperation; property OnAfterOperation: TGMOperationNotifyEvent read FOnAfterOperation write FOnAfterOperation; property OnAfterFieldValueChange: TGMFieldValueChangeNotifyEvent read FOnAfterFieldValueChange write FOnAfterFieldValueChange; property OnAfterSQLChange: TGMObjectProc read FOnAfterSQLChange write FOnAfterSQLChange; property OnValidateFieldValues: TGMObjectProc read FOnValidateFieldValues write FOnValidateFieldValues; end; TGMRecordsetMasterSource = class(TGMRecordsetIntfSource) protected FAutoActivate: Boolean; public constructor Create(const AOwner: TObject; const ANeededInterfaceIDs: array of TGUID); //published property AutoActivate: Boolean read FAutoActivate write FAutoActivate default cDfltAutoActivate; end; TGMFieldIntfSource = class(TGMRecordsetIntfSource, IGMGetFieldName, IGMGetSetFieldName {$IFDEF FPC},IGMGetInterfaceSource, IGMGetSetInterfaceSource{$ENDIF}) protected FFieldName: TGMString; FOnAfterFieldNameChange: TGMFieldNameChangeNotifyEvent; // ---- IGMGetSetFieldName ---- function GetFieldName: TGMString; virtual; procedure SetFieldName(const Value: TGMString); virtual; public //function DesignTimeDisplayText: TGMString; override; function FieldCanModify: Boolean; overload; function GetFieldIntf(const IID: TGUID; out Intf): HResult; overload; function Edit: Boolean; override; property FieldName: TGMString read GetFieldName write SetFieldName; property OnAfterFieldNameChange: TGMFieldNameChangeNotifyEvent read FOnAfterFieldNameChange write FOnAfterFieldNameChange; end; TGMLookupIntfSource = class(TGMRecordsetIntfSource) protected FKeyFieldName: TGMString; FDisplayFieldNames: TGMString; FDisplaySearchFieldIdx: Integer; FDisplayFieldNameList: TGMStringArray; procedure SetDisplayFieldNames(const Value: TGMString); procedure SetDisplaySearchFieldIdx(const Value: Integer); procedure LimitSearchFieldIndex; public constructor Create(const AOwner: TObject); property DisplayFieldNameList: TGMStringArray read FDisplayFieldNameList; //published property KeyFieldName: TGMString read FKeyFieldName write FKeyFieldName; property DisplayFieldNames: TGMString read FDisplayFieldNames write SetDisplayFieldNames; property DisplaySearchFieldIdx: Integer read FDisplaySearchFieldIdx write SetDisplaySearchFieldIdx; end; TGMTreeIntfSource = class(TGMRecordsetIntfSource) protected FKeyFieldName: TGMString; FNodeTitleFieldNames: TGMString; FParentFieldName: TGMString; FImageIndexFieldName: TGMString; FSelectedIndexFieldName: TGMString; FStateImageIdxFieldName: TGMString; FFixedImageIndex: PtrInt; FFixedSelectedImageIndex: PtrInt; FNodeTitleFieldNameList: TGMStringArray; FOnAfterFieldNameChange: TGMFieldNameChangeNotifyEvent; procedure SetKeyFieldName(const Value: TGMString); procedure SetNodeTitleFieldNames(const Value: TGMString); procedure SetParentFieldName(const Value: TGMString); procedure SetImageIndexFieldName(const Value: TGMString); procedure SetSelectedIndexFieldName(const Value: TGMString); procedure SetStateImageIdxFieldName(const Value: TGMString); public constructor Create(const AOwner: TObject); //function DesignTimeDisplayText: TGMString; override; property NodeTitleFieldNameList: TGMStringArray read FNodeTitleFieldNameList; //published property AlwaysNotify default cDfltTreeNotify; property KeyFieldName: TGMString read FKeyFieldName write SetKeyFieldName; property NodeTitleFieldNames: TGMString read FNodeTitleFieldNames write SetNodeTitleFieldNames; property ParentFieldName: TGMString read FParentFieldName write SetParentFieldName; property ImageIndexFieldName: TGMString read FImageIndexFieldName write SetImageIndexFieldName; property SelectedIndexFieldName: TGMString read FSelectedIndexFieldName write SetSelectedIndexFieldName; property StateImageIdxFieldName: TGMString read FStateImageIdxFieldName write SetStateImageIdxFieldName; property FixedImageIndex: PtrInt read FFixedImageIndex write FFixedImageIndex default cInvalidItemIdx; property FixedSelectedImageIndex: PtrInt read FFixedSelectedImageIndex write FFixedSelectedImageIndex default cInvalidItemIdx; property OnAfterFieldNameChange: TGMFieldNameChangeNotifyEvent read FOnAfterFieldNameChange write FOnAfterFieldNameChange; end; TGMInterfaceSourceLink = class(TGMActivatableObject, IGMGetState, IGMEnumerateItems, IGMCanExecuteOperation, IGMExecuteOperation, IGMGetPosition, IGMGetSetPosition, IGMAskBoolean, IGMAskInteger, IGMGetIntfByName, IGMGetIntfByPosition, IGMGetCount, IGMSaveRestoreState, IGMUnidirectionalCursor, IGMBidirectionalCursor, IGMCursorFirstLast, IGMNamedValueChange, IGMGetAttributes, IGMGetSetAttributes, IGMLookupValues, IGMLocateValues, IGMPositionOfValues, IGMGetColumnSortOrder, IGMSetColumnSortOrder) protected FInterfaceSource: TGMRecordsetIntfSource; FOnAfterIntfSourceChange: TGMIntfSourceChangeEvent; FOnBeforePositionChange: TGMObjectProc; FOnAfterPositionChange: TGMObjectProc; FOnBeforeOperation: TGMOperationNotifyEvent; FOnAfterOperation: TGMOperationNotifyEvent; FOnAfterFieldValueChange: TGMFieldValueChangeNotifyEvent; FOnAfterSQLChange: TGMObjectProc; FOnValidateFieldValues: TGMObjectProc; function GetActive: Boolean; override; procedure SetInterfaceSource(const Value: TGMRecordsetIntfSource); procedure InternalOpen; override; procedure SetupIntfSourceConnector(const IntfConnector: TGMRecordsetIntfSource); function NeededSourceIIDs: TGMInterfaceIDArray; virtual; function GetState: LongInt; virtual; stdcall; procedure EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer = nil); virtual; stdcall; function CanExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; virtual; stdcall; function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; virtual; stdcall; function GetPosition: PtrInt; virtual; stdcall; procedure SetPosition(const Value: PtrInt); virtual; stdcall; function AskBoolean(const ValueId: LongInt): LongInt; virtual; stdcall; function AskInteger(const ValueId: LongInt): LongInt; virtual; stdcall; function GetIntfByName(const FieldName: TGMString; const IID: TGUID; out Intf): HResult; virtual; stdcall; function GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; virtual; stdcall; function GetCount: PtrInt; virtual; stdcall; function CaptureState: IUnknown; virtual; stdcall; procedure RestoreState(const State: IUnknown); virtual; stdcall; function GetBOF: Boolean; virtual; stdcall; function GetEOF: Boolean; virtual; stdcall; //function GetIsEmpty: Boolean; virtual; stdcall; procedure MoveToNext; virtual; stdcall; procedure MoveToPrevious; virtual; stdcall; procedure MoveToFirst; virtual; stdcall; procedure MoveToLast; virtual; stdcall; procedure AfterValueChange(const FieldName: TGMString); virtual; function GetAttributes: Longword; virtual; stdcall; procedure SetAttributes(const Value: Longword); virtual; stdcall; function LookupValues(const SQLCriteria: TGMString; const Values: IUnknown): Boolean; virtual; stdcall; function LocateValues(const Values: IUnknown): Boolean; virtual; stdcall; function PositionOfValues(const Values: IUnknown; var FindPos: LongInt): Boolean; virtual; stdcall; function GetColumnSortOrder(const ColumnName: TGMString): LongInt; stdcall; procedure SetColumnSortOrder(const ColumnName: TGMString; const SortOrder: LongInt; const Cumulative, ReExecuteWhenChanged: Boolean); stdcall; { ---- Notification Handler ---- } procedure AfterInterfaceSrcObjChange(const OldSource, NewSource: IUnknown); virtual; procedure BeforeActiveChange(const NewActive: Boolean); virtual; procedure AfterActiveChange(const NewActive: Boolean); virtual; procedure BeforePositionChange; virtual; procedure AfterPositionChange; virtual; procedure BeforeOperation(const Operation: LongInt; const Parameter: IUnknown = nil); virtual; procedure AfterOperation(const Operation: LongInt; const Parameter: IUnknown = nil); virtual; procedure AfterValueChange2(Sender: IUnknown; const FieldName: TGMString); virtual; procedure ValidateValues; procedure AfterSQLChange; virtual; public constructor Create(const ARefLifeTime: Boolean); override; destructor Destroy; override; { ---- IGMEnableNotifications ---- } function GetNotifyDisableCount: LongInt; override; function EnableNotifications(const NotificationOnReEnable: LongInt = Ord(rgNone)): LongInt; override; function DisableNotifications(const NotificationOnFirstDisable: LongInt = Ord(rgNone)): LongInt; override; { ---- IGMGetPropertyIntf ---- } function GetPropertyIntf(const PropertyName: TGMString; const IID: TGUID; out Intf): HResult; override; //published //property ActivationProperties; property InterfaceSource: TGMRecordsetIntfSource read FInterfaceSource write SetInterfaceSource; property OnAfterIntfSourceChange: TGMIntfSourceChangeEvent read FOnAfterIntfSourceChange write FOnAfterIntfSourceChange; property OnBeforeActiveChange; property OnAfterActiveChange; property OnBeforePositionChange: TGMObjectProc read FOnBeforePositionChange write FOnBeforePositionChange; property OnAfterPositionChange: TGMObjectProc read FOnAfterPositionChange write FOnAfterPositionChange; property OnBeforeOperation: TGMOperationNotifyEvent read FOnBeforeOperation write FOnBeforeOperation; property OnAfterOperation: TGMOperationNotifyEvent read FOnAfterOperation write FOnAfterOperation; property OnAfterFieldValueChange: TGMFieldValueChangeNotifyEvent read FOnAfterFieldValueChange write FOnAfterFieldValueChange; property OnAfterSQLChange: TGMObjectProc read FOnAfterSQLChange write FOnAfterSQLChange; property OnValidateFieldValues: TGMObjectProc read FOnValidateFieldValues write FOnValidateFieldValues; end; TGMQualifiedSourceLink = class(TGMInterfaceSourceLink, IGMTellEnumString) protected FQualifierParseChPos: PtrInt; FEnumQualifierName: TGMString; FTellEnumSink: IGMTellEnumString; procedure InternalEnumerateValues(const ItemKind: LongInt); virtual; procedure EnumerateValuesOfIntfSource(const Source: TGMRecordsetIntfSource; const ItemKind: LongInt); virtual; procedure EnumerateItems(const ItemKind: LongInt; const ATellEnumSink: IUnknown; const Parameter: Pointer = nil); override; procedure TellEnumString(const ItemKind: LongInt; const Value: TGMString; const Parameter: Pointer); virtual; stdcall; end; TGMSourceStateWrapper = class(TGMRefCountedObj, IGMGetName) protected FName: TGMString; FSourceState: IUnknown; function GetName: TGMString; stdcall; public constructor Create(const Source: IUnknown); reintroduce; procedure RestoreState(const Dest: IUnknown); end; TGMInterfaceMultiSourceLink = class; IMultiLinkSources = interface(IUnknown) ['{DD609D1E-0C45-4074-9969-30F5DAFB63E8}'] function GetSourceCount: LongInt; stdcall; function GetSource(Idx: LongInt): IUnknown; stdcall; property SourceCount: LongInt read GetSourceCount; property Sources[Idx: LongInt]: IUnknown read GetSource; end; IRestoreToMultiLink = interface(IUnknown) ['{20A7356F-545B-4d32-9E4B-61D1875F477F}'] procedure RestoreToMultiLink(const MultiLink: IMultiLinkSources); stdcall; end; TGMMultiLinkStateHolder = class(TGMRefCountedObj, IRestoreToMultiLink) protected FMasterState: TGMSourceStateWrapper; FSourceStates: TGMObjArrayCollection; public constructor Create(const AMultiLink: TGMInterfaceMultiSourceLink); reintroduce; destructor Destroy; override; procedure RestoreToMultiLink(const AMultiLink: IMultiLinkSources); stdcall; end; TGMInterfaceMultiSourceLink = class(TGMQualifiedSourceLink, IMultiLinkSources) protected FSourceList: TGMObjArrayCollection; procedure InternalOpen; override; function NeededSourceIIDs: TGMInterfaceIDArray; override; function FindSourceForQualifier(const Qualifier: TGMString; var Source: TGMRecordsetIntfSource): Boolean; { ---- IMultiLinkSources ---- } function GetMasterSource: IUnknown; stdcall; function GetSourceCount: LongInt; stdcall; function GetSource(Idx: LongInt): IUnknown; stdcall; { ---- override with new semantic ---- } procedure InternalEnumerateValues(const ItemKind: LongInt); override; function GetIntfByName(const QualifiedName: TGMString; const IID: TGUID; out Intf): HResult; override; function GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; override; procedure AfterValueChange(const QualifiedName: TGMString); override; function CaptureState: IUnknown; override; procedure RestoreState(const State: IUnknown); override; { ---- simple distributions to all sources ---- } function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; override; procedure SetPosition(const Value: PtrInt); override; procedure MoveToNext; override; procedure MoveToPrevious; override; procedure MoveToFirst; override; procedure MoveToLast; override; public constructor Create(const ARefLifeTime: Boolean); override; destructor Destroy; override; procedure AddSourceObj(const SourceObj: TObject); procedure RemoveSourceObj(const SourceObj: TObject); property SourceList: TGMObjArrayCollection read FSourceList; end; TGMInterfaceGroupSourceLink = class; TColumnSet = class(TGMRefCountedObj, IGMGetName, IGMTellEnumString) protected FOwner: TGMInterfaceGroupSourceLink; FInterfaceSource: IUnknown; FQualifiedName: TGMString; function GetName: TGMString; stdcall; public constructor Create(const AOwner: TGMInterfaceGroupSourceLink; const AQualifiedName: TGMString; const AInterfaceSource: IUnknown); reintroduce; procedure TellEnumString(const ItemKind: LongInt; const Value: TGMString; const Parameter: Pointer); virtual; stdcall; procedure EnumerateItems(const ItemKind: LongInt); function GetIntfByName(const QualifiedName: TGMString; const IID: TGUID; out Intf): HResult; property InterfaceSource: IUnknown read FInterfaceSource; end; TGMInterfaceGroupSourceLink = class(TGMQualifiedSourceLink) protected FColumnSetList: IGMObjArrayCollection; procedure InternalEnumerateValues(const ItemKind: LongInt); override; public constructor Create(const ARefLifeTime: Boolean); override; //destructor Destroy; override; function GetIntfByName(const QualifiedName: TGMString; const IID: TGUID; out Intf): HResult; override; function GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; override; procedure AddColumnSet(const QualifiedName: TGMString; const InterfaceSource: IUnknown); function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; override; property ColumnGroupList: IGMObjArrayCollection read FColumnSetList; end; RGMDisplayTextData = record Text: TGMString; IsValid: Boolean; procedure Invalidate; end; RGMCachedUnionValue = record Value: RGMUnionValue; IsValid: Boolean; procedure Invalidate; end; TGMValueBuffer = class(TGMMemoryLockBytes, IGMGetModified, IGMGetSetModified, IGMGetUnionValue, IGMGetSetUnionValue, //IGMAskInteger, IGMAskBoolean, //IGMExecuteOperation, IGMGetText, IGMAssignFromObj) protected FOwner: TObject; FModified: Boolean; FDataType: TGMDBColumnDataType; FIsNull: Boolean; FMaxStrLength: PtrUInt; FCachedValue: RGMCachedUnionValue; // ---- Volatile members ---- FValueReadStream: ISequentialStream; // <- used to hold the Stream // FValueWriteStream: ISequentialStream; // <- used to hold the Stream function CalculateBufferSize: LongInt; virtual; //procedure InternalFetchData(const AForDisplayText: Boolean = False); virtual; function GetDataLength: PtrInt; virtual; procedure SetDataLength(const AValue: PtrInt); virtual; function InternalGetUnionValue: RGMUnionValue; virtual; procedure InternalSetUnionValue(const AValue: RGMUnionValue); virtual; procedure InternalSetNullValue; virtual; procedure InternalSetSize(ANewSize: Int64); override; function InternalBuildDisplayText: TGMString; virtual; public // ---- IGMGetSetModified ---- // function GetModified: Boolean; virtual; stdcall; procedure SetModified(const AValue: Boolean); virtual; stdcall; // ---- IGMGetSetUnionValue ---- // function GetUnionValue: RGMUnionValue; virtual; procedure SetUnionValue(const AUnionValue: RGMUnionValue); virtual; // ---- IGMGetText ---- // function GetText: TGMString; virtual; stdcall; { ---- IGMExecuteOperation ---- } //function ExecuteOperation(const AOperation: LongInt; const AParameter: IUnknown = nil): Boolean; virtual; stdcall; // ---- IGMAskBoolean ---- // function AskBoolean(const AValueId: LongInt): LongInt; virtual; stdcall; procedure AssignFromObj(const Source: TObject); virtual; stdcall; procedure AssignFromIntf(const Source: IUnknown); override; public DisplayText: RGMDisplayTextData; constructor Create(const AOwner: TObject; const ADataType: TGMDBColumnDataType; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const ARefLifeTime: Boolean = False); reintroduce; virtual; function WriteAt(ulOffset: Int64; pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; override; function CreateValueStream(const AMode: DWORD): ISequentialStream; virtual; procedure Invalidate(const AResetOffset, ASetToNULL: Boolean); virtual; function IsNull: Boolean; virtual; function IsFixedBufferSize: Boolean; virtual; // function DataIsCompressed: Boolean; virtual; property Owner: TObject read FOwner; property Modified: Boolean read GetModified write SetModified; property DataType: TGMDBColumnDataType read FDataType write FDataType; property Value: RGMUnionValue read GetUnionValue write SetUnionValue; property DataLength: PtrInt read GetDataLength write SetDataLength; end; TGMValueBufferClass = class of TGMValueBuffer; TGMValueBuffers = array [EGMValueBufferInstance] of TGMValueBuffer; TGMFieldValueBuffer = class(TGMValueBuffer) protected FColumnPosition: LongInt; FieldName: TGMString; SizeInBytes: PtrUInt; StatementHandle: THandle; public constructor CreateFieldBuffer(const AOwner: TObject; const ADataType: TGMDBColumnDataType; const AColumnPosition: LongInt; const AFieldName: TGMString; const ASizeInBytes: PtrUInt; const AMaxStrLength: PtrUInt; const AStatementHandle: THandle); virtual; end; TGMFieldValueBufferClass = class of TGMFieldValueBuffer; TGMDBField = class(TGMRefCountedObj, IGMGetName, IGMGetPosition, IGMGetValueDefinition, IGMGetModified, IGMGetSetModified, IGMAskInteger, IGMAskBoolean, IGMActiveChangeNotifications, IGMPositionChangeNotifications, IGMOperationNotifications, IGMGetValueBufferIntf, IGMGetUnionValue, IGMGetSetUnionValue, IGMGetText, IGMGetSetText) protected FOwner: TObject; FCreateData: RGMFieldCreateData; FValueBufferIdxMap: array [EGMValueBufferInstance] of EGMValueBufferInstance; FValueBuffers: array [EGMValueBufferInstance] of TGMFieldValueBuffer; procedure SetModified(const Value: Boolean); virtual; stdcall; function ValueBufferCreateClass: TGMFieldValueBufferClass; virtual; function ValueBuffer(const AValueBufferInstance: EGMValueBufferInstance): TGMFieldValueBuffer; virtual; function GetUnionValue: RGMUnionValue; virtual; function GetText: TGMString; virtual; stdcall; procedure SetUnionValue(const AUnionValue: RGMUnionValue); virtual; procedure SetText(const AValue: TGMString); virtual; stdcall; procedure NotifyDataChange; virtual; function EditOrInsertRecordset: Boolean; virtual; procedure CheckupdatableState(const AMethodName: TGMString = ''); function RecordsetState: LongInt; function RecordsetAttributes: TGMRecordsetAttributes; procedure SwapBufferMap; virtual; procedure FreeValueBuffers; public // ---- Interfaces ---- // function GetName: TGMString; virtual; stdcall; function GetPosition: PtrInt; virtual; stdcall; function GetModified: Boolean; virtual; stdcall; function GetDataType: TGMDBColumnDataType; virtual; stdcall; function GetNullValuesAllowed: TGMAllowNullValues; virtual; stdcall; function GetUpdatable: Boolean; virtual; stdcall; function AskInteger(const ValueId: LongInt): LongInt; stdcall; function AskBoolean(const ValueId: LongInt): LongInt; virtual; stdcall; procedure BeforeActiveChange(const NewActive: Boolean); virtual; stdcall; procedure AfterActiveChange(const NewActive: Boolean); virtual; stdcall; procedure BeforePositionChange; virtual; stdcall; procedure AfterPositionChange; virtual; stdcall; procedure BeforeOperation(const Operation: Integer; const Parameter: IUnknown = nil); virtual; stdcall; procedure AfterOperation(const Operation: Integer; const Parameter: IUnknown = nil); virtual; stdcall; function GetValueBufferIntf(const AValueBufferInstance: LongInt; const AIID: TGUID; out AIntf): HResult; stdcall; public constructor Create(const AOwner: TObject; const ACreateData: RGMFieldCreateData); reintroduce; virtual; destructor Destroy; override; function IsSigned: Boolean; virtual; function IsAutoIncrementing: Boolean; virtual; function SizeInBytes: PtrInt; virtual; function DisplayWidth: PtrInt; virtual; function EditLength: PtrInt; virtual; property Owner: TObject read FOwner; property Name: TGMString read GetName; property Position: PtrInt read GetPosition; property Modified: Boolean read GetModified write SetModified; property CreateData: RGMFieldCreateData read FCreateData; property DataType: TGMDBColumnDataType read GetDataType; property NullValuesAllowed: TGMAllowNullValues read GetNullValuesAllowed; property Updatable: Boolean read GetUpdatable; property Value: RGMUnionValue read GetUnionValue write SetUnionValue; end; TGMFieldClass = class of TGMDBField; //TGMDBFieldList = TGMGenericArrayCollection<TGMDBField>; TGMFieldStateBuffer = class(TGMValueBuffer) public function IsFixedBufferSize: Boolean; override; end; TGMFieldStateHolder = class(TGMRefCountedObj, IGMGetName, IGMGetSetName, IGMAssignFromObj, IGMAssignToObj, IGMAssignFromIntf, IGMAssignToIntf, IGMGetValueBufferIntf) protected FName: TGMString; FDataType: TGMDBColumnDataType; FValueBuffers: TGMValueBuffers; function ValueBufferCreateClass: TGMValueBufferClass; virtual; function ValueBuffer(const ValueBufferInstance: EGMValueBufferInstance): TGMValueBuffer; virtual; { ---- IGMGetSetName ---- } function GetName: TGMString; virtual; stdcall; procedure SetName(const AValue: TGMString); virtual; stdcall; { ---- IGMGetValueBufferIntf ---- } function GetValueBufferIntf(const ValueBufferInstance: LongInt; const IID: TGUID; out Intf): HResult; virtual; stdcall; { ---- IGMAssignByObj ---- } procedure AssignFromObj(const Source: TObject); virtual; stdcall; procedure AssignToObj(const Dest: TObject); virtual; stdcall; { ---- IGMAssignByIntf ---- } procedure AssignFromIntf(const Source: IUnknown); virtual; stdcall; procedure AssignToIntf(const Dest: IUnknown); virtual; stdcall; public constructor Create(const Source: IUnknown = nil); reintroduce; virtual; destructor Destroy; override; procedure ResetContents; virtual; property Name: TGMString read FName write FName; property DataType: TGMDBColumnDataType read FDataType write FDataType; end; TGMFieldStateCreateClass = class of TGMFieldStateHolder; TGMRecordsetStateHolder = class(TGMRefCountedObj, IGMAssignFromObj, IGMAssignToObj, IGMAssignFromIntf, IGMAssignToIntf, IGMTellEnumString) protected FFieldStates: TGMObjArrayCollection; FState: LongInt; FPosition: LongInt; FSource: IUnknown; function FieldStateCreateClass: TGMFieldStateCreateClass; virtual; procedure ResetContents; virtual; procedure TellEnumString(const ItemKind: LongInt; const Value: TGMString; const Parameter: Pointer); virtual; stdcall; procedure AssignFields(const Dest: IUnknown); virtual; property FieldStates: TGMObjArrayCollection read FFieldStates; public constructor Create(const Source: IUnknown = nil); reintroduce; destructor Destroy; override; procedure AssignFromIntf(const Source: IUnknown); virtual; stdcall; procedure AssignToIntf(const Dest: IUnknown); virtual; stdcall; procedure AssignFromObj(const Source: TObject); virtual; stdcall; procedure AssignToObj(const Dest: TObject); virtual; stdcall; property State: LongInt read FState write FState; property Position: LongInt read FPosition write FPosition; end; { ---- Locate Types ---- } TNameAndValueMatch = record Name: TGMString; Value: RGMUnionValue; MatchKind: TMatchKind; MatchCase: Boolean; end; function NameAndValueMatch(const FieldName: TGMString; const FieldValue: RGMUnionValue; const MatchKind: TMatchKind = GMIntf.mkExactMatch; const MatchCase: Boolean = True): TNameAndValueMatch; type TGMNameAndValueMatchObj = class(TGMRefCountedObj, IGMGetName, IGMGetUnionValue, IGMGetSetUnionValue, IGMAskBoolean, IGMAskInteger) public FData: TNameAndValueMatch; function GetName: TGMString; virtual; stdcall; function GetUnionValue: RGMUnionValue; virtual; procedure SetUnionValue(const AUnionValue: RGMUnionValue); virtual; function AskBoolean(const ValueId: LongInt): LongInt; virtual; stdcall; function AskInteger(const ValueId: LongInt): LongInt; virtual; stdcall; constructor Create(const AData: TNameAndValueMatch; const RefLifeTime: Boolean = False); reintroduce; end; TGMNamedValueCollection = class(TGMObjArrayCollection, IGMGetIntfByName) public constructor Create(const Names: array of TGMString; const RefLifeTime: Boolean = True); function GetIntfByName(const Name: TGMString; const IID: TGUID; out Intf): HResult; stdcall; function FindValueByName(const ValueName: TGMString; var Value: TGMNameAndValueObj): Boolean; procedure SaveValues; procedure RestoreValues; procedure ClearOldValues; end; TGMNameAndValueMatchList = class(TGMObjArrayCollection) public constructor Create(const Values: array of TNameAndValueMatch; const RefLifeTime: Boolean = True); end; TGMFieldNameAndValue = class(TGMNameAndValueObj, IGMGetValueDefinition) protected FOwner: TObject; FOldValue: RGMUnionValue; FReadOnly: Boolean; public constructor Create(const AOwner: TObject; const AName: TGMString; const AValue: RGMUnionValue; const AReadOnly: Boolean = False; const ARefLifeTime: Boolean = False); reintroduce; overload; procedure SetUnionValue(const AUnionValue: RGMUnionValue); override; procedure NotifyValueChange; function GetDataType: TGMDBColumnDataType; stdcall; function GetNullValuesAllowed: TGMAllowNullValues; stdcall; function GetUpdatable: Boolean; stdcall; procedure SaveValue; procedure RestoreValue; procedure ClearOldValue; property ReadOnly: Boolean read FReadOnly write FReadOnly; end; TGMNamedValuesContainer = Class; TGMNamedValueChangeEvent = procedure (Sender: TGMNamedValuesContainer; const ValueName: TGMString) of object; TRecalculateValuesEvent = procedure (Sender: TGMNamedValuesContainer) of object; TGMNamedValuesContainer = Class(TGMActivatableObject, IGMAskboolean, IGMGetState, IGMEnumerateItems, IGMSaveRestoreState, IGMGetPosition, IGMGetIntfByName, IGMGetIntfByPosition, IGMGetCount, IGMExecuteOperation, IGMCanExecuteOperation, IGMNamedValueChange, IGMLoadStoreData, IGMGetMasterSource, IGMGetSetMasterSource) protected FState: TGMRecordsetState; FNamedValuesList: TGMNamedValueCollection; FMasterSource: TGMRecordsetMasterSource; FReCalculationTimer: TGMThreadTimer; FTimedReCalculationDelay: Integer; FOnAfterValueChange: TGMNamedValueChangeEvent; FOnRecalculateValues: TRecalculateValuesEvent; function GetValue(const AIndex: RGMUnionValue): RGMUnionValue; function GetMasterSourceConnector: TGMRecordsetMasterSource; procedure SetValue(const AIndex: RGMUnionValue; const Value: RGMUnionValue); procedure SetMasterSourceConnector(const Value: TGMRecordsetMasterSource); procedure AfterMasterActiveChange(const NewActive: Boolean); virtual; procedure AfterMasterPositionChange; virtual; procedure AfterMasterOperation(const Operation: LongInt; const Parameter: IUnknown = nil); virtual; function GetActive: Boolean; override; procedure InternalOpen; override; procedure InternalClose; override; public // Interfaces function GetMasterSource: IUnknown; procedure SetMasterSource(const AValue: IUnknown); function AskBoolean(const ValueId: LongInt): LongInt; virtual; stdcall; function GetCount: PtrInt; virtual; stdcall; function GetState: LongInt; virtual; stdcall; procedure EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer = nil); virtual; stdcall; function CaptureState: IUnknown; virtual; stdcall; procedure RestoreState(const State: IUnknown); virtual; stdcall; function GetPosition: PtrInt; virtual; stdcall; function GetIntfByName(const Name: TGMString; const IID: TGUID; out Intf): HResult; virtual; stdcall; function GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; virtual; stdcall; procedure AfterValueChange(const ValueName: TGMString); virtual; function CanExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; virtual; stdcall; function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; virtual; stdcall; procedure LoadData(const Source: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; procedure StoreData(const Dest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; public constructor Create(const ARefLifeTime: Boolean); override; destructor Destroy; override; procedure AddNamedValue(const Name: TGMString; const Value: RGMUnionValue; const ReadOnly: Boolean = False; const NotifyValueChange: Boolean = False); procedure RecalculateValues(const Sender: TObject); virtual; procedure ScheduleReCalculation; property ReCalculationTimer: TGMThreadTimer read FReCalculationTimer; property Values[const Idx: RGMUnionValue]: RGMUnionValue read GetValue write SetValue; default; property NamedValuesList: TGMNamedValueCollection read FNamedValuesList; //published property ActivationProperties; property MasterSource: TGMRecordsetMasterSource read GetMasterSourceConnector write SetMasterSourceConnector; property TimedReCalculationDelay: Integer read FTimedReCalculationDelay write FTimedReCalculationDelay default cDfltReExecutionDelay; property OnAfterValueChange: TGMNamedValueChangeEvent read FOnAfterValueChange write FOnAfterValueChange; property OnBeforeActiveChange; property OnAfterActiveChange; property OnRecalculateValues: TRecalculateValuesEvent read FOnRecalculateValues write FOnRecalculateValues; end; TGMSqlStatementBase = class(TGMHandleActivateObj, IGMGetName, IGMGetState, IGMEnumerateItems, IGMCanExecuteOperation, IGMSaveRestoreState, IGMExecuteOperation, IGMGetColumnSortOrder, IGMSetColumnSortOrder, IGMGetSortColumnName, IGMGetSubItems, IGMAssignFromObj) protected FState: TGMRecordsetState; FSQL: TGMSqlProperty; FReExecutionTimer: TGMThreadTimer; FInternalExecuted: Boolean; FColumnsStayValidOnReExecution: Boolean; FOnAfterSQLChange: TGMObjNotifyProc; function GetTimedReExecutionDelay: Integer; function GetConnectionIntf: IUnknown; procedure SetSQL(const AValue: TGMSqlProperty); procedure SetTimedReExecutionDelay(const AValue: Integer); procedure SetConnectionIntf(const AValue: IUnknown); procedure SQLChanged(const Sender: TObject); virtual; procedure OnTimedReExecution(const Sender: TObject); virtual; procedure CallSinkAfterSQLChange(const ANotifySink: IUnknown; const AParams: array of RGMUnionValue); procedure NotifyAfterSQLChange; virtual; procedure NotifyBeforeOperation(const Operation: Integer; const Parameter: IUnknown = nil); virtual; procedure NotifyAfterOperation(const Operation: Integer; const Parameter: IUnknown = nil); virtual; procedure NotifyConnectedObjectsBeforePositionChange; virtual; procedure NotifyConnectedObjectsAfterPositionChange; virtual; procedure NotifyConnectedObjectsOnFirstDisable(const NotificationOnFirstDisable: LongInt = Ord(rgNone)); override; procedure NotifyConnectedObjectsOnReEnable(const NotificationOnReEnable: LongInt = Ord(rgNone)); override; procedure OnBeforeIntfSourceChange(const OldSource, NewSource: IUnknown); procedure ResetMembers; virtual; function GetResolvedSQLStatement: TGMString; virtual; procedure CheckSQLStatementText(const ASQL: TGMString); virtual; procedure InternalExecute; virtual; procedure APIExecuteSQL(const ASQLText: TGMString); virtual; abstract; procedure AllocHandle; override; procedure ReleaseHandle; override; procedure DoStateChange(const AOperation: TGMRecordsetOperation; const AInternalOperationProc: TGMObjectProc = nil; const AParameter: IUnknown = nil); virtual; public constructor Create(const ARefLifeTime: Boolean = False); overload; override; constructor Create(const AConnection: IUnknown; const ASql: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; procedure AssignFromObj(const Source: TObject); virtual; stdcall; procedure Execute; virtual; function CanModify: Boolean; virtual; procedure ReExecuteStatement(const AColumnsStayValid: Boolean = True; APreserveState: Boolean = True); virtual; procedure ScheduleReExecution(const AColumnsStayValid: Boolean = True); virtual; function GetName: TGMString; stdcall; // IGMGetPropertyIntf function GetPropertyIntf(const APropertyName: TGMString; const AIID: TGUID; out AIntf): HResult; override; // IGMGetState function GetState: LongInt; virtual; stdcall; // IGMEnumerateItems procedure EnumerateItems(const AItemKind: LongInt; const ATellEnumSink: IUnknown; const AParameter: Pointer = nil); virtual; stdcall; // Operations function CanExecuteOperation(const AOperation: Integer; const AParameter: IUnknown = nil): Boolean; virtual; stdcall; function ExecuteOperation(const AOperation: Integer; const AParameter: IUnknown = nil): Boolean; virtual; stdcall; // IGMSaveRestoreState function CaptureState: IUnknown; virtual; stdcall; procedure RestoreState(const AState: IUnknown); virtual; stdcall; // IGMGetColumnSortOrder function GetColumnSortOrder(const AColumnName: TGMString): LongInt; stdcall; procedure SetColumnSortOrder(const AColumnName: TGMString; const ASortOrder: LongInt; const ACumulative, AReExecuteWhenChanged: Boolean); stdcall; // IGMGetSortColumnName function GetSortColumnName(var AColumnName: TGMString): Boolean; stdcall; // ---- IGMGetSubItems ---- function GetSubItems(const AParentFieldName: TGMString; const AParentFieldValue: RGMUnionValue; const AIID: TGUID; out Intf): HResult; property InternalExecuted: Boolean read FInternalExecuted; property State: TGMRecordsetState read FState; property ReExecutionTimer: TGMThreadTimer read FReExecutionTimer; property SQL: TGMSqlProperty read FSQL write SetSQL; // implements IGMGetText; property ConnectionIntf: IUnknown read GetConnectionIntf write SetConnectionIntf; property OnAfterSQLChange: TGMObjNotifyProc read FOnAfterSQLChange write FOnAfterSQLChange; end; IGMModifyViaSQL = interface(IUnknown) ['{5A6F4EDD-0BFB-4609-B493-334EA9E04051}'] procedure Update(const ASQLExecuter: IUnknown); stdcall; procedure Insert(const ASQLExecuter: IUnknown); stdcall; procedure Delete(const ASQLExecuter: IUnknown); stdcall; procedure Refresh; procedure Reset; end; TGMModifyViaSql = class(TGMRefCountedObj, IGMModifyViaSQL, IGMTellEnumString) protected FOwner: TObject; FFieldList: TGMStringArray; FKeyFieldList: TGMStringArray; FFieldListsValid: Boolean; //function FieldList: TGMStringArray; //function KeyFieldList: TGMStringArray; procedure BuildFieldLists; function KeyValuesSQL(const BufferInstance: EGMValueBufferInstance): TGMString; procedure TellEnumString(const ItemKind: LongInt; const Value: TGMString; const Parameter: Pointer); stdcall; public constructor Create(const AOwner: TObject; const ARefLiftetime: Boolean = False); reintroduce; procedure Reset; procedure Update(const ASQLExecuter: IUnknown); stdcall; procedure Insert(const ASQLExecuter: IUnknown); stdcall; procedure Delete(const ASQLExecuter: IUnknown); stdcall; procedure Refresh; property Owner: TObject read FOwner; property FieldList: TGMStringArray read FFieldList; property KeyFieldList: TGMStringArray read FKeyFieldList; end; { ---- BLOB Types ---- } //TGMCompressedBlobHeaderData = packed record // Guid: TGUID; // DataSize: Longword; // Reserved: LongWord; //end; function GMEmptyStrAsNil(const AValue: TGMString): TGMString; function IsSelectSQL(const ASQLText: TGMString): Boolean; function GMSqlStatmentKind(const ASQLText: TGMString): TGMSqlStatementKind; function GMIterateAllSqlStatements(const ASqlText: TGMString; const ASqlStmtVisitFunc: TGMSqlStmtVisitFunc; const AOpaqueAppData: Pointer = nil): Integer; function GMNextSqlStatement(var AChPos: PtrInt; const ASQLText: TGMString): TGMString; function GMPreviousSqlStatement(var AChPos: PtrInt; const ASQLText: TGMString): TGMString; function GMLastSqlStatement(const ASQLText: TGMString; const AKind: TGMSqlStatementKind = skSelect): TGMString; function GMDbColDataTypeOfUnionValue(const AValue: RGMUnionValue): TGMDBColumnDataType; function IsIntegerFieldDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; function IsStreamedFieldDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; function IsTextFieldDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; function IsStringFieldDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; function IsFixedLengthDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; function IsSortableDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; //function IsAggregatSelectList(const SQLSelectList: TGMString): Boolean; function GMExtractNameFromConnectionString(const AConnectionString: TGMString): TGMString; //function GMReplaceDSNInConnectionString(const ConnectionString, NewDSN: TGMString): TGMString; function GMAddOrReplaceValueInConnectionString(const ConnectionString, ValueName, Value: TGMString): TGMString; function ExtractDSNFromDisplayName(const ADSNDisplayName: TGMString): TGMString; //function GMCompareConnectionStrings(const ConnectionStr1, ConnectionStr2: TGMString; const CompareKind: TConnectionStrCompareKind = cnpLazyMatch): Boolean; function DataTypeCanEditAsString(const AFieldDataType: TGMDBColumnDataType): Boolean; //function GMVarTypeOfDataType(const AFieldDataType: TGMDBColumnDataType; const ACallingName: TGMString): Integer; //function GMDataTypeOfVarType(const AVarType: Integer; const ACallingName: TGMString): TGMDBColumnDataType; function GMUnionTypeOfDbDataType(const ADbDataType: TGMDBColumnDataType): EGMUnionValueType; function GMDbDataTypeOfUnionType(const AValueType: EGMUnionValueType): TGMDBColumnDataType; //function GMDataTypeOfUnionType(const AVarType: Integer; const ACallingName: TGMString): TGMDBColumnDataType; function GMValueBufferSizeOfFieldDataType(const FieldDataType: TGMDBColumnDataType): Integer; function GMFieldEditLength(const AFielDataType: TGMDBColumnDataType; const AMaxStrLength: PtrUInt): PtrUInt; function GMFieldDisplayWidth(const AFielDataType: TGMDBColumnDataType; const AMaxStrLength: PtrUInt): PtrInt; function GMCharSizeInBytes(const AFieldDataType: TGMDBColumnDataType): Word; function GMStripSQLComments(const ASQLText: TGMString): TGMString; function GMNextSQLToken(var AChPos: PtrInt; const ASQLText, ASeparators: TGMString): TGMString; function GMPreviousSQLToken(var AChPos: PtrInt; const ASQLText, ASeparators: TGMString; const ASkipTrailingSeparators: Boolean = True): TGMString; function GMExtractQualifier(const QualifiedName: TGMString; var chPos: PtrInt; var Qualifier: TGMString; const Separators: TGMString = cSqlQualSep): Boolean; function GMSplitQualifiedName(const QualifiedName: TGMString; var Qualifier, FieldName: TGMString): Boolean; function GMVarToConnectionStrLiteral(const AValue: RGMUnionValue): TGMString; function GMUnionValueAsSqlLiteral(const AValue: RGMUnionValue; ASQLFormatStrForDateTime: TGMString = ''): TGMString; function GMStringAsSqlLiteral(const AValue: TGMString; const AQuoteChar: TGMChar = cSqlStrQuoteChar): TGMString; //function DuplicateQuotes(const SQL: TGMString; const QuoteChar: TGMChar = cSqlStrQuoteChar): TGMString; function ExtractSQLSelectList(const ASQLText: TGMString): TGMString; procedure GMCheckSQLNotEmpty(const SQL: TGMString; const Caller: TObject = nil; const CallingName: TGMString = ''); function GMCalcParamCount(const SQLString: TGMString): SmallInt; function IsUpdatableState(const State: Longword): Boolean; function GMObjectIsInUpdatableState(const Intf: IUnknown): Boolean; function GMObjectCanBeEdited(const Intf: IUnknown): Boolean; function GMEditOrInsertIntf(const AIntf: IUnknown): Boolean; procedure GMCheckExecRSOperation(const Obj: TObject; const Operation: TGMRecordsetOperation; const CallingName: TGMString = ''; const Parameter: IUnknown = nil); overload; procedure GMCheckExecRSOperation(const Intf: IUnknown; const Operation: TGMRecordsetOperation; const CallingName: TGMString = ''; const Parameter: IUnknown = nil); overload; function ConvertStringToFieldType(const AValAsStr: TGMString; const ADbDataType: TGMDBColumnDataType): RGMUnionValue; function RecordsetStateAfterOperation(const AOperation: TGMRecordsetOperation; const AObj: TObject = nil): TGMRecordsetState; function RSAttributesToLongWord(const Value: TGMRecordsetAttributes): Longword; function RSAttributesFromLongWord(const Value: Longword): TGMRecordsetAttributes; function SchemaListsToLongWord(const Value: TGMSchemaLists): Longword; function SchemaListsFromLongWord(const Value: Longword): TGMSchemaLists; function GMExtractNextFieldName(var AChPos: PtrInt; const FieldNames: TGMString): TGMString; function GMExtractTableName(const ASQLText: TGMString): TGMString; function GMSqlIdentifierNeedsQuotation(const AIdentifier: TGMString): Boolean; function GMSqlQuoteIdentifierIfNeeded(const AIdentifier: TGMString; const AIdQuoteChar: TGMString = cSqlIdQuoteCh): TGMString; function GMBuildSelectAllSQL(ATableName: TGMString; const AIdQuoteChar: TGMString = cSqlIdQuoteCh; const AOrderBy: TGMString = ''): TGMString; function GMBuildSelectCountSQL(ATableName: TGMString; const AIdQuoteChar: TGMString = cSqlIdQuoteCh; const AWhereClause: TGMString = ''): TGMString; function GMModifyToSelectCountSQL(const ASqlText: TGMString; const ACaller: TObject = nil): TGMString; function GMBuildSQLDelete(ATableName: TGMString; const AWhere: TGMString = ''): TGMString; function GMReplaceSqlValue(const SQLPart, FieldName, OpInner, OpOuter: TGMString; const FieldValue: RGMUnionValue): TGMString; function GMConfirmDeletion(const Container: IUnknown; ConfirmQuestion: TGMString = ''): Boolean; procedure GMDoDeletion(const AContainer: IUnknown; const ASelection: IUnknown = nil); procedure GMDeleteCascaded(const Container: IUnknown; const KeyValueName, ParentRefValueName: TGMString); overload; procedure GMDeleteCascaded(const Container: IUnknown); overload; procedure GMInsertChild(const Container: IUnknown); function GMLookupValues(const Container, Values: IUnknown; const SQLCriteria: TGMString; const GlobalLookup: Boolean = True): Boolean; function GMLookupValue(const Container: IUnknown; const ValueName, SQLCriteria: TGMString; const GlobalLookup: Boolean = True): RGMUnionValue; function GetSqlIdQuoteChFromConnection(const AConnection: IUnknown): TGMString; function GetSqlIdQuoteChFromStatement(const AStatement: IUnknown): TGMString; //function GMExecSqlSelectCount(const AStatement: IUnknown; const ASqlText: TGMString): RGMUnionValue; function GMGetSubItemsBySQL(const Container: IUnknown; const ParentFieldName: TGMString; ParentFieldValue: RGMUnionValue; const IID: TGUID; out Intf): HResult; function RecordsetAttributesToInt(const Value: TGMRecordsetAttributes): LongInt; function RecordsetAttributesFromInt(const Value: LongInt): TGMRecordsetAttributes; function GMBuildContentsString(const Source: IUnknown; const FieldNames: TGMStringArray; SelectionSource: IUnknown = nil; const IncludeTitles: Boolean = True; const ColumnSeparator: TGMString = cDfltColumnSeparator; const RowSeparator: TGMString = cDfltRowSeparator): TGMString; //function GMCompressedBlobHeaderData(const DataSize: LongWord = 0): TGMCompressedBlobHeaderData; //function GMIsCompressedBlobHeaderData(const Data: TGMCompressedBlobHeaderData): Boolean; function GMSetSortOrder(const AFieldName: TGMString; const ASortOrder: LongInt; const ASQLOrderBy: TGMString; const ACumulative: Boolean = True): TGMString; // Return values: Negative values = DESC, 0 and positive values = ASC, the number represents the position inside the applied sortings function GMFindSortOrderPos(const AFieldName, ASQLOrderBy: TGMString; var AChPos: PtrInt): PtrInt; function GMFindSortOrder(const AFieldName, ASQLOrderBy: TGMString): LongInt; procedure GMNotifyFieldsBeforeOperation(const AFieldList: TGMObjArrayCollection; const AOperation: Integer; const AParameter: IUnknown = nil); procedure GMNotifyFieldsAfterOperation(const AFieldList: TGMObjArrayCollection; const AOperation: Integer; const AParameter: IUnknown = nil); procedure GMNotifyFieldsBeforePositionChange(const AFieldList: TGMObjArrayCollection); procedure GMNotifyFieldsAfterPositionChange(const AFieldList: TGMObjArrayCollection); procedure GMNotifyFieldsBeforeActiveChange(const AFieldList: TGMObjArrayCollection; const ANewActive: Boolean); procedure GMNotifyFieldsAfterActiveChange(const AFieldList: TGMObjArrayCollection; const ANewActive: Boolean); function GMRecordsetAttributeName(const ARSAttribute: TGMRecordsetAttribute): TGMString; function GMRSOperationName(const ARSOperation: TGMRecordsetOperation): TGMString; function GMSchemaListName(const ASchemList: TGMSchemaList): TGMString; function GMFieldDataTypeName(const AFieldDataType: TGMDBColumnDataType): TGMString; function GMRecordsetStateName(const ARSState: TGMRecordsetState): TGMString; procedure GMCallSinkAfterSQLChange(const NotifySink: IUnknown; const Params: array of OleVariant); procedure GMCallSinkAfterFieldValueChange(const NotifySink: IUnknown; const Params: array of OleVariant); function GMNullableYN(const AValue: TGMAllowNullValues): TGMString; function GMNullableName(const AValue: TGMAllowNullValues): TGMString; function GMSortOrderDirectionName(const ASortOrderDirection: TGMSortOrderDirection): TGMString; function GMAllowDuplicatesName(const AValue: TGMAllowDuplicates): TGMString; resourcestring RStrNULLValue = '<Unknown>'; RStrAutoSaveChanges = 'Automatically save changes before moving to another record'; RStrAutoEdit = 'Automatically enter editing state when a field value is modified'; RStrConfrimDeletions = 'Confirm record deletions'; RStrBookmarksEnabled = 'Enable bookmarks'; RStrExposeBookmarkColumn = 'Make bookmark column accessible'; RStrStripTrailingBlanks = 'Strip trailing blanks from string values when reading data'; RStRroEdit = 'Edit'; RStRroInsert = 'Insert'; RStRroDelete = 'Delete'; RStRroCancelChanges = ''; RStRroApplyChanges = 'Apply changes'; RStRroRefreshCurrent = 'Refresh current'; RStRroReExecuteStatement = 're-Execute'; RStRroScheduleReExecution = 'Schedule re-Execute'; RStRroLeaveModifyingState = 'Leave modfying state'; RStRroSetSimplestConfiguration = 'Set simplest configuration'; //RStrSystemTables = 'System Tables'; RStrTables = 'Tables'; //RStrViews = 'Views'; RStrProcedures = 'Procedures'; RStrTablePrivilegs = 'Table Privileges'; RStrColumnPrivilegs = 'Column Privileges'; RStrStatistics = 'Indexes'; RStrColumns = 'Columns'; RStrProcedureColumns = 'Procedure Columns'; RStrPrimaryKeys = 'Primary Keys'; RStrForeignKeys = 'Foreign Keys'; RStrTypeInfo = 'Type Info'; RStrfdtBit = 'Bool'; RStrfdtInt8 = 'Int8'; RStrfdtUInt8 = 'UInt8'; RStrfdtInt16 = 'Int16'; RStrfdtUInt16 = 'UInt16'; RStrfdtInt32 = 'Int32'; RStrfdtUInt32 = 'UInt32'; RStrfdtInt64 = 'Int64'; RStrfdtUInt64 = 'UInt64'; RStrfdtSingle = 'Single'; RStrfdtDouble = 'Double'; RStrfdtNumeric = 'Numeric'; RStrfdtDate = 'Date'; RStrfdtTime = 'Time'; RStrfdtDateTime = 'Datetime'; RStrfdtAnsiString = 'String (Ansi)'; RStrfdtWideString = 'String (Unicode)'; RStrfdtAnsiMemo = 'Memo (Ansi)'; RStrfdtWideMemo = 'Memo (Unicode)'; RStrfdtBinary = 'Binary'; RStrfdtGUID = 'GUID'; RStrrsInactive = 'Inactive'; RStrrsBrowsing = 'Browsing'; RStrrsInserting = 'Inserting'; RStrrsEditing = 'Editing'; RStrrsUnknown = '<Unknown>'; const cStrCascadePropertyName = 'CascadedContentsProperties'; cUpdatableStates = [Ord(rsInserting), Ord(rsEditing)]; cGeneralOperationtypeName = 'TDBGeneralOperation'; //cGMBlobCompressionSignature: TGUID = '{DB81F896-A3C3-4e00-BE3A-98A594A2B7CC}'; //cStrSchemaData = 'SchemaData'; // <- must match property name cStrSchemaList = 'TGMSchemaList'; cOdbcSchemaNameColPos: array [TGMSchemaList] of Integer = (3, 3, 4, 4, 6, 6, 12, 6, 7, 1, -1); //cSqlSortOrderNames: array [TGMSortOrder] of TGMString = ('', cSqlAsc, cSqlDesc); cEnableNotify: array [Boolean] of Integer = (Ord(rgNone), Ord(rgRefeshComplete)); var vDBWaitCursor: TGMCursor = crWait; vSQLDatTimeFmtStr: TGMString = '"''"yyyy"-"mm"-"dd"T"hh":"nn":"ss"."zzz"''"'; resourcestring srNotInUpdatableState = 'Not in updatable state'; srTreeDesignDisplayFmt = 'Table:'#9'%s'#13#13'Key:'#9'%s'#13'Parent:'#9'%s'#13'Title:'#9'%s'#13'Image:'#9'%s'#13'Selected:'#9'%s'#13'State:'#9'%s'; srUnresolvedParams = 'Failed to prepare the SQL Statement because the following Parameters are unresolved or have no Value assigned to them: '; srNoBlobField = 'BLOB Data Interfaces can only be used with BLOB Fields'; srNoValue = 'The Value cannot be used with BLOB fields. Use the BLOB Data Interfaces instead'; srConfirmRecordDeletion = 'Delete current record'; srConfirmMultipleDelete = 'Delete %d records'; srConfirmDeleteCascaded = 'Delete current record and all cascaded records ?'; srBinaryDataFmt = '<binary data: %s byte>'; srCnStrEmpty = 'The connection TGMString is empty'; //RStrOnlyModfifiyngSQL = 'Only Modifying SQL Statements can be executed with this Component.'; //RStrNoModfifiyngSQL = 'Only SQL SELECT Statements can be executed with this Component.'; srNoSQLKeyValues = 'No Key values found'; srSQLIsEmpty = 'The SQL text of the statement is empty'; //RStrCascadeInfoIncomplete = 'Cascading Information is incomplete'; implementation {$IFDEF JEDIAPI}uses jwaWinError, jwaWinUser;{$ENDIF} resourcestring srInvalidSQLVariantFmt = 'Union-Value type "%s" cannot be expressed as SQL literal'; srParamNameNotFound = 'A parameter with name ''%s'' doesn''t exist'; //RStrNoFieldTypeForVarType = 'Union-Value type "%s" cannot be mapped on any field data type'; srAskContinueDeletion = 'Continue deleting remaining records'; srValueNameNotFound = 'A value with name ''%s'' doesn''t exist'; srUnableBuildCountSQL = 'Unable to build "SELECT Count(*)" SQL'; //RStrBlobData = '<Binary BLOB Data>'; //RStrFixedBufSizeViolation = 'Requested value buffer size (%d Bytes) of fixed buffer is larger than current buffer size (%d Bytes)'; { ------------------------- } { ---- Global Routines ---- } { ------------------------- } function GMDbColDataTypeOfUnionValue(const AValue: RGMUnionValue): TGMDBColumnDataType; begin case AValue.ValueType of //uvtUnassigned, uvtNull: Result := fdtUnknown; uvtString: Result := {$IFDEF UNICODE}fdtUnicodeString{$ELSE}fdtAnsiString{$ENDIF}; uvtBoolean: Result := fdtBoolean; uvtInt16: Result := fdtInt16; uvtInt32: Result := fdtInt32; uvtInt64: Result := fdtInt64; uvtDouble: Result := fdtDouble; uvtDateTime: Result := fdtDateTime; //uvtPointer else Result := fdtUnknown; end; end; function IsIntegerFieldDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; begin Result := AFieldDataType in cIntegerFieldDataTypes; end; function IsStreamedFieldDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; begin Result := AFieldDataType in cStreamedFieldDataTypes; end; function IsTextFieldDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; begin Result := AFieldDataType in cMemoFieldDataTypes; end; function IsStringFieldDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; begin Result := AFieldDataType in cStringFieldDataTypes; end; function IsFixedLengthDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; begin Result := not (AFieldDataType in cVariableLengthDataTypes); end; function IsSortableDataType(const AFieldDataType: TGMDBColumnDataType): Boolean; begin Result := not (AFieldDataType in cStreamedFieldDataTypes); end; function DataTypeCanEditAsString(const AFieldDataType: TGMDBColumnDataType): Boolean; begin Result := AFieldDataType <> fdtBinary; end; function RecordsetAttributesToInt(const Value: TGMRecordsetAttributes): LongInt; var i: TGMRecordsetAttribute; begin Result := 0; for i:=Low(i) to High(i) do if i in Value then Result := Result or (1 shl Ord(i)); end; function RecordsetAttributesFromInt(const Value: LongInt): TGMRecordsetAttributes; var i: TGMRecordsetAttribute; begin Result := []; for i:=Low(i) to High(i) do if Value and (1 shl Ord(i)) <> 0 then Include(Result, i); end; procedure GMCallSinkAfterSQLChange(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMSQLChangeNotifications; begin if GMQueryInterface(NotifySink, IGMSQLChangeNotifications, Sink) then try Sink.AfterSQLChange; except end; end; procedure GMCallSinkAfterFieldValueChange(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMNamedValueChange; begin if GMQueryInterface(NotifySink, IGMNamedValueChange, Sink) then case Length(Params) of 1: try Sink.AfterValueChange(Params[Low(Params)]); except end; else raise EGMException.ObjError(GMFormat(RStrInvalidParamCountFmt, [Length(Params)]), nil, {$I %CurrentRoutine%}); end; end; //function ReadNextSQLChar(var AChPos: PtrInt; const ASQLText: TGMString; var AChar: TGMChar): Boolean; //var nextCh, lastCh: TGMChar; inLineComment, inComment1: Boolean; //begin //Result := False; inLineComment := False; inComment1 := False; //while AChPos <= Length(ASQLText) do // begin // AChar := ASQLText[AChPos]; // Inc(AChPos); // // if inLineComment then // begin // inLineComment := (AChar <> #10) and (AChar <> #13); if inLineComment then Continue; // end // else // if inComment1 then // begin // if AChPos-2 >= 1 then lastCh := ASQLText[AChPos-2] else lastCh := #0; // inComment1 := (lastCh <> '*') or (AChar <> '/'); // Continue; // end // else // begin // if AChPos < Length(ASQLText) then nextCh := ASQLText[AChPos+1] else nextCh := #0; // case AChar of // '-': if nextCh = '-' then begin inLineComment := True; Continue; end; // '/': if nextCh = '*' then begin inComment1 := True; Continue; end; // end; // // Result := True; // Break; // end; // end; //end; //function GMStripSQLComments(const ASQLText: TGMString): TGMString; //var chPos, resultChPos: PtrInt; inLineComment1, inLineComment2, inComment1: Boolean; lastCh, ch, nextCh: TGMChar; //begin // Result := ''; inLineComment1 := False; inLineComment2 := False; inComment1 := False; lastCh := #0; // resultChPos := 1; // // for chPos:=1 to Length(ASQLText) do // begin // ch := ASQLText[chPos]; // // if inLineComment1 then inLineComment1 := (ch <> #10) and (ch <> #13) // else // if inLineComment2 then inLineComment2 := (ch <> #10) and (ch <> #13) // else // if inComment1 then begin inComment1 := (lastCh <> '*') or (ch <> '/'); lastCh := ch; Continue; end // else // begin // if chPos < Length(ASQLText) then nextCh := ASQLText[chPos+1] else nextCh := #0; // case ch of // '-': inLineComment1 := nextCh = '-'; // '/': begin inComment1 := nextCh = '*'; inLineComment2 := nextCh = '/'; end; // end; // end; // // if not (inLineComment1 or inLineComment2 or inComment1) then Result := Result + ch; // lastCh := ch; // end; //end; function GMStripSQLComments(const ASQLText: TGMString): TGMString; var chPos, resultChPos: PtrInt; inLineComment1, inLineComment2, inComment1: Boolean; lastCh, ch, nextCh: TGMChar; begin SetLength(Result, Length(ASQLText)); inLineComment1 := False; inLineComment2 := False; inComment1 := False; lastCh := #0; resultChPos := 1; for chPos:=1 to Length(ASQLText) do begin ch := ASQLText[chPos]; if inLineComment1 then inLineComment1 := (ch <> #10) and (ch <> #13) else if inLineComment2 then inLineComment2 := (ch <> #10) and (ch <> #13) else if inComment1 then begin inComment1 := (lastCh <> '*') or (ch <> '/'); lastCh := ch; Continue; end else begin if chPos < Length(ASQLText) then nextCh := ASQLText[chPos+1] else nextCh := #0; case ch of '-': inLineComment1 := nextCh = '-'; '/': begin inComment1 := nextCh = '*'; inLineComment2 := nextCh = '/'; end; end; end; if not (inLineComment1 or inLineComment2 or inComment1) then begin Result[resultChPos] := ch; Inc(resultChPos); end; lastCh := ch; end; SetLength(Result, resultChPos-1); end; //function SkipSQLCommentsCharPos(AChPos: PtrInt; const ASQLText: TGMString): PtrInt; //var ch, nextCh, lastCh: TGMChar; inLineComment, inComment1: Boolean; //begin //Result := AChPos; //inLineComment := False; inComment1 := False; //while AChPos <= Length(ASQLText) do // begin // ch := ASQLText[AChPos]; // // if inLineComment then // begin // inLineComment := (ch <> #10) and (ch <> #13); if inLineComment then begin Inc(AChPos); Continue; end; // end // else // if inComment1 then // begin // if AChPos-1 >= 1 then lastCh := ASQLText[AChPos-1] else lastCh := #0; // inComment1 := (lastCh <> '*') or (ch <> '/'); // Inc(AChPos); // Continue; // end // else // begin // if AChPos < Length(ASQLText) then nextCh := ASQLText[AChPos+1] else nextCh := #0; // case ch of // '-': if nextCh = '-' then begin inLineComment := True; Inc(AChPos, 2); Continue; end; // '/': if nextCh = '*' then begin inComment1 := True; Inc(AChPos, 2); Continue; end; // end; // // Result := AChPos; // Break; // end; // end; //end; function GMNextSQLToken(var AChPos: PtrInt; const ASQLText, ASeparators: TGMString): TGMString; var startPos: Integer; inSquareBrackets, inSingleQuotes, inDblQuotes, inGravisQuotes: Boolean; procedure SkipSeparators; begin while (AChPos <= Length(ASQLText)) and GMIsDelimiter(ASeparators, ASQLText, AChPos) do Inc(AChPos); end; begin if AChPos < 1 then AChPos := 1; SkipSeparators; startPos := AChPos; inSquareBrackets := False; inDblQuotes := False; inSingleQuotes := False; inGravisQuotes := False; //for chPos:=1 to Length(ASQLText) do while AChPos <= Length(ASQLText) do begin case ASQLText[AChPos] of '[': inSquareBrackets := True; ']': inSquareBrackets := False; '"': inDblQuotes := not inDblQuotes; '`': inGravisQuotes := not inGravisQuotes; '''': inSingleQuotes := not inSingleQuotes; else if not (inSquareBrackets or inDblQuotes or inSingleQuotes or inGravisQuotes) and GMIsDelimiter(ASeparators, ASQLText, AChPos) then Break; end; Inc(AChPos); // AChPos := SkipSQLCommentsCharPos(AChPos+1, ASQLText); end; if AChPos > startPos then Result := System.Copy(ASQLText, startPos, AChPos-startPos) else Result := ''; //SkipSeparators; //while (AChPos <= Length(ASQLText)) and GMIsDelimiter(ASeparators, ASQLText, AChPos) do AChPos := SkipSQLCommentsCharPos(AChPos+1, ASQLText); end; function GMPreviousSQLToken(var AChPos: PtrInt; const ASQLText, ASeparators: TGMString; const ASkipTrailingSeparators: Boolean = True): TGMString; var endPos: Integer; inSquareBrackets, inSingleQuotes, inDblQuotes, inGravisQuotes: Boolean; procedure SkipSeparators; begin // AChPos := SkipSQLCommentsCharPos(AChPos, ASQLText); // cWhiteSpace while (AChPos >= 1) and GMIsDelimiter(ASeparators, ASQLText, AChPos) do Dec(AChPos); // AChPos := SkipSQLCommentsCharPos(AChPos+1, ASQLText); end; begin if AChPos > Length(ASQLText) then AChPos := Length(ASQLText); if ASkipTrailingSeparators then SkipSeparators; endPos := AChPos; inSquareBrackets := False; inDblQuotes := False; inSingleQuotes := False; inGravisQuotes := False; while AChPos >= 1 do begin case ASQLText[AChPos] of '[': inSquareBrackets := False; ']': inSquareBrackets := True; '"': inDblQuotes := not inDblQuotes; '`': inGravisQuotes := not inGravisQuotes; '''': inSingleQuotes := not inSingleQuotes; else if not (inSquareBrackets or inDblQuotes or inSingleQuotes or inGravisQuotes) and GMIsDelimiter(ASeparators, ASQLText, AChPos) then Break; end; Dec(AChPos); // AChPos := SkipSQLCommentsCharPos(AChPos+1, ASQLText); end; if AChPos < endPos then Result := System.Copy(ASQLText, AChPos+1, endPos-AChPos) else Result := ''; //SkipSeparators; //while (AChPos <= Length(ASQLText)) and GMIsDelimiter(ASeparators, ASQLText, AChPos) do AChPos := SkipSQLCommentsCharPos(AChPos+1, ASQLText); end; function GMNextSqlStatement(var AChPos: PtrInt; const ASQLText: TGMString): TGMString; begin //if not GMIsInRange(AChPos, 1, Length(ASQLText)) then begin Result := ''; Exit; end; if AChPos < 1 then AChPos := 1; while (AChPos <= Length(ASQLText)) and (ASQLText[AChPos] = cSQLStmtTerm) do Inc(AChPos); // (AChPos <= Length(ASQLText)) Result := GMNextSQLToken(AChPos, ASQLText, cSQLStmtTerm); end; function GMPreviousSqlStatement(var AChPos: PtrInt; const ASQLText: TGMString): TGMString; begin //if not GMIsInRange(AChPos, 1, Length(ASQLText)) then begin Result := ''; Exit; end; if AChPos > Length(ASQLText) then AChPos := Length(ASQLText); while (AChPos >= 1) and (ASQLText[AChPos] = cSQLStmtTerm) do Dec(AChPos); Result := GMPreviousSQLToken(AChPos, ASQLText, cSQLStmtTerm); end; function GMLastSqlStatement(const ASQLText: TGMString; const AKind: TGMSqlStatementKind): TGMString; var chPos: PtrInt; stmt: TGMString; begin chPos := Length(ASQLText); repeat stmt := GMPreviousSqlStatement(chPos, ASQLText); until (chPos < 1) or (GMSqlStatmentKind(stmt) = AKind); // (Length(stmt) <= 0) Result := stmt; end; //function GMNextSqlStatement(var AChPos: Integer; const ASqlStatements: TGMString): TGMString; //var pStart, pEnd: PGMChar; //begin //if not GMIsInRange(AChPos, 1, Length(ASqlStatements)) then begin Result := ''; Exit; end; // //while (AChPos <= Length(ASqlStatements)) and (ASqlStatements[AChPos] = ';') do Inc(AChPos); // //pStart := @ASqlStatements[AChPos]; //pEnd := GMStrLScan(pStart, ';', Length(ASqlStatements)); //if pEnd = nil then Result := ASqlStatements else // Result := Copy(ASqlStatements, AChPos, pEnd - pStart); //Inc(AChPos, Length(Result)); //end; function GMSqlStatmentKind(const ASQLText: TGMString): TGMSqlStatementKind; //const separators = cSqlSeparators + cSqlOperators; var firstToken: TGMString; chPos: PtrInt; function IsWhiteSpace(AChar: TGMChar): Boolean; begin case AChar of ' ', #9, #10, #13: Result := True; else Result := False; end; end; function ParseForFirstToken: TGMString; var chPos, resultChPos: PtrInt; inLineComment1, inLineComment2, inComment1: Boolean; lastCh, ch, nextCh: TGMChar; leadingWS: Boolean; begin Result := ''; inLineComment1 := False; inLineComment2 := False; inComment1 := False; lastCh := #0; resultChPos := 1; leadingWS := True; for chPos:=1 to Length(ASQLText) do begin ch := ASQLText[chPos]; if inLineComment1 then inLineComment1 := (ch <> #10) and (ch <> #13) else if inLineComment2 then inLineComment2 := (ch <> #10) and (ch <> #13) else if inComment1 then begin inComment1 := (lastCh <> '*') or (ch <> '/'); lastCh := ch; Continue; end else begin if chPos < Length(ASQLText) then nextCh := ASQLText[chPos+1] else nextCh := #0; case ch of '-': inLineComment1 := nextCh = '-'; '/': begin inComment1 := nextCh = '*'; inLineComment2 := nextCh = '/'; end; end; end; // Not a comment => then process it .. if not (inLineComment1 or inLineComment2 or inComment1) then begin if leadingWS then leadingWS := IsWhiteSpace(ch); if not leadingWS then if IsWhiteSpace(ch) then break else Result := Result + ch; end; lastCh := ch; end; end; begin chPos := 1; //firstToken := GMStrip(GMNextSQLToken(chPos, GMStripSQLComments(ASQLText), separators), separators); firstToken := ParseForFirstToken; if Length(firstToken) <= 0 then Result := skUnknown else //if GMSameText(firstToken, cSqlSelect) or GMSameText(firstToken, 'VALUES') or GMSameText(firstToken, 'WITH') then Result := skSelect if GMIsOneOfStrings(firstToken, [cSqlSelect, 'VALUES', 'WITH']) then Result := skSelect else if GMSameText(firstToken, cSqlSet) then Result := skSetting else if GMSameText(firstToken, cSqlExecute) then Result := skExecute else if GMSameText(firstToken, cSqlInsert) then Result := skInsert else if GMSameText(firstToken, cSqlUpdate) then Result := skUpdate else if GMSameText(firstToken, cSqlDelete) then Result := skDelete else //if GMIsOneOfStrings(firstToken, [cSqlInsert, cSqlUpdate, cSqlDelete]) then Result := skDataModify //else if GMIsOneOfStrings(firstToken, [cSqlCreate, cSqlAlter, cSqlDrop]) then Result := skDDL else Result := skUnknown; end; function GMIterateAllSqlStatements(const ASqlText: TGMString; const ASqlStmtVisitFunc: TGMSqlStmtVisitFunc; const AOpaqueAppData: Pointer): Integer; var chPos: PtrInt; sql: TGMString; begin Result := 0; if not Assigned(ASqlStmtVisitFunc) then Exit; chPos := 1; sql := ''; while chPos <= Length(ASqlText) do begin sql := GMStrip(GMNextSqlStatement(chPos, ASqlText), cWhiteSpace + cSQLStmtTerm); if Length(sql) > 0 then begin if not ASqlStmtVisitFunc(sql, AOpaqueAppData) then Break; Inc(Result); end; end; end; function GMEmptyStrAsNil(const AValue: TGMString): TGMString; begin if Length(AValue) > 0 then Result := AValue else Result := cStrNil; end; function IsSelectSQL(const ASQLText: TGMString): Boolean; begin Result := GMSqlStatmentKind(ASQLText) = skSelect; end; function GMExtractNameFromConnectionString(const AConnectionString: TGMString): TGMString; var CnStrParser: IGMValueStorage; begin CnStrParser := TGMConnectionStringStorage.Create(AConnectionString, True); Result := CnStrParser.ReadString(cStrCnStrDSN); if Result = '' then Result := CnStrParser.ReadString(cStrCnStrFileDSN); if Result = '' then Result := CnStrParser.ReadString(cSTrCnStrDatabase); if Result = '' then Result := GMExtractFileName(CnStrParser.ReadString(cStrCnStrDBQ)); if Result = '' then Result := GMExtractFileName(GMStripRight(CnStrParser.ReadString(cStrCnDir), cDirSep)); if Result = '' then Result := GMExtractFileName(GMStripRight(CnStrParser.ReadString(cStrCnDefaultDir), cDirSep)); end; function GMRecordsetAttributeName(const ARSAttribute: TGMRecordsetAttribute): TGMString; begin case ARSAttribute of raAutoSaveChanges: Result := RStrAutoSaveChanges; raAutoEdit: Result := RStrAutoEdit; raConfrimDeletions: Result := RStrConfrimDeletions; raExposeBookmarkColumn: Result := RStrExposeBookmarkColumn; raBookmarksEnabled: Result := RStrBookmarksEnabled; raStripTrailingBlanks: Result := RStrStripTrailingBlanks; else Result := ''; end; end; function GMRSOperationName(const ARSOperation: TGMRecordsetOperation): TGMString; begin case ARSOperation of roEdit: Result := RStRroEdit; roInsert: Result := RStRroInsert; roDelete: Result := RStRroDelete; roCancelChanges: Result := RStRroCancelChanges; roApplyChanges: Result := RStRroApplyChanges; roRefreshCurrent: Result := RStRroRefreshCurrent; roReExecuteStatement: Result := RStRroReExecuteStatement; roScheduleReExecution: Result := RStRroScheduleReExecution; roLeaveModifyingState: Result := RStRroLeaveModifyingState; roSetSimplestConfiguration: Result := RStRroSetSimplestConfiguration; else Result := ''; end; end; function GMSchemaListName(const ASchemList: TGMSchemaList): TGMString; begin case ASchemList of // slSystemTables: Result := RStrSystemTables; slTables: Result := RStrTables; // slViews: Result := RStrViews; slProcedures: Result := RStrProcedures; slTablePrivileges: Result := RStrTablePrivilegs; slColumnPrivileges: Result := RStrColumnPrivilegs; slStatistics: Result := RStrStatistics; slColumns: Result := RStrColumns; slProcedureColumns: Result := RStrProcedureColumns; slPrimaryKeys: Result := RStrPrimaryKeys; slForeignKeys: Result := RStrForeignKeys; slTypeInfo: Result := RStrTypeInfo; else Result := ''; end; end; function GMFieldDataTypeName(const AFieldDataType: TGMDBColumnDataType): TGMString; begin case AFieldDataType of fdtBoolean: Result := RStrfdtBit; fdtInt8: Result := RStrfdtInt8; fdtUInt8: Result := RStrfdtUInt8; fdtInt16: Result := RStrfdtInt16; fdtUInt16: Result := RStrfdtUInt16; fdtInt32: Result := RStrfdtInt32; fdtUInt32: Result := RStrfdtUInt32; fdtInt64: Result := RStrfdtInt64; fdtUInt64: Result := RStrfdtUInt64; fdtSingle: Result := RStrfdtSingle; fdtDouble: Result := RStrfdtDouble; fdtNumeric: Result := RStrfdtNumeric; fdtDate: Result := RStrfdtDate; fdtTime: Result := RStrfdtTime; fdtDateTime: Result := RStrfdtDateTime; fdtAnsiString: Result := RStrfdtAnsiString; fdtUnicodeString: Result := RStrfdtWideString; fdtAnsiText: Result := RStrfdtAnsiMemo; fdtUnicodeText: Result := RStrfdtWideMemo; fdtBinary: Result := RStrfdtBinary; fdtGUID: Result := RStrfdtGUID; else Result := ''; end; end; function GMRecordsetStateName(const ARSState: TGMRecordsetState): TGMString; begin case ARSState of rsInactive: Result := RStrrsInactive; rsBrowsing: Result := RStrrsBrowsing; rsInserting: Result := RStrrsInserting; rsEditing: Result := RStrrsEditing; else Result := RStrrsUnknown; end; end; //function GMReplaceDSNInConnectionString(const ConnectionString, NewDSN: TGMString): TGMString; ////var CnStrParser: IGMValueStorage; PIAsString: IGMGetText; //begin // //CnStrParser := TGMConnectionStringStorage.Create(ConnectionString, True); // //CnStrParser.WriteString(cStrCnStrDSN, NewDSN); // //GMCheckQueryInterface(CnStrParser, IGMGetText, PIAsString, {$I %CurrentRoutine%}); // //Result := PIAsString.AsString; // Result := GMAddOrReplaceValueInConnectionString(ConnectionString, cStrCnStrDSN, NewDSN); //end; function GMAddOrReplaceValueInConnectionString(const ConnectionString, ValueName, Value: TGMString): TGMString; var CnStrParser: IGMValueStorage; PIText: IGMGetText; begin CnStrParser := TGMConnectionStringStorage.Create(ConnectionString, True); CnStrParser.WriteString(ValueName, Value); GMCheckQueryInterface(CnStrParser, IGMGetText, PIText, {$I %CurrentRoutine%}); Result := PIText.Text; end; {function GMCompareConnectionStrings(const ConnectionStr1, ConnectionStr2: TGMString; const CompareKind: TConnectionStrCompareKind = cnpLazyMatch): Boolean; var CnStrParser1, CnStrParser2: IGMValueStorage; i: Integer; begin CnStrParser1 := TGMConnectionStringStorage.Create(ConnectionStr1, True); CnStrParser2 := TGMConnectionStringStorage.Create(ConnectionStr2, True); case CompareKind of cnpExactMatch: begin Result := True; for i:=0 to CnStrParser1.Count-1 do if GMSameText(CnStrParser1.ReadString[CnStrParser1.Names[i]], CnStrParser2.Values[CnStrParser1.Names[i]]) <> 0 then begin Result := False; Break; end; if Result then for i:=0 to CnStrParser2.Count-1 do if GMSameText(CnStrParser1.Values[CnStrParser2.Names[i]], CnStrParser2.Values[CnStrParser2.Names[i]]) <> 0 then begin Result := False; Break; end; end; cnpLazyMatch: Result := (GMSameText(CnStrParser1.Values[cStrCnStrDSN], CnStrParser2.Values[cStrCnStrDSN]) = 0) or (GMSameText(CnStrParser1.Values[cStrCnStrFileDSN], CnStrParser2.Values[cStrCnStrFileDSN]) = 0); else Result := False; end; end;} procedure SetupDSNStringBounds(const ADSN: TGMString; var C1, C2: Integer); begin C1 := Pos(':', ADSN); if C1 = 0 then C1 := 1 else Inc(C1); C2 := Pos('[', ADSN); if C2 = 0 then C2 := Length(ADSN) + 1; end; function ExtractDSNFromDisplayName(const ADSNDisplayName: TGMString): TGMString; var C1, C2: Integer; begin SetupDSNStringBounds(ADSNDisplayName, C1, C2); Result := GMStrip(Copy(ADSNDisplayName, C1, C2 - C1), cWhiteSpace + '"'); end; //function IsAggregatSelectList(const SQLSelectList: TGMString): Boolean; //var chPos: Integer; Token: TGMString; //begin //if SQLSelectList = '' then Result := False else // begin // Result := True; chPos := 1; // repeat // Token := GMFirstWord(GMNextWord(chPos, SQLSelectList, cFieldListSeparators), cSqlSeparators); // if Token <> '' then Result := Result and GMIsOneOfStrings(Token, cSqlAggregatFunctions); // until (Token = '') or not Result; // end; //end; //function GMVarTypeOfDataType(const AFieldDataType: TGMDBColumnDataType; const ACallingName: TGMString): Integer; //begin // case AFieldDataType of // fdtBoolean: Result := varBoolean; // fdtInt8: Result := varshortint; // fdtUInt8: Result := varByte; // fdtInt16: Result := varSmallInt; // fdtUInt16: Result := varWord; // fdtInt32: Result := varInteger; // fdtUInt32: Result := varLongword; // fdtInt64: Result := varInt64; // {$IFDEF DELPHI9} // fdtUInt64: Result := varQword; // {$ELSE} // fdtUInt64: Result := varInt64; // {$ENDIF} // fdtSingle: Result := varSingle; // fdtDouble, fdtNumeric: Result := varDouble; // fdtDate, fdtTime, fdtDateTime: Result := varDate; // fdtAnsiString, fdtAnsiText, fdtGUID: Result := varString; // fdtUnicodeString, fdtUnicodeText: Result := varOleStr; // else raise EGMException.ObjError(MsgUnsupportedFieldDataType(Ord(AFieldDataType)), nil, ACallingName); // end; //end; //function GMDataTypeOfVarType(const AVarType: Integer; const ACallingName: TGMString): TGMDBColumnDataType; // procedure VarTypeError; // begin // raise EGMException.ObjError(GMFormat(RStrNoFieldTypeForVarType, [VarTypeAsText(AVarType)]), nil, ACallingName); // end; //begin // if (AVarType and varArray <> 0) or (AVarType and varByRef <> 0) then VarTypeError; // // case AVarType and varTypeMask of // varNull, varEmpty: Result := fdtUnknown; // varshortint: Result := fdtInt8; // varByte: Result := fdtUInt8; // varSmallint: Result := fdtInt16; // varWord: Result := fdtUInt16; // varInteger: Result := fdtInt32; // varLongword: Result := fdtUInt32; // varInt64: Result := fdtInt64; // varString: Result := fdtAnsiString; // {$IFDEF DELPHI9} // varQword: Result := fdtUInt64; // varUString: Result := fdtUnicodeString; // {$ENDIF} // varSingle: Result := fdtSingle; // varDouble: Result := fdtDouble; // varCurrency: Result := fdtDouble; // varDate: Result := fdtDateTime; // varOleStr: Result := fdtUnicodeString; // varBoolean: Result := fdtBoolean; // varStrArg: Result := fdtGUID; // else begin VarTypeError; Result := fdtUnknown; end; // <- avoid compiler warning // end; //end; function GMUnionTypeOfDbDataType(const ADbDataType: TGMDBColumnDataType): EGMUnionValueType; begin case ADbDataType of fdtBoolean: Result := uvtBoolean; fdtInt8, fdtUInt8, fdtInt16: Result := uvtInt16; fdtUInt16, fdtInt32: Result := UvtInt32; fdtUInt32, fdtInt64: Result := uvtInt64; {$IFDEF DELPHI9} fdtUInt64: Result := uvtInt64; {$ELSE} fdtUInt64: Result := uvtInt64; {$ENDIF} fdtSingle, fdtDouble, fdtNumeric: Result := uvtDouble; fdtDate, fdtTime, fdtDateTime: Result := uvtDatetime; fdtAnsiString, fdtAnsiText, fdtGUID, fdtUnicodeString, fdtUnicodeText: Result := uvtString; fdtBinary: Result := uvtPointer; else Result := uvtUnassigned; //else raise EGMException.ObjError(MsgUnsupportedFieldDataType(Ord(ADbDataType)), nil, ACallingName); end; end; function GMDbDataTypeOfUnionType(const AValueType: EGMUnionValueType): TGMDBColumnDataType; begin case AValueType of //uvtUnassigned, uvtNull: Result := fdtUnknown; uvtString: {$IFDEF UNICODE}Result := fdtUnicodeString;{$ELSE}Result := fdtAnsiString;{$ENDIF} uvtBoolean: Result := fdtBoolean; uvtInt16: Result := fdtInt16; uvtInt32: Result := fdtInt32; uvtInt64: Result := fdtInt64; uvtDouble: Result := fdtDouble; uvtDateTime: Result := fdtDateTime; uvtPointer: Result := fdtBinary; else Result := fdtUnknown end; end; function IsUpdatableState(const State: Longword): Boolean; begin Result := State in cUpdatableStates; end; function NameAndValueMatch(const FieldName: TGMString; const FieldValue: RGMUnionValue; const MatchKind: TMatchKind = GMIntf.mkExactMatch; const MatchCase: Boolean = True): TNameAndValueMatch; //var vt: LongInt; begin //vt := VarType(FieldValue); Result.Name := FieldName; Result.Value := FieldValue; Result.MatchKind := MatchKind; Result.MatchCase := MatchCase; end; //function GMCompressedBlobHeaderData(const DataSize: LongWord = 0): TGMCompressedBlobHeaderData; //begin //Result.DataSize := DataSize; //Result.Guid := CGMBlobCompressionSignature; //Result.Reserved := 0; //end; //function GMIsCompressedBlobHeaderData(const Data: TGMCompressedBlobHeaderData): Boolean; //begin //Result := IsEqualGUID(CGMBlobCompressionSignature, Data.Guid); //end; function GMValueBufferSizeOfFieldDataType(const FieldDataType: TGMDBColumnDataType): Integer; begin case FieldDataType of fdtBoolean: Result := SizeOf(Boolean); fdtInt8, fdtUInt8: Result := SizeOf(Byte); fdtInt16, fdtUInt16: Result := SizeOf(SmallInt); fdtInt32, fdtUInt32: Result := SizeOf(LongInt); fdtInt64, fdtUInt64: Result := SizeOf(Int64); fdtSingle: Result := SizeOf(Single); fdtDouble, fdtNumeric: Result := SizeOf(Double); fdtDate, fdtTime, fdtDateTime: Result := SizeOf(TDateTime); fdtGUID: Result := SizeOf(TGUID); // fdtAnsiString, fdtUnicodeString, fdtAnsiText, fdtUnicodeText, fdtBinary: else Result := 0; end; end; function GMFieldDisplayWidth(const AFielDataType: TGMDBColumnDataType; const AMaxStrLength: PtrUInt): PtrInt; const cMaxChars = cMaxFieldDisplayWidth div cAvgCharWidth; begin case AFielDataType of fdtBoolean: Result := 6; fdtInt8, fdtUInt8: Result := 3; fdtInt16, fdtUInt16: Result := 5; fdtInt32, fdtUInt32: Result := 8; fdtInt64, fdtUInt64: Result := 10; fdtSingle: Result := 10; fdtDouble, fdtNumeric: Result := 12; fdtDate: Result := 10; fdtTime: Result := 8; fdtDateTime: Result := 15; fdtAnsiText, fdtUnicodeText: Result := cMaxChars; fdtGUID: Result := 38; fdtBinary: Result := cMaxChars; fdtAnsiString, fdtUnicodeString: if AMaxStrLength = 0 then Result := cMaxChars else Result := AMaxStrLength; // div SizeOf(AnsiChar)); // fdtUnicodeString: if ASizeInBytes = 0 then Result := cMaxChars else Result := (ASizeInBytes div SizeOf(WideChar)); else Result := cDfltFieldDisplayWidth div cAvgCharWidth; end; Result := GMBoundedInt(Result * cAvgCharWidth, cMinFieldDisplayWidth, cMaxFieldDisplayWidth); end; function GMFieldEditLength(const AFielDataType: TGMDBColumnDataType; const AMaxStrLength: PtrUInt): PtrUInt; begin case AFielDataType of fdtBoolean: Result := 6; fdtInt8, fdtUInt8: Result := 3; fdtInt16, fdtUInt16: Result := 5; fdtInt32, fdtUInt32: Result := 10; fdtInt64, fdtUInt64: Result := 20; fdtSingle: Result := 10; fdtDouble, fdtNumeric: Result := 15; fdtDate: Result := 20; fdtTime: Result := 8; fdtDateTime: Result := 30; fdtGUID: Result := 40; fdtAnsiString, fdtUnicodeString: if AMaxStrLength = 0 then Result := 0 else Result := AMaxStrLength; // fdtUnicodeString: if AMaxStrLength = 0 then Result := (ASizeInBytes div SizeOf(WideChar)) else Result := AMaxStrLength; else Result := 0; // <- Unlimited end; end; function GMCharSizeInBytes(const AFieldDataType: TGMDBColumnDataType): Word; begin case AFieldDataType of fdtAnsiString, fdtAnsiText: Result := SizeOf(AnsiChar); fdtUnicodeString, fdtUnicodeText: Result := SizeOf(WideChar); else Result := 0; end; end; function GMNullableYN(const AValue: TGMAllowNullValues): TGMString; begin case AValue of nvNullValuesNotAllowed: Result := RStrNo; nvNullValuesAllowed: Result := RStrYes; else Result := '?'; end; end; function GMNullableName(const AValue: TGMAllowNullValues): TGMString; begin case AValue of nvNullValuesAllowed: Result := RStrNullAllowed; nvNullValuesNotAllowed: Result := RStrNotNull; else Result := ''; end; end; function GMSortOrderDirectionName(const ASortOrderDirection: TGMSortOrderDirection): TGMString; begin Case ASortOrderDirection of soAscending: Result := srAscending; soDescending: Result := srDescending; else Result := ''; end; end; function GMAllowDuplicatesName(const AValue: TGMAllowDuplicates): TGMString; begin case AValue of adDuplicatesAllowed: Result := RStrDuplicatesAlloed; adDuplicatesNotAllowed: Result := RStrUnique; else Result := ''; end; end; //function DuplicateQuotes(const SQL: TGMString; const QuoteChar: TGMChar = cSqlStrQuoteChar): TGMString; //var i,j: Integer; //begin //J:=0; Result := SQL; //for i:=1 to Length(Result) do if Result[i+j] = QuoteChar then begin Insert(QuoteChar, Result, i+j); Inc(j); end; //end; function ExtractSQLSelectList(const ASQLText: TGMString): TGMString; begin Result := GMFindTextPart(ASQLText, cSqlSeparators, [cSqlSelect, cSqlUpdate, cSqlInsert, cSqlDelete], [cSqlSet, cSqlValues, cSqlFrom, cSqlLeft, cSqlRight, cSqlInner, cSqlOuter, cSqlJoin, cSqlWhere, cSqlGroupBy, cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True); end; procedure GMCheckSQLNotEmpty(const SQL: TGMString; const Caller: TObject = nil; const CallingName: TGMString = ''); begin if GMStrip(SQL, cWhiteSpace) = '' then raise EGMException.ObjError(srSQLIsEmpty, Caller, BuildCallingName(CallingName, {$I %CurrentRoutine%})); end; function GMVarToConnectionStrLiteral(const AValue: RGMUnionValue): TGMString; var pScan: PGMChar; begin Result := AValue.AsStringDflt; pScan := GMStrLScan(PGMChar(Result), ';', Length(Result)); if pScan <> nil then Result := GMQuote(Result, '{', '}'); // GMQuote(Result, '"', '"'); end; function GMStringAsSqlLiteral(const AValue: TGMString; const AQuoteChar: TGMChar): TGMString; var i,j: Integer; begin J:=0; Result := AValue; //for i:=1 to Length(Result) do if Result[i+j] = AQuoteChar then begin Insert('\', Result, i+j); Inc(j); end; for i:=1 to Length(Result) do if Result[i+j] = AQuoteChar then begin Insert(AQuoteChar, Result, i+j); Inc(j); end; Result := AQuoteChar + Result + AQuoteChar; end; function GMUnionValueAsSqlLiteral(const AValue: RGMUnionValue; ASQLFormatStrForDateTime: TGMString): TGMString; procedure Error; begin raise EGMException.ObjError(GMFormat(srInvalidSQLVariantFmt, [AValue.ValueTypeName]), nil, {$I %CurrentRoutine%}); end; begin case AValue.ValueType of uvtNull: Result := cStrNULL; uvtString: if GMIsGUID(AValue) then Result := AValue else Result := GMStringAsSqlLiteral(AValue, cSqlStrQuoteChar); uvtDateTime: if Length(ASQLFormatStrForDateTime) > 0 then Result := FormatDateTime(ASQLFormatStrForDateTime, AValue) else Result := FormatDateTime(vSQLDatTimeFmtStr, AValue); uvtDouble, uvtInt16, uvtInt32, uvtInt64, uvtBoolean: Result := AValue; //Result := GMReplaceChars(GMDeleteChars(AValue, '.'), ',', '.'); else Error; end; end; function GMObjectIsInUpdatableState(const Intf: IUnknown): Boolean; var PIState: IGMGetState; begin if Intf = nil then Result := False else Result := (Intf.QueryInterface(IGMGetState, PIState) = S_OK) and IsUpdatableState(PIState.State); end; function GMObjectCanBeEdited(const Intf: IUnknown): Boolean; var PICanExecOp: IGMCanExecuteOperation; begin if Intf = nil then Result := False else Result := GMObjectIsInUpdatableState(Intf) or ((Intf.QueryInterface(IGMCanExecuteOperation, PICanExecOp) = S_OK) and ((GMIntfIsEmpty(Intf) and PICanExecOp.CanExecuteOperation(Ord(roInsert))) or (not GMIntfIsEmpty(Intf) and PICanExecOp.CanExecuteOperation(Ord(roEdit))))); end; function GMEditOrInsertIntf(const AIntf: IUnknown): Boolean; var rsState: IGMGetState; begin Result := False; if AIntf <> nil then begin GMCheckQueryInterface(AIntf, IGMGetState, rsState, {$I %CurrentRoutine%}); Result := IsUpdatableState(rsState.State); if not Result then if GMIntfIsEmpty(AIntf) then Result := GMExecuteOperation(AIntf, Ord(roInsert)) else Result := GMExecuteOperation(AIntf, Ord(roEdit)); end; end; procedure GMCheckExecRSOperation(const Obj: TObject; const Operation: TGMRecordsetOperation; const CallingName: TGMString = ''; const Parameter: IUnknown = nil); begin GMCheckExecOperation(Obj, Ord(Operation), GMRSOperationName(Operation), CallingName, Parameter); end; procedure GMCheckExecRSOperation(const Intf: IUnknown; const Operation: TGMRecordsetOperation; const CallingName: TGMString = ''; const Parameter: IUnknown = nil); begin GMCheckExecOperation(Intf, Ord(Operation), GMRSOperationName(Operation), CallingName, Parameter); end; function ConvertStringToFieldType(const AValAsStr: TGMString; const ADbDataType: TGMDBColumnDataType): RGMUnionValue; begin case ADbDataType of fdtBoolean: Result := GMStrToBool(AValAsStr); fdtInt8, fdtUInt8, fdtInt16, fdtUInt16, fdtInt32, fdtUInt32, fdtInt64, fdtUInt64: //Result := GMStrToInt(GMMakeDezInt(AValAsStr)); Result := GMUnionValueAsType(GMMakeDezInt(AValAsStr), GMUnionTypeOfDbDataType(ADbDataType)); fdtSingle, fdtDouble, fdtNumeric: Result := StrToFloat(AValAsStr); fdtDate, fdtTime, fdtDateTime: Result := StrToDateTime(AValAsStr); fdtGUID, fdtAnsiString, fdtUnicodeString: Result := AValAsStr; else raise EGMException.ObjError(MsgUnsupportedFieldDataType(Ord(ADbDataType)), nil, {$I %CurrentRoutine%}); end; end; function RecordsetStateAfterOperation(const AOperation: TGMRecordsetOperation; const AObj: TObject = nil): TGMRecordsetState; begin case AOperation of roEdit: Result := rsEditing; roInsert: Result := rsInserting; roCancelChanges, roApplyChanges, roLeaveModifyingState, roRefreshCurrent, roReExecuteStatement, roScheduleReExecution, roDelete: Result := rsBrowsing; else raise EGMException.ObjError(MsgUnsupportedOperation(Ord(AOperation)), AObj, {$I %CurrentRoutine%}); end; end; function GMExtractNextFieldName(var AChPos: PtrInt; const FieldNames: TGMString): TGMString; begin Result := GMStrip(GMNextSQLToken(AChPos, FieldNames, cSqlSeparators + cSqlOperators), cSqlSeparators + cSqlOperators); end; function GMExtractTableName(const ASQLText: TGMString): TGMString; begin Result := GMFindTextPart(ASQLText, cSqlSeparators, [cSqlUpdate, cSqlInto, cSqlFrom], [cSqlSet, cSqlValues, cSqlLeft, cSqlRight, cSqlInner, cSqlOuter, cSqlJoin, cSqlWhere, cSqlGroupBy, cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True); end; //function GMExtractTableName(const SQL: TGMString): TGMString; //var SQLPartitioner: IGMGetTableName; //begin // SQLStrings := TStringList.Create; // try // SQLStrings.Text := SQL; // SQLPartitioner := TGMSQLStatmentPartitioner.Create(nil, SQLStrings, nil, True); // Result := SQLPartitioner.TableName; // finally // SQLStrings.Free; // end; //end; function GMBuildSQLDelete(ATableName: TGMString; const AWhere: TGMString = ''): TGMString; begin ATableName := cSqlIdQuoteCh + GMStrip(ATableName, cSqlIdQuoteCh) + cSqlIdQuoteCh; if ATableName <> '' then begin Result := GMFormat('%s %s %s', [cSqlDelete, cSqlFrom, ATableName]); if AWhere <> '' then Result := GMFormat('%s %s %s', [Result, cSqlWhere, GMStrip(AWhere, ';')]); Result := Result + ';'; end; end; function GMBuildSQLWhere(const AList: IUnknown; const AOparator: TGMString = ' AND '; const ACompare: TGMString = ' = '): TGMString; var i: Integer; PICount: IGMGetCount; PIIntfByPosition: IGMGetIntfByPosition; PIName: IGMGetName; PIValue: IGMGetUnionValue; begin GMCheckQueryInterface(AList, IGMGetCount, PICount, {$I %CurrentRoutine%}); GMCheckQueryInterface(AList, IGMGetIntfByPosition, PIIntfByPosition, {$I %CurrentRoutine%}); Result := ''; for i:=0 to PICount.Count-1 do begin GMCheckGetIntfByPosition(PIIntfByPosition, i, IGMGetName, PIName, srCollectionelement, {$I %CurrentRoutine%}); GMCheckGetIntfByPosition(PIIntfByPosition, i, IGMGetUnionValue, PIValue, srCollectionelement, {$I %CurrentRoutine%}); if PIValue.Value.IsNullOrUnassigned then Result := GMStringJoin(Result, AOparator, GMFormat('(%s IS NULL)', [PIName.Name])) else Result := GMStringJoin(Result, AOparator, GMFormat('(%s%s%s)', [PIName.Name, ACompare, GMUnionValueAsSqlLiteral(PIValue.Value)])); end; end; function GMConfirmDeletion(const Container: IUnknown; ConfirmQuestion: TGMString): Boolean; begin if Container = nil then Result := False else begin if ConfirmQuestion = '' then ConfirmQuestion := srConfirmRecordDeletion + '?'; Result := not GMAskBoolean(Container, Ord(bvConfirmDeletions), True) or (vfGMMessageBox(ConfirmQuestion, svConfirmation, mb_YesNo) = IdYes); end; end; procedure GMDoDeletion(const AContainer: IUnknown; const ASelection: IUnknown); var PISelectedCount: IGMGetCount; PISelectedPositions: IGMMapIntegerOnInteger; PISourcePosition: IGMGetSetPosition; procedure ClearSelection; var clearSel: IGMClear; begin if GMQueryInterface(ASelection, IGMClear, clearSel) then clearSel.Clear; end; procedure DeleteOne; begin if GMConfirmDeletion(AContainer, '') then GMCheckExecRSOperation(AContainer, roDelete, {$I %CurrentRoutine%}); end; procedure DeleteMultiple; var i: Integer; mousePtrWait: IUnknown; PIEnableNotify: IGMEnableNotifications; ReExecutionneeded: Boolean; begin //GMCheckQueryInterface(AContainer, IGMEnableNotifications, PIEnableNotify, {$I %CurrentRoutine%}); AContainer.QueryInterface(IGMEnableNotifications, PIEnableNotify); if GMConfirmDeletion(AContainer, GMFormat(srConfirmMultipleDelete + '?', [PISelectedCount.Count])) then begin mousePtrWait := TGMTempCursor.Create(vDBWaitCursor); ReExecutionneeded := False; if PIEnableNotify <> nil then PIEnableNotify.DisableNotifications; try for i:=PISelectedCount.Count-1 downto 0 do begin PISourcePosition.Position := PISelectedPositions.MapIntegerOnInteger(i); try GMCheckExecRSOperation(AContainer, roDelete, {$I %CurrentRoutine%}); ReExecutionneeded := True; except on E: Exception do if not GMAskExceptionContinue(E, eaAskUser, srAskContinueDeletion) then raise; else raise; end; end; ClearSelection; finally if PIEnableNotify <> nil then PIEnableNotify.EnableNotifications(CEnableNotify[ReExecutionneeded]); end; end; end; begin if AContainer = nil then Exit; if //(ASelection <> nil) and //(GMGetPropIntfFromIntf(ASelection, cStrSelectedPositions, IGMGetCount, PISelectedCount) = S_OK) and (PISelectedCount.Count > 1) and GMQueryInterface(ASelection, IGMGetCount, PISelectedCount) and (PISelectedCount.Count > 1) and (PISelectedCount.QueryInterface(IGMMapIntegerOnInteger, PISelectedPositions) = S_OK) and (AContainer.QueryInterface(IGMGetSetPosition, PISourcePosition) = S_OK) then DeleteMultiple else DeleteOne; end; procedure GMDeleteCascaded(const Container: IUnknown); var PICascade: IGMCascadedContentsProperties; begin if (Container <> nil) and (GMGetPropIntfFromIntf(Container, cStrCascadePropertyName, IGMCascadedContentsProperties, PICascade) = S_OK) and PICascade.ConfigurationIsValid then GMDeleteCascaded(Container, PICascade.KeyValueName, PICascade.ParentReferenceValueName); end; procedure GMDeleteCascaded(const Container: IUnknown; const KeyValueName, ParentRefValueName: TGMString); var PIEnableNotify: IGMEnableNotifications; ReExecutionneeded: Boolean; mousePtrWait: IUnknown; procedure DeleteItem(const SubContainer: IUnknown); var PICount: IGMGetCount; PIGetSubItems: IGMGetSubItems; begin //if SubContainer = nil then Exit; GMCheckQueryInterface(SubContainer, IGMGetSubItems, PIGetSubItems, {$I %CurrentRoutine%}); GMHrCheckIntf(PIGetSubItems.GetSubItems(ParentRefValueName, GMCheckGetItemValue(SubContainer, KeyValueName, {$I %CurrentRoutine%}), IGMGetCount, PICount), SubContainer, {$I %CurrentRoutine%}); //GMCheckExecRSOperation(PICount, roSetSimplestConfiguration, {$I %CurrentRoutine%}); <- readonly! GMSetIntfActive(PICount, True, {$I %CurrentRoutine%}); while PICount.Count > 0 do try DeleteItem(PICount); except on E: Exception do if not GMAskExceptionContinue(E, eaAskUser, srAskContinueDeletion) then raise; else raise; end; GMCheckExecRSOperation(SubContainer, roDelete, {$I %CurrentRoutine%}); ReExecutionneeded := True; end; begin if (Container = nil) or (KeyValueName = '') or (ParentRefValueName = '') or not GMIntfIsActive(Container) then Exit; Container.QueryInterface(IGMEnableNotifications, PIEnableNotify); if GMConfirmDeletion(Container, srConfirmDeleteCascaded) then begin mousePtrWait := TGMTempCursor.Create(vDBWaitCursor); if PIEnableNotify <> nil then PIEnableNotify.DisableNotifications; try ReExecutionneeded := False; DeleteItem(Container); finally if PIEnableNotify <> nil then PIEnableNotify.EnableNotifications(CEnableNotify[ReExecutionneeded]); end; end; end; procedure GMInsertChild(const Container: IUnknown); var PICascade: IGMCascadedContentsProperties; ParentKey: RGMUnionValue; begin if (GMGetPropIntfFromIntf(Container, cStrCascadePropertyName, IGMCascadedContentsProperties, PICascade) = S_OK) and PICascade.ConfigurationIsValid then begin ParentKey := GMCheckGetItemValue(Container, PICascade.KeyValueName, {$I %CurrentRoutine%}); GMCheckExecRSOperation(Container, roInsert, {$I %CurrentRoutine%}, PICascade); GMCheckSetItemValue(Container, PICascade.ParentReferenceValueName, ParentKey, {$I %CurrentRoutine%}); end; end; function GMLookupValues(const Container, Values: IUnknown; const SQLCriteria: TGMString; const GlobalLookup: Boolean = True): Boolean; var PIValueCount: IGMGetCount; PILookupRS: IUnknown; function DoLookupValues: Boolean; // Own Scope for Interface Pointers var i: Integer; PIUniCursor: IGMUnidirectionalCursor; PIFieldIntfByName: IGMGetIntfByName; PIFieldValue: IGMGetUnionValue; PISql: IGMSqlStatementParts; PIIntfByPos: IGMGetIntfByPosition; PIValue: IGMGetSetUnionValue; PIValueName: IGMGetName; begin if (PILookupRS.QueryInterface(IGMUnidirectionalCursor, PIUniCursor) = S_OK) and (PILookupRS.QueryInterface(IGMGetIntfByName, PIFieldIntfByName) = S_OK) and (GMGetPropIntfFromIntf(PILookupRS, cStrSQL, IGMSqlStatementParts, PISql) = S_OK) and (Values.QueryInterface(IGMGetIntfByPosition, PIIntfByPos) = S_OK) then begin GMCheckExecRSOperation(PILookupRS, roSetSimplestConfiguration, {$I %CurrentRoutine%}); if GlobalLookup or (PISql.SQLWhere = '') then PISql.SQLWhere := SQLCriteria else PISql.SQLWhere := GMFormat('(%s) AND (%s)', [PISql.SQLWhere, SQLCriteria]); GMSetIntfActive(PILookupRS, True, {$I %CurrentRoutine%}); if GMIntfIsEmpty(PILookupRS) then begin for i:=0 to PIValueCount.Count-1 do if (PIIntfByPos.GetIntfByPosition(i, IGMGetSetUnionValue, PIValue) = S_OK) then PIValue.Value := uvtNull; Result := False; end else begin for i:=0 to PIValueCount.Count-1 do if (PIIntfByPos.GetIntfByPosition(i, IGMGetSetUnionValue, PIValue) = S_OK) then if (PIIntfByPos.GetIntfByPosition(i, IGMGetName, PIValueName) = S_OK) and (PIFieldIntfByName.GetIntfByName(PIValueName.Name, IGMGetUnionValue, PIFieldValue) = S_OK) then PIValue.Value := PIFieldValue.Value else PIValue.Value := uvtNull; Result := True; end; end else Result := False; end; begin Result := False; if (SQLCriteria <> '') and (Values <> nil) and (Values.QueryInterface(IGMGetCount, PIValueCount) = S_OK) and (PIValueCount.Count > 0) and (Container <> nil) and (GMCreateCopyQI(Container, IUnknown, PILookupRS) = S_OK) then Result := DoLookupValues; end; function GMLookupValue(const Container: IUnknown; const ValueName, SQLCriteria: TGMString; const GlobalLookup: Boolean = True): RGMUnionValue; var LookupValues: IGMObjArrayCollection; begin Result := uvtNull; LookupValues := TGMNamedValueCollection.Create([ValueName]); if GMLookupValues(Container, LookupValues, SQLCriteria, GlobalLookup) then Result := GMGetItemValue(LookupValues, 0); end; function GMReplaceSqlValue(const SQLPart, FieldName, OpInner, OpOuter: TGMString; const FieldValue: RGMUnionValue): TGMString; const CSep = cSqlSeparators + cSqlOperators; var chPos: PtrInt; function BuildClause: TGMString; begin if FieldValue.IsNullOrUnassigned then Result := GMFormat('%s IS NULL', [FieldName]) else Result := GMFormat('%s %s %s', [FieldName, GMStrip(OpInner, cWhiteSpace), GMUnionValueAsSqlLiteral(FieldValue)]); end; begin Result := SQLPart; chPos := 1; if GMFindToken(Result, FieldName, chPos, CSep) then begin // needs a space between operator and value .. while not GMIsDelimiter(CSep, Result, chPos) and (Length(Result) >= chPos) do Delete(Result, chPos, 1); while GMIsDelimiter(cSqlSeparators, Result, chPos) and (Length(Result) >= chPos) do Delete(Result, chPos, 1); while not GMIsDelimiter(cSqlSeparators, Result, chPos) and (Length(Result) >= chPos) do Delete(Result, chPos, 1); while GMIsDelimiter(cSqlSeparators, Result, chPos) and (Length(Result) >= chPos) do Delete(Result, chPos, 1); while not GMIsDelimiter(cSqlSeparators, Result, chPos) and (Length(Result) >= chPos) do Delete(Result, chPos, 1); //while not GMIsDelimiter(CSep, Result, chPos) and (Length(Result) >= chPos) do Delete(Result, chPos, 1); //while GMIsDelimiter(CSep, Result, chPos) and (Length(Result) >= chPos) do Delete(Result, chPos, 1); //while not GMIsDelimiter(CSep, Result, chPos) and (Length(Result) >= chPos) do Delete(Result, chPos, 1); Insert(BuildClause, Result, chPos); end else Result := GMStringJoin(GMStrip(Result, cWhiteSpace), ' ' + GMStrip(OpOuter, cWhiteSpace) + ' ', '(' + BuildClause + ')'); end; function GetSqlIdQuoteChFromConnection(const AConnection: IUnknown): TGMString; var syntaxElements: RGMTypedIntf<IGMSqlSyntaxElements>; begin //if GMQueryInterface(AConnection, IGMSqlSyntaxElements, syntaxElements) then if syntaxElements.QueryFrom(AConnection) then Result := syntaxElements.Intf.SqlIdentifierQuoteChar else Result := ''; // cSqlIdQuoteCh; end; function GetSqlIdQuoteChFromStatement(const AStatement: IUnknown): TGMString; var intfSrc: RGMTypedIntf<IGMGetInterfaceSource>; begin //if GMQueryInterface(AStatement, IGMGetInterfaceSource, intfSrc) then if intfSrc.QueryFrom(AStatement) then Result := GetSqlIdQuoteChFromConnection(intfSrc.Intf.InterfaceSource) else Result := ''; end; //function GMExecSqlSelectCount(const AStatement: IUnknown; const ASqlText: TGMString): RGMUnionValue; //var setSqlText: IGMGetSetText; //ActiveKeeper: IUnknown; //begin // Result := uvtNull; // if (Length(ASqlText) > 0) and (AStatement <> nil) then // try //// ATableName := cSqlIdQuoteCh + GMStrip(ATableName, cSqlIdQuoteCh) + cSqlIdQuoteCh; // GMSetIntfActive(AStatement, False); //// ActiveKeeper := TGMActiveKeeper.Create(AStatement, False); // if GMGetPropIntfFromIntf(AStatement, cStrSQL, IGMGetSetText, setSqlText) = S_OK then // begin // setSqlText.Text := ASqlText; // GMBuildSelectCountSQL(ATableName, GetSqlIdQuoteChFromStatement(AStatement), AWhereClause); // GMSetIntfActive(AStatement, True); // Result := GMGetItemValue(AStatement, 1); // <- Result of select count(*) will always be first field in first record! // end; // except // on ex: TObject do begin GMTraceException(ex); Result := uvtNull; end; // end; //end; function GMGetSubItemsBySQL(const Container: IUnknown; const ParentFieldName: TGMString; ParentFieldValue: RGMUnionValue; const IID: TGUID; out Intf): HResult; var clone: IUnknown; sqlParts: IGMSqlStatementParts; begin if (Container = nil) or (ParentFieldName = '') then begin Result := E_INVALIDARG; Exit; end; Result := GMCreateCopyQI(Container, IUnknown, clone); if Result <> S_OK then Exit; Result := clone.QueryInterface(IID, Intf); if Result <> S_OK then Exit; try Result := GMGetPropIntfFromIntf(clone, cStrSQL, IGMSqlStatementParts, sqlParts); if Result <> S_OK then Exit; sqlParts.SQLWhere := GMReplaceSqlValue(sqlParts.SQLWhere, ParentFieldName, cStrEqual, cStrAnd, ParentFieldValue); Result := S_OK; finally if Result <> S_OK then IUnknown(Intf) := nil; // <- release early if not successful end; end; function GMBuildContentsString(const Source: IUnknown; const FieldNames: TGMStringArray; SelectionSource: IUnknown = nil; const IncludeTitles: Boolean = True; const ColumnSeparator: TGMString = cDfltColumnSeparator; const RowSeparator: TGMString = cDfltRowSeparator): TGMString; var PINotify: IGMEnableNotifications; PIState: IGMSaveRestoreState; PISourcePosition: IGMGetSetPosition; PIFieldIntf: IGMGetIntfByName; PISelectedCount: IGMGetCount; SaveState: IUnknown; mousePtrWait: IUnknown; procedure AddTitleRow; var i: Integer; RowStr: TGMString; begin RowStr := ''; for i := Low(FieldNames) to High(FieldNames) do RowStr := RowStr + FieldNames[i] + ColumnSeparator; RowStr := GMStrip(RowStr, ColumnSeparator); if RowStr <> '' then Result := Result + RowStr + RowSeparator; end; procedure AddCurrentPosition; var i: Integer; RowStr: TGMString; PIText: IGMGetText; begin RowStr := ''; for i := Low(FieldNames) to High(FieldNames) do if (PIFieldIntf.GetIntfByName(FieldNames[i], IGMGetText, PIText) = S_OK) then RowStr := RowStr + PIText.Text + ColumnSeparator; RowStr := GMStrip(RowStr, ColumnSeparator); if RowStr <> '' then Result := Result + RowStr + RowSeparator; end; procedure AddAllPositions; var i: Integer; PISourceCount: IGMGetCount; begin GMCheckQueryInterface(Source, IGMGetCount, PISourceCount, {$I %CurrentRoutine%}); for i:=1 to PISourceCount.Count do begin PISourcePosition.Position := i; AddCurrentPosition; end; end; procedure AddSelectedPositions; var i: Integer; PISelectedPositions: IGMMapIntegerOnInteger; begin GMCheckQueryInterface(PISelectedCount, IGMMapIntegerOnInteger, PISelectedPositions, {$I %CurrentRoutine%}); for i:=0 to PISelectedCount.Count-1 do begin PISourcePosition.Position := PISelectedPositions.MapIntegerOnInteger(i); AddCurrentPosition; end; end; begin if (Source <> nil) and (Length(FieldNames) > 0) then begin if SelectionSource = nil then SelectionSource := Source; Source.QueryInterface(IGMEnableNotifications, PINotify); //GMCheckQueryInterface(Source, IGMEnableNotifications, PINotify, {$I %CurrentRoutine%}); GMCheckQueryInterface(Source, IGMSaveRestoreState, PIState, {$I %CurrentRoutine%}); GMCheckQueryInterface(Source, IGMGetIntfByName, PIFieldIntf, {$I %CurrentRoutine%}); GMCheckQueryInterface(Source, IGMGetSetPosition, PISourcePosition, {$I %CurrentRoutine%}); mousePtrWait := TGMTempCursor.Create(vDBWaitCursor); if PINotify <> nil then PINotify.DisableNotifications; try SaveState := PIState.CaptureState; try GMCheckExecRSOperation(Source, roLeaveModifyingState, {$I %CurrentRoutine%}); if IncludeTitles then AddTitleRow; if //(SelectionSource <> nil) and //(GMGetPropIntfFromIntf(SelectionSource, cStrSelectedPositions, IGMGetCount, PISelectedCount) = S_OK) and GMQueryInterface(SelectionSource, IGMGetCount, PISelectedCount) and (PISelectedCount.Count > 0) then AddSelectedPositions else AddAllPositions; Result := GMStrip(Result, ColumnSeparator + RowSeparator); finally PIState.RestoreState(SaveState); end; finally if PINotify <> nil then PINotify.EnableNotifications; end; end; end; function GMFindSortOrderPos(const AFieldName, ASQLOrderBy: TGMString; var AChPos: PtrInt): PtrInt; const cStrDesc: TGMString = 'DESC'; // cStrAsc: TGMString = 'ASC'; var chPos1, chPos2: PtrInt; clause, sortOrder, token: TGMString; function NextClause: TGMString; begin // Result := GMNextWord(chPos1, ASQLOrderBy, cFieldListSeparators); Result := GMNextSQLToken(chPos1, ASQLOrderBy, cFieldListSeparators); Result := GMStrip(Result, cSqlWhiteSpace + cFieldListSeparators); end; begin Result := 0; chPos1 := 1; clause := NextClause; while clause <> '' do begin chPos2 := 1; Inc(Result); token := GMstripRight(GMStripLeft(GMNextSQLToken(chPos2, clause, cSqlSeparators), '["`'), ']"`'); if GMSameText(token, AFieldName) then begin sortOrder := GMNextSQLToken(chPos2, clause, cSqlSeparators); if GMSameText(sortOrder, cStrDesc) then Result := -Result; Exit; // <- NOTE: Exit here! end; AChPos := chPos1; clause := NextClause; end; Result := 0; // <- will be skipped by Exit statement! end; function GMFindSortOrder(const AFieldName, ASQLOrderBy: TGMString): LongInt; var chPos: PtrInt; begin chPos := 1; Result := GMFindSortOrderPos(AFieldName, ASQLOrderBy, chPos); end; function GMSetSortOrder(const AFieldName: TGMString; const ASortOrder: LongInt; const ASQLOrderBy: TGMString; const ACumulative: Boolean): TGMString; var startChPos, endChPos: PtrInt; comma, sortToken: TGMString; begin startChPos := 1; comma := ','; Result := ASQLOrderBy; if not ACumulative then Result := '' else begin GMFindSortOrderPos(AFieldName, Result, startChPos); endChPos := startChPos; GMNextSQLToken(endChPos, Result, cFieldListSeparators); Delete(Result, startChPos, endChPos - startChPos); if startChPos <= Length(Result) then comma := ''; Result := GMStrip(Result, cFieldListSeparators); end; if ASortOrder <> 0 then begin if ASortOrder < 0 then sortToken := cSqlDesc else sortToken := cSqlAsc; Insert(GMFormat('%s %s %s,', [comma, GMSqlQuoteIdentifierIfNeeded(AFieldName), sortToken]), Result, startChPos); end; Result := GMStrip(Result, cFieldListSeparators + cWhiteSpace); end; function GMSqlIdentifierNeedsQuotation(const AIdentifier: TGMString): Boolean; var chPos: Integer; begin Result := False; for chPos:=1 to Length(AIdentifier) do case AIdentifier[chPos] of 'a' .. 'z', 'A' .. 'Z', '0' .. '9', '_', '.': ; // <- Nothing! else Exit(True); end; end; function GMSqlQuoteIdentifierIfNeeded(const AIdentifier: TGMString; const AIdQuoteChar: TGMString = cSqlIdQuoteCh): TGMString; begin if (Length(AIdQuoteChar) > 0) and GMSqlIdentifierNeedsQuotation(AIdentifier) then Result := AIdQuoteChar + GMStrip(AIdentifier, AIdQuoteChar) + AIdQuoteChar else Result := AIdentifier; //Result := AIdentifier; //if (Length(AIdQuoteChar) > 0) and GMSqlIdentifierNeedsQuotation(Result) then // Result := AIdQuoteChar + GMStrip(Result, AIdQuoteChar) + AIdQuoteChar; end; function GMBuildSelectAllSQL(ATableName: TGMString; const AIdQuoteChar, AOrderBy: TGMString): TGMString; begin if GMSqlIdentifierNeedsQuotation(ATableName) then ATableName := AIdQuoteChar + GMStrip(ATableName, AIdQuoteChar) + AIdQuoteChar; if Length(AOrderBy) <= 0 then Result := GMFormat(cSqlSelectAllFmt, [ATableName]) + ';' else Result := GMFormat('%s * %s %s %s %s %s;', [cSqlSelect, cSqlFrom, ATableName, cSqlOrderBy, AOrderBy, cSqlAsc]); end; function GMBuildSelectCountSQL(ATableName: TGMString; const AIdQuoteChar: TGMString; const AWhereClause: TGMString): TGMString; begin ATableName := GMSqlQuoteIdentifierIfNeeded(ATableName, AIdQuoteChar); Result := GMFormat(cSqlSelectCountFmt, [ATableName]); if Length(AWhereClause) > 0 then Result := Result + cNewLine + cSqlWhere + ' ' + AWhereClause; end; function GMStripSQLOrderBy(const ASqlText: TGMString; var AChPos: PtrInt): TGMString; var token: TGMString; tokenStartPos, orderStartChPos, resultChPos: PtrInt; inOrderBy: Boolean; // , lastToken procedure AppendToken(AEndChPos: PtrInt); // (AStartChPos: PtrInt); var len: PtrInt; begin len := AEndChPos - tokenStartPos; if len > 0 then begin System.Move(ASqlText[tokenStartPos], Result[resultChPos], len * SizeOf(TGMChar)); Inc(resultChPos, len); end; //for i:=tokenStartPos to AEndChPos-1 do // Result += ASqlText[i]; // begin Result[resultChPos] := ASqlText[i]; Inc(resultChPos); end; end; begin //Result := ''; Setlength(Result, Length(ASqlText)); resultChPos := 1; inOrderBy := False; orderStartChPos := -1; repeat tokenStartPos := AChPos; token := GMNextSQLToken(AChPos, ASqlText, cSqlSeparators + cSqlOperators); if (orderStartChPos > 0) and GMSameText(token, 'BY') then inOrderBy := True; if not inOrderBy then begin if GMSameText(token, 'ORDER') then begin orderStartChPos := tokenStartPos; AppendToken(AChPos - Length(token)); end else orderStartChPos := -1; if orderStartChPos < 0 then AppendToken(AChPos); end else if GMSameText(token, 'LIMIT') then begin AppendToken(AChPos); orderStartChPos := -1; inOrderBy := False; end; //lastToken := token; // lastLastChPos := tokenStartPos; until Length(token) <= 0; SetLength(Result, resultChPos - 1); end; function GMModifyToSelectCountSQL(const ASqlText: TGMString; const ACaller: TObject): TGMString; var chPos: PtrInt; strippedSQL, token: TGMString; stmtKind: TGMSqlStatementKind; sqlParts: TGMSqlProperty; // firstToken: Boolean; begin Result := ''; chPos := 1; strippedSQL := GMStripRight(GMStripSQLOrderBy(GMStrip(GMStripSQLComments(ASqlText)), chPos), ';'); stmtKind := GMSqlStatmentKind(strippedSQL); case stmtKind of skSelect, skDelete: begin chPos := 1; repeat token := GMNextSQLToken(chPos, strippedSQL, cSqlSeparators + cSqlOperators); if GMSameText(token, cSqlFrom) then Exit('SELECT Count(*) FROM ' + System.Copy(strippedSQL, chPos, Length(strippedSQL) - chPos + 1) + ';') else if GMIsOneOfStrings(token, ['AVG', 'SUM', 'MIN', 'MAX', 'COUNT']) then Exit('SELECT Count(*) FROM ('+ GMStripRight(strippedSQL, ';'+cWhiteSpace) +');'); until Length(token) <= 0; end; skUpdate: begin sqlParts := TGMSqlProperty.Create(nil, strippedSQL, nil, False); try Exit('SELECT Count(*) FROM ' + sqlParts.TableName + ' WHERE ' + sqlParts.SQLWhere + ';'); finally sqlParts.Free; end; end; end; raise EGMException.ObjError(srUnableBuildCountSQL+': '+strippedSQL, ACaller, {$I %CurrentRoutine%}); end; function GMCalcParamCount(const SQLString: TGMString): SmallInt; var chPos: PtrInt; begin chPos := 1; Result := 0; while GMFindToken(SQLString, cSqlParamMarker, chPos, cSqlSeparators + cSqlOperators) do begin Inc(Result); Inc(chPos, Length(cSqlParamMarker)); end; end; function GMExtractQualifier(const QualifiedName: TGMString; var chPos: PtrInt; var Qualifier: TGMString; const Separators: TGMString = cSqlQualSep): Boolean; begin Qualifier := GMNextWord(chPos, QualifiedName, Separators, False); Result := Qualifier <> ''; end; function GMSplitQualifiedName(const QualifiedName: TGMString; var Qualifier, FieldName: TGMString): Boolean; var chPos: PtrInt; begin chPos:=1; Result := GMExtractQualifier(QualifiedName, chPos, Qualifier) and GMExtractQualifier(QualifiedName, chPos, FieldName); end; { ---------------------------- } { ---- RGMQualifiedDBName ---- } { ---------------------------- } function GMInitRQualifiedDBName(const AElementName: TGMString; const ACatalogName: TGMString = ''; const ASchemaName: TGMString = ''): RGMQualifiedDBName; begin Result.CatalogName := ACatalogName; Result.SchemaName := ASchemaName; Result.TableName := AElementName; end; function RGMQualifiedDBName.QualifiedName(const ASeparator: TGMString): TGMString; begin Result := GMStringJoin(CatalogName, ASeparator, GMStringJoin(SchemaName, ASeparator, TableName)); end; function RGMQualifiedDBName.CompareTo(const AOtherQName: RGMQualifiedDBName): TGMCompareResult; // TGMCompareResult = (crALessThanB, crAEqualToB, crAGreaterThanB); function IsWildCard(const AValue: TGMString): Boolean; inline; begin Result := (AValue = '') or (AValue = '*') or (AValue = '%'); end; function CompareParts(const APart, AOtherPart: TGMString): TGMCompareResult; inline; begin if IsWildCard(APart) or IsWildCard(AOtherPart) then Result := crAEqualToB else Result := GMCompareNames(APart, AOtherPart); end; begin Result := CompareParts(CatalogName, AOtherQName.CatalogName); if Result = crAEqualToB then begin Result := CompareParts(SchemaName, AOtherQName.SchemaName); if Result = crAEqualToB then Result := CompareParts(TableName, AOtherQName.TableName); end; end; function GMBuildQualifiedDBName(const AElementName, ACatalogName, ASchemaName, ASeparator: TGMString): TGMString; begin Result := GMInitRQualifiedDBName(AElementName, ACatalogName, ASchemaName).QualifiedName(ASeparator); end; function GMCompareQualifiedDBName(const AQNameA, AQNameB: RGMQualifiedDBName): TGMCompareResult; begin //Result := GMCompareNames(AQNameA.QualifiedName, AQNameB.QualifiedName); Result := AQNameA.CompareTo(AQNameB); end; function GMSplitSqlQualifiedName(const AQualifiedName: TGMString; const ASeparatorChar: TGMChar): RGMQualifiedDBName; var chPos: PtrInt; procedure SkipSeparator; begin if (chPos >= 1) and (AQualifiedName[chPos] = ASeparatorChar) then Dec(chPos); end; begin chPos := Length(AQualifiedName); Result.TableName := GMPreviousSQLToken(chPos, AQualifiedName, ASeparatorChar + cSqlWhiteSpace, False); SkipSeparator; Result.SchemaName := GMPreviousSQLToken(chPos, AQualifiedName, ASeparatorChar + cSqlWhiteSpace, False); SkipSeparator; Result.CatalogName := GMPreviousSQLToken(chPos, AQualifiedName, ASeparatorChar + cSqlWhiteSpace, False); end; { ------------------------------ } { ---- Field List Notifyers ---- } { ------------------------------ } procedure GMNotifyFieldsBeforePositionChange(const AFieldList: TGMObjArrayCollection); var i: Integer; // notifySink: IGMPositionChangeNotifications; begin if AFieldList <> nil then for i:=0 to AFieldList.Count-1 do (AFieldList[i] as TGMDBField).BeforePositionChange; //if GMGetInterface(AFieldList[i], IGMPositionChangeNotifications, notifySink) then // notifySink.BeforePositionChange; end; procedure GMNotifyFieldsAfterPositionChange(const AFieldList: TGMObjArrayCollection); var i: Integer; // notifySink: IGMPositionChangeNotifications; begin if AFieldList <> nil then for i:=0 to AFieldList.Count-1 do try (AFieldList[i] as TGMDBField).AfterPositionChange; except end; //if GMGetInterface(AFieldList[i], IGMPositionChangeNotifications, notifySink) then // try notifySink.AfterPositionChange; except {on E: EGMOdbcError do raise;} end; end; procedure GMNotifyFieldsBeforeOperation(const AFieldList: TGMObjArrayCollection; const AOperation: Integer; const AParameter: IUnknown); var i: Integer; // notifySink: IGMOperationNotifications; begin if AFieldList <> nil then for i:=0 to AFieldList.Count-1 do (AFieldList[i] as TGMDBField).BeforeOperation(AOperation, AParameter); //if GMGetInterface(AFieldList[i], IGMOperationNotifications, notifySink) then // notifySink.BeforeOperation(AOperation, AParameter); end; procedure GMNotifyFieldsAfterOperation(const AFieldList: TGMObjArrayCollection; const AOperation: Integer; const AParameter: IUnknown); var i: Integer; // notifySink: IGMOperationNotifications; begin if AFieldList <> nil then for i:=0 to AFieldList.Count-1 do try (AFieldList[i] as TGMDBField).AfterOperation(AOperation, AParameter); except end; //if GMGetInterface(AFieldList[i], IGMOperationNotifications, notifySink) then // try notifySink.AfterOperation(AOperation, AParameter); except {on E: EGMOdbcError do raise;} end; end; procedure GMNotifyFieldsBeforeActiveChange(const AFieldList: TGMObjArrayCollection; const ANewActive: Boolean); var i: Integer; // notifySink: IGMActiveChangeNotifications; begin if AFieldList <> nil then for i:=0 to AFieldList.Count-1 do (AFieldList[i] as TGMDBField).BeforeActiveChange(ANewActive); //if GMGetInterface(AFieldList[i], IGMActiveChangeNotifications, notifySink) then // notifySink.BeforeActiveChange(ANewActive); end; procedure GMNotifyFieldsAfterActiveChange(const AFieldList: TGMObjArrayCollection; const ANewActive: Boolean); var i: Integer; // notifySink: IGMActiveChangeNotifications; begin if AFieldList <> nil then for i:=0 to AFieldList.Count-1 do try (AFieldList[i] as TGMDBField).AfterActiveChange(ANewActive); except end; //if GMGetInterface(AFieldList[i], IGMActiveChangeNotifications, notifySink) then // try notifySink.AfterActiveChange(ANewActive); except {on E: EGMOdbcError do raise;} end; end; { ------------------------------------------ } { ---- Recordset Attributes conversions ---- } { ------------------------------------------ } function RSAttributesToLongWord(const Value: TGMRecordsetAttributes): Longword; var i: TGMRecordsetAttribute; begin Result := 0; for i:=Low(i) to High(i) do if i in Value then Result := Result or Longword(1 shl Ord(i)); end; function RSAttributesFromLongWord(const Value: Longword): TGMRecordsetAttributes; var i: TGMRecordsetAttribute; begin Result := []; for i:=Low(i) to High(i) do if Value and (1 shl Ord(i)) <> 0 then Include(Result, i); end; { ------------------------------------- } { ---- Schema Root Lists converions---- } { ------------------------------------- } function SchemaListsToLongWord(const Value: TGMSchemaLists): Longword; var i: TGMSchemaList; begin Result := 0; for i:=Low(i) to High(i) do if i in Value then Result := Result or Longword(1 shl Ord(i)); end; function SchemaListsFromLongWord(const Value: Longword): TGMSchemaLists; var i: TGMSchemaList; begin Result := []; for i:=Low(i) to High(i) do if Value and (1 shl Ord(i)) <> 0 then Include(Result, i); end; { ----------------------------- } { ---- TGMFieldValueBuffer ---- } { ----------------------------- } constructor TGMFieldValueBuffer.CreateFieldBuffer(const AOwner: TObject; const ADataType: TGMDBColumnDataType; const AColumnPosition: LongInt; const AFieldName: TGMString; const ASizeInBytes: PtrUInt; const AMaxStrLength: PtrUInt; const AStatementHandle: THandle); begin FColumnPosition := AColumnPosition; FieldName := AFieldName; SizeInBytes := ASizeInBytes; StatementHandle := AStatementHandle; FMaxStrLength := AMaxStrLength; Create(AOwner, ADataType, False, True, False); // <- "inherited Create" would not call virtual overriden versions of create end; { -------------------- } { ---- TGMDBField ---- } { -------------------- } constructor TGMDBField.Create(const AOwner: TObject; const ACreateData: RGMFieldCreateData); var bi: EGMValueBufferInstance; begin inherited Create(False); FOwner := AOwner; FCreateData := ACreateData; for bi:=Low(bi) to High(bi) do FValueBufferIdxMap[bi] := bi; end; destructor TGMDBField.Destroy; begin FreeValueBuffers; inherited Destroy; end; procedure TGMDBField.FreeValueBuffers; var i: EGMValueBufferInstance; begin for i:=Low(FValueBuffers) to High(FValueBuffers) do GMFreeAndNil(FValueBuffers[i]); end; function TGMDBField.ValueBufferCreateClass: TGMFieldValueBufferClass; begin Result := TGMFieldValueBuffer; end; function TGMDBField.GetName: TGMString; begin Result := CreateData.Name; end; function TGMDBField.GetPosition: PtrInt; begin Result := CreateData.Position; end; function TGMDBField.GetDataType: TGMDBColumnDataType; begin Result := CreateData.DataType; end; function TGMDBField.GetNullValuesAllowed: TGMAllowNullValues; begin Result := CreateData.AllowNullValues; end; function TGMDBField.IsSigned: Boolean; begin Result := CreateData.IsSigned; end; function TGMDBField.IsAutoIncrementing: Boolean; begin Result := CreateData.IsAutoincrementing; end; function TGMDBField.DisplayWidth: PtrInt; begin with FCreateData do Result := GMFieldDisplayWidth(DataType, MaxStrLength); end; function TGMDBField.EditLength: PtrInt; begin with FCreateData do Result := GMFieldEditLength(DataType, MaxStrLength); end; function TGMDBField.SizeInBytes: PtrInt; begin Result := CreateData.SizeInBytes; end; function TGMDBField.GetModified: Boolean; begin Result := ValueBuffer(vbiValue).Modified; end; procedure TGMDBField.SetModified(const Value: Boolean); begin ValueBuffer(vbiValue).Modified := Value; end; function TGMDBField.GetUpdatable: Boolean; begin Result := CreateData.Updatable and GMAskBoolean(Owner, Ord(bvCanModify), False); end; function TGMDBField.ValueBuffer(const AValueBufferInstance: EGMValueBufferInstance): TGMFieldValueBuffer; var rsHandle: IGMGetHandle; begin if FValueBuffers[FValueBufferIdxMap[AValueBufferInstance]] = nil then begin GMCheckGetInterface(Owner, IGMGetHandle, rsHandle, {$I %CurrentRoutine%}); FValueBuffers[FValueBufferIdxMap[AValueBufferInstance]] := ValueBufferCreateClass.CreateFieldBuffer( Owner, GetDataType, GetPosition, GetName, SizeInBytes, CreateData.MaxStrLength, rsHandle.Handle); end; Result := FValueBuffers[FValueBufferIdxMap[AValueBufferInstance]]; end; function TGMDBField.AskInteger(const ValueId: LongInt): LongInt; begin case ValueId of Ord(ivMaxEditLength): Result := EditLength; Ord(ivDisplayWidth): Result := Displaywidth; Ord(ivDataSize): Result := SizeInBytes; else Result := CInvalidIntValue; end; end; function TGMDBField.AskBoolean(const ValueId: LongInt): LongInt; begin case ValueId of Ord(bvIsNULL): Result := GMBooleanAskResult(ValueBuffer(vbiValue).IsNull); //Ord(bvDisplayText): Result := GMBooleanAskResult(ValueBuffer(vbiValue).DisplayText.IsValid); Ord(bvIsSigned): Result := GMBooleanAskResult(IsSigned); Ord(bvIsAutoIncrementing): Result := GMBooleanAskResult(IsAutoIncrementing); else Result := Ord(barUnknown); end; end; procedure TGMDBField.SwapBufferMap; var Tmp: EGMValueBufferInstance; begin Tmp := FValueBufferIdxMap[vbiValue]; FValueBufferIdxMap[vbiValue] := FValueBufferIdxMap[vbiOldValue]; FValueBufferIdxMap[vbiOldValue] := Tmp; end; procedure TGMDBField.NotifyDataChange; var PIChangeNotify: IGMNamedValueChange; begin GMCheckGetInterface(Owner, IGMNamedValueChange, PIChangeNotify, {$I %CurrentRoutine%}); PIChangeNotify.AfterValueChange(Name); end; function TGMDBField.RecordsetState: LongInt; var PIState: IGMGetState; begin GMCheckgetInterface(Owner, IGMGetState, PIState, {$I %CurrentRoutine%}); Result := PIState.State; end; function TGMDBField.RecordsetAttributes: TGMRecordsetAttributes; var PIAttributes: IGMGetAttributes; begin if (Owner <> nil) and Owner.GetInterface(IGMGetAttributes, PIAttributes) then Result := RSAttributesFromLongWord(PIAttributes.Attributes) else Result := []; end; procedure TGMDBField.CheckupdatableState(const AMethodName: TGMString = ''); var mtdName: TGMString; begin if AMethodName = '' then mtdName := {$I %CurrentRoutine%} else mtdName := AMethodName; if not IsUpdatableState(RecordsetState) then raise EGMexception.ObjError(srNotInUpdatableState, Owner, mtdName); end; function TGMDBField.EditOrInsertRecordset: Boolean; begin if raAutoEdit in RecordsetAttributes then Result := GMEditOrInsertIntf(GMObjAsIntf(Owner)) else Result := False; end; function TGMDBField.GetText: TGMString; begin Result := ValueBuffer(vbiValue).GetText; end; function TGMDBField.GetUnionValue: RGMUnionValue; begin Result := ValueBuffer(vbiValue).GetUnionValue; end; procedure TGMDBField.SetUnionValue(const AUnionValue: RGMUnionValue); begin EditOrInsertRecordset; CheckUpdatableState({$I %CurrentRoutine%}); ValueBuffer(vbiValue).SetUnionValue(AUnionValue); NotifyDataChange; end; procedure TGMDBField.SetText(const AValue: TGMString); var FieldDataType: TGMDBColumnDataType; begin if AValue = '' then SetUnionValue(uvtNull) else begin FieldDataType := GetDataType; case FieldDataType of fdtBoolean: SetUnionValue(GMStrToBool(AValue)); fdtInt8, fdtUInt8, fdtInt16, fdtUInt16, fdtInt32, fdtUInt32, fdtInt64, fdtUInt64: //SetValue(GMStrToInt(AValue)); SetUnionValue(GMUnionValueAsType(AValue, GMUnionTypeOfDbDataType(FieldDataType))); fdtSingle, fdtDouble, fdtNumeric: SetUnionValue(StrToFloat(AValue)); fdtDate: SetUnionValue(StrToDate(AValue)); fdtTime: SetUnionValue(StrToTime(AValue)); fdtDateTime: SetUnionValue(StrToDateTime(AValue)); fdtAnsiString, fdtUnicodeString, fdtGUID, fdtAnsiText, fdtUnicodeText: SetUnionValue(AValue); else raise EGMException.ObjError(MsgUnsupportedFieldDataType(Ord(FieldDataType)), Owner, {$I %CurrentRoutine%}); end; end; end; function TGMDBField.GetValueBufferIntf(const AValueBufferInstance: LongInt; const AIID: TGUID; out AIntf): HResult; begin GMCheckIntRange(cStrValBufInstTypeName, AValueBufferInstance, Ord(Low(EGMValueBufferInstance)), Ord(High(EGMValueBufferInstance)), Owner, {$I %CurrentRoutine%}); if FValueBuffers[FValueBufferIdxMap[EGMValueBufferInstance(AValueBufferInstance)]] <> nil then Result := CQIResult[FValueBuffers[FValueBufferIdxMap[EGMValueBufferInstance(AValueBufferInstance)]].GetInterface(AIID, AIntf)] else Result := E_FAIL; end; { ---- Notifications ---- } procedure TGMDBField.BeforeActiveChange(const NewActive: Boolean); begin end; procedure TGMDBField.AfterActiveChange(const NewActive: Boolean); begin if not NewActive then FreeValueBuffers else ValueBuffer(vbiValue).Invalidate(True, False); end; procedure TGMDBField.BeforePositionChange; begin end; procedure TGMDBField.AfterPositionChange; begin ValueBuffer(vbiValue).Invalidate(True, False); end; procedure TGMDBField.BeforeOperation(const Operation: Integer; const Parameter: IUnknown = nil); begin end; procedure TGMDBField.AfterOperation(const Operation: Integer; const Parameter: IUnknown = nil); begin case Operation of Ord(roCancelChanges): begin SwapBufferMap; ValueBuffer(vbiOldValue).Invalidate(True, True); end; Ord(roApplyChanges): begin ValueBuffer(vbiOldValue).Invalidate(True, True); Modified := False; end; Ord(roEdit), Ord(roInsert): begin // prevent delayed fetches in edit/insert state, and after cancelchanges. And provide proper OldValue! ValueBuffer(vbiValue).Value; ValueBuffer(vbiOldValue).AssignFromIntf(ValueBuffer(vbiValue)); if Operation = Ord(roInsert) then begin ValueBuffer(vbiValue).SetUnionValue(uvtNull); ValueBuffer(vbiValue).Modified := False; end; end; Ord(roRefreshCurrent): ValueBuffer(vbiValue).Invalidate(True, False); end; end; { ------------------------- } { ---- TGMSqlParameter ---- } { ------------------------- } constructor TGMSqlParameter.Create(const AOwner: TObject; const AName: TGMString; const AValue: RGMUnionValue; const AIsLiteral: Boolean); begin inherited Create; FOwner := AOwner; FName := AName; FValue := AValue; FIsLiteral := AIsLiteral; end; function TGMSqlParameter.GetName: TGMString; begin Result := FName; end; function TGMSqlParameter.GetUnionValue: RGMUnionValue; begin Result := FValue; end; procedure TGMSqlParameter.SetUnionValue(const AUnionValue: RGMUnionValue); begin //if FValue = Value then Exit; FValue := AUnionValue; if Owner is TGMSqlParameterList then TGMSqlParameterList(Owner).OnParameterValueChanged; end; procedure TGMSqlParameter.AssignValue(const AValue: RGMUnionValue; const AIsLiteral: Boolean); begin FValue := AValue; FIsLiteral := AIsLiteral; end; { ----------------------------- } { ---- TGMSqlParameterList ---- } { ----------------------------- } constructor TGMSqlParameterList.Create(const AOwner: TObject); begin inherited Create; FOwner := AOwner; FParameterList := TGMObjArrayCollection.Create(True, False, True, GMCompareByName, True); FReExecuteAfterParamValueChange := cDfltReExecAfterParamValChange; end; {destructor TGMSqlParameterList.Destroy; begin GMFreeAndNil(FParameterList); inherited Destroy; end;} function TGMSqlParameterList.GetCount: PtrInt; begin Result := ParameterList.Count; end; function TGMSqlParameterList.GetIntfByName(const Name: TGMString; const IID: TGUID; out Intf): HResult; begin Result := CQIResult[Parameters[Name].GetInterface(IID, Intf)]; end; function TGMSqlParameterList.GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; begin Result := CQIResult[Parameters[Position].GetInterface(IID, Intf)]; end; procedure TGMSqlParameterList.OnParameterValueChanged; begin if ReExecuteAfterParamValueChange then GMCheckExecOperation(Owner, Ord(roScheduleReExecution), '', {$I %CurrentRoutine%}); end; function TGMSqlParameterList.FindParameterByName(const ParameterName: TGMString; var Parameter: TGMSqlParameter): Boolean; var PIName: IGMGetName; begin //Result := False; //if ParameterName <> '' then //begin PIName := TGMNameObj.Create(ParameterName, True); Result := ParameterList.Find(PIName, Parameter); //end; end; function TGMSqlParameterList.GetParameter(const AIndex: RGMUnionValue): TGMSqlParameter; //var Parameter: TGMSqlParameter; begin case AIndex.ValueType of uvtInt16, uvtInt32, uvtInt64, uvtDouble: Result := ParameterList[AIndex] as TGMSqlParameter; uvtString: if not FindParameterByName(AIndex, Result) then // Result := Parameter else raise EGMException.ObjError(GMFormat(srParamNameNotFound, [AIndex.AsStringDflt]), Owner, {$I %CurrentRoutine%}); else raise EGMException.ObjError(GMFormat(RStrUnsupportedIdxType, [AIndex.ValueTypeName]), Owner, {$I %CurrentRoutine%}); end; end; procedure TGMSqlParameterList.AssignFromObj(const Source: TObject); var i: Integer; SourceParamList: TGMSqlParameterList; begin if Source is TGMSqlParameterList then begin ParameterList.Clear; SourceParamList := Source as TGMSqlParameterList; for i:=0 to SourceParamList.Count-1 do ParameterList.Add(TGMSqlParameter.Create(Self, SourceParamList[i].Name, SourceParamList[i].Value, SourceParamList[i].IsLiteral)); ReExecuteAfterParamValueChange := TGMSqlParameterList(Source).ReExecuteAfterParamValueChange; end; end; procedure TGMSqlParameterList.AssignParamValues(const Source: TObject); var i: Integer; SourceParamList: TGMSqlParameterList; Parameter: TGMSqlParameter; begin if Source is TGMSqlParameterList then begin SourceParamList := Source as TGMSqlParameterList; for i:=0 to SourceParamList.Count-1 do if FindParameterByName(SourceParamList[i].Name, Parameter) then Parameter.AssignValue(SourceParamList[i].Value, SourceParamList[i].IsLiteral); end; end; procedure TGMSqlParameterList.ParseForParameters; var oldValues: TGMSqlParameterList; getSqlText: IGMGetText; parameter: TGMSqlParameter; sqlStr, sqlToken: TGMString; chPos: PtrInt; begin if GMGetPropIntfFromIntf(GMObjAsIntf(Owner), cStrSQL, IGMGetText, getSqlText) = S_OK then begin oldValues := TGMSqlParameterList.Create(nil); try oldValues.AssignFromObj(Self); ParameterList.Clear; sqlStr := getSqlText.Text; chPos := 1; while chPos <= Length(sqlStr) do begin sqlToken := GMNextSQLToken(chPos, sqlStr, cSqlSeparators + cSqlOperators); if (Length(sqlToken) > 1) and (sqlToken[1] = cSqlParamPrefixChar) then begin System.Delete(sqlToken, 1, 1); if not FindParameterByName(sqlToken, parameter) then ParameterList.Add(TGMSqlParameter.Create(Self, sqlToken, uvtNull, False)); end; end; AssignParamValues(oldValues); finally oldValues.Free; end; end; end; { ----------------------------------- } { ---- TGMSQLStatmentPartitioner ---- } { ----------------------------------- } constructor TGMSQLStatmentPartitioner.Create(const AOwner: IUnknown; const AGetSQLText: TGMGetStringFunc; const ASetSQLText: TGMSetStringProc; const ADoParseSQLXxxxPropFunc: TDoParseSQLXxxxPropFunc; const ARefLifeTime: Boolean); begin inherited Create(AOwner, ARefLifeTime); FGetSQLText := AGetSQLText; FSetSQLText := ASetSQLText; FParseSQLXxxxPropFunc := ADoParseSQLXxxxPropFunc; end; function TGMSQLStatmentPartitioner.ParseForSQLXxxxProperties: Boolean; begin if Assigned(FParseSQLXxxxPropFunc) then Result := FParseSQLXxxxPropFunc else Result := True; end; function TGMSQLStatmentPartitioner.GetText: TGMString; begin if Assigned(FGetSQLText) then Result := FGetSQLText; end; procedure TGMSQLStatmentPartitioner.SetText(const Value: TGMString); begin if Assigned(FSetSQLText) then FSetSQLText(Value); end; function TGMSQLStatmentPartitioner.GetTableName: TGMString; begin Result := GMFindTextPart(GetText, cSqlSeparators, [cSqlUpdate, cSqlInto, cSqlFrom], [cSqlSet, cSqlValues, cSqlLeft, cSqlRight, cSqlInner, cSqlOuter, cSqlJoin, cSqlWhere, cSqlGroupBy, cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True); end; procedure TGMSQLStatmentPartitioner.SetTableName(Value: TGMString); begin if Value <> '' then Value := cSqlPartSep + cSqlFrom + ' ' + Value + cSqlPartSep; SetText(GMReplaceTextPart(GetText, cSqlSeparators, Value, [cSqlUpdate, cSqlInto, cSqlFrom], [cSqlSet, cSqlValues, cSqlLeft, cSqlRight, cSqlInner, cSqlOuter, cSqlJoin, cSqlWhere, cSqlGroupBy, cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True)); end; function TGMSQLStatmentPartitioner.GetSQLSelectedFields: TGMString; begin if ParseForSQLXxxxProperties then Result := ExtractSQLSelectList(GetText) //Result := GMFindTextPart(GetText, cSqlSeparators, [cSqlSelect, cSqlUpdate, cSqlInsert, cSqlDelete], [cSqlFrom, cSqlLeft, cSqlRight, cSqlInner, cSqlOuter, cSqlJoin, cSqlWhere, cSqlGroupBy, cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True) else Result := ''; end; procedure TGMSQLStatmentPartitioner.SetSQLSelectedFields(Value: TGMString); begin if ParseForSQLXxxxProperties and (GetSQLSelectedFields <> Value) then begin if Value <> '' then Value := cSqlSelect + ' ' + Value + cSqlPartSep; SetText(GMReplaceTextPart(GetText, cSqlSeparators, Value, [cSqlSelect, cSqlUpdate, cSqlInsert, cSqlDelete], [cSqlSet, cSqlValues, cSqlFrom, cSqlLeft, cSqlRight, cSqlInner, cSqlOuter, cSqlJoin, cSqlWhere, cSqlGroupBy, cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True)); end; end; function TGMSQLStatmentPartitioner.GetSQLWhere: TGMString; begin if ParseForSQLXxxxProperties then Result := GMFindTextPart(GetText, cSqlSeparators, [cSqlWhere], [cSqlGroupBy, cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True) else Result := ''; end; procedure TGMSQLStatmentPartitioner.SetSQLWhere(Value: TGMString); begin if ParseForSQLXxxxProperties and (GetSQLWhere <> Value) then begin if Value <> '' then Value := cSqlPartSep + cSqlWhere + ' ' + Value + cSqlPartSep; SetText(GMReplaceTextPart(GetText, cSqlWhiteSpace, Value, [cSqlWhere], [cSqlGroupBy, cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True)); end; end; function TGMSQLStatmentPartitioner.GetSQLGroupBy: TGMString; begin if ParseForSQLXxxxProperties then Result := GMStrip(GMDeleteFirstWord(GMFindTextPart(GetText, cSqlSeparators, [cSqlGroupBy], [cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True), cSqlSeparators), cSqlSeparators) else Result := ''; end; procedure TGMSQLStatmentPartitioner.SetSQLGroupBy(Value: TGMString); begin if ParseForSQLXxxxProperties and (GetSQLGroupBy <> Value) then begin if Value <> '' then Value := cSqlPartSep + cSqlGroupBy + ' ' + Value + cSqlPartSep; SetText(GMReplaceTextPart(GetText, cSqlWhiteSpace, Value, [cSqlGroupBy], [cSqlHaving, cSqlOrderBy, cSqlForUpdateOf], True)); end; end; function TGMSQLStatmentPartitioner.GetSQLHaving: TGMString; begin if ParseForSQLXxxxProperties then Result := GMFindTextPart(GetText, cSqlSeparators, [cSqlHaving], [cSqlOrderBy, cSqlForUpdateOf], True) else Result := ''; end; procedure TGMSQLStatmentPartitioner.SetSQLHaving(Value: TGMString); begin if ParseForSQLXxxxProperties and (GetSQLHaving <> Value) then begin if Value <> '' then Value := cSqlPartSep + cSqlHaving + ' ' + Value + cSqlPartSep; SetText(GMReplaceTextPart(GetText, cSqlSeparators, Value, [cSqlHaving], [cSqlOrderBy, cSqlForUpdateOf], True)); end; end; function TGMSQLStatmentPartitioner.GetSQLOrderBy: TGMString; begin if ParseForSQLXxxxProperties then Result := GMStrip(GMDeleteFirstWord(GMFindTextPart(GetText, cSqlSeparators, [cSqlOrderBy], [cSqlForUpdateOf], True), cSqlSeparators), cSqlSeparators) else Result := ''; end; procedure TGMSQLStatmentPartitioner.SetSQLOrderBy(Value: TGMString); begin if ParseForSQLXxxxProperties and (GetSQLOrderBy <> Value) then begin if Value <> '' then Value := cSqlPartSep + cSqlOrderBy + ' ' + Value + cSqlPartSep; SetText(GMReplaceTextPart(GetText, cSqlSeparators, Value, [cSqlOrderBy], [cSqlForUpdateOf], True)); end; end; function TGMSQLStatmentPartitioner.GetSQLForUpdateOf: TGMString; begin if ParseForSQLXxxxProperties then Result := GMStrip(GMDeleteFirstWords(GMFindTextPart(GetText, cSqlSeparators, [cSqlForUpdateOf], [''], True), 2, cSqlSeparators), cSqlSeparators) else Result := ''; end; procedure TGMSQLStatmentPartitioner.SetSQLForUpdateOf(Value: TGMString); begin if ParseForSQLXxxxProperties and (GetSQLForUpdateOf <> Value) then begin if Value <> '' then Value := cSqlPartSep + cSqlForUpdateOf + ' ' + Value + cSqlPartSep; SetText(GMReplaceTextPart(GetText, cSqlSeparators, Value, [cSqlForUpdateOf], [''], True)); end; end; { ------------------------ } { ---- TGMSqlProperty ---- } { ------------------------ } constructor TGMSqlProperty.Create(const AOwner: TObject; const ASqlText: TGMString; const AParseSQLXxxxPropFunc: TDoParseSQLXxxxPropFunc; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FOwner := AOwner; FSQLParser := TGMSQLStatmentPartitioner.Create(Self, GetSQLText, SetSQLText, AParseSQLXxxxPropFunc, False); FParameterList := TGMSqlParameterList.Create(AOwner); FReExecuteAfterSQLChange := cDfltReExecuteAfterSQLChange; FSqlText := ASqlText; end; destructor TGMSqlProperty.Destroy; begin GMFreeAndNil(FSQLParser); GMFreeAndNil(FParameterList); inherited Destroy; end; function TGMSqlProperty.GetSQLText: TGMString; begin Result := FSQLText; end; procedure TGMSqlProperty.SetSQLText(const AValue: TGMString); begin if GMSameText(AValue, FSQLText) then Exit; FSQLText := AValue; SQLChanged(Self); end; procedure TGMSqlProperty.AssignFromObj(const ASource: TObject); begin if ASource is TGMSqlProperty then begin ReExecuteAfterSQLChange := (ASource as TGMSqlProperty).ReExecuteAfterSQLChange; SQLText := (ASource as TGMSqlProperty).SQLText; SQLParameter := (ASource as TGMSqlProperty).SQLParameter; end; end; procedure TGMSqlProperty.SQLChanged(const ASender: TObject); begin SQLParameter.ParseForParameters; if Assigned(OnAfterSQLChange) then OnAfterSQLChange(ASender); if ReExecuteAfterSQLChange then GMCheckExecRSOperation(Owner, roScheduleReExecution, {$I %CurrentRoutine%}); end; procedure TGMSqlProperty.SetParameterList(const AValue: TGMSqlParameterList); begin SQLParameter.AssignFromObj(AValue); end; function TGMSqlProperty.BuildResolvedSQLText: TGMString; //var i, chPos, NextPos, EndPos: Integer; // ParamToken, ParamName, ErrMsg, InsertStr: TGMString; // Parameter: TGMSqlParameter; // UnresolvedParams: TGMStringArray; begin Result := SQLText; //chPos := 1; //while GMFindToken(Result, cSqlParamPrefixChar, chPos, cSqlSeparators + cSqlOperators, False) do // begin // NextPos := chPos; // ParamToken := GMNextWord(NextPos, Result, cSqlSeparators + cSqlOperators); // ParamName := GMStrip(ParamToken, cSqlParamPrefixChar + cSqlSeparators); // if SQLParameter.FindParameterByName(ParamName, Parameter) {and not VarIsEmpty(Parameter.Value)} then // begin // System.Delete(Result, chPos, Length(ParamToken)); // if GMVarIsNullOrEmpty(Parameter.Value) then // begin // Dec(chPos); EndPos := chPos; // while (chPos >= 1) and GMIsDelimiter(cSqlOperators + cSqlWhiteSpace, Result, chPos) do Dec(chPos); // Inc(chPos); // if EndPos >= chPos then System.Delete(Result, chPos, EndPos - chPos + 1); // System.Insert(cStrSqlIsNull, Result, chPos); // Inc(chPos, Length(cStrSqlIsNull)); // end // else // begin // if Parameter.IsLiteral then InsertStr := Parameter.Value else InsertStr := GMUnionValueAsSqlLiteral(Parameter.Value); // System.Insert(InsertStr, Result, chPos); // Inc(chPos, Length(InsertStr)); // end; // end // else // begin // Inc(chPos, Length(ParamToken)); // GMAddStrToArray(ParamName, UnresolvedParams); // end; // end; // //if Length(UnresolvedParams) > 0 then // begin // ErrMsg := srUnresolvedParams; // for i:=Low(UnresolvedParams) to High(UnresolvedParams) do ErrMsg := ErrMsg + UnresolvedParams[i] + ', '; // raise EGMException.ObjError(GMStrip(ErrMsg, ', '), Self, {$I %CurrentRoutine%}); // end; end; { ---- Properties ---- } {procedure TGMSqlProperty.SetSQLStrings(const Value: TGMStringArray); begin if Value = nil then Exit; SQLParser.SetText(Value.Text); end;} function TGMSqlProperty.IDEGetSQLSelectedFields: TGMString; begin Result := SQLParser.GetSQLSelectedFields; end; procedure TGMSqlProperty.IDESetSQLSelectedFields(Value: TGMString); begin SQLParser.SetSQLSelectedFields(Value); end; function TGMSqlProperty.IDEGetSQLWhere: TGMString; begin Result := SQLParser.GetSQLWhere; end; procedure TGMSqlProperty.IDESetSQLWhere(Value: TGMString); begin SQLParser.SetSQLWhere(Value); end; function TGMSqlProperty.IDEGetSQLGroupBy: TGMString; begin Result := SQLParser.GetSQLGroupBy; end; procedure TGMSqlProperty.IDESetSQLGroupBy(Value: TGMString); begin SQLParser.SetSQLGroupBy(Value); end; function TGMSqlProperty.IDEGetSQLHaving: TGMString; begin Result := SQLParser.GetSQLHaving; end; procedure TGMSqlProperty.IDESetSQLHaving(Value: TGMString); begin SQLParser.SetSQLHaving(Value); end; function TGMSqlProperty.IDEGetTableName: TGMString; begin Result := SQLParser.GetTableName; end; procedure TGMSqlProperty.IDESetTableName(Value: TGMString); begin SQLParser.SetTableName(Value); end; function TGMSqlProperty.IDEGetSQLOrderBy: TGMString; begin Result := SQLParser.GetSQLOrderBy; end; procedure TGMSqlProperty.IDESetSQLOrderBy(Value: TGMString); begin SQLParser.SetSQLOrderBy(Value); end; function TGMSqlProperty.IDEGetSQLForUpdateOf: TGMString; begin Result := SQLParser.GetSQLForUpdateOf; end; procedure TGMSqlProperty.IDESetSQLForUpdateOf(Value: TGMString); begin SQLParser.SetSQLForUpdateOf(Value); end; { ---- IGMEnumerateItems ---- } procedure TGMSqlProperty.EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer); var PIEnumValues: IGMEnumerateItems; begin if (Owner <> nil) and Owner.GetInterface(IGMEnumerateItems, PIEnumValues) then PIEnumValues.EnumerateItems(ItemKind, TellEnumSink, Parameter); end; { --------------------------------------- } { ---- TGMCascadedContentsProperties ---- } { --------------------------------------- } constructor TGMCascadedContentsProperties.Create(const AOwner: TObject); begin inherited Create; FOwner := AOwner; end; procedure TGMCascadedContentsProperties.AssignFromObj(const Source: TObject); begin if Source is TGMCascadedContentsProperties then begin KeyValueName := TGMCascadedContentsProperties(Source).KeyValueName; ParentReferenceValueName := TGMCascadedContentsProperties(Source).ParentReferenceValueName; end; end; function TGMCascadedContentsProperties.ConfigurationIsValid: Boolean; begin Result := (KeyValueName <> '') and (ParentReferenceValueName <> ''); end; procedure TGMCascadedContentsProperties.EnumerateItems(const ItemKind: Integer; const TellEnumSink: IUnknown; const Parameter: Pointer); var PIEnum: IGMEnumerateItems; begin if (Owner <> nil) and Owner.GetInterface(IGMEnumerateItems, PIEnum) then PIEnum.EnumerateItems(ItemKind, TellEnumSink, Parameter); end; function TGMCascadedContentsProperties.GetKeyValueName: TGMString; begin Result := KeyValueName; end; function TGMCascadedContentsProperties.GetParentReferenceValueName: TGMString; begin Result := ParentReferenceValueName; end; { --------------------------- } { ---- TOdbcConnectValue ---- } { --------------------------- } procedure TConnectionStringValue.LoadData(const ASource: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); begin if ASource <> nil then FStrValue := ASource.ReadString(FName); end; procedure TConnectionStringValue.StoreData(const ADest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); begin if ADest <> nil then GMStoreString(ADest, FName, FStrValue); end; { ------------------------------------ } { ---- TGMConnectionStringStorage ---- } { ------------------------------------ } constructor TGMConnectionStringStorage.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FValues := TGMIntfArrayCollection.Create(True, True, GMCompareByName, True); // // Aggregated FValueStorage must be created without RefLifeTime to avoid circular reference count problem // FValueStorage := TGMValueStorageImpl.Create(Self, GetValueByName, SetValueByName, False); end; constructor TGMConnectionStringStorage.Create(const AConnectionString: TGMString; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); if Length(AConnectionString) > 0 then ParseConnectionString(AConnectionString); end; destructor TGMConnectionStringStorage.Destroy; begin FValueStorage.Free; inherited; end; function TGMConnectionStringStorage.Obj: TGMConnectionStringStorage; begin Result := Self; end; procedure TGMConnectionStringStorage.ParseConnectionString(const AConnectionString: TGMString); type TQuoteKind = (qkNone, qkSingle, qkDouble, qkBraces); var startPos, chPos: LongInt; inQuote: TQuoteKind; valName: TGMString; parseVal: Boolean; procedure AddEntry; var valStr: TGMString; begin valStr := Copy(AConnectionString, startPos, chPos - StartPos); if Length(valStr) >= 1 then case valStr[1] of '''': valStr := GMRemoveQuotes(valStr, '''', ''''); '"': valStr := GMRemoveQuotes(valStr, '"', '"'); '{': valStr := GMRemoveQuotes(valStr, '{', '}'); end; if Length(valName) > 0 then SetValueByName(valName, valStr); // GMStrip(Copy(AConnectionString, startPos, chPos - StartPos), '"''{}=') valName := ''; parseVal := False; startPos := chPos + 1; end; begin //if AClearValues then Values.Clear; chPos := 1; startPos := chPos; inQuote := qkNone; parseVal := False; while chPos <= Length(AConnectionString) do begin if inQuote <> qkNone then begin case inQuote of qkSingle: if AConnectionString[chPos] = '''' then inQuote := qkNone; qkDouble: if AConnectionString[chPos] = '"' then inQuote := qkNone; qkBraces: if AConnectionString[chPos] = '}' then inQuote := qkNone; end; end else case AConnectionString[chPos] of '''': if parseVal then inQuote := qkSingle; '"': if parseVal then inQuote := qkDouble; '{': if parseVal then inQuote := qkBraces; '=': if parseVal then Inc(chPos) else begin valName := Copy(AConnectionString, startPos, chPos - StartPos); parseVal := True; startPos := chPos + 1; end; cCnStrEntrySep: AddEntry; end; Inc(chPos); end; AddEntry; // <- in case connection string not terminated by ";" end; function TGMConnectionStringStorage.ContainsValue(const ValueName: TGMString): Boolean; var searchName: IGMGetName; begin searchName := TGMNameObj.Create(ValueName); Result := GMCollectionContains(Values, searchName); end; function TGMConnectionStringStorage.GetValueByName(const AValueName: TGMString; const ADefaultValue: TGMString): TGMString; var nameObj, foundEntry: IUnknown; getStrVal: IGMGetStringValue; begin nameObj := TGMNameObj.Create(AValueName); if Values.Find(nameObj, foundEntry) and GMQueryInterface(foundEntry, IGMGetStringValue, getStrVal) then Result := getStrVal.StringValue else Result := ADefaultValue; end; procedure TGMConnectionStringStorage.SetValueByName(const AValueName, AValue: TGMString); var nameObj, foundEntry: IUnknown; setStrVal: IGMGetSetStringValue; begin nameObj := TGMNameObj.Create(AValueName); if not Values.Find(nameObj, foundEntry) then Values.Add(TConnectionStringValue.Create(AValueName, AValue)) else if GMQueryInterface(foundEntry, IGMGetSetStringValue, setStrVal) then setStrVal.SetStringValue(AValue); end; function TGMConnectionStringStorage.GetText: TGMString; stdcall; begin Result := GMNamesAndValuesAsString(FValues, GMVarToConnectionStrLiteral, cCnStrEntrySep, cCnStrValSep); end; procedure TGMConnectionStringStorage.LoadData(const ASource: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; valueNames: TGMStringArray; valName: TGMString; // loadData: IGMLoadStoreData; begin if valStgDir.QueryFrom(ASource) then begin valStgDir.Intf.ReadValueNames(valueNames); for valName in valueNames do SetValueByName(valName, ASource.ReadString(valName)); end; // // The following cannot be used here, values existing here but not in the source would be set to empty: // //if GMQueryInterface(Values, IGMLoadStoreData, loadData) then loadData.LoadData(ASource, ACryptCtrlData); //GMIntfCollectionLoadAll(Values, ADest, ACryptCtrlData); end; procedure TGMConnectionStringStorage.StoreData(const ADest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); //var storeData: IGMLoadStoreData; begin GMIntfCollectionStoreAll(Values, ADest, ACryptCtrlData); //if GMQueryInterface(Values, IGMLoadStoreData, storeData) then storeData.StoreData(ADest, ACryptCtrlData); end; { ------------------------------------ } { ---- TGMConnectionStringStorage ---- } { ------------------------------------ } {constructor TGMConnectionStringStorage.Create(const AConnectionString: TGMString = ''; const ARefLifeTime: Boolean = False); begin inherited Create(False, ARefLifeTime, False); FValueStorage := TGMValueStorageImpl.Create(Self, ReadString, WriteString, False); AsValueString := AConnectionString; end; destructor TGMConnectionStringStorage.Destroy; begin GMFreeAndNil(FValueStorage); inherited Destroy; end; function TGMConnectionStringStorage.GetText: TGMString; begin Result := AsValueString; end;} { ----------------------------- } { ---- TGMSchemaProperties ---- } { ----------------------------- } constructor TGMSchemaProperties.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FReExecuteAfterPropertyValueChange := cReExecuteAfterPropertyValueChange; SetAll; //Reset; end; //function TGMSchemaProperties.Obj: TGMSchemaProperties; //begin // Result := Self; //end; //procedure TGMSchemaProperties.Reset; //begin // FSchemaList := cDfltSchemaList; // FCatalogName := ''; //cStrNil; // FSchemaName := ''; // cStrNil; // FTableName := cSqlWildcardChar; // FColumnName := cSqlWildcardChar; // FTableKind := ''; // cStrTableKindTable; // FForeignCatalogName := ''; // cStrNil; // FForeignSchemaName := ''; // cStrNil; // FForeignTableName := cSqlWildcardChar; //end; procedure TGMSchemaProperties.SetAll(ASchemaList: TGMSchemaList; ACatalogName, ASchemaName, ATableName, ATableKind, AColumnName, AForeignCatalogName, AForeignSchemaName, AForeignTableName: TGMString); begin FSchemaList := ASchemaList; FCatalogName := ACatalogName; FSchemaName := ASchemaName; FTableName := ATableName; FTableKind := ATableKind; FColumnName := AColumnName; FForeignCatalogName := AForeignCatalogName; FForeignSchemaName := AForeignSchemaName; FForeignTableName := AForeignTableName; end; function TGMSchemaProperties.GetSchemaList: TGMSchemaList; begin Result := FSchemaList; end; function TGMSchemaProperties.GetCatalogName: TGMString; begin Result := FCatalogName; end; function TGMSchemaProperties.GetSchemaName: TGMString; begin Result := FSchemaName; end; function TGMSchemaProperties.GetTableName: TGMString; begin Result := FTableName; end; function TGMSchemaProperties.GetColumnName: TGMString; begin Result := FColumnName; end; function TGMSchemaProperties.GetTableKind: TGMString; begin Result := FTableKind; end; function TGMSchemaProperties.GetForeignCatalogName: TGMString; begin Result := FForeignCatalogName; end; function TGMSchemaProperties.GetForeignSchemaName: TGMString; begin Result := FForeignSchemaName; end; function TGMSchemaProperties.GetForeignTableName: TGMString; begin Result := FForeignTableName; end; procedure TGMSchemaProperties.AssignFromObj(const Source: TObject); stdcall; begin if Source is TGMSchemaProperties then begin SchemaList := TGMSchemaProperties(Source).SchemaList; CatalogName := TGMSchemaProperties(Source).CatalogName; SchemaName := TGMSchemaProperties(Source).SchemaName; TableName := TGMSchemaProperties(Source).TableName; ColumnName := TGMSchemaProperties(Source).ColumnName; ForeignCatalogName := TGMSchemaProperties(Source).ForeignCatalogName; ForeignSchemaName := TGMSchemaProperties(Source).ForeignSchemaName; ForeignTableName := TGMSchemaProperties(Source).ForeignTableName; ReExecuteAfterPropertyValueChange := TGMSchemaProperties(Source).ReExecuteAfterPropertyValueChange; end; end; function TGMSchemaProperties.GetText: TGMString; stdcall; const cStrSchemaDataDiaplayTextFmt = 'List:'#9'%s'#13#13 + 'Database:'#9'%s'#13 + 'Schema:'#9'%s'#13 + 'Table/Proc:'#9'%s'#13 + 'Columnname:'#9'%s'#13 + 'FK Database:'#9'%s'#13 + 'FK Schema:'#9'%s'#13 + 'FK Table:'#9'%s'; begin Result := GMFormat(cStrSchemaDataDiaplayTextFmt, [GMSchemaListName(SchemaList), CatalogName, SchemaName, TableName, ColumnName, ForeignCatalogName, ForeignSchemaName, ForeignTableName]); end; procedure TGMSchemaProperties.AfterPropertyValueChange; begin if ReExecuteAfterPropertyValueChange and GMObjIsActive(OwnerObj) then GMCheckExecRSOperation(Owner, roReExecuteStatement, {$I %CurrentRoutine%}, Self); // <-- Pass Self because Columns may Change //if ReExecuteAfterPropertyValueChange and (Owner is TGMOdbcRecordsetBase) and TGMOdbcRecordsetBase(Owner).Active then //TGMOdbcRecordsetBase(Owner).ReExecuteStatement(False); if Assigned(OnAfterSchemaDataChange) then OnAfterSchemaDataChange(Self); end; procedure TGMSchemaProperties.SetSchemaList(const AValue: TGMSchemaList); begin if AValue <> SchemaList then begin FSchemaList := AValue; AfterPropertyValueChange; end; end; procedure TGMSchemaProperties.SetCatalogName(const AValue: TGMString); begin if AValue <> CatalogName then begin FCatalogName := AValue; AfterPropertyValueChange; end; end; procedure TGMSchemaProperties.SetSchemaName(const AValue: TGMString); begin if AValue <> SchemaName then begin FSchemaName := AValue; AfterPropertyValueChange; end; end; procedure TGMSchemaProperties.SetTableName(const AValue: TGMString); begin if AValue <> TableName then begin FTableName := AValue; AfterPropertyValueChange; end; end; procedure TGMSchemaProperties.SetColumnName(const AValue: TGMString); begin if AValue <> ColumnName then begin FColumnName := AValue; AfterPropertyValueChange; end; end; procedure TGMSchemaProperties.SetTableKind(const AValue: TGMString); begin if AValue <> TableKind then begin FTableKind := AValue; AfterPropertyValueChange; end; end; procedure TGMSchemaProperties.SetForeignCatalogName(const AValue: TGMString); begin if AValue <> ForeignCatalogName then begin FForeignCatalogName := AValue; AfterPropertyValueChange; end; end; procedure TGMSchemaProperties.SetForeignSchemaName(const AValue: TGMString); begin if AValue <> ForeignSchemaName then begin FForeignSchemaName := AValue; AfterPropertyValueChange; end; end; procedure TGMSchemaProperties.SetForeignTableName(const AValue: TGMString); begin if AValue <> ForeignTableName then begin FForeignTableName := AValue; AfterPropertyValueChange; end; end; { -------------------------------- } { ---- TGMRecordsetIntfSource ---- } { -------------------------------- } constructor TGMRecordsetIntfSource.Create(const AOwner: TObject; const ANeededInterfaceIDs: array of TGUID; const AIntfIDsToConnect: array of TGMIntfConnectDataRec); begin inherited Create(AOwner, [IGMGetIntfByName, IConnectionPointContainer], [GMIntfConnectData(IGMPositionChangeNotifications, False), GMIntfConnectData(IGMOperationNotifications, False), GMIntfConnectData(IGMNamedValueChange, False), GMIntfConnectData(IGMSQLChangeNotifications, False), GMIntfConnectData(IGMValidateValues, False)]); AddNeededIntfIDs(ANeededInterfaceIDs); AddIntfIDsToConnect(AIntfIDsToConnect); end; function TGMRecordsetIntfSource.SourceState: LongInt; begin Result := inherited SourceState; if Result = CGMUnknownState then Result := Ord(rsInactive); end; function TGMRecordsetIntfSource.GetIntfByName(const FieldName: TGMString; const IID: TGUID; out Intf): HResult; var PIIntfByName: IGMGetIntfByName; begin if GetSourceIntf(IGMGetIntfByName, PIIntfByName) then Result := PIIntfByName.GetIntfByName(FieldName, IID, Intf) else Result := E_FAIL; end; function TGMRecordsetIntfSource.GetIntfByPosition(const Position: LongInt; const IID: TGUID; out Intf): HResult; var PIIntfByPosition: IGMGetIntfByPosition; begin if GetSourceIntf(IGMGetIntfByPosition, PIIntfByPosition) then Result := PIIntfByPosition.GetIntfByPosition(Position, IID, Intf) else Result := E_FAIL; end; function TGMRecordsetIntfSource.FieldCanModify(const FieldName: TGMString): Boolean; var FieldDef: IGMGetValueDefinition; begin if GetIntfByName(FieldName, IGMGetValueDefinition, FieldDef) = S_OK then Result := FieldDef.Updatable else Result := False; end; {function TGMRecordsetIntfSource.DesignTimeDisplayText: TGMString; var PISqlStr: IGMGetText; PIText: IGMGetText; begin if GetSourceIntf(IGMGetText, PIText) then Result := PIText.DisplayText else if (GetPropertyIntf(cStrSQL, IGMGetText, PISqlStr) = S_OK) then Result := PISqlStr.AsString else Result := ''; end;} function TGMRecordsetIntfSource.CanEdit: Boolean; begin Result := GMObjectCanBeEdited(InterfaceSource); end; function TGMRecordsetIntfSource.Edit: Boolean; begin Result := GMEditOrInsertIntf(InterfaceSource); end; { ---- IGMEnumerateItems ---- } procedure TGMRecordsetIntfSource.EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer); var PIEnumValues: IGMEnumerateItems; begin if GetSourceIntf(IGMEnumerateItems, PIEnumValues) then PIEnumValues.EnumerateItems(ItemKind, TellEnumSink, Parameter); end; { ---- IGMPositionChangeNotifications ---- } procedure TGMRecordsetIntfSource.BeforePositionChange; begin if Assigned(OnbeforePositionChange) then OnbeforePositionChange; end; procedure TGMRecordsetIntfSource.AfterPositionChange; begin if Assigned(OnAfterPositionChange) then OnAfterPositionChange; end; { ---- IGMOperationNotifications ----} procedure TGMRecordsetIntfSource.BeforeOperation(const Operation: LongInt; const Parameter: IUnknown = nil); begin if Assigned(OnBeforeOperation) then OnBeforeOperation(Operation, Parameter); end; procedure TGMRecordsetIntfSource.AfterOperation(const Operation: LongInt; const Parameter: IUnknown = nil); begin if Assigned(OnAfterOperation) then OnAfterOperation(Operation, Parameter); end; { ---- IGMNamedValueChange ----} procedure TGMRecordsetIntfSource.AfterValueChange(const ValueName: TGMString); begin if Assigned(OnAfterFieldValueChange) then OnAfterFieldValueChange(InterfaceSource, ValueName); end; { ---- IGMSQLChangeNotification ----} procedure TGMRecordsetIntfSource.AfterSQLChange; begin if Assigned(OnAfterSQLChange) then OnAfterSQLChange; end; procedure TGMRecordsetIntfSource.ValidateValues; begin if Assigned(OnValidateFieldValues) then OnValidateFieldValues; end; { ---------------------------------- } { ---- TGMRecordsetMasterSource ---- } { ---------------------------------- } constructor TGMRecordsetMasterSource.Create(const AOwner: TObject; const ANeededInterfaceIDs: array of TGUID); begin inherited Create(AOwner, ANeededInterfaceIDs, []); FAutoActivate := cDfltAutoActivate; end; { ---------------------------- } { ---- TGMFieldIntfSource ---- } { ---------------------------- } {procedure TGMFieldIntfSource.AssignFromObj(Source: TPersistent); begin inherited AssignFromObj(Source); if Source is TGMFieldIntfSource then FieldName := TGMFieldIntfSource(Source).FieldName; end;} function TGMFieldIntfSource.GetFieldIntf(const IID: TGUID; out Intf): HResult; begin Result := GetIntfByName(FieldName, IID, Intf); end; {function TGMFieldIntfSource.DesignTimeDisplayText: TGMString; var PITableName: IGMGetTableName; TableName: TGMString; begin if (GetPropertyIntf(cStrSQL, IGMGetTableName, PITableName) = S_OK) then TableName := PITableName.TableName else TableName := ''; Result := GMStrip(GMFormat('%s.%s', [TableName, FieldName]), '.'); end;} function TGMFieldIntfSource.FieldCanModify: Boolean; begin Result := FieldCanModify(FieldName); end; function TGMFieldIntfSource.Edit: Boolean; begin Result := FieldCanModify and inherited Edit; end; function TGMFieldIntfSource.GetFieldName: TGMString; begin Result := FFieldName; end; procedure TGMFieldIntfSource.SetFieldName(const Value: TGMString); var OldFieldName: TGMString; begin if Value <> FieldName then begin OldFieldName := FFieldName; FFieldName := Value; if Assigned(OnAfterFieldNameChange) then OnAfterFieldNameChange(Self, OldFieldName, Value); end; end; { ----------------------------- } { ---- TGMLookupIntfSource ---- } { ----------------------------- } constructor TGMLookupIntfSource.Create(const AOwner: TObject); begin inherited Create(AOwner, [IGMLookupValues], []); end; procedure TGMLookupIntfSource.LimitSearchFieldIndex; begin FDisplaySearchFieldIdx := GMBoundedInt(DisplaySearchFieldIdx, Low(DisplayFieldNameList), High(DisplayFieldNameList)); end; procedure TGMLookupIntfSource.SetDisplaySearchFieldIdx(const Value: Integer); begin if Value <> DisplaySearchFieldIdx then begin FDisplaySearchFieldIdx := Value; LimitSearchFieldIndex; end; end; procedure TGMLookupIntfSource.SetDisplayFieldNames(const Value: TGMString); var chPos: PtrInt; NextFieldName: TGMString; begin if Value <> DisplayFieldNames then begin SetLength(FDisplayFieldNameList, 0); chPos := 1; repeat NextFieldName := GMExtractNextFieldName(chPos, Value); if NextFieldName <> '' then GMAddStrToArray(NextFieldName, FDisplayFieldNameList); until NextFieldName = ''; FDisplayFieldNames := Value; LimitSearchFieldIndex; end; end; {procedure TGMLookupIntfSource.AssignFromObj(Source: TPersistent); begin inherited AssignFromObj(Source); if Source is TGMLookupIntfSource then begin KeyFieldName := TGMLookupIntfSource(Source).KeyFieldName; DisplayFieldNames := TGMLookupIntfSource(Source).DisplayFieldNames; DisplaySearchFieldIdx := TGMLookupIntfSource(Source).DisplaySearchFieldIdx; end; end;} { --------------------------- } { ---- TGMTreeIntfSource ---- } { --------------------------- } constructor TGMTreeIntfSource.Create(const AOwner: TObject); begin inherited Create(AOwner, [IGMCreateCopyQI, IGMGetPropertyIntf, IGMUnidirectionalCursor], []); FFixedImageIndex := cInvalidItemIdx; FFixedSelectedImageIndex := cInvalidItemIdx; FAlwaysNotify := cDfltTreeNotify; end; procedure TGMTreeIntfSource.SetKeyFieldName(const Value: TGMString); var OldFieldName: TGMString; begin if Value <> KeyFieldName then begin OldFieldName := KeyFieldName; FKeyFieldName := Value; if Assigned(OnAfterFieldNameChange) then OnAfterFieldNameChange(Self, OldFieldName, Value); end; end; procedure TGMTreeIntfSource.SetNodeTitleFieldNames(const Value: TGMString); var chPos: PtrInt; OldFieldName, NextFieldName: TGMString; begin if Value <> NodeTitleFieldNames then begin OldFieldName := NodeTitleFieldNames; SetLength(FNodeTitleFieldNameList, 0); chPos := 1; repeat NextFieldName := GMExtractNextFieldName(chPos, Value); if NextFieldName <> '' then GMAddStrToArray(NextFieldName, FNodeTitleFieldNameList); until NextFieldName = ''; FNodeTitleFieldNames := Value; if Assigned(OnAfterFieldNameChange) then OnAfterFieldNameChange(Self, OldFieldName, Value); end; end; procedure TGMTreeIntfSource.SetParentFieldName(const Value: TGMString); var OldFieldName: TGMString; begin if Value <> ParentFieldName then begin OldFieldName := ParentFieldName; FParentFieldName := Value; if Assigned(OnAfterFieldNameChange) then OnAfterFieldNameChange(Self, OldFieldName, Value); end; end; procedure TGMTreeIntfSource.SetImageIndexFieldName(const Value: TGMString); var OldFieldName: TGMString; begin if Value <> ImageIndexFieldName then begin OldFieldName := ImageIndexFieldName; FImageIndexFieldName := Value; if Assigned(OnAfterFieldNameChange) then OnAfterFieldNameChange(Self, OldFieldName, Value); end; end; procedure TGMTreeIntfSource.SetSelectedIndexFieldName(const Value: TGMString); var OldFieldName: TGMString; begin if Value <> SelectedIndexFieldName then begin OldFieldName := SelectedIndexFieldName; FSelectedIndexFieldName := Value; if Assigned(OnAfterFieldNameChange) then OnAfterFieldNameChange(Self, OldFieldName, Value); end; end; procedure TGMTreeIntfSource.SetStateImageIdxFieldName(const Value: TGMString); var OldFieldName: TGMString; begin if Value <> StateImageIdxFieldName then begin OldFieldName := StateImageIdxFieldName; FStateImageIdxFieldName := Value; if Assigned(OnAfterFieldNameChange) then OnAfterFieldNameChange(Self, OldFieldName, Value); end; end; {function TGMTreeIntfSource.DesignTimeDisplayText: TGMString; var PITableName: IGMGetTableName; TableName: TGMString; begin if (GetPropertyIntf(cStrSQL, IGMGetTableName, PITableName) = S_OK) then TableName := PITableName.TableName else TableName := RStrUnknown; Result := GMFormat(srTreeDesignDisplayFmt, [TableName, KeyFieldName, ParentFieldName, NodeTitleFieldNames, ImageIndexFieldName, SelectedIndexFieldName, StateImageIdxFieldName]); end;} {procedure TGMTreeIntfSource.AssignFromObj(Source: TPersistent); begin inherited AssignFromObj(Source); if Source is TGMTreeIntfSource then begin KeyFieldName := TGMTreeIntfSource(Source).KeyFieldName; NodeTitleFieldNames := TGMTreeIntfSource(Source).NodeTitleFieldNames; ParentFieldName := TGMTreeIntfSource(Source).ParentFieldName; ImageIndexFieldName := TGMTreeIntfSource(Source).ImageIndexFieldName; SelectedIndexFieldName := TGMTreeIntfSource(Source).SelectedIndexFieldName; end; end;} { -------------------------------- } { ---- TGMInterfaceSourceLink ---- } { -------------------------------- } constructor TGMInterfaceSourceLink.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); CreateConnectionPoint(IGMActiveChangeNotifications); CreateConnectionPoint(IGMOperationNotifications); CreateConnectionPoint(IGMPositionChangeNotifications); CreateConnectionPoint(IGMNamedValueChange); CreateConnectionPoint(IGMValidateValues); CreateConnectionPoint(IGMSQLChangeNotifications); FInterfaceSource := TGMRecordsetIntfSource.Create(Self, NeededSourceIIDs, []); SetupIntfSourceConnector(FInterfaceSource); end; destructor TGMInterfaceSourceLink.Destroy; begin inherited Destroy; GMFreeAndNil(FInterfaceSource); end; function TGMInterfaceSourceLink.NeededSourceIIDs: TGMInterfaceIDArray; begin Result := Default(TGMInterfaceIDArray); //SetLength(Result, 0); end; procedure TGMInterfaceSourceLink.SetupIntfSourceConnector(const IntfConnector: TGMRecordsetIntfSource); begin if IntfConnector <> nil then begin IntfConnector.OnAfterIntfSourceChange := AfterInterfaceSrcObjChange; IntfConnector.OnBeforeActiveChange := BeforeActiveChange; IntfConnector.OnAfterActiveChange := AfterActiveChange; IntfConnector.OnBeforePositionChange := BeforePositionChange; IntfConnector.OnAfterPositionChange := AfterPositionChange; IntfConnector.OnBeforeOperation := BeforeOperation; IntfConnector.OnAfterOperation := AfterOperation; IntfConnector.OnAfterFieldValueChange := AfterValueChange2; IntfConnector.OnValidateFieldValues := ValidateValues; IntfConnector.OnAfterSQLChange := AfterSQLChange; end; end; procedure TGMInterfaceSourceLink.SetInterfaceSource(const Value: TGMRecordsetIntfSource); begin InterfaceSource.AssignFromObj(Value); end; procedure TGMInterfaceSourceLink.AfterInterfaceSrcObjChange(const OldSource, NewSource: IUnknown); begin if Assigned(OnAfterIntfSourceChange) then OnAfterIntfSourceChange(OldSource, NewSource); end; function TGMInterfaceSourceLink.GetActive: Boolean; begin Result := InterfaceSource.SourceIsActive; end; procedure TGMInterfaceSourceLink.InternalOpen; begin GMSetIntfActive(InterfaceSource.InterFaceSource, True, {$I %CurrentRoutine%}); end; function TGMInterfaceSourceLink.GetNotifyDisableCount: LongInt; var notifications: IGMEnableNotifications; begin //Result := inherited GetNotifyDisableCount; if InterfaceSource.GetSourceIntf(IGMEnableNotifications, notifications) then Result := notifications.NotifyDisableCount else Result := 0; end; function TGMInterfaceSourceLink.EnableNotifications(const NotificationOnReEnable: LongInt = Ord(rgNone)): LongInt; var notifications: IGMEnableNotifications; begin //Result := inherited EnableNotifications(NotificationOnReEnable); if InterfaceSource.GetSourceIntf(IGMEnableNotifications, notifications) then Result := notifications.EnableNotifications(NotificationOnReEnable) else Result := 0; end; function TGMInterfaceSourceLink.DisableNotifications(const NotificationOnFirstDisable: LongInt = Ord(rgNone)): LongInt; var notifications: IGMEnableNotifications; begin //Result := inherited DisableNotifications(NotificationOnFirstDisable); if InterfaceSource.GetSourceIntf(IGMEnableNotifications, notifications) then Result := notifications.DisableNotifications(NotificationOnFirstDisable) else Result := 0; end; function TGMInterfaceSourceLink.GetPropertyIntf(const PropertyName: TGMString; const IID: TGUID; out Intf): HResult; begin Result := GMGetPropIntfFromIntf(InterfaceSource.InterfaceSource, PropertyName, IID, Intf); end; function TGMInterfaceSourceLink.GetColumnSortOrder(const ColumnName: TGMString): LongInt; var getSort: IGMGetColumnSortOrder; begin if InterfaceSource.GetSourceIntf(IGMGetColumnSortOrder, getSort) then Result := getSort.GetColumnSortOrder(ColumnName) else Result := 0; end; procedure TGMInterfaceSourceLink.SetColumnSortOrder(const ColumnName: TGMString; const SortOrder: LongInt; const Cumulative, ReExecuteWhenChanged: Boolean); var setSort: IGMSetColumnSortOrder; begin if InterfaceSource.GetSourceIntf(IGMSetColumnSortOrder, setSort) then setSort.SetColumnSortOrder(ColumnName, SortOrder, Cumulative, ReExecuteWhenChanged); end; function TGMInterfaceSourceLink.GetState: LongInt; stdcall; begin Result := InterfaceSource.SourceState; end; procedure TGMInterfaceSourceLink.EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer); stdcall; begin InterfaceSource.EnumerateItems(ItemKind, TellEnumSink, Parameter); end; function TGMInterfaceSourceLink.CanExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; stdcall; var PICanExecOp: IGMCanExecuteOperation; begin Result := InterfaceSource.GetSourceIntf(IGMCanExecuteOperation, PICanExecOp) and PICanExecOp.CanExecuteOperation(Operation, Parameter); end; function TGMInterfaceSourceLink.ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; stdcall; var execOp: IGMExecuteOperation; begin Result := InterfaceSource.GetSourceIntf(IGMExecuteOperation, execOp) and execOp.ExecuteOperation(Operation, Parameter); end; function TGMInterfaceSourceLink.GetPosition: PtrInt; var getPos: IGMGetPosition; begin if InterfaceSource.GetSourceIntf(IGMGetPosition, getPos) then Result := getPos.Position else Result := CGMUnknownPosition; end; procedure TGMInterfaceSourceLink.SetPosition(const Value: PtrInt); var getSetPos: IGMGetSetPosition; begin if InterfaceSource.GetSourceIntf(IGMGetSetPosition, getSetPos) then getSetPos.Position := Value; end; function TGMInterfaceSourceLink.AskBoolean(const ValueId: LongInt): LongInt; var askBool: IGMAskBoolean; begin if InterfaceSource.GetSourceIntf(IGMAskBoolean, askBool) then Result := askBool.AskBoolean(ValueId) else Result := Ord(barUnknown); end; function TGMInterfaceSourceLink.AskInteger(const ValueId: LongInt): LongInt; var askInt: IGMAskInteger; begin if InterfaceSource.GetSourceIntf(IGMAskInteger, askInt) then Result := askInt.AskInteger(ValueId) else Result := 0; end; function TGMInterfaceSourceLink.GetIntfByName(const FieldName: TGMString; const IID: TGUID; out Intf): HResult; begin Result := InterfaceSource.GetIntfByName(FieldName, IID, Intf); end; function TGMInterfaceSourceLink.GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; var intfByPos: IGMGetIntfByPosition; begin if InterfaceSource.GetSourceIntf(IGMGetIntfByPosition, intfByPos) then Result := intfByPos.GetIntfByPosition(Position, IID, Intf) else Result := E_FAIL; end; function TGMInterfaceSourceLink.GetCount: PtrInt; var count: IGMGetCount; begin if InterfaceSource.GetSourceIntf(IGMGetCount, count) then Result := count.Count else Result := cGMUnknownCount; end; function TGMInterfaceSourceLink.CaptureState: IUnknown; var PISaveRestore: IGMSaveRestoreState; begin if InterfaceSource.GetSourceIntf(IGMSaveRestoreState, PISaveRestore) then Result := PISaveRestore.CaptureState else Result := nil; end; procedure TGMInterfaceSourceLink.RestoreState(const State: IUnknown); var PISaveRestore: IGMSaveRestoreState; begin if InterfaceSource.GetSourceIntf(IGMSaveRestoreState, PISaveRestore) then PISaveRestore.RestoreState(State); end; function TGMInterfaceSourceLink.GetBOF: Boolean; var PIUniCur: IGMUnidirectionalCursor; begin if InterfaceSource.GetSourceIntf(IGMUnidirectionalCursor, PIUniCur) then Result := PIUniCur.BOF else Result := True; end; function TGMInterfaceSourceLink.GetEOF: Boolean; var PIUniCur: IGMUnidirectionalCursor; begin if InterfaceSource.GetSourceIntf(IGMUnidirectionalCursor, PIUniCur) then Result := PIUniCur.EOF else Result := True; end; procedure TGMInterfaceSourceLink.MoveToNext; var PIUniCur: IGMUnidirectionalCursor; begin if InterfaceSource.GetSourceIntf(IGMUnidirectionalCursor, PIUniCur) then PIUniCur.MoveToNext; end; procedure TGMInterfaceSourceLink.MoveToPrevious; var PIBiCur: IGMBidirectionalCursor; begin if InterfaceSource.GetSourceIntf(IGMBidirectionalCursor, PIBiCur) then PIBiCur.MoveToPrevious; end; procedure TGMInterfaceSourceLink.MoveToFirst; var PIFirstLast: IGMCursorFirstLast; begin if InterfaceSource.GetSourceIntf(IGMCursorFirstLast, PIFirstLast) then PIFirstLast.MoveToFirst; end; procedure TGMInterfaceSourceLink.MoveToLast; var PIFirstLast: IGMCursorFirstLast; begin if InterfaceSource.GetSourceIntf(IGMCursorFirstLast, PIFirstLast) then PIFirstLast.MoveToLast; end; procedure TGMInterfaceSourceLink.AfterValueChange(const FieldName: TGMString); var PIFieldValChange: IGMNamedValueChange; begin if InterfaceSource.GetSourceIntf(IGMNamedValueChange, PIFieldValChange) then PIFieldValChange.AfterValueChange(FieldName); end; function TGMInterfaceSourceLink.GetAttributes: Longword; var PIGetAttr: IGMGetAttributes; begin if InterfaceSource.GetSourceIntf(IGMGetAttributes, PIGetAttr) then Result := PIGetAttr.Attributes else Result := 0; end; procedure TGMInterfaceSourceLink.SetAttributes(const Value: Longword); var PISetAttr: IGMGetSetAttributes; begin if InterfaceSource.GetSourceIntf(IGMGetSetAttributes, PISetAttr) then PISetAttr.Attributes := Value; end; function TGMInterfaceSourceLink.LookupValues(const SQLCriteria: TGMString; const Values: IUnknown): Boolean; var PILookup: IGMLookupValues; begin if InterfaceSource.GetSourceIntf(IGMLookupValues, PILookup) then Result := PILookup.LookupValues(SQLCriteria, Values) else Result := False; end; function TGMInterfaceSourceLink.LocateValues(const Values: IUnknown): Boolean; var PILocate: IGMLocateValues; begin if InterfaceSource.GetSourceIntf(IGMLocateValues, PILocate) then Result := PILocate.LocateValues(Values) else Result := False; end; function TGMInterfaceSourceLink.PositionOfValues(const Values: IUnknown; var FindPos: LongInt): Boolean; var PIPosOfValues: IGMPositionOfValues; begin if InterfaceSource.GetSourceIntf(IGMPositionOfValues, PIPosOfValues) then Result := PIPosOfValues.PositionOfValues(Values, FindPos) else Result := False; end; { ---- Notifications from source ---- } procedure TGMInterfaceSourceLink.BeforeActiveChange(const NewActive: Boolean); begin NotifyBeforeActiveChange(NewActive); end; procedure TGMInterfaceSourceLink.AfterActiveChange(const NewActive: Boolean); begin NotifyAfterActiveChange(NewActive); end; procedure TGMInterfaceSourceLink.BeforePositionChange; begin if Assigned(OnBeforePositionChange) then OnBeforePositionChange; GMCpcCallNotifySinks(Self, IGMPositionChangeNotifications, GMCallSinkBeforePositionChange, NotifyDisableCount = 0, []); end; procedure TGMInterfaceSourceLink.AfterPositionChange; begin GMCpcCallNotifySinks(Self, IGMPositionChangeNotifications, GMCallSinkAfterPositionChange, NotifyDisableCount = 0, []); if Assigned(OnAfterPositionChange) then try OnAfterPositionChange; except end; end; procedure TGMInterfaceSourceLink.BeforeOperation(const Operation: LongInt; const Parameter: IUnknown = nil); begin if Assigned(OnBeforeOperation) then OnBeforeOperation(Operation, Parameter); GMCpcCallNotifySinks(Self, IGMOperationNotifications, GMCallSinkBeforeOperation, NotifyDisableCount = 0, [Operation, Parameter]); end; procedure TGMInterfaceSourceLink.AfterOperation(const Operation: LongInt; const Parameter: IUnknown = nil); begin GMCpcCallNotifySinks(Self, IGMOperationNotifications, GMCallSinkAfterOperation, NotifyDisableCount = 0, [Operation, Parameter]); if Assigned(OnAfterOperation) then try OnAfterOperation(Operation, Parameter); finally end; end; procedure TGMInterfaceSourceLink.AfterValueChange2(Sender: IUnknown; const FieldName: TGMString); begin GMCpcCallNotifySinks(Self, IGMNamedValueChange, GMCallSinkAfterFieldValueChange, NotifyDisableCount = 0, [FieldName]); if Assigned(OnAfterFieldValueChange) then try OnAfterFieldValueChange(Sender, FieldName); except end; end; procedure TGMInterfaceSourceLink.ValidateValues; begin GMCpcCallNotifySinks(Self, IGMValidateValues, GMCallSinkValidateValue, NotifyDisableCount = 0, []); if Assigned(OnValidateFieldValues) then OnValidateFieldValues; end; procedure TGMInterfaceSourceLink.AfterSQLChange; begin GMCpcCallNotifySinks(Self, IGMSQLChangeNotifications, GMCallSinkAfterSQLChange, NotifyDisableCount = 0, []); if Assigned(OnAfterSQLChange) then try OnAfterSQLChange; except end; end; { -------------------------------- } { ---- TGMQualifiedSourceLink ---- } { -------------------------------- } procedure TGMQualifiedSourceLink.TellEnumString(const ItemKind: LongInt; const Value: TGMString; const Parameter: Pointer); begin if FTellEnumSink <> nil then FTellEnumSink.TellEnumString(ItemKind, GMStringJoin(FEnumQualifierName, cSqlQualSep, Value), Parameter); end; procedure TGMQualifiedSourceLink.EnumerateValuesOfIntfSource(const Source: TGMRecordsetIntfSource; const ItemKind: LongInt); var PIName: IGMGetName; begin if (Source <> nil) and Source.GetSourceIntf(IGMGetName, PIName) then begin FEnumQualifierName := PIName.Name; Source.EnumerateItems(ItemKind, Self); end; end; procedure TGMQualifiedSourceLink.InternalEnumerateValues(const ItemKind: LongInt); begin EnumerateValuesOfIntfSource(InterfaceSource, ItemKind); end; procedure TGMQualifiedSourceLink.EnumerateItems(const ItemKind: LongInt; const ATellEnumSink: IUnknown; const Parameter: Pointer); begin if (ATellEnumSink <> nil) and (ATellEnumSink.QueryInterface(IGMTellEnumString, FTellEnumSink) = S_OK) then try InternalEnumerateValues(ItemKind); finally FTellEnumSink := nil; end; end; { ------------------------------- } { ---- TGMSourceStateWrapper ---- } { ------------------------------- } constructor TGMSourceStateWrapper.Create(const Source: IUnknown); var PISRState: IGMSaveRestoreState; PISourceName: IGMGetName; begin inherited Create(False); if Source <> nil then begin if Source.QueryInterface(IGMSaveRestoreState, PISRState) = S_OK then FSourceState := PISRState.CaptureState; if Source.QueryInterface(IGMGetName, PISourceName) = S_OK then FName := PISourceName.Name; end; end; function TGMSourceStateWrapper.GetName: TGMString; begin Result := FName; end; procedure TGMSourceStateWrapper.RestoreState(const Dest: IUnknown); var PISRState: IGMSaveRestoreState; PIDestName: IGMGetName; begin if (Dest <> nil) and (Dest.QueryInterface(IGMGetName, PIDestName) = S_OK) and GMSameText(FName, PIDestName.Name) and (Dest.QueryInterface(IGMSaveRestoreState, PISRState) = S_OK) then PISRState.RestoreState(FSourceState); end; { --------------------------------- } { ---- TGMMultiLinkStateHolder ---- } { --------------------------------- } constructor TGMMultiLinkStateHolder.Create(const AMultiLink: TGMInterfaceMultiSourceLink); var i: Integer; begin inherited Create(True); Assert(AMultiLink <> nil); FMasterState := TGMSourceStateWrapper.Create(AMultiLink.InterfaceSource.InterfaceSource); FSourceStates := TGMObjArrayCollection.Create(True, True, True, GMCompareByName); for i:=0 to AMultiLink.SourceList.Count-1 do FSourceStates.Add(TGMSourceStateWrapper.Create((AMultiLink.SourceList[i] as TGMObjInterfaceConnector).InterfaceSource)); end; destructor TGMMultiLinkStateHolder.Destroy; begin GMFreeAndNil(FMasterState); GMFreeAndNil(FSourceStates); inherited Destroy; end; procedure TGMMultiLinkStateHolder.RestoreToMultiLink(const AMultiLink: IMultiLinkSources); var i: LongInt; PISourceName: IGMGetName; PINameObj: IUnknown; intfSrc: IGMGetInterfaceSource; State: TGMSourceStateWrapper; begin if GMQueryInterface(AMultiLink, IGMGetInterfaceSource, intfSrc) then begin FMasterState.RestoreState(intfSrc.InterfaceSource); for i:=0 to AMultiLink.SourceCount-1 do if AMultiLink.Sources[i].QueryInterface(IGMGetName, PISourceName) = S_OK then begin PINameObj := TGMNameObj.Create(PISourceName.Name, True); if FSourceStates.Find(PINameObj, State) then State.RestoreState(AMultiLink.Sources[i]); end; end; end; { ------------------------------------- } { ---- TGMInterfaceMultiSourceLink ---- } { ------------------------------------- } constructor TGMInterfaceMultiSourceLink.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FSourceList := TGMObjArrayCollection.Create(True); end; destructor TGMInterfaceMultiSourceLink.Destroy; begin GMFreeAndNil(FSourceList); inherited Destroy; end; function TGMInterfaceMultiSourceLink.NeededSourceIIDs: TGMInterfaceIDArray; begin Result := inherited NeededSourceIIDs; SetLength(Result, Length(Result)+1); Result[High(Result)] := IGMGetName; end; procedure TGMInterfaceMultiSourceLink.InternalOpen; var i: integer; begin for i:=0 to SourceList.Count-1 do GMSetIntfActive((SourceList[i] as TGMObjInterfaceConnector).InterfaceSource, True, {$I %CurrentRoutine%}); inherited InternalOpen; end; procedure TGMInterfaceMultiSourceLink.AddSourceObj(const SourceObj: TObject); var Connector: TGMRecordsetIntfSource; i: integer; begin Connector := TGMRecordsetIntfSource.Create(Self, NeededSourceIIDs, []); //SetupIntfSourceConnector(Connector); <- mmmhhh? Connector.InterfaceSource := GMObjAsIntf(SourceObj); SourceList.Add(Connector); if Active then begin GMSetIntfActive(InterfaceSource.InterFaceSource, False, {$I %CurrentRoutine%}); for i:=0 to SourceList.Count-1 do GMSetIntfActive((SourceList[i] as TGMObjInterfaceConnector).InterfaceSource, False, {$I %CurrentRoutine%}); Open; end; end; procedure TGMInterfaceMultiSourceLink.RemoveSourceObj(const SourceObj: TObject); var i: Integer; begin for i:=SourceList.Count-1 downto 0 do if (SourceList[i] as TGMRecordsetIntfSource).InterfaceSource = GMObjAsIntf(SourceObj) then SourceList.RemoveByIdx(i); end; { ---- IMultiLinkSources ---- } function TGMInterfaceMultiSourceLink.GetMasterSource: IUnknown; begin Result := InterfaceSource.InterfaceSource; end; function TGMInterfaceMultiSourceLink.GetSourceCount: LongInt; begin Result := SourceList.Count; end; function TGMInterfaceMultiSourceLink.GetSource(Idx: LongInt): IUnknown; begin Result := (SourceList[Idx] as TGMObjInterfaceConnector).InterfaceSource; end; { ---- override with new semantic ---- } procedure TGMInterfaceMultiSourceLink.InternalEnumerateValues(const ItemKind: LongInt); var i: Integer; begin inherited InternalEnumerateValues(ItemKind); for i:=0 to SourceList.Count-1 do EnumerateValuesOfIntfSource(SourceList[i] as TGMRecordsetIntfSource, ItemKind); end; function TGMInterfaceMultiSourceLink.FindSourceForQualifier(const Qualifier: TGMString; var Source: TGMRecordsetIntfSource): Boolean; var i: integer; PIName: IGMGetName; begin Result := False; if Qualifier <> '' then if InterfaceSource.GetSourceIntf(IGMGetName, PIName) and GMSameText(Qualifier, PIName.Name) then begin Source := InterfaceSource; Result := True; end else for i:=0 to SourceList.Count-1 do if (SourceList[i] as TGMObjInterfaceConnector).GetSourceIntf(IGMGetName, PIName) and GMSameText(Qualifier, PIName.Name) then begin Source := (SourceList[i] as TGMRecordsetIntfSource); Result := True; Break; end; end; function TGMInterfaceMultiSourceLink.GetIntfByName(const QualifiedName: TGMString; const IID: TGUID; out Intf): HResult; var Qualifier, FieldName: TGMString; Source: TGMRecordsetIntfSource; begin if GMSplitQualifiedName(QualifiedName, Qualifier, FieldName) and FindSourceForQualifier(Qualifier, Source) then Result := Source.GetIntfByName(FieldName, IID, Intf) else Result := E_FAIL; end; function TGMInterfaceMultiSourceLink.GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; var i, n: Integer; function SourceFieldCount(const Source: TGMObjInterfaceConnector): Integer; begin Result := 0; if Source <> nil then Result := GMAskInteger(Source.InterfaceSource, Ord(ivFieldCount), 0) end; begin Result := E_FAIL; n:=0; if GMIsInRange(Position, n, n + SourceFieldCount(InterfaceSource) - 1) then Result := InterfaceSource.GetIntfByPosition(Position - n, IID, Intf) else begin Inc(n, SourceFieldCount(InterfaceSource)); for i:=0 to SourceList.Count-1 do if not GMIsInRange(Position, n, n + SourceFieldCount(SourceList[i] as TGMObjInterfaceConnector) - 1) then Inc(n, SourceFieldCount(SourceList[i] as TGMObjInterfaceConnector)) else begin Result := (SourceList[i] as TGMRecordsetIntfSource).GetIntfByPosition(Position - n, IID, Intf); Break; end end; end; procedure TGMInterfaceMultiSourceLink.AfterValueChange(const QualifiedName: TGMString); var Qualifier, FldName: TGMString; Source: TGMRecordsetIntfSource; begin if GMSplitQualifiedName(QualifiedName, Qualifier, FldName) and FindSourceForQualifier(Qualifier, Source) then Source.AfterValueChange(FldName); end; function TGMInterfaceMultiSourceLink.CaptureState: IUnknown; begin Result := TGMMultiLinkStateHolder.Create(Self); end; procedure TGMInterfaceMultiSourceLink.RestoreState(const State: IUnknown); var PIRestore: IRestoreToMultiLink; begin if (State <> nil) and (State.QueryInterface(IRestoreToMultiLink, PIRestore) = S_OK) then PIRestore.RestoreToMultiLink(Self); end; { ---- simple distributions to all sources ---- } function TGMInterfaceMultiSourceLink.ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; var i: Integer; PIExecOp: IGMExecuteOperation; begin //if Operation <> Ord(roScheduleReExecution) then ... ??? for i:=0 to SourceList.Count-1 do if (SourceList[i] as TGMObjInterfaceConnector).GetSourceIntf(IGMExecuteOperation, PIExecOp) then PIExecOp.ExecuteOperation(Operation, Parameter); Result := inherited ExecuteOperation(Operation, Parameter); end; procedure TGMInterfaceMultiSourceLink.SetPosition(const Value: PtrInt); var i: Integer; PIGetSetPos: IGMGetSetPosition; begin for i:=0 to SourceList.Count-1 do if (SourceList[i] as TGMObjInterfaceConnector).GetSourceIntf(IGMGetSetPosition, PIGetSetPos) then PIGetSetPos.Position := Value; inherited SetPosition(Value); end; procedure TGMInterfaceMultiSourceLink.MoveToNext; var i: Integer; PIUniCur: IGMUnidirectionalCursor; begin for i:=0 to SourceList.Count-1 do if (SourceList[i] as TGMObjInterfaceConnector).GetSourceIntf(IGMUnidirectionalCursor, PIUniCur) then PIUniCur.MoveToNext; inherited MoveToNext; end; procedure TGMInterfaceMultiSourceLink.MoveToPrevious; var i: Integer; PIBiDiCur: IGMBidirectionalCursor; begin for i:=0 to SourceList.Count-1 do if (SourceList[i] as TGMObjInterfaceConnector).GetSourceIntf(IGMBidirectionalCursor, PIBiDiCur) then PIBiDiCur.MoveToPrevious; inherited MoveToPrevious; end; procedure TGMInterfaceMultiSourceLink.MoveToFirst; var i: Integer; PIFirstLast: IGMCursorFirstLast; begin for i:=0 to SourceList.Count-1 do if (SourceList[i] as TGMObjInterfaceConnector).GetSourceIntf(IGMCursorFirstLast, PIFirstLast) then PIFirstLast.MoveToFirst; inherited MoveToFirst; end; procedure TGMInterfaceMultiSourceLink.MoveToLast; var i: Integer; PIFirstLast: IGMCursorFirstLast; begin for i:=0 to SourceList.Count-1 do if (SourceList[i] as TGMObjInterfaceConnector).GetSourceIntf(IGMCursorFirstLast, PIFirstLast) then PIFirstLast.MoveToLast; inherited MoveToLast; end; { -------------------- } { ---- TColumnSet ---- } { -------------------- } constructor TColumnSet.Create(const AOwner: TGMInterfaceGroupSourceLink; const AQualifiedName: TGMString; const AInterfaceSource: IUnknown); var masterSrc: IGMGetSetMasterSource; begin Assert(AOwner <> nil); inherited Create(False); FOwner := AOwner; FInterfaceSource := AInterfaceSource; FQualifiedName := AQualifiedName; if GMQueryInterface(FInterfaceSource, IGMGetMasterSource, masterSrc) then begin //GMCheckQueryInterface(FInterfaceSource, IGMGetSetReferencedObject, masterSrc, {$I %CurrentRoutine%}); masterSrc.MasterSource := FOwner.InterfaceSource.InterfaceSource; end; end; procedure TColumnSet.TellEnumString(const ItemKind: LongInt; const Value: TGMString; const Parameter: Pointer); begin if FOwner.FTellEnumSink <> nil then FOwner.FTellEnumSink.TellEnumString(ItemKind, GMFormat('%s%s%s', [FQualifiedName, cSqlQualSep, Value]), Parameter); end; function TColumnSet.GetName: TGMString; begin Result := FQualifiedName; end; procedure TColumnSet.EnumerateItems(const ItemKind: LongInt); var PIEnumValues: IGMEnumerateItems; begin GMSetIntfActive(FInterfaceSource, True, {$I %CurrentRoutine%}); if (FInterfaceSource <> nil) and (FInterfaceSource.QueryInterface(IGMEnumerateItems, PIEnumValues) = S_OK) then PIEnumValues.EnumerateItems(ItemKind, Self); end; function TColumnSet.GetIntfByName(const QualifiedName: TGMString; const IID: TGUID; out Intf): HResult; var PIIntfByName: IGMGetIntfByName; begin Result := E_FAIL; GMSetIntfActive(FInterfaceSource, True, {$I %CurrentRoutine%}); if (FInterfaceSource <> nil) and (FInterfaceSource.QueryInterface(IGMGetIntfByName, PIIntfByName) = S_OK) then Result := PIIntfByName.GetIntfByName(GMLastWord(QualifiedName, cSqlQualSep), IID, Intf); end; { ------------------------------------- } { ---- TGMInterfaceGroupSourceLink ---- } { ------------------------------------- } constructor TGMInterfaceGroupSourceLink.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FColumnSetList := TGMObjArrayCollection.Create(True, True, False, GMCompareByName, True); end; {destructor TGMInterfaceGroupSourceLink.Destroy; begin GMFreeAndNil(FColumnSetList); inherited Destroy; end;} procedure TGMInterfaceGroupSourceLink.AddColumnSet(const QualifiedName: TGMString; const InterfaceSource: IUnknown); var PINameObj: IUnknown; ColumnSet: TObject; begin PINameObj := TGMNameObj.Create(QualifiedName, True); if not FColumnSetList.Find(PINameObj, ColumnSet) then FColumnSetList.Add(TColumnSet.Create(Self, QualifiedName, InterfaceSource)); end; procedure TGMInterfaceGroupSourceLink.InternalEnumerateValues(const ItemKind: LongInt); var i: Integer; begin inherited InternalEnumerateValues(ItemKind); if (ItemKind = Ord(eidFieldNames)) and (FTellEnumSink <> nil) then for i:=0 to FColumnSetList.Count-1 do (FColumnSetList[i] as TColumnSet).EnumerateItems(ItemKind); end; function TGMInterfaceGroupSourceLink.GetIntfByName(const QualifiedName: TGMString; const IID: TGUID; out Intf): HResult; var Qualifier, FldName: TGMString; PIName: IGMGetName; ColumnSet: TColumnSet; begin Result := E_FAIL; FQualifierParseChPos := 1; if GMExtractQualifier(QualifiedName, FQualifierParseChPos, Qualifier) then if InterfaceSource.GetSourceIntf(IGMGetName, PIName) and GMSameText(Qualifier, PIName.Name) then begin if GMExtractQualifier(QualifiedName, FQualifierParseChPos, FldName) then Result := InterfaceSource.GetIntfByName(FldName, IID, Intf) end else begin PIName := TGMNameObj.Create(GMDeleteLastWord(QualifiedName, cSqlQualSep), True); if FColumnSetList.Find(PIName, ColumnSet) then Result := ColumnSet.GetIntfByName(QualifiedName, IID, Intf); end; end; function TGMInterfaceGroupSourceLink.GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; begin Assert(False); Result := E_FAIL; end; function TGMInterfaceGroupSourceLink.ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; var i: Integer; begin Result := inherited ExecuteOperation(Operation, Parameter); for i:=0 to FColumnSetList.Count-1 do //if FColumnSetList[i] is TColumnSet then GMCheckExecOperation((FColumnSetList[i] as TColumnSet).InterfaceSource, Operation, '', {$I %CurrentRoutine%}, Parameter); end; { ------------------------------- } { ---- Invalidatable records ---- } { ------------------------------- } procedure RGMDisplayTextData.Invalidate; begin Text := ''; IsValid := False; end; procedure RGMCachedUnionValue.Invalidate; begin Value := uvtUnassigned; IsValid := False; end; { ------------------------ } { ---- TGMValueBuffer ---- } { ------------------------ } constructor TGMValueBuffer.Create(const AOwner: TObject; const ADataType: TGMDBColumnDataType; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const ARefLifeTime: Boolean = False); //const cMemAllocDelta: array [Boolean] of LongInt = (1, 512); var bufSize: Integer; // , allocDelta begin FOwner := AOwner; FDataType := ADataType; FIsNull := True; if IsFixedBufferSize then bufSize := CalculateBufferSize else bufSize := 0; //case DataType of // fdtAnsiString, fdtUnicodeString, fdtAnsiText, fdtUnicodeText, fdtBinary: allocDelta := 1; // else allocDelta := SizeOf(Pointer); //end; inherited Create(SizeOf(Pointer), AZeroInit, AFreeMemoryOnDestroy, bufSize, ARefLifeTime); FFullDataSize := bufSize; end; function TGMValueBuffer.IsFixedBufferSize: Boolean; begin Result := IsFixedLengthDataType(DataType); end; function TGMValueBuffer.CalculateBufferSize: LongInt; begin Result := GMValueBufferSizeOfFieldDataType(DataType); end; procedure TGMValueBuffer.InternalSetSize(ANewSize: Int64); begin if not IsFixedBufferSize then inherited InternalSetSize(ANewSize); // else // if ANewSize > MemoryBuffer.SizeInBytes then // raise EGMException.ObjError(GMFormat(RStrFixedBufSizeViolation, [ANewSize, MemoryBuffer.SizeInBytes]), Self, {$I %CurrentRoutine%}); end; function TGMValueBuffer.WriteAt(ulOffset: Int64; pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; begin Result := inherited WriteAt(ulOffset, pv, cb, pcbWritten); Modified := True; DisplayText.Invalidate; end; //function TGMValueBuffer.ExecuteOperation(const AOperation: LongInt; const AParameter: IUnknown = nil): Boolean; //begin // Result := True; // case AOperation of // Ord(opInvalidate): Invalidate(True, False); // else Result := False; // end; //end; function TGMValueBuffer.AskBoolean(const AValueId: LongInt): LongInt; begin //Result := inherited AskBoolean(AValueId); //if Result = Ord(barUnknown) then case AValueId of Ord(bvIsNull): Result := GMBooleanAskResult(IsNull); Ord(bvModified): Result := GMBooleanAskResult(Modified); //Ord(bvDisplayText): Result := GMBooleanAskResult(DisplayText.IsValid); else Result := Ord(barUnknown); end; end; function TGMValueBuffer.CreateValueStream(const AMode: DWORD): ISequentialStream; begin Result := TGMLockBytesIStream.Create(Self, True); end; //procedure TGMValueBuffer.InternalFetchData(const AForDisplayText: Boolean); //begin //end; function TGMValueBuffer.GetDataLength: PtrInt; begin Result := DataSize; end; procedure TGMValueBuffer.SetDataLength(const AValue: PtrInt); begin end; function TGMValueBuffer.IsNull: Boolean; begin Result := FIsNull; end; function TGMValueBuffer.GetModified: Boolean; begin Result := FModified; end; procedure TGMValueBuffer.SetModified(const AValue: Boolean); begin FModified := AValue; end; //function TGMValueBuffer.DataIsCompressed: Boolean; //var Header: TGMCompressedBlobHeaderData; //begin //Result := False; //if DataSize >= SizeOf(Header) then // begin // GMLockByteSafeReadAt(Self, 0, @Header, SizeOf(Header)); // Result := GMIsCompressedBlobHeaderData(Header); // end; //end; function TGMValueBuffer.InternalGetUnionValue: RGMUnionValue; //var unkStrm: IUnknown; begin case DataType of fdtBoolean: Result := Boolean(Memory^); fdtInt8, fdtUInt8: Result := Byte(Memory^); fdtInt16: Result := SmallInt(Memory^); fdtUInt16: Result := Word(Memory^); fdtInt32: Result := LongInt(Memory^); {$IFDEF DELPHI9} fdtUInt32: Result := Longword(Memory^); fdtInt64: Result := Int64(Memory^); fdtUInt64: Result := QWord(Memory^); {$ELSE} fdtUInt32: Result := LongInt(Longword(Memory^)); {$IFDEF DELPHI6} fdtInt64, fdtUInt64: Result := Int64(Memory^); {$ELSE} fdtInt64, fdtUInt64: Result := LongInt(Int64(Memory^)); {$ENDIF} {$ENDIF} fdtSingle: Result := Single(Memory^); fdtDouble, fdtNumeric: Result := Double(Memory^); fdtDate, fdtTime, fdtDateTime: Result := TDateTime(Memory^); fdtGUID: Result := GMGuidToString(TGUID(Memory^)); fdtAnsiString, fdtAnsiText: Result := AnsiString(PAnsiChar(Memory)); fdtUnicodeString, fdtUnicodeText: Result := UnicodeString(PUnicodeChar(Memory)); //fdtAnsiString, fdtAnsiText: Result := GMBufferAsString(Memory, GMStrLen(Memory, GMBoundedInt(DataLength, 0, DataSize))); //fdtUnicodeString, fdtUnicodeText: Result := GMBufferAsWideString(Memory, GMWStrLen(Memory, GMBoundedInt(DataLength, 0, DataSize div SizeOf(WideChar)))); fdtBinary: begin FValueReadStream := CreateValueStream(STGM_READ); Result := FValueReadStream; //if GMQueryInterface(FValueReadStream, IUnknown, unkStrm) then Result := unkStrm else Result := uvtUnassigned; //Result := uvtNull; end; else Result := uvtUnassigned; end; end; function TGMValueBuffer.GetUnionValue: RGMUnionValue; begin if not FCachedValue.IsValid then begin // // Some DOBC drivers may not assign the DataLength indicator with SQL_NULL_DATA even if the indicator is bound via SQLBindCol // Then a first call to SQLGetData ist needed to retrieve the NULL status of the value // if IsTextFieldDataType(DataType) then FCachedValue.Value := InternalGetUnionValue // <- IsNULL may be termined by InternalGetUnionValue in derived classes else if IsNull then FCachedValue.Value := uvtNull else FCachedValue.Value := InternalGetUnionValue; FCachedValue.IsValid := True; end; Result := FCachedValue.Value; end; procedure TGMValueBuffer.InternalSetUnionValue(const AValue: RGMUnionValue); var aStr: AnsiString; wStr: UnicodeString; valByteSize, bufByteSize: Cardinal; unkStrm: IUnknown; begin case DataType of fdtBoolean: Boolean(Memory^) := AValue; // <- the assignent may convert the data type! fdtInt8, fdtUInt8: Byte(Memory^) := AValue; // <- the assignent may convert the data type! fdtInt16: SmallInt(Memory^) := AValue; // <- the assignent may convert the data type! fdtUInt16: Word(Memory^) := AValue; // <- the assignent may convert the data type! fdtInt32: LongInt(Memory^) := AValue; // <- the assignent may convert the data type! fdtUInt32: LongWord(Memory^) := AValue; // <- the assignent may convert the data type! {$IFDEF DELPHI9} fdtInt64: case AValue.ValueType of uvtString: Int64(Memory^) := GMStrToInt64(AValue); else Int64(Memory^) := AValue; end; fdtUInt64: case AValue.ValueType of uvtString: QWord(Memory^) := GMStrToUInt64(AValue); else QWord(Memory^) := AValue; end; {$ELSE} {$IFDEF DELPHI6} fdtInt64, fdtUInt64: case VarType(AValue) of varOleStr, varString: Int64(Memory^) := GMStrToInt64(AValue); else Int64(Memory^) := AValue; end; {$ELSE} fdtInt64, fdtUInt64: case VarType(AValue) of varOleStr, varString: Int64(Memory^) := GMStrToInt64(AValue); else Int64(Memory^) := LongInt(AValue); end; {$ENDIF} {$ENDIF} fdtSingle: case AValue.ValueType of uvtString: Single(Memory^) := GMStrToSingle(AValue); else Single(Memory^) := AValue; // <- the assignent may convert the data type! end; fdtDouble, fdtNumeric: case AValue.ValueType of uvtString: Double(Memory^) := GMStrToDouble(AValue); else Double(Memory^) := AValue; // <- the assignent may convert the data type! end; fdtDate, fdtTime, fdtDateTime: TDateTime(Memory^) := AValue; // <- the assignent may convert the data type! fdtGUID: TGUID(Memory^) := GMStringToGuid(GMQuote(GMStrip(AValue, cStrHexChars + '-', True), '{', '}'), Owner, {$I %CurrentRoutine%}); fdtAnsiString, fdtAnsiText: begin aStr := AValue; // <- the assignent may convert the data type! valByteSize := Length(aStr) + 1; bufByteSize := valByteSize; if (FMaxStrLength > 0) and (bufByteSize > FMaxStrLength + 1) then bufByteSize := FMaxStrLength + 1; if IsFixedBufferSize then bufByteSize := GMBoundedInt(bufByteSize, 0, GetDataSize) else GMHrCheckObj(SetSize(bufByteSize), Self, {$I %CurrentRoutine%}); // <- sets FFullDataSize which will be used for copying the contents Move(PAnsiChar(aStr)^, Memory^, bufByteSize); if bufByteSize < valByteSize then PAnsiChar(GMAddPtr(Memory, bufByteSize - 1))^ := #0; DataLength := Max(0, bufByteSize - 1); end; fdtUnicodeString, fdtUnicodeText: begin wStr := AValue; // <- the assignent may convert the data type! valByteSize := (Length(wStr) + 1) * SizeOf(WideChar); // (lstrlenw(TVarData(AValue).VOleStr) + 1) * SizeOf(WideChar); bufByteSize := valByteSize; if (FMaxStrLength > 0) and (bufByteSize > ((FMaxStrLength + 1) * SizeOf(WideChar))) then bufByteSize := (FMaxStrLength + 1) * SizeOf(WideChar); if IsFixedBufferSize then bufByteSize := GMBoundedInt(bufByteSize, 0, GetDataSize) else GMHrCheckObj(SetSize(bufByteSize), Self, {$I %CurrentRoutine%}); // <- sets FFullDataSize which will be used for copying the contents Move(PUnicodeChar(wStr)^, Memory^, bufByteSize); // PUnicodeChar(TVarData(AValue).VOleStr)^ if bufByteSize < valByteSize then PUnicodeChar(GMAddPtr(Memory, bufByteSize - SizeOf(WideChar)))^ := #0; DataLength := Max(0, bufByteSize - SizeOf(WideChar)); // <- must contain the size in Bytes! end; fdtBinary: if AValue.ValueType in [uvtPointer, uvtInterface] then begin //unkStrm := AValue; // .AsPointer; //GMQueryInterface(unkStrm, ISequentialStream, FValueReadStream); GMQueryInterface(AValue, ISequentialStream, FValueReadStream); end; // else // begin // aStr := AValue; // <- the assignent may convert the data type! // valByteSize := Length(aStr); // GMHrCheckObj(SetSize(valByteSize), Self, {$I %CurrentRoutine%}); // <- will raise if fixed and buffer too small // Move(PAnsiChar(aStr)^, Memory^, valByteSize); // DataLength := valByteSize; // end; else raise EGMException.ObjError(MsgUnsupportedFieldDataType(Ord(DataType)), Owner, {$I %CurrentRoutine%}); end; FIsNull := False; end; procedure TGMValueBuffer.InternalSetNullValue; begin FIsNull := True; end; procedure TGMValueBuffer.SetUnionValue(const AUnionValue: RGMUnionValue); begin if AUnionValue.IsNullOrUnassigned then InternalSetNullValue else InternalSetUnionValue(AUnionValue); DisplayText.Invalidate; FCachedValue.Invalidate; //DataFetched := True; Modified := True; end; function TGMValueBuffer.InternalBuildDisplayText: TGMString; begin Result := GetUnionValue.AsStringDflt; end; function TGMValueBuffer.GetText: TGMString; begin if not DisplayText.IsValid then begin DisplayText.Text := InternalBuildDisplayText; DisplayText.IsValid := True; end; Result := DisplayText.Text; end; procedure TGMValueBuffer.Invalidate(const AResetOffset, ASetToNULL: Boolean); begin if AResetOffset then Offset := 0; Modified := False; DisplayText.Invalidate; //DataFetched := False; if ASetToNULL then FIsNull := True; FValueReadStream := nil; FCachedValue.Invalidate; //FCachedValue.IsValid := False; //FCachedValue.Value := uvtUnassigned; end; procedure TGMValueBuffer.AssignFromObj(const Source: TObject); var PIUnknown: IUnknown; begin GMCheckGetInterface(Source, IUnknown, PIUnknown, {$I %CurrentRoutine%}); AssignFromIntf(PIUnknown); end; procedure TGMValueBuffer.AssignFromIntf(const Source: IUnknown); begin FIsNull := GMCheckAskBoolean(Source, Ord(bvIsNull), {$I %CurrentRoutine%}); if not IsNull then inherited AssignFromIntf(Source); Modified := GMCheckAskBoolean(Source, Ord(bvModified), {$I %CurrentRoutine%}); end; { ----------------------------- } { ---- TGMFieldStateBuffer ---- } { ----------------------------- } function TGMFieldStateBuffer.IsFixedBufferSize: Boolean; begin // field state buffers are not frequently reassigned, to save memory they can be tight Result := False; end; { ----------------------------- } { ---- TGMFieldStateHolder ---- } { ----------------------------- } constructor TGMFieldStateHolder.Create(const Source: IUnknown = nil); begin inherited Create; if Source <> nil then AssignFromIntf(Source); end; destructor TGMFieldStateHolder.Destroy; var i: EGMValueBufferInstance; begin for i:=Low(FValueBuffers) to High(FValueBuffers) do GMFreeAndNil(FValueBuffers[i]); inherited Destroy; end; function TGMFieldStateHolder.ValueBufferCreateClass: TGMValueBufferClass; begin Result := TGMFieldStateBuffer; end; function TGMFieldStateHolder.ValueBuffer(const ValueBufferInstance: EGMValueBufferInstance): TGMValueBuffer; begin if FValueBuffers[ValueBufferInstance] = nil then FValueBuffers[ValueBufferInstance] := ValueBufferCreateClass.Create(Self, DataType); Result := FValueBuffers[ValueBufferInstance]; end; procedure TGMFieldStateHolder.ResetContents; var i: EGMValueBufferInstance; begin for i:=Low(FValueBuffers) to High(FValueBuffers) do if FValueBuffers[i] <> nil then FValueBuffers[i].Invalidate(True, True); Name := ''; end; function TGMFieldStateHolder.GetName: TGMString; begin Result := Name; end; procedure TGMFieldStateHolder.SetName(const AValue: TGMString); begin Name := AValue; end; function TGMFieldStateHolder.GetValueBufferIntf(const ValueBufferInstance: LongInt; const IID: TGUID; out Intf): HResult; begin GMCheckIntRange(cStrValBufInstTypeName, ValueBufferInstance, Ord(Low(EGMValueBufferInstance)), Ord(High(EGMValueBufferInstance)), Self, {$I %CurrentRoutine%}); // Always create the desired Valuebuffer in neccessary Result := CQIResult[ValueBuffer(EGMValueBufferInstance(ValueBufferInstance)).GetInterface(IID, Intf)]; end; procedure TGMFieldStateHolder.AssignToObj(const Dest: TObject); var PUnk: IUnknown; begin if (Dest <> nil) and Dest.GetInterface(IUnknown, PUnk) then AssignToIntf(PUnk); end; procedure TGMFieldStateHolder.AssignFromObj(const Source: TObject); var PUnk: IUnknown; begin if (Source <> nil) and Source.GetInterface(IUnknown, PUnk) then AssignFromIntf(PUnk); end; procedure TGMFieldStateHolder.AssignFromIntf(const Source: IUnknown); var i: EGMValueBufferInstance; PIName: IGMGetName; PISourceValBufIntf: IGMGetValueBufferIntf; PIUnkSrcBuf: IUnknown; PIIntfAssign: IGMAssignFromIntf; PIFieldDef: IGMGetValueDefinition; begin ResetContents; GMCheckQueryInterface(Source, IGMGetName, PIName, {$I %CurrentRoutine%}); GMCheckQueryInterface(Source, IGMGetValueDefinition, PIFieldDef, {$I %CurrentRoutine%}); Name := PIName.Name; DataType := PIFieldDef.DataType; for i:=Low(FValueBuffers) to High(FValueBuffers) do if FValueBuffers[i] <> nil then FValueBuffers[i].DataType := DataType; if Source.QueryInterface(IGMGetValueBufferIntf, PISourceValBufIntf) = S_OK then for i:=Low(FValueBuffers) to High(FValueBuffers) do if PISourceValBufIntf.GetValueBufferIntf(Ord(i), IUnknown, PIUnkSrcBuf) and GetValueBufferIntf(Ord(i), IGMAssignFromIntf, PIIntfAssign) = S_OK then PIIntfAssign.AssignFromIntf(PIUnkSrcBuf); end; procedure TGMFieldStateHolder.AssignToIntf(const Dest: IUnknown); var i: EGMValueBufferInstance; PIDestValBufIntf: IGMGetValueBufferIntf; PIDestBufAssign: IGMAssignFromIntf; PIUnkSrcBuf: IUnknown; begin if Dest <> nil then begin if Dest.QueryInterface(IGMGetValueBufferIntf, PIDestValBufIntf) = S_OK then for i:=Low(FValueBuffers) to High(FValueBuffers) do if (PIDestValBufIntf.GetValueBufferIntf(Ord(i), IGMAssignFromIntf, PIDestBufAssign) = S_OK) and (GetValueBufferIntf(Ord(i), IUnknown, PIUnkSrcBuf) = S_OK) then PIDestBufAssign.AssignFromIntf(PIUnkSrcBuf); end; end; { --------------------------------- } { ---- TGMRecordsetStateHolder ---- } { --------------------------------- } constructor TGMRecordsetStateHolder.Create(const Source: IUnknown = nil); begin inherited Create(True); FFieldStates := TGMObjArrayCollection.Create(True); if Source <> nil then AssignFromIntf(Source); end; destructor TGMRecordsetStateHolder.Destroy; begin GMFreeAndNil(FFieldStates); inherited Destroy; end; procedure TGMRecordsetStateHolder.ResetContents; begin Fieldstates.Clear; State := CGMUnknownState; Position := CGMUnknownPosition; end; function TGMRecordsetStateHolder.FieldStateCreateClass: TGMFieldStateCreateClass; begin Result := TGMFieldStateHolder; end; procedure TGMRecordsetStateHolder.TellEnumString(const ItemKind: LongInt; const Value: TGMString; const Parameter: Pointer); var FieldByName: IGMGetIntfByName; PUnk: IUNknown; begin if (ItemKind = Ord(eidFieldNames)) and (FSource <> nil) and (FSource.QueryInterface(IGMGetIntfByName, FieldByName) = S_OK) and (FieldByName.GetIntfByName(Value, IUnknown, PUnk) = S_OK) then FieldStates.Add(FieldStateCreateClass.Create(PUnk)); end; procedure TGMRecordsetStateHolder.AssignFromObj(const Source: TObject); var PIUnk: IUnknown; begin GMCheckGetInterface(Source, IUnknown, PIUnk, {$I %CurrentRoutine%}); AssignFromIntf(PIUnk); end; procedure TGMRecordsetStateHolder.AssignToObj(const Dest: TObject); var PIUnk: IUnknown; begin GMCheckGetInterface(Dest, IUnknown, PIUnk, {$I %CurrentRoutine%}); AssignToIntf(PIUnk); end; procedure TGMRecordsetStateHolder.AssignFromIntf(const Source: IUnknown); var PIPosition: IGMGetPosition; PIState: IGMGetState; PIEnumValues: IGMEnumerateItems; begin if Source <> nil then begin //GMCheckIntfIsActive(Source, {$I %CurrentRoutine%}); <- Allow Inactive State! ResetContents; if (Source.QueryInterface(IGMGetPosition, PIPosition) = S_OK) then Position := PIPosition.Position else Position := CGMUnknownPosition; if (Source.QueryInterface(IGMGetState, PIState) = S_OK) then State := PIState.State else State := CGMUnknownState; if (State in cUpdatableStates) and (Source.QueryInterface(IGMEnumerateItems, PIEnumValues) = S_OK) then try FSource := Source; PIEnumValues.EnumerateItems(Ord(eidFieldNames), Self); finally FSource := nil; // <- Dont hold a reference, otherwise use a TGMRecordsetIntfSource end; end; end; procedure TGMRecordsetStateHolder.AssignFields(const Dest: IUnknown); var i: Integer; PIFieldByName: IGMGetIntfByName; PIDestField: IUnknown; begin if Dest.QueryInterface(IGMGetIntfByName, PIFieldByName) = S_OK then for i:=0 to Fieldstates.Count-1 do if PIFieldByName.GetIntfByName((Fieldstates[i] as TGMFieldStateHolder).Name, IUnknown, PIDestField) = S_OK then (Fieldstates[i] as TGMFieldStateHolder).AssignToIntf(PIDestField); end; procedure TGMRecordsetStateHolder.AssignToIntf(const Dest: IUnknown); var PIDestPosition: IGMGetSetPosition; PIDestState: IGMGetState; procedure InvalidStateTransition(const OldState, NewState: LongInt); begin raise EGMException.ObjError(MsgInvalidStateTransition(OldState, NewState), Self, {$I %CurrentRoutine%}); end; begin if Dest <> nil then begin if Position <> CGMUnknownPosition then begin GMCheckQueryInterface(Dest, IGMGetSetPosition, PIDestPosition, {$I %CurrentRoutine%}); if Position <> PIDestPosition.Position then begin GMCheckExecRSOperation(Dest, roLeaveModifyingState, {$I %CurrentRoutine%}); PIDestPosition.Position := Position; end; end; if State <> CGMUnknownState then begin GMCheckQueryInterface(Dest, IGMGetState, PIDestState, {$I %CurrentRoutine%}); if State <> PIDestState.State then case State of Ord(rsInactive): GMSetIntfActive(Dest, False); Ord(rsBrowsing): case PIDestState.State of Ord(rsInactive): GMSetIntfActive(Dest, True); Ord(rsInserting), Ord(rsEditing): if not GMExecuteOperation(Dest, Ord(roLeaveModifyingState)) then InvalidStateTransition(PIDestState.State, State); end; Ord(rsInserting): if PIDestState.State <> Ord(rsBrowsing) then InvalidStateTransition(PIDestState.State, State) else GMCheckExecRSOperation(Dest, roInsert, {$I %CurrentRoutine%}); Ord(rsEditing): if PIDestState.State <> Ord(rsBrowsing) then InvalidStateTransition(PIDestState.State, State) else GMCheckExecRSOperation(Dest, roEdit, {$I %CurrentRoutine%}); else InvalidStateTransition(PIDestState.State, State); end; if State in cUpdatableStates then AssignFields(Dest); end; end; end; { --------------------------------- } { ---- TGMNameAndValueMatchObj ---- } { --------------------------------- } constructor TGMNameAndValueMatchObj.Create(const AData: TNameAndValueMatch; const RefLifeTime: Boolean = False); begin inherited Create(RefLifeTime); FData := AData; end; function TGMNameAndValueMatchObj.GetName: TGMString; begin Result := FData.Name; end; function TGMNameAndValueMatchObj.GetUnionValue: RGMUnionValue; begin Result := FData.Value; end; procedure TGMNameAndValueMatchObj.SetUnionValue(const AUnionValue: RGMUnionValue); begin FData.Value := AUnionValue; end; function TGMNameAndValueMatchObj.AskBoolean(const ValueId: LongInt): LongInt; begin case ValueId of Ord(bvMatchCase): Result := GMBooleanAskResult(FData.MatchCase); else Result := Ord(barUnknown); end; end; function TGMNameAndValueMatchObj.AskInteger(const ValueId: LongInt): LongInt; begin case ValueId of Ord(ivMatchKind): Result := Ord(FData.MatchKind); else Result := CInvalidIntValue; end; end; { ---------------------------------- } { ---- TGMNameAndValueMatchList ---- } { ---------------------------------- } constructor TGMNamedValueCollection.Create(const Names: array of TGMString; const RefLifeTime: Boolean = True); var i: Integer; begin inherited Create(True, False, False, GMCompareByName, RefLifeTime); for i:=Low(Names) to High(Names) do Add(TGMNameAndValueObj.Create(Names[i], uvtNull, False)); end; function TGMNamedValueCollection.GetIntfByName(const Name: TGMString; const IID: TGUID; out Intf): HResult; var PIName: IUnknown; Entry: TObject; begin Result := E_FAIL; PIName := TGMNameObj.Create(Name, True); if Find(PIName, Entry) then Result := CQIResult[Entry.GetInterface(IID, Intf)]; end; function TGMNamedValueCollection.FindValueByName(const ValueName: TGMString; var Value: TGMNameAndValueObj): Boolean; var PIName: IUnknown; begin PIName := TGMNameObj.Create(ValueName, True); Result := Find(PIName, Value); //if Result then Value := Items[Idx] as TGMNameAndValueObj; end; procedure TGMNamedValueCollection.SaveValues; var i: Integer; begin for i:=0 to Count-1 do if Entries[i] is TGMFieldNameAndValue then (Entries[i] as TGMFieldNameAndValue).SaveValue; end; procedure TGMNamedValueCollection.RestoreValues; var i: Integer; begin for i:=0 to Count-1 do if Entries[i] is TGMFieldNameAndValue then (Entries[i] as TGMFieldNameAndValue).RestoreValue; end; procedure TGMNamedValueCollection.ClearOldValues; var i: Integer; begin for i:=0 to Count-1 do if Entries[i] is TGMFieldNameAndValue then (Entries[i] as TGMFieldNameAndValue).ClearOldValue; end; { ---------------------------------- } { ---- TGMNameAndValueMatchList ---- } { ---------------------------------- } constructor TGMNameAndValueMatchList.Create(const Values: array of TNameAndValueMatch; const RefLifeTime: Boolean = True); var i: Integer; begin inherited Create(True, False, False, nil, RefLifeTime); for i:=Low(Values) to High(Values) do Add(TGMNameAndValueMatchObj.Create(Values[i])); end; { ------------------------------ } { ---- TGMFieldNameAndValue ---- } { ------------------------------ } constructor TGMFieldNameAndValue.Create(const AOwner: TObject; const AName: TGMString; const AValue: RGMUnionValue; const AReadOnly: Boolean = False; const ARefLifeTime: Boolean = False); begin inherited Create(AName, AValue, ARefLifeTime); FReadOnly := AReadOnly; FOwner := AOwner; end; procedure TGMFieldNameAndValue.NotifyValueChange; var PIChangeNotify: IGMNamedValueChange; begin if (FOwner <> nil) and FOwner.GetInterface(IGMNamedValueChange, PIChangeNotify) then PIChangeNotify.AfterValueChange(Name); end; procedure TGMFieldNameAndValue.SetUnionValue(const AUnionValue: RGMUnionValue); begin inherited SetUnionValue(AUnionValue); NotifyValueChange; end; function TGMFieldNameAndValue.GetDataType: TGMDBColumnDataType; begin Result := GMDbDataTypeOfUnionType(FValue.ValueType); end; function TGMFieldNameAndValue.GetNullValuesAllowed: TGMAllowNullValues; begin Result := nvNullableUnknown; end; function TGMFieldNameAndValue.GetUpdatable: Boolean; //const CUpdatable: array [Boolean] of TGMUpdatable = (upUpdatable, upReadonly); begin Result := not ReadOnly; end; procedure TGMFieldNameAndValue.SaveValue; begin FOldValue := FValue; end; procedure TGMFieldNameAndValue.RestoreValue; begin FValue := FOldValue; ClearOldValue; end; procedure TGMFieldNameAndValue.ClearOldValue; begin FOldValue := uvtUnassigned; end; { --------------------------------- } { ---- TGMNamedValuesContainer ---- } { --------------------------------- } constructor TGMNamedValuesContainer.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FTimedReCalculationDelay := cDfltReExecutionDelay; FNamedValuesList := TGMNamedValueCollection.Create([], False); FMasterSource := TGMRecordsetMasterSource.Create(Self, []); FReCalculationTimer := TGMThreadTimer.Create(RecalculateValues, Self, FTimedReCalculationDelay); MasterSource.OnAfterActiveChange := AfterMasterActiveChange; MasterSource.OnAfterPositionChange := AfterMasterPositionChange; MasterSource.OnAfterOperation := AfterMasterOperation; CreateConnectionPoint(IGMNamedValueChange); FState := rsInactive; end; destructor TGMNamedValuesContainer.Destroy; begin inherited Destroy; // <- may access members during closing GMFreeAndNil(FReCalculationTimer); GMFreeAndNil(FMasterSource); GMFreeAndNil(FNamedValuesList); end; function TGMNamedValuesContainer.GetActive: Boolean; begin Result := FState <> rsInactive; end; procedure TGMNamedValuesContainer.InternalOpen; begin FState := rsBrowsing; end; procedure TGMNamedValuesContainer.InternalClose; begin ReCalculationTimer.Stop; FState := rsInactive; end; procedure TGMNamedValuesContainer.AddNamedValue(const Name: TGMString; const Value: RGMUnionValue; const ReadOnly: Boolean = False; const NotifyValueChange: Boolean = False); begin NamedValuesList.Add(TGMFieldNameAndValue.Create(Self, Name, Value, ReadOnly)); if NotifyValueChange then AfterValueChange(Name); end; function TGMNamedValuesContainer.GetValue(const AIndex: RGMUnionValue): RGMUnionValue; var NamedValue: TGMNameAndValueObj; begin case AIndex.ValueType of uvtInt16, uvtInt32, uvtInt64, uvtDouble: Result := (NamedValuesList[AIndex] as TGMFieldNameAndValue).Value; uvtString: if NamedValuesList.FindValueByName(AIndex, NamedValue) then Result := NamedValue.Value else raise EGMException.ObjError(GMFormat(srValueNameNotFound, [AIndex.AsStringDflt]), Self, {$I %CurrentRoutine%}); else raise EGMException.ObjError(GMFormat(RStrUnsupportedIdxType, [AIndex.ValueTypeName]), Self, {$I %CurrentRoutine%}); end; end; procedure TGMNamedValuesContainer.SetValue(const AIndex: RGMUnionValue; const Value: RGMUnionValue); var NamedValue: TGMNameAndValueObj; begin case AIndex.ValueType of uvtInt16, uvtInt32, uvtInt64, uvtDouble: (NamedValuesList[AIndex] as TGMFieldNameAndValue).Value := Value; uvtString: if NamedValuesList.FindValueByName(AIndex, NamedValue) then NamedValue.Value := Value else raise EGMException.ObjError(GMFormat(srValueNameNotFound, [AIndex.AsStringDflt]), Self, {$I %CurrentRoutine%}); else raise EGMException.ObjError(GMFormat(RStrUnsupportedIdxType, [AIndex.ValueTypeName]), Self, {$I %CurrentRoutine%}); end; end; function TGMNamedValuesContainer.GetMasterSourceConnector: TGMRecordsetMasterSource; begin Result := FMasterSource; end; procedure TGMNamedValuesContainer.SetMasterSourceConnector(const Value: TGMRecordsetMasterSource); begin FMasterSource.AssignFromObj(Value); end; function TGMNamedValuesContainer.GetMasterSource: IUnknown; begin Result := MasterSource.InterfaceSource; end; procedure TGMNamedValuesContainer.SetMasterSource(const AValue: IUnknown); begin MasterSource.InterfaceSource := AValue; end; procedure TGMNamedValuesContainer.ScheduleReCalculation; begin if ReCalculationTimer.Interval = 0 then RecalculateValues(Self) else ReCalculationTimer.Restart(FTimedReCalculationDelay); end; procedure TGMNamedValuesContainer.RecalculateValues(const Sender: TObject); begin if Assigned(OnRecalculateValues) then OnRecalculateValues(Self); Close; Open; // <- will stop timer and notify connected objects end; procedure TGMNamedValuesContainer.AfterMasterActiveChange(const NewActive: Boolean); begin if not MasterSource.AutoActivate then Exit; if NewActive then ScheduleReCalculation else Close; end; procedure TGMNamedValuesContainer.AfterMasterPositionChange; begin ScheduleReCalculation; end; procedure TGMNamedValuesContainer.AfterMasterOperation(const Operation: LongInt; const Parameter: IUnknown = nil); begin case Operation of Ord(roInsert), Ord(roCancelChanges), Ord(roApplychanges), Ord(roRefreshCurrent), Ord(roReExecuteStatement): ScheduleReCalculation; end; end; { ---- Interfaces ---- } function TGMNamedValuesContainer.AskBoolean(const ValueId: LongInt): LongInt; begin case ValueId of Ord(bvCanModify){, Ord(bvCursorValid)}: Result := GMBooleanAskResult(True); //Ord(bvCanSetPosition): Result := GMBooleanAskResult(False); //Ord(bvIsEmpty): Result := GMBooleanAskResult(False); else Result := Ord(barUnknown); end; end; function TGMNamedValuesContainer.GetCount: PtrInt; begin Result := 1; // <- we have only one record end; function TGMNamedValuesContainer.GetState: LongInt; begin Result := Ord(FState); end; procedure TGMNamedValuesContainer.EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer); var PIEnumSink: IGMTellEnumString; i: Integer; WasActive: Boolean; begin if (TellEnumSink = nil) or (TellEnumSink.QueryInterface(IGMTellEnumString, PIEnumSink) <> S_OK) then Exit; case ItemKind of Ord(eidFieldNames): begin WasActive := Active; try Open; for i:=0 to NamedValuesList.Count-1 do if (NamedValuesList[i] is TGMNameAndValueObj) then try PIEnumSink.TellEnumString(ItemKind, TGMNameAndValueObj(NamedValuesList[i]).Name, Pointer(Parameter)); except end; finally if not WasActive then Close; end; end; end; end; function TGMNamedValuesContainer.CaptureState: IUnknown; begin Result := nil; end; procedure TGMNamedValuesContainer.RestoreState(const State: IUnknown); begin end; function TGMNamedValuesContainer.GetPosition: PtrInt; begin Result := 1; end; function TGMNamedValuesContainer.GetIntfByName(const Name: TGMString; const IID: TGUID; out Intf): HResult; begin Result := NamedValuesList.GetIntfByName(Name, IID, Intf); end; function TGMNamedValuesContainer.GetIntfByPosition(const Position: PtrInt; const IID: TGUID; out Intf): HResult; begin Result := NamedValuesList.GetIntfByPosition(Position, IID, Intf); end; procedure TGMNamedValuesContainer.AfterValueChange(const ValueName: TGMString); begin GMCpcCallNotifySinks(Self, IGMNamedValueChange, GMCallSinkAfterFieldValueChange, NotifyDisableCount = 0, [ValueName]); if Assigned(FOnAfterValueChange) then FOnAfterValueChange(Self, ValueName); end; function TGMNamedValuesContainer.CanExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; begin case Operation of //Ord(roSetSimplestConfiguration) Ord(roReExecuteStatement), Ord(roScheduleReExecution): Result := FState in [rsInactive, rsBrowsing]; Ord(roRefreshCurrent), Ord(roInsert), Ord(roEdit), Ord(roDelete): Result := FState = rsBrowsing; Ord(roCancelChanges), Ord(roApplyChanges), Ord(roLeaveModifyingState): Result := IsUpdatableState(Ord(FState)); else Result := False; end; end; function TGMNamedValuesContainer.ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; begin Result := True; case Operation of // Ord(roDelete) Ord(roSetSimplestConfiguration) Ord(roReExecuteStatement): RecalculateValues(Self); Ord(roScheduleReExecution): ScheduleReCalculation; Ord(roEdit): begin NamedValuesList.SaveValues; FState := rsEditing; end; Ord(roInsert): begin NamedValuesList.SaveValues; FState := rsInserting; end; Ord(roRefreshCurrent), Ord(roDelete): ; // <- Nothing Ord(roLeaveModifyingState), Ord(roApplyChanges): begin NamedValuesList.ClearOldValues; FState := rsBrowsing; end; Ord(roCancelChanges): begin NamedValuesList.RestoreValues; FState := rsBrowsing; end; else Result := False; end; end; procedure TGMNamedValuesContainer.LoadData(const Source: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); begin NamedValuesList.LoadData(Source, ACryptCtrlData); end; procedure TGMNamedValuesContainer.StoreData(const Dest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); begin NamedValuesList.StoreData(Dest, ACryptCtrlData); end; { ----------------------------- } { ---- TGMSqlStatementBase ---- } { ----------------------------- } constructor TGMSqlStatementBase.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); ObjectConnectedTo.OnBeforeIntfSourceChange := OnBeforeIntfSourceChange; FReExecutionTimer := TGMThreadTimer.Create(OnTimedReExecution, Self, cDfltReExecutionDelay); FSQL := TGMSqlProperty.Create(Self, ''); FSQL.OnAfterSQLChange := SQLChanged; FState := rsInactive; CreateConnectionPoint(IGMSQLChangeNotifications); end; constructor TGMSqlStatementBase.Create(const AConnection: IUnknown; const ASql: TGMString; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); SQL.SQLText := ASql; ConnectionIntf := AConnection; end; destructor TGMSqlStatementBase.Destroy; begin ReExecutionTimer.Stop; inherited Destroy; GMFreeAndNil(FReExecutionTimer); GMFreeAndNil(FSQL); end; procedure TGMSqlStatementBase.OnBeforeIntfSourceChange(const OldSource, NewSource: IUnknown); begin if Oldsource <> NewSource then CheckIsInactive('ConnectionIntf ' + RStrProperty); end; procedure TGMSqlStatementBase.AssignFromObj(const Source: TObject); begin if Source is TGMSqlStatementBase then begin Close; ConnectionIntf := TGMSqlStatementBase(Source).ConnectionIntf; SQL := TGMSqlStatementBase(Source).SQL; end; end; procedure TGMSqlStatementBase.SQLChanged(const Sender: TObject); begin NotifyAfterSQLChange; if Assigned(OnAfterSQLChange) then OnAfterSQLChange(Self); end; procedure TGMSqlStatementBase.ResetMembers; begin FInternalExecuted := False; FState := rsInactive; end; procedure TGMSqlStatementBase.DoStateChange(const AOperation: TGMRecordsetOperation; const AInternalOperationProc: TGMObjectProc; const AParameter: IUnknown); var newState: TGMRecordsetState; begin newState := RecordsetStateAfterOperation(AOperation, Self); if (State <> newState) or (AOperation in [roDelete, roRefreshCurrent, roReExecuteStatement, roScheduleReExecution, roLeaveModifyingState]) then begin NotifyBeforeOperation(Ord(AOperation), AParameter); if Assigned(AInternalOperationProc) then AInternalOperationProc; FState := newState; NotifyAfterOperation(Ord(AOperation), AParameter); end; end; function TGMSqlStatementBase.GetTimedReExecutionDelay: Integer; begin Result := ReExecutionTimer.Interval; end; procedure TGMSqlStatementBase.SetTimedReExecutionDelay(const AValue: Integer); begin ReExecutionTimer.Interval := AValue; end; procedure TGMSqlStatementBase.SetSQL(const AValue: TGMSqlProperty); begin SQL.AssignFromObj(AValue); end; function TGMSqlStatementBase.GetConnectionIntf: IUnknown; begin Result := ObjectConnectedTo.InterfaceSource; end; procedure TGMSqlStatementBase.SetConnectionIntf(const AValue: IUnknown); begin ObjectConnectedTo.InterfaceSource := AValue; // <- will be checked via OnBeforeIntfSourceChange {if AValue <> ConnectionIntf then begin CheckIsInactive('ConnectionIntf ' + RStrProperty); ObjectConnectedTo.InterfaceSource := AValue; end;} end; function TGMSqlStatementBase.GetSubItems(const AParentFieldName: TGMString; const AParentFieldValue: RGMUnionValue; const AIID: TGUID; out Intf): HResult; begin Result := GMGetSubItemsBySQL(Self, AParentFieldName, AParentFieldValue, AIID, Intf); end; { ---- Handles ---- } procedure TGMSqlStatementBase.InternalExecute; var sqlTxt: TGMString; begin sqlTxt := GetResolvedSQLStatement; CheckSQLStatementText(sqlTxt); if vfGMDoTracing then GMTrace('===================================================' + cNewLine + sqlTxt, tpSQL); APIExecuteSQL(sqlTxt); end; procedure TGMSqlStatementBase.AllocHandle; begin //if HandleAllocated {nd not InternalExecuted ?} then //begin InternalExecute; FInternalExecuted := True; //end; end; procedure TGMSqlStatementBase.ReleaseHandle; begin ReExecutionTimer.Stop; ResetMembers; end; { ---- Execute ---- } function TGMSqlStatementBase.GetResolvedSQLStatement: TGMString