{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: GM - Interfaces | } { | | } { | | } { | Copyright (C) - 1996 - Gerrit Moeller. | } { | | } { | Source code dstributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMIntf; interface uses {$IFDEF JEDIAPI}jwaWinType, jwaWinError, jwaWinNT, jwaWinUser,{$ELSE}Windows,{$ENDIF} GMStrDef ,GMActiveX, GMUnionValue, SysUtils, TypInfo; const cDfltRoutineName = ''; cStrFieldDataTypeName = 'TGMDBColumnDataType'; CGMUnknownState = -1; CGMUnknownPosition = -1; cGMUnknownCount = -1; CInvalidEnumPos = High(LongInt); cCurrentStrmPos = -1; cDfltCoCeateContext = CLSCTX_SERVER; cDfltReadString = ''; cDfltReadInteger = 0; cDfltReadBoolean = False; cDfltReadFloat = 0; cDfltReadDateTime = 0; cDfltCopyBufferSize = $10000; // <- 64 KB cDfltUiResponseMS = 400; // 330; // <- Milliseconds cFormatBufSize = 4096; cDfltCoInitFlags = COINIT_APARTMENTTHREADED; // COINIT_MULTITHREADED scSubNodesDirSeparator = '.'; //cStrUnknown = '?'; cCustomHrError: LongInt = LongInt($A0000000); cNewLine = #13#10; c2NewLine = cNewLine + cNewLine; type {$IFNDEF JEDIAPI} {$IFNDEF FPC} {$IFDEF CPU64} PtrInt = Int64; PtrUInt = QWord; {$ELSE} PtrInt = LongInt; PtrUInt = LongWord; {$ENDIF} PPtrInt = ^PtrInt; PPtrUInt = ^PtrUInt; {$ENDIF} {$ENDIF} TGMCompareResult = (crALessThanB, crAEqualToB, crAGreaterThanB); TGMSeverityLevel = (svNone, svConfirmation, svInformation, svWarning, svError); //TGMSeverityLevel = svInformation .. svError; //TSeverityLevels = set of TGMSeverityLevelBase; TGMCharKind = (ckUnknown, ckAnsi, ckUtf8, ckUtf16LE, ckUtf16BE); EGMLineEndKind = (lekUnknown, lekCR, lekCRLF, lekLF, leLFCR); //TGMCharKind = (ckAnsi, ckUtf8, ckUtf16LE, jccISO_8859_1); TGMCheckRefCountProc = procedure(const ARefCount: LongInt; const AObj: TObject); PGMPtrIntArray = ^TGMPtrIntArray; TGMPtrIntArray = array of PtrInt; procedure GMAddIntegersToArray(var ADest: TGMPtrIntArray; const AValues: array of PtrInt); // // Optionally exported function of plugins to write their resource string PO files // type TDllWriteResStrPOFileProc = procedure (FileExtension: TApiString = ''; OutputFolder: TApiString = ''); stdcall; const cStrDllWriteResStrPOFileProcName = 'DllWriteResStrPOFile'; { ------------------------------ } { ---- Type Safe Interfaces ---- } { ------------------------------ } type // // This generic prevents you from using a different (wrong) IID than the variable was declared for // TIntf is meant to be an interface type derived from IUnknown // RGMTypedIntf<TIntf> = record public Intf: TIntf; //class operator Implicit(const ATypedIntf: RGMTypedIntf<TIntf>): Pointer; //class operator Implicit(AValue: Pointer): RGMTypedIntf<TIntf>; class operator := (const ATypedIntf: RGMTypedIntf<TIntf>): TIntf; class operator := (AValue: IUnknown): RGMTypedIntf<TIntf>; class operator := (AObj: TObject): RGMTypedIntf<TIntf>; function QueryFrom(AIntf: IUnknown; ACheckResult: Boolean = False): Boolean; function GetFrom(AObj: TObject; ACheckResult: Boolean = False): Boolean; function Call(ACaller: TObject = nil): TIntf; end; { ----------------------- } { ---- String Arrays ---- } { ----------------------- } type PGMStringArray = ^TGMStringArray; TGMStringArray = array of TGMString; function GMStringArray(const AStrings: array of TGMString): TGMStringArray; procedure GMAddStrToArray(const AValue: TGMString; var AStringArray: TGMStringArray; const AAddEmptyStrings: Boolean = False); function GMStrArrayAsText(const AStrings: TGMStringArray; const ASeparator: TGMString = cNewLine): TGMString; function GMIndexOfStrInArray(const AValue: TGMString; const AStringArray: TGMStringArray): PtrInt; function GMFindStrInArray(const AValue: TGMString; const AStringArray: TGMStringArray; var AIdx: PtrInt): Boolean; procedure GMDeleteStrInArray(var AStringArray: TGMStringArray; const AIdx: PtrInt); { -------------------------------- } { ---- Thread synchronization ---- } { -------------------------------- } type IGMCriticalSection = interface(IUnknown) ['{278BDF06-1387-4181-A83D-8DDF4E18CE03}'] procedure EnterCriticalSection; procedure LeaveCriticalSection; //function TryEnterCriticalSection: Boolean; end; procedure GMEnterCriticalSection(const ACriticalSection: IUnknown); procedure GMLeaveCriticalSection(const ACriticalSection: IUnknown); { ----------------- } { ---- Objects ---- } { ----------------- } type // // Getting the object implementing an interface // IGMObjInfo = interface(IUnknown) ['{F8FF8365-3C8F-4730-B628-82280DCC75FB}'] function GetClassName: TGMString; function GetClassType: TClass; function GetInstance: TObject; function GetTypeInfo: PTypeInfo; // <- will return nil unless class has been declared with $M+ compiler directive! property ClassName: TGMString read GetClassName; property ClassType: TClass read GetClassType; property Instance: TObject read GetInstance; property TypeInfo: PTypeInfo read GetTypeInfo; end; TGMHashCode = PtrInt; IGMHashCode = interface(IUnknown) ['{9C61B58B-41DF-4695-9716-AC4A343DC2DB}'] function HashCode: TGMHashCode; end; { -------------------- } { ---- Exceptions ---- } { -------------------- } IGMGetHRCode = interface(IUnknown) ['{B3526DBB-F29F-474e-94A0-C8B3218DABC0}'] function GetHRCode: HResult; stdcall; property HRCode: HResult read GetHRCode; end; function GMGetObjHRCode(const AObj: TObject; const ADefaultHrCode: HResult = S_OK): HResult; function GMGetIntfHRCode(const AIntf: IUnknown; const ADefaultHrCode: HResult = S_OK): HResult; function GMIsOneOfIntegers(const AValue: PtrInt; const AIntValues: array of PtrInt): Boolean; type IGMSetExceptionInformation = interface(IUnknown) ['{07870B30-5CFA-4F90-8A22-EEB7EE796543}'] procedure SetMessage(AMessage: PGMChar); stdcall; procedure SetSeverityLevel(ASeverityLevel: TGMSeverityLevel); stdcall; end; IGMExceptionInformation = interface(IUnknown) ['{E9D30915-FAF3-43b3-A3FA-B3AE9E24EA02}'] // // The TGMExceptionHandlerObj will ask raised Exceptions for // this Interface. If they have this interface the information // will be used to display more comprehensive error information. // function GetGMMessage: PGMChar; stdcall; function GetExceptionClassName: PGMChar; stdcall; function GetExceptAddress: Pointer; stdcall; function GetRaisorName: PGMChar; stdcall; function GetRaisorClassName: PGMChar; stdcall; function GetRoutineName: PGMChar; stdcall; function GetSeverityLevel: TGMSeverityLevel; stdcall; function GetHelpCtx: LongInt; stdcall; property GMMessage: PGMChar read GetGMMessage; property ExceptionClassName: PGMChar read GetExceptionClassName; property ExceptAddress: Pointer read GetExceptAddress; property RaisorName: PGMChar read GetRaisorName; property RaisorClassName: PGMChar read GetRaisorClassName; property RoutineName: PGMChar read GetRoutineName; property SeverityLevel: TGMSeverityLevel read GetSeverityLevel; property HelpContext: LongInt read GetHelpCtx; end; TGMDfltVerticalAlignment = (vaDefault, vaTop, vaCenter, vaBottom); TGMVerticalAlignment = vaTop .. vaBottom; TGMDfltHorizontalAlignment = (haDefault, haLeft, haCenter, haRight); TGMHorizontalAlignment = haLeft .. haRight; TGMColumnDescRec = record Title: TGMString; Width: LongInt; Alignment: TGMDfltHorizontalAlignment; end; IGMClear = interface(IUnknown) ['{EC95F51C-8238-40AB-A1A2-406C761E1456}'] procedure Clear(const ANotify: Boolean = True); end; { ----------------------------- } { ---- Activatable Objects ---- } { ----------------------------- } IGMGetActive = interface(IUnknown) ['{BEB78B21-2B77-11d5-AB38-000021DCAD19}'] // // Anything that can be activated, like: // - Recordsets // - Players // - Connections // function GetActive: Boolean; stdcall; property Active: Boolean read GetActive; end; IGMGetSetActive = interface(IGMGetActive) ['{731F9581-1642-11d5-A5E4-00E0987755DD}'] procedure SetActive(const Value: Boolean); stdcall; property Active: Boolean read GetActive write SetActive; end; IGMActiveChangeNotifications = interface(IUnknown) ['{4D3692B3-522B-4bf2-BA82-EAB98198B755}'] procedure BeforeActiveChange(const NewActive: Boolean); stdcall; procedure AfterActiveChange(const NewActive: Boolean); stdcall; end; IGMVerifyActivation = interface(IUnknown) ['{290C3D48-1C5A-11d5-AB38-000021DCAD19}'] // // Verify the State on an activatable object. Raise if it is not. // procedure CheckIsActive(const ACallingName: TGMString = cDfltRoutineName); stdcall; procedure CheckIsInactive(const NeedInActiveName: TGMString = cDfltRoutineName); stdcall; end; function GMObjIsActive(const AObj: TObject; const ADefaultValue: Boolean = False): Boolean; function GMIntfIsActive(const AIntf: IUnknown; const ADefaultValue: Boolean = False): Boolean; function GMSetObjActive(const AObj: TObject; const Active: Boolean; const ACallingName: TGMString = cDfltRoutineName): Boolean; function GMSetIntfActive(const AIntf: IUnknown; const Active: Boolean; const ACallingName: TGMString = cDfltRoutineName): Boolean; procedure GMCheckObjIsInActive(const AObj: TObject; const NeedInActiveName: TGMString); procedure GMCheckIntfIsInActive(const AIntf: IUnknown; const NeedInActiveName: TGMString); procedure GMCheckObjIsActive(const AObj: TObject; const ACallingName: TGMString = cDfltRoutineName); procedure GMCheckIntfIsActive(const AIntf: IUnknown; const ACallingName: TGMString = cDfltRoutineName); type { ------------------------------------- } { ---- Connections between Objects ---- } { ------------------------------------- } // // There are many situations when Objects need to be connected to each other. // Instead of designing my own set of interfaces for connecting objects I decided // to use th� interfaces IConnectionPointContainer and IConnectionPoint. // // There are implementations for Connection points and containers in unit gmdbbase. // I did my own implementation because I couldn't agree with the borland one. // IGMCreateConnectionPoint = interface(IUnknown) ['{FD024422-1DE8-11d5-AB38-000021DCAD19}'] // // A Implementation of a IConnectionPointContainer may implement this interface // too to let others create new ConnectionPoints from outside. // procedure CreateConnectionPoint(const AIID: TGUID); stdcall; end; IGMDisconnectFromConnectionPoint = interface(IUnknown) ['{0D697004-1D84-11d5-AB38-000021DCAD19}'] // // A Object that is connected to a connection point may implement this interface. // The connection point will call DisconnectFromConnectionPoint on all connected // Objects if it wants the Objects to disconnect from itself (because of closing down or destruction). // procedure DisconnectFromConnectionPoint(const ConnectionPointContainer: IUnknown; const AIID: TGUID; const Cookie: LongInt); stdcall; end; { ----------------- } { ---- Handles ---- } { ----------------- } // // Note: Even if the datatype of a handle can be technically marshalled to // other processes or computers normally a handle will be invalid in // another process (computer). // IGMGetHandle = interface(IUnknown) ['{5BB45961-15A9-11d5-A5E4-00E0987755DD}'] // // Anything that has a Handle: // =========================== // - Windows // - Files // - DB Objects // - GDI Objects etc. // function GetHandle: THandle; stdcall; property Handle: THandle read GetHandle; end; IGMGetSetHandle = interface(IGMGetHandle) ['{A6D2A402-1F1E-11d5-AB38-000021DCAD19}'] // // This one allows to set the Handle too. // procedure SetHandle(const Value: THandle); stdcall; property Handle: THandle read GetHandle write SetHandle; end; IGMGetHandleType = interface(IUnknown) ['{39ED6E5A-DD09-4956-B5C3-58F203EA1A08}'] function GetHandleType: Longword; stdcall; property HandleType: Longword read GetHandleType; end; IGMHandleAllocated = interface(IUnknown) ['{81BED96A-D5A7-418a-8808-31CD51E22117}'] // Windows handles are often created when accessed. // So Handle <> 0 doesnt work since it creates the handle if neccessary. // In such situations use IGMHandleAllocated. function GetHandleAllocated: Boolean; stdcall; property HandleAllocated: Boolean read GetHandleAllocated; end; {IGMEnableDisablePaint = interface(IUnknown) ['655E0FB2-6AC8-4b5d-864B-EFCA768090F9'] function EnablePaint: LongInt; stdcall; function DisablePaint: LongInt; stdcall; function GetPaintDisabledCount: LongInt; stdcall; property PaintDisabledCount: LongInt read GetPaintDisabledCount; end;} { ---------------------- } { ---- Names / Text ---- } { ---------------------- } type IGMGetName = interface(IUnknown) ['{D7242466-1DD0-494e-97CF-7944331A9116}'] function GetName: TGMString; stdcall; property Name: TGMString read GetName; end; IGMGetSetName = Interface(IGMGetName) ['{423674CA-F5D1-4c34-ADF6-E592ACD9D4AA}'] procedure SetName(const Value: TGMString); stdcall; property Name: TGMString read GetName write SetName; end; IGMGetFileName = interface(IUnknown) ['{D3ECCB42-A563-4cc4-B375-79931031ECBA}'] function GetFileName: TGMString; stdcall; property FileName: TGMString read GetFileName; end; IGMGetSetFileName = Interface(IGMGetFileName) ['{ECFB879F-86F6-41a3-A685-0C899A2B5BCA}'] procedure SetFileName(const Value: TGMString); stdcall; property FileName: TGMString read GetFileName write SetFileName; end; IGMGetHint = interface(IUnknown) ['{08E916C0-5208-4513-BB23-71747E5140C3}'] function GetHint: TGMString; stdcall; property Hint: TGMString read GetHint; end; IGMGetSetHint = interface(IGMGetHint) ['{225B8C2D-4FD3-4d6e-B331-6AA331F761BC}'] procedure SetHint(const Value: TGMString); stdcall; property Hint: TGMString read GetHint write SetHint; end; IGMGetText = interface(IUnknown) ['{BBDCFBC0-B9A3-4208-AFC1-3EE2903C21C2}'] function GetText: TGMString; stdcall; property Text: TGMString read GetText; end; IGMGetSetText = interface(IGMGetText) ['{547DA16A-5C69-45a2-9FB0-25D93F749168}'] procedure SetText(const Value: TGMString); stdcall; property Text: TGMString read GetText write SetText; end; { ------------------------------------ } { ---- Objects that have an owner ---- } { ------------------------------------ } type IGMReleaseReferences = interface(IUnknown) ['{A213DBA5-1F9B-11d5-AB38-000021DCAD19}'] procedure ReleaseReferences; stdcall; end; procedure GMReleaseMembers(const AIntf: IUnknown); type IGMGetParentObj = interface(IUnknown) ['{B8487F83-E75D-4e5a-BB2D-BA857CC846FE}'] function GetParentObj: TObject; property ParentObj: TObject read GetParentObj; end; IGMGetSetParentObj = interface(IGMGetParentObj) ['{C7306C62-6C64-4d05-85C1-2593F8960951}'] procedure SetParentObj(const Value: TObject; const Relayout: Boolean = True); //property ParentObj: TObject read GetParentObj write SetParentObj; end; { ------------------------- } { ---- File Attributes ---- } { ------------------------- } TFileAttribute = (faArchive, faCompressed, faDirectory, faEncrypted, faHidden, faNormal, faOffline, faReadOnly, faReparsePoint, faSparse, faSystem, faTemporary); TFileAttributes = set of TFileAttribute; IGMFileProperties = interface(IUnknown) ['{1F883BC2-19F8-4f67-9633-B0CA563F7DC0}'] function GetFileName: TGMString; stdcall; function GetDisplayName: TGMString; stdcall; function GetAttributes: TFileAttributes; stdcall; function GetCreationTime: TDateTime; stdcall; function GetLastAccessTime: TDateTime; stdcall; function GetLastWriteTime: TDateTime; stdcall; function GetSizeInBytes: Int64; stdcall; property FileName: TGMString read GetFileName; property DisplayName: TGMString read GetDisplayName; property Attributes: TFileAttributes read GetAttributes; property CreationTime: TDateTime read GetCreationTime; property LastAccessTime: TDateTime read GetLastAccessTime; property LastWriteTime: TDateTime read GetLastWriteTime; property SizeInBytes: Int64 read GetSizeInBytes; end; function GMDWordToFileAttributes(const AValue: DWORD): TFileAttributes; function GMFileAttributesToDWORD(const AValue: TFileAttributes): DWORD; { ------------------------- } { ---- Enumarte things ---- } { ------------------------- } type IGMTellEnumString = interface(IUnknown) ['{C74E385E-C615-4398-BECE-8B7D537DA87E}'] procedure TellEnumString(const ItemKind: LongInt; const Value: TGMString; const Parameter: Pointer = nil); stdcall; end; IGMTellEnumIntf = interface(IUnknown) ['{54EDEAAA-C059-41d1-9F7A-2611D05A8D73}'] procedure TellEnumIntf(const Sender: IUnknown; const ItemKind: LongInt; const Value: IUnknown; const Parameter: Pointer = nil); stdcall; end; IGMEnumerateItems = interface(IUnknown) ['{525D8C22-275A-11d5-AB38-000021DCAD19}'] procedure EnumerateItems(const ItemKind: LongInt; const TellEnumSink: IUnknown; const Parameter: Pointer = nil); stdcall; end; { ------------------------- } { ---- Locate / Lookup ---- } { ------------------------- } type IGMLookupValues = interface(IUnknown) ['{40B69A61-2819-11d5-AB38-000021DCAD19}'] function LookupValues(const SQLCriteria: TGMString; const Values: IUnknown): Boolean; stdcall; end; TMatchKind = (mkExactMatch, mkNearestMatch); IGMPositionOfValues = interface(IUnknown) ['{52E31022-3907-4fc8-82CF-7FD9B96285F9}'] function PositionOfValues(const Values: IUnknown; var FindPos: LongInt): Boolean; stdcall; end; IGMLocateValues = interface(IUnknown) ['{D19ECF62-28E7-11d5-AB38-000021DCAD19}'] function LocateValues(const Values: IUnknown): Boolean; stdcall; end; { ------------------------------------- } { ---- Getting Interfaces indirect ---- } { ------------------------------------- } IGMGetIntfByName = interface(IUnknown) ['{4694A883-24F6-11d5-AB38-000021DCAD19}'] function GetIntfByName(const Name: TGMString; const AIID: TGUID; out AIntf): HResult; stdcall; end; function GMFieldDisplayText(const FieldName: TGMString; const PIFieldByName: IGMGetIntfByName): TGMString; type IGMGetIntfByPosition = interface(IUnknown) ['{4694A884-24F6-11d5-AB38-000021DCAD19}'] function GetIntfByPosition(const Position: PtrInt; const AIID: TGUID; out AIntf): HResult; stdcall; end; IGMGetPropertyIntf = interface(IUnknown) ['{746A0021-33EC-11d5-AB38-000021DCAD19}'] function GetPropertyIntf(const PropertyName: TGMString; const AIID: TGUID; out AIntf): HResult; stdcall; end; IGMGetSubItems = interface(IUnknown) ['{967AED57-89B8-4547-8A8F-36A3D8C7CD32}'] function GetSubItems(const ParentFieldName: TGMString; const ParentFieldValue: RGMUnionValue; const AIID: TGUID; out AIntf): HResult; end; { ---------------------- } { ---- Data Sources ---- } { ---------------------- } type IGMGetInterfaceSource = interface(IUnknown) ['{DFB04E9F-BC8D-474c-9134-B242699810EC}'] function GetInterfaceSource: IUnknown; stdcall; property InterfaceSource: IUnknown read GetInterfaceSource; end; IGMGetSetInterfaceSource = interface(IGMGetInterfaceSource) ['{06B67B17-78B5-4a54-8959-3EDE25F0CDEA}'] procedure SetInterfaceSource(const Value: IUnknown); stdcall; property InterfaceSource: IUnknown read GetInterfaceSource write SetInterfaceSource; end; function GMGetInterfaceSource(const AContainer: IUnknown): IUnknown; procedure GMSetInterfaceSource(const AContainer, AIntfSource: IUnknown); { ---------------- } { ---- Values ---- } { ---------------- } // // The following Value related interfaces may be implemnted by: // ============================================================ // - Fields // - Parameters // - Cached values // - Anything else that maintains a Value // type IGMGetOleValue = interface(IUnknown) ['{5DC49C42-1BBE-11d5-AB38-000021DCAD19}'] // // Anything that has a Value that can be read // function GetOleValue: OleVariant; stdcall; property Value: OleVariant read GetOleValue; end; IGMGetSetOleValue = interface(IGMGetOleValue) ['{5DC49C44-1BBE-11d5-AB38-000021DCAD19}'] // // Anything that has a Read/Write Value // procedure SetOleValue(const AValue: OleVariant); stdcall; property Value: OleVariant read GetOleValue write SetOleValue; end; function GMGetItemValue(const AContainer: IUnknown; const AItemName: TGMString): RGMUnionValue; overload; function GMGetItemValue(const AContainer: IUnknown; const AItemPosition: LongInt): RGMUnionValue; overload; function GMCheckGetItemValue(const AContainer: IUnknown; const ItemName: TGMString; const ACallingName: TGMString = cDfltRoutineName): RGMUnionValue; overload; function GMCheckGetItemValue(const AContainer: IUnknown; const ItemPosition: LongInt; const ACallingName: TGMString = cDfltRoutineName): RGMUnionValue; overload; procedure GMSetItemValue(const AContainer: IUnknown; const AItemName: TGMString; const AValue: RGMUnionValue); procedure GMCheckSetItemValue(const AContainer: IUnknown; const ItemName: TGMString; const AValue: RGMUnionValue; const ACallingName: TGMString = cDfltRoutineName); function GMGetFieldValueImpl(const AContainer: IUnknown; const AIndex: RGMUnionValue): RGMUnionValue; procedure GMSetFieldValueImpl(const AContainer: IUnknown; const AIndex: RGMUnionValue; const AValue: RGMUnionValue); type IGMGetStringValue = interface(IUnknown) ['{601C32E7-A887-44D3-9604-06D128CF0670}'] function GetStringValue: TGMString; property StringValue: TGMString read GetStringValue; end; IGMGetSetStringValue = interface(IGMGetStringValue) ['{D96903C3-4063-401D-AB17-1FC69E87F23A}'] procedure SetStringValue(const ANewValue: TGMString); property StringValue: TGMString read GetStringValue write SetStringValue; end; IGMGetGUID = interface(IUnknown) ['{54A2C24B-EAF3-4de7-9359-27A88214E02D}'] function GetGUID: TGUID; stdcall; property GUID: TGUID read GetGUID; end; IGMGetSetGUID = interface(IGMGetGUID) ['{7A0B2960-72B6-4cee-BAC9-69C58CFCAF3E}'] procedure SetGUID(const Value: TGUID); stdcall; property GUID: TGUID read GetGUID write SetGUID; end; IGMGetModified = interface(IUnknown) ['{CC345281-29B8-11d5-AB38-000021DCAD19}'] function GetModified: Boolean; stdcall; property Modified: Boolean read GetModified; end; IGMGetSetModified = interface(IGMGetModified) ['{CC345282-29B8-11d5-AB38-000021DCAD19}'] procedure SetModified(const Value: Boolean); stdcall; property Modified: Boolean read GetModified write SetModified; end; IGMValidateValues = interface(IUnknown) ['{BB458E41-2C19-11d5-AB38-000021DCAD19}'] procedure ValidateValues; end; IGMGetReadOnly = interface(IUnknown) ['{88A90C63-47A5-49ae-89CC-E123ACB6D629}'] function GetReadonly: Boolean; stdcall; property ReadOnly: Boolean read GetReadOnly; end; IGMGetSetReadOnly = interface(IGMGetReadOnly) ['{B551AD30-8A05-4b59-9D1C-75FD8F9A478E}'] procedure SetReadOnly(const Value: Boolean); stdcall; property ReadOnly: Boolean read GetReadOnly write SetReadOnly; end; IGMGetEnabled = interface(IUnknown) ['{B460F84A-929B-47d9-8E19-77B63276DB23}'] function GetEnabled: Boolean; stdcall; property Enabled: Boolean read GetEnabled; end; IGMGetSetEnabled = interface(IGMGetEnabled) ['{FB390167-27D1-41a2-8A94-0322E0B64EDD}'] procedure SetEnabled(const Value: Boolean); stdcall; property Enabled: Boolean read GetEnabled write SetEnabled; end; procedure GMEnableObj(const AObj: TObject; const AEnabled: Boolean); procedure GMEnableIntf(const AIntf: IUnknown; const AEnabled: Boolean); function GMGetObjEnabled(const AObj: TObject; const ADefaultValue: Boolean = False): Boolean; function GMGetIntfEnabled(const AIntf: IUnknown; const ADefaultValue: Boolean = False): Boolean; type TGMValueBufferAccessMode = (baRead, baWrite); EGMValueBufferInstance = (vbiValue, vbiOldValue); const cStrBufAccessTypeName = 'TGMValueBufferAccessMode'; cStrValBufInstTypeName = 'EGMValueBufferInstance'; type //IGMAccessValueBuffer = interface(IUnknown) // ['{478594C1-2CE4-11d5-AB38-000021DCAD19}'] // function AccessValueBuffer(const AccessMode: LongInt; const AIID: TGUID; out AIntf; const ValueBufferInstance: LongInt = Ord(vbiValue)): HResult; stdcall; //end; IGMGetValueBufferIntf = interface(IUnknown) ['{48E70686-D324-4ef7-B1D7-E646EA0F612A}'] function GetValueBufferIntf(const ValueBufferInstance: LongInt; const AIID: TGUID; out AIntf): HResult; stdcall; end; { ----------------------------------- } { ---- Objects that have a State ---- } { ----------------------------------- } IGMGetState = interface(IUnknown) ['{427EF9A1-220B-11d5-AB38-000021DCAD19}'] function GetState: LongInt; stdcall; property State: LongInt read GetState; end; IGMGetSetState = interface(IGMGetState) ['{427EF9A2-220B-11d5-AB38-000021DCAD19}'] procedure SetState(const Value: LongInt); stdcall; property State: LongInt read GetState write SetState; end; IGMStateChangeNotifications = interface(IUnknown) ['{C3A9CA45-1ACD-11d5-AB38-000021DCAD19}'] // // Implemented by: // =============== // - Fields // - Data aware controls // // The implementing Object wants to be informed when a Recordset changes it's state. // // To connect to a recordset the IconnectionPointContainer/IConnectionPoint // interfaces should be used. // procedure BeforeStateChange(const OldState, NewState: LongInt); stdcall; procedure AfterStateChange(const OldState, NewState: LongInt); stdcall; end; IGMSaveRestoreState = interface ['{D5DC937A-959B-47d9-96BF-2FB011C6071D}'] function CaptureState: IUnknown; stdcall; // <- Give the current state represented as IUnknown procedure RestoreState(const State: IUnknown); stdcall; // <- Restore from a previously saved state end; { ------------------ } { ---- Progress ---- } { ------------------ } type TGMCalcProgressKind = (cpkAbsolute, cpkRelative); TGMOnProgressProc = procedure (const AProgress: Int64; var ACancel: BOOL) of object; stdcall; //TGMOnTellTotalProgressProc = procedure (const ATotalProgress: Int64) of object; stdcall; IGMOnProgress = interface(IUnknown) ['{3128A854-FB14-41f1-AFF1-77E67C7F4EA8}'] procedure OnProgress(const AProgress: Int64; var ACancel: BOOL; const ACalcProgressKind: TGMCalcProgressKind = cpkAbsolute); stdcall; end; IGMSetCounter = interface(IUnknown) ['{63C0E4E8-FDF8-4B75-9133-8C09CC9584A3}'] procedure SetCounter(const ACounterId: LongInt; const AValue: Int64; const ACalcCountKind: TGMCalcProgressKind = cpkAbsolute); stdcall; end; IGMSetProgressMax = interface(IGMOnProgress) ['{837A4D36-0F99-4ef2-82CF-0F375A522E5C}'] procedure SetProgressMax(const AProgressMax: Int64); stdcall; end; IGMSetProgressDescription = interface(IUnknown) ['{289F562F-EFC1-4652-AD1E-BDC57A07F245}'] procedure SetProgressDescription(const AProgressDescription: TGMString; const ATextColor: COLORREF = 0); stdcall; end; //IGMMultiPhaseProgress = interface(IGMSetProgressMax) // ['{5B90D670-915B-4900-BAEB-2B0C1633D6F3}'] // procedure SetPhaseCount(const Value: LongInt); // procedure NextProgressPhase(const APhaseDescription: TGMString); // //procedure SetupPhaseProgressRange(const AMin, AMax: LongInt; const ACurrentProgress: LongInt = cInvalidProgress); //end; procedure GMSetProgressAndCheckCanceled(const AProgresssable: IUnknown; const AProgress: Int64; var ACancel: BOOL; const ACalcProgressKind: TGMCalcProgressKind = cpkAbsolute); procedure GMSetProgressMax(const AProgresssable: IUnknown; const AProgressMax: Int64); procedure GMSetProgressDescription(const AProgresssable: IUnknown; const AProgressDescription: TGMString; const ATextColor: COLORREF = 0); type IGMAppendText = interface(IUnknown) ['{3E9D2E3A-7B1A-4757-A7C6-89DE6FF08DD8}'] procedure AppendText(const Text: TGMString; const Color: COLORREF = 0; const Bold: Boolean = False; const AFontSize: LongInt = 0); end; IGMAppendTextFromDLL = interface(IUnknown) ['{C3502DE5-296C-4274-9283-B8625EA5C639}'] procedure AppendTextFromDLL(const Text: PGMChar; const Color: COLORREF = 0; const Bold: Boolean = False; const AFontSize: LongInt = 0); stdcall; end; IGMGetOperationCanceled = interface(IUnknown) ['{2DC47225-B370-4C0A-BA1A-4A6FAE9044B4}'] function GetOperationCanceled: BOOL; stdcall; property OperationCanceled: BOOL read GetOperationCanceled; end; { ------------------- } { ---- Questions ---- } { ------------------- } TGMBoolAskResult = (barUnknown, barFalse, barTrue); TGMAskBoolValueId = (// bvFirstByteRead, bvDisplayValue, bvDisplayText, bvDataFetchNeeded, bvIsNULL, bvModified, bvAlwaysNotify, bvIsMultiLine, bvCanModify, bvPositionalInsert, bvIsSigned, bvIsAutoIncrementing, bvConfirmDeletions, bvHasFocus, bvMatchCase, bvDoColorChange, bvCanSetPosition, bvWantsActivationClick, bvCustomStoreValues); IGMAskBoolean = interface(IUnknown) ['{7AAFA581-DC29-4c9a-B182-0E3F2BB412BB}'] //function AskBoolean(const ValueId: LongInt): TGMBoolAskResult; stdcall; function AskBoolean(const ValueId: LongInt): LongInt; stdcall; end; function GMObjIsEmpty(const AObj: TObject; const DefaultResult: Boolean = True): Boolean; function GMIntfIsEmpty(const AIntf: IUnknown; const DefaultResult: Boolean = True): Boolean; function GMBooleanAskResult(const Value: Boolean): LongInt; function GMAskBoolean(const AObj: TObject; const ValueId: LongInt; const DefaultResult: Boolean = False): Boolean; overload; function GMAskBoolean(const AIntf: IUnknown; const ValueId: LongInt; const DefaultResult: Boolean = False): Boolean; overload; function GMAskUnkBoolean(const AIntf: IUnknown; const AValueId: LongInt): TGMBoolAskResult; function GMCheckAskBoolean(const AObj: TObject; const ValueId: LongInt; const ACallingName: TGMString = cDfltRoutineName): Boolean; overload; function GMCheckAskBoolean(const AIntf: IUnknown; const ValueId: LongInt; const ACallingName: TGMString = cDfltRoutineName): Boolean; overload; const cInvalidIntValue = Low(LongInt); type TGMAskIntValueId = (ivDataSize, ivDataLength, ivMatchKind, ivMaxEditLength, ivId, ivFieldCount, ivCursorType, ivDisplayWidth, ivImageIndex); // ivStoredDataLength IGMAskInteger = interface(IUnknown) ['{501B3BB4-BF5F-4b7a-8094-76FF8FF5C847}'] function AskInteger(const ValueId: LongInt): LongInt; stdcall; end; function GMAskInteger(const AObj: TObject; const ValueId: LongInt; const ADefaultValue: LongInt = cInvalidIntValue): LongInt; overload; function GMAskInteger(const AIntf: IUnknown; const ValueId: LongInt; const ADefaultValue: LongInt = cInvalidIntValue): LongInt; overload; function GMCheckAskInteger(const AObj: TObject; const ValueId: LongInt; const ACallingName: TGMString = cDfltRoutineName): LongInt; overload; function GMCheckAskInteger(const AIntf: IUnknown; const ValueId: LongInt; const ACallingName: TGMString = cDfltRoutineName): LongInt; overload; type IGMMapIntegerOnInteger = interface(IUnknown) ['{1BC6F7EB-C230-48ba-B383-B332D555DA6F}'] function MapIntegerOnInteger(const MapValue: PtrInt): PtrInt; stdcall; end; //IGMIntegerMapChange = interface(IUnknown) // ['{1EEF030C-E9BA-478f-809F-81E0EEE100B6}'] // procedure IntegerMapChanged(const Value: LongInt); stdcall; //end; { -------------------- } { ---- Operations ---- } { -------------------- } TGMOperation = (roEdit, roInsert, roDelete, roCancelChanges, roApplyChanges, roRefreshCurrent, roReExecuteStatement, roScheduleReExecution, roLeaveModifyingState, roSetSimplestConfiguration, // opClear, // opFetchData, opInvalidate, opCompressData, opUncompressData, goShow, goHide, goSetFocus, goKillFocus, goRebuildContextMenu, goInitialize, goEnable, goDisable, noNotifyDataChange); IGMCanExecuteOperation = interface(IUnknown) ['{9BA70E7C-CB2C-4404-8203-2BD68ABED85B}'] function CanExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; stdcall; end; IGMExecuteOperation = interface(IUnknown) ['{DCC23FA6-D77E-44c9-95BA-DFAA264451FD}'] function ExecuteOperation(const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; stdcall; end; function GMCanExecOperation(const AIntf: IUnknown; const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; function GMExecuteOperation(const AObj: TObject; const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; overload; function GMExecuteOperation(const AIntf: IUnknown; const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; overload; procedure GMCheckExecOperation(const AObj: TObject; const Operation: LongInt; const OperationName: TGMString; const ACallingName: TGMString = cDfltRoutineName; const Parameter: IUnknown = nil); overload; procedure GMCheckExecOperation(const AIntf: IUnknown; const Operation: LongInt; const OperationName: TGMString; const ACallingName: TGMString = cDfltRoutineName; const Parameter: IUnknown = nil); overload; type IGMOperationNotifications = interface(IUnknown) ['{B9FCB8C1-10D6-41fe-83A3-6F85140419FC}'] procedure BeforeOperation(const Operation: LongInt; const Parameter: IUnknown = nil); stdcall; procedure AfterOperation(const Operation: LongInt; const Parameter: IUnknown = nil); stdcall; end; TGMRefreshGranularity = (rgNone, rgRefreshPosition, rgRefreshCurrent, rgRefeshComplete); IGMEnableNotifications = interface(IUnknown) ['{D59116D7-62F4-4408-A482-DB2E2B8A5ACD}'] function GetNotifyDisableCount: LongInt; stdcall; function EnableNotifications(const NotificationOnReEnable: LongInt = Ord(rgNone)): LongInt; stdcall; function DisableNotifications(const NotificationOnFirstDisable: LongInt = Ord(rgNone)): LongInt; stdcall; property NotifyDisableCount: LongInt read GetNotifyDisableCount; end; { ----------------- } { ---- Cursors ---- } { ----------------- } // // Abstract cursor interfaces, not specialized to anything. // // Implemented easily and meaningful by: // ===================================== // - TStrem or other stream like classes // - TDataset or any other Recordset // - List boxes, Grids or Comboboxes // - File access classes // // // Cusorposition Changes will be notified by the // IGMPositionChangeNotifications interface. // IGMUnidirectionalCursor = interface(IUnknown) ['{C3A9CA46-1ACD-11d5-AB38-000021DCAD19}'] function GetBOF: Boolean; stdcall; function GetEOF: Boolean; stdcall; procedure MoveToNext; stdcall; property BOF: Boolean read GetBOF; property EOF: Boolean read GetEOF; end; IGMBidirectionalCursor = interface(IGMUnidirectionalCursor) ['{C3A9CA47-1ACD-11d5-AB38-000021DCAD19}'] procedure MoveToPrevious; stdcall; end; IGMCursorFirstLast = interface(IGMBidirectionalCursor) ['{C3A9CA48-1ACD-11d5-AB38-000021DCAD19}'] procedure MoveToFirst; stdcall; procedure MoveToLast; stdcall; end; TGMCursorMove = (cmFirst, cmPrior, cmNext, cmLast); function GMIsValidCursorMove(const AIntf: IUnknown; const Move: TGMCursorMove): Boolean; procedure GMMoveCursor(const AIntf: IUnknown; const Move: TGMCursorMove); procedure GMMovePosition(const AIntf: IUnknown; const Delta: LongInt); procedure GMSafeCursorMove(const AIntf: IUnknown; const Move: TGMCursorMove); { ------------------ } { ---- Position ---- } { ------------------ } // // All things that have a Position, like: // ====================================== // - Streams // - Files // - Recordsets // - Listboxes, comboboxes, Grids // - Scrollbars // - Progress Bars // type IGMGetPosition = interface(IUnknown) ['{C3A9CA4A-1ACD-11d5-AB38-000021DCAD19}'] function GetPosition: PtrInt; stdcall; property Position: PtrInt read GetPosition; end; IGMGetSetPosition = interface(IGMGetPosition) ['{5DC49C45-1BBE-11d5-AB38-000021DCAD19}'] procedure SetPosition(const Value: PtrInt); stdcall; property Position: PtrInt read GetPosition write SetPosition; end; IGMPositionChangeNotifications = interface(IUnknown) ['{290C3D43-1C5A-11d5-AB38-000021DCAD19}'] // // If others want to be informed when a Position changes // they can implement this interface. // // To connect to the Position holder the IconnectionPointContainer/IConnectionPoint // interfaces should be used. // procedure BeforePositionChange; stdcall; procedure AfterPositionChange; stdcall; end; IGMScrollBar = interface(IGMGetSetPosition) ['{3835397C-7C0F-422A-BFD9-763CA068E96C}'] function GetMinPosition: LongInt; stdcall; function GetMaxPosition: LongInt; stdcall; function GetPageSize: LongInt; stdcall; procedure SetMinPosition(const AValue: LongInt); stdcall; procedure SetMaxPosition(const AValue: LongInt); stdcall; procedure SetPageSize(const AValue: LongInt); stdcall; property MinPosition: LongInt read GetMinPosition write SetMinPosition; property MaxPosition: LongInt read GetMaxPosition write SetMaxPosition; property PageSize: LongInt read GetPageSize write SetPageSize; end; function GMGetIntfPosition(const AIntf: IUnknown; const DefaultPos: LongInt = CGMUnknownPosition): LongInt; procedure GMSetIntfPosition(const AIntf: IUnknown; const Position: LongInt); { ---------------- } { ---- colors ---- } { ---------------- } type IGMBkgndColor = interface(IUnknown) ['{26A00902-95B8-4854-BCC4-01E5C2E80135}'] function BkgndColor: COLORREF; stdcall; //property BkgndColor: COLORREF read GetBkgndColor; end; IGMGetSetBkgndColor = interface(IGMBkgndColor) ['{2667B51E-1EB9-4c76-99AF-51232F4E13C6}'] procedure SetBkgndColor(const Value: COLORREF; const Repaint: Boolean = True); stdcall; //property BkgndColor: COLORREF read IGMBkgndColor; // write SetBkgndColor; end; { --------------- } { ---- Count ---- } { --------------- } IGMGetCount = interface(IUnknown) ['{93880081-2684-11d5-AB38-000021DCAD19}'] function GetCount: PtrInt; stdcall; property Count: PtrInt read GetCount; end; IGMGetSetCount = interface(IGMGetCount) ['{93880082-2684-11d5-AB38-000021DCAD19}'] procedure SetCount(const Value: PtrInt); stdcall; property Count: PtrInt read GetCount write SetCount; end; function GMGetIntfCount(const AIntf: IUnknown; const ADefaultValue: PtrInt = 0): PtrInt; { ---------------- } { ---- Offset ---- } { ---------------- } type IGMGetOffset = interface(IUnknown) ['{AC94E5A1-38AB-11d5-AB38-000021DCAD19}'] function GetOffset: PtrInt; stdcall; property Offset: PtrInt read GetOffset; end; IGMGetSetOffset = interface(IGMGetOffset) ['{AC94E5A2-38AB-11d5-AB38-000021DCAD19}'] procedure SetOffset(PtrInt: PtrInt); stdcall; property Offset: PtrInt read GetOffset write SetOffset; end; IGMShiftOffset = interface(IUnknown) ['{9A57A8D4-2DFE-4aa0-BE1E-6365C3FD2B68}'] procedure SetOffsetAndShiftData(const NewOffset: LongInt); stdcall; end; { ------------------- } { ---- Placement ---- } { ------------------- } IGMGetLeft = interface(IUnknown) ['{F2589550-F6A9-46d4-AC88-D694B080C0DE}'] function GetLeft: LongInt; stdcall; property Left: LongInt read GetLeft; end; {IGMGetSetLeft = interface(IGMGetLeft) ['567DD2AA-B5B3-4bc3-B68E-2649698A0C05'] procedure SetLeft(const Value: LongInt); stdcall; property Left: LongInt read GetLeft write SetLeft; end;} {IGMGetTop = interface(IUnknown) ['9ABE0B27-B9BD-4c19-878E-30FBB67F9D75'] function GetTop: LongInt; stdcall; property Top: LongInt read GetTop; end;} {IGMGetSetTop = interface(IGMGetTop) ['BBAB652D-AD89-4468-8DDB-C8AE8F20926A'] procedure SetTop(const Value: LongInt); stdcall; property Top: LongInt read GetTop write SetTop; end;} {IGMGetWidth = interface(IUnknown) ['7416B560-6800-4bfb-9F72-FF21F3B91EEA'] function GetWidth: LongInt; stdcall; property Width: LongInt read GetWidth; end;} {IGMGetSetWidth = interface(IGMGetWidth) ['CE61FDA8-FD92-47e6-BCDF-A5599FFEA6AB'] procedure SetWidth(const Value: LongInt); stdcall; property Width: LongInt read GetWidth write SetWidth; end;} {IGMGetHeight = interface(IUnknown) ['E703AB11-7475-45c8-A2DC-ECFB83906E21'] function GetHeight: LongInt; stdcall; property Height: LongInt read GetHeight; end;} {IGMGetSetHeight = interface(IGMGetHeight) ['7E5751E5-C243-4054-8180-A440BDA79DBE'] procedure SetHeight(const Value: LongInt); stdcall; property Height: LongInt read GetHeight write SetHeight; end;} {IGMSetBounds = interface(IUnknown) ['FDEECACF-47A4-4b6d-B2FA-F062FCD3F9D3'] procedure SetBounds(ALeft, ATop, AWidth, AHeight: LongInt); stdcall; end;} { ------------------------------- } { ---- Assign#ments / Clones ---- } { ------------------------------- } IGMAssignFromObj = interface(IUnknown) ['{347F1FD6-9775-4612-A9D4-828415E0E274}'] procedure AssignFromObj(const ASource: TObject); stdcall; end; IGMAssignToObj = interface(IUnknown) ['{76BE483F-13F2-408c-A6DC-75F2F10EA32A}'] procedure AssignToObj(const ADest: TObject); stdcall; end; IGMAssignFromIntf = interface(IUnknown) ['{B4047CE2-4821-4b08-BC3F-0EFA7D2A0481}'] procedure AssignFromIntf(const ASource: IUnknown); stdcall; end; IGMAssignToIntf = interface(IUnknown) ['{5DC7F8E2-00BD-487f-A8F6-1FCF8706CF7D}'] procedure AssignToIntf(const ADest: IUnknown); stdcall; end; IGMCreateCopyQI = interface(IUnknown) ['{82C8DD54-9DEC-455f-9C94-CF0D6CC7E0A7}'] // // Anything that allows to create a Copy of itself. // Specify the Interface you want use to communicate to // the newly created Object in the AIID Parameter. // function CreateCopyQI(const AIID: TGUID; out AIntf): HResult; stdcall; end; { -------------------- } { ---- Attributes ---- } { -------------------- } // // Bitflag Field interpreted as a Set of Boolean Attributes. // IGMGetAttributes = interface(IUnknown) ['{5771C661-3BF8-11d5-AB38-000021DCAD19}'] function GetAttributes: Longword; stdcall; property Attributes: Longword read GetAttributes; end; IGMGetSetAttributes = interface(IGMGetAttributes) ['{E94E2166-597A-4937-A700-FBE37EEDE291}'] procedure SetAttributes(const Value: Longword); stdcall; property Attributes: Longword read GetAttributes write SetAttributes; end; { ---------------------- } { ---- User Account ---- } { ---------------------- } IGMUsernameAndPassword = interface(IUnknown) ['{CAE0D477-6191-4502-A4B6-7FA36BCC250B}'] function GetUsername: TGMString; procedure SetUsername(const ABypass: TGMString); function GetPassword: TGMString; procedure SetPassword(const ABypass: TGMString); property Username: TGMString read GetUsername write SetUsername; property Password: TGMString read GetPassword write SetPassword; end; IGMUserAccount = interface(IUnknown) ['{42129443-AFC0-4103-91E1-0ED04AB8584B}'] function GetUsername: PGMChar; stdcall; function GetPassword: PGMChar; stdcall; // function GetDomain: PGMChar; stdcall; function GetSaveUserData: Boolean; stdcall; procedure SetUsername(AuserName: PGMChar); stdcall; procedure SetPassword(APassword: PGMChar); stdcall; // procedure SetDomain(ADomain: PGMChar); stdcall; procedure SetSaveUserData(Value: Boolean); stdcall; property Username: PGMChar read GetUsername write SetUsername; property Password: PGMChar read GetPassword write SetPassword; // property Domain: PGMChar read GetDomain write SetDomain; property SaveUserData: Boolean read GetSaveUserData write SetSaveUserData; end; { ----------------- } { ---- Strings ---- } { ----------------- } {IGMStrings = interface(IUnknown) ['FA99E2AC-F393-417a-AA19-5C9501B200B5'] // // Cannot be marshalled // procedure BeginUpdate; procedure EndUpdate; function Get(Index: LongInt): TGMString; function GetSorted: Boolean; procedure Put(Index: LongInt; const S: TGMString); procedure SetSorted(Value: Boolean); procedure Clear; function GetCount: LongInt; function IsEmpty: Boolean; function Add(const Value: TGMString): LongInt; procedure Delete(Index: LongInt); function IndexOf(const Value: TGMString): LongInt; function IndexOfNearest(const Value: TGMString): LongInt; function Find(const Value: TGMString; var Index: LongInt): Boolean; property Count: LongInt read GetCount; property Strings[Index: LongInt]: TGMString read Get write Put; default; property Sorted: Boolean read GetSorted write SetSorted; end;} { ------------------------ } { ---- Storing Values ---- } { ------------------------ } PGMCryptCtrlData = ^RGMCryptCtrlData; RGMCryptCtrlData = record KeyData: AnsiString; HashAlgoID: Cardinal; CryptAlgoID: Cardinal; end; TGMReadValStrFunc = function(const AValueName: TGMString; const ADefaultValue: TGMString = ''): TGMString of object; stdcall; TGMWriteValStrProc = procedure(const AValueName, AValue: TGMString) of object; stdcall; IGMStringStorage = interface(IUnknown) ['{6C1E6792-ED8D-4c16-A49E-12CB62F61E7E}'] function ReadString(const ValueName: TGMString; const ADefaultValue: TGMString = ''): TGMString; stdcall; procedure WriteString(const ValueName, Value: TGMString); stdcall; end; IGMValueStorage = interface(IGMStringStorage) ['{5B79A555-D8BA-4062-B84E-A08AD279194B}'] function ReadInteger(const ValueName: TGMString; const ADefaultValue: LongInt = cDfltReadInteger): LongInt; stdcall; function ReadInt64(const ValueName: TGMString; const ADefaultValue: Int64 = cDfltReadInteger): Int64; stdcall; function ReadBoolean(const ValueName: TGMString; const ADefaultValue: Boolean = cDfltReadBoolean): Boolean; stdcall; function ReadDateTime(const ValueName: TGMString; const ADefaultValue: Double = cDfltReadDateTime): Double; stdcall; function ReadDouble(const ValueName: TGMString; const ADefaultValue: Double = cDfltReadFloat): Double; stdcall; function ReadVariant(const ValueName: TGMString; const ADefaultValue: OleVariant): OleVariant; stdcall; function ReadUnionValue(const ValueName: TGMString; const ADefaultValue: RGMUnionValue): RGMUnionValue; stdcall; procedure WriteInteger(const ValueName: TGMString; const Value: LongInt); stdcall; procedure WriteInt64(const ValueName: TGMString; const Value: Int64); stdcall; procedure WriteBoolean(const ValueName: TGMString; const Value: Boolean); stdcall; procedure WriteDateTime(const ValueName: TGMString; const Value: Double); stdcall; procedure WriteDouble(const ValueName: TGMString; const Value: Double); stdcall; procedure WriteVariant(const ValueName: TGMString; const Value: OleVariant); stdcall; procedure WriteUnionValue(const ValueName: TGMString; const Value: RGMUnionValue); stdcall; end; TGMLoadStoreValuesProc = procedure (const AStorage: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil) of object; //IGMBinaryStorage = interface(IUnknown) // ['EF4C4B29-EFEA-4e2d-B483-7EA3DAA608FA}'] // function ReadBinary(const ValueName: TGMString; out Data; const DataSize: LongInt; const ZeroInit: Boolean = True): LongWord; stdcall; // procedure WriteBinary(const ValueName: TGMString; const Data; const DataSize: LongInt); stdcall; //end; IGMContainsValue = interface(IUnknown) ['{EFF05048-5460-4A8E-B6D1-2FCCDB184CC2}'] function ContainsValue(const ValueName: TGMString): Boolean; stdcall; end; IGMValueStorageDirectory = interface(IGMContainsValue) ['{E8696A1E-B597-46cd-ABA3-0376EC82609D}'] function OpenDir(const DirPath: TGMString; const CreateIfNotExist: Boolean = False): Boolean; stdcall; // function DirExists(const DirPath: TGMString): Boolean; stdcall; procedure ReadSubDirNames(var SubDirNames: TGMStringArray); stdcall; procedure ReadValueNames(var ValueNames: TGMStringArray); stdcall; function DeleteValue(const ValueName: TGMString): Boolean; stdcall; function DeleteDir(const DirPath: TGMString): Boolean; stdcall; function CurrentPath: TGMString; stdcall; procedure Commit; stdcall; function GetBasePath: TGMString; stdcall; function GetRootKey: HKEY; stdcall; procedure SetBasePath(const Value: TGMString); stdcall; procedure SetRootKey(const Value: HKEY); stdcall; property BasePath: TGMString read GetBasePath write SetBasePath; property RootKey: HKEY read GetRootKey write SetRootKey; end; IGMLoadStoreData = interface(IUnknown) ['{D8D48DE1-AE80-4132-AE40-ECA66F9256C6}'] procedure LoadData(const ASource: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; procedure StoreData(const ADest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); stdcall; end; { ---------------------------- } { ---- Content Container ---- } { ---------------------------- } IGWriteToStream = interface(IUnknown) ['{AEFAA5A9-50C8-43F3-95ED-E0645E74791E}'] procedure WriteToStream(const ADestStream: ISequentialStream; const ACharCoding: TGMCharKind = ckUtf8; const AIndent: TGMString = ''); end; { ---------------- } { ---- Trees ---- } { ---------------- } IGMTreeable = Interface(IUnknown) ['{72EF5208-0379-4C0B-BBDF-4AB64B9050F3}'] function Parent: IGMTreeable; // <- Level up function FirstChild: IGMTreeable; // <- Level down function NextSibling: IGMTreeable; // <- Next neighbour on same Level function PrevSibling: IGMTreeable; // <- Previous neighbour on same Level end; IGMCreateTreeNodeWithDataObj = interface(IUnknown) ['{6ED27D2A-0349-490E-A42D-F238DCF77D87}'] function CreateTreeNodeWithDataObj(const ASource: IGMValueStorage; const ParentNode: IGMTreeable; const Parameters: IUnknown = nil): IGMTreeable; // stdcall; end; IGMCreateNewTreeNode = interface(IUnknown) ['{E1AC135B-AB0D-4228-B945-C4B111EE884E}'] function CreateNewTreeNode(const ParentNode: IGMTreeable; const Title: TGMString; const ImgIdx, SelectedImgIdx: Integer; const DataObj: TObject = nil; const Parameters: IUnknown = nil): IGMTreeable; stdcall; end; IGMGetTreeNodeFromRaw = interface(IUnknown) ['{A1531AA5-68B5-4FD9-A2DB-85F0CD37880B}'] function GetTreeNodeFromRaw(const ANode: Pointer): IGMTreeable; stdcall; end; IGMGetDataObject = interface(IUnknown) ['{66E08396-AD93-4996-B4A0-E506085CAD49}'] function GetDataObject: TObject; stdcall; end; IGMSetDataObject = interface(IUnknown) ['{F0520DB3-D54A-4E9A-B57A-D2BD2F91F796}'] procedure SetDataObject(const Value: TObject); stdcall; end; // // Return value True continues iteratiing further nodes, False stops iteration at current node // TGMNodeVisitFunc = function(const Node: IGMTreeable; const Parameter: Pointer = nil): Boolean; TGMNodeVisitMethod = function(const Node: IGMTreeable; const Parameter: Pointer = nil): Boolean of object; PGMNodeVisitData = ^RGMNodeVisitData; RGMNodeVisitData = record DataClass: TClass; NodeTitle: TGMString; Node: IGMTreeable; Index, SearchIdx: LongInt; end; function GMTreeableNodeLevel(ANode: IGMTreeable): Integer; function GMInitNodeVisitData(const ADataClass: TClass; const ANodeTitle: TGMString = ''; const ANode: IGMTreeable = nil; const ASearchIndex: LongInt = 0): RGMNodeVisitData; function GMGetDataObject(const AOwner: IUnknown): TObject; function GMSetDataObject(const AOwner: IUnknown; const ADataObj: TObject): TObject; function GMIntfHasDataClass(const AIntf: IUnknown; const ADataClass: TClass): Boolean; function GMGetIntfDataClass(const AIntf: IUnknown): TClass; function GMVisitNodesRootFirst(const AStartNode: IGMTreeable; const AVisitFunc: TGMNodeVisitFunc; const ARecurse: Boolean = True; const AParameter: Pointer = nil): Boolean; overload; function GMVisitNodesRootFirst(const AStartNode: IGMTreeable; const AVisitFunc: TGMNodeVisitMethod; const ARecurse: Boolean = True; const AParameter: Pointer = nil): Boolean; overload; function GMVisitNodesDepthFirst(const AStartNode: IGMTreeable; const AVisitFunc: TGMNodeVisitFunc; const ARecurse: Boolean = True; const AParameter: Pointer = nil): Boolean; overload; function GMVisitNodesDepthFirst(const AStartNode: IGMTreeable; const AVisitFunc: TGMNodeVisitMethod; const ARecurse: Boolean = True; const AParameter: Pointer = nil): Boolean; overload; function GMIsNodeMatch(ANode: IGMTreeable; const ADataClass: TClass; const ANodeTitle: TGMString = ''): Boolean; function GMFindParentNode(const AStartNode: IGMTreeable; const ADataClass: TClass; const ANodeTitle: TGMString = ''): IGMTreeable; function GMFindNode(const AStartNode: IGMTreeable; const ADecideFunc: TGMNodeVisitFunc; const ARecurse: Boolean; const AParameter: Pointer = nil): IGMTreeable; overload; function GMFindNode(const AStartNode: IGMTreeable; const ADataClass: TClass; const ANodeTitle: TGMString = ''; const ARecurse: Boolean = True): IGMTreeable; overload; function GMFindRootNode(const ANode: IUnknown): IGMTreeable; function GMNodePath(const ANode: IUnknown; const ADelimStr: TGMString = '\'): TGMString; { ---------------------------------------------------------------- } { ---- Classes supporting reference counted lifetime control ---- } { ---------------------------------------------------------------- } type TGMRefCountedObj = class(TObject, IUnknown, IGMObjInfo, IGMCreateCopyQI) protected FRefLifeTime: Boolean; FRefCount: LongInt; public constructor Create(const ARefLifeTime: Boolean = False); virtual; procedure AfterConstruction; override; procedure BeforeDestruction; override; destructor Destroy; override; procedure OnFinalRelease; virtual; // IGMObjInfo function GetClassName: TGMString; function GetClassType: TClass; function GetInstance: TObject; function GetTypeInfo: PTypeInfo; // IUnknown function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} AIID: TGUID; out AIntf): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _AddRef: LongInt; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _Release: LongInt; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; // IGMCreateCopyQI function CreateCopyQI(const AIID: TGUID; out AIntf): HResult; virtual; stdcall; property RefCount: LongInt read FRefCount; property RefLifeTime: Boolean read FRefLifeTime write FRefLifeTime; end; TGMRefCountedObjClass = class of TGMRefCountedObj; TGMAggregatableObj = class(TGMRefCountedObj, IUnknown) // // Intended to be aggregated to/by another class via "implements" compiler featrue. // Must not be created with RefLifetime when used as an aggregate (Interface delegation member). // // If used as interface delegation member the owner must refernece this class by a normal // object member and not an interface member. Because reference counts are routed back to the // owner by this class a cyclic reference by interfaces would keep the owner forever. For the same reason // this class must not reference other delegation classes of the owner by interfaces. // // Can be created standalone (AOwner = nil) too, with or without RefLifeTime. // protected FOwner: Pointer; // <- cannot be a Interface reference, would cause circular reference public constructor Create(const AOwner: IUnknown; const ARefLifeTime: Boolean = False); virtual; reintroduce; overload; function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} AIID: TGUID; out AIntf): HResult; override; function _AddRef: LongInt; override; function _Release: LongInt; override; function GetOwner: IUnknown; function GetOwnerObj: TObject; property Owner: IUnknown read GetOwner; property OwnerObj: TObject read GetOwnerObj; end; {$IFDEF DELPHIVCL} TGMRefLifePersistent = class(TPersistent, IUnknown, IGMObjInfo) protected FConstructed: Boolean; FRefCount: LongInt; FRefLifeTime: Boolean; public constructor Create(const ARefLifeTime: Boolean = False); procedure AfterConstruction; override; destructor Destroy; override; procedure OnFinalRelease; virtual; // IGMObjInfo function GetClassName: TGMString; function GetClassType: TClass; function GetInstance: TObject; function GetTypeInfo: PTypeInfo; // IUnknown function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} AIID: TGUID; out AIntf): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _AddRef: LongInt; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _Release: LongInt; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; property RefCount: LongInt read FRefCount; property RefLifeTime: Boolean read FRefLifeTime write FRefLifeTime; end; {$ENDIF} {$IFDEF DELPHIVCL} TGMRefLifeComponent = class; TGMRefLifeComponentClass = class of TGMRefLifeComponent; TGMRefLifeComponent = class(TComponent, IUnknown, IGMCreateCopyQI, IGMAssignFromObj, IGMAssignToObj, IGMGetName, IGMObjInfo) protected FConstructed: Boolean; FRefCount: LongInt; FRefLifeTime: Boolean; function CopyCreateClass: TGMRefLifeComponentClass; public constructor CreateIntf; // virtual; <- not needed, calls virtual create constructor procedure AfterConstruction; override; destructor Destroy; override; procedure OnFinalRelease; virtual; // IGMObjInfo function GetClassName: TGMString; function GetClassType: TClass; function GetInstance: TObject; function GetTypeInfo: PTypeInfo; // IGMGetName function GetName: TGMString; virtual; stdcall; // IGMAssignByObj procedure AssignFromObj(const ASource: TObject); virtual; stdcall; procedure AssignToObj(const ADest: TObject); virtual; stdcall; // IGMCreateCopyQI function CreateCopyQI(const AIID: TGUID; out AIntf): HResult; virtual; stdcall; // IUnknown function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} AIID: TGUID; out AIntf): HResult; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _AddRef: LongInt; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _Release: LongInt; virtual; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; property RefCount: LongInt read FRefCount; property RefLifeTime: Boolean read FRefLifeTime write FRefLifeTime; end; {$ENDIF} TCPCNotifyProc = procedure (const NotifySink: IUnknown; const Params: array of OleVariant); TCPCNotifyProcObj = procedure (const NotifySink: IUnknown; const Params: array of OleVariant) of object; { ---------------------------------- } { ---- Synchronization Classes ---- } { ---------------------------------- } TGMCriticalSection = class(TGMRefCountedObj, IGMCriticalSection) protected FCriticalSection: TRTLCriticalSection; public constructor Create(const ARefLifeTime: Boolean = True); override; destructor Destroy; override; procedure EnterCriticalSection; procedure LeaveCriticalSection; function TryEnterCriticalSection: Boolean; end; TGMCriticalSectionLock = class(TGMRefCountedObj) protected FCriticalSection: IGMCriticalSection; public constructor Create(const ACriticalSection: IUnknown; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end deprecated 'Use RGMCriticalSectionLock instead'; RGMCriticalSectionLock = record private LockCount: Int64; CriticalSection: IGMCriticalSection; class operator Initialize(var ACriticalSectionLock: RGMCriticalSectionLock); class operator Finalize(var ACriticalSectionLock: RGMCriticalSectionLock); public procedure Lock(const ACriticalSection: IGMCriticalSection); overload; procedure Lock(const ACriticalSection: IUnknown); overload; procedure Lock(const ACriticalSection: TObject); overload; procedure LockAgain; procedure Unlock; procedure UnlockAll; function GetLockCount: Int64; end; { ------------------------ } { ---- Smart Classes ---- } { ------------------------ } TGMCOMInitializer = class(TGMRefCountedObj) protected FInitialized: Boolean; public constructor Create(const ACoInitFlags: DWORD = cDfltCoInitFlags; const AHrCheck: Boolean = True; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; TGMNotificationDisabler = class(TGMRefCountedObj) protected FNotifier: IGMEnableNotifications; FNotificationOnReEnable: LongInt; public constructor Create(const ANotifier: IUnknown; const ANotificationOnReEnable: LongInt = Ord(rgNone); const ANotificationOnFirstDisable: LongInt = Ord(rgNone); const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; TGMPositionKeeper = class(TGMRefCountedObj) protected FPosition: LongInt; FObjWithPosition: IGMGetSetPosition; public constructor Create(const AObjWithPosition: IUnknown; const ANewposition: LongInt = -1; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; TGMStateKeeper = class(TGMRefCountedObj) protected FObjWithState: IGMSaveRestoreState; FState: IUnknown; public constructor Create(const AObjWithState: IUnknown; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; TGMQuietStateKeeper = class(TGMRefCountedObj) protected FStateKeeper: IUnknown; // <- Released First FNotificationDisabler: IUnknown; // <- Released Second public constructor Create(const AObjWithState: IUnknown; const ANotificationOnReEnable: LongInt = Ord(rgNone); const ANotificationOnFirstDisable: LongInt = Ord(rgNone); const ARefLifeTime: Boolean = True); reintroduce; end; TGMActiveKeeper = class(TGMRefCountedObj) protected FActivatableObj: IGMGetSetActive; FWasActive: Boolean; public constructor Create(const AActivatableObj: IUnknown; const ANewActive: Boolean = True; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; TGMVsdDirPathKeeper = class(TGMRefCountedObj) protected FValStorageDir: IGMValueStorageDirectory; FOldDirPath: TGMString; public constructor Create(const AValStorageDir: IUnknown; const ANewDirPath: TGMString = ''; const ACreateIfNotExists: Boolean = False; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; TGMIStreamPosKeeper = class(TGMRefCountedObj) protected FStream: IStream; FOldPos: Int64; public constructor Create(const AStream: IUnknown; AStartPos: Int64 = cCurrentStrmPos; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; {TGMPaintDisabler = class(TGMRefCountedObj) protected FPaintObj: IGMEnableDisablePaint; public constructor Create(const APaintObj: IUnknown; const ARefLifeTime: Boolean = True); destructor Destroy; override; end;} { ---- Key Value Directory Routines ---- } function GMVsdOpenDir(const AStorage: IUnknown; const ADirPath: TGMString; const ACreateIfNotExist: Boolean = False): Boolean; function GMVsdDirExists(const AStorage: IUnknown; const ADirPath: TGMString): Boolean; function GMVsdOpenAbsDir(const AStorage: IUnknown; const ADirPath: TGMString; const ACreateIfNotExist: Boolean = False): Boolean; function GMVsdDeleteDir(const AStorage: IUnknown; const ADirPath: TGMString): Boolean; function GMVsdDeleteAbsDir(const Storage: IUnknown; const ADirPath: TGMString): Boolean; function GMVsdContainsValue(const AStorage: IUnknown; const AValueName: TGMString): Boolean; function GMVsdDeleteValue(const AStorage: IUnknown; const AValueName: TGMString): Boolean; //function GMVsdValueNameExists(const AStorage: IUnknown; const ValueName: TGMString): Boolean; //procedure GMVsdDeletePrefixedValues(const AStorage: IUnknown; const PrefixStr: TGMString); //procedure GMVsdDeleteValues(const AStorage: IUnknown); procedure GMVsdReadSubDirNames(const AStorage: IUnknown; var ASubDirNames: TGMStringArray); procedure GMVsdReadValueNames(const AStorage: IUnknown; var AValueNames: TGMStringArray); procedure GMVsdCreatePath(const AStorage: IUnknown; const ADirPath: TGMString); function GMVsdCurrentPath(const AStorage: IUnknown): TGMString; procedure GMVsdCommit(const AStorage: IUnknown); procedure GMVsdLoadFromDir(const ASource: IGMValueStorage; const ALoadPath: TGMString; const ALoadProc: TGMLoadStoreValuesProc; const ACryptCtrlData: PGMCryptCtrlData = nil); overload; procedure GMVsdLoadFromDir(const ASource: IGMValueStorage; const ALoadPath: TGMString; const ALoadIntf: IUnknown; const ACryptCtrlData: PGMCryptCtrlData = nil); overload; procedure GMVsdStoreToDir(const ADest: IGMValueStorage; const AStorePath: TGMString; const AStoreProc: TGMLoadStoreValuesProc; const ACryptCtrlData: PGMCryptCtrlData = nil); overload; procedure GMVsdStoreToDir(const ADest: IGMValueStorage; const AStorePath: TGMString; const AStoreIntf: IUnknown; const ACryptCtrlData: PGMCryptCtrlData = nil); overload; procedure GMVsdLoadTree(const ASource: IGMValueStorage; const AParentTreeNode: IGMTreeable; const ATreeNodeCreator: IGMCreateTreeNodeWithDataObj; const AParameter: IUnknown = nil; const ACryptCtrlData: PGMCryptCtrlData = nil; const ASubDirSeparator: TGMString = scSubNodesDirSeparator); procedure GMStoreTree(const ADest: IGMValueStorage; ANode: IGMTreeable; var ANodeIdx: LongInt; const AStoreSiblings: Boolean; const ACryptCtrlData: PGMCryptCtrlData = nil); procedure GMVsdCopyDirValues(const ASource, ADest: IGMStringStorage); procedure GMVsdCopyStorageContents(const ASource, ADest: IUnknown; AStartDirPath: TGMString = ''); procedure GMStoreString(const ADest: IGMStringStorage; const AValueName, AValue: TGMString; const ADefaultValue: TGMString = cDfltReadString); procedure GMStoreInteger(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: LongInt; const ADefaultValue: LongInt = cDfltReadInteger); procedure GMStoreInt64(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: Int64; const ADefaultValue: Int64 = cDfltReadInteger); procedure GMStoreBoolean(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: Boolean; const ADefaultValue: Boolean = cDfltReadBoolean); procedure GMStoreDateTime(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: TDateTime; const ADefaultValue: TDateTime = cDfltReadDateTime); procedure GMStoreDouble(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: Double; const ADefaultValue: Double = cDfltReadFloat); procedure GMStoreVariant(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue, ADefaultValue: OleVariant); { ---- ILockByte Routines ---- } function GMLockByteSize(const LockBytes: ILockBytes): Int64; procedure GMCopyLockBytes(const ASource, ADest: ILockBytes; const AMaxBytesToCopy: LongInt = 0; const AVerfy: Boolean = True); procedure GMLockByteSafeReadAt(const ASource: ILockBytes; const AOffset: Int64; const APData: Pointer; const ACount: LongInt; const ACallingName: TGMString = cDfltRoutineName); procedure GMLockByteSafeWriteAt(const ADest: ILockBytes; const AOffset: Int64; const APData: Pointer; const ACount: LongInt; const ACallingName: TGMString = cDfltRoutineName); { ---- Istream Routines ---- } function GMIStreamSize(const AStream: IUnknown): Int64; function GMIStreamPos(const AStream: IUnknown): Int64; function GMSetIStreamAbsPos(const AStream: IUnknown; const ANewPos: Int64; const ACallingName: TGMString = cDfltRoutineName): Int64; function GMIStreamRead(const ASource: ISequentialStream; const Data: Pointer; const DataSizeInBytes: LongWord): Cardinal; procedure GMSafeIStreamRead(const ASource: ISequentialStream; const AData: Pointer; const ADataSizeInBytes: LongWord; const ACallingName: TGMString = cDfltRoutineName); procedure GMSafeIStreamWrite(const ADest: ISequentialStream; const AData: Pointer; const ADataSizeInBytes: LongWord; const ACallingName: TGMString = cDfltRoutineName); function GMIStreamReadResult(const pcbOut: Pointer; const AllDone: Boolean): HResult; function GMIStreamWriteResult(const pcbOut: Pointer; const AllDone: Boolean): HResult; function GMIStreamContentAsString(const ASourceStrm: ISequentialStream; StartPos: Int64 = -1; const ACallingName: TGMString = ''): AnsiString; procedure GMCopyIStreamTime(const ASourceStrm, ADestStrm: ISequentialStream; const AOnProgressProc: TGMOnProgressProc = nil; const ACallBackTimeInMS: LongWord = cDfltUiResponseMS; const ACallingName: TGMString = cDfltRoutineName); procedure GMCopyIStreamBufSize(const ASourceStrm, ADestStrm: ISequentialStream; const ACopyBufferSize: LongWord = cDfltCopyBufferSize; const AOnProgressProc: TGMOnProgressProc = nil; const ACallingName: TGMString = cDfltRoutineName); procedure GMCopyIStream(const ASourceStrm, ADestStrm: ISequentialStream; const ACopyBufferSize: LongInt = cDfltCopyBufferSize; const AOnProgressProc: TGMOnProgressProc = nil; const ACallingName: TGMString = cDfltRoutineName); { ---- Objects / Interfaces / Classes ---- } //function GMIsOneOfClasses(const AObj: TObject; const Classes: array of TClass): Boolean; function GMIntfClassName(const AIntf: IUnknown): TGMString; function GMObjFromIntf(const AIntf: IUnknown): TObject; function GMCompareIUnknown(const AIntf1, AIntf2: IUnknown): TGMCompareResult; function GMObjAsIntf(const AObj: TObject): IUnknown; inline; function GMGetIntfName(const AIntf: IUnknown; const ADefaultName: TGMString = ''): TGMString; function GMGetIntfDisplayName(const AIntf: IUnknown): TGMString; // ; const ADefaultValue: TGMString = cStrUnknown function GMGetIntfFileName(const AIntf: IUnknown; const ADefaultFileName: TGMString = ''): TGMString; function GMIntfIIDName(const AIID: TGuid): TGMString; overload; function GMIntfIIDName(const IIDStr: TGMString): TGMString; overload; function GMGetObjName(const AObj: TObject; const ADefaultName: TGMString = ''): TGMString; function GMGetObjDisplayName(const AObj: TObject): TGMString; function GMObjClassName(const AObj: TObject): TGMString; function GMClassName(const AClass: TClass): TGMString; function GMGetPropertyIntf(const AObj: TObject; const PropertyName: TGMString; const AIID: TGUID; out AIntf): HResult; function GMGetPropIntfFromIntf(const AOwner: IUnknown; const APropertyName: TGMString; const AIID: TGUID; out AIntf): HResult; //procedure GMCheckGetPropIntfFromIntf(const Owner: IUnknown; const PropertyName: TGMString; const AIID: TGUID; out AIntf; const ACallingName: TGMString = ''); procedure GMCheckGetInterface(const AObj: TObject; const AIID: TGUID; out AIntf; const ACallingName: TGMString = cDfltRoutineName); function GMGetInterface(const AObj: TObject; const AIID: TGUID; out AIntf): Boolean; inline; function GMGetWeakInterface(const AObj: TObject; const AIID: TGUID; out AIntf): Boolean; inline; function GMQueryInterface(const ASource: IUnknown; const AIID: TGUID; out AIntf): Boolean; inline; procedure GMCheckQueryInterface(const ASource: IUnknown; const AIID: TGUID; out AIntf; const ACallingName: TGMString = cDfltRoutineName); function GMAllInterfacesSupported(const AIntf: IUnknown; const InterfaceIDs: array of TGUID): Boolean; procedure GMCheckAllInterfacesSupported(const AIntf: IUnknown; const InterfaceIDs: array of TGUID; const ACallingName: TGMString = cDfltRoutineName); procedure GMCheckGetIntfByPosition(const ACollection: IGMGetIntfByPosition; const Position: LongInt; const AIID: TGUID; out AIntf; const ElementName, ACallingName: TGMString); function GMGetIntfHandle(const AIntf: IUnknown; const ADefaultValue: THandle = 0): THandle; function GMIsHandleAllocated(const AIntf: IUnknown): Boolean; function GMCheckGetIntfHandle(const AIntf: IUnknown; const ACallingName: TGMString): THandle; function GMGetAllocatedIntfHandle(const AIntf: IUnknown; var Handle: THandle): Boolean; function GMGetAllocatedObjHandle(const AObj: TObject; var AHandle: THandle): Boolean; function GMCreateCopyQI(const ASource: IUnknown; const AIID: TGUID; out AIntf): HResult; function GMObjCreateCopyQI(const ASource: TObject; const AIID: TGUID; out AIntf): HResult; function GMFindParentObj(const AObj: TObject; const AParentClass: TClass; out AParent): Boolean; function GMIsParentObj(AParent, AObj: TObject; const AllowIdentity: Boolean = False; const AStopAtClass: TClass = nil): Boolean; procedure GMCheckFindParentObj(const AObj: TObject; const ParentClass: TClass; out Parent); function GMGetObjText(const AObj: TObject; const ADefaultValue: TGMString = ''): TGMString; procedure GMSetObjText(const AObj: TObject; const AValue: TGMString); function GMGetIntfText(const AIntf: IUnknown; const ADefaultValue: TGMString = ''): TGMString; procedure GMSetIntfText(const AIntf: IUnknown; const AValue: TGMString); function GMGetIntfStrValue(const AIntf: IUnknown; const ADefaultValue: TGMString = ''): TGMSTring; { ---- Connection Point Helpers ---- } function GMDoNotifySink(const NotificationsEnabled: Boolean; const NotifySink: IUnknown; const AIID: TGUID; out AIntf): Boolean; procedure GMInterfaceConnect(const AObj: TObject; const AContainer: IUnknown; const AIID: TGUID; var Cookie: LongInt; const ACallingName: TGMString = cDfltRoutineName); overload; procedure GMInterfaceConnect(const Sink, AContainer: IUnknown; const AIID: TGUID; var Cookie: LongInt; const AObj: TObject = nil; const ACallingName: TGMString = cDfltRoutineName); overload; procedure GMQuietInterfaceConnect(const AObj: TObject; const AContainer: IUnknown; const AIID: TGUID; var Cookie: LongInt); procedure GMInterfaceDisconnect(const AContainer: IUnknown; const AIID: TGUID; var Cookie: LongInt); procedure GMCpcCallNotifySinks(const Cpc: IConnectionPointContainer; const ConnectionPointIID: TGUID; const NotifyProc: TCPCNotifyProc; const NotificationsEnabled: Boolean; const Params: array of OleVariant); procedure GMCpcCallNotifySinksObj(const Cpc: IConnectionPointContainer; const ConnectionPointIID: TGUID; const NotifyProc: TCPCNotifyProcObj; const NotificationsEnabled: Boolean; const Params: array of OleVariant); procedure GMRequestCPCDisconnect(const Cpc: IConnectionPointContainer); { ---- CPC Notifiers ---- } procedure GMCallSinkClose(const NotifySink: IUnknown; const Params: array of OleVariant); procedure GMCallSinkBeforeActiveChange(const NotifySink: IUnknown; const Params: array of OleVariant); procedure GMCallSinkAfterActiveChange(const NotifySink: IUnknown; const Params: array of OleVariant); procedure GMCallSinkBeforePositionChange(const NotifySink: IUnknown; const Params: array of OleVariant); procedure GMCallSinkAfterPositionChange(const NotifySink: IUnknown; const Params: array of OleVariant); procedure GMCallSinkBeforeOperation(const NotifySink: IUnknown; const Params: array of OleVariant); procedure GMCallSinkAfterOperation(const NotifySink: IUnknown; const Params: array of OleVariant); procedure GMCallSinkValidateValue(const NotifySink: IUnknown; const Params: array of OleVariant); { ---- COM Helpers ---- } function GMHrSucceeded(const AErrorCode: HResult): Boolean; function GMSysErrorMsg(const AErrorCode: LongInt; const AParams: array of PGMChar): TGMString; function GMCreateGuid: TGuid; function GMIsGUID(const AGuidStr: TGMString): Boolean; procedure GMCopyGuid(const ASource, ADest: IUnknown; const ACallingName: TGMString = cDfltRoutineName); function GMGuidToString(const Guid: TGUID): TGMString; function GMStringToGuid(const AGuidStr: TGMString; const ACaller: TObject = nil; const ACallingName: TGMString = cDfltRoutineName): TGUID; function GMMakeGuidStr(const GuidStr: TGMString): TGMString; function GMMakeGuid(GuidStr: TGMString; const AObj: TObject = nil; const ACallingName: TGMString = cDfltRoutineName): TGUID; function GMCompareGuids(const GuidA, GuidB: TGUID): TGMCompareResult; function GMEqualGuids(const GuidA, GuidB: TGUID): Boolean; function GMCreateComObject(const ClassID: TGUID; const CreateContext: DWORD = cDfltCoCeateContext): IUnknown; function GMCoClassIsRegistered(const ClassId: TGUID): Boolean; { ---- Storage Routines ---- } function GMIsStorageGuid(const Storage: IStorage; const Guid: TGUID; const Caller: TObject = nil): Boolean; function GMIsStorageFileGuid(const FileName: TGMString; const Guid: TGUID; const Caller: TObject = nil): Boolean; procedure GMCheckIsStorageGuid(const Storage: IStorage; const Guid: TGUID; const Caller: TObject = nil); procedure GMCheckIsStorageFileGuid(const FileName: TGMString; const Guid: TGUID; const Caller: TObject = nil); { ---- Error Message Format Helpers ---- } function GMSeverityName(const Aseverity: TGMSeverityLevel): TGMString; function BuildCallingName(const ACallingName, ThisName: TGMString): TGMString; function MsgInconsistentClassSize(const ClassName: TGMString): TGMString; function MsgUnsupportedFieldDataType(const OrdinalValue: LongInt): TGMString; function MsgUnknownValue(const ValueName: TGMString; const Value: LongInt): TGMString; function MsgUnsupportedValue(const ValueName: TGMString; const Value: LongInt): TGMString; function MsgUnknownFieldDataType(const OrdinalValue: LongInt): TGMString; function MsgUnknownPropVal(const PropertyName: TGMString; const Value: LongInt): TGMString; function MsgIntfNotSupported(const Name: TGMString; const AIID: TGuid): TGMString; function MsgNoItemIntfPrefix(const Name: TGMString; const AIID: TGuid): TGMString; function MsgNoOwnerClass(const ClassName: TGMString): TGMString; function MsgOutOfRange(const ValueName: TGMString; const Value: LongInt; const MinVal: LongInt; const MaxVal: LongInt): TGMString; function MsgUnsupportedOperation(const OrdinalValue: LongInt): TGMString; function MsgInvalidStateTransition(const OldState, NewState: LongInt): TGMString; function MsgUnknownQestionOrdinal(const Question: LongInt): TGMString; function MsgMemoryTooSmall(const BufferName: TGMString; const BufferSize, RequiredSize: LongInt): TGMString; function MsgPointerIsNil(const PointerName: TGMString): TGMString; //function MsgModuleNotInstalled(const ModuleName, ErrorMsg, DownloadURL: TGMString): TGMString; procedure GMCheckPointerAssigned(const Ptr: Pointer; const PointerName: TGMString; const AObj: TObject = nil; const ACallingName: TGMString = cDfltRoutineName); procedure GMCheckIntRange(const ValueName: TGMString; const Value, MinValue, MaxValue: PtrInt; const AObj: TObject = nil; const ACallingName: TGMString = cDfltRoutineName); procedure GMCheckMemorySize(const BufferName: TGMString; const BufferSize, RequiredSize: PtrInt; const AObj: TObject = nil; const ACallingName: TGMString = cDfltRoutineName); procedure GMTraceQueryInterface(const AObj: TObject; const AIID: TGuid; const AResult: HResult); {$IFDEF DEBUG} procedure GMCheckRefCountIsZero(const ARefCount: LongInt; const AObj: TObject); {$ENDIF} function GMCoTaskStrDupW(const AValue: WideString): PWideChar; { ---- Lists as Strings ---- } function GMStringJoin(const ALeftStr, ASeparator, ARightStr: TGMString): TGMString; function GMSeparatedStrings(const AStrings: array of TGMString; const ASeparator: TGMString = ', '): TGMString; function GMSeparatedNames(const ACollection: IUnknown; const ASeparator: TGMString = ', '): TGMString; function GMSeparatedValues(const ACollection: IUnknown; const AVarToStrFunc: TGMUnionValToStrFunc; const ASeparator: TGMString = ', '): TGMString; function GMNamesAndValuesAsString(const ACollection: IUnknown; const AVarToStrFunc: TGMUnionValToStrFunc; const ASeparator: TGMString = ', '; const AOperator: TGMString = ' = '; const AOmitNullValues: Boolean = False): TGMString; function GMColumnDesc(const ATitle: TGMString; const AWidth: LongInt; const AAlignment: TGMDfltHorizontalAlignment = haLeft): TGMColumnDescRec; { ---- Additional error message modules ---- } procedure GMRegisterErrorMsgModule(const AModuleName: TGMString); procedure GMExtendExceptionMsg(const AException: TObject; const AAddition: TGMString; const ASeparator: TGMString = ': '; const APrefix: Boolean = True); function GMFileAttributeName(const AFileAttribute: TFileAttribute): TGMString; function GMMatchKindName(const AMatchKind: TMatchKind): TGMString; resourcestring RStrInterface = '<Interface>'; RStrNil = '<nil>'; RStrCPC = 'Connection point container'; RStrUnknownSysErrorMsgFmt = 'Unknown system error code: %d'; RStrField = 'Field'; //RStrStreamRead = 'Stream read'; //RStrStreamWrite = 'Stream write'; RStrProperty = 'Property'; RStrMethod = 'Method'; //RStrItemByNameNoIntf = '%s %s doesn''t exist or'; RStrRefCountFmt = '%s [%p] "%s" Reference Count at Destruction = %d'; RStrAskShowAgain = 'Shall this Message be shown again?'; RStrNoCPForIntf = '%s has no Connection Point for the Interface: %s'; RStrSysErrorCodeFmt = 'System Error, Code Hex: 0x%X, Code Dez: %d'; RStrInvalidParamCountFmt = 'Unsupported number of Parameter: %d'; RStrMissingPropVal = 'The "%s" property must be set before the component can be activated'; RStrUnsupportedIdxType = 'Unsupported Datatype "%s" used for indexing'; RStrNoIntfFmt = '%s [%p] "%s" Interface not Supported: %s %s'; RStrNoItemIntf = 'Unable to get interface %s for item "%s"'; RStrNeedRTTI = 'Class "%s" must be declared with the $M+ compiler directive to access properties.'; RStrFieldNotFound = 'Field "%s" not found in "%s"'; RStrNoValueForItemFmt = 'Cannot get a value for item "%s" at position %d'; RStrCreateDirFailed = 'Failed to create persistent directory "%s"'; srCannotCallNilIntf = 'RGMTypedIntf<%s>.Call: Cannot call any method on NIL interface pointer'; srCollectionelement = 'Collection element'; RStrValue = 'Value'; RStrExactMatch = 'Exact Match'; RStrClosestMatch = 'Closest Match'; RStrArchive = 'Archiv'; RStrCompressed = 'Compressed'; RStrDirectory = 'Directory'; RStrEncrypted = 'Encrypted'; RStrHidden = 'Hidden'; RStrNormal = 'Normal'; RStrOffline = 'Offline'; RStrReadOnly = 'Readonly'; RStrReparsePoint = 'Reparse point'; RStrSparse = 'Sparse'; RStrSystem = 'System'; RStrTemporary = 'Temporary'; RStrError = 'Error'; RStrInformation = 'Information'; RStrWarning = 'Warning'; RStrConfirm = 'Confirm'; RStrNullAllowed = 'NULL allowed'; RStrNotNull = 'Not NULL'; srAscending = 'Ascending'; srDescending = 'Descending'; RStrUnique = 'Unique'; RStrDuplicatesAlloed = 'Duplicates allowed'; RStrInvalidCompareResult = 'Invalid Compare Result'; const cEnumElementCount: array [Boolean] of LongInt = (0, 1); cHRSeverity: array [Boolean] of TGMSeverityLevel = (svInformation, svError); CQIResult: array [Boolean] of HResult = (E_NOINTERFACE, S_OK); GM_E_STREAMWRITE = STG_E_CANTSAVE; GM_E_STREAMREAD = E_FAIL; // E_UNEXPECTED; {$IFDEF FPC} {$IFNDEF JEDIAPI} {$EXTERNALSYM IDI_APPLICATION} IDI_APPLICATION = PGMChar(ULONG_PTR(WORD(32512))); {$EXTERNALSYM IDI_HAND} IDI_HAND = LPTSTR(ULONG_PTR(WORD(32513))); {$EXTERNALSYM IDI_QUESTION} IDI_QUESTION = LPTSTR(ULONG_PTR(WORD(32514))); {$EXTERNALSYM IDI_EXCLAMATION} IDI_EXCLAMATION = LPTSTR(ULONG_PTR(WORD(32515))); {$EXTERNALSYM IDI_ASTERISK} IDI_ASTERISK = LPTSTR(ULONG_PTR(WORD(32516))); {$EXTERNALSYM IDI_WINLOGO} IDI_WINLOGO = LPTSTR(ULONG_PTR(WORD(32517))); {$EXTERNALSYM IDI_WARNING} IDI_WARNING = IDI_EXCLAMATION; {$EXTERNALSYM IDI_ERROR} IDI_ERROR = IDI_HAND; {$EXTERNALSYM IDI_INFORMATION} IDI_INFORMATION = IDI_ASTERISK; {$ENDIF} {$ENDIF} var vShowRefCountWarnings: Boolean = {$IFDEF DEBUG}True;{$ELSE}False;{$ENDIF} {$IFDEF DEBUG} vfGMCheckRefCountOnDestroy: TGMCheckRefCountProc = GMCheckRefCountIsZero; {$ELSE} vfGMCheckRefCountOnDestroy: TGMCheckRefCountProc = nil; {$ENDIF} //vGMFileAttributeNames: array [TFileAttribute] of TGMString = // (RStrArchive, RStrCompressed, RStrDirectory, RStrEncrypted, RStrHidden, RStrNormal, RStrOffline, // RStrReadOnly, RStrReparsePoint, RStrSparse, RStrSystem, RStrTemporary); vGMSevrityIcons: array [TGMSeverityLevel] of Pointer = (nil, IDI_QUESTION, IDI_INFORMATION, IDI_WARNING, IDI_ERROR); //vMatchKindNames: array [TMatchKind] of TGMString = (RStrExactMatch, RStrClosestMatch); vGMComInitFlags: LongInt = cDfltCoInitFlags; implementation uses GMCommon {$IFDEF JEDIAPI}, jwaWinReg, jwaWinBase{$ENDIF} {$IFDEF DELPHI6}, Variants{$ENDIF} ; var vGMErrorMsgModules: TGMStringArray; resourcestring RStrUnsupportedValue = 'Unsupported value (%d) for "%s"'; RStrUnknownValue = 'Unknown Value (%d) for "%s"'; RStrMsgOutOfRangeFmt = '%s out of range: %d. The Value must be in Interval [%d, %d]'; RStrMsgUnsupportedOperation = 'Operation not supported, Ord(Operation): %d'; RStrIntfNotSupported = '%s doesn''t support the Interface: %s'; RStrUnknownPropVal = 'Unknown Value of Property "%s", value: %d'; RStrNoOwnerClass = 'No owner Component with class "%s" found'; RStrInvalidstateTransition = 'Invalid State transition, Ord(OldState): %d, Ord(NewState): %d'; RStrCheckActive = 'The %s can only be used when the Object is Active'; RStrCheckInactive = 'The %s cannot be changed while the Object is active'; RStrUnknownQestionOrdinal = 'Unknown Ordinal Value for Boolean Question: %d'; RStrOperationExecFailed = 'Failed to execute operation %s'; RStrUnsupoortedBoolQuestion = 'Unsupported Question ID: %d'; RStrUnsupportedValueId = 'Unsupported Value ID: %d'; RStrInconsistentclassSize = 'Inconsistent class Size: %s'; RStrInvalidStorageGuid = 'Invalid Storage GUID, requested GUID %s storage GUID %s'; RStrNoParentFmt = 'The object "%s" has no parent of class "%s"'; RStrMemoryTooSmall = '%s size too small (%d Bytes), must be at least %d Bytes'; RStrPtrIsNil = '%s is <nil>'; RStrTheObject = 'The Object'; RStrTheList = 'The List'; //RStrModuleNotInstalled = 'The ''%s'' has not been installed on this System.'; //RStrModuleDownload = 'It can be downloaded from: %s.'; //RStrModuleErrorMsg = 'The System Error Message was:'#13 + // '---------------------------------------------------'#13 + // '%s'; { -------------------------------------- } { ---- Error message Format Helpers ---- } { -------------------------------------- } function GMSeverityName(const ASeverity: TGMSeverityLevel): TGMString; begin case ASeverity of svInformation: Result := RStrInformation; svConfirmation: Result := RStrConfirm; svWarning: Result := RStrWarning; svError: Result := RStrError; else Result := ''; end; end; function GMFileAttributeName(const AFileAttribute: TFileAttribute): TGMString; begin case AFileAttribute of faArchive: Result := RStrArchive; faCompressed: Result := RStrCompressed; faDirectory: Result := RStrDirectory; faEncrypted: Result := RStrEncrypted; faHidden: Result := RStrHidden; faNormal: Result := RStrNormal; faOffline: Result := RStrOffline; faReadOnly: Result := RStrReadOnly; faReparsePoint: Result := RStrReparsePoint; faSparse: Result := RStrSparse; faSystem: Result := RStrSystem; faTemporary: Result := RStrTemporary; else Result := ''; end; end; function GMMatchKindName(const AMatchKind: TMatchKind): TGMString; begin case AMatchKind of mkExactMatch: Result := RStrExactMatch; mkNearestMatch: Result := RStrClosestMatch; else Result := ''; end; end; function BuildCallingName(const ACallingName, ThisName: TGMString): TGMString; begin if ACallingName <> cDfltRoutineName then Result := ACallingName else Result := ThisName; end; function MsgInconsistentClassSize(const ClassName: TGMString): TGMString; begin Result := GMFormat(RStrInconsistentclassSize, [ClassName]); end; function MsgUnsupportedFieldDataType(const OrdinalValue: LongInt): TGMString; begin Result := GMFormat(RStrUnsupportedValue, [OrdinalValue, cStrFieldDataTypeName]); end; function MsgUnknownValue(const ValueName: TGMString; const Value: LongInt): TGMString; begin Result := GMFormat(RStrUnknownValue, [Value, ValueName]); end; function MsgUnsupportedValue(const ValueName: TGMString; const Value: LongInt): TGMString; begin Result := GMFormat(RStrUnsupportedValue, [Value, ValueName]); end; function MsgUnknownFieldDataType(const OrdinalValue: LongInt): TGMString; begin Result := MsgUnknownValue(cStrFieldDataTypeName, OrdinalValue); end; function MsgUnknownPropVal(const PropertyName: TGMString; const Value: LongInt): TGMString; begin Result := GMFormat(RStrUnknownPropVal, [PropertyName, Value]); end; function MsgIntfNotSupported(const Name: TGMString; const AIID: TGuid): TGMString; begin Result := GMFormat(RStrIntfNotSupported, [Name, GMGuidToString(AIID)]); end; function MsgNoItemIntfPrefix(const Name: TGMString; const AIID: TGuid): TGMString; begin Result := GMFormat(RStrNoItemIntf + ': ', [GMGuidToString(AIID), Name]); end; {function MsgNoIntfOrNotExist(const Kind, Name: TGMString; const AIID: TGuid): TGMString; begin Result := MsgIntfNotSupported(GMFormat(RStrItemByNameNoIntf, [Kind, Name]), AIID); end;} function MsgNoOwnerClass(const ClassName: TGMString): TGMString; begin Result := GMFormat(RStrNoOwnerClass, [ClassName]); end; function MsgOutOfRange(const ValueName: TGMString; const Value: LongInt; const MinVal: LongInt; const MaxVal: LongInt): TGMString; begin Result := GMFormat(RStrMsgOutOfRangeFmt, [ValueName, Value, MinVal, MaxVal]); end; function MsgUnsupportedOperation(const OrdinalValue: LongInt): TGMString; begin Result := GMFormat(RStrMsgUnsupportedOperation, [OrdinalValue]); end; function MsgInvalidStateTransition(const OldState, NewState: LongInt): TGMString; begin Result := GMFormat(RStrInvalidstateTransition, [OldState, NewState]); end; function MsgUnknownQestionOrdinal(const Question: LongInt): TGMString; begin Result := GMFormat(RStrUnknownQestionOrdinal, [Question]); end; function MsgMemoryTooSmall(const BufferName: TGMString; const BufferSize, RequiredSize: LongInt): TGMString; begin Result := GMFormat(RStrMemoryTooSmall, [BufferName, BufferSize, RequiredSize]); end; function MsgPointerIsNil(const PointerName: TGMString): TGMString; begin Result := GMFormat(RStrPtrIsNil, [PointerName]); end; //function MsgModuleNotInstalled(const ModuleName, ErrorMsg, DownloadURL: TGMString): TGMString; ////const C2Line = #13#13; //begin //Result := GMFormat(RStrModuleNotInstalled + c2NewLine, [ModuleName]); //if DownloadURL <> '' then Result := Result + GMFormat(RStrModuleDownload + c2NewLine, [DownloadURL]); //if ErrorMsg <> '' then Result := Result + GMFormat(RStrModuleErrorMsg, [ErrorMsg]); //end; { ------------------------------- } { ---- String array routines ---- } { ------------------------------- } function GMStringArray(const AStrings: array of TGMString): TGMStringArray; var i: LongInt; begin SetLength(Result, Length(AStrings)); for i:=Low(AStrings) to High(AStrings) do Result[i] := AStrings[i]; end; procedure GMAddStrToArray(const AValue: TGMString; var AStringArray: TGMStringArray; const AAddEmptyStrings: Boolean); begin if AAddEmptyStrings or (Length(AValue) > 0) then begin SetLength(AStringArray, Length(AStringArray)+1); AStringArray[High(AStringArray)] := AValue; end; end; function GMStrArrayAsText(const AStrings: TGMStringArray; const ASeparator: TGMString = cNewLine): TGMString; var i: LongInt; begin Result := ''; for i:=Low(AStrings) to High(AStrings) do Result := GMStringJoin(Result, ASeparator, AStrings[i]); end; function GMIndexOfStrInArray(const AValue: TGMString; const AStringArray: TGMStringArray): PtrInt; begin for Result:=Low(AStringArray) to High(AStringArray) do if GMSameText(AStringArray[Result], AValue) then Exit; Result := cInvalidItemIdx; end; function GMFindStrInArray(const AValue: TGMString; const AStringArray: TGMStringArray; var AIdx: PtrInt): Boolean; begin AIdx := GMIndexOfStrInArray(AValue, AStringArray); Result := AIdx <> cInvalidItemIdx; end; procedure GMDeleteStrInArray(var AStringArray: TGMStringArray; const AIdx: PtrInt); var i: LongInt; begin if not GMIsInRange(AIdx, Low(AStringArray), High(AStringArray)) then Exit; for i:=AIdx to High(AStringArray)-1 do AStringArray[i] := AStringArray[i+1]; SetLength(AStringArray, Length(AStringArray)-1); end; { ------------------------- } { ---- Buffer Checking ---- } { ------------------------- } procedure GMCheckPointerAssigned(const Ptr: Pointer; const PointerName: TGMString; const AObj: TObject; const ACallingName: TGMString); begin if Ptr = nil then raise EGMException.ObjError(MsgPointerIsNil(PointerName), AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; procedure GMCheckIntRange(const ValueName: TGMString; const Value, MinValue, MaxValue: PtrInt; const AObj: TObject; const ACallingName: TGMString); begin if not GMIsInRange(Value, MinValue, MaxValue) then raise EGMException.ObjError(MsgOutOfRange(ValueName, Value, MinValue, MaxValue), AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; procedure GMCheckMemorySize(const BufferName: TGMString; const BufferSize, RequiredSize: PtrInt; const AObj: TObject; const ACallingName: TGMString); begin if BufferSize < RequiredSize then raise EGMException.ObjError(MsgMemoryTooSmall(BufferName, BufferSize, RequiredSize), AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; function GMCoTaskStrDupW(const AValue: WideString): PWideChar; begin Result := CoTaskMemAlloc((Length(AValue) + 1) * SizeOf(WideChar)); if Result = nil then raise EGMHrException.ObjError(E_OUTOFMEMORY, [], nil, {$I %CurrentRoutine%}); Move(PWideChar(AValue)^, Result^, (Length(AValue) + 1) * SizeOf(WideChar)); end; {$IFDEF DEBUG} procedure GMCheckRefCountIsZero(const ARefCount: LongInt; const AObj: TObject); var Msg: TGMString; begin if ARefCount <> 0 then begin Msg := GMFormat(RStrRefCountFmt, [GMObjClassName(AObj), Pointer(AObj), GMGetObjName(AObj), ARefCount]); GMTrace(Msg, tpWarning); if vShowRefCountWarnings then vShowRefCountWarnings := vfGMMessageBox(Msg + c2NewLine + RStrAskShowAgain, svWarning, MB_YESNO) = IdYes; end; end; {$ENDIF} procedure GMTraceQueryInterface(const AObj: TObject; const AIID: TGuid; const AResult: HResult); begin if AResult = S_OK then Exit; GMTrace(GMFormat(RStrNoIntfFmt, [GMObjClassName(AObj), Pointer(AObj), GMGetObjName(AObj), GMIntfIIDName(AIID), GMGuidToString(AIID)]), tpInterface); end; { ------------------------------------ } { ---- File Attribute conversions ---- } { ------------------------------------ } function GMDWordToFileAttributes(const AValue: DWORD): TFileAttributes; begin Result := []; if AValue and FILE_ATTRIBUTE_ARCHIVE <> 0 then Include(Result, faArchive); if AValue and FILE_ATTRIBUTE_COMPRESSED <> 0 then Include(Result, faCompressed); if AValue and FILE_ATTRIBUTE_DIRECTORY <> 0 then Include(Result, faDirectory); if AValue and FILE_ATTRIBUTE_ENCRYPTED <> 0 then Include(Result, faEncrypted); if AValue and FILE_ATTRIBUTE_HIDDEN <> 0 then Include(Result, faHidden); if AValue and FILE_ATTRIBUTE_NORMAL <> 0 then Include(Result, faNormal); if AValue and FILE_ATTRIBUTE_OFFLINE <> 0 then Include(Result, faOffline); if AValue and FILE_ATTRIBUTE_READONLY <> 0 then Include(Result, faReadOnly); if AValue and FILE_ATTRIBUTE_REPARSE_POINT <> 0 then Include(Result, faReparsePoint); if AValue and FILE_ATTRIBUTE_SPARSE_FILE <> 0 then Include(Result, faSparse); if AValue and FILE_ATTRIBUTE_SYSTEM <> 0 then Include(Result, faSystem); if AValue and FILE_ATTRIBUTE_TEMPORARY <> 0 then Include(Result, faTemporary); end; function GMFileAttributesToDWORD(const AValue: TFileAttributes): DWORD; begin Result := 0; if faArchive in AValue then Result := Result or FILE_ATTRIBUTE_ARCHIVE; if faCompressed in AValue then Result := Result or FILE_ATTRIBUTE_COMPRESSED; if faDirectory in AValue then Result := Result or FILE_ATTRIBUTE_DIRECTORY; if faEncrypted in AValue then Result := Result or FILE_ATTRIBUTE_ENCRYPTED; if faHidden in AValue then Result := Result or FILE_ATTRIBUTE_HIDDEN; if faNormal in AValue then Result := Result or FILE_ATTRIBUTE_NORMAL; if faOffline in AValue then Result := Result or FILE_ATTRIBUTE_OFFLINE; if faReadOnly in AValue then Result := Result or FILE_ATTRIBUTE_READONLY; if faReparsePoint in AValue then Result := Result or FILE_ATTRIBUTE_REPARSE_POINT; if faSparse in AValue then Result := Result or FILE_ATTRIBUTE_SPARSE_FILE; if faSystem in AValue then Result := Result or FILE_ATTRIBUTE_SYSTEM; if faTemporary in AValue then Result := Result or FILE_ATTRIBUTE_TEMPORARY; end; { ------------------------- } { ---- String Routines ---- } { ------------------------- } function GMStringJoin(const ALeftStr, ASeparator, ARightStr: TGMString): TGMString; begin if Length(ARightStr) <= 0 then Result := ALeftStr else if Length(ALeftStr) <= 0 then Result := ARightStr else if Length(ASeparator) <= 0 then Result := ALeftStr + ARightStr else Result := ALeftStr + ASeparator + ARightStr; end; function GMSeparatedStrings(const AStrings: array of TGMString; const ASeparator: TGMString): TGMString; var i: LongInt; begin Result := ''; for i:=Low(AStrings) to high(AStrings) do Result := GMStringJoin(Result, ASeparator, AStrings[i]); end; function GMSeparatedNames(const ACollection: IUnknown; const ASeparator: TGMString): TGMString; var i: LongInt; PICount: IGMGetCount; PIIntfByPosition: IGMGetIntfByPosition; PIName: IGMGetName; begin Result := ''; GMCheckQueryInterface(ACollection, IGMGetCount, PICount, {$I %CurrentRoutine%}); GMCheckQueryInterface(ACollection, IGMGetIntfByPosition, PIIntfByPosition, {$I %CurrentRoutine%}); for i:=0 to PICount.Count-1 do begin GMCheckGetIntfByPosition(PIIntfByPosition, i, IGMGetName, PIName, srCollectionelement, {$I %CurrentRoutine%}); Result := GMStringJoin(Result, ASeparator, PIName.Name); end; end; function GMSeparatedValues(const ACollection: IUnknown; const AVarToStrFunc: TGMUnionValToStrFunc; const ASeparator: TGMString): TGMString; var i: LongInt; PICount: IGMGetCount; PIIntfByPosition: IGMGetIntfByPosition; PIValue: IGMGetUnionValue; begin Result := ''; Assert(Assigned(AVarToStrFunc), 'Assigned(AVarToStrFunc)'); GMCheckQueryInterface(ACollection, IGMGetCount, PICount, {$I %CurrentRoutine%}); GMCheckQueryInterface(ACollection, IGMGetIntfByPosition, PIIntfByPosition, {$I %CurrentRoutine%}); for i:=0 to PICount.Count-1 do begin GMCheckGetIntfByPosition(PIIntfByPosition, i, IGMGetUnionValue, PIValue, srCollectionelement, {$I %CurrentRoutine%}); Result := GMStringJoin(Result, ASeparator, AVarToStrFunc(PIValue.Value)); end; end; function GMNamesAndValuesAsString(const ACollection: IUnknown; const AVarToStrFunc: TGMUnionValToStrFunc; const ASeparator, AOperator: TGMString; const AOmitNullValues: Boolean): TGMString; var i: LongInt; count: IGMGetCount; intfByPos: IGMGetIntfByPosition; getName: IGMGetName; getVal: IGMGetUnionValue; getText: IGMGetText; valStr: TGMString; begin Result := ''; Assert(Assigned(AVarToStrFunc), 'Assigned(AVarToStrFunc)'); GMCheckQueryInterface(ACollection, IGMGetCount, count, {$I %CurrentRoutine%}); GMCheckQueryInterface(ACollection, IGMGetIntfByPosition, intfByPos, {$I %CurrentRoutine%}); for i:=0 to count.Count-1 do begin GMCheckGetIntfByPosition(intfByPos, i, IGMGetName, getName, srCollectionelement, {$I %CurrentRoutine%}); // GMCheckGetIntfByPosition(intfByPos, i, IGMGetUnionValue, getVal, srCollectionelement, {$I %CurrentRoutine%}); // valStr := ''; if intfByPos.GetIntfByPosition(i, IGMGetUnionValue, getVal) = S_OK then valStr := AVarToStrFunc(getVal.Value) else if intfByPos.GetIntfByPosition(i, IGMGetText, getText) = S_OK then valStr := getText.Text else raise EGMException.IntfError(GMFormat(RStrNoValueForItemFmt, [getName.Name, i]), getName, {$I %CurrentRoutine%}); if not AOmitNullValues or not getVal.Value.IsNullOrUnassigned then Result := GMStringJoin(Result, ASeparator, getName.Name + AOperator + valStr); // <- dont StrJoin the latter part! GMStringJoin(getName.Name, AOperator, valStr) end; end; function GMColumnDesc(const ATitle: TGMString; const AWidth: LongInt; const AAlignment: TGMDfltHorizontalAlignment = haLeft): TGMColumnDescRec; begin Result.Title := ATitle; Result.Width := AWidth; Result.Alignment := AAlignment; end; { ------------------------------ } { ---- Objects / Interfaces ---- } { ------------------------------ } {function GMIsOneOfClasses(const AObj: TObject; const Classes: array of TClass): Boolean; var i: LongInt; begin // if Classes is empty Result is True! Result := Length(Classes) = 0; if not Result then for i:=Low(Classes) to High(Classes) do if Obj is Classes[i] then begin Result := True; Break; end; end;} function GMIntfClassName(const AIntf: IUnknown): TGMString; var obiInfo: IGMObjInfo; begin if not GMQueryInterface(AIntf, IGMObjInfo, obiInfo) then Result := RStrInterface else Result := obiInfo.ClassName; end; function GMObjClassName(const AObj: TObject): TGMString; begin if AObj = nil then Result := RStrNil else Result := AObj.ClassName; end; function GMClassName(const AClass: TClass): TGMString; begin if AClass = nil then Result := RStrNil else Result := AClass.ClassName; end; function GMGetIntfName(const AIntf: IUnknown; const ADefaultName: TGMString): TGMString; var getName: IGMGetName; begin if GMQueryInterface(AIntf, IGMGetName, getName) then Result := getName.Name else Result := ADefaultName; end; function GMGetIntfDisplayName(const AIntf: IUnknown): TGMString; // ; const ADefaultValue: TGMString = cStrUnknown var name: IGMGetName; begin if AIntf = nil then Result := RStrNil else if GMQueryInterface(AIntf, IGMGetName, name) then Result := name.Name else Result := RStrUnknown; end; function GMGetIntfFileName(const AIntf: IUnknown; const ADefaultFileName: TGMString): TGMString; var fileName: IGMGetFileName; begin if AIntf = nil then Result := ADefaultFileName else if GMQueryInterface(AIntf, IGMGetFileName, fileName) then Result := fileName.FileName else Result := ADefaultFileName; end; function GMIntfIIDName(const IIDStr: TGMString): TGMString; begin Result := GMIntfIIDName(GMStringToGuid(IIDStr)); end; function GMIntfIIDName(const AIID: TGuid): TGMString; var RegKey: IGMRegKey; begin RegKey := TGMRegKey.Create; if RegKey.Obj.OpenKey(HKEY_CLASSES_ROOT, '\Interface\' + GMGuidToString(AIID)) then Result := RegKey.Obj.ReadString('') else Result := RStrUnknown; end; function GMGetObjName(const AObj: TObject; const ADefaultName: TGMString = ''): TGMString; var getName: IGMGetName; begin if GMGetInterface(AObj, IGMGetName, getName) then Result := getName.Name else Result := ADefaultName; end; function GMGetObjDisplayName(const AObj: TObject): TGMString; begin if AObj = nil then Result := RStrNil else {$IFDEF DELPHIVCL} if AObj is TComponent then Result := (>Obj as TComponent).Name else {$ENDIF} Result := GMGetObjName(AObj, RStrUnknown); end; procedure GMEnableObj(const AObj: TObject; const AEnabled: Boolean); begin GMEnableIntf(GMObjAsIntf(AObj), AEnabled); end; function GMGetIntfEnabled(const AIntf: IUnknown; const ADefaultValue: Boolean = False): Boolean; var getEnabled: IGMGetEnabled; begin if GMQueryInterface(AIntf, IGMGetEnabled, getEnabled) then Result := getEnabled.Enabled else Result := ADefaultValue; end; function GMGetObjEnabled(const AObj: TObject; const ADefaultValue: Boolean = False): Boolean; var getEnabled: IGMGetEnabled; begin if GMGetInterface(AObj, IGMGetEnabled, getEnabled) then Result := getEnabled.Enabled else Result := ADefaultValue; end; procedure GMEnableIntf(const AIntf: IUnknown; const AEnabled: Boolean); var enable: IGMGetSetEnabled; begin if GMQueryInterface(AIntf, IGMGetSetEnabled, enable) then enable.SetEnabled(AEnabled); end; function GMTreeableNodeLevel(ANode: IGMTreeable): Integer; begin Result := 0; while ANode <> nil do begin ANode := ANode.Parent; Inc(Result); end; end; function GMInitNodeVisitData(const ADataClass: TClass; const ANodeTitle: TGMString; const ANode: IGMTreeable; const ASearchIndex: LongInt): RGMNodeVisitData; begin Result.DataClass := ADataClass; Result.NodeTitle := ANodeTitle; Result.Node := ANode; Result.Index := 0; Result.SearchIdx := ASearchIndex; end; {$push} {$macro on} {$define DoNodeVisitRootFirstInnerFunc:=function DoNodeVisit(ANode: IGMTreeable): Boolean; begin Result := True; while (ANode <> nil) and Result do begin Result := AVisitFunc(ANode, AParameter); if ARecurse and Result then Result := DoNodeVisit(ANode.FirstChild); ANode := ANode.NextSibling; end; end;} function GMVisitNodesRootFirst(const AStartNode: IGMTreeable; const AVisitFunc: TGMNodeVisitFunc; const ARecurse: Boolean; const AParameter: Pointer): Boolean; {.$I DoNodeVisit.inc} DoNodeVisitRootFirstInnerFunc begin if Assigned(AVisitFunc) then Result := DoNodeVisit(AStartNode) else Result := True; end; function GMVisitNodesRootFirst(const AStartNode: IGMTreeable; const AVisitFunc: TGMNodeVisitMethod; const ARecurse: Boolean; const AParameter: Pointer): Boolean; {.$I DoNodeVisit.inc} DoNodeVisitRootFirstInnerFunc begin if Assigned(AVisitFunc) then Result := DoNodeVisit(AStartNode) else Result := True; end; {$define DoNodeVisitDepthFirstInnerFunc:= function DoNodeVisitDepthFirst(ANode: IGMTreeable): Boolean; begin Result := True; while (ANode <> nil) and Result do begin if ARecurse and Result then Result := DoNodeVisitDepthFirst(ANode.FirstChild); if Result then Result := AVisitFunc(ANode, AParameter); ANode := ANode.NextSibling; end; end;} function GMVisitNodesDepthfirst(const AStartNode: IGMTreeable; const AVisitFunc: TGMNodeVisitFunc; const ARecurse: Boolean; const AParameter: Pointer): Boolean; {.$I DoNodeVisitDepthfirst.inc} DoNodeVisitDepthFirstInnerFunc begin if Assigned(AVisitFunc) then Result := DoNodeVisitDepthFirst(AStartNode) else Result := True; end; function GMVisitNodesDepthfirst(const AStartNode: IGMTreeable; const AVisitFunc: TGMNodeVisitMethod; const ARecurse: Boolean; const AParameter: Pointer): Boolean; {.$I DoNodeVisitDepthfirst.inc} DoNodeVisitDepthFirstInnerFunc begin if Assigned(AVisitFunc) then Result := DoNodeVisitDepthFirst(AStartNode) else Result := True; end; {$pop} function GMFindRootNode(const ANode: IUnknown): IGMTreeable; begin GMQueryInterface(ANode, IGMTreeable, Result); while (Result <> nil) and (Result.Parent <> nil) do Result := Result.Parent; while (Result <> nil) and (Result.PrevSibling <> nil) do Result := Result.PrevSibling; end; function GMNodePath(const ANode: IUnknown; const ADelimStr: TGMString): TGMString; var node: IGMTreeable; begin Result := ''; if GMQueryInterface(ANode, IGMTreeable, node) then while node <> nil do begin Result := GMStringJoin(GMGetIntfText(node), ADelimStr, Result); node := node.Parent; end; end; function GMIntfHasDataClass(const AIntf: IUnknown; const ADataClass: TClass): Boolean; begin Result := GMGetDataObject(AIntf) is ADataClass; end; function GMGetIntfDataClass(const AIntf: IUnknown): TClass; var dataObj: TObject; begin dataObj := GMGetDataObject(AIntf); if dataObj <> nil then Result := dataObj.ClassType else Result := nil; end; function GMIsNodeMatch(ANode: IGMTreeable; const ADataClass: TClass; const ANodeTitle: TGMString): Boolean; begin Result := ((ADataClass = nil) or (GMGetDataObject(ANode) is ADataClass)) and ((ANodeTitle = '') or GMSameText(ANodeTitle, GMGetIntfText(ANode))); end; function GMFindParentNode(const AStartNode: IGMTreeable; const ADataClass: TClass; const ANodeTitle: TGMString): IGMTreeable; begin Result := AStartNode; while (Result <> nil) and not GMIsNodeMatch(Result, ADataClass, ANodeTitle) do Result := Result.Parent; end; function GMFindNode(const AStartNode: IGMTreeable; const ADecideFunc: TGMNodeVisitFunc; const ARecurse: Boolean; const AParameter: Pointer): IGMTreeable; // // Use the same return value semantics of ADecideFunc here as in GMVisitNodesXxxxx (True => continue iteration, False => stop iteration). // Otherwise a TGMNodeVisitFunc could not be used for both GMFindNode and GMVisitNodesXxxxx. // function DoFind(ANode: IGMTreeable): IGMTreeable; begin Result := nil; while (ANode <> nil) and (Result = nil) do begin if not ADecideFunc(ANode, AParameter) then Result := ANode else if ARecurse then Result := DoFind(ANode.FirstChild); ANode := ANode.NextSibling; end; end; begin if Assigned(ADecideFunc) then Result := DoFind(AStartNode) else Result := nil; end; function GMNodeMatchVisitFunc(const ANode: IGMTreeable; const AParameter: Pointer): Boolean; begin Result := (AParameter = nil) or not GMIsNodeMatch(ANode, PGMNodeVisitData(AParameter).DataClass, PGMNodeVisitData(AParameter).NodeTitle); end; function GMFindNode(const AStartNode: IGMTreeable; const ADataClass: TClass; const ANodeTitle: TGMString; const ARecurse: Boolean): IGMTreeable; var visitData: RGMNodeVisitData; begin visitData := GMInitNodeVisitData(ADataClass, ANodeTitle); Result := GMFindNode(AStartNode, GMNodeMatchVisitFunc, ARecurse, @visitData); end; function GMGetDataObject(const AOwner: IUnknown): TObject; var getDataObj: IGMGetDataObject; begin if GMQueryInterface(AOwner, IGMGetDataObject, getDataObj) then Result := getDataObj.GetDataObject else Result := nil; end; function GMSetDataObject(const AOwner: IUnknown; const ADataObj: TObject): TObject; var PIDataObj: IGMSetDataObject; begin if GMQueryInterface(AOwner, IGMSetDataObject, PIDataObj) then PIDataObj.SetDataObject(ADataObj); Result := ADataObj; end; function GMGetIntfText(const AIntf: IUnknown; const ADefaultValue: TGMString): TGMString; var getText: IGMGetText; begin if GMQueryInterface(AIntf, IGMGetText, getText) then Result := getText.Text else Result := ADefaultValue; end; procedure GMSetIntfText(const AIntf: IUnknown; const AValue: TGMString); var setText: IGMGetSetText; begin if GMQueryInterface(AIntf, IGMGetSetText, setText) then setText.Text := AValue; end; function GMObjFromIntf(const AIntf: IUnknown): TObject; var PIObiInfo: IGMObjInfo; begin if not GMQueryInterface(AIntf, IGMObjInfo, PIObiInfo) then Result := nil else Result := PIObiInfo.Instance; end; function GMGetIntfStrValue(const AIntf: IUnknown; const ADefaultValue: TGMString = ''): TGMSTring; var strVal: IGMGetStringValue; begin if GMQueryInterface(AIntf, IGMGetStringValue, strVal) then Result := strVal.StringValue else Result := ADefaultValue; end; function GMCompareIUnknown(const AIntf1, AIntf2: IUnknown): TGMCompareResult; var unk1, unk2: IUnknown; begin Result := crALessThanB; if GMQueryInterface(AIntf1, IUnknown, unk1) and GMQueryInterface(AIntf2, IUnknown, unk2) then begin if PtrUInt(unk1) = PtrUInt(unk2) then Result := crAEqualToB else if PtrUInt(unk1) > PtrUInt(unk2) then Result := crAGreaterThanB; end; end; function GMObjAsIntf(const AObj: TObject): IUnknown; begin if (AObj = nil) or not AObj.GetInterface(IUnknown, Result) then Result := nil; end; procedure GMCheckGetInterface(const AObj: TObject; const AIID: TGUID; out AIntf; const ACallingName: TGMString); begin GMCheckPointerAssigned(AObj, RStrTheObject, AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); if not AObj.GetInterface(AIID, AIntf) then raise EGMException.ObjError(MsgIntfNotSupported(RStrTheObject, AIID), AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; procedure GMCheckQueryInterface(const ASource: IUnknown; const AIID: TGUID; out AIntf; const ACallingName: TGMString); var CallerName: TGMString; Hr: HResult; function LocalBuildCallingName: TGMString; begin if CallerName = '' then CallerName := GMStringJoin(BuildCallingName(ACallingName, {$I %CurrentRoutine%}), ' - ', GMFormat('QueryInterface<%s>("%s")', [GMIntfClassName(ASource), GMGuidToString(AIID)])); Result := CallerName; end; begin //GMCheckPointerAssigned(Pointer(Obj), RStrTheObject, nil, CallerName); if ASource = nil then raise EGMException.ObjError(MsgPointerIsNil(RStrTheObject), nil, LocalBuildCallingName); //GMHrCheckIntf(Obj.QueryInterface(AIID, AIntf), Obj, CallerName); Hr := ASource.QueryInterface(AIID, AIntf); if not GMHrSucceeded(Hr) then GMHrCheckIntf(ASource.QueryInterface(AIID, AIntf), ASource, LocalBuildCallingName); //if Obj.QueryInterface(AIID, AIntf) <> S_OK then raise EGMException.IntfError(MsgIntfNotSupported(RStrTheObject, AIID), Obj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; function GMQueryInterface(const ASource: IUnknown; const AIID: TGUID; out AIntf): Boolean; begin Result := (ASource <> nil) and (ASource.QueryInterface(AIID, AIntf) = S_OK); end; function GMGetInterface(const AObj: TObject; const AIID: TGUID; out AIntf): Boolean; begin Result := (AObj <> nil) and AObj.GetInterface(AIID, AIntf); end; function GMGetWeakInterface(const AObj: TObject; const AIID: TGUID; out AIntf): Boolean; begin Result := (AObj <> nil) and AObj.GetInterfaceWeak(AIID, AIntf); end; function GMGetIntfHRCode(const AIntf: IUnknown; const ADefaultHrCode: HResult): HResult; var getHrCode: IGMGetHRCode; begin if GMQueryInterface(AIntf, IGMGetHRCode, getHrCode) then Result := getHrCode.HRCode else Result := ADefaultHrCode end; function GMGetObjHRCode(const AObj: TObject; const ADefaultHrCode: HResult): HResult; begin Result := GMGetIntfHRCode(GMObjAsIntf(AObj), ADefaultHrCode); end; procedure GMEnterCriticalSection(const ACriticalSection: IUnknown); var cs: IGMCriticalSection; begin if GMQueryInterface(ACriticalSection, IGMCriticalSection, cs) then cs.EnterCriticalSection; //if ACriticalSection <> nil then ACriticalSection.EnterCriticalSection; end; procedure GMLeaveCriticalSection(const ACriticalSection: IUnknown); var cs: IGMCriticalSection; begin if GMQueryInterface(ACriticalSection, IGMCriticalSection, cs) then cs.LeaveCriticalSection; //if ACriticalSection <> nil then ACriticalSection.LeaveCriticalSection; end; function GMIsOneOfIntegers(const AValue: PtrInt; const AIntValues: array of PtrInt): Boolean; var val: PtrInt; // i: PtrInt; begin //for i:=Low(AIntValues) to High(AIntValues) do if AValue = AIntValues[i] then begin Result := True; Exit; end; for val in AIntValues do if val = AValue then Exit(True); Result := False; end; procedure GMAddIntegersToArray(var ADest: TGMPtrIntArray; const AValues: array of PtrInt); var i: LongInt; begin if Length(AValues) = 0 then Exit; SetLength(ADest, Length(ADest) + Length(AValues)); for i:=Low(AValues) to High(AValues) do ADest[High(ADest) - Length(AValues) - Low(AValues) + i + 1] := AValues[i]; end; procedure GMCheckAllInterfacesSupported(const AIntf: IUnknown; const InterfaceIDs: array of TGUID; const ACallingName: TGMString); var i: LongInt; PIUnknown: IUnknown; begin for i:=Low(InterfaceIDs) to High(InterfaceIDs) do GMCheckQueryInterface(AIntf, InterfaceIDs[i], PIUnknown, ACallingName); end; function GMAllInterfacesSupported(const AIntf: IUnknown; const InterfaceIDs: array of TGUID): Boolean; var i: LongInt; PIUnknown: IUnknown; begin if AIntf = nil then Result := False else begin Result := True; for i:=Low(InterfaceIDs) to High(InterfaceIDs) do if GMQueryInterface(AIntf, InterfaceIDs[i], PIUnknown) then begin Result := False; break; end; end; end; procedure GMCheckGetIntfByPosition(const ACollection: IGMGetIntfByPosition; const Position: LongInt; const AIID: TGUID; out AIntf; const ElementName, ACallingName: TGMString); //var Hr: HResult; begin GMCheckPointerAssigned(Pointer(ACollection), RStrTheList, nil, ACallingName); //Hr := ACollection.GetIntfByPosition(Position, AIID, AIntf); // <- Save MsgNoItemIntfPrefix overhead on success GMHrCheckIntf(ACollection.GetIntfByPosition(Position, AIID, AIntf), ACollection, ACallingName, MsgNoItemIntfPrefix(GMIntToStr(Position), AIID)); //then raise EGMException.IntfError(MsgIntfNotSupported(GMFormat('%s %d', [ElementName, Position]), AIID), nil, ACallingName); end; function GMGetPropertyIntf(const AObj: TObject; const PropertyName: TGMString; const AIID: TGUID; out AIntf): HResult; var Prop: LongInt; begin if (PropertyName = '') or (AObj = nil) then Result := E_INVALIDARG else begin if AObj.ClassInfo = nil then raise EGMException.ObjError(GMFormat(RStrNeedRTTI, [AObj.ClassName]), AObj, 'GMGetPropertyIntf'); if not GMGetOrdinalProperty(AObj, PropertyName, Prop) or (TObject(Prop) = nil) then Result := DISP_E_UNKNOWNNAME else Result := CQIResult[TObject(Prop).GetInterface(AIID, AIntf)]; end; //GMGetOrdinalProperty(Obj, PropertyName, Prop) and //(TObject(Prop) <> nil) then Result := TObject(Prop).GetInterface(AIID, AIntf) else Result := False; end; function GMGetPropIntfFromIntf(const AOwner: IUnknown; const APropertyName: TGMString; const AIID: TGUID; out AIntf): HResult; var getPropIntf: IGMGetPropertyIntf; begin if AOwner = nil then begin Result := E_POINTER; Exit; end; Result := AOwner.QueryInterface(IGMGetPropertyIntf, getPropIntf); if Result = S_OK then Result := getPropIntf.GetPropertyIntf(APropertyName, AIID, AIntf); end; //procedure GMCheckGetPropIntfFromIntf(const Owner: IUnknown; const PropertyName: TGMString; const AIID: TGUID; out AIntf; const ACallingName: TGMString = ''); //var PIGetPropIntf: IGMGetPropertyIntf; //begin // GMCheckQueryInterface(Owner, IGMGetPropertyIntf, PIGetPropIntf, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); // if not PIGetPropIntf.GetPropertyIntf(PropertyName, AIID, AIntf) then // raise EGMException.IntfError(MsgNoIntfOrNotExist(RStrProperty, PropertyName, AIID), Owner, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); //end; procedure GMReleaseMembers(const AIntf: IUnknown); var ReleaseReferences: IGMReleaseReferences; begin if GMQueryInterface(AIntf, IGMReleaseReferences, ReleaseReferences) then ReleaseReferences.ReleaseReferences; end; function GMGetIntfCount(const AIntf: IUnknown; const ADefaultValue: PtrInt): PtrInt; var PICount: IGMGetCount; begin if GMQueryInterface(AIntf, IGMGetCount, PICount) then Result := PICount.Count else Result := ADefaultValue; end; function GMGetIntfHandle(const AIntf: IUnknown; const ADefaultValue: THandle): THandle; var PIHandle: IGMGetHandle; begin if GMQueryInterface(AIntf, IGMGetHandle, PIHandle) then Result := PIHandle.Handle else Result := ADefaultValue; end; function GMCheckGetIntfHandle(const AIntf: IUnknown; const ACallingName: TGMString): THandle; var PIHandle: IGMGetHandle; begin GMCheckQueryInterface(AIntf, IGMGetHandle, PIHandle, ACallingName); Result := PIHandle.Handle; end; function GMGetAllocatedIntfHandle(const AIntf: IUnknown; var Handle: THandle): Boolean; var PIHAlloc: IGMHandleAllocated; PIHandle: IGMGetHandle; begin if (AIntf <> nil) and ((AIntf.QueryInterface(IGMHandleAllocated, PIHAlloc) <> S_OK) or PIHAlloc.HandleAllocated) and (AIntf.QueryInterface(IGMGetHandle, PIHandle) = S_OK) then begin Handle := PIHandle.Handle; Result := Handle <> 0; end else Result := False; end; function GMGetAllocatedObjHandle(const AObj: TObject; var AHandle: THandle): Boolean; begin Result := GMGetAllocatedIntfHandle(GMObjAsIntf(AObj), AHandle); end; function GMIsHandleAllocated(const AIntf: IUnknown): Boolean; var PIHandle: IGMGetHandle; PIHAlloc: IGMHandleAllocated; begin // // If we can get a IGMHandleAllocated avoid accessing PIHandle.Handle because this may create a handle // but we only want to test for a valid handle here and dont want to create one! // Result := (AIntf <> nil) and ((AIntf.QueryInterface(IGMHandleAllocated, PIHAlloc) <> S_OK) or PIHAlloc.HandleAllocated) and (AIntf.QueryInterface(IGMGetHandle, PIHandle) = S_OK) and (PIHandle.Handle <> 0); end; function GMCreateCopyQI(const ASource: IUnknown; const AIID: TGUID; out AIntf): HResult; var PICreateCopy: IGMCreateCopyQI; begin if ASource = nil then Result := E_INVALIDARG else begin Result := ASource.QueryInterface(IGMCreateCopyQI, PICreateCopy); if Result <> S_OK then Exit; Result := PICreateCopy.CreateCopyQI(AIID, AIntf); end; end; function GMObjCreateCopyQI(const ASource: TObject; const AIID: TGUID; out AIntf): HResult; var PICreateCopy: IGMCreateCopyQI; begin if ASource = nil then Result := E_INVALIDARG else begin if not ASource.GetInterface(IGMCreateCopyQI, PICreateCopy) then begin Result := E_NOINTERFACE; Exit; end; Result := PICreateCopy.CreateCopyQI(AIID, AIntf); end; end; function GMFindParentObj(const AObj: TObject; const AParentClass: TClass; out AParent): Boolean; var PIParent: IGMGetParentObj; Prnt: TObject; begin Result := False; TObject(AParent) := nil; if AObj = nil then Exit; if AObj is AParentClass then begin TObject(AParent) := AObj; Result := True; Exit; end; if not AObj.GetInterface(IGMGetParentObj, PIParent) then Exit; Prnt := PIParent.ParentObj; while (Prnt <> nil) and not (Prnt is AParentClass) do begin if not Prnt.GetInterface(IGMGetParentObj, PIParent) then Exit; Prnt := PIParent.ParentObj; end; Result := Prnt <> nil; if Result then TObject(AParent) := Prnt; end; function GMIsParentObj(AParent, AObj: TObject; const AllowIdentity: Boolean; const AStopAtClass: TClass): Boolean; var PIParent: IGMGetParentObj; begin if not AllowIdentity and (AObj = AParent) then begin Result := False; Exit; end; repeat Result := (AObj <> nil) and (AObj = AParent); if Result or (AObj = nil) or ((AStopAtClass <> nil) and (AObj is AStopAtClass)) then Break; if not AObj.GetInterface(IGMGetParentObj, PIParent) then Break; AObj := PIParent.ParentObj; until Result; end; procedure GMCheckFindParentObj(const AObj: TObject; const ParentClass: TClass; out Parent); begin GMCheckPointerAssigned(AObj, RStrTheObject, AObj, {$I %CurrentRoutine%}); if not GMFindParentObj(AObj, ParentClass, Parent) then raise EGMException.ObjError(GMFormat(RStrNoParentFmt, [GMGetObjName(AObj), GMClassName(ParentClass)]), AObj, {$I %CurrentRoutine%}); end; function GMGetObjText(const AObj: TObject; const ADefaultValue: TGMString): TGMString; var PIText: IGMGetText; begin if (AObj <> nil) and AObj.GetInterface(IGMGetText, PIText) then Result := PIText.Text else Result := ADefaultValue; end; procedure GMSetObjText(const AObj: TObject; const AValue: TGMString); var PIText: IGMGetSetText; begin if (AObj <> nil) and AObj.GetInterface(IGMGetSetText, PIText) then PIText.Text := AValue; end; //function GMFindParentObj(const Area: TObject; const ObjClass: TClass; out AObj): Boolean; //var PIParent: IGMGetParentObj; PILayout: IGMUiArea; Parent: TObject; //begin // GMCheckGetInterface(Area, IGMGetParentObj, PIParent, {$I %CurrentRoutine%}); // Parent := PIParent.ParentObj; // while (Parent <> nil) and not (Parent is ObjClass) do // begin // GMCheckGetInterface(Parent, IGMGetParentObj, PIParent, {$I %CurrentRoutine%}); // Parent := PIParent.ParentObj; // end; // Result := Parent <> nil; // if Result then TObject(AObj) := Parent; //end; //function GMObjHandleAllocated(const AObj: TObject): Boolean; //var PIHandle: IGMGetHandle; //begin // Result := (AObj <> nil) and AObj.GetInterface(IGMGetHandle, PIHandle) and (PIHandle.HAndle <> 0); //end; //function GMIntfHandleAllocated(const AIntf: IUnknown): Boolean; //var PIHandle: IGMGetHandle; //begin // Result := (AIntf <> nil) and (AIntf.QueryInterface(IGMGetHandle, PIHandle) = S_OK) and (PIHandle.HAndle <> 0); //end; { --------------------- } { ---- COM Helpers ---- } { --------------------- } function GMHrSucceeded(const AErrorCode: HResult): Boolean; begin Result := AErrorCode and $80000000 = 0; end; //function GMSysErrorMsg(const AErrorCode: LongInt): TGMString; //begin // Result := SysErrorMessage(AErrorCode); // if Result = '' then Result := GMFormat(RStrSysErrorCodeFmt, [AErrorCode, AErrorCode]); //end; procedure GMRegisterErrorMsgModule(const AModuleName: TGMString); begin if not GMIsOneOfStrings(AModuleName, vGMErrorMsgModules) then GMAddStrToArray(AModuleName, vGMErrorMsgModules); end; procedure GMExtendExceptionMsg(const AException: TObject; const AAddition: TGMString; const ASeparator: TGMString = ': '; const APrefix: Boolean = True); var setText: IGMGetSetText; function BuildMsg(const ACurrentMsg: TGMString): TGMString; begin if APrefix then Result := GMStringJoin(AAddition, ASeparator, ACurrentMsg) else Result := GMStringJoin(ACurrentMsg, ASeparator, AAddition); end; begin if GMGetInterface(AException, IGMGetSetText, setText) then setText.Text := BuildMsg(setText.Text) else if GMIsClassByName(AException, Exception) then Exception(AException).Message := BuildMsg(Exception(AException).Message); end; function GMSysErrorMsg(const AErrorCode: LongInt; const AParams: array of PGMChar): TGMString; var apiCode: DWORD; pParams: Pointer; i: Integer; unresolved: TGMString; function BuildSysErrMsg(AFlags: DWORD): TGMString; var buffer: PGMChar; len: DWORD; begin len := FormatMessage(AFlags or FORMAT_MESSAGE_ALLOCATE_BUFFER, nil, DWORD(AErrorCode), 0, PGMChar(@buffer), 0, pParams); if len = 0 then begin apiCode := GetLastError; Result := ''; end else begin apiCode := ERROR_SUCCESS; while (len > 0) do case buffer[len - 1] of #0..#32, '.': Dec(len); else Break; end; SetString(Result, buffer, len); if LocalFree(HLOCAL(buffer)) <> 0 then GMTrace('GMSysErrorMsg - LocalFree failed!', tpWarning); end; end; function DoInserts(const AMsg: TGMString): TGMString; var bitMaskInserted, chPos, i, argNo: Integer; strToInsert: TGMString; pCh, pChFound: PGMChar; // unResolved, begin Result := AMsg; unResolved := ''; chPos := 1; bitMaskInserted := 0; repeat pCh := @Result[chPos]; // <- Result may have been moved due to modifications! pChFound := GMStrLScan(pCh, '%', Length(Result) - chPos + 1); if pChFound <> nil then begin Inc(chPos, pChFound - pCh); Inc(pChFound); argNo := Ord(pChFound^) - 49; if GMIsInRange(argNo, Low(AParams), High(AParams)) then begin strToInsert := AParams[argNo]; System.Delete(Result, chPos, 2); System.Insert(strToInsert, Result, chPos); Inc(chPos, Length(strToInsert)); bitMaskInserted := bitMaskInserted or (1 shl argNo); end; end; until (pChFound = nil) or (pChFound^ = #0); for i:=Low(AParams) to High(AParams) do if bitMaskInserted and (1 shl i) = 0 then unResolved := GMStringJoin(unResolved, ', ', AParams[i]); end; begin if Length(AParams) = 0 then pParams := nil else pParams := @AParams[Low(AParams)]; //Result := BuildSysErrMsg(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY); //if (Length(Result) <= 0) and (apiCode = ERROR_INVALID_PARAMETER) then Result := BuildSysErrMsg(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY or FORMAT_MESSAGE_IGNORE_INSERTS); if (Length(Result) <= 0) then // and (Length(vGMErrorMsgModules) > 0) for i:=Low(vGMErrorMsgModules) to High(vGMErrorMsgModules) do begin Result := GMModuleErrorMessage(vGMErrorMsgModules[i], LongWord(AErrorCode and $0000FFFF)); if Length(Result) > 0 then Break; end; unresolved := ''; Result := DoInserts(Result); Result := GMStringJoin(Result, ': ', unresolved); if Length(Result) <= 0 then Result := GMFormat(RStrUnknownSysErrorMsgFmt, [AErrorCode]); end; function GMGuidToString(const Guid: TGUID): TGMString; var PWStr: PWideChar; begin GMHrCheckObj(StringFromCLSID(Guid, PWStr), nil, {$I %CurrentRoutine%}); Result := PWStr; CoTaskMemFree(PWStr); end; procedure GMCopyGuid(const ASource, ADest: IUnknown; const ACallingName: TGMString); var PISrcGuid: IGMGetGuid; PIDstGuid: IGMGetSetGuid; begin GMCheckQueryInterface(ASource, IGMGetGuid, PISrcGuid, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); GMCheckQueryInterface(ADest, IGMGetSetGuid, PIDstGuid, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); PIDstGuid.GUID := PISrcGuid.GUID; end; function GMMakeGuidStr(const GuidStr: TGMString): TGMString; begin Result := GMStrip(GuidStr, cGuidStripChars); if Result <> '' then Result := '{' + Result + '}'; end; function GMCreateGuid: TGuid; begin GMHrCheckObj(CoCreateGuid(Result), nil, 'GMCreateGuid'); end; function GMIsGUID(const AGuidStr: TGMString): Boolean; var GUID: TGUID; guidWStr: UnicodeString; begin guidWStr := GMMakeGuidStr(AGuidStr); Result := GMHrSucceeded(CLSIDFromString(PWideChar(guidWStr), GUID)); end; function GMStringToGuid(const AGuidStr: TGMString; const ACaller: TObject; const ACallingName: TGMString): TGUID; var guidWStr: UnicodeString; begin guidWStr := GMMakeGuidStr(AGuidStr); GMHrCheckObj(CLSIDFromString(PWideChar(guidWStr), Result), ACaller, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; function GMMakeGuid(GuidStr: TGMString; const AObj: TObject; const ACallingName: TGMString): TGUID; begin GuidStr := GMMakeGuidStr(GuidStr); if GuidStr <> '' then Result := GMStringToGuid(GuidStr, AObj, ACallingName) else Result := GUID_NULL; end; function GMCreateComObject(const ClassID: TGUID; const CreateContext: DWORD): IUnknown; begin GMHrCheckObj(CoCreateInstance(ClassID, nil, CreateContext, IUnknown, Result), nil, {$I %CurrentRoutine%}); end; function GMCompareGuids(const GuidA, GuidB: TGUID): TGMCompareResult; var Cmp: LongInt; begin Cmp := CompareText(GMGuidToString(GuidA), GMGuidToString(GuidB)); if Cmp < 0 then Result := crALessThanB else if Cmp = 0 then Result := crAEqualToB else Result := crAGreaterThanB end; function GMEqualGuids(const GuidA, GuidB: TGUID): Boolean; begin Result := CompareMem(@GuidA, @GuidB, SizeOf(TGUID)); // GMCompareGuids(GuidA, GuidB) = crAEqualToB; end; function GMCoClassIsRegistered(const ClassId: TGUID): Boolean; var ProgId: PWideChar; begin ProgId := nil; Result := ProgIDFromCLSID(ClassId, ProgId) = S_OK; if ProgId <> nil then CoTaskMemFree(ProgId); end; { -------------------------- } { ---- Storage Routines ---- } { -------------------------- } function GMIsStorageGuid(const Storage: IStorage; const Guid: TGUID; const Caller: TObject): Boolean; var Stat: TStatStg; begin if Storage = nil then Result := False else begin GMHrCheckObj(Storage.Stat(Stat, STATFLAG_NONAME), Caller, {$I %CurrentRoutine%}); //if Stat.pwcsName <> nil then CoTaskMemFree(Stat.pwcsName); Result := IsEqualGuid(Stat.clsid, Guid); end; end; function GMIsStorageFileGuid(const FileName: TGMString; const Guid: TGUID; const Caller: TObject): Boolean; var Storage: IStorage; begin GMCheckFileExists(FileName, Caller, {$I %CurrentRoutine%}); //if not FileExists(FileName) then raise EGMException.ObjError(GMFormat(RStrFileNotExists, [FileName]), Caller, {$I %CurrentRoutine%}); GMHrCheckObj(StgOpenStorage(PWideChar(UnicodeString(FileName)), nil, STGM_READWRITE or STGM_SHARE_EXCLUSIVE, nil, 0, Storage), Caller, {$I %CurrentRoutine%}); Result := GMIsStorageGuid(Storage, Guid); end; procedure GMCheckIsStorageGuid(const Storage: IStorage; const Guid: TGUID; const Caller: TObject); var Stat: TStatStg; begin if Storage <> nil then begin GMHrCheckObj(Storage.Stat(Stat, STATFLAG_NONAME), Caller, {$I %CurrentRoutine%}); //if Stat.pwcsName <> nil then CoTaskMemFree(Stat.pwcsName); if not IsEqualGuid(Stat.clsid, Guid) then raise EGMException.ObjError(GMFormat(RStrInvalidStorageGuid, [GMGuidToString(Guid), GMGuidToString(Stat.clsid)]), Caller, {$I %CurrentRoutine%}); end; end; procedure GMCheckIsStorageFileGuid(const FileName: TGMString; const Guid: TGUID; const Caller: TObject = nil); var Storage: IStorage; begin GMCheckFileExists(FileName, Caller, {$I %CurrentRoutine%}); //if not FileExists(FileName) then raise EGMException.ObjError(GMFormat(RStrFileNotExists, [FileName]), Caller, {$I %CurrentRoutine%}); GMHrCheckObj(StgOpenStorage(PWideChar(UnicodeString(FileName)), nil, STGM_READWRITE or STGM_SHARE_EXCLUSIVE, nil, 0, Storage), Caller, {$I %CurrentRoutine%}); GMCheckIsStorageGuid(Storage, Guid, Caller); end; { ---------------------------------- } { ---- Connection Point Helpers ---- } { ---------------------------------- } function GMDoNotifySink(const NotificationsEnabled: Boolean; const NotifySink: IUnknown; const AIID: TGUID; out AIntf): Boolean; //var PIAskBoolean: IGMAskBoolean; begin if not GMQueryInterface(NotifySink, AIID, AIntf) then Result := False else Result := NotificationsEnabled or GMAskBoolean(NotifySink, Ord(bvAlwaysNotify), False); //((NotifySink.QueryInterface(IGMAskBoolean, PIAskBoolean) = S_OK) and (PIAskBoolean.AskBoolean(Ord(bvAlwaysNotify)) = Ord(barTrue))); end; procedure GMInterfaceConnect(const AObj: TObject; const AContainer: IUnknown; const AIID: TGUID; var Cookie: LongInt; const ACallingName: TGMString); var PISink: IUnknown; begin if (AObj <> nil) and (AContainer <> nil) then begin Cookie := CInvalidCPCookie; GMCheckGetInterface(AObj, IUnknown, PISink, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); GMInterfaceConnect(PISink, AContainer, AIID, Cookie, AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; end; procedure GMInterfaceConnect(const Sink, AContainer: IUnknown; const AIID: TGUID; var Cookie: LongInt; const AObj: TObject; const ACallingName: TGMString); overload; var CPC: IConnectionPointContainer; CP: IConnectionPoint; begin if (Sink <> nil) and (AContainer <> nil) then begin Cookie := CInvalidCPCookie; if not GMQueryInterface(AContainer, IConnectionPointContainer, CPC) then raise EGMException.ObjError(MsgIntfNotSupported(RStrCPC, IConnectionPointContainer), AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); if CPC.FindConnectionPoint(AIID, CP) <> S_OK then raise EGMException.ObjError(GMFormat(RStrNoCPForIntf, [RStrCPC, GMGuidToString(AIID)]), AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); GMHrCheckObj(CP.Advise(Sink, Cookie), AObj, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; end; procedure GMQuietInterfaceConnect(const AObj: TObject; const AContainer: IUnknown; const AIID: TGUID; var Cookie: LongInt); var sink: IUnknown; cpc: IConnectionPointContainer; cp: IConnectionPoint; begin if (AObj <> nil) and (AContainer <> nil) then begin Cookie := CInvalidCPCookie; if AObj.GetInterface(IUnknown, sink) and GMQueryInterface(AContainer, IConnectionPointContainer, cpc) and (cpc.FindConnectionPoint(AIID, cp) = S_OK) then cp.Advise(sink, Cookie); end; end; procedure GMInterfaceDisconnect(const AContainer: IUnknown; const AIID: TGUID; var Cookie: LongInt); var CPC: IConnectionPointContainer; CP: IConnectionPoint; begin if (AContainer <> nil) and (Cookie <> CInvalidCPCookie) then if GMHrSucceeded(AContainer.QueryInterface(IConnectionPointContainer, CPC)) then if GMHrSucceeded(CPC.FindConnectionPoint(AIID, CP)) then if GMHrSucceeded(CP.Unadvise(Cookie)) then Cookie := CInvalidCPCookie; end; procedure GMCpcCallNotifySinks(const Cpc: IConnectionPointContainer; const ConnectionPointIID: TGUID; const NotifyProc: TCPCNotifyProc; const NotificationsEnabled: Boolean; const Params: array of OleVariant); var EnumCP: IEnumConnectionPoints; ConnectionPoint: IConnectionPoint; procedure NotifyConnections(const ConnectionPoint: IConnectionPoint); var EnumConnections: IEnumConnections; ConnectData: tagConnectData; PISinkUnk: IUnknown; begin if (ConnectionPoint <> nil) and (ConnectionPoint.EnumConnections(EnumConnections) = S_OK) then while EnumConnections.Next(1, ConnectData, nil) = S_OK do if GMDoNotifySink(NotificationsEnabled, ConnectData.pUnk, IUnknown, PISinkUnk) then NotifyProc(ConnectData.pUnk, Params) //if ConnectData.pUnk <> nil then NotifyProc(ConnectData.pUnk, Params); {(ConnectData.pUnk.QueryInterface(ConnectionPointIID, NotifySink) = S_OK)} end; begin if (Cpc <> nil) and Assigned(NotifyProc) then begin if IsEqualGuid(ConnectionPointIID, GUID_NULL) then begin if Cpc.EnumConnectionPoints(EnumCP) = S_OK then while EnumCP.Next(1, ConnectionPoint, nil) = S_OK do NotifyConnections(ConnectionPoint); end else if Cpc.FindConnectionPoint(ConnectionPointIID, ConnectionPoint) = S_OK then NotifyConnections(ConnectionPoint); end; end; procedure GMCpcCallNotifySinksObj(const Cpc: IConnectionPointContainer; const ConnectionPointIID: TGUID; const NotifyProc: TCPCNotifyProcObj; const NotificationsEnabled: Boolean; const Params: array of OleVariant); var EnumCP: IEnumConnectionPoints; ConnectionPoint: IConnectionPoint; procedure NotifyConnections(const ConnectionPoint: IConnectionPoint); var EnumConnections: IEnumConnections; ConnectData: tagConnectData; PISinkUnk: IUnknown; begin if (ConnectionPoint <> nil) and (ConnectionPoint.EnumConnections(EnumConnections) = S_OK) then while EnumConnections.Next(1, ConnectData, nil) = S_OK do if GMDoNotifySink(NotificationsEnabled, ConnectData.pUnk, IUnknown, PISinkUnk) then NotifyProc(ConnectData.pUnk, Params) //if ConnectData.pUnk <> nil then NotifyProc(ConnectData.pUnk, Params); {(ConnectData.pUnk.QueryInterface(ConnectionPointIID, NotifySink) = S_OK)} end; begin if (Cpc <> nil) and Assigned(NotifyProc) then begin if IsEqualGuid(ConnectionPointIID, GUID_NULL) then begin if Cpc.EnumConnectionPoints(EnumCP) = S_OK then while EnumCP.Next(1, ConnectionPoint, nil) = S_OK do NotifyConnections(ConnectionPoint); end else if Cpc.FindConnectionPoint(ConnectionPointIID, ConnectionPoint) = S_OK then NotifyConnections(ConnectionPoint); end; end; procedure GMRequestCPCDisconnect(const Cpc: IConnectionPointContainer); var EnumCP: IEnumConnectionPoints; ConnectionPoint: IConnectionPoint; CpIID: TGUID; EnumConnections: IEnumConnections; ConnectData: tagConnectData; ConnectedObj: IGMDisconnectFromConnectionPoint; begin if (Cpc <> nil) and (Cpc.EnumConnectionPoints(EnumCP) = S_OK) then while EnumCP.Next(1, ConnectionPoint, nil) = S_OK do if (ConnectionPoint.GetConnectionInterface(CpIID) = S_OK) and (ConnectionPoint.EnumConnections(EnumConnections) = S_OK) then while EnumConnections.Next(1, ConnectData, nil) = S_OK do if GMQueryInterface(ConnectData.pUnk, IGMDisconnectFromConnectionPoint, ConnectedObj) then try ConnectedObj.DisconnectFromConnectionPoint(Cpc, CpIID, ConnectData.dwCookie); except end; end; { ------------------------------------ } { ---- Connection Point Notifiers ---- } { ------------------------------------ } procedure GMCallSinkClose(const NotifySink: IUnknown; const Params: array of OleVariant); var PIActive: IGMGetSetActive; begin if GMQueryInterface(NotifySink, IGMGetSetActive, PIActive) then PIActive.Active := False; // <- Don't eat exceptions! end; procedure GMCallSinkBeforeActiveChange(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMActiveChangeNotifications; begin if (Length(Params) > 0) and GMQueryInterface(NotifySink, IGMActiveChangeNotifications, Sink) then Sink.BeforeActiveChange(Params[Low(Params)]); end; procedure GMCallSinkAfterActiveChange(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMActiveChangeNotifications; begin if (Length(Params) > 0) and GMQueryInterface(NotifySink, IGMActiveChangeNotifications, Sink) then {try} Sink.AfterActiveChange(Params[Low(Params)]); //except end; end; procedure GMCallSinkBeforePositionChange(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMPositionChangeNotifications; begin // No try Except around the Call Here! if GMQueryInterface(NotifySink, IGMPositionChangeNotifications, Sink) then Sink.BeforePositionChange; end; procedure GMCallSinkAfterPositionChange(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMPositionChangeNotifications; begin if GMQueryInterface(NotifySink, IGMPositionChangeNotifications, Sink) then try Sink.AfterPositionChange; except end; end; procedure GMCallSinkBeforeOperation(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMOperationNotifications; begin if GMQueryInterface(NotifySink, IGMOperationNotifications, Sink) then case Length(Params) of 1: Sink.BeforeOperation(Params[Low(Params)]); 2: Sink.BeforeOperation(Params[Low(Params)], Params[Low(Params) + 1]); else raise EGMException.ObjError(GMFormat(RStrInvalidParamCountFmt, [Length(Params)]), nil, {$I %CurrentRoutine%}); end; end; procedure GMCallSinkAfterOperation(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMOperationNotifications; begin if GMQueryInterface(NotifySink, IGMOperationNotifications, Sink) then case Length(Params) of 1: try Sink.AfterOperation(Params[Low(Params)]); except end; 2: try Sink.AfterOperation(Params[Low(Params)], Params[Low(Params) + 1]); except end; else raise EGMException.ObjError(GMFormat(RStrInvalidParamCountFmt, [Length(Params)]), nil, {$I %CurrentRoutine%}); end; end; procedure GMCallSinkValidateValue(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMValidateValues; begin // No try Except around the Call Here! if GMQueryInterface(NotifySink, IGMValidateValues, Sink) then Sink.ValidateValues; end; { ------------------------------------------- } { ---- Value AStorage Directory Routines ---- } { ------------------------------------------- } procedure GMVsdCreatePath(const AStorage: IUnknown; const ADirPath: TGMString); var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; chPos: PtrInt; Dir: TGMString; //AbsPath: Boolean; begin if not valStgDir.QueryFrom(AStorage) then Exit; chPos := 1; if not GMIsRelativePath(ADirPath) then GMVsdOpenDir(AStorage, '\', True); repeat Dir := GMNextWord(chPos, ADirPath, cDirSep); if Length(Dir) > 0 then GMVsdOpenDir(AStorage, Dir, True); until Dir = ''; end; function GMVsdOpenDir(const AStorage: IUnknown; const ADirPath: TGMString; const ACreateIfNotExist: Boolean): Boolean; var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; begin if not valStgDir.QueryFrom(AStorage) then Result := False else begin Result := valStgDir.Intf.OpenDir(ADirPath, ACreateIfNotExist); if not Result and ACreateIfNotExist then raise EGMException.IntfError(GMFormat(RStrCreateDirFailed, [ADirPath]), AStorage, {$I %CurrentRoutine%}); end; end; function GMVsdDirExists(const AStorage: IUnknown; const ADirPath: TGMString): Boolean; var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; oldDirPath: TGMString; // dirPathKeeper: IUnknown; begin if not valStgDir.QueryFrom(AStorage) then Result := False else begin // dirPathKeeper := TGMVsdDirPathKeeper.Create(AStorage); oldDirPath := valStgDir.Intf.CurrentPath; try Result := valStgDir.Intf.OpenDir(ADirPath, False); finally valStgDir.Intf.OpenDir(oldDirPath, False); end; end; end; function GMVsdOpenAbsDir(const AStorage: IUnknown; const ADirPath: TGMString; const ACreateIfNotExist: Boolean): Boolean; begin Result := GMVsdOpenDir(AStorage, GMAbsPath(ADirPath), ACreateIfNotExist); end; function GMVsdDeleteAbsDir(const Storage: IUnknown; const ADirPath: TGMString): Boolean; begin Result := GMVsdDeleteDir(Storage, GMAbsPath(ADirPath)); end; function GMVsdDeleteDir(const AStorage: IUnknown; const ADirPath: TGMString): Boolean; var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; begin if valStgDir.QueryFrom(AStorage) then Result := valStgDir.Intf.DeleteDir(ADirPath) else Result := False; end; function GMVsdDeleteValue(const AStorage: IUnknown; const AValueName: TGMString): Boolean; var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; begin if valStgDir.QueryFrom(AStorage) then Result := valStgDir.Intf.DeleteValue(AValueName) else Result := False; end; function GMVsdContainsValue(const AStorage: IUnknown; const AValueName: TGMString): Boolean; var containsVal: RGMTypedIntf<IGMContainsValue>; begin if containsVal.QueryFrom(AStorage) then Result := containsVal.Intf.ContainsValue(AValueName) else Result := False; end; procedure GMVsdReadSubDirNames(const AStorage: IUnknown; var ASubDirNames: TGMStringArray); var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; begin if valStgDir.QueryFrom(AStorage) then valStgDir.Intf.ReadSubDirNames(ASubDirNames); end; procedure GMVsdReadValueNames(const AStorage: IUnknown; var AValueNames: TGMStringArray); var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; begin if valStgDir.QueryFrom(AStorage) then valStgDir.Intf.ReadValueNames(AValueNames); end; function GMVsdCurrentPath(const AStorage: IUnknown): TGMString; var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; begin if valStgDir.QueryFrom(AStorage) then Result := valStgDir.Intf.CurrentPath else Result := ''; end; procedure GMVsdCommit(const AStorage: IUnknown); var valStgDir: RGMTypedIntf<IGMValueStorageDirectory>; begin if valStgDir.QueryFrom(AStorage) then valStgDir.Intf.Commit; end; {function GMVsdValueNameExists(const Storage: IUnknown; const ValueName: TGMString): Boolean; var ValueNames: IGMStrings; valStgDir: IGMValueStorageDirectory; begin if (Storage = nil) or (Storage.QueryInterface(IGMValueStorageDirectory, valStgDir) <> S_OK) then Result := False else begin ValueNames := TGMStringList.Create(False, True); ValueNames.Sorted := True; valStgDir.ReadValueNames(ValueNames); Result := ValueNames.IndexOf(ValueName) <> CInvalidItemIdx; end; end;} {procedure GMVsdDeletePrefixedValues(const Storage: IUnknown; const PrefixStr: TGMString); var i: LongInt; ValueNames: IGMStrings; valStgDir: IGMValueStorageDirectory; begin if (Storage <> nil) and (Storage.QueryInterface(IGMValueStorageDirectory, valStgDir) = S_OK) then begin ValueNames := TGMStringList.Create(False, True); valStgDir.ReadValueNames(ValueNames); for i:=0 to ValueNames.Count-1 do if GMIsPrefixStr(PrefixStr, ValueNames[i], True) then valStgDir.DeleteValue(ValueNames[i]); end; end; procedure GMVsdDeleteValues(const Storage: IUnknown); begin GMVsdDeletePrefixedValues(Storage, ''); end; } procedure GMStoreString(const ADest: IGMStringStorage; const AValueName, AValue: TGMString; const ADefaultValue: TGMString = cDfltReadString); begin if ADest = nil then Exit; if not GMSameText(AValue, ADefaultValue) then ADest.WriteString(AValueName, AValue) else GMVsdDeleteValue(ADest, AValueName); end; procedure GMStoreInteger(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: LongInt; const ADefaultValue: LongInt = cDfltReadInteger); begin if ADest = nil then Exit; if AValue <> ADefaultValue then ADest.WriteInteger(AValueName, AValue) else GMVsdDeleteValue(ADest, AValueName); end; procedure GMStoreInt64(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: Int64; const ADefaultValue: Int64 = cDfltReadInteger); begin if ADest = nil then Exit; if AValue <> ADefaultValue then ADest.WriteInt64(AValueName, AValue) else GMVsdDeleteValue(ADest, AValueName); end; procedure GMStoreBoolean(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: Boolean; const ADefaultValue: Boolean = cDfltReadBoolean); begin if ADest = nil then Exit; if AValue <> ADefaultValue then ADest.WriteBoolean(AValueName, AValue) else GMVsdDeleteValue(ADest, AValueName); end; procedure GMStoreDateTime(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: TDateTime; const ADefaultValue: TDateTime = cDfltReadDateTime); begin if ADest = nil then Exit; if AValue <> ADefaultValue then ADest.WriteDateTime(AValueName, AValue) else GMVsdDeleteValue(ADest, AValueName); end; procedure GMStoreDouble(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue: Double; const ADefaultValue: Double = cDfltReadFloat); begin if ADest = nil then Exit; if AValue <> ADefaultValue then ADest.WriteDouble(AValueName, AValue) else GMVsdDeleteValue(ADest, AValueName); end; procedure GMStoreVariant(const ADest: IGMValueStorage; const AValueName: TGMString; const AValue, ADefaultValue: OleVariant); begin if ADest = nil then Exit; if (VarType(AValue) <> VarType(ADefaultValue)) or (AValue <> ADefaultValue) then ADest.WriteVariant(AValueName, AValue) else GMVsdDeleteValue(ADest, AValueName); end; procedure GMVsdLoadFromDir(const ASource: IGMValueStorage; const ALoadPath: TGMString; const ALoadProc: TGMLoadStoreValuesProc; const ACryptCtrlData: PGMCryptCtrlData); var threadSync: RGMCriticalSectionLock; pathKeeper: IUnknown; begin if (ASource <> nil) and (ALoadPath <> '') and Assigned(ALoadProc) then begin threadSync.Lock(ASource); pathKeeper := TGMVsdDirPathKeeper.Create(ASource); if GMVsdOpenDir(ASource, ALoadPath, False) then ALoadProc(ASource, ACryptCtrlData); end; end; procedure GMVsdStoreToDir(const ADest: IGMValueStorage; const AStorePath: TGMString; const AStoreProc: TGMLoadStoreValuesProc; const ACryptCtrlData: PGMCryptCtrlData); var threadSync: RGMCriticalSectionLock; pathKeeper: IUnknown; begin if (ADest <> nil) and (AStorePath <> '') and Assigned(AStoreProc) then begin threadSync.Lock(ADest); pathKeeper := TGMVsdDirPathKeeper.Create(ADest, AStorePath, True); AStoreProc(ADest, ACryptCtrlData); end; end; procedure GMVsdLoadFromDir(const ASource: IGMValueStorage; const ALoadPath: TGMString; const ALoadIntf: IUnknown; const ACryptCtrlData: PGMCryptCtrlData); var threadSync: RGMCriticalSectionLock; pathKeeper: IUnknown; PILoadStore: IGMLoadStoreData; begin if (ASource <> nil) and (Length(ALoadPath) > 0) and GMQueryInterface(ALoadIntf, IGMLoadStoreData, PILoadStore) then begin threadSync.Lock(ASource); pathKeeper := TGMVsdDirPathKeeper.Create(ASource); if GMVsdOpenDir(ASource, ALoadPath, False) then PILoadStore.LoadData(ASource, ACryptCtrlData); end; end; procedure GMVsdStoreToDir(const ADest: IGMValueStorage; const AStorePath: TGMString; const AStoreIntf: IUnknown; const ACryptCtrlData: PGMCryptCtrlData); var threadSync: RGMCriticalSectionLock; pathKeeper: IUnknown; PILoadStore: IGMLoadStoreData; begin if (ADest <> nil) and (Length(AStorePath) > 0) and GMQueryInterface(AStoreIntf, IGMLoadStoreData, PILoadStore) then begin threadSync.Lock(ADest); pathKeeper := TGMVsdDirPathKeeper.Create(ADest, AStorePath, True); PILoadStore.StoreData(ADest, ACryptCtrlData); end; end; procedure GMVsdLoadTree(const ASource: IGMValueStorage; const AParentTreeNode: IGMTreeable; const ATreeNodeCreator: IGMCreateTreeNodeWithDataObj; const AParameter: IUnknown; const ACryptCtrlData: PGMCryptCtrlData; const ASubDirSeparator: TGMString); var i: Integer; subDirNames: TGMStringArray; newNode: IGMTreeable; dirKeeper: IUnknown; loadStore: IGMLoadStoreData; begin if (ASubDirSeparator = '') or not GMVsdOpenDir(ASource, ASubDirSeparator) then Exit; GMVsdReadSubDirNames(ASource, subDirNames); for i:=Low(subDirNames) to High(subDirNames) do begin dirKeeper := nil; // <- restore previous dir dirKeeper := TGMVsdDirPathKeeper.Create(ASource); if not GMVsdOpenDir(ASource, subDirNames[i]) then Continue; newNode := ATreeNodeCreator.CreateTreeNodeWithDataObj(ASource, AParentTreeNode, AParameter); if GMQueryInterface(newNode, IGMLoadStoreData, loadStore) then loadStore.LoadData(ASource, ACryptCtrlData); //loadStore := nil; // <- release early, saves some memory GMVsdLoadTree(ASource, newNode, ATreeNodeCreator, AParameter, ACryptCtrlData, ASubDirSeparator); end; end; procedure GMStoreTree(const ADest: IGMValueStorage; ANode: IGMTreeable; var ANodeIdx: LongInt; const AStoreSiblings: Boolean; const ACryptCtrlData: PGMCryptCtrlData); var dirKeeper: IUnknown; loadStore: IGMLoadStoreData; begin while ANode <> nil do begin dirKeeper := nil; // <- restore previous dir // in TGMIniFileStorage name order must match integer order -> pad node idx with zeros dirKeeper := TGMVsdDirPathKeeper.Create(ADest, GMFormat('%s\%.5d', [scSubNodesDirSeparator, ANodeIdx]), True); if GMQueryInterface(ANode, IGMLoadStoreData, loadStore) then loadStore.StoreData(ADest, ACryptCtrlData); loadStore := nil; // <- release early, saves some memory Inc(ANodeIdx); GMStoreTree(ADest, ANode.FirstChild, ANodeIdx, True, ACryptCtrlData); if AStoreSiblings then ANode := ANode.NextSibling else ANode := nil; end; end; procedure GMVsdCopyDirValues(const ASource, ADest: IGMStringStorage); const cDfltString = ''; var threadSync1, threadSync2: RGMCriticalSectionLock; i: LongInt; ValueNames: TGMStringArray; begin if (ASource = nil) or (ADest = nil) then Exit; threadSync1.Lock(ASource); threadSync2.Lock(ADest); GMVsdReadValueNames(ASource, ValueNames); for i:=Low(ValueNames) to High(ValueNames) do GMStoreString(ADest, ValueNames[i], ASource.ReadString(ValueNames[i], cDfltString), cDfltString); end; procedure GMVsdCopyStorageContents(const ASource, ADest: IUnknown; AStartDirPath: TGMString); var threadSync1, threadSync2: RGMCriticalSectionLock; mousePtrWait: IUnknown; srcValues, dstValues: IGMStringStorage; procedure CopyDirContents(const Dir: TGMString); var i: LongInt; SubDirNames: TGMStringArray; SrcDirKeeper, DstDirKeeper: IUnknown; begin SrcDirKeeper := TGMVsdDirPathKeeper.Create(ASource); if not GMVsdOpenDir(ASource, Dir, False) then Exit; DstDirKeeper := TGMVsdDirPathKeeper.Create(ADest, '\' + GMVsdCurrentPath(ASource), True); GMVsdCopyDirValues(srcValues, dstValues); GMVsdReadSubDirNames(ASource, SubDirNames); for i:=Low(SubDirNames) to High(SubDirNames) do CopyDirContents(SubDirNames[i]); end; begin if (ASource = nil) or (ADest = nil) then Exit; threadSync1.Lock(ASource); threadSync2.Lock(ADest); GMCheckQueryInterface(ASource, IGMStringStorage, srcValues, {$I %CurrentRoutine%}); GMCheckQueryInterface(ADest, IGMStringStorage, dstValues, {$I %CurrentRoutine%}); if AStartDirPath = '' then AStartDirPath := '\' + GMVsdCurrentPath(ASource); mousePtrWait := TGMTempCursor.Create(vGMWaitCursor); CopyDirContents(AStartDirPath); end; { ---------------------------- } { ---- ILockByte Routines ---- } { ---------------------------- } function GMLockByteSize(const LockBytes: ILockBytes): Int64; var Stat: TStatStg; begin if LockBytes = nil then Result := 0 else begin GMHrCheckIntf(LockBytes.Stat(Stat, STATFLAG_NONAME), LockBytes, {$I %CurrentRoutine%}); //if Stat.pwcsName <> nil then CoTaskMemFree(Stat.pwcsName); Result := Stat.cbSize; end; end; procedure GMCopyLockBytes(const ASource, ADest: ILockBytes; const AMaxBytesToCopy: LongInt = 0; const AVerfy: Boolean = True); const CCopyBufSize = $20000; var pBuffer: Pointer; bufSize, readCount, WriteCount, n, sourceSize, sourcePos, destPos: LongInt; begin if (ASource <> nil) and (ADest <> nil) then begin sourceSize := GMLockByteSize(ASource); if AMaxBytesToCopy > 0 then sourceSize := Min(sourceSize, AMaxBytesToCopy); GMHrCheckIntf(ADest.SetSize(sourceSize), ADest, {$I %CurrentRoutine%}); if sourceSize > 0 then begin sourcePos := 0; destPos := 0; bufSize := Min(CCopyBufSize, sourceSize); GetMem(pBuffer, bufSize); try while sourcePos < sourceSize do begin n := Max(0, Min(bufSize, sourceSize - sourcePos)); GMHrCheckIntf(ASource.ReadAt(sourcePos, pBuffer, n, @readCount), ASource, {$I %CurrentRoutine%}); if AVerfy and (readCount <> n) then raise EGMException.IntfError(GMFormat(RStrReadErrorFmt, [bufSize, readCount]), ASource, {$I %CurrentRoutine%}); Inc(sourcePos, readCount); GMHrCheckIntf(ADest.WriteAt(destPos, pBuffer, readCount, @WriteCount), ADest, {$I %CurrentRoutine%}); if AVerfy and (WriteCount <> readCount) then raise EGMException.IntfError(GMFormat(RStrWriteErrorFmt, [readCount, WriteCount]), ADest, {$I %CurrentRoutine%}); Inc(destPos, WriteCount); end; finally FreeMem(pBuffer); end; end; end; end; procedure GMLockByteSafeReadAt(const ASource: ILockBytes; const AOffset: Int64; const APData: Pointer; const ACount: LongInt; const ACallingName: TGMString); var n: LongInt; begin if (ASource = nil) or (ACount <= 0) then Exit; GMHrCheckIntf(ASource.ReadAt(AOffset, APData, ACount, @n), ASource, ACallingName); if n <> ACount then raise EGMException.IntfError(GMFormat(RStrReadErrorFmt, [ACount, n]), ASource, ACallingName); end; procedure GMLockByteSafeWriteAt(const ADest: ILockBytes; const AOffset: Int64; const APData: Pointer; const ACount: LongInt; const ACallingName: TGMString); var n: LongInt; begin if (ADest = nil) or (ACount <= 0) then Exit; GMHrCheckIntf(ADest.WriteAt(AOffset, APData, ACount, @n), ADest, ACallingName); if n <> ACount then raise EGMException.IntfError(GMFormat(RStrWriteErrorFmt, [ACount, n]), ADest, ACallingName); end; { --------------------------- } { ---- Progress Routines ---- } { --------------------------- } procedure GMSetProgressAndCheckCanceled(const AProgresssable: IUnknown; const AProgress: Int64; var ACancel: BOOL; const ACalcProgressKind: TGMCalcProgressKind); var OnProgress: IGMOnProgress; begin if GMQueryInterface(AProgresssable, IGMOnProgress, OnProgress) then begin OnProgress.OnProgress(AProgress, ACancel, ACalcProgressKind); if ACancel then raise EGMAbort.Create(RStrOperationCanceled); end; end; procedure GMSetProgressMax(const AProgresssable: IUnknown; const AProgressMax: Int64); var ProgressMax: IGMSetProgressMax; begin if GMQueryInterface(AProgresssable, IGMSetProgressMax, ProgressMax) then ProgressMax.SetProgressMax(AProgressMax); end; procedure GMSetProgressDescription(const AProgresssable: IUnknown; const AProgressDescription: TGMString; const ATextColor: COLORREF); var ProgressDescription: IGMSetProgressDescription; begin if GMQueryInterface(AProgresssable, IGMSetProgressDescription, ProgressDescription) then ProgressDescription.SetProgressDescription(AProgressDescription, ATextColor); end; { -------------------------- } { ---- Istream Routines ---- } { -------------------------- } function GMIStreamSize(const AStream: IUnknown): Int64; var Stat: TStatStg; strm: IStream; begin if not GMQueryInterface(AStream, IStream, strm) then Result := 0 else begin FillByte(Stat, SizeOf(Stat), 0); GMHrCheckIntf(strm.Stat(Stat, STATFLAG_NONAME), strm, 'GMIStreamSize'); if Stat.pwcsName <> nil then CoTaskMemFree(Stat.pwcsName); Result := Stat.cbSize; end; end; function GMIStreamPos(const AStream: IUnknown): Int64; var strm: IStream; begin if not GMQueryInterface(AStream, IStream, strm) then Result := 0 else GMHrCheckIntf(strm.Seek(0, STREAM_SEEK_CUR, @Result), strm, 'GMIStreamPos'); end; function GMSetIStreamAbsPos(const AStream: IUnknown; const ANewPos: Int64; const ACallingName: TGMString): Int64; var strm: IStream; begin if not GMQueryInterface(AStream, IStream, strm) then Result := 0 else GMHrCheckIntf(strm.Seek(ANewPos, STREAM_SEEK_SET, @Result), strm, ACallingName); end; function GMIStreamRead(const ASource: ISequentialStream; const Data: Pointer; const DataSizeInBytes: LongWord): Cardinal; begin if (ASource = nil) or (DataSizeInBytes = 0) then Result := 0 else ASource.Read(Data, DataSizeInBytes, Pointer(@Result)); end; procedure GMSafeIStreamRead(const ASource: ISequentialStream; const AData: Pointer; const ADataSizeInBytes: LongWord; const ACallingName: TGMString); var N: LongWord; //RtnName: TGMString; begin if (ASource <> nil) and (ADataSizeInBytes > 0) then begin //if ACallingName <> cDfltRoutineName then RtnName := ACallingName else RtnName := {$I %CurrentRoutine%}; N := 0; GMHrCheckIntf(ASource.Read(AData, ADataSizeInBytes, Pointer(@N)), ASource, ACallingName); // , RStrStreamRead + ': ' if N <> ADataSizeInBytes then raise EGMException.IntfError(GMStringJoin(ACallingName, ': ', GMFormat(RStrReadErrorFmt, [ADataSizeInBytes, N])), ASource, ACallingName); end; end; procedure GMSafeIStreamWrite(const ADest: ISequentialStream; const AData: Pointer; const ADataSizeInBytes: LongWord; const ACallingName: TGMString); var dwWritten: LongWord; //RtnName: TGMString; begin if (ADest <> nil) and (ADataSizeInBytes > 0) then begin //if ACallingName <> cDfltRoutineName then RtnName := ACallingName else RtnName := {$I %CurrentRoutine%}; dwWritten := 0; GMHrCheckIntf(ADest.Write(AData, ADataSizeInBytes, Pointer(@dwWritten)), ADest, ACallingName); // , RStrStreamWrite + ':' if dwWritten <> ADataSizeInBytes then raise EGMException.IntfError(GMFormat(RStrWriteErrorFmt, [ADataSizeInBytes, dwWritten]), ADest, ACallingName); end; end; function GMIStreamReadResult(const pcbOut: Pointer; const AllDone: Boolean): HResult; const CResult: array [Boolean, Boolean] of HResult = ((S_FALSE, S_OK), (GM_E_STREAMREAD, S_OK)); begin Result := CResult[pcbOut = nil, AllDone]; end; function GMIStreamWriteResult(const pcbOut: Pointer; const AllDone: Boolean): HResult; const CResult: array [Boolean, Boolean] of HResult = ((S_FALSE, S_OK), (GM_E_STREAMWRITE, S_OK)); begin Result := CResult[pcbOut = nil, AllDone]; end; procedure GMCopyIStreamTime(const ASourceStrm, ADestStrm: ISequentialStream; const AOnProgressProc: TGMOnProgressProc; const ACallBackTimeInMS: LongWord; const ACallingName: TGMString); const cBufAlignSize = $1000;{4KB} cBufSizeMin = 1024; cBufSizeMax = $40000;{256KB} cBufSizeStart = 4096; cOneMilliSecond = 1 / (24 * 60 * 60 * 1000); var n, bufferSize, newBufSize: LongWord; total: Int64; t1, t2, cbTime: TDateTime; buffer: RawByteString; canceled: BOOL;// PBuffer: Pointer; t1, t2: LongWord; begin // // Adjust buffer size during copy so that OnProgress will be called every ACallBackTimeInMS // // Because Tickcount will wrap every 72 days better use a TDateTime values instead of TickCount here! // canceled := False; //PBuffer := nil; if (ASourceStrm = nil) or (ADestStrm = nil) or (ACallBackTimeInMS <= 0) then Exit; //try cbTime := ACallBackTimeInMS * cOneMilliSecond; bufferSize := 0; newBufSize := cBufSizeStart; total := 0; repeat if GMAlignedValue(bufferSize, cBufAlignSize) <> GMAlignedValue(newBufSize, cBufAlignSize) then SetLength(buffer, GMAlignedValue(newBufSize, cBufAlignSize)); //ReAllocMem(PBuffer, GMAlignedValue(newBufSize, cBufAlignSize)); {$IFDEF DEBUG} //GMTrace('Stream Copy bufferSize: '+GMIntToStr(newBufSize)); // <- for testing {$ENDIF} bufferSize := newBufSize; t1 := now; // t1 := GetTickCount; n := 0; GMHrCheckIntf(ASourceStrm.Read(PAnsiChar(buffer), bufferSize, Pointer(@n)), ASourceStrm, ACallingName); // , RStrStreamRead + ': ' GMSafeIStreamWrite(ADestStrm, PAnsiChar(buffer), n, ACallingName); //Sleep(170); <- Test t2 := Now; // t2 := GetTickCount; //if Progress <> nil then begin Inc(total, n); Progress.OnProgress(total, Result); end; if Assigned(AOnProgressProc) then begin Inc(total, n); AOnProgressProc(total, canceled); end; //if t1 = t2 then newBufSize := cBufSizeMax else newBufSize := GMBoundedInt(Round(n * ACallBackTimeInMS / (t2 - t1)), 1, cBufSizeMax); if t1 = t2 then newBufSize := cBufSizeMax else newBufSize := GMBoundedInt(Round(n * (cbTime / (t2 - t1))), cBufSizeMin, cBufSizeMax); // Sleep(600); until (n < bufferSize) or canceled; if canceled then raise EGMAbort.Create(RStrOperationCanceled); // Result := not Result; //finally //FreeMem(PBuffer); //end; end; procedure GMCopyIStreamBufSize(const ASourceStrm, ADestStrm: ISequentialStream; const ACopyBufferSize: LongWord; const AOnProgressProc: TGMOnProgressProc; const ACallingName: TGMString); var n: LongWord; total: Int64; buffer: RawByteString; canceled: BOOL; //PIBuffer: IGMMemoryBuffer; begin canceled := False; total := 0; if (ASourceStrm = nil) or (ADestStrm = nil) or (ACopyBufferSize = 0) then Exit; //PIBuffer := TGMMemoryBuffer.Create(nil, ACopyBufferSize); SetLength(buffer, ACopyBufferSize); repeat n := 0; // PIBuffer.Memory GMHrCheckIntf(ASourceStrm.Read(PAnsiChar(buffer), ACopyBufferSize, Pointer(@n)), ASourceStrm, ACallingName); // , RStrStreamRead + ': ' if n > 0 then GMSafeIStreamWrite(ADestStrm, PAnsiChar(buffer), n, ACallingName); //if Progress <> nil then begin Inc(total, n); Progress.OnProgress(total, Result); end; if Assigned(AOnProgressProc) then begin Inc(total, n); AOnProgressProc(total, canceled); end; until (n < ACopyBufferSize) or canceled; if canceled then raise EGMAbort.Create(RStrOperationCanceled); //Result := not Result; end; procedure GMCopyIStream(const ASourceStrm, ADestStrm: ISequentialStream; const ACopyBufferSize: LongInt; const AOnProgressProc: TGMOnProgressProc; const ACallingName: TGMString); begin if ACopyBufferSize = 0 then Exit; // begin Result := False; Exit; end; if ACopyBufferSize < 0 then //Result := GMCopyIStreamTime(ASourceStrm, ADestStrm, AOnProgressProc, -ACopyBufferSize, ACallingName) else //Result := GMCopyIStreamBufSize(ASourceStrm, ADestStrm, ACopyBufferSize, AOnProgressProc, ACallingName); end; function GMIStreamContentAsString(const ASourceStrm: ISequentialStream; StartPos: Int64; const ACallingName: TGMString): AnsiString; var PosKeeper: IUnknown; seekStrm, strStream: IStream; begin Result := ''; if ASourceStrm = nil then Exit; if GMQueryInterface(ASourceStrm, IStream, seekStrm) then begin if StartPos < 0 then GMHrCheckObj(seekStrm.Seek(0, STREAM_SEEK_CUR, @StartPos), nil, ACallingName); PosKeeper := TGMIStreamPosKeeper.Create(seekStrm, StartPos); end; strStream := TGMAnsiStringIStream.Create(''); GMCopyIStream(ASourceStrm, strStream); Result := GMGetIntfText(strStream); //SetLength(Result, GMIStreamSize(ASourceStrm) - StartPos); //if Length(Result) > 0 then GMSafeIStreamRead(ASourceStrm, PGMChar(Result), Length(Result), ACallingName); end; { ----------------------------- } { ---- Activatable Objects ---- } { ----------------------------- } function GMObjIsActive(const AObj: TObject; const ADefaultValue: Boolean = False): Boolean; var PIActive: IGMGetActive; begin if (AObj <> nil) and AObj.GetInterface(IGMGetActive, PIActive) then Result := PIActive.Active else Result := ADefaultValue; //Result := (AObj <> nil) and AObj.GetInterface(IGMGetActive, PIActive) and PIActive.Active; end; function GMIntfIsActive(const AIntf: IUnknown; const ADefaultValue: Boolean = False): Boolean; var PIActive: IGMGetActive; begin if GMQueryInterface(AIntf, IGMGetActive, PIActive) then Result := PIActive.Active else Result := ADefaultValue; //Result := (AIntf <> nil) and (AIntf.QueryInterface(IGMGetActive, PIActive) = S_OK) and PIActive.Active; end; procedure GMCheckObjIsActive(const AObj: TObject; const ACallingName: TGMString); var PIActive: IGMGetActive; //RtnName: TGMString; begin //if ACallingName then RtnName := {$I %CurrentRoutine%} else RtnName := ACallingName; GMCheckGetInterface(AObj, IGMGetActive, PIActive, {$I %CurrentRoutine%}); if not PIActive.Active then raise EGMException.ObjError(GMFormat(RStrCheckActive, [ACallingName]), AObj, {$I %CurrentRoutine%}); end; procedure GMCheckIntfIsActive(const AIntf: IUnknown; const ACallingName: TGMString); var PIActive: IGMGetActive; //RtnName: TGMString; begin //if ACallingName then RtnName := {$I %CurrentRoutine%} else RtnName := ACallingName; GMCheckQueryInterface(AIntf, IGMGetActive, PIActive, {$I %CurrentRoutine%}); if not PIActive.Active then raise EGMException.IntfError(GMFormat(RStrCheckActive, [ACallingName]), AIntf, {$I %CurrentRoutine%}); end; procedure GMCheckObjIsInActive(const AObj: TObject; const NeedInActiveName: TGMString); var PIActive: IGMGetActive; begin GMCheckGetInterface(AObj, IGMGetActive, PIActive, {$I %CurrentRoutine%}); if PIActive.Active then raise EGMException.ObjError(GMFormat(RStrCheckInactive, [NeedInActiveName]), AObj, {$I %CurrentRoutine%}); end; procedure GMCheckIntfIsInActive(const AIntf: IUnknown; const NeedInActiveName: TGMString); var PIActive: IGMGetActive; begin GMCheckQueryInterface(AIntf, IGMGetActive, PIActive, {$I %CurrentRoutine%}); if PIActive.Active then raise EGMException.IntfError(GMFormat(RStrCheckInactive, [NeedInActiveName]), AIntf, {$I %CurrentRoutine%}); end; function GMSetObjActive(const AObj: TObject; const Active: Boolean; const ACallingName: TGMString): Boolean; //var PIActive: IGMGetSetActive; begin //if (AObj <> nil) and AObj.GetInterface(IGMGetSetActive, PIActive) then PIActive.Active := Active; Result := GMSetIntfActive(GMObjAsIntf(AObj), Active, ACallingName); end; function GMSetIntfActive(const AIntf: IUnknown; const Active: Boolean; const ACallingName: TGMString): Boolean; var PIActive: IGMGetSetActive; begin if AIntf = nil then Result := False else begin GMCheckQueryInterface(AIntf, IGMGetSetActive, PIActive, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); Result := PIActive.Active; PIActive.Active := Active; end; end; { -------------------------- } { ---- Interface Source ---- } { -------------------------- } function GMGetInterfaceSource(const AContainer: IUnknown): IUnknown; var getIntfSrc: IGMGetInterfaceSource; begin if GMQueryInterface(AContainer, IGMGetInterfaceSource, getIntfSrc) then Result := getIntfSrc.InterfaceSource else Result := nil; end; procedure GMSetInterfaceSource(const AContainer, AIntfSource: IUnknown); var setIntfSrc: IGMGetSetInterfaceSource; begin if GMQueryInterface(AContainer, IGMGetSetInterfaceSource, setIntfSrc) then setIntfSrc.InterfaceSource := AIntfSource; end; { ---------------------- } { ---- Field Values ---- } { ---------------------- } function GMGetItemValue(const AContainer: IUnknown; const AItemName: TGMString): RGMUnionValue; var fieldByName: IGMGetIntfByName; getVal: IGMGetUnionValue; begin if (AItemName <> '') and GMQueryInterface(AContainer, IGMGetIntfByName, fieldByName) and (fieldByName.GetIntfByName(AItemName, IGMGetUnionValue, getVal) = S_OK) then Result := getVal.Value else Result := uvtNull; end; function GMGetItemValue(const AContainer: IUnknown; const AItemPosition: LongInt): RGMUnionValue; var fieldByPos: IGMGetIntfByPosition; getVal: IGMGetUnionValue; begin if GMQueryInterface(AContainer, IGMGetIntfByPosition, fieldByPos) and (fieldByPos.GetIntfByPosition(AItemPosition, IGMGetUnionValue, getVal) = S_OK) then Result := getVal.Value else Result := uvtNull; end; function GMCheckGetItemValue(const AContainer: IUnknown; const ItemName: TGMString; const ACallingName: TGMString = cDfltRoutineName): RGMUnionValue; overload; var fieldByName: IGMGetIntfByName; getVal: IGMGetUnionValue; begin GMCheckQueryInterface(AContainer, IGMGetIntfByName, fieldByName, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); GMHrCheckIntf(fieldByName.GetIntfByName(ItemName, IGMGetUnionValue, getVal), AContainer, BuildCallingName(ACallingName, {$I %CurrentRoutine%}), MsgNoItemIntfPrefix(ItemName, IGMGetUnionValue)); Result := getVal.Value; end; function GMCheckGetItemValue(const AContainer: IUnknown; const ItemPosition: LongInt; const ACallingName: TGMString = cDfltRoutineName): RGMUnionValue; overload; var fieldByPos: IGMGetIntfByPosition; getVal: IGMGetUnionValue; begin GMCheckQueryInterface(AContainer, IGMGetIntfByPosition, fieldByPos, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); GMHrCheckIntf(fieldByPos.GetIntfByPosition(ItemPosition, IGMGetUnionValue, getVal), AContainer, BuildCallingName(ACallingName, {$I %CurrentRoutine%}), MsgNoItemIntfPrefix(GMIntToStr(ItemPosition), IGMGetUnionValue)); Result := getVal.Value; end; procedure GMSetItemValue(const AContainer: IUnknown; const AItemName: TGMString; const AValue: RGMUnionValue); var PIFieldByName: IGMGetIntfByName; getVal: IGMGetSetUnionValue; begin if (AItemName <> '') and GMQueryInterface(AContainer, IGMGetIntfByName, PIFieldByName) and (PIFieldByName.GetIntfByName(AItemName, IGMGetSetUnionValue, getVal) = S_OK) then getVal.Value := AValue; end; procedure GMCheckSetItemValue(const AContainer: IUnknown; const ItemName: TGMString; const AValue: RGMUnionValue; const ACallingName: TGMString = cDfltRoutineName); var PIFieldByName: IGMGetIntfByName; setVal: IGMGetSetUnionValue; begin GMCheckQueryInterface(AContainer, IGMGetIntfByName, PIFieldByName, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); GMHrCheckIntf(PIFieldByName.GetIntfByName(ItemName, IGMGetSetUnionValue, setVal), AContainer, BuildCallingName(ACallingName, {$I %CurrentRoutine%}), MsgNoItemIntfPrefix(ItemName, IGMGetSetUnionValue)); setVal.Value := AValue; end; function GMGetFieldValueImpl(const AContainer: IUnknown; const AIndex: RGMUnionValue): RGMUnionValue; var intfByPos: IGMGetIntfByPosition; intfByName: IGMGetIntfByName; val: IGMGetUnionValue; fieldPos: LongInt; fieldName: TGMString; hr: HResult; begin GMCheckIntfIsActive(AContainer, 'FieldValue ' + RStrProperty); case AIndex.ValueType of uvtInt16, uvtInt32, uvtInt64, uvtDouble: begin GMCheckQueryInterface(AContainer, IGMGetIntfByPosition, intfByPos, {$I %CurrentRoutine%}); fieldPos := AIndex; hr := intfByPos.GetIntfByPosition(fieldPos, IGMGetUnionValue, val); if not GMHrSucceeded(hr) then GMHrCheckIntf(hr, AContainer, {$I %CurrentRoutine%}, MsgNoItemIntfPrefix(GMIntToStr(fieldPos), IGMGetUnionValue)); end; uvtString: begin GMCheckQueryInterface(AContainer, IGMGetIntfByName, intfByName, {$I %CurrentRoutine%}); fieldName := AIndex; hr := intfByName.GetIntfByName(fieldName, IGMGetUnionValue, val); if not GMHrSucceeded(hr) then begin if hr = GMHResultFromWin32(ERROR_FILE_NOT_FOUND) then raise EGMException.IntfError(GMFormat(RStrFieldNotFound, [fieldName, GMGetIntfName(AContainer)]), AContainer, {$I %CurrentRoutine%}) else GMHrCheckIntf(hr, AContainer, {$I %CurrentRoutine%}, MsgNoItemIntfPrefix(GMStringJoin(GMGetIntfName(AContainer), '.', fieldName), IGMGetUnionValue)); end; end; else raise EGMException.IntfError(GMFormat(RStrUnsupportedIdxType, [AIndex.ValueTypeName]), AContainer, {$I %CurrentRoutine%}); end; if val <> nil then Result := val.Value else Result := uvtNull; end; procedure GMSetFieldValueImpl(const AContainer: IUnknown; const AIndex: RGMUnionValue; const AValue: RGMUnionValue); var intfByPos: IGMGetIntfByPosition; intfByName: IGMGetIntfByName; val: IGMGetSetUnionValue; fieldPos: LongInt; fieldName: TGMString; hr: HResult; begin GMCheckIntfIsActive(AContainer, 'FieldValue ' + RStrProperty); case AIndex.ValueType of uvtInt16, uvtInt32, uvtInt64, uvtDouble: begin GMCheckQueryInterface(AContainer, IGMGetIntfByPosition, intfByPos, {$I %CurrentRoutine%}); fieldPos := AIndex; hr := intfByPos.GetIntfByPosition(fieldPos, IGMGetSetUnionValue, val); if not GMHrSucceeded(hr) then GMHrCheckIntf(hr, AContainer, {$I %CurrentRoutine%}, MsgNoItemIntfPrefix(GMIntToStr(fieldPos), IGMGetSetUnionValue)); end; uvtString: begin GMCheckQueryInterface(AContainer, IGMGetIntfByName, intfByName, {$I %CurrentRoutine%}); fieldName := AIndex; hr := intfByName.GetIntfByName(fieldName, IGMGetSetUnionValue, val); if not GMHrSucceeded(hr) then begin if hr = GMHResultFromWin32(ERROR_FILE_NOT_FOUND) then raise EGMException.IntfError(GMFormat(RStrFieldNotFound, [fieldName, GMGetIntfName(AContainer)]), AContainer, {$I %CurrentRoutine%}) else GMHrCheckIntf(hr, AContainer, {$I %CurrentRoutine%}, MsgNoItemIntfPrefix(GMStringJoin(GMGetIntfName(AContainer), '.', fieldName), IGMGetSetUnionValue)); end; end; else raise EGMException.IntfError(GMFormat(RStrUnsupportedIdxType, [AIndex.ValueTypeName]), AContainer, {$I %CurrentRoutine%}); end; if val <> nil then val.Value := AValue; end; { --------------------- } { ---- DisplayText ---- } { --------------------- } function GMFieldDisplayText(const FieldName: TGMString; const PIFieldByName: IGMGetIntfByName): TGMString; var PIText: IGMGetText; begin if (FieldName <> '') and (PIFieldByName <> nil) and (PIFieldByName.GetIntfByName(FieldName, IGMGetText, PIText) = S_OK) then Result := PIText.Text else Result := ''; end; { ------------------------------ } { ---- Executing Operations ---- } { ------------------------------ } function GMCanExecOperation(const AIntf: IUnknown; const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; var PICanExecOp: IGMCanExecuteOperation; begin if AIntf = nil then Result := False else if GMQueryInterface(AIntf, IGMCanExecuteOperation, PICanExecOp) then Result := PICanExecOp.CanExecuteOperation(Ord(Operation)) else Result := True; end; procedure GMCheckExecOperation(const AObj: TObject; const Operation: LongInt; const OperationName: TGMString; const ACallingName: TGMString; const Parameter: IUnknown); begin GMCheckExecOperation(GMObjAsIntf(AObj), Operation, OperationName, ACallingName, Parameter); end; procedure GMCheckExecOperation(const AIntf: IUnknown; const Operation: LongInt; const OperationName: TGMString; const ACallingName: TGMString; const Parameter: IUnknown); var PIExecOp: IGMExecuteOperation; OpName: TGMString; begin if not GMCanExecOperation(AIntf, Operation, Parameter) then Exit; GMCheckQueryInterface(AIntf, IGMExecuteOperation, PIExecOp, ACallingName); if not PIExecOp.ExecuteOperation(Operation, Parameter) then begin if OperationName = '' then OpName := GMFormat('(%d)', [Operation]) else OpName := GMFormat('(%d) "%s"', [Operation, OperationName]); raise EGMException.IntfError(GMFormat(RStrOperationExecFailed, [OpName]), AIntf, ACallingName); end; end; function GMExecuteOperation(const AObj: TObject; const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; begin Result := GMExecuteOperation(GMObjAsIntf(AObj), Operation, Parameter) end; function GMExecuteOperation(const AIntf: IUnknown; const Operation: LongInt; const Parameter: IUnknown = nil): Boolean; var PIExecOp: IGMExecuteOperation; begin Result := GMCanExecOperation(AIntf, Operation, Parameter); if Result and GMQueryInterface(AIntf, IGMExecuteOperation, PIExecOp) then Result := PIExecOp.ExecuteOperation(Ord(Operation), Parameter); end; { ---------------------------------- } { ---- Asking Boolean Questions ---- } { ---------------------------------- } function GMBooleanAskResult(const Value: Boolean): LongInt; const cResultValues: array [Boolean] of LongInt = (Ord(barFalse), Ord(barTrue)); begin Result := cResultValues[Value]; end; function GMAskBoolean(const AObj: TObject; const ValueId: LongInt; const DefaultResult: Boolean): Boolean; begin Result := GMAskBoolean(GMObjAsIntf(AObj), ValueId, DefaultResult) end; function GMAskBoolean(const AIntf: IUnknown; const ValueId: LongInt; const DefaultResult: Boolean): Boolean; var PIAskBoolean: IGMAskBoolean; begin if not GMQueryInterface(AIntf, IGMAskBoolean, PIAskBoolean) then Result := DefaultResult else case PIAskBoolean.AskBoolean(ValueId) of Ord(barTrue): Result := True; Ord(barFalse): Result := False; else Result := DefaultResult; end; end; function GMAskUnkBoolean(const AIntf: IUnknown; const AValueId: LongInt): TGMBoolAskResult; var PIAskBoolean: IGMAskBoolean; begin if not GMQueryInterface(AIntf, IGMAskBoolean, PIAskBoolean) then Result := barUnknown else Result := TGMBoolAskResult(GMBoundedInt(PIAskBoolean.AskBoolean(AValueId), Ord(Low(TGMBoolAskResult)), Ord(High(TGMBoolAskResult)))); end; function GMCheckAskBoolean(const AObj: TObject; const ValueId: LongInt; const ACallingName: TGMString): Boolean; begin Result := GMCheckAskBoolean(GMObjAsIntf(AObj), ValueId, ACallingName); end; function GMCheckAskBoolean(const AIntf: IUnknown; const ValueId: LongInt; const ACallingName: TGMString): Boolean; var PIAskBoolean: IGMAskBoolean; Answer: LongInt; begin GMCheckQueryInterface(AIntf, IGMAskBoolean, PIAskBoolean, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); Answer := PIAskBoolean.AskBoolean(ValueId); case Answer of Ord(barTrue): Result := True; Ord(barFalse): Result := False; else raise EGMException.IntfError(GMFormat(RStrUnsupoortedBoolQuestion, [ValueId]), AIntf, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; end; { ----------------------------- } { ---- Asking for Integers ---- } { ----------------------------- } function GMAskInteger(const AObj: TObject; const ValueId: LongInt; const ADefaultValue: LongInt): LongInt; overload; //var PIUnk: IUnknown; begin // if (AObj <> nil) and (AObj.GetInterface(IUnknown, PIUnk)) then // Result := GMAskInteger(PIUnk, ValueId, ADefaultValue) // else // Result := ADefaultValue; Result := GMAskInteger(GMObjAsIntf(AObj), ValueId, ADefaultValue); end; function GMAskInteger(const AIntf: IUnknown; const ValueId: LongInt; const ADefaultValue: LongInt): LongInt; overload; var PIAskInteger: IGMAskInteger; begin if not GMQueryInterface(AIntf, IGMAskInteger, PIAskInteger) then Result := ADefaultValue else begin Result := PIAskInteger.AskInteger(ValueId); if Result = cInvalidIntValue then Result := ADefaultValue; end; end; function GMCheckAskInteger(const AObj: TObject; const ValueId: LongInt; const ACallingName: TGMString): LongInt; begin Result := GMCheckAskInteger(GMObjAsIntf(AObj), ValueId, ACallingName); end; function GMCheckAskInteger(const AIntf: IUnknown; const ValueId: LongInt; const ACallingName: TGMString): LongInt; var PIAskInteger: IGMAskInteger; begin GMcheckQueryInterface(AIntf, IGMAskInteger, PIAskInteger, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); Result := PIAskInteger.AskInteger(ValueId); if Result = CInvalidIntValue then raise EGMException.IntfError(GMFormat(RStrUnsupportedValueId, [ValueId]), AIntf, BuildCallingName(ACallingName, {$I %CurrentRoutine%})); end; { ------------------------- } { ---- Position Helper ---- } { ------------------------- } function GMGetIntfPosition(const AIntf: IUnknown; const DefaultPos: LongInt): LongInt; var PIPosition: IGMGetPosition; begin if GMQueryInterface(AIntf, IGMGetPosition, PIPosition) then Result := PIPosition.Position else Result := DefaultPos; end; procedure GMSetIntfPosition(const AIntf: IUnknown; const Position: LongInt); var PIPosition: IGMGetSetPosition; begin if {and GMAskBoolean(AIntf, Ord(bvCanSetPosition), True)} GMQueryInterface(AIntf, IGMGetSetPosition, PIPosition) then PIPosition.Position := Position; end; procedure GMMovePosition(const AIntf: IUnknown; const Delta: LongInt); var PIPosition: IGMGetSetPosition; begin if {and GMAskBoolean(AIntf, Ord(bvCanSetPosition), True)} GMQueryInterface(AIntf, IGMGetSetPosition, PIPosition) then PIPosition.Position := PIPosition.Position + Delta; end; { ----------------------- } { ---- Empty Objects ---- } { ----------------------- } function GMObjIsEmpty(const AObj: TObject; const DefaultResult: Boolean): Boolean; begin Result := GMIntfIsEmpty(GMObjAsIntf(AObj), DefaultResult); end; function GMIntfIsEmpty(const AIntf: IUnknown; const DefaultResult: Boolean): Boolean; var PICount: IGMGetCount; begin if GMQueryInterface(AIntf, IGMGetCount, PICount) then Result := PICount.Count <= 0 else Result := DefaultResult; end; { ---------------------------- } { ---- Cursor Move Helper ---- } { ---------------------------- } function GMIsValidCursorMove(const AIntf: IUnknown; const Move: TGMCursorMove): Boolean; var PIUniCur: IGMUnidirectionalCursor; begin if AIntf = nil then Result := False else Case Move of cmFirst: Result := GMQueryInterface(AIntf, IGMCursorFirstLast, PIUniCur) and not PIUniCur.BOF and not GMIntfIsEmpty(PIUniCur) and GMAskBoolean(AIntf, Ord(bvCanSetPosition), True); cmPrior: Result := GMQueryInterface(AIntf, IGMBidirectionalCursor, PIUniCur) and not PIUniCur.BOF and not GMIntfIsEmpty(PIUniCur) and GMAskBoolean(AIntf, Ord(bvCanSetPosition), True); cmNext: Result := GMQueryInterface(AIntf, IGMUnidirectionalCursor, PIUniCur) and not PIUniCur.EOF and not GMIntfIsEmpty(PIUniCur) and GMIntfIsActive(AIntf); cmLast: Result := GMQueryInterface(AIntf, IGMCursorFirstLast, PIUniCur) and not PIUniCur.EOF and not GMIntfIsEmpty(PIUniCur) and GMAskBoolean(AIntf, Ord(bvCanSetPosition), True); else Result := False; end; end; procedure GMMoveCursor(const AIntf: IUnknown; const Move: TGMCursorMove); var PIUniCur: IGMUnidirectionalCursor; PIBiCur: IGMBidirectionalCursor; PIFreeCur: IGMCursorFirstLast; begin if AIntf <> nil then case Move of cmFirst: if GMQueryInterface(AIntf, IGMCursorFirstLast, PIFreeCur) and not PIFreeCur.BOF then PIFreeCur.MoveToFirst; cmPrior: if GMQueryInterface(AIntf, IGMBidirectionalCursor, PIBiCur) and not PIBiCur.BOF then PIBiCur.MoveToPrevious; cmNext: if GMQueryInterface(AIntf, IGMUnidirectionalCursor, PIUniCur) and not PIUniCur.EOF then PIUniCur.MoveToNext; cmLast: if GMQueryInterface(AIntf, IGMCursorFirstLast, PIFreeCur) and not PIFreeCur.EOF then PIFreeCur.MoveToLast; end; end; procedure GMSafeCursorMove(const AIntf: IUnknown; const Move: TGMCursorMove); begin if GMIsValidCursorMove(AIntf, Move) then GMMoveCursor(AIntf, Move); end; { ---------------------- } { ---- RGMTypedIntf ---- } { ---------------------- } //class operator RGMTypedIntf<TIntf>.Implicit(const ATypedIntf: RGMTypedIntf<TIntf>): Pointer; //begin // Result := Pointer(ATypedIntf.Intf); //end; //class operator RGMTypedIntf<TIntf>.Implicit(const ATypedIntf: RGMTypedIntf<TIntf>): TIntf; //begin // Result := ATypedIntf.Intf; //end; //class operator RGMTypedIntf<TIntf>.Implicit(AValue: Pointer): RGMTypedIntf<TIntf>; //begin // //end; //class operator RGMTypedIntf<TIntf>.Implicit(AValue: IUnknown): RGMTypedIntf<TIntf>; //begin // if AValue = nil then Result.Intf := nil else // GMCheckQueryInterface(AValue, TIntf, Result.Intf, 'RGMTypedIntf<TIntf>.Implicit'); //end; class operator RGMTypedIntf<TIntf>.:=(const ATypedIntf: RGMTypedIntf<TIntf>): TIntf; begin Result := ATypedIntf.Intf; end; class operator RGMTypedIntf<TIntf>.:=(AValue: IUnknown): RGMTypedIntf<TIntf>; begin if AValue = nil then Result.Intf := nil else GMCheckQueryInterface(AValue, TIntf, Result.Intf, 'RGMTypedIntf<'+GMGuidToString(TIntf)+'>.Assign'); end; class operator RGMTypedIntf<TIntf>.:=(AObj: TObject): RGMTypedIntf<TIntf>; begin if AObj = nil then Result.Intf := nil else GMCheckGetInterface(AObj, TIntf, Result.Intf, 'RGMTypedIntf<'+GMGuidToString(TIntf)+'>.Assign'); end; function RGMTypedIntf<TIntf>.QueryFrom(AIntf: IUnknown; ACheckResult: Boolean): Boolean; begin if ACheckResult then begin GMCheckQueryInterface(AIntf, TIntf, Intf, {$I %CurrentRoutine%}); Result := True; end else Result := GMQueryInterface(AIntf, TIntf, Intf); end; function RGMTypedIntf<TIntf>.GetFrom(AObj: TObject; ACheckResult: Boolean): Boolean; begin if ACheckResult then begin GMCheckGetInterface(AObj, TIntf, Intf, {$I %CurrentRoutine%}); Result := True; end else Result := GMGetInterface(AObj, TIntf, Intf); end; function RGMTypedIntf<TIntf>.Call(ACaller: TObject): TIntf; begin //Assert(Intf <> nil, 'RGMTypedIntf<TIntf>.Intf <> nil'); if Intf = nil then EGMException.ObjError(GMFormat(srCannotCallNilIntf, [GMGuidToString(TIntf)]), ACaller, 'RGMTypedIntf<'+GMGuidToString(TIntf)+'>.Call'); Result := Intf; end; { -------------------------------- } { ---- RGMCriticalSectionLock ---- } { -------------------------------- } class operator RGMCriticalSectionLock.Initialize(var ACriticalSectionLock: RGMCriticalSectionLock); begin ACriticalSectionLock := Default(RGMCriticalSectionLock); end; class operator RGMCriticalSectionLock.Finalize(var ACriticalSectionLock: RGMCriticalSectionLock); begin ACriticalSectionLock.UnlockAll; end; procedure RGMCriticalSectionLock.Lock(const ACriticalSection: IGMCriticalSection); begin CriticalSection := ACriticalSection; LockAgain; end; procedure RGMCriticalSectionLock.Lock(const ACriticalSection: IUnknown); var cs: IGMCriticalSection; begin if GMQueryInterface(ACriticalSection, IGMCriticalSection, cs) then Lock(cs); end; procedure RGMCriticalSectionLock.Lock(const ACriticalSection: TObject); var cs: IGMCriticalSection; begin if GMGetInterface(ACriticalSection, IGMCriticalSection, cs) then Lock(cs); end; procedure RGMCriticalSectionLock.LockAgain; begin if CriticalSection <> nil then begin CriticalSection.EnterCriticalSection; Inc(LockCount); end; end; procedure RGMCriticalSectionLock.Unlock; begin if (CriticalSection <> nil) and (LockCount > 0) then begin CriticalSection.LeaveCriticalSection; Dec(LockCount); end; end; procedure RGMCriticalSectionLock.UnlockAll; begin while LockCount > 0 do Unlock; end; function RGMCriticalSectionLock.GetLockCount: Int64; begin Result := LockCount; end; { ---------------------------- } { ---- TGMCriticalSection ---- } { ---------------------------- } constructor TGMCriticalSection.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); {$IFNDEF JEDIAPI}windows{$ELSE}jwaWinBase{$ENDIF}.InitializeCriticalSection(FCriticalSection); end; destructor TGMCriticalSection.Destroy; begin {$IFNDEF JEDIAPI}windows{$ELSE}jwaWinBase{$ENDIF}.DeleteCriticalSection(FCriticalSection); inherited Destroy; end; procedure TGMCriticalSection.EnterCriticalSection; begin {$IFNDEF JEDIAPI}windows{$ELSE}jwaWinBase{$ENDIF}.EnterCriticalSection(FCriticalSection); end; procedure TGMCriticalSection.LeaveCriticalSection; begin {$IFNDEF JEDIAPI}windows{$ELSE}jwaWinBase{$ENDIF}.LeaveCriticalSection(FCriticalSection); end; function TGMCriticalSection.TryEnterCriticalSection: Boolean; begin Result := {$IFNDEF JEDIAPI}windows{$ELSE}jwaWinBase{$ENDIF}.TryEnterCriticalSection(FCriticalSection); end; { -------------------------------- } { ---- TGMCriticalSectionLock ---- } { -------------------------------- } constructor TGMCriticalSectionLock.Create(const ACriticalSection: IUnknown; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); if ACriticalSection = nil then Exit; // <- allow nil! // But force ACriticalSection to support IGMCriticalSection interface if not nil! GMCheckQueryInterface(ACriticalSection, IGMCriticalSection, FCriticalSection, {$I %CurrentRoutine%}); if FCriticalSection <> nil then FCriticalSection.EnterCriticalSection; end; destructor TGMCriticalSectionLock.Destroy; begin if FCriticalSection <> nil then FCriticalSection.LeaveCriticalSection; inherited Destroy; end; { --------------------------- } { ---- TGMCOMInitializer ---- } { --------------------------- } constructor TGMCOMInitializer.Create(const ACoInitFlags: DWORD; const AHrCheck, ARefLifeTime: Boolean); var Hr: HResult; begin inherited Create(ARefLifeTime); Hr := CoInitializeEx(nil, ACoInitFlags); if AHrCheck then GMHrCheckObj(Hr, Self, 'CoInitializeEx'); FInitialized := GMHrSucceeded(Hr); end; destructor TGMCOMInitializer.Destroy; begin if FInitialized then CoUninitialize; inherited Destroy; end; { --------------------------------- } { ---- TGMNotificationDisabler ---- } { --------------------------------- } constructor TGMNotificationDisabler.Create(const ANotifier: IUnknown; const ANotificationOnReEnable: LongInt; const ANotificationOnFirstDisable: LongInt; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FNotificationOnReEnable := ANotificationOnReEnable; // follow "if possible" semantics here if not GMQueryInterface(ANotifier, IGMEnableNotifications, FNotifier) then Exit; //GMCheckQueryInterface(ANotifier, IGMEnableNotifications, FNotifier, {$I %CurrentRoutine%}); FNotifier.DisableNotifications(ANotificationOnFirstDisable); end; destructor TGMNotificationDisabler.Destroy; begin if FNotifier <> nil then try FNotifier.EnableNotifications(FNotificationOnReEnable); except end; // <- never raise exceptions in destructors inherited Destroy; end; { --------------------------- } { ---- TGMPositionKeeper ---- } { --------------------------- } constructor TGMPositionKeeper.Create(const AObjWithPosition: IUnknown; const ANewposition: LongInt; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); // follow "if possible" semantics here if not GMQueryInterface(AObjWithPosition, IGMGetSetPosition, FObjWithPosition) then Exit; //GMCheckQueryInterface(AObjWithPosition, IGMGetSetPosition, FObjWithPosition, {$I %CurrentRoutine%}); FPosition := FObjWithPosition.Position; if ANewposition <> -1 then FObjWithPosition.Position := ANewposition; end; destructor TGMPositionKeeper.Destroy; //var PICount: IGMGetCount; begin if FObjWithPosition <> nil then try FObjWithPosition.Position := FPosition; except end; // <- never raise exceptions in destructors //if FObjWithPosition.QueryInterface(IGMGetCount, PICount) = S_OK then FObjWithPosition.Position := Min(FPosition, PICount.Count) else inherited Destroy; end; { ------------------------ } { ---- TGMStateKeeper ---- } { ------------------------ } constructor TGMStateKeeper.Create(const AObjWithState: IUnknown; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); // follow "if possible" semantics here if not GMQueryInterface(AObjWithState, IGMSaveRestoreState, FObjWithState) then Exit; //GMCheckQueryInterface(AObjWithState, IGMSaveRestoreState, FObjWithState, {$I %CurrentRoutine%}); FState := FObjWithState.CaptureState; end; destructor TGMStateKeeper.Destroy; begin // never raise exceptions in destructors if FObjWithState <> nil then try FObjWithState.RestoreState(FState); except end; // <- never raise exceptions in destructors inherited Destroy; end; { ----------------------------- } { ---- TGMQuietStateKeeper ---- } { ----------------------------- } constructor TGMQuietStateKeeper.Create(const AObjWithState: IUnknown; const ANotificationOnReEnable: LongInt; const ANotificationOnFirstDisable: LongInt; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FNotificationDisabler := TGMNotificationDisabler.Create(AObjWithState, ANotificationOnReEnable, ANotificationOnFirstDisable); FStateKeeper := TGMStateKeeper.Create(AObjWithState); end; { ------------------------- } { ---- TGMActiveKeeper ---- } { ------------------------- } constructor TGMActiveKeeper.Create(const AActivatableObj: IUnknown; const ANewActive: Boolean; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); GMQueryInterface(AActivatableObj, IGMGetSetActive, FActivatableObj); FWasActive := GMSetIntfActive(FActivatableObj, ANewActive); end; destructor TGMActiveKeeper.Destroy; begin try GMSetIntfActive(FActivatableObj, FWasActive); except end; // <- never raise exceptions in destructors inherited Destroy; end; { ----------------------------- } { ---- TGMVsdDirPathKeeper ---- } { ----------------------------- } constructor TGMVsdDirPathKeeper.Create(const AValStorageDir: IUnknown; const ANewDirPath: TGMString; const ACreateIfNotExists: Boolean; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); if AValStorageDir = nil then Exit; // force AValStorageDir to support IGMValueStorageDirectory interface GMCheckQueryInterface(AValStorageDir, IGMValueStorageDirectory, FValStorageDir, {$I %CurrentRoutine%}); FOldDirPath := FValStorageDir.CurrentPath; if Length(ANewDirPath) > 0 then GMVsdOpenDir(FValStorageDir, ANewDirPath, ACreateIfNotExists); end; destructor TGMVsdDirPathKeeper.Destroy; begin if FValStorageDir <> nil then GMVsdOpenAbsDir(FValStorageDir, FOldDirPath, False); inherited Destroy; end; { ----------------------------- } { ---- TGMIStreamPosKeeper ---- } { ----------------------------- } constructor TGMIStreamPosKeeper.Create(const AStream: IUnknown; AStartPos: Int64; const ARefLifeTime: Boolean); var strm: IStream; begin inherited Create(ARefLifeTime); //if AStream = nil then Exit; if not GMQueryInterface(AStream, IStream, strm) then Exit; FStream := strm; if AStartPos >= 0 then GMHrCheckObj(FStream.Seek(AStartPos, STREAM_SEEK_SET, @FOldPos), Self, {$I %CurrentRoutine%}) else GMHrCheckObj(FStream.Seek(0, STREAM_SEEK_CUR, @FOldPos), Self, {$I %CurrentRoutine%}); end; destructor TGMIStreamPosKeeper.Destroy; begin if FStream <> nil then FStream.Seek(FOldPos, STREAM_SEEK_SET, @FOldPos); // <- no exceptions in destructors! inherited Destroy; end; { -------------------------- } { ---- TGMPaintDisabler ---- } { -------------------------- } {constructor TGMPaintDisabler.Create(const APaintObj: IUnknown; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); if APaintObj <> nil then APaintObj.QueryInterface(IGMEnableDisablePaint, FPaintObj); if FPaintObj <> nil then FPaintObj.DisablePaint; end; destructor TGMPaintDisabler.Destroy; begin if FPaintObj <> nil then FPaintObj.EnablePaint; inherited Destroy; end;} { -------------------------- } { ---- TGMRefCountedObj ---- } { -------------------------- } constructor TGMRefCountedObj.Create(const ARefLifeTime: Boolean); begin inherited Create; FRefLifeTime := ARefLifeTime; FRefCount := 1; // <- artificial RefCount during construction, avoiding immediate destruction // when local interface variables to this instance are used by derived constructors. end; procedure TGMRefCountedObj.AfterConstruction; begin Dec(FRefCount); inherited AfterConstruction; end; procedure TGMRefCountedObj.BeforeDestruction; begin inherited BeforeDestruction; InterlockedIncrement(FRefCount); // <- put an artificial RefCount during destruction to avoid reentering destructor if temporary references are used during destruction end; destructor TGMRefCountedObj.Destroy; begin inherited Destroy; if Assigned(vfGMCheckRefCountOnDestroy) then vfGMCheckRefCountOnDestroy(RefCount-1, Self); end; procedure TGMRefCountedObj.OnFinalRelease; begin Free; end; function TGMRefCountedObj.CreateCopyQI(const AIID: TGUID; out AIntf): HResult; var unkCopy: IUnknown; assignFrom: IGMAssignFromObj; begin unkCopy := TGMRefCountedObjClass(ClassType).Create(True); Result := unkCopy.QueryInterface(AIID, AIntf); if (Result = S_OK) and (unkCopy.QueryInterface(IGMAssignFromObj, assignFrom) = S_OK) then assignFrom.AssignFromObj(Self); end; { ---- IGMGetObjInfo ---- } function TGMRefCountedObj.GetClassName: TGMString; //var RetVal: TGMString; begin //RetVal := ClassName; //Result := PGMChar(RetVal); Result := ClassName; end; function TGMRefCountedObj.GetClassType: TClass; begin Result := ClassType; end; function TGMRefCountedObj.GetInstance: TObject; begin Result := Self; end; function TGMRefCountedObj.GetTypeInfo: PTypeInfo; begin Result := ClassInfo; end; { ---- IUnknown ---- } function TGMRefCountedObj.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} AIID: TGUID; out AIntf): HResult; begin if GetInterface(AIID, AIntf) then Result := S_OK else Result := E_NOINTERFACE; //GMTraceQueryInterface(Self, AIID, Result); end; function TGMRefCountedObj._AddRef: LongInt; begin Result := InterlockedIncrement(FRefCount); end; function TGMRefCountedObj._Release: LongInt; begin Result := InterlockedDecrement(FRefCount); if (Result = 0) and RefLifeTime then OnFinalRelease; end; { ---------------------------- } { ---- TGMAggregatableObj ---- } { ---------------------------- } constructor TGMAggregatableObj.Create(const AOwner: IUnknown; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); FOwner := Pointer(AOwner); Assert((AOwner = nil) or not ARefLifeTime, '(AOwner = nil) or not ARefLifeTime'); end; function TGMAggregatableObj.QueryInterface(constref AIID: TGUID; out AIntf): HResult; stdcall; begin if FOwner <> nil then Result := IUnknown(FOwner).QueryInterface(AIID, AIntf) else Result := E_NOINTERFACE; if Result <> S_OK then Result := inherited QueryInterface(AIID, AIntf); end; function TGMAggregatableObj._AddRef: LongInt; stdcall; begin if FOwner <> nil then Result := IUnknown(FOwner)._AddRef else Result := inherited _AddRef; end; function TGMAggregatableObj._Release: LongInt; stdcall; begin if FOwner <> nil then Result := IUnknown(FOwner)._Release else Result := inherited _Release; end; function TGMAggregatableObj.GetOwner: IUnknown; begin Result := IUnknown(FOwner); end; function TGMAggregatableObj.GetOwnerObj: TObject; begin Result := GMObjFromIntf(IUnknown(FOwner)); end; { ------------------------------ } { ---- TGMRefLifePersistent ---- } { ------------------------------ } {$IFDEF DELPHIVCL} constructor TGMRefLifePersistent.Create(const ARefLifeTime: Boolean); begin inherited Create; FRefLifeTime := ARefLifeTime; end; procedure TGMRefLifePersistent.AfterConstruction; begin inherited AfterConstruction; FConstructed := True; end; destructor TGMRefLifePersistent.Destroy; begin inherited Destroy; if Assigned(vfGMCheckRefCountOnDestroy) then vfGMCheckRefCountOnDestroy(RefCount, Self); end; procedure TGMRefLifePersistent.OnFinalRelease; begin Free; end; { ---- IGMGetObjInfo ---- } function TGMRefLifePersistent.GetClassName: TGMString; begin Result := ClassName; end; function TGMRefLifePersistent.GetClassType: TClass; begin Result := ClassType; end; function TGMRefLifePersistent.GetInstance: TObject; begin Result := Self; end; function TGMRefLifePersistent.GetTypeInfo: PTypeInfo; begin Result := ClassInfo; end; { ---- IUnknown ---- } function TGMRefLifePersistent.QueryInterface(const AIID: TGUID; out AIntf): HResult; begin if GetInterface(AIID, AIntf) then Result := S_OK else Result := E_NOINTERFACE; //GMTraceQueryInterface(Self, AIID, Result); end; function TGMRefLifePersistent._AddRef: LongInt; begin Result := InterlockedIncrement(FRefCount); end; function TGMRefLifePersistent._Release: LongInt; begin Result := InterlockedDecrement(FRefCount); if (Result = 0) and RefLifeTime and FConstructed then OnFinalRelease; end; {$ENDIF} { ----------------------------- } { ---- TGMRefLifeComponent ---- } { ----------------------------- } {$IFDEF DELPHIVCL} constructor TGMRefLifeComponent.CreateIntf; begin RefLifeTime := True; Create(nil); // <- Important: call virtual constructor here, to let derived classes initialize their members end; procedure TGMRefLifeComponent.AfterConstruction; begin inherited AfterConstruction; FConstructed := True; end; destructor TGMRefLifeComponent.Destroy; begin inherited Destroy; {if RefLifeTime then} if Assigned(vfGMCheckRefCountOnDestroy) then vfGMCheckRefCountOnDestroy(RefCount, Self); end; function TGMRefLifeComponent.CopyCreateClass: TGMRefLifeComponentClass; begin Result := TGMRefLifeComponentClass(ClassType); end; procedure TGMRefLifeComponent.OnFinalRelease; begin Free; end; { ---- IGMGetObjInfo ---- } function TGMRefLifeComponent.GetClassName: TGMString; begin Result := ClassName; end; function TGMRefLifeComponent.GetClassType: TClass; begin Result := ClassType; end; function TGMRefLifeComponent.GetInstance: TObject; begin Result := Self; end; function TGMRefLifeComponent.GetTypeInfo: PTypeInfo; begin Result := ClassInfo; end; { ---- IGMGetName ---- } function TGMRefLifeComponent.GetName: TGMString; begin Result := Name; end; { ---- IGMAssignByObj ---- } procedure TGMRefLifeComponent.AssignFromObj(const ASource: TObject); begin if ASource is TPersistent then Assign(TPersistent(ASource)); end; procedure TGMRefLifeComponent.AssignToObj(const ADest: TObject); begin if ADest is TPersistent then TPersistent(ADest).Assign(Self); end; { ---- IGMCreateCopyQI ---- } function TGMRefLifeComponent.CreateCopyQI(const AIID: TGUID; out AIntf): HResult; var PIUnknown: IUnknown; PIAssign: IGMAssignFromObj; begin PIUnknown := CopyCreateClass.CreateIntf; Result := PIUnknown.QueryInterface(AIID, AIntf); if (Result = S_OK) and (PIUnknown.QueryInterface(IGMAssignFromObj, PIAssign) = S_OK) then PIAssign.AssignFromObj(Self); end; { ---- IUnknown ---- } function TGMRefLifeComponent.QueryInterface(const AIID: TGUID; out AIntf): HResult; begin if GetInterface(AIID, AIntf) then Result := S_OK else Result := E_NOINTERFACE; //GMTraceQueryInterface(Self, AIID, Result); end; function TGMRefLifeComponent._AddRef: LongInt; begin Result := InterlockedIncrement(FRefCount); end; function TGMRefLifeComponent._Release: LongInt; begin Result := InterlockedDecrement(FRefCount); if (Result = 0) and RefLifeTime and FConstructed then OnFinalRelease; end; {$ENDIF} end.