{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: Commonly useful Routines/Objects/Types. | } { | | } { | | } { | Copyright (C) - 1996 - Gerrit Moeller. | } { | | } { | Source code dstributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMCommon; interface uses {$IFDEF JEDIAPI}jwaWinType, jwaWinError, jwaWinNT, jwaWinBase, jwaWinUser, jwaWinReg, JwaWinNLS,{$ELSE}Windows,{$ENDIF} SysUtils, GMStrDef, GMActiveX, GMIntf, GMCollections, GMUnionValue, TypInfo {$IFDEF CALLSTACK}, GMCallStack{$ENDIF}; type TGMTracePrefix = (tpNone, tpInformation, tpWarning, tpError, tpException, tpCall, tpExecute, tpSQL, tpHttp, tpSOAP, tpTime, tpInterface, tpHTML, tpXML, tpSocket, tpFtp, tpText); TGMErrorAction = (eaContinue, eaAskUser, eaAbort); //TGMWaitResult = (wrSignaled, wrTimeout, wrAbandoned, wrError); TGMVersionResInfo = (viCompanyName, viProductName, viVersionText, viCopyRight, viComments, viFileVersion); TGMWinVersion = (wvInvalid, wvWin_3_11, wvWin95, wvWin98, wvWinNT, wvWin2000, wvWinXP, wvServer2003, wvVista, wvWin7_8, wvWin10_11, wvUnknown); TGM2DDirection = (d2dHorizontal, d2dVertical); TGM2DDirections = set of TGM2DDirection; TGMCursor = (crArrow, crIBeam, crWait, crCross, crUpArrow, crSize, crDrag, crSizeNESW, crSizeNS, crSizeNWSE, crSizeWE, crNo, crHandPoint, crAppStart, crHelp); TGMDateTimePart = (dtpSep0, dtpSign, dtpHour, dtpMinute, dtpSecond, dtpMilliSecond, dtpDay, dtpMonth, dtpDD, dtpMM, dtpYYYY, dtpYY, dtpHH, dtpNN, dtpSS, dtpUnknown); ERightLeftSide = (rlsLeft, rlsRight); const cGMTempFilePrefix = '~GM'; cGMTempFileExtension = 'tmp'; cPersistentFileExt = 'prs'; //CHelpFileExt = 'HLP'; cStrMaskAllFiles = '*.*'; GM_USER = $0801; // $0400 => WM_USER, small Offset interferes with MS Up/down control .. //UM_DONEMODAL = GM_USER - 1; {$IFDEF FPC} {$IFNDEF JEDIAPI} {$EXTERNALSYM QS_KEY} QS_KEY = $0001; {$EXTERNALSYM QS_MOUSEMOVE} QS_MOUSEMOVE = $0002; {$EXTERNALSYM QS_MOUSEBUTTON} QS_MOUSEBUTTON = $0004; {$EXTERNALSYM QS_POSTMESSAGE} QS_POSTMESSAGE = $0008; {$EXTERNALSYM QS_TIMER} QS_TIMER = $0010; {$EXTERNALSYM QS_PAINT} QS_PAINT = $0020; {$EXTERNALSYM QS_SENDMESSAGE} QS_SENDMESSAGE = $0040; {$EXTERNALSYM QS_HOTKEY} QS_HOTKEY = $0080; {$EXTERNALSYM QS_ALLPOSTMESSAGE} QS_ALLPOSTMESSAGE = $0100; {$EXTERNALSYM DT_WORD_ELLIPSIS} DT_WORD_ELLIPSIS = $40000; {$EXTERNALSYM CONNECT_E_FIRST} CONNECT_E_FIRST = HRESULT($80040200); {$EXTERNALSYM CONNECT_E_LAST} CONNECT_E_LAST = HRESULT($8004020F); {$EXTERNALSYM CONNECT_E_NOCONNECTION} CONNECT_E_NOCONNECTION = CONNECT_E_FIRST + 0; {$EXTERNALSYM CONNECT_E_ADVISELIMIT} CONNECT_E_ADVISELIMIT = CONNECT_E_FIRST + 1; {$EXTERNALSYM CONNECT_E_CANNOTCONNECT} CONNECT_E_CANNOTCONNECT = CONNECT_E_FIRST + 2; {$EXTERNALSYM CONNECT_E_OVERRIDDEN} CONNECT_E_OVERRIDDEN = CONNECT_E_FIRST + 3; {$ENDIF} {$ENDIF} {$IFNDEF JEDIAPI} INVALID_FILE_ATTRIBUTES = DWORD(-1); {$EXTERNALSYM INVALID_FILE_ATTRIBUTES} SORT_DIGITSASNUMBERS = $00000008; // treat digits like numbers {$EXTERNALSYM SORT_DIGITSASNUMBERS} {$ENDIF} cUtf16LEBom: RawByteString = #$FF#$FE; cUtf16BEBom: RawByteString = #$FE#$FF; cUtf8Bom: RawByteString = #$EF#$BB#$BF; cMsgAwakeByAll = QS_ALLEVENTS or QS_ALLINPUT or QS_ALLPOSTMESSAGE; cFalseInt = 0; cTrueInt = 1; cBoolInt: array [Boolean] of LongInt = (cFalseInt, cTrueInt); //cBoolInt: array [Boolean] of Int64 = (0, 1); cBoolStr: array [Boolean] of TGMString = ('False', 'True'); cSpaceCh = ' '; cWhiteSpace = cSpaceCh + #9#10#13; cChDontTerm = '^'; cDfltExceptionMsg = ''; cDfltHelpCtx = 0; cBeepInvalidChar = 0; cDfltPrntWnd = 0; cNoUIWnd = $FFFFFFFF; cHrPrntWnd = cNoUIWnd; cDontChangeTimerInterval = $FFFFFFFF; //CInvalidRefCount = -1; cDfltDateTime = 0; cDfltSizeInBytes = 0; cDfltAllocAlignment = SizeOf(Pointer); cDfltGlobalAllocFlags = GMEM_MOVEABLE; cDfltActiveStored = False; cDfltActivePersists = True; cDfltIIDRequired = True; cDfltCallEventsWhenDisabled = False; cDfltTimerInterval = 1000; cDfltSaveUSerData = False; cDfltAlwaysNotify = False; cDfltTextDrawFlags = DT_WORD_ELLIPSIS or DT_NOPREFIX; cDfltStorageRootKey = HKEY_CURRENT_USER; cDontUseRootKey = 0; cCoInitUseDflt = -1; cDontCoInit = -2; cInvalidUIPos = Low(LongInt); KEY_CREATE = KEY_READ or KEY_WRITE; KEY_DELETE = KEY_READ or KEY_WRITE; // or _DELETE; // KEY_READ or KEY_CREATE_SUB_KEY or _DELETE; // {$IFNDEF JEDIAPI} {$EXTERNALSYM MB_CANCELTRYCONTINUE} MB_CANCELTRYCONTINUE = $00000006; {$EXTERNALSYM FILE_ATTRIBUTE_ENCRYPTED} FILE_ATTRIBUTE_ENCRYPTED = $00000040; {$EXTERNALSYM FILE_ATTRIBUTE_SPARSE_FILE} FILE_ATTRIBUTE_SPARSE_FILE = $00000200; {$EXTERNALSYM FILE_ATTRIBUTE_REPARSE_POINT} FILE_ATTRIBUTE_REPARSE_POINT = $00000400; {$EXTERNALSYM STGM_DIRECT_SWMR} STGM_DIRECT_SWMR = $00400000; {$EXTERNALSYM WS_EX_LAYERED} WS_EX_LAYERED = $00080000; {$EXTERNALSYM WS_EX_COMPOSITED} WS_EX_COMPOSITED = $02000000; {$EXTERNALSYM LWA_COLORKEY} LWA_COLORKEY = $00000001; {$EXTERNALSYM LWA_ALPHA} LWA_ALPHA = $00000002; {$EXTERNALSYM KEY_WOW64_64KEY} KEY_WOW64_64KEY = $0100; {$EXTERNALSYM KEY_WOW64_32KEY} KEY_WOW64_32KEY = $0200; {$ENDIF} {$EXTERNALSYM STGC_CONSOLIDATE} STGC_CONSOLIDATE = 8; cStrGMWebAddress = 'https://www.gm-software.de'; cStrGMSupportMailAddr = 'support@gm-software.de'; cStrGMProblemReportMailAddr = 'problem-reports@gm-software.de'; cStrGMPersistentBasePath = '\Software\GM-Software'; cStrNULL = 'NULL'; cStrNone = '<None>'; cStrMore = '...'; cStr_More = ' ' + cStrMore; cStrSoftware = 'Software'; cDirSep = '/\'; cAbsKeyCh = '\'; cValSepCh = ';'; cInvalidFileNameChars = '\/:*?"<>|'; cAllFilesExt = '*'; cGuidStripChars = cWhiteSpace + '(){}[]"'''; cInvalidItemIdx = Low(LongInt); // Low(PtrInt); // -1; cNullPoint: TPoint = (X: 0; Y: 0); cNullRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0); cNullSize: TSize = (cx: 0; cy: 0); cInvalidUIPoint: TPoint = (X: cInvalidUIPos; Y: cInvalidUIPos); cInvalidUIRect: TRect = (Left: cInvalidUIPos; Top: cInvalidUIPos; Right: cInvalidUIPos; Bottom: cInvalidUIPos); cAll2DDirections = [Low(TGM2DDirection)..High(TGM2DDirection)]; cStrClassName = 'ClassName'; cStrLeft = 'Left'; cStrTop = 'Top'; cStrRight = 'Right'; cStrBottom = 'Bottom'; cStrFixedDateSep = '.'; cStrFixedTimeSep = ':'; cStrFixedMilliSecSep = '-'; //cStrFixedDezSep = '.'; cStrFixedDateFmt = 'dd"'+cStrFixedDateSep+'"mm"'+cStrFixedDateSep+'"yyyy'; // <- do not localize! cStrFixedTimeFmt = 'hh"'+cStrFixedTimeSep+'"nn"'+cStrFixedTimeSep+'"ss"'+cStrFixedMilliSecSep+'"zzz'; // <- do not localize! //cStrFixedDateTimeFmt = cStrFixedDateFmt + ' ' + cStrFixedTimeFmt; //cStrFixedDateFmt = 'dd"."mm"."yyyy'; // <- do not localize! //cStrFixedTimeFmt = 'hh":"nn":"ss"-"zzz'; // <- do not localize! cStrFixedDateTimeFmt = cStrFixedDateFmt + ' ' + cStrFixedTimeFmt; //cStrFixedDateTimeFmt = 'dd"."mm"."yyyy hh":"nn":"ss"-"zzz'; cDecSep = '.'; cStrDigits = '0123456789'; cStrSigns = '-+'; cStrHexChars = cStrDigits + 'abcdefABCDEF'; cStrHexConvertChars: TGMString = '0123456789ABCDEF'; cInvalidCPCookie = 0; cStrTCompareResult = 'TGMCompareResult'; cStrVerInfoCompany = 'CompanyName'; cStrVerInfoProduct = 'ProductName'; cStrVerInfoCopyright = 'LegalCopyright'; cStrVerInfoVersion = 'FileVersion'; cStrVerInfoComments = 'Comments'; cStrUserName = 'Username'; cStrPassword = 'Password'; cStrIsEncryptedPwd = 'PwdIsEncrypted'; cStrSaveUserData = 'SaveUserData'; cDfltUserName = ''; cDfltPassword = ''; cUnixStartDate: TDateTime = 25569.0; cMessageBoxIcon: array [TGMSeverityLevel] of LongWord = (0, mb_IconQuestion, mb_IconInformation, mb_IconExclamation, mb_IconStop); cVersionInfoKeys: array [TGMVersionResInfo] of TGMString = (cStrVerInfoCompany, cStrVerInfoProduct, cStrVerInfoVersion, cStrVerInfoCopyright, cStrVerInfoComments, ''); cVersionInfoKeysA: array [TGMVersionResInfo] of AnsiString = (cStrVerInfoCompany, cStrVerInfoProduct, cStrVerInfoVersion, cStrVerInfoCopyright, cStrVerInfoComments, ''); cGMTracePrefixes: array [TGMTracePrefix] of TGMString = ('', 'INFORMATION', 'WARNING', 'ERROR', 'EXCEPTION', 'CALL', 'EXECUTE', 'SQL', 'HTTP', 'SOAP', 'TIME', 'INTERFACE', 'HTML', 'XML', 'SOCKET', 'FTP', 'TEXT'); cWinCursorRes: array [TGMCursor] of Pointer = (IDC_ARROW, IDC_IBEAM, IDC_WAIT, IDC_CROSS, IDC_UPARROW, IDC_SIZE, IDC_ICON, IDC_SIZENESW, IDC_SIZENS, IDC_SIZENWSE, IDC_SIZEWE, IDC_NO, IDC_HAND, IDC_APPSTARTING, IDC_HELP); //TGMSeverityLevel = (svNone, svConfirmation, svInformation, svWarning, svError); cGMSeveritySound: array [TGMSeverityLevel] of LongWord = (0, MB_ICONQUESTION, MB_ICONASTERISK, MB_ICONEXCLAMATION, MB_ICONHAND); cDateTimeFmtPatterns: array [TGMDateTimePart] of TGMString = ('*', 'SIGN', 'HOUR', 'MINUTE', 'SECOND', 'MILLISECOND', 'DAY', 'MONTH', 'DD', 'MM', 'YYYY', 'YY', 'HH', 'NN', 'SS', ''); type PBoolean = ^Boolean; { ----------------------------- } { ---- Function Prototypes ---- } { ----------------------------- } TProcedure = procedure; TGMBooleanFunc = function: Boolean; stdcall; TGMMessageBoxFunc = function (const Msg: TGMString; const Severity: TGMSeverityLevel = svInformation; Flags: LongWord = 0; const ParentWnd: HWnd = cDfltPrntWnd): LongInt; stdcall; TGMTraceProc = procedure (const AText: TGMString; const APrefix: TGMString = ''); TGMTraceLineProc = procedure (const ALine: TGMString); TProcessLineProc = procedure (const ALine: TGMString; const Data: Pointer); TGMInfoProc = TProcedure; //TGMExceptionHandlerFunc = function (const AException: TObject; const ParentWnd: HWnd = cDfltPrntWnd; const DefaultCode: LongWord = ERROR_INTERNAL_ERROR): LongWord; stdcall; TGMHrExceptionHandlerFunc = function (const AException: TObject; const ParentWnd: HWnd; const DefaultCode: HResult = E_UNEXPECTED): HResult; stdcall; // cHrPrntWnd TGMExceptionDlgFunc = function (const AException: TObject; const ParentWnd: HWnd = cDfltPrntWnd): LongInt; stdcall; TGMObjectProc = procedure of object; TGMObjNotifyProc = procedure(const Sender: TObject) of object; TGMObjNotifyBoolFunc = function(const Sender: TObject): Boolean of object; TGMGetStringFunc = function: TGMString of object; TGMSetStringProc = procedure (const Value: TGMString) of object; TGMAddLineFunc = function (const ALine: TGMString; const ALastLine: Boolean; const AData: Pointer): Boolean; // <- return false to stop iterating more lines { ----------------- } { ---- Classes ---- } { ----------------- } TGMHandleObj = class(TGMRefCountedObj, IGMGetHandle, IGMHashCode) protected FHandle: THandle; public constructor Create(const AHandle: THandle; const ARefLifeTime: Boolean = True); reintroduce; overload; function GetHandle: THandle; stdcall; function GetHandleAddr: Pointer; function HashCode: TGMHashCode; property Handle: THandle read FHandle; property HandleAddr: Pointer read GetHandleAddr; // <- useful for calls to WaitForMultipleObjects end; TGMCloseHandleObj = class(TGMHandleObj) public destructor Destroy; override; end; TGMHotKeyTable = class(TGMHandleObj) // Virtual key codes: // https://docs.microsoft.com/en-us/windows/desktop/inputdev/virtual-key-codes public constructor Create(const AKeys: array of TAccel; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; end; TGMNamedOsHandleObj = class(TGMCloseHandleObj, IGMGetName) protected FName: TGMString; public function GetName: TGMString; stdcall; property Name: TGMString read FName; end; TGMMutableHandleObj = class(TGMHandleObj, IGMGetSetHandle) public procedure SetHandle(const Value: THandle); stdcall; end; TGMRegKey = class; IGMRegKey = interface(IGMGetHandle) ['{9211EC93-F0A1-4e99-AD71-1BEE41B15EB4}'] function Obj: TGMRegKey; end; { TGMRegKey } TGMRegKey = class(TGMRefCountedObj, IGMGetHandle, IGMRegKey) protected FRootKeyRef: IUnknown; FRootKey: HKEY; FHandle: HKEY; function FormatKeyPath(const Value: TGMString): TGMString; public // Interfaces function Obj: TGMRegKey; function GetHandle: THandle; stdcall; constructor Create(const ARefLifeTime: Boolean = True); override; constructor CreateKey(const ARootKey: HKEY; AKeyPath: TGMString = ''; const AAccessMode: DWORD = KEY_CREATE; const ARefLifeTime: Boolean = True); reintroduce; overload; constructor CreateKey(const ARootKey: IUnknown; const AKeyPath: TGMString = ''; const AAccessMode: DWORD = KEY_CREATE; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; procedure CloseKey; function OpenKey(const ARootKey: HKEY; const AKeyPath: TGMString = ''; const ACheckExists: Boolean = False; const AAccessMode: DWORD = KEY_READ): Boolean; overload; function OpenKey(const ARootKey: IUnknown; const AKeyPath: TGMString = ''; const ACheckExists: Boolean = False; const AAccessMode: DWORD = KEY_READ): Boolean; overload; procedure ReadValueNames(var Names: TGMStringArray); procedure ReadSubKeyNames(var Names: TGMStringArray); function DeleteValue(const AValueName: TGMString): Boolean; function DeleteKey(const ARootKey: HKEY; const AKeyPath: TGMString; const ARecurse: Boolean): Boolean; function ValueExists(const AValueName: TGMString): Boolean; function ReadString(const AValueName: TGMString; const ADefaultValue: TGMString = ''): TGMString; function ReadInteger(const AValueName: TGMString; const ADefaultValue: LongInt = 0): LongInt; function ReadBinary(const AValueName: TGMString; const ADestData: Pointer; const ADestDataSizeInBytes: LongInt): DWORD; procedure WriteString(const AValueName, Value: TGMString); procedure WriteInteger(const AValueName: TGMString; const Value: LongInt); procedure WriteBinary(const AValueName: TGMString; const Data; const DataSize: DWORD); end; IGMWaitFor = interface(IUnknown) ['{340FE1DC-8690-4A51-83F1-19472E1C19A1}'] function WaitFor(const AProcessMessages: Boolean; const Timeout: DWORD = INFINITE): DWORD; end; IGMEvent = interface(IGMWaitFor) ['{016F7E8A-7219-4CC2-9132-AD61CB0E7A9E}'] procedure Signal; procedure Reset; end; TGMEvent = class(TGMNamedOsHandleObj, IGMEvent) public constructor Create(const AManualReset, AInitialSignaled: Boolean; const AName: TGMString = ''; const ASecurityAttr: PSecurityAttributes= nil; const ARefLifetime: Boolean = True); reintroduce; function WaitFor(const AProcessMessages: Boolean; const Timeout: DWORD = INFINITE): DWORD; procedure Signal; procedure Reset; end; TGMMutex = class(TGMNamedOsHandleObj, IGMCriticalSection) // // Use a mutex like a critical section. This allows so serve the message queue while waiting. // A Mutex is re-entrant like a critical section but works across process boundaries too. // protected FProcessMessagesWhileWaiting: Boolean; FTimeout: DWORD; public constructor Create(const AName: TGMString = ''; const AProcessMessagesWhileWaiting: Boolean = False; const ATimeout: DWORD = INFINITE; const ASecurityAttr: PSecurityAttributes= nil; const ARefLifetime: Boolean = True); reintroduce; procedure EnterCriticalSection; procedure LeaveCriticalSection; end; IGMSemaphore = interface(IUnknown) ['{FCFBC53F-BBAB-404B-B414-E338FD5C762C}'] procedure EnterShared; procedure LeaveShared; procedure EnterSingleExclusive; procedure LeaveSingleExclusive; end; TGMSemaphore = class(TGMNamedOsHandleObj, IGMSemaphore) protected FMaxShareCount: LongInt; public constructor Create(const AMaxShareCount: LongInt; const AName: TGMString = ''; // const AProcessMessagesWhileWaiting: Boolean = False; const ASecurityAttr: PSecurityAttributes= nil; const ARefLifetime: Boolean = True); reintroduce; procedure EnterShared; procedure LeaveShared; procedure EnterSingleExclusive; procedure LeaveSingleExclusive; end; IGMTimer = interface(IGMGetHandle) ['{5D2C8DAA-3C88-4EE3-9B34-6BD418D3B1BE}'] procedure Restart(const ANewIntervalMS: UINT = cDontChangeTimerInterval); procedure Start; procedure Stop; function IsRunning: BOOL; function GetInterval: UINT; procedure SetInterval(const AInterval: UINT); property Interval: UINT read GetInterval write SetInterval; end; {$IFDEF JEDIAPI} TGMWaitableTimer = class(TGMNamedOsHandleObj, IGMTimer) protected FDueTime: LARGE_INTEGER; FInterval: LONG; FIsRunning: BOOL; FExecRoutine: PTIMERAPCROUTINE; FExecRoutineArg: Pointer; public constructor Create(const ADueTime: Int64; // See Microsoft help for CreateWaitableTimer const AAutoStart: Boolean = False; const AName: TGMString = ''; const AInterval: LONG = 0; const AExecRoutine: PTIMERAPCROUTINE = nil; const AExecRoutineArg: Pointer = nil; const ASecurityAttr: PSecurityAttributes= nil; const ARefLifetime: Boolean = True); reintroduce; destructor Destroy; override; procedure Start; procedure Restart(const ANewIntervalMS: UINT = cDontChangeTimerInterval); procedure Stop; function IsRunning: BOOL; function GetInterval: UINT; procedure SetInterval(const AInterval: UINT); end; {$ENDIF} TGMTimerBase = class(TGMRefCountedObj, IGMGetHandle, IGMTimer) protected FTimerId: UINT; FInterval: UINT; function GetInterval: UINT; procedure SetInterval(const AInterval: UINT); function GetHandle: THandle; virtual; stdcall; public destructor Destroy; override; // function Obj: TGMTimerBase; procedure Restart(const ANewIntervalMS: UINT = cDontChangeTimerInterval); procedure Start; virtual; abstract; procedure Stop; virtual; abstract; function IsRunning: BOOL; property Interval: UINT read GetInterval write SetInterval; end; TGMThreadTimer = class(TGMTimerBase) protected FCaller: TObject; FOnTimerProc: TGMObjNotifyProc; procedure DoOnTimer; virtual; public constructor Create(const AOnTimerProc: TGMObjNotifyProc = nil; const ACaller: TObject = nil; const AWaitTimeoutMilliSec: UINT = cDfltTimerInterval; const AAutoStart: Boolean = False; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual; procedure Start; override; procedure Stop; override; property OnTimer: TGMObjNotifyProc read FOnTimerProc write FOnTimerProc; end; TGMWndTimer = class(TGMTimerBase) protected FWnd: HWnd; FClientID: LongInt; function GetHandle: THandle; override; public constructor Create(const AWnd: HWnd; const ATimerID: LongInt; const AWaitTimeoutMilliSec: LongInt = cDfltTimerInterval; const AAutoStart: Boolean = False; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual; procedure Start; override; procedure Stop; override; end; TGMThread = class; IGMThread = interface(IUnknown) ['{3DC881DD-24DC-41dc-B309-6629CDA7D434}'] function Obj: TGMThread; end; TGMThread = class(TGMCloseHandleObj, IGMThread) // // Get rid of all the stupid things in borlands Classes.TThread. // This one is much simpler and has a nice exception wrapper and COM initialization. // protected FThreadId: DWORD; FSuspendCount: LongInt; FCanceled: BOOL; FCoInitFlags: LongInt; FTerminated: Boolean; FAllowExceptDlg: Boolean; FHasBeenRunning: Boolean; public FreeOnTerminate: Boolean; WaitTimeoutOnDestroy: DWORD; constructor Create(const ACoInitFlags: LongInt = cCoInitUseDflt; // <- must be first parameter to avoid ambiguity with inherited constructor const ACreateSuspended: Boolean = True; const APriority: LongInt = THREAD_PRIORITY_NORMAL; const AAllowExceptDlg: Boolean = False; AThreadProc: Pointer = nil; const AStackSize: LongWord = 0; const ASecurityAttr: PSecurityAttributes = nil; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; function Obj: TGMThread; function Execute: HResult; virtual; abstract; // <- return value becomes thread Exit code function Suspend: DWORD; function Resume: DWORD; procedure Run; virtual; procedure Cancel; virtual; function WaitFor(const AProcessMessages: Boolean; const ATimeoutMS: DWORD = INFINITE): HResult; function GetPriority: LongInt; procedure SetPriority(const AValue: LongInt); function ExitCode: DWORD; property ThreadID: LongWord read FThreadId; property SuspendCount: LongInt read FSuspendCount; property HasBeenRunning: Boolean read FHasBeenRunning; property Priority: LongInt read GetPriority write SetPriority; property Canceled: BOOL read FCanceled; property Terminated: Boolean read FTerminated; end; TGMThreadTermMsgDataRec = record TargetWnd: THandle; Msg: Integer; WParam: WPARAM; LParam: LPARAM; end; TGMSilentThread = class; IGMSilentThread = interface(IUnknown) ['{C26731AE-59DF-4689-92F3-A5A487D8D975}'] function Obj: TGMSilentThread; end; TGMSilentThread = class(TGMThread, IGMSilentThread) protected FExceptInfo: IGMExceptionInformation; FCSTermMsgData: IGMCriticalSection; FTermMsg: TGMThreadTermMsgDataRec; function DfltExceptResult: HResult; virtual; function Obj: TGMSilentThread; public {$IFDEF CALLSTACK} ExceptCallStack: IGMThreadCallStack; // ExceptCallStack: TGMPtrIntArray; {$ENDIF} constructor Create(const ARefLifeTime: Boolean); overload; override; procedure SetTermMsgData(const ATermMsgData: TGMThreadTermMsgDataRec); virtual; procedure SendTerminationMsg; virtual; function InternalExecute: HResult; virtual; abstract; function Execute: HResult; override; property ExceptInfo: IGMExceptionInformation read FExceptInfo write FExceptInfo; end; TGMTempCursor = class(TGMRefCountedObj) protected FOldCursor: HCursor; FPMemberVar: PHandle; FOldMemeberVarValue: THandle; public constructor Create(const ANewCursor: TGMCursor; const APMemberVar: PHandle = nil; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; end; {IGMMemoryBuffer = interface(IUnknown) ['9C07F06F-FFC9-4047-8A23-FBEBB88AF307'] function GetMemory: Pointer; function GetSizeInBytes: Cardinal; function GetAllocAlignment: LongWord; function GetZeroInit: Boolean; function GetFreeMemoryOnDestroy: Boolean; procedure SetAllocAlignment(const Value: LongWord); procedure SetZeroInit(const Value: Boolean); procedure SetFreeMemoryOnDestroy(const Value: Boolean); procedure Realloc(NewSizeInBytes: Cardinal); procedure FreeMemory; property Memory: Pointer read GetMemory; property SizeInBytes: Cardinal read GetSizeInBytes; property AllocAlignment: LongWord read GetAllocAlignment write SetAllocAlignment; property ZeroInit: Boolean read GetZeroInit write SetZeroInit; property FreeMemoryOnDestroy: Boolean read GetFreeMemoryOnDestroy write SetFreeMemoryOnDestroy; end;} TGMMemoryBuffer = class; IGMMemoryBuffer = interface(IUnknown) ['{9C07F06F-FFC9-4047-8A23-FBEBB88AF307}'] function Obj: TGMMemoryBuffer; end; TGMMemoryBuffer = class(TGMRefCountedObj, IGMMemoryBuffer) // // Can be used as a aggregate for interface delegation via "implements" compiler featrue. // Will redirect QueryInterface calls to it's owner if the requested interface isn't // supported by itself and owner <> nil. // // If used as interface delegation member the owner must refernece this class by a normal // object pointer and not an interface. Because reference counts are routed back to the // owner by this class a cyclic reference would keep the owner forever. For the same reason // this class must not reference other delegation classes of the owner by interfaces. // // Note: This is the only solution always working. // protected FOwner: TObject; FMemory: Pointer; FAllocAlignment: LongWord; FZeroInit: Boolean; FFreeMemoryOnDestroy: Boolean; FSizeInBytes: Int64; FOnAfterRealloc: TGMObjNotifyProc; //function GetMemory: Pointer; //function GetSizeInBytes: Int64; //function GetAllocAlignment: LongWord; //function GetZeroInit: Boolean; //function GetFreeMemoryOnDestroy: Boolean; procedure SetAllocAlignment(const AValue: LongWord); //procedure SetZeroInit(const Value: Boolean); //procedure SetFreeMemoryOnDestroy(const Value: Boolean); procedure InternalRealloc(const ANewSizeInBytes: Int64); virtual; public constructor Create(const AOwner: TObject = nil; const ASizeInBytes: Int64 = 0; const AAllocAlignment: LongWord = cDfltAllocAlignment; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); reintroduce; virtual; destructor Destroy; override; function QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; override; function _AddRef: LongInt; override; function _Release: LongInt; override; function Obj: TGMMemoryBuffer; procedure FreeMemory; virtual; procedure ReallocMemory(ANewSizeInBytes: Int64); virtual; property Memory: Pointer read FMemory; // GetMemory; property AllocAlignment: LongWord read FAllocAlignment write SetAllocAlignment; // GetAllocAlignment property SizeInBytes: Int64 read FSizeInBytes; // GetSizeInBytes; property ZeroInit: Boolean read FZeroInit write FZeroInit; // GetZeroInit write SetZeroInit; property FreeMemoryOnDestroy: Boolean read FFreeMemoryOnDestroy write FFreeMemoryOnDestroy; // GetFreeMemoryOnDestroy write SetFreeMemoryOnDestroy; end; TGMGlobalMemoryBuffer = class(TGMMemoryBuffer, IGMGetHandle, IGMGetSetHandle) protected FHGlobal: HGLOBAL; FAllocFlags: LongWord; procedure InternalRealloc(const ANewSizeInBytes: Int64); override; public function GetHandle: THandle; stdcall; procedure SetHandle(const Value: THandle); stdcall; public constructor Create(const AOwner: TObject = nil; const ASizeInBytes: Int64 = 0; const AAllocAlignment: LongWord = cDfltAllocAlignment; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); overload; override; constructor Create(const AOwner: TObject = nil; const ASizeInBytes: Int64 = 0; const AAllocAlignment: LongWord = cDfltAllocAlignment; const AAllocFlags: LongWord = cDfltGlobalAllocFlags; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual; destructor Destroy; override; property Handle: THandle read GetHandle; end; IGMGetAnsiText = interface(IUnknown) ['{E6114C8A-BA01-430F-BBCD-B1AB1FEBD27F}'] function GetAnsiText: AnsiString; end; TGMAnsiStringMemoryBuffer = class(TGMMemoryBuffer, IGMGetText, IGMGetAnsiText) protected FAnsiStringBuffer: AnsiString; procedure InternalRealloc(const ANewSizeInBytes: Int64); override; public constructor Create(const AOwner: TObject = nil; const AContentAsString: AnsiString = ''; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); reintroduce; // overload; virtual; function GetText: TGMString; stdcall; function GetAnsiText: AnsiString; end; TGMStringMemoryBuffer = class(TGMMemoryBuffer, IGMGetText) // IGMGetAnsiText protected FStringBuffer: TGMString; procedure InternalRealloc(const ANewSizeInBytes: Int64); override; public constructor Create(const AOwner: TObject = nil; const AContentAsString: TGMString = ''; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); reintroduce; // overload; virtual; function GetText: TGMString; stdcall; //function GetAnsiText: AnsiString; end; TGMResourceMemoryBuffer = class(TGMMemoryBuffer) protected procedure InternalRealloc(const ANewSizeInBytes: Int64); override; public constructor Create(const AOwner: TObject = nil; const AResourceName: PGMChar = nil; const AResourceType: PGMChar = nil; AModuleHandle: THandle = INVALID_HANDLE_VALUE; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); reintroduce; // virtual; end; TGMMemoryLockBytes = class(TGMRefCountedObj, IGMGetOffset, IGMGetSetOffset, ILockBytes, IGMShiftOffset, IGMAssignFromIntf, IGMMemoryBuffer) // // This class is a ILockBytes implementation on Heap memory. // protected FMemoryBuffer: TGMMemoryBuffer; FFullDataSize: Int64; FOffset: PtrInt; FCTime, FATime, FMTime: TFileTime; function GetDataSize: Int64; virtual; procedure InternalSetSize(ANewSize: Int64); virtual; //function CreateMemoryBuffer(const ASizeInBytes, AAllocAlignment: LongInt; const AZeroInit, AFreeMemoryOnDestroy: Boolean): TGMMemoryBuffer; virtual; procedure OnAfterRealloc(const ASender: TObject); virtual; public constructor Create(const AAllocAlignment: LongInt = cDfltAllocAlignment; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const ASizeInBytes: Int64 = 0; const ARefLifeTime: Boolean = True); reintroduce; virtual; destructor Destroy; override; function Memory: Pointer; inline; procedure AssignFromIntf(const ASource: IUnknown); virtual; stdcall; procedure Clear(const AResetOffset: Boolean = True); virtual; // IGMGetSetOffset function GetOffset: PtrInt; virtual; stdcall; procedure SetOffset(AValue: PtrInt); virtual; stdcall; // IGMShiftOffset procedure SetOffsetAndShiftData(const ANewOffset: LongInt); virtual; stdcall; // ILockBytes function ReadAt(ulOffset: Int64; pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; virtual; stdcall; function WriteAt(ulOffset: Int64; pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; virtual; stdcall; function SetSize(cb: Int64): HResult; virtual; stdcall; function LockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; virtual; stdcall; function UnlockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; virtual; stdcall; function Stat(out statstg: TStatStg; grfStatFlag: LongInt): HResult; virtual; stdcall; function Flush: HResult; virtual; stdcall; property DataSize: Int64 read GetDataSize; property Offset: PtrInt read GetOffset write SetOffset; property MemoryBuffer: TGMMemoryBuffer read FMemoryBuffer implements IGMMemoryBuffer; end; TGMIStreamBase = class; TGMIStreamRootClass = class of TGMIStreamBase; TGMIStreamBase = class(TGMRefCountedObj, ISequentialStream, IStream, IGMGetName) protected FCaptureExceptions: Boolean; FMode: DWORD; FName: UnicodeString; function InternalGetSize: Int64; virtual; public // Interfaces constructor Create(const AMode: DWORD; const AName: UnicodeString = ''; const ARefLifeTime: Boolean = True); reintroduce; overload; function GetName: TGMString; stdcall; // ISequentialStream function Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; virtual; stdcall; abstract; function Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; virtual; stdcall; abstract; // IStream function Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; virtual; stdcall; abstract; function SetSize(libNewSize: Int64): HResult; virtual; stdcall; function CopyTo(stm: IStream; cb: Int64; out cbRead: Int64; out cbWritten: Int64): HResult; virtual; stdcall; function Commit(grfCommitFlags: LongInt): HResult; virtual; stdcall; function Revert: HResult; virtual; stdcall; function LockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; virtual; stdcall; function UnlockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; virtual; stdcall; function Stat(out statstg: TStatStg; grfStatFlag: LongInt): HResult; virtual; stdcall; function Clone(out stm: IStream): HResult; virtual; stdcall; function CloneCreateClass: TGMIStreamRootClass; virtual; property CaptureExceptions: Boolean read FCaptureExceptions write FCaptureExceptions; end; TGMSequentialIStream = class(TGMIStreamBase) // // Internal read/write are called repeatedly if they dont deliver all // data with the first call until all requested data is processed. // Seek does the best sequential streams can do. // protected FSize: Int64; FPosition: Int64; // Internal rotuines may raise, and may deliver less data than requested function InternalGetSize: Int64; override; procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); virtual; abstract; procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); virtual; abstract; public function Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; override; stdcall; function Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; override; stdcall; function Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; override; stdcall; end; TGMMemoryIStreamBase = class; IGMMemoryStream = interface(IUnknown) ['{732B500B-F422-43cd-A45D-6181D5B02405}'] function Obj: TGMMemoryIStreamBase; end; TGMMemoryIStreamBase = class(TGMSequentialIStream, IGMMemoryBuffer, IGMMemoryStream) protected FMemoryBuffer: TGMMemoryBuffer; procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); override; procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); override; procedure InternalSetSize(NewSize: Int64); virtual; procedure LimitPosition; virtual; procedure OnAfterRealloc(const Sender: TObject); virtual; public destructor Destroy; override; function Obj: TGMMemoryIStreamBase; function Memory: Pointer; function Size: Int64; procedure Clear; virtual; function SetSize(libNewSize: Int64): HResult; override; function Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; override; property MemoryBuffer: TGMMemoryBuffer read FMemoryBuffer implements IGMMemoryBuffer; end; TGMMemoryIStream = class(TGMMemoryIStreamBase) protected function CreateMemoryBuffer(const ASizeInBytes: Int64; const AAllocAlignment: LongInt; const AZeroInit, AFreeMemoryOnDestroy: Boolean): TGMMemoryBuffer; virtual; public constructor Create(const AAllocAlignment: LongInt = cDfltAllocAlignment; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const ASizeInBytes: Int64 = 0; const ARefLifeTime: Boolean = True); overload; virtual; end; TGMGlobalMemoryIStream = class(TGMMemoryIStream, IGMGetHandle) protected FAllocFlags: LongWord; function CreateMemoryBuffer(const ASizeInBytes: Int64; const AAllocAlignment: LongInt; const AZeroInit, AFreeMemoryOnDestroy: Boolean): TGMMemoryBuffer; override; public constructor Create(const AAllocAlignment: LongInt = cDfltAllocAlignment; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const ASizeInBytes: Int64 = 0; const ARefLifeTime: Boolean = True); overload; override; constructor Create(const AAllocAlignment: LongInt = cDfltAllocAlignment; const AAllocFlags: LongWord = cDfltGlobalAllocFlags; const AHGlobal: HGlobal = 0; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const ASizeInBytes: Int64 = 0; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual; function GetHandle: THandle; stdcall; procedure AssignGlobalMemory(const AHGlobal: HGLOBAL; const ADataSize: Int64 = -1; const APosition: LongInt = 0); property Handle: THandle read GetHandle; end; TGMResourceIStream = class(TGMMemoryIStreamBase) public constructor Create(const AResourceName: PGMChar = nil; const AResourceType: PGMChar = nil; const AModuleHandle: THandle = INVALID_HANDLE_VALUE; const ARefLifeTime: Boolean = True); reintroduce; virtual; end; TGMAnsiStringIStream = class(TGMMemoryIStreamBase, IGMGetText, IGMGetAnsiText) public constructor Create(const AContentAsString: AnsiString = ''; const ARefLifeTime: Boolean = True); reintroduce; virtual; function GetText: TGMString; stdcall; function GetAnsiText: AnsiString; end; TGMStringIStream = class(TGMMemoryIStreamBase, IGMGetText) // IGMGetAnsiText public constructor Create(const AContentAsString: TGMString = ''; const ARefLifeTime: Boolean = True); reintroduce; virtual; function GetText: TGMString; stdcall; //function GetAnsiText: AnsiString; end; TGMLockBytesIStream = class(TGMSequentialIStream {, IGMGetOffset, IGMGetSetOffset}) protected FLockBytes: ILockBytes; //FOffset: LongInt; procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); override; procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); override; //public // Interfaces //function GetOffset: LongInt; stdcall; //procedure SetOffset(Value: LongInt); stdcall; public constructor Create(const ALockBytes: ILockBytes; const ARefLifeTime: Boolean = True); reintroduce; function SetSize(libNewSize: Int64): HResult; override; function Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; override; end; TGMFileHandleIStream = class(TGMSequentialIStream, IGMGetHandle) // // IStream implementation based on Windows ReadFile/WriteFile routines // ReadFile/WriteFile works on Files, Pipes, Sockets, .. // protected FHandle: THandle; procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); override; procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); override; public constructor Create(const AHandle: LongWord; const AMode: LongInt; const AName: UnicodeString = ''; const ARefLifeTime: Boolean = True); reintroduce; overload; function GetHandle: THandle; stdcall; function HandleIsValid: Boolean; property Handle: THandle read FHandle; end; TGMFileIStream = class(TGMFileHandleIStream) public constructor Create(const AFileName: TGMString; const AAccess, AShare, ACreateKind: DWORD; const AFlags: DWORD = FILE_ATTRIBUTE_NORMAL; const ARefLifeTime: Boolean = True); reintroduce; overload; constructor CreateRead(const AFileName: TGMString; const AShare: DWORD = FILE_SHARE_READ; const AFlags: DWORD = FILE_ATTRIBUTE_NORMAL; const ARefLifeTime: Boolean = True); constructor CreateOverwrite(const AFileName: TGMString; const AAccess: DWORD = GENERIC_WRITE; const AFlags: DWORD = FILE_ATTRIBUTE_NORMAL; const ARefLifeTime: Boolean = True); destructor Destroy; override; function Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; override; end; TOverlappedWaitHandles = (owhAbort, owhIOComple); // <- Order matters here! Check aborted before checking IOComplete! TFileRWFunc = function (hFile: THandle; pBuffer: Pointer; nNumberOfBytes: DWORD; var lpBytesTransferred: DWORD; lpOverlapped: POverlapped): BOOL; TGMOverlappedIStream = class(TGMFileHandleIStream) protected FEvIOCompleted: IGMGetHandle; FOverlappedIOData: TOverlapped; FWaitHandles: array [TOverlappedWaitHandles] of THandle; procedure FileRWWrapper(pv: Pointer; cb: LongWord; var pcbRead: LongWord; const FileRWFunc: TFileRWFunc); procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); override; procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); override; public constructor Create(const AHandle: LongWord; const AMode: LongInt; const AEvAbort: IGMGetHandle; const AName: UnicodeString = ''; const ARefLifeTime: Boolean = True); reintroduce; overload; end; TGMChainedIStream = class(TGMIStreamBase) protected FChainedStream: IStream; public // ISequentialStream function Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; override; stdcall; function Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; override; stdcall; // IStream function Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; override; stdcall; function SetSize(libNewSize: Int64): HResult; override; stdcall; function Commit(grfCommitFlags: LongInt): HResult; override; stdcall; function Revert: HResult; override; stdcall; function LockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; override; stdcall; function UnlockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; override; stdcall; function Stat(out statstg: TStatStg; grfStatFlag: LongInt): HResult; override; stdcall; constructor Create(const AChainedStream: IStream; const ARefLifeTime: Boolean = True); reintroduce; end; TGMNotifyingIStream = class(TGMChainedIStream, IConnectionPointContainer, IGMCreateConnectionPoint) // // This stream may be chained between other streams. // All operations are passed to the stream given in constructor. // When reading or writing connected objects will be notified about the progress. // This allows to get progress information when sombody else is reading or writing. // protected FPosition: Int64; FConnectionPointContainer: IConnectionPointContainer; FCancel: BOOL; //FMTime: TFileTime; procedure CallSinkOnProgress(const NotifySink: IUnknown; const Params: array of OleVariant); function OnProgress(const AProgress: Int64): Boolean; public constructor Create(const AChainedStream: IStream; const ARefLifeTime: Boolean = True); //constructor CreateLastMod(const AChainedStream: IStream; const ALastMod: TDateTime; const ARefLifeTime: Boolean = True); //function Stat(out statstg: TStatStg; grfStatFlag: LongInt): HResult; override; destructor Destroy; override; // ISequentialStream function Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; override; stdcall; function Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; override; stdcall; // IGMCreateConnectionPoint procedure CreateConnectionPoint(const IID: TGUID); stdcall; // IConnectionPointContainer function EnumConnectionPoints(out Enum: IEnumConnectionPoints): HResult; stdcall; function FindConnectionPoint(const iid: TGUID; out cp: IConnectionPoint): HResult; stdcall; end; TGMBufferedIStream = class(TGMSequentialIStream) protected FChainedStream: IStream; FAnsiStrBuffer: AnsiString; FBufWriteCount: LongInt; FBufDataSize: LongInt; FBufPos: LongInt; function FillBuffer: HResult; function FlushBuffer: HResult; procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); override; procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); override; public constructor Create(const AChainedStream: IStream; const ABufSizeInBytes: Integer = cDfltCopyBufferSize; const AName: TGMString = ''; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; // ISequentialStream function Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; override; stdcall; function Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; override; stdcall; // function Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; override; stdcall; end; TGMInterfaceIDArray = array of TGUID; TGMIntfConnectDataRec = record IID: TGUID; Cookie: LongInt; Required: Boolean; end; TGMIntfSourceChangeEvent = procedure (const OldSource, NewSource: IUnknown) of object; //TGMIntfSourceObjChangeEvent = procedure (const OldSource, NewSource: TObject) of object; TGMIntfProc = procedure (const Intf: IUnknown) of object; TIntfIDsToConnectArray = array of TGMIntfConnectDataRec; TGMObjInterfaceConnector = class(TGMRefCountedObj, IGMGetActive, IGMGetSetActive, IGMDisconnectFromConnectionPoint, IGMAskBoolean, IGMGetInterfaceSource, IGMGetSetInterfaceSource) protected FOwner: TObject; FObjectToBeConnected: TObject; FInterfaceSource: IUnknown; // FInterfaceSourceObject: TObject; FNeededInterfaceIDs: TGMInterfaceIDArray; FIntfIDsToConnect: TIntfIDsToConnectArray; FAlwaysNotify: Boolean; FOnBeforeIntfSourceChange: TGMIntfSourceChangeEvent; FOnAfterIntfSourceChange: TGMIntfSourceChangeEvent; // FOnBeforeIntfSourceObjChange: TGMIntfSourceObjChangeEvent; // FOnAfterIntfSourceObjChange: TGMIntfSourceObjChangeEvent; FOnCheckIntfCanBeConnected: TGMIntfProc; function GetInterfaceSource: IUnknown; virtual; stdcall; procedure SetInterfaceSource(const AValue: IUnknown); virtual; stdcall; // procedure SetInterfaceSourceObject(const Value: TObject); procedure CheckNotConnected(AMethodName: TGMString); // IGMGetSetActive function GetActive: Boolean; virtual; stdcall; procedure SetActive(const Value: Boolean); virtual; stdcall; // IGMDisconnectFromConnectionPoint procedure DisconnectFromConnectionPoint(const ConnectionPointContainer: IUnknown; const IID: TGUID; const Cookie: LongInt); virtual; stdcall; // IGMAskBoolean function AskBoolean(const ValueId: LongInt): LongInt; virtual; stdcall; public constructor Create(const AOwner: TObject; const ANeededInterfaceIDs: array of TGUID; const AIntfIDsToConnect: array of TGMIntfConnectDataRec); reintroduce; destructor Destroy; override; procedure AssignFromObj(const Source: TObject); virtual; stdcall; procedure CheckInterfaceCanBeConnected(const Intf: IUnknown); virtual; function InterfaceCanBeConnected(const Intf: IUnknown): Boolean; virtual; function IsConnected: Boolean; virtual; function GetSourceIntf(const IID: TGUID; out Intf): Boolean; virtual; function GetPropertyIntf(const PropertyName: TGMString; const IID: TGUID; out Intf): HResult; virtual; function SourceIsActive: Boolean; virtual; function SourceState: LongInt; virtual; procedure AddNeededIntfID(const IID: TGUID); virtual; procedure AddNeededIntfIDs(const IIDs: array of TGUID); procedure AddIntfIDToConnect(const IID: TGUID; const Required: Boolean = cDfltIIDRequired); virtual; procedure AddIntfIDsToConnect(const AIntfIDsToConnect: array of TGMIntfConnectDataRec); procedure ConnectInterface(const Container: IUnknown; var GMIntfConnectData: TGMIntfConnectDataRec; const ARoutineName: TGMString = cDfltRoutineName); virtual; procedure DisconnectInterface(const Container: IUnknown; const IID: TGUID; var Cookie: LongInt); virtual; procedure ConnectAllInterfaces(const Container: IUnknown); //overload; procedure DisconnectAllInterfaces(const Container: IUnknown); //overload; property NeededInterfaceIDs: TGMInterfaceIDArray read FNeededInterfaceIDs; property IntfIDsToConnect: TIntfIDsToConnectArray read FIntfIDsToConnect; property Owner: TObject read FOwner; property ObjectToBeConnected: TObject read FObjectToBeConnected write FObjectToBeConnected; // property InterfaceSourceObject: TObject read FInterfaceSourceObject write SetInterfaceSourceObject; property InterfaceSource: IUnknown read GetInterfaceSource write SetInterfaceSource; property AlwaysNotify: Boolean read FAlwaysNotify write FAlwaysNotify default cDfltAlwaysNotify; property OnBeforeIntfSourceChange: TGMIntfSourceChangeEvent read FOnBeforeIntfSourceChange write FOnBeforeIntfSourceChange; property OnAfterIntfSourceChange: TGMIntfSourceChangeEvent read FOnAfterIntfSourceChange write FOnAfterIntfSourceChange; // property OnBeforeIntfSourceObjChange: TGMIntfSourceObjChangeEvent read FOnBeforeIntfSourceObjChange write FOnBeforeIntfSourceObjChange; // property OnAfterIntfSourceObjChange: TGMIntfSourceObjChangeEvent read FOnAfterIntfSourceObjChange write FOnAfterIntfSourceObjChange; property OnCheckIntfCanBeConnected: TGMIntfProc read FOnCheckIntfCanBeConnected write FOnCheckIntfCanBeConnected; end; TGMActiveChangeNotifyEvent = procedure (const NewActive: Boolean) of Object; TGMActivatableIntfSource = class(TGMObjInterfaceConnector, IGMActiveChangeNotifications) protected FOnBeforeActiveChange: TGMActiveChangeNotifyEvent; FOnAfterActiveChange: TGMActiveChangeNotifyEvent; public // IGMActiveChangeNotifications procedure BeforeActiveChange(const NewActive: Boolean); virtual; stdcall; procedure AfterActiveChange(const NewActive: Boolean); virtual; stdcall; constructor Create(const AOwner: TObject; const ANeededInterfaceIDs: array of TGUID; const AIntfIDsToConnect: array of TGMIntfConnectDataRec); published property OnBeforeActiveChange: TGMActiveChangeNotifyEvent read FOnBeforeActiveChange write FOnBeforeActiveChange; property OnAfterActiveChange: TGMActiveChangeNotifyEvent read FOnAfterActiveChange write FOnAfterActiveChange; end; { -------------------- } { ---- Components ---- } { -------------------- } TGMConnectableObject = class(TGMRefCountedObj, IConnectionPointContainer, IGMCreateConnectionPoint, IGMEnableNotifications, IGMGetPropertyIntf, IGMGetInterfaceSource, IGMGetSetInterfaceSource) protected FObjectConnectedTo: TGMObjInterfaceConnector; FConnectionPointContainer: IConnectionPointContainer; FNotifyDisableCount: LongInt; FCallEventsWhenDisabled: Boolean; procedure InternalClose; virtual; //procedure CallSinkClose(const NotifySink: IUnknown; const Params: array of OleVariant); procedure ConnectInterface(const Container: TObject; const IID: TGUID; var Cookie: LongInt; const CallingRoutineName: TGMString = cDfltRoutineName); overload; virtual; procedure ConnectInterface(const Container: IUnknown; const IID: TGUID; var Cookie: LongInt; const CallingRoutineName: TGMString = cDfltRoutineName); overload; virtual; procedure DisconnectInterface(const Container: TObject; const IID: TGUID; var Cookie: LongInt); overload; virtual; procedure DisconnectInterface(const Container: IUnknown; const IID: TGUID; var Cookie: LongInt); overload; virtual; procedure NotifyConnectedObjectsOnFirstDisable(const NotificationOnFirstDisable: LongInt = Ord(rgNone)); virtual; procedure NotifyConnectedObjectsOnReEnable(const NotificationOnReEnable: LongInt = Ord(rgNone)); virtual; public constructor Create(const ARefLifeTime: Boolean); override; destructor Destroy; override; // IGMGetPropertyIntf function GetPropertyIntf(const PropertyName: TGMString; const IID: TGUID; out Intf): HResult; virtual; stdcall; // IGMCreateConnectionPoint procedure CreateConnectionPoint(const IID: TGUID); virtual; stdcall; // IConnectionPointContainer function EnumConnectionPoints(out Enum: IEnumConnectionPoints): HResult; stdcall; function FindConnectionPoint(const iid: TGUID; out cp: IConnectionPoint): HResult; stdcall; // IGMEnableNotifications function GetNotifyDisableCount: LongInt; virtual; stdcall; function EnableNotifications(const NotificationOnReEnable: LongInt = Ord(rgNone)): LongInt; virtual; stdcall; function DisableNotifications(const NotificationOnFirstDisable: LongInt = Ord(rgNone)): LongInt; virtual; stdcall; function DoCallEvents: Boolean; virtual; function DoNotifySink(const NotifySink: IUnknown; const IID: TGUID; out Intf): Boolean; virtual; property ConnectionPointContainer: IConnectionPointContainer read FConnectionPointContainer; property NotifyDisableCount: LongInt read GetNotifyDisableCount; property ObjectConnectedTo: TGMObjInterfaceConnector read FObjectConnectedTo implements IGMGetSetInterfaceSource, IGMGetInterfaceSource; property CallEventsWhenDisabled: Boolean read FCallEventsWhenDisabled write FCallEventsWhenDisabled default cDfltCallEventsWhenDisabled; end; TGMActivationProperties = class(TGMRefCountedObj) protected FOwner: TObject; FActiveStored: Boolean; function GetActive: Boolean; virtual; procedure SetActive(Value: Boolean); virtual; function IsActiveStored: Boolean; virtual; public constructor Create(const AOwner: TObject); reintroduce; virtual; property Owner: TObject read FOwner; published property Active: Boolean read GetActive write SetActive stored IsActiveStored; property StoreActive: Boolean read FActiveStored write FActiveStored default cDfltActiveStored; end; TGMActivationPropertyClass = class of TGMActivationProperties; TGMActivationStoredProperties = class(TGMActivationProperties) public constructor Create(const AOwner: TObject); override; published property StoreActive default cDfltActivePersists; end; TGMActivatableObject = class; TGMActiveChangeEvent = procedure (Sender: TGMActivatableObject; const NewActive: Boolean) of object; TGMActivatableObject = class(TGMConnectableObject, IGMGetActive, IGMGetSetActive, IGMVerifyActivation) protected FWasActive: Boolean; FActivationProperties: TGMActivationProperties; FOnBeforeActiveChange: TGMActiveChangeEvent; FOnAfterActiveChange: TGMActiveChangeEvent; function ActivationPropertyCreateClass: TGMActivationPropertyClass; virtual; function GetActive: Boolean; virtual; stdcall; abstract; procedure SetActive(const Value: Boolean); virtual; stdcall; procedure SetActivationProperties(const Value: TGMActivationProperties); procedure CheckIsActive(const MemberName: TGMString = cDfltRoutineName); virtual; stdcall; procedure CheckIsInactive(const MemberName: TGMString = cDfltRoutineName); virtual; stdcall; procedure DoBeforeOpen; virtual; procedure DoAfterOpen; virtual; procedure DoBeforeClose; virtual; procedure DoAfterClose; virtual; //procedure CallSinkBeforeActiveChange(const NotifySink: IUnknown; const Params: array of OleVariant); //procedure CallSinkAfterActiveChange(const NotifySink: IUnknown; const Params: array of OleVariant); procedure NotifyBeforeActiveChange(const NewActive: Boolean); virtual; procedure NotifyAfterActiveChange(const NewActive: Boolean); virtual; procedure InternalOpen; virtual; abstract; function CloseOnDestroy: Boolean; virtual; public constructor Create(const ARefLifeTime: Boolean); override; destructor Destroy; override; procedure Open; procedure Close; property Active: Boolean read GetActive write SetActive; property ActivationProperties: TGMActivationProperties read FActivationProperties write SetActivationProperties; property OnBeforeActiveChange: TGMActiveChangeEvent read FOnBeforeActiveChange write FOnBeforeActiveChange; property OnAfterActiveChange: TGMActiveChangeEvent read FOnAfterActiveChange write FOnAfterActiveChange; end; TGMHandleActivateObj = class(TGMActivatableObject, IGMGetHandle) protected FHandle: THandle; function GetActive: Boolean; override; procedure InternalOpen; override; procedure InternalClose; override; procedure AllocHandle; virtual; abstract; procedure ReleaseHandle; virtual; abstract; public function GetHandle: THandle; virtual; stdcall; function GetHandleAllocated: Boolean; virtual; stdcall; property Handle: THandle read GetHandle; end; TGMClipboard = class; IGMClipboard = interface(IUnknown) ['{153C4E19-E12B-452d-A05F-FC53D9D10461}'] function Obj: TGMClipboard; end; TGMClipboard = class(TGMRefCountedObj, IGMClipboard) public procedure SetEmpty; procedure SetAsHandle(const AFormat: UINT; const AValue: THandle; const ASetEmptyBefore: Boolean = False); procedure SetAsLockBytes(const AFormat: UINT; const AValue: ILockBytes; const ASetEmptyBefore: Boolean = False); procedure SetAsText(const AValue: TGMString; const ASetEmptyBefore: Boolean = False); function GetAsHandle(const AFormat: UINT): THandle; procedure ReplaceByHandle(const AFormat: UINT; const AValue: THandle); function GetAsText: TGMString; procedure ReplaceByText(const AValue: TGMString); function GetAsLockBytes(const AFormat: UINT): ILockBytes; procedure ReplaceByLockBytes(const AFormat: UINT; const AValue: ILockBytes); procedure PasteToLockBytes(const AFormat: UINT; const LockBytes: ILockBytes); function Obj: TGMClipboard; //function GetAsIStream: IStream; //procedure SetAsIStream(const Value: IStream); constructor Create(const AWnd: HWnd = 0; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; property AsText: TGMString read GetAsText write ReplaceByText; property AsHandle[const AFormat: UINT]: THandle read GetAsHandle write ReplaceByHandle; property AsLockBytes[const AFormat: UINT]: ILockBytes read GetAsLockBytes write ReplaceByLockBytes; //property AsIStream: IStream read GetAsIStream write SetAsIStream; end; { ------------------------------- } { ---- GM Exception Handling ---- } { ------------------------------- } TGMExceptionAskBoolValId = (bevPresentToUI, bevCaptureCallStack); TGMExceptionInformation = class(TGMRefCountedObj, IGMExceptionInformation, IGMGetHRCode, IGMAssignFromObj, IGMAssignFromIntf, IGMAskBoolean) // // A container to carry exception information // public FMessage: TGMString; FExceptionClassName: TGMString; FExceptAddress: Pointer; FRaisorName: TGMString; FRaisorClassName: TGMString; FRoutineName: TGMString; FSeverityLevel: TGMSeverityLevel; FHelpContext: LongInt; FHrCode: HResult; FCaptureCallStack: BOOL; FPresentToUI: LongInt; // <- TGMBoolAskResult; public constructor CreateFromObj(const ASource: TObject; const ARefLifeTime: Boolean = False; const ACaptureCallStack: Boolean = False); reintroduce; constructor CreateFromIntf(const ASource: IUnknown; const ARefLifeTime: Boolean = False; const ACaptureCallStack: Boolean = False); reintroduce; constructor Create(const ARefLifeTime: Boolean = False; const ACaptureCallStack: Boolean = False; const AMessage: TGMString = ''; const AExceptionClassName: TGMString = ''; const AExceptAddress: Pointer = nil; const ARaisorName: TGMString = ''; const ARaisorClassName: TGMString = ''; const ARoutineName: TGMString = ''; const ASeverityLevel: TGMSeverityLevel = svError; const AHelpContext: LongInt = 0; const AHRCode: HResult = ERROR_SUCCESS); reintroduce; procedure AssignFromObj(const ASource: TObject); stdcall; procedure AssignFromIntf(const ASource: IUnknown); stdcall; function GetHRCode: HResult; stdcall; function AskBoolean(const ValueId: LongInt): LongInt; stdcall; { ---- IGMExceptionInformation ---- } function GetGMMessage: PGMChar; stdcall; function GetExceptionClassName: PGMChar; stdcall; function GetExceptAddress: Pointer; stdcall; function GetRaisorName: PGMChar; stdcall; function GetRoutineName: PGMChar; stdcall; function GetHelpCtx: LongInt; stdcall; function GetSeverityLevel: TGMSeverityLevel; stdcall; function GetRaisorClassName: PGMChar; stdcall; //function GetPresentToUI: BOOL; stdcall; end; EGMException = class(Exception, IUnknown, IGMExceptionInformation, IGMGetText, IGMGetSetText, IGMSetExceptionInformation) protected FGMMessage: TGMString; FRefCount: LongInt; FExceptAddress: Pointer; FRaisorName: TGMString; FRaisorClassName: TGMString; FRoutineName: TGMString; FSeverityLevel: TGMSeverityLevel; FHelpContext: LongInt; FClassName: TGMString; procedure SetupInformation(const AMsg: TGMString = cDfltExceptionMsg; const ARaisorName: TGMString = ''; const ARaisorClassName: TGMString = ''; const ARoutineName: TGMString = cDfltRoutineName; const ASeverityLevel: TGMSeverityLevel = svError; const AHelpCtx: LongInt = cDfltHelpCtx); virtual; public constructor ObjError(const AMsg: TGMString = cDfltExceptionMsg; const AObj: TObject = nil; const ARoutineName: TGMString = cDfltRoutineName; const ASeverityLevel: TGMSeverityLevel = svError; const AHelpCtx: LongInt = cDfltHelpCtx); virtual; constructor IntfError(const AMsg: TGMString = cDfltExceptionMsg; const AIntf: IUnknown = nil; const ARoutineName: TGMString = cDfltRoutineName; const ASeverityLevel: TGMSeverityLevel = svError; const AHelpCtx: LongInt = cDfltHelpCtx); virtual; destructor Destroy; override; // procedure SetRoutineName(const ARoutineName: PGMChar); stdcall; // procedure SetMessage(const AMessage: PGMChar); stdcall; // procedure SetSeverityLevel(const ASeverityLevel: TGMSeverityLevel); 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}; // IGMGetSetText function GetText: TGMString; stdcall; procedure SetText(const Value: TGMString); stdcall; // IGMSetExceptionInformation procedure SetMessage(AMessage: PGMChar); stdcall; procedure SetSeverityLevel(ASeverityLevel: TGMSeverityLevel); stdcall; // IGMExceptionInformation 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 RefCount: LongInt read FRefCount; // property ARoutineName: TGMString read FRoutineName write FRoutineName; // property SeverityLevel: TGMSeverityLevel read GetSeverityLevel write FSeverityLevel; end; EGMExceptionClass = class of EGMException; EGMConvertException = class(EGMException); EGMFmtException = class(EGMException); EGMHrException = class(EGMException, IGMGetHRCode) protected FHrCode: HResult; public constructor ObjError(const AHRCode: HResult; const AParams: array of PGMChar; const AObj: TObject = nil; const ARoutineName: TGMString = cDfltRoutineName; const AMsgPostfix: TGMString = ''; const AHelpCtx: LongInt = cDfltHelpCtx); reintroduce; overload; virtual; constructor IntfError(const AHRCode: HResult; const AParams: array of PGMChar; const AIntf: IUnknown = nil; const ARoutineName: TGMString = cDfltRoutineName; const AMsgPostfix: TGMString = ''; const AHelpCtx: LongInt = cDfltHelpCtx); reintroduce; overload; virtual; function GetHrCode: HResult; stdcall; property HRCode: HResult read GetHRCode; end; EAPIException = class(EGMException, IGMGetHRCode) protected FErrorCode: LongWord; public constructor ObjError(const AWinApiErrorCode: LongWord; const AParams: array of PGMChar; const AObj: TObject = nil; const ARoutineName: TGMString = cDfltRoutineName; const AMsgPostfix: TGMString = ''; const AHelpCtx: LongInt = cDfltHelpCtx); reintroduce; overload; virtual; function GetHRCode: HResult; stdcall; property HRCode: HResult read GetHRCode; property ErrorCode: LongWord read FErrorCode; end; EGMAbort = class(EAbort, IUnknown, IGMGetHRCode) protected FRefCount: LongInt; public 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}; function GetHRCode: HResult; stdcall; end; { ------------------------------------------ } { ---- Connection Point Implementations ---- } { ------------------------------------------ } IGMConnectedObjListEntry = interface(IUnknown) ['{19601AE2-1EAA-11d5-AB38-000021DCAD19}'] procedure AssignTo(var CnData: tagConnectData); stdcall; function GetUnkIntf: IUnknown; stdcall; function GetCookie: LongInt; stdcall; procedure SetUnkIntf(const Value: IUnknown); stdcall; procedure SetCookie(const Value: LongInt); stdcall; property UnkIntf: IUnknown read GetUnkIntf write SetUnkIntf; property Cookie: LongInt read GetCookie write SetCookie; end; TGMConnectedObjListEntry = class(TGMRefCountedObj, IGMConnectedObjListEntry) protected FUnkIntf: IUnknown; FCookie: LongInt; function GetUnkIntf: IUnknown; stdcall; function GetCookie: LongInt; stdcall; procedure SetUnkIntf(const Value: IUnknown); stdcall; procedure SetCookie(const Value: LongInt); stdcall; public constructor Create(const AUnkIntf: IUnknown; const ACookie: LongInt); reintroduce; destructor Destroy; override; procedure AssignTo(var CnData: tagConnectData); stdcall; property UnkIntf: IUnknown read GetUnkIntf write SetUnkIntf; property Cookie: LongInt read GetCookie write SetCookie; end; TGMEnumXxxxImpl = class; TGMEnumXxxxImplClass = class of TGMEnumXxxxImpl; TGMEnumXxxxImpl = class(TGMRefCountedObj) protected FList: IGMIntfArrayCollection; FListPos: LongInt; FElemIID: TGUID; public constructor Create(const AList: IGMIntfArrayCollection; const AElemIID: TGUID; const AListPos: LongInt = cGMUnknownPosition); reintroduce; function CreateCloneClass: TGMEnumXxxxImplClass; virtual; abstract; property ElemIID: TGUID read FElemIID; function CreateClone(const IID: TGUID; out Enum): HResult; stdcall; { ---- IEnumXxxx ---- } function Skip(celt: LongInt): HResult; stdcall; function Reset: HResult; stdcall; end; TGMEnumConnectionPointsImpl = class(TGMEnumXxxxImpl, IEnumConnectionPoints) public constructor Create(const AList: IGMIntfArrayCollection); function CreateCloneClass: TGMEnumXxxxImplClass; override; function Clone(out Enum: IEnumConnectionPoints): HResult; stdcall; function Next(celt: LongInt; out elt; pceltFetched: PLongint): HResult; stdcall; end; TGMEnumConnectionsImpl = class(TGMEnumXxxxImpl, IEnumConnections) public constructor Create(const AList: IGMIntfArrayCollection); function CreateCloneClass: TGMEnumXxxxImplClass; override; function Clone(out Enum: IEnumConnections): HResult; stdcall; function Next(celt: LongInt; out elt; pceltFetched: PLongint): HResult; stdcall; end; TGMConnectionPointContainerImpl = class(TGMRefCountedObj, IConnectionPointContainer, IGMReleaseReferences, IGMCreateConnectionPoint) protected FConnectionPoints: IGMIntfArrayCollection; public constructor Create(const AConnectionPoints: array of TGUID; const ARefLifeTime: Boolean = True); reintroduce; // IGMReleaseReferences procedure ReleaseReferences; virtual; stdcall; // IGMMaintainConnectionPoints procedure CreateConnectionPoint(const IID: TGUID); virtual; stdcall; // IConnectionPointContainer function EnumConnectionPoints(out Enum: IEnumConnectionPoints): HResult; stdcall; function FindConnectionPoint(const iid: TGUID; out cp: IConnectionPoint): HResult; stdcall; end; TGMConnectionPointImpl = class(TGMRefCountedObj, IConnectionPoint) protected FIntfID: TGUID; FOwner: IUnknown; FConnectedObjects: IGMIntfArrayCollection; FCurrentCookie: LongWord; public constructor Create(const AOwner: IUnknown; const IID: TGUID; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; property IntfID: TGUID read FIntfID; // IConnectionPoint function GetConnectionInterface(out iid: TGUID): HResult; stdcall; function GetConnectionPointContainer(out Cpc: IConnectionPointContainer): HResult; stdcall; function EnumConnections(out Enum: IEnumConnections): HResult; stdcall; function Advise(const unkSink: IUnknown; out dwCookie: LongInt): HResult; stdcall; function Unadvise(dwCookie: LongInt): HResult; stdcall; end; { --------------------- } { ---- File System ---- } { --------------------- } TGMFileProperties = class(TGMRefCountedObj, IGMFileProperties, IGMGetFileName, IGMGetSetFileName, IGMAssignFromIntf, IGMCriticalSection) protected FCriticalSection: IGMCriticalSection; FFileName: TGMString; FDisplayName: TGMString; FAttributes: TFileAttributes; FCreationTime: TDateTime; FLastAccessTime: TDateTime; FLastWriteTime: TDateTime; FSizeInBytes: Int64; 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; public constructor Create(const ARefLifeTime: Boolean = True); overload; override; constructor CreateFromExisting(const AExistingFileName: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload; constructor Create(const FindData: TWin32FindData; const AFilePath: TGMString = ''; const ARefLifeTime: Boolean = True); reintroduce; overload; constructor Create(const AFileName: TGMString; const AAttributes: TFileAttributes = []; const ASizeInBytes: Int64 = cDfltSizeInBytes; const ACreationTime: TDateTime = cDfltDateTime; const ALastWriteTime: TDateTime = cDfltDateTime; const ALastAccessTime: TDateTime = cDfltDateTime; const ARefLifeTime: Boolean = True); reintroduce; overload; //constructor Create(const AFileName: TGMString; const AAttributes: TFileAttributes = []; const ASize: Int64 = -1; const ARefLifeTime: Boolean = True); overload; //function CriticalSection: IGMCriticalSection; procedure SetFileName(const Value: TGMString); stdcall; procedure AssignFromIntf(const Source: IUnknown); stdcall; property AFileName: TGMString read FFileName; property Attributes: TFileAttributes read FAttributes; property CreationTime: TDateTime read FCreationTime; property LastAccessTime: TDateTime read FLastAccessTime; property LastWriteTime: TDateTime read FLastWriteTime; property SizeInBytes: Int64 read FSizeInBytes; property CriticalSection: IGMCriticalSection read FCriticalSection implements IGMCriticalSection; end; { ----------------------- } { ---- Miscellaneous ---- } { ----------------------- } type //PMetafileHeader = ^TMetafileHeader; //TMetafileHeader = packed record // Key: LongInt; // Handle: SmallInt; // Box: TSmallRect; // Inch: Word; // Reserved: LongInt; // CheckSum: Word; //end; //PCursorOrIconRec = ^TCursorOrIconRec; //TCursorOrIconRec = packed record // Reserved: Word; // wType: Word; // Count: Word; //end; // // A set of char that works with ansi chars and unicode chars. // Performance is almost the same as "set of char" compiler generated code. // TGMSetOfChar = class protected //FElementsAsBits: array [0..Ord(High(TGMChar)) div (SizeOf(PtrInt)) * 8] of PtrInt; FElementsAsBits: array [0..Ord(High(TGMChar)) div 8] of Byte; public procedure AddChar(AChar: TGMChar); procedure RemoveChar(AChar: TGMChar); // : Boolean; procedure RemoveAllChars; procedure AddAllChars; function Contains(AChar: TGMChar): Boolean; procedure Union(AOther: TGMSetOfChar); end; // // Objects To be used as temprary Reference Items for the TGMObjArrayCollection Find/FindNearest Methods // TGMNameObj = class(TGMRefCountedObj, IGMGetName, IGMHashCode, IGMGetSetName) protected FName: TGMString; public constructor Create(const AName: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload; function GetName: TGMString; virtual; stdcall; procedure SetName(const ANewName: TGMString); virtual; stdcall; function HashCode: TGMHashCode; property Name: TGMString read GetName write SetName; end; TGMIntegerObj = class(TGMRefCountedObj, IGMHashCode) protected FValue: PtrInt; public constructor Create(const AValue: PtrInt; const ARefLifeTime: Boolean = True); reintroduce; function HashCode: TGMHashCode; property Value: PtrInt read FValue; end; TGMPositionObj = class(TGMIntegerObj, IGMGetPosition) public destructor Destroy; override; function GetPosition: PtrInt; virtual; stdcall; end; TGMLeftObj = class(TGMIntegerObj, IGMGetLeft) public function GetLeft: LongInt; virtual; stdcall; end; TGMGuidObj = class(TGMRefCountedObj, IGMGetGUID) protected FGuid: TGUID; public constructor Create(const AGuid: TGUID; const ARefLifeTime: Boolean = True); reintroduce; function GetGUID: TGUID; stdcall; property Guid: TGUID read FGuid; end; TGMNameAndPosObj = class(TGMNameObj, IGMGetPosition) protected FPosition: PtrInt; public constructor Create(const AName: TGMString; const APosition: LongInt; const ARefLifeTime: Boolean = True); reintroduce; virtual; function GetPosition: PtrInt; virtual; stdcall; end; TGMNameAndStrValueObj = class(TGMNameObj, IGMGetStringValue, IGMGetUnionValue, IGMGetText, IGMGetSetStringValue, IGMGetSetUnionValue, IGMGetSetText) protected FStrValue: TGMString; public constructor Create(const AName, AStrValue: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload; function GetStringValue: TGMString; virtual; procedure SetStringValue(const AStrValue: TGMString); virtual; function GetUnionValue: RGMUnionValue; virtual; procedure SetUnionValue(const AUnionValue: RGMUnionValue); virtual; function GetText: TGMString; virtual; stdcall; procedure SetText(const AStrValue: TGMString); virtual; stdcall; property StrValue: TGMString read GetStringValue write SetStringValue; end; TGMNameAndValueObj = class(TGMNameObj, IGMGetUnionValue, IGMGetStringValue, IGMGetText, IGMLoadStoreData, IGMGetSetUnionValue, IGMGetSetText) protected FValue: RGMUnionValue; public constructor Create(const AName: TGMString; const AValue: RGMUnionValue; const ARefLifeTime: Boolean = True); reintroduce; overload; function GetKeyValue: RGMUnionValue; virtual; // function GetName: TGMString; virtual; stdcall; // procedure SetName(const AValue: TGMString); virtual; stdcall; function GetUnionValue: RGMUnionValue; virtual; function GetStringValue: TGMString; procedure SetUnionValue(const AUnionValue: RGMUnionValue); virtual; function GetText: TGMString; virtual; stdcall; procedure SetText(const AValue: TGMString); virtual; stdcall; procedure LoadData(const ASource: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); virtual; stdcall; procedure StoreData(const ADest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData = nil); virtual; stdcall; // function HashCode: TGMHashCode; property Value: RGMUnionValue read GetUnionValue write SetUnionValue; end; TGMUserAccountObj = class(TGMRefCountedObj, IGMUserAccount) protected FUsername: TGMString; FPassword: TGMString; // FDomain: TGMString; FSaveUserData: Boolean; 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; public constructor Create(const AUsername, APassword: TGMString; const ASAveUserData: Boolean = cDfltSaveUSerData; const ARefLifeTime: Boolean = True); reintroduce; end; RGMNameAndStrValue = record Name: TGMString; StrValue: TGMString; //function Init(const AName, AStrValue: TGMString): RGMNameAndStrValue; procedure Init(const AName, AStrValue: TGMString); end; PGMNameAndStrValArray = ^TGMNameAndStrValArray; TGMNameAndStrValArray = Array of RGMNameAndStrValue; function InitRGMNameAndStrValue(const AName, AStrValue: TGMString): RGMNameAndStrValue; { ----------------------- } { ---- Smart classes ---- } { ----------------------- } type TGMDLLHandleObj = class(TGMHandleObj) protected FLoadErrorCode: DWORD; public constructor Create(const ADLLFilePath: TGMString; const ACheckSuccess: Boolean = False; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; end; TGMIconHolder = class(TGMHandleObj) public destructor Destroy; override; end; TStringReplaceRec = record SearchStr: TGMString; Replacement: TGMString; end; RPathWalkData = record ValuePart, MaskPart: TGMString; ValueChPos, MaskchPos: PtrInt; end; { ------------------------- } { ---- Global Routines ---- } { ------------------------- } { ---- Data Load Store ---- } //function GMReadValidRect(const Source: IGMValueStorage; const RectName: TGMString; var Value: TRect; const DefaultValue: LongInt = cInvalidUIPos): Boolean; function GMReadRect(const ASource: IGMValueStorage; const ARectName: TGMString; const ADefaultRect: TRect): TRect; procedure GMWriteRect(const ADest: IGMValueStorage; const ARectName: TGMString; const AValue: TRect; const ADefaultValue: LongInt = cInvalidUIPos); //function GMFontStyleToInt(const Value: TFontStyles): LongInt; //function GMFontStyleFromInt(const Value: LongInt): TFontStyles; //procedure GMReadFont(const Source: IGMValueStorage; const FontName: TGMString; const Font: TFont); //procedure GMWriteFont(const Dest: IGMValueStorage; const FontName: TGMString; const Font: TFont); { ---- AStream routines ---- } function GMIStreamHasSignature(const AStream: IStream; const AFormatSig: AnsiString): Boolean; function GMIStreamContainsJpeg(const AStream: IStream): boolean; function GMIStreamContainsGIF(const AStream: IStream): boolean; function GMIStreamContainsBmp(const AStream: IStream): boolean; function GMIStreamReadStrA(const AStream: ISequentialStream): AnsiString; function GMIStreamReadStrW(const AStream: ISequentialStream): UnicodeString; procedure GMIStreamWriteStrA(const AStream: ISequentialStream; const AValue: AnsiString); procedure GMIStreamWriteStrW(const AStream: ISequentialStream; const AValue: UnicodeString); function GMReadBOMCharKind(const AStream: IStream; const ADefaultChKind: TGMCharKind = ckAnsi): TGMCharKind; procedure GMWriteBOM(const ADestStream: ISequentialStream; const ACharKind: TGMCharKind); function GMIStreamContainsASCIIText(const AStream: IStream): Boolean; function GMIStreamContainsXml(const AStream: IStream): Boolean; procedure GMConsumeStreamContent(const AStream: ISequentialStream; const ABufferSize: LongInt = $8000); // ---- String type conversion ---- // //function GMStrToHexStr(const AValue: AnsiString): AnsiString; <- Use GMCharCoding.GMEncodeBase16Str instead //function GMHexStrToStr(const AValue: AnsiString): AnsiString; <- Use GMCharCoding.GMDecodeBase16Str instead {$IFDEF DELPHI9} function GMIntToStr(const AValue: QWord): TGMString; overload; {$ENDIF} function GMIntToStr(const AValue: Int64): TGMString; overload; function GMIntToStr(const AValue: LongInt): TGMString; overload; function GMIntToHexStr(AValue: LongInt): TGMString; overload; function GMIntToHexStr(AValue: Int64): TGMString; overload; {$IFDEF DELPHI9} function GMIntToHexStr(AValue: QWord): TGMString; overload; {$ENDIF} { $IFDEF DELPHI9} function GMStrToInt(const AValue: TGMString): Int64; // overload; { $ENDIF} //function GMStrToInt(const AValue: TGMString): LongInt; {$IFDEF DELPHI9}overload;{$ENDIF} function GMStrToInt32(const AValue: TGMString): LongInt; function GMStrToUInt32(const AValue: TGMString): LongWord; function GMStrToInt64(const AValue: TGMString): Int64; {$IFDEF DELPHI9} function GMStrToUInt64(const AValue: TGMString): QWord; {$ENDIF} function GMStrToSingle(AValue: TGMString): Single; function GMStrToDouble(AValue: TGMString): Double; function GMStrToCurrency(AValue: TGMString): Currency; function GMSingleToStr(const AValue: Single; const AWidth: Integer = -1; const APrecision: Integer = -1): TGMString; function GMDoubleToStr(const AValue: Double; const AWidth: Integer = -1; const APrecision: Integer = 17): TGMString; function GMExtendedToStr(const AValue: Extended; const AWidth: Integer = -1; const APrecision: Integer = -1): TGMString; function GMCurrencyToStr(const AValue: Currency; const AWidth: Integer = -1; const APrecision: Integer = -1): TGMString; // ---- String routines ---- // function GMIsPrefixStr(const APrefix, AValue: TGMString; const AIngoreCase: Boolean = True): Boolean; function GMIsDigitA(ACh: AnsiChar): Boolean; function GMIsDigit(ACh: TGMChar): Boolean; function GMIsLetter(ACh: TGMChar): Boolean; // Froward string scan until = ACh function GMStrLScanA(AStr: PAnsiChar; ACh: AnsiChar; AMaxLen: PtrUInt): PAnsiChar; assembler; register; function GMStrLScanW(AStr: PWideChar; ACh: WideChar; AMaxLen: PtrUInt): PWideChar; assembler; register; function GMStrLScan(AStr: PGMChar; ACh: TGMChar; AMaxLen: PtrUInt): PGMChar; // Reverse string scan until = ACh function GMStrRLScanA(AStr: PAnsiChar; ACh: AnsiChar; AMaxLen: PtrUInt): PAnsiChar; assembler; register; function GMStrRLScanW(AStr: PWideChar; ACh: WideChar; AMaxLen: PtrUInt): PWideChar; assembler; register; function GMStrRLScan(AStr: PGMChar; ACh: TGMChar; AMaxLen: PtrUInt): PGMChar; // Froward string scan until <> ACh function GMStrCLScanA(AStr: PAnsiChar; ACh: AnsiChar; AMaxLen: PtrUInt): PAnsiChar; assembler; register; function GMStrCLScanW(AStr: PWideChar; ACh: WideChar; AMaxLen: PtrUInt): PWideChar; assembler; register; function GMStrCLScan(AStr: PGMChar; ACh: TGMChar; AMaxLen: PtrUInt): PGMChar; // Reverse string scan until <> ACh function GMStrCRLScanA(AStr: PAnsiChar; ACh: AnsiChar; AMaxLen: PtrUInt): PAnsiChar; assembler; register; function GMStrCRLScanW(AStr: PWideChar; ACh: WideChar; AMaxLen: PtrUInt): PWideChar; assembler; register; function GMStrCRLScan(AStr: PGMChar; ACh: TGMChar; AMaxLen: PtrUInt): PGMChar; function GMStrLScanPos(const AValue: TGMString; AChToFind: TGMChar; AStartChPos: PtrInt = 1): PtrInt; function GMStrScanA(AStr: PAnsiChar; ACh: AnsiChar): PAnsiChar; assembler; register; function GMStrScanW(AStr: PWideChar; ACh: WideChar): PWideChar; assembler; register; function GMStrScan(AStr: PGMChar; ACh: TGMChar): PGMChar; function GMStrLCompA(const AStr1, AStr2: PAnsiChar; AMaxLen: PtrUInt): PtrInt; assembler; register; function GMStrLCompW(const AStr1, AStr2: PWideChar; AMaxLen: PtrUInt): PtrInt; assembler; register; function GMStrLComp(const AStr1, AStr2: PGMChar; AMaxLen: PtrUInt): PtrInt; //function GMStrComp(const Str1, Str2: TGMString): LongInt; function GMCompareMemory(const AContents1, AContents2: Pointer; const AMaxLenInBytes: PtrUInt): TGMCompareResult; function GMStrLICompA(const AStr1, AStr2: PAnsiChar; AMaxLen: PtrUInt): LongInt; assembler; register; function GMStrLICompW(const AStr1, AStr2: PWideChar; AMaxLen: PtrUInt): LongInt; assembler; register; function GMStrLIComp(const AStr1, AStr2: PGMChar; AMaxLen: PtrUInt): LongInt; function GMSameText(const AValue1, AValue2: TGMString): Boolean; //function GMStrScanPas(const AValue: PGMChar; Ch: TGMChar): PGMChar; function GMIsDelimiterA(const ADelimiters, AValue: AnsiString; ACharIndex: PtrInt): Boolean; {$IFDEF DELPHI9}inline;{$ENDIF} function GMIsDelimiterW(const ADelimiters, AValue: UnicodeString; ACharIndex: PtrInt): Boolean; {$IFDEF DELPHI9}inline;{$ENDIF} function GMIsDelimiter(const ADelimiters, AValue: TGMString; ACharIndex: PtrInt): Boolean; {$IFDEF DELPHI9}inline;{$ENDIF} function GMLastDelimiter(const ADelimiters, AValue: TGMString): PtrInt; function GMIsNumber(const AValue: TGMString): Boolean; function GMDeleteLastWord(const Value: TGMString; const Separators: TGMString): TGMString; function GMDeleteFirstWord(const Value: TGMString; const Separators: TGMString; const StripSeparators: Boolean = True): TGMString; function GMDeleteFirstWords(const Value: TGMString; const WordCount: LongInt; const Separators: TGMString): TGMString; function GMDeleteNextWord(const AchPos: PtrInt; const Value, Separators: TGMString): TGMString; function GMDeleteChars(const Value: TGMString; const ADelChars: TGMString; const ANotDelChars: Boolean = False): TGMString; function GMDeleteCharsA(const AValue: AnsiString; const ADelChars: AnsiString; const ANotDelChars: Boolean = False): AnsiString; function GMDeleteWords(const AValue: TGMString; const AWords: array of TGMString; const ASeparators: TGMString; const AWholeWords: Boolean = True; const AIgnoreCase: Boolean = True): TGMString; function GMKeepWords(const AValue: TGMString; const AWords: array of TGMString; const ASeparators: TGMString; const AWholeWords: Boolean = True; const AIgnoreCase: Boolean = True): TGMString; function GMNextWord(var AChPos: PtrInt; const AValue: TGMString; ASeparatorChar: TGMChar; const ASkipLeadingSeparators: Boolean = True): TGMString; overload; function GMNextWord(var AChPos: PtrInt; const AValue, ASeparators: TGMString; const ASkipLeadingSeparators: Boolean = True): TGMString; overload; function GMFirstWord(const AValue: TGMString; const ASeparators: TGMString; const ASkipLeadingSeparators: Boolean = True): TGMString; function GMLastWord(const AValue: TGMString; const ASeparators: TGMString; const ASkipTrailingSeparators: Boolean = True): TGMString; function GMNThWord(const AValue: TGMString; const AWordNummber: Word; const ASeparators: TGMString; const AFromSide: ERightLeftSide = rlsLeft): TGMString; function GMWordCount(const AText, ASeparators: TGMString): LongInt; function GMNextLine(var AChPos: PtrInt; const AText: TGMString): TGMString; function GMPreviousWord(var AChPos: PtrInt; const AValue, ASeparators: TGMString; const ASkipTrailingSeparators: Boolean = True): TGMString; //function GMFirstLine(const AValue: TGMString): TGMString; function GMStrip(const AValue: TGMString; const AChars: TGMString = cWhiteSpace; const ANotStripChars: Boolean = False): TGMString; function GMStripRight(const AValue: TGMString; const AChars: TGMString = cWhiteSpace): TGMString; function GMStripLeft(const AValue: TGMString; const AChars: TGMString = cWhiteSpace): TGMString; function GMTrimLeftA(const AValue: AnsiString; AChar: AnsiChar = ' '): AnsiString; function GMTrimLeftW(const AValue: UnicodeString; AChar: WideChar = ' '): UnicodeString; function GMTrimLeft(const AValue: TGMString; AChar: TGMChar = ' '): TGMString; function GMTrimRightA(const AValue: AnsiString; AChar: AnsiChar = ' '): AnsiString; function GMTrimRightW(const AValue: UnicodeString; AChar: WideChar = ' '): UnicodeString; function GMTrimRight(const AValue: TGMString; AChar: TGMChar = ' '): TGMString; function GMTrim(const AStr: TGMString; AChar: TGMChar = ' '): TGMString; //function GMTermSentence(const AStr: TGMString): TGMString; function GMTerminateStr(const AStr: TGMString; const ATermination: TGMString = '.'): TGMString; function GMFindToken(const AText, AToken: TGMString; var AChPos: PtrInt; const ASeparators: TGMString; AWholeWords: Boolean = True; const AIgnoreCase: Boolean = True): Boolean; function GMHasToken(const AValue, AToken, ASeparators: TGMString; AWholeWords: Boolean = True; AIgnoreCase: Boolean = True): Boolean; function GMTokenCount(const AValue, AToken, ASeparators: TGMString; AWholeWords: Boolean = True; AIgnoreCase: Boolean = True): LongInt; function GMReplaceChars(const AValue: TGMString; const AFindChars, AReplacements: TGMString): TGMString; function GMReplaceWords(const AValue: TGMString; const AOldWord, ANewWord, Separators: TGMString; const AIgnoreCase: Boolean = True): TGMString; function GMFindOneOfWords(const AText, Separators: TGMString; const AWords: array of TGMString; var chPos: PtrInt; const AIgnoreCase: Boolean = True): Boolean; function GMFindTextPart(const AText, Separators: TGMString; const AStartWords, EndWords: array of TGMString; const AIgnoreCase: Boolean = True): TGMString; function GMReplaceTextPart(const AText: TGMString; const ASeparators, NewPart: TGMString; const AStartWords, AEndWords: array of TGMString; const AIgnoreCase: Boolean = True): TGMString; function GMCommonPrefixLen(const Str1, Str2: TGMString; const IngoreCase: Boolean = True): LongInt; function GMQuote(const AValue: TGMString; const ALeftQuote: TGMChar = '"'; const ARightQuote: TGMChar = '"'): TGMString; //function GMRemoveQuotes(const AValue: TGMString; const ALeftQuotes: TGMString = '"'; const ARightQuotes: TGMString = '"'): TGMString; function GMRemoveQuotes(const AValue: TGMString; const ALeftQuote: TGMchar = '"'; const ARightQuote: TGMChar = '"'): TGMString; //function SysStringLen(const S: UnicodeString): LongInt; stdcall; external 'oleaut32.dll' name 'SysStringLen'; function GMIsOneOfStrings(const AValue: TGMString; const AStrings: array of TGMString; const AIgnoreCase: Boolean = True): Boolean; function GMFixedEncodeDateTime(const AValue: TDateTime): TGMString; function GMFixedDecodeDateTime(const AValue: TGMString): TDateTime; function GMStrToDateTime(const AValue, AFormat: TGMString): TDateTime; function GMHasDateTimeFormat(const AValue, AFormat: TGMString): Boolean; function GMCompareVersions(const AVersionA, AVersionB: TGMString): TGMCompareResult; function GMUpCaseW(ACh: WideChar): WideChar; function GMUpCaseA(ACh: AnsiChar): AnsiChar; function GMUpCase(ACh: TGMChar): TGMChar; function GMLoCaseW(ACh: WideChar): WideChar; function GMLoCaseA(ACh: AnsiChar): AnsiChar; function GMLoCase(ACh: TGMChar): TGMChar; function GMUpperCaseA(const AValue: AnsiString): AnsiString; function GMUpperCaseW(const AValue: UnicodeString): UnicodeString; function GMUpperCase(const AValue: TGMString): TGMString; function GMLowerCase(const AValue: TGMString): TGMString; function GMHashCodeFromString(const AValue: TGMString): TGMHashCode; function GMInsertEscapeChars(const AValue: TGMString): TGMString; function GMResolveEscapeChars(const AValue: TGMString; const ACaller: TObject = nil): TGMString; function GMInsertQuotedStrEscChars(const AValue: TGMString): TGMString; function GMResolveQuotedStrEscChars(const AValue: TGMString; const ACaller: TObject = nil): TGMString; { ---- complex string manipulations ---- } //function GMResolveEscapeChars(const Value: TGMString; const EscCh: TGMChar): TGMString; function GMMakeSingleLine(const AValue: TGMString; const ANewLineStr: TGMString = ', '; const AEmitEmptyLines: Boolean = False): TGMString; function GMReduceWhiteSpace(const AValue: TGMString): TGMString; //function GMFullLineBreaks(const Value: TGMString): TGMString; function GMInsertXMLLineBreaks(const AValue: TGMString): TGMString; function GMBlockIndent(const AValue, AIndent: TGMString; const AStrip: Boolean = True): TGMString; function GMReplaceStrings(const AValue: TGMString; const AReplacements: array of TStringReplaceRec; const AMatchCase: Boolean = False): TGMString; function GMExpandEnvironmentStrings(const APath: TGMString): TGMString; function GMExpandPath(const APath: TGMString; ARootPath: TGMString = ''; const ADirSep: TGMString = '\'): TGMString; function GMLimitedTextExtract(const AValue: TGMString; const AMaxLineCount, AMaxLineLength: Integer; const ARemoveEmptyLines: Boolean = True): TGMString; { ---- TGMString Buffer Routines ---- } //function GMStrLen(AValue: PGMChar): LongWord; function GMStrLenA(const AStr: PAnsiChar; AMaxLenInChars: PtrInt = -1): PtrInt; function GMStrLenW(const AStr: PWideChar; AMaxLenInChars: PtrInt = -1): PtrInt; function GMStrLen(const AStr: PGMChar; AMaxLenInChars: PtrInt = -1): PtrInt; //function GMStrNLen(const Value: PAnsiChar; const AMaxLen: Integer): LongWord; //function GMWStrNLen(const Value: PWideChar; const MaxLen: Integer): LongWord; //function GMStrLenA(const Value: PAnsiChar; const MaxLen: LongInt = -1): LongInt; //function GMBufferAsString(const Buffer: Pointer; MaxLen: LongInt = -1): AnsiString; //function GMStrLenW(const Value: PWideChar; const MaxLen: LongInt = -1): LongInt; //function GMBufferAsWideString(const Buffer: Pointer; MaxLen: LongInt = -1): UnicodeString; { ---- filepath / doc routines ---- } function GMFileSystemEntry(const FilePath: TGMString): IGMFileProperties; function GMFindDataFileSize(const FindData: TWin32FindData): Int64; function GMFileExists(const AFileName: TGMString): Boolean; procedure GMCheckFileExists(const AFileName: TGMString; const Caller: TObject = nil; const CallingName: TGMString = cDfltRoutineName); procedure GMCheckFileOpenReadOnly(const AFileName: TGMString; const OpenReadOnly: Boolean; const Caller: TObject = nil; const CallingName: TGMString = cDfltRoutineName); function GMFolderExists(const AFolderName: TGMString): Boolean; function GMFileOrFolderExists(const AFileName: TGMString): Boolean; procedure GMCreatePath(DirPath: TGMString; const Caller: TObject = nil); function GMApplicationExeName: TGMString; function GMTempFileName(AFolderPath: TGMString = ''; Prefix: TGMString = CGMTempFilePrefix; Extension: TGMString = CGMTempFileExtension): TGMString; function GMModuleFileName(const ModuleHandle: HMODULE): TGMString; function GMThisModuleFileName: TGMString; function GMExecutableForDocExt(DocExt: TGMString): TGMString; function GMAppFileWithExtension(const AExtension: TGMString): TGMString; function GMChangeFileExt(const AFileName, ANewExtension: TGMString): TGMString; function GMIsRelativePath(const APath: TGMString): Boolean; function GMTermPath(const Path: TGMString; const Separator: TGMString = '\'): TGMString; function GMAbsPath(const APath: TGMString; const AAbsStart: TGMString = '\'): TGMString; function GMApplyRelativePath(const Path, RelativePath: TGMString): TGMString; function GMAppendPath(const APath1, APath2: TGMString; const APathSep: TGMString = '\'): TGMString; function GMBuildPath(const APathParts: array of TGMString; const APathSep: TGMString = '\'): TGMString; function GMAppendStrippedPath(const Path1, Path2: TGMString; const Separator: TGMString = '\'): TGMString; function GMParentDir(const APath: TGMString): TGMString; function GMFullPathName(const AFileName: TGMString): TGMString; function GMLongPathName(const AShortPathName: TGMString): TGMString; function GMFileHasExtension(const AFileName, FileExtension: TGMString): Boolean; function GMFileVersionInfo(const AFileName: TGMString; const VersionInfoKey: TGMVersionResInfo; const AAnsiData: Boolean = True): TGMString; function GMExeVersionInformation(const AVersionInfoKey: TGMVersionResInfo): TGMString; function GMIsValidFileName(const AFileName: TGMString; const AInvalidChars: TGMString = cInvalidFileNameChars): Boolean; procedure GMCheckIsValidFileName(const AFileName: TGMString; const AInvalidChars: TGMString = cInvalidFileNameChars; const Caller: TObject = nil; const CallingName: TGMString = ''); function GMExtractFileName(const AFilePath: TGMString): TGMString; function GMExtractPath(const AFilePath: TGMString): TGMString; function GMExtractPathWithoutDrive(const AFilePath: TGMString): TGMString; function GMExtractFileExt(const AFilePath: TGMString): TGMString; function GMExtractFileBaseName(const AFilePath: TGMString): TGMString; function GMExtractDrive(const AFilePath: TGMString): TGMString; function GMIsStringMatch(const AValue, AMask: TGMString; const AMatchEmptyMask: Boolean = True; const ACharIndex: LongInt = 1): Boolean; function GMWalkPathMask(const AValue, AMask, ADirSeparators: TGMString; var AWalkData: RPathWalkData): Boolean; function GMIsAbsPathMatch(const AValue, AMask, ADirSeparators: TGMString): Boolean; function GMIsSingleMaskMatch(const AFileName, ASingleMask, ADirSeparators: TGMString; const AMatchCase: Boolean): Boolean; function GMIsAnyMaskMatch(const AFileName, AMultiMask, ADirSeparators: TGMString; const AMatchEmptyMask: Boolean = True; const AMatchCase: Boolean = False; const AMaskSeparators: TGMString = ';'): Boolean; { ---- Type Check/Convert ---- } function GMDateIsNull(const AValue: TDateTime): Boolean; function GMTimeIsNull(const AValue: TDateTime): Boolean; function GMVarToNum(const AValue: OleVariant; const ADefaultValue: LongInt = 0): OleVariant; function GMVarToInt(const AValue: OleVariant; const ADefaultValue: LongInt = 0): LongInt; function GMVarToFloat(const AValue: OleVariant; const ADefaultValue: double = 0.0): OleVariant; function GMVarToNULLStr(const AValue: OleVariant): TGMString; function GMStrToNULLVar(const AValue: TGMString): Variant; function GMMakeDezInt(const AValue: TGMString; const ADefaultValue: Int64 = 0): TGMString; function GMMakeFloat(const AValue: TGMString; const ADefaultValue: Double = 0): TGMString; function GMVarIsNullOrEmpty(const AValue: Variant): Boolean; function GMVarToStr(const AValue: OleVariant): TGMString; function GMVarToQuotedStr(const AValue: OleVariant): TGMString; function GMStrToBool(const AValue: TGMString): Boolean; function GMBoolToStr(AValue: Boolean; const AStrFalse: TGMString = ''; const AStrTrue: TGMString = ''): TGMString; function GMGetTimeZoneInfoByRegistryKeyName(const ATimeZoneRegKeyName: TGMString; var ATimeZoneData: TIME_ZONE_INFORMATION): Boolean; function GMUTCToLocalTime(const AUtcTime: TDateTime; const ALocalTimeZone: PTIME_ZONE_INFORMATION = nil; const ACaller: TObject = nil): TDateTime; function GMLocalTimeToUTC(const ALocalTime: TDateTime; const ALocalTimeZone: PTIME_ZONE_INFORMATION = nil; const ACaller: TObject = nil): TDateTime; function GMDateTimeToFileTime(const AValue: TDateTime; const ACaller: TObject = nil): TFileTime; function GMFileTimeToDateTime(const AValue: TFileTime; const ACaller: TObject = nil): TDateTime; function GMUnixTimeToDateTime(const AUnixTime: Int64): TDateTime; function GMUnixTimeFromDateTime(const ADateTime: TDateTime): Int64; { ---- formating ---- } function GMDateTimeToStr(const ADateTime: TDateTime): TGMString; function GMIntWithThousandSep(const Value: Int64): TGMString; function GMFileSizeAsString(const FileSize: Int64): TGMString; function GMFileAttrAsString(const FileEntry: IGMFileProperties; const Separator: TGMString = ', '): TGMString; function GMFileEntryAsString(const FileEntry: IGMFileProperties; const Separator: TGMString = ', '): TGMString; function GMFormat(const AFormatStr: TGMString; const Args: array of const): TGMString; function GMStringToUtf8(const AValue: UnicodeString): AnsiString; function GMUtf8ToString(const AValue: AnsiString): UnicodeString; { ---- Rectangle Routines ---- } function GMRect(const ALeft, ATop, ARight, ABottom: LongInt): TRect; overload; inline; function GMRect(const ATopLeft, ABottomRight: TPoint): TRect; overload; inline; function GMPoint(const AX, AY: LongInt): TPoint; inline; function GMSize(const cx, cy: LongInt): TSize; inline; function GMInflateRect(const R: TRect; const dx: LongInt = 0; const dy: LongInt = 0): TRect; inline; function GMMoveRect(const R: TRect; const dx: LongInt = 0; const dy: LongInt = 0): TRect; overload; inline; function GMMoveRect(const R: TRect; const Delta: TPoint): TRect; overload; inline; function GMRectModifiedBy(const R: TRect; const dLeft: LongInt = 0; const dTop: LongInt = 0; const dRight: LongInt = 0; const dBottom: LongInt = 0): TRect; function GMRectIntersection(const R1, R2: TRect): TRect; function GMRectUnion(const R1, R2: TRect): TRect; function GMCenterRectInRect(const Inner, Outer: Trect): TRect; function GMCenterExtent(const AValue: LongInt; const ASize: TPoint): TPoint; function GMCenterExtentInRect(const ASize: TPoint; const ARect: TRect): TRect; function GMRectSize(const ARect: TRect): TPoint; function GMLayoutRect(const RDraw: TRect; const LayoutSize: TPoint; const HAlignment: TGMHorizontalAlignment; const VAlignment: TGMVerticalAlignment): TRect; function GMPointOffsBy(const APoint: TPoint; const ADelta: LongInt): TPoint; function GMAddPoints(const APointA, APointB: TPoint; const AScale: SmallInt = 1): TPoint; function GMEqualPoints(const PointA, PointB: TPoint): Boolean; deprecated 'Use "PointA = PointB or PointA <> PointB" instead (TPoint.Equal operator)'; procedure GMExchangeLongInt(var AValue1, AValue2: LongInt); procedure GMExchangePtrInt(var AValue1, AValue2: PtrInt); { ---- window Stack ---- } function GMTopwindow: HWnd; procedure GMPushModalDlgWnd(AWnd: HWnd); function GMPopModalDlgWnd: HWnd; function GMWndStackCloseAll(const AStopAtWnd: HWnd = 0; const AModalResult: LongInt = IDCLOSE; const AMessage: LongInt = WM_CLOSE): LongInt; { ---- Registered Classes ---- } function GMIsClass(AClassInstance, AClass: TClass): Boolean; function GMIsClassByName(const AObj: TObject; const AClass: TClass): Boolean; { ---- Compiler Design Interface ---- } function GMGetOrdinalProperty(const AObject: TObject; const PropertyName: TGMString; var PropertyValue: LongInt): Boolean; function GMGetStringProperty(const AObject: TObject; const PropertyName: TGMString; var PropertyValue: TGMString): Boolean; function GMSetStringProperty(const AObject: TObject; const PropertyName: TGMString; const PropertyValue: TGMString): Boolean; // GMAssignObjProperties works only for classes declared with the $M+ compiler directive function GMCheckGetEnumValFromName(const ATypInfo: PTypeInfo; const AEnumValueName: TGMString): Integer; procedure GMAssignObjProperties(const Source, Dest: TObject; const TypeKinds: TTypeKinds); { ---- Arithmetic Functions ---- } function Min(A, B: LongInt): LongInt; overload; inline; function Min(A, B: Int64): Int64; overload; inline; function Max(A, B: LongInt): LongInt; overload; inline; function Max(A, B: Int64): Int64; overload; inline; function MakeLongInt(Lo, Hi: SmallInt): LongInt; inline; function GMBoundedInt(Value, Min, Max: LongInt; const MinBased: Boolean = True): LongInt; overload; inline; function GMBoundedInt(Value, Min, Max: Int64; const MinBased: Boolean = True): Int64; overload; inline; function GMBoundedDouble(Value, Min, Max: Double; const MinBased: Boolean = True): Double; function GMIsInRange(const Value, Min, Max: LongInt): Boolean; overload; inline; function GMIsInRange(const Value, Min, Max: Int64): Boolean; overload; inline; //function GMAbsInt(const Value: LongInt): LongInt; //function GMAbsPtrInt(AValue: PtrInt): PtrInt; inline; function GMAddPtr(const APointer: Pointer; const AOffset: LongInt): Pointer; overload; inline; function GMAddPtr(const APointer: Pointer; const AOffset: Int64): Pointer; overload; inline; function GMAlignedValue(const AValue, AlignDelta: PtrInt): PtrInt; inline; { ---- Dlg window related ---- } function GMAddMsgBoxIcon(const Flags: LongWord; const Severity: TGMSeverityLevel): LongWord; function GMWindowsMsgBox(const Msg: TGMString; const Severity: TGMSeverityLevel = svInformation; Flags: LongWord = 0; const ParentWnd: HWnd = cDfltPrntWnd): LongInt; stdcall; function GMActiveProcessWindow: HWnd; function GMDlgRootWindow(const AWnd: HWnd): HWnd; function GMAppRootWindow(const AWnd: HWnd = cDfltPrntWnd; const SearchProcess: Boolean = True): HWnd; function GMModalDlgParentWnd(const AParentWnd: HWnd = cDfltPrntWnd; const ASearchProcess: Boolean = True): HWnd; procedure GMRemoveAllMenuItems(const Menu: HMenu); { ---- Exceptions ---- } function GMHrCheckObj(const HRCode: HResult; const Obj: TObject = nil; const ARoutineName: TGMString = cDfltRoutineName; const AMsgPostfix: TGMString = ''; const Strict: Boolean = False; const AHelpCtx: LongInt = cDfltHelpCtx): HResult; function GMHrCheckObjParams(const HRCode: HResult; const Params: array of PGMChar; const Obj: TObject = nil; const ARoutineName: TGMString = cDfltRoutineName; const AMsgPostfix: TGMString = ''; const Strict: Boolean = False; const AHelpCtx: LongInt = cDfltHelpCtx): HResult; procedure GMHrTraceObjParams(const HRCode: HResult; const Params: array of PGMChar; const Obj: TObject = nil; const ARoutineName: TGMString = cDfltRoutineName; const AMsgPostfix: TGMString = ''; const Strict: Boolean = False; const AHelpCtx: LongInt = cDfltHelpCtx); procedure GMHrCheckIntf(const HRCode: HResult; const Intf: IUnknown = nil; const ARoutineName: TGMString = cDfltRoutineName; const AMsgPostfix: TGMString = ''; const Strict: Boolean = False; const AHelpCtx: LongInt = cDfltHelpCtx); procedure GMAPICheckObj(const ARoutineName: TGMString; const AMsgPostfix: TGMString; const AWinApiErrorCode: DWORD; const AWinApiRetVal: BOOL; const AObj: TObject = nil; const AHelpCtx: LongInt = cDfltHelpCtx); procedure GMAPICheckObjParams(const ARoutineName: TGMString; const AMsgPostfix: TGMString; const AWinApiErrorCode: DWORD; const AWinApiRetVal: BOOL; const Params: array of PGMChar; const Obj: TObject = nil; const AHelpCtx: LongInt = cDfltHelpCtx); procedure GMAPICheckObjEx(const ARoutineName: TGMString; const AMsgPostfix: TGMString; const AWinApiErrorCode: DWORD; const AWinApiRetVal: BOOL; const SuccessCodes: array of PtrInt; const Obj: TObject = nil; const AHelpCtx: LongInt = cDfltHelpCtx); function GMExceptObject: TObject; deprecated 'Use: "on ex: TObject do .. ;" instead!'; //function GMExceptAddr: Pointer; { ---- OLE ---- } function OLEFormatEtc(const cfFormat: TClipFormat = 0; const ptd: PDVTargetDevice = nil; const dwAspect: LongInt = DVASPECT_CONTENT; const lindex: LongInt = -1; const tymed: LongInt = TYMED_HGLOBAL): TFormatEtc; function OLEStgMedium(const tymed: LongInt; const handle: THandle; const unkForRelease: Pointer = nil): TStgMedium; overload; function OLEStgMedium(const tymed: LongInt; const pUnknown: Pointer; const unkForRelease: Pointer = nil): TStgMedium; overload; function OLEStgMedium(const tymed: LongInt; const lpszFileName: POleStr; const unkForRelease: Pointer = nil): TStgMedium; overload; //function GMFindOleServerForClassId(const ClassId: TGUID; var OleServer: TGMString; var IconIndex: LongInt): Boolean; { ---- system ---- } function GMWindowsDir: TGMString; function GMWinSystemDir: TGMString; function GMWinTempDir: TGMString; function GMCurrentDir: TGMString; {$IFDEF JEDIAPI} procedure GMGetUserAndDomainNames(var AUserName, ADomainName: TGMString); {$ENDIF} function GMThisComputerName: TGMString; function GMThisUserName: TGMString; function GMThisUserSID: TGMString; procedure GMGetAllUserNames(var AUserNames: TGMStringArray); procedure GMGetAllUserSettingsDirectories(var ADirectories: TGMStringArray; const ASubDirName: TGMString); function GMWinVersion: TGMWinVersion; function GMIs64BitOS: BOOL; function GMPointerSizeInBits: Integer; function GMPointerSizeAsString(const AAddLeft: TGMString = ''; const AAddRight: TGMString = ''): TGMString; function GMMousePosition: TPoint; procedure GMRefreshMouseCursor; procedure GMSetCaretPos(const ACaretPos: TPoint); function GMSetLayeredWindowAttributes(Wnd: HWnd; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): BOOL; function GMCanUseLayeredWindows: Boolean; function GMGetProcAddress(const AModuleName: TGMString; const AProcName: AnsiString; const ACheck: Boolean = True): Pointer; procedure GMLoadProcAddress(const AModuleName: TGMString; const AProcName: AnsiString; var AProc); procedure GMSplitParameterStr(AParameterStr: PGMChar; var ADestParams: TGMStringArray); function GMParseCommandLine(var ADestParams: TGMStringArray): TGMString; // <- returns the application path+name { ---- Tracing ---- } //procedure GMIterateLines(const AText: TGMString; const ALineProc: TProcessLineProc; const AData: Pointer); function GMDfltDoTracing: Boolean; stdcall; procedure GMDfltTraceLine(const ALine: TGMString); procedure GMDfltTrace(const AText: TGMString; const APrefix: TGMString = ''); procedure GMTraceMethod(const AObj: TObject; const AMethodName: TGMString; const AText: TGMString = ''); procedure GMTraceException(const AException: TObject; const ASingleLine: Boolean = True); procedure GMTraceAllInterfaces(const AIntf: IUnknown; const AName: TGMString); { ---- Exception handling ---- } function GMPresentExceptionUI(const AException: TObject): Boolean; function GMHResultFromWin32(const AWinErrorCode: LongWord; const AFacilitycode: LongWord = FACILITY_WIN32): HResult; //function GMWin32FromHResult(const HRCode: HResult): LongWord; function GMDfltExecExceptionDlg(const AException: TObject; const AParentWnd: HWnd= cDfltPrntWnd): LongInt; stdcall; //function GMDfltVerboseExceptionMessages: Boolean; stdcall; function GMDfltHrExceptionHandler(const AException: TObject; const AParentWnd: HWnd; const ADefaultCode: HResult = E_UNEXPECTED): HResult; stdcall; // cHrPrntWnd function GMBuildExceptionMsg(const AExceptInfo: IGMExceptionInformation; const AVerbose: Boolean = {$IFDEF DEBUG}True{$ELSE}False{$ENDIF}): TGMString; function GMMsgFromExceptObj(const AException: TObject; const AVerbose: Boolean = {$IFDEF DEBUG}True{$ELSE}False{$ENDIF}): TGMString; function GMExceptionSeverity(const AException: TObject; const ADefaultValue: TGMSeverityLevel = svError): TGMSeverityLevel; function GMIsFatalException(const AExceptObject: TObject): Boolean; function GMAskExceptionContinue(const AException: TObject; const ErrorAction: TGMErrorAction; AskContinue: TGMString = ''; const ParentWnd: HWnd = cDfltPrntWnd): Boolean; function GMModuleErrorMessage(const ModuleFileName: TGMString; const ErrorCode: DWORD): TGMString; { ---- Compare Routines ---- } // LINGUISTIC_IGNORECASE ?? function GMCompareNames(const AName1, AName2: TGMString; const ACmpareFlags: DWORD = NORM_IGNORECASE; ALocale: LCID = 0): TGMCompareResult; function GMCompareByLeft(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByName(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByString(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByNameDigitsAsNumbers(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByFileName(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByPosition(const ItemA, ItemB: IUnknown): TGMCompareResult; //function GMCompareByKeyValue(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByInstance(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByGuid(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareByHandle(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareFileEntryByName(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareFileEntryBySize(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareFileEntryByLastMod(const ItemA, ItemB: IUnknown): TGMCompareResult; function GMCompareVariants(const ValueA, ValueB: Variant; const MatchCase: Boolean = True): TGMCompareResult; function GMCompareUnionValues(const ValueA, ValueB: RGMUnionValue; const MatchCase: Boolean = True): TGMCompareResult; { ---- Message processing ---- } function GMHotKeyRec(const AFlags: Byte; const AKey, ACommand: Word): TAccel; function GMTranslateAndDispatchMsg(var AMsg: TMsg): LRESULT; procedure GMProcessAllMessages; procedure GMProcessMessages(const AMessages: array of LongInt); function GMMsgLoopWaitForMultipleObjects(const AHandleCount: DWORD; const AHandles: Pointer; const AProcessMessages: Boolean; const AWaitTimeoutMilliSec: DWORD = INFINITE; const AWaitForAll: BOOL = False): DWORD; function GMExecProcess(const ACmdLine: TGMString; const AProcessFlags: DWORD = 0; const AWaitForTermination: Boolean = False; const AUserToken: THandle = 0; const AWaitForInputReady: Boolean = True): DWORD; { ---- creators ---- } function GMIntfConnectData(const IID: TGUID; const Required: Boolean = cDfltIIDRequired): TGMIntfConnectDataRec; function GMStringReplaceRec(const ASearchStr, AReplacement: TGMString): TStringReplaceRec; { ---- global memory ---- } //procedure GMFreeMetafileHandle(const HMetaFile: HGlobal); function GMCopyToGlobalMem(const PData: Pointer; const DataSize: LongWord; const AllocFlags: LongWord = GMEM_MOVEABLE): HGlobal; function GMCopyHGlobal(const Handle: HGLOBAL; const AllocFlags: LongWord = GMEM_MOVEABLE): HGLOBAL; { ---- TGMString Arrays ---- } procedure GMParseLinesToStrArray(const AMultiLineText: TGMString; var ADstLines: TGMStringArray; const AddEmptyLines: Boolean = False); procedure GMSplitWordsToStrArray(const AValue, ASeparators: TGMString; const AAllowDuplicates: Boolean; var ADestStrings: TGMStringArray); { ---- Other ---- } function GMErrorActionName(const ErrorAction: TGMErrorAction): TGMString; //procedure GMAssignImgFromRes(const Picture: TPicture; const ResourceName: TGMString; const GraphicClass: TGraphicClass; const ResTypeName: TGMString = cDfltGMResTypeName; ResModuleHandle: THandle = 0); // GMParseLines smartly recognizes all kinds of line breaks CRLF | LFCR | CR | LF procedure GMParseLines(const AMultiLineText: TGMString; const AAddLineFunc: TGMAddLineFunc; const AData: Pointer; const AddEmptyLines: Boolean = False); function GMRegKeyAsString(const ARootKey: HKEY): TGMString; function GMScrollData(const fMask: UINT = 0; const nMin: LongInt = 0; const nMax: LongInt = 0; const nPage: UINT = 0; const nPos: LongInt = 0; const nTrackPos: LongInt = 0): TScrollInfo; function GMScrollDataFromWnd(const AHandle: HWnd; const ACtlKind, AMask: LongWord): TScrollInfo; function GMWheelScrollDelta(const PageSize: LongInt; const Direction: LongInt): LongInt; function GMCalcScrollPos(const AScrollCode: LongInt; const AScrollData: TScrollInfo): LongInt; function GMIsUrl(const AUrl: TGMString): Boolean; procedure GMCheckIsValidUrl(const AUrl: TGMString; const Caller: TObject = nil; const CallingName: TGMString = ''); procedure GMShowURL(const AURL: TGMString; const ACaller: TObject = nil); function GMTimerList: TGMObjArrayCollection; procedure GMTrace(const AText: TGMString; const APrefix: TGMTracePrefix = tpNone); procedure GMFreeAndNil(var Obj); procedure GMAddCharsToSetOfChar(const ACharSet: TGMSetOfChar; const ACharsToAdd: TGMString; const ARemoveOtherChars: Boolean); {$IFNDEF JEDIAPI} function TzSpecificLocalTimeToSystemTime(lpTimeZoneInformation: PTimeZoneInformation; const lpLocalTime: TSystemTime; var lpUniversalTime: TSystemTime): BOOL; stdcall; external 'kernel32.dll'; {$ENDIF} {$EXTERNALSYM ShellExecute} function ShellExecute(Wnd: HWND; Operation, FileName, Parameters, Directory: PGMChar; ShowCmd: Integer): THandle; stdcall; external 'shell32.dll' name {$IFDEF UNICODE}'ShellExecuteW'{$ELSE}'ShellExecuteA'{$ENDIF}; resourcestring //RStrUnknown = '<Unknown>'; RStrUnknown = '?'; RStrMessage = 'Message'; RStrPassword = 'Password'; RStrUsername = 'Username'; RStrYes = 'Yes'; RStrNo = 'No'; RStrTrue = 'True'; RStrFalse = 'False'; RStrOperationCanceled = 'Operation canceled'; RStrOperationError = 'Operation Error'; RStrWriteErrorFmt = 'Write Error, bytes to write %d, bytes that have been written %d'; RStrReadErrorFmt = 'Read Error, bytes to read %d, bytes that have been read %d'; RStrNoExceptInfo = 'No exception information available'; RStrContinueOperation = 'Continue Operation'; RStrAskUser = 'Ask User'; RStrAbort = 'Abort Operation'; RStrExceptionClass = 'Exception Class'; RStrSeverityLevel = 'Severity Level'; RStrObjectName = 'Object Name'; RStrObjectClass = 'Object Class'; RStrRoutineName = 'Routine Name'; RStrExceptAddr = 'Exception Address'; RStrUnknownError = 'Unknown Error'; RStrFileNotExists = 'File not found: "%s"'; RStrFileReadonlyFmt = 'The file "%s" is readonly and can only be opened in read only mode'; RStrValueBoundsHint = 'The value must be between %d and %d'; RStrResWriteNotSupported = 'Writing to resources not supported'; RStrAllFiles = 'All Files'; RStrInvalidESCSequenceFmt = 'Invalid escape char sequence "%s" in string "%s" at position %d'; RStrInvalidIntStrFmt = 'Invalid character in integer value "%s" at position %d'; RStrInvalidFloatStrFmt = 'Invalid character in floating point value "%s" at position %d'; RStrInvalidCurrencyStrFmt = 'Invalid character in currency value "%s" at position %d'; RStrInvalidFmtChar = 'Invalid format type char'; RStrInvalidArgTypeFmtChar = 'Invalid argument type for format type char'; RStrFmtDigitExpected = 'Digit expected in format string but found'; RStrInvalidDateTimeFmtStr = 'Invalid date time format string "%s" at character position %d'; RStrInvalidFileName = 'Invalid file or folder name "%s". The name must not be empty and must not contain one of the following charachters: %s'; //RStrInvalidFileName = '"%s" ist kein g�ltiger Datei- oder Ordnername. Der Name darf nicht leer sein und folgende Zeichen nicht enthalten: %s'; const cGMNoHandler: TGMObjNotifyProc = nil; // <- useful for overloaded inherited constructor call //cIntfNil: IUnknown = nil; // <- useful for overloaded inherited constructor call var gGMMainThreadID: LongWord = 0; //vfGMVerboseExceptionMessages: TGMBooleanFunc = GMDfltVerboseExceptionMessages; vfGMDoTracing: TGMBooleanFunc = GMDfltDoTracing; vfGMTraceLine: TGMTraceLineProc = GMDfltTraceLine; vfGMTrace: TGMTraceProc = GMDfltTrace; vfGMMessageBox: TGMMessageBoxFunc = GMWindowsMsgBox; vGMWaitCursor: TGMCursor = crWait; vfGMHrExceptionHandler: TGMHrExceptionHandlerFunc = GMDfltHrExceptionHandler; vfGMExecExceptionDlg: TGMExceptionDlgFunc = GMDfltExecExceptionDlg; //vGMTopWindow: HWnd = 0; vGMModalWnd: HWnd = 0; gDigitAsNumberSortSupported: Boolean = False; vGMKeyAcceleratorTargetWnd: HWnd = 0; vGMKeyAcceleratorTable: IGMGetHandle = nil; //vGMErrorActionNames: array [TGMErrorAction] of TGMString = (RStrContinueOperation, RStrAskUser, RStrAbort); //vAliveMessages: array [0..18] of LongInt = (6, 7, 8, 10, 11, 12, 13, 14, 15, $0014, $0200, $0113, $0020, $002C, $002B, $0083, $0084, $0085, $0086); //vAliveMessages: set of Byte = [6, 7, 8, 10, 11, 12, 13, 14, 15, $0014, $0020, $002C, $002B, $0083, $0084, $0085, $0086]; // $0200, $0113, implementation {$IFDEF JEDIAPI}uses{$ELSE} {$IFDEF DELPHI6}uses{$ENDIF} {$ENDIF} {$IFDEF DELPHI6}Variants{$ENDIF} {$IFDEF JEDIAPI}{$IFDEF DELPHI6},{$ENDIF}jwaWinVer, JwaSddl{$ENDIF} {$IFDEF JEDIAPI};{$ELSE} {$IFDEF DELPHI6};{$ENDIF} {$ENDIF} resourcestring RStrIntfListCantChange = 'The Interface Lists cannot be changed while the Object is connected'; RStrExceptionModule = 'Exception in Module'; //RStrNoModuleName = 'No module name specified'; RStrRoutineNotFound = 'Routine "%s" not found in DLL "%s"'; //RStrInvalidListSize = 'Ivalid List Size: %d'; RStrCharPos = 'Character position'; RStrFileCreatedFmt = 'Created %s'; RStrFileModifiedFmt = 'Modified %s'; RStrFileSizeFmt = 'Size %s'; RStrFileAttrFmt = 'Attributes [%s]'; RStrInFolderFmt = 'in Folder "%s"'; RStrNoTypeInfo = 'Type information is nil'; RStrNotEnumTypeFmt = 'Type "%s" is of kind "%s" instead of "%s"'; RStrInvalidEnumValFmt = 'Invalid value "%s" for enumeration type "%s". Valid values are (%s)'; RStrInvalidUrlFmt = 'Invalid URL: %s'; var gGMTimerList: TGMObjArrayCollection = nil; gCStraceText: IGMCriticalsection = nil; gCSExceptHandler: IGMCriticalsection = nil; vCSWndStack: IGMCriticalSection = nil; vGMModalWndStack: array of THandle = nil; { ------------------------------------ } { ---- Names from resourcestrings ---- } { ------------------------------------ } function GMErrorActionName(const ErrorAction: TGMErrorAction): TGMString; begin case ErrorAction of eaContinue: Result := RStrContinueOperation; eaAskUser: Result := RStrAskUser; eaAbort: Result := RStrAbort; else Result := ''; end; end; { ---------------------- } { ---- TGMSetOfChar ---- } { ---------------------- } const cCharSetElementBitSize = 8; cByteBitMask: array [0..7] of Byte = (1, 2, 4, 8, 16, 32, 64, 128); procedure GMAddCharsToSetOfChar(const ACharSet: TGMSetOfChar; const ACharsToAdd: TGMString; const ARemoveOtherChars: Boolean); var i: PtrInt; begin if ACharSet <> nil then begin if ARemoveOtherChars then ACharSet.RemoveAllChars; for i:=1 to Length(ACharsToAdd) do ACharSet.AddChar(ACharsToAdd[i]); end; end; procedure TGMSetOfChar.RemoveAllChars; begin FillByte(FElementsAsBits, SizeOf(FElementsAsBits), 0); end; procedure TGMSetOfChar.AddAllChars; begin FillByte(FElementsAsBits, SizeOf(FElementsAsBits), $FF); end; procedure TGMSetOfChar.AddChar(AChar: TGMChar); var divIdx: PtrInt; begin divIdx := Ord(AChar) div cCharSetElementBitSize; FElementsAsBits[divIdx] := FElementsAsBits[divIdx] or cByteBitMask[Ord(AChar) mod cCharSetElementBitSize]; end; procedure TGMSetOfChar.RemoveChar(AChar: TGMChar); //: Boolean; var divIdx: PtrInt; begin //Result := Contains(AChar); divIdx := Ord(AChar) div cCharSetElementBitSize; FElementsAsBits[divIdx] := FElementsAsBits[divIdx] and not cByteBitMask[Ord(AChar) mod cCharSetElementBitSize]; end; function TGMSetOfChar.Contains(AChar: TGMChar): Boolean; begin Result := FElementsAsBits[Ord(AChar) div cCharSetElementBitSize] and cByteBitMask[Ord(AChar) mod cCharSetElementBitSize] <> 0; end; procedure TGMSetOfChar.Union(AOther: TGMSetOfChar); var i: PtrInt; pSrc, pDst: PPtrUInt; begin //if AOther <> nil then // for i:=Low(FElementsAsBits) to High(FElementsAsBits) do // FElementsAsBits[i] := FElementsAsBits[i] or AOther.FElementsAsBits[i]; // // Do Assignment in granularity of a native int, using full processor register size should be faster ... // pDst := PPtrUInt(@FElementsAsBits[Low(FElementsAsBits)]); pSrc := PPtrUInt(@AOther.FElementsAsBits[Low(AOther.FElementsAsBits)]); for i:=0 to Length(FElementsAsBits) div SizeOf(PtrUInt)-1 do begin pDst^ := pDst^ or pSrc^; Inc(pSrc); Inc(pDst); end; end; { ---------------------------- } { ---- RGMNameAndStrValue ---- } { ---------------------------- } function InitRGMNameAndStrValue(const AName, AStrValue: TGMString): RGMNameAndStrValue; begin Result.Name := AName; Result.StrValue := AStrValue; end; //function RGMNameAndStrValue.Init(const AName, AStrValue: TGMString): RGMNameAndStrValue; //begin // Result.Name := AName; // Result.StrValue := AStrValue; //end; procedure RGMNameAndStrValue.Init(const AName, AStrValue: TGMString); begin Name := AName; StrValue := AStrValue; end; { -------------------- } { ---- TGMNameObj ---- } { -------------------- } constructor TGMNameObj.Create(const AName: TGMString; const ARefLifeTime: Boolean); begin //inherited Create(ARefLifeTime); FName := AName; end; function TGMNameObj.GetName: TGMString; begin Result := FName; end; procedure TGMNameObj.SetName(const ANewName: TGMString); begin FName := ANewName; end; function TGMNameObj.HashCode: TGMHashCode; begin Result := GMHashCodeFromString(FName); end; { ---------------------- } { ---- TGMHandleObj ---- } { ---------------------- } constructor TGMHandleObj.Create(const AHandle: THandle; const ARefLifeTime: Boolean); begin //inherited Create(ARefLifeTime); FHandle := AHandle; end; function TGMHandleObj.GetHandle: THandle; begin Result := Handle; end; function TGMHandleObj.HashCode: TGMHashCode; begin Result := TGMHashCode(FHandle); end; function TGMHandleObj.GetHandleAddr: Pointer; begin Result := @FHandle; end; { --------------------------- } { ---- TGMCloseHandleObj ---- } { --------------------------- } destructor TGMCloseHandleObj.Destroy; begin if FHandle <> 0 then begin CloseHandle(FHandle); FHandle := 0; end; inherited Destroy; end; { --------------------------- } { ---- TGMCloseHandleObj ---- } { --------------------------- } constructor TGMHotKeyTable.Create(const AKeys: array of TAccel; const ARefLifeTime: Boolean); {$IFNDEF JEDIAPI}var pa: PAccel;{$ENDIF} begin {$IFDEF JEDIAPI} FHandle := CreateAcceleratorTable(@AKeys[Low(AKeys)], Length(AKeys)); {$ELSE} pa := @AKeys[Low(AKeys)]; FHandle := CreateAcceleratorTable(pa^, Length(AKeys)); {$ENDIF} inherited Create(FHandle, ARefLifeTime); GMApiCheckObj('CreateAcceleratorTable', '', GetLastError, FHandle <> 0, Self); end; destructor TGMHotKeyTable.Destroy; begin if FHandle <> 0 then begin DestroyAcceleratorTable(FHandle); FHandle := 0; end; inherited Destroy; end; { ----------------------------- } { ---- TGMNamedOsHandleObj ---- } { ----------------------------- } function TGMNamedOsHandleObj.GetName: TGMString; begin Result := FName; end; { ----------------------------- } { ---- TGMMutableHandleObj ---- } { ----------------------------- } procedure TGMMutableHandleObj.SetHandle(const Value: THandle); begin FHandle := Value; end; { ----------------------- } { ---- TGMIntegerObj ---- } { ----------------------- } constructor TGMIntegerObj.Create(const AValue: PtrInt; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FValue := AValue; end; function TGMIntegerObj.HashCode: TGMHashCode; begin Result := FValue; end; { ------------------------ } { ---- TGMPositionObj ---- } { ------------------------ } destructor TGMPositionObj.Destroy; begin inherited; end; function TGMPositionObj.GetPosition: PtrInt; begin Result := FValue; end; { -------------------- } { ---- TGMLeftObj ---- } { -------------------- } function TGMLeftObj.GetLeft: LongInt; begin Result := FValue; end; { -------------------- } { ---- TGMGuidObj ---- } { -------------------- } constructor TGMGuidObj.Create(const AGuid: TGUID; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FGuid := AGuid; end; function TGMGuidObj.GetGUID: TGUID; begin Result := FGuid; end; { -------------------------- } { ---- TGMNameAndPosObj ---- } { -------------------------- } constructor TGMNameAndPosObj.Create(const AName: TGMString; const APosition: LongInt; const ARefLifeTime: Boolean); begin inherited Create(AName, ARefLifeTime); FPosition := APosition; end; function TGMNameAndPosObj.GetPosition: PtrInt; begin Result := FPosition; end; { ------------------------------- } { ---- TGMNameAndStrValueObj ---- } { ------------------------------- } constructor TGMNameAndStrValueObj.Create(const AName, AStrValue: TGMString; const ARefLifeTime: Boolean); begin Create(AName, ARefLifeTime); FStrValue := AStrValue; end; function TGMNameAndStrValueObj.GetStringValue: TGMString; begin Result := FStrValue; end; function TGMNameAndStrValueObj.GetText: TGMString; begin Result := FStrValue; end; function TGMNameAndStrValueObj.GetUnionValue: RGMUnionValue; begin Result := FStrValue; end; procedure TGMNameAndStrValueObj.SetStringValue(const AStrValue: TGMString); begin FStrValue := AStrValue; end; procedure TGMNameAndStrValueObj.SetText(const AStrValue: TGMString); begin FStrValue := AStrValue; end; procedure TGMNameAndStrValueObj.SetUnionValue(const AUnionValue: RGMUnionValue); begin FStrValue := AUnionValue; end; { ---------------------------- } { ---- TGMNameAndValueObj ---- } { ---------------------------- } constructor TGMNameAndValueObj.Create(const AName: TGMString; const AValue: RGMUnionValue; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); FName := AName; FValue := AValue; end; //function TGMNameAndValueObj.GetName: TGMString; //begin //Result := FName; //end; // //procedure TGMNameAndValueObj.SetName(const AValue: TGMString); //begin //FName := AValue; //end; function TGMNameAndValueObj.GetUnionValue: RGMUnionValue; begin Result := FValue; end; function TGMNameAndValueObj.GetStringValue: TGMString; begin Result := FValue; end; function TGMNameAndValueObj.GetKeyValue: RGMUnionValue; begin Result := FValue; end; procedure TGMNameAndValueObj.SetUnionValue(const AUnionValue: RGMUnionValue); begin FValue := AUnionValue; end; function TGMNameAndValueObj.GetText: TGMString; begin Result := FValue.AsStringDflt; end; procedure TGMNameAndValueObj.SetText(const AValue: TGMString); //var ValStr: TGMString; begin case FValue.ValueType of uvtDouble: FValue := GMStrToDouble(GMReplaceChars(AValue, '.', ',')); uvtInt64: FValue := GMStrToInt64(AValue); uvtInt32: FValue := GMStrToInt(AValue); else FValue := AValue; end; //if FValue.ValueType in [uvtDouble] then ValStr := GMReplaceChars(AValue, '.', ',') else ValStr := AValue; //{$IFDEF FPC} //FValue := VarAsType(ValStr, VarType(FValue)); //{$ELSE} //VarCast(FValue, ValStr, VarType(FValue)); //{$ENDIF} end; procedure TGMNameAndValueObj.LoadData(const ASource: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); stdcall; begin if ASource <> nil then FValue := ASource.ReadUnionValue(Name, FValue); // <- Dont't trigger AfterValueChange Event here end; procedure TGMNameAndValueObj.StoreData(const ADest: IGMValueStorage; const ACryptCtrlData: PGMCryptCtrlData); stdcall; begin if ADest <> nil then ADest.WriteUnionValue(Name, FValue); end; //function TGMNameAndValueObj.HashCode: TGMHashCode; //begin //Result := GMHashCodeFromString(FName); //end; { --------------------------- } { ---- TGMUserAccountObj ---- } { --------------------------- } constructor TGMUserAccountObj.Create(const AUsername, APassword: TGMString; const ASaveUserData: Boolean = cDfltSaveUSerData; const ARefLifeTime: Boolean = True); begin inherited Create(ARefLifeTime); FUsername := AUsername; FPassword := APassword; //FDomain := ADomain; FSaveUserData := ASaveUserData; end; function TGMUserAccountObj.GetUsername: PGMChar; begin Result := PGMChar(FUsername); end; function TGMUserAccountObj.GetPassword: PGMChar; begin Result := PGMChar(FPassword); end; //function TGMUserAccountObj.GetDomain: PGMChar; //begin //Result := PGMChar(FDomain); //end; function TGMUserAccountObj.GetSaveUserData: Boolean; begin Result := FSaveUserData; end; procedure TGMUserAccountObj.SetUsername(AUsername: PGMChar); begin FUsername := AUsername; end; procedure TGMUserAccountObj.SetPassword(APassword: PGMChar); begin FPassword := APassword; end; //procedure TGMUserAccountObj.SetDomain(ADomain: PGMChar); //begin //FDomain := ADomain; //end; procedure TGMUserAccountObj.SetSaveUserData(Value: Boolean); begin FSaveUserData := Value; end; { ------------------------- } { ---- TGMDLLHandleObj ---- } { ------------------------- } constructor TGMDLLHandleObj.Create(const ADLLFilePath: TGMString; const ACheckSuccess: Boolean = False; const ARefLifeTime: Boolean = True); begin inherited Create(LoadLibrary(PGMChar(ADLLFilePath)), ARefLifeTime); if ACheckSuccess and (Handle = 0) then begin FLoadErrorCode := GetLastError; GMAPICheckObjParams('LoadLibrary("'+ADLLFilePath+'")', '', FLoadErrorCode, Handle <> 0, [PGMChar(ADLLFilePath)], Self); end; end; destructor TGMDLLHandleObj.Destroy; begin if Handle <> 0 then begin FreeLibrary(Handle); FHandle := 0; end; inherited Destroy; end; { ----------------------- } { ---- TGMIconHolder ---- } { ----------------------- } destructor TGMIconHolder.Destroy; begin if FHandle <> 0 then DestroyIcon(FHandle); inherited; end; { ------------------- } { ---- TGMRegKey ---- } { ------------------- } constructor TGMRegKey.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); end; constructor TGMRegKey.CreateKey(const ARootKey: HKEY; AKeyPath: TGMString; const AAccessMode: DWORD; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FRootKey := ARootKey; AKeyPath := FormatKeyPath(AKeyPath); GMApiCheckObj('RegCreateKeyEx("'+AKeyPath+'")', '', RegCreateKeyEx(ARootKey, PGMChar(AKeyPath), 0, nil, REG_OPTION_NON_VOLATILE, AAccessMode, nil, FHandle, nil), False, Self); end; constructor TGMRegKey.CreateKey(const ARootKey: IUnknown; const AKeyPath: TGMString; const AAccessMode: DWORD; const ARefLifeTime: Boolean); var key: IGMGetHandle; begin GMCheckQueryInterface(ARootKey, IGMGetHandle, key, {$I %CurrentRoutine%}); FRootKeyRef := ARootKey; CreateKey(key.Handle, AKeyPath, AAccessMode, ARefLifeTime); end; destructor TGMRegKey.Destroy; begin CloseKey; inherited Destroy; end; function TGMRegKey.Obj: TGMRegKey; begin Result := Self; end; function TGMRegKey.GetHandle: THandle; stdcall; begin Result := FHandle; end; procedure TGMRegKey.CloseKey; begin if FHandle <> 0 then begin RegCloseKey(FHandle); FHandle := 0; end; end; function TGMRegKey.FormatKeyPath(const Value: TGMString): TGMString; begin Result := GMStrip(Value, cWhiteSpace + '/\'); end; function TGMRegKey.OpenKey(const ARootKey: HKEY; const AKeyPath: TGMString; const ACheckExists: Boolean; const AAccessMode: DWORD): Boolean; var AWinApiErrorCode: LongInt; begin CloseKey; FRootKey := ARootKey; //AKeyPath := FormatKeyPath(AKeyPath); if not ACheckExists then Result := RegOpenKeyEx(ARootKey, PGMChar(FormatKeyPath(AKeyPath)), 0, AAccessMode, FHandle) = ERROR_SUCCESS else begin AWinApiErrorCode := RegOpenKeyEx(ARootKey, PGMChar(FormatKeyPath(AKeyPath)), 0, AAccessMode, FHandle); if (AWinApiErrorCode <> ERROR_SUCCESS) and (AWinApiErrorCode <> ERROR_FILE_NOT_FOUND) and (AWinApiErrorCode <> ERROR_PATH_NOT_FOUND) then GMApiCheckObj(GMFormat('RegOpenKeyEx(%s, "%s", Accessmode: %u, 0x%x)', [GMRegKeyAsString(ARootKey), AKeyPath, AAccessMode, AAccessMode]), '', AWinApiErrorCode, False, Self); Result := AWinApiErrorCode = ERROR_SUCCESS; end; end; function TGMRegKey.OpenKey(const ARootKey: IUnknown; const AKeyPath: TGMString; const ACheckExists: Boolean; const AAccessMode: DWORD): Boolean; var PIKey: IGMGetHandle; begin GMCheckQueryInterface(ARootKey, IGMGetHandle, PIKey, 'TGMRegKey.OpenKey'); FRootKeyRef := ARootKey; Result := OpenKey(PIKey.Handle, AKeyPath, ACheckExists, AAccessMode); end; procedure TGMRegKey.ReadValueNames(var Names: TGMStringArray); var RetCode: LongInt; MaxLen: DWORD; Name: TGMString; i: LongInt; begin SetLength(Names, 0); GMApiCheckObj('RegQueryInfoKey', '', RegQueryInfoKey(FHandle, nil, nil, nil, nil, nil, nil, nil, @MaxLen, nil, nil, nil), False, Self); if MaxLen = 0 then Exit; SetLength(Name, MaxLen); i := 0; repeat MaxLen := Length(Name) + 1; RetCode := RegEnumValue(FHandle, i, PGMChar(Name), MaxLen, nil, nil, nil, nil); if RetCode = ERROR_SUCCESS then GMAddStrToArray(PGMChar(Name), Names); Inc(i); until RetCode <> ERROR_SUCCESS; GMAPICheckObjEx('RegEnumKeyEx', '', RetCode, False, [ERROR_SUCCESS, ERROR_NO_MORE_ITEMS], Self); end; procedure TGMRegKey.ReadSubKeyNames(var Names: TGMStringArray); var RetCode: LongInt; MaxLen: DWORD; Name: TGMString; i: LongInt; begin SetLength(Names, 0); GMApiCheckObj('RegQueryInfoKey', '', RegQueryInfoKey(FHandle, nil, nil, nil, nil, @MaxLen, nil, nil, nil, nil, nil, nil), False, Self); if (MaxLen > 0) and (GMWinVersion < wvWinNT) then Dec(MaxLen); if MaxLen = 0 then Exit; SetLength(Name, MaxLen); i := 0; repeat MaxLen := Length(Name) + 1; RetCode := RegEnumKeyEx(FHandle, i, PGMChar(Name), MaxLen, nil, nil, nil, nil); if RetCode = ERROR_SUCCESS then GMAddStrToArray(PGMChar(Name), Names); Inc(i); until RetCode <> ERROR_SUCCESS; GMAPICheckObjEx('RegEnumKeyEx', '', RetCode, False, [ERROR_SUCCESS, ERROR_NO_MORE_ITEMS], Self); //if RetCode <> ERROR_NO_MORE_ITEMS then raise EAPIException.ObjError(RetCode, Self, 'ReadSubKeyNames'); end; function TGMRegKey.DeleteKey(const ARootKey: HKEY; const AKeyPath: TGMString; const ARecurse: Boolean): Boolean; var SubKey: IGMRegKey; SubKeyNames: TGMStringArray; i: LongInt; AWinApiErrorCode: LongInt; begin if ARecurse then begin Result := OpenKey(ARootKey, AKeyPath); try if not Result then Exit; ReadSubKeyNames(SubKeyNames); SubKey := TGMRegKey.Create; for i:=Low(SubKeyNames) to High(SubKeyNames) do SubKey.Obj.DeleteKey(ARootKey, GMAppendPath(AKeyPath, SubKeyNames[i]), ARecurse); finally CloseKey; end; end; AWinApiErrorCode := RegDeleteKey(ARootKey, PGMChar(FormatKeyPath(AKeyPath))); if (AWinApiErrorCode <> ERROR_SUCCESS) and (AWinApiErrorCode <> ERROR_FILE_NOT_FOUND) and (AWinApiErrorCode <> ERROR_PATH_NOT_FOUND) then GMApiCheckObj(GMFormat('RegDeleteKey(%s, Valuename: "%s", Recurse: %s)', [GMRegKeyAsString(ARootKey), AKeyPath, GMBoolToStr(ARecurse)]), '', AWinApiErrorCode, False, Self); Result := AWinApiErrorCode = ERROR_SUCCESS; end; function TGMRegKey.ValueExists(const AValueName: TGMString): Boolean; var RegType, len: DWORD; begin Result := RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @RegType, nil, @len) = ERROR_SUCCESS; end; function TGMRegKey.DeleteValue(const AValueName: TGMString): Boolean; var AWinApiErrorCode: DWORD; begin AWinApiErrorCode := RegDeleteValue(FHandle, PGMChar(AValueName)); if (AWinApiErrorCode <> ERROR_SUCCESS) and (AWinApiErrorCode <> ERROR_FILE_NOT_FOUND) and (AWinApiErrorCode <> ERROR_PATH_NOT_FOUND) then GMApiCheckObj(GMFormat('RegDeleteValue(%s, Valuename: "%s")', [GMRegKeyAsString(FHandle), AValueName]), '', AWinApiErrorCode, False, Self); Result := AWinApiErrorCode = ERROR_SUCCESS; end; procedure TGMRegKey.WriteBinary(const AValueName: TGMString; const Data; const DataSize: DWORD); begin GMApiCheckObj('RegSetValueEx("'+AValueName+'")', '', RegSetValueEx(FHandle, PGMChar(AValueName), 0, REG_BINARY, Pointer(@Data), DataSize), False, Self); end; procedure TGMRegKey.WriteString(const AValueName, Value: TGMString); begin GMApiCheckObj(GMFormat('RegSetValueEx(Valuename: "%s", Value: "%s")', [AValueName, Value]), '', RegSetValueEx(FHandle, PGMChar(AValueName), 0, REG_SZ, Pointer(PGMChar(Value)), (Length(Value)+1) * SizeOf(TGMChar)), False, Self); end; procedure TGMRegKey.WriteInteger(const AValueName: TGMString; const Value: LongInt); begin GMApiCheckObj(GMFormat('RegSetValueEx(Valuename: "%s", Value: "%d")', [AValueName, Value]), '', RegSetValueEx(FHandle, PGMChar(AValueName), 0, REG_DWORD, Pointer(@Value), SizeOf(Value)), False, Self); end; function TGMRegKey.ReadString(const AValueName: TGMString; const ADefaultValue: TGMString): TGMString; var regType, len, dwValue: DWORD; // retCode: LongInt; begin Result := ADefaultValue; //retCode := RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, nil, @len); //if retCode <> ERROR_SUCCESS then raise EApiException.ObjError(retCode, [], Self); if RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, nil, @len) <> ERROR_SUCCESS then Exit; case regType of REG_DWORD: begin len := SizeOf(dwValue); if RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, Pointer(@dwValue), @len) = ERROR_SUCCESS then Result := GMIntToStr(dwValue); end; REG_SZ, REG_EXPAND_SZ: if len div SizeOf(TGMChar) <= 1 then Result := '' else begin SetLength(Result, LongInt(len) div SizeOf(TGMChar)-1); if RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, Pointer(PGMChar(Result)), @len) <> ERROR_SUCCESS then Exit; if regType = REG_EXPAND_SZ then Result := GMExpandEnvironmentStrings(Result); end; //else Result := ADefaultValue; end; end; function TGMRegKey.ReadInteger(const AValueName: TGMString; const ADefaultValue: LongInt): LongInt; var regType, len: DWORD; StrVal: TGMString; begin Result := ADefaultValue; if RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, nil, @len) <> ERROR_SUCCESS then Exit; case regType of REG_DWORD: begin len := SizeOf(Result); {if not} RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, Pointer(@Result), @len); // = ERROR_SUCCESS then Result := ADefaultValue; end; REG_SZ, REG_EXPAND_SZ: if len <= 1 then Result := ADefaultValue else begin SetLength(StrVal, LongInt((len div SizeOf(TGMChar))-1)); if RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, Pointer(PGMChar(StrVal)), @len) <> ERROR_SUCCESS then Exit; if regType = REG_EXPAND_SZ then StrVal := GMExpandEnvironmentStrings(StrVal); Result := GMStrToInt32(GMMakeDezInt(StrVal, ADefaultValue)); end; //else Result := ADefaultValue; end; end; function TGMRegKey.ReadBinary(const AValueName: TGMString; const ADestData: Pointer; const ADestDataSizeInBytes: LongInt): DWORD; var regType: DWORD; retVal: LongInt; begin if RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, nil, @Result) <> ERROR_SUCCESS then begin Result := 0; Exit; end; Result := Max(0, Min(ADestDataSizeInBytes, Result)); if Result > 0 then begin retVal := RegQueryValueEx(FHandle, PGMChar(AValueName), nil, @regType, ADestData, @Result); Assert(retVal = ERROR_SUCCESS); //if retVal <> ERROR_SUCCESS then ... end; end; { ------------------ } { ---- TGMEvent ---- } { ------------------ } constructor TGMEvent.Create(const AManualReset, AInitialSignaled: Boolean; const AName: TGMString; const ASecurityAttr: PSecurityAttributes; const ARefLifetime: Boolean); var pName: PGMChar; begin FName := AName; if Length(AName) > 0 then pName := PGMChar(AName) else pName := nil; inherited Create(CreateEvent(ASecurityAttr, AManualReset, AInitialSignaled, pName), ARefLifetime); if FHandle = 0 then GMApiCheckObj('CreateEvent', '', GetLastError, FHandle <> 0, Self); end; function TGMEvent.WaitFor(const AProcessMessages: Boolean; const Timeout: DWORD): DWORD; begin Result := GMMsgLoopWaitForMultipleObjects(1, @FHandle, AProcessMessages, Timeout); end; procedure TGMEvent.Signal; begin GMApiCheckObj('SetEvent', '', GetLastError, SetEvent(Handle), Self); end; procedure TGMEvent.Reset; begin GMApiCheckObj('ResetEvent', '', GetLastError, ResetEvent(Handle), Self); end; { ------------------ } { ---- TGMMutex ---- } { ------------------ } constructor TGMMutex.Create(const AName: TGMString; const AProcessMessagesWhileWaiting: Boolean; const ATimeout: DWORD; const ASecurityAttr: PSecurityAttributes; const ARefLifetime: Boolean); var lastErr: DWORD; pName: PGMChar; begin FName := AName; FProcessMessagesWhileWaiting := AProcessMessagesWhileWaiting; FTimeout := ATimeout; inherited Create(0, ARefLifeTime); if Length(AName) > 0 then pName := PGMChar(AName) else pName := nil; FHandle := CreateMutex(ASecurityAttr, False, pName); if FHandle = 0 then // <- The case ERROR_ALREADY_EXISTS will set the handle! begin lastErr := GetLastError; if lastErr <> ERROR_ACCESS_DENIED then GMApiCheckObj('CreateMutex', '', lastErr, FHandle <> 0, Self) else begin FHandle := OpenMutex(SYNCHRONIZE, False, PGMChar(AName)); GMApiCheckObj('OpenMutex', '', GetLastError, FHandle <> 0, Self) end; end; end; procedure TGMMutex.EnterCriticalSection; begin GMMsgLoopWaitForMultipleObjects(1, @FHandle, FProcessMessagesWhileWaiting, FTimeout); end; procedure TGMMutex.LeaveCriticalSection; begin GMApiCheckObj('ReleaseMutex', '', GetLastError, ReleaseMutex(Handle), Self); end; { ---------------------- } { ---- TGMSemaphore ---- } { ---------------------- } constructor TGMSemaphore.Create(const AMaxShareCount: LongInt; const AName: TGMString; // const AProcessMessagesWhileWaiting: Boolean = False; const ASecurityAttr: PSecurityAttributes; const ARefLifetime: Boolean); var pName: PGMChar; begin FMaxShareCount := AMaxShareCount; FName := AName; if Length(AName) > 0 then pName := PGMChar(AName) else pName := nil; inherited Create(CreateSemaphore(ASecurityAttr, AMaxShareCount, AMaxShareCount, pName), ARefLifetime); if FHandle = 0 then GMApiCheckObj('CreateSemaphore', '', GetLastError, FHandle <> 0, Self); end; procedure TGMSemaphore.EnterShared; begin case WaitForSingleObject(FHandle, INFINITE) of WAIT_OBJECT_0: ; WAIT_TIMEOUT: ; end; end; procedure TGMSemaphore.LeaveShared; var lastErr: DWORD; begin if not ReleaseSemaphore(FHandle, 1, nil) then begin lastErr := GetLastError; GMApiCheckObj('ReleaseSemaphore(1)', '', lastErr, False, Self); end; end; procedure TGMSemaphore.EnterSingleExclusive; var i: Integer; begin for i:=1 to FMaxShareCount do case WaitForSingleObject(FHandle, INFINITE) of WAIT_OBJECT_0: ; WAIT_TIMEOUT: ; end; end; procedure TGMSemaphore.LeaveSingleExclusive; var lastErr: DWORD; begin if not ReleaseSemaphore(FHandle, FMaxShareCount, nil) then begin lastErr := GetLastError; GMApiCheckObj('ReleaseSemaphore(FMaxShareCount)', '', lastErr, False, Self); end; end; { -------------------------- } { ---- TGMWaitableTimer ---- } { -------------------------- } {$IFDEF JEDIAPI} constructor TGMWaitableTimer.Create(const ADueTime: Int64; const AAutoStart: Boolean; const AName: TGMString; const AInterval: LONG; const AExecRoutine: PTIMERAPCROUTINE; const AExecRoutineArg: Pointer; const ASecurityAttr: PSecurityAttributes; const ARefLifetime: Boolean); var pName: PGMChar; begin FName := AName; FDueTime.QuadPart := ADueTime; FInterval := AInterval; FExecRoutine := AExecRoutine; FExecRoutineArg := AExecRoutineArg; FIsRunning := False; if Length(AName) > 0 then pName := PGMChar(AName) else pName := nil; inherited Create(CreateWaitableTimer(ASecurityAttr, False, pName), ARefLifeTime); if FHandle = 0 then GMApiCheckObj('CreateWaitableTimer', '', GetLastError, FHandle <> 0, Self); if AAutoStart then Start; end; destructor TGMWaitableTimer.Destroy; begin try Stop; except end; // <- no exceptions in destructors! inherited Destroy; end; function TGMWaitableTimer.IsRunning: BOOL; begin Result := FIsRunning; end; procedure TGMWaitableTimer.Start; begin FIsRunning := SetWaitableTimer(FHandle, FDueTime, FInterval, FExecRoutine, FExecRoutineArg, False); GMApiCheckObj('SetWaitableTimer', '', GetLastError, FIsRunning, Self); end; procedure TGMWaitableTimer.Stop; begin if FIsRunning then GMApiCheckObj('CancelWaitableTimer', '', GetLastError, CancelWaitableTimer(FHandle), Self); end; function TGMWaitableTimer.GetInterval: UINT; begin Result := UINT(FInterval); end; procedure TGMWaitableTimer.SetInterval(const AInterval: UINT); begin FInterval := Max(0, Min(AInterval, High(FInterval))); end; procedure TGMWaitableTimer.Restart(const ANewIntervalMS: UINT); begin if (ANewIntervalMS <> cDontChangeTimerInterval) then begin FDueTime.QuadPart := ANewIntervalMS * -10000; FInterval := ANewIntervalMS; end; Start; end; {$ENDIF} { ---------------------- } { ---- TGMTimerBase ---- } { ---------------------- } destructor TGMTimerBase.Destroy; begin try Stop; except on ex: TObject do GMTraceException(ex); end; // <- no exceptions in destructors! inherited Destroy; end; function TGMTimerBase.GetHandle: THandle; begin Result := FTimerId; end; //function TGMTimerBase.Obj: TGMTimerBase; //begin //Result := Self; //end; function TGMTimerBase.IsRunning: BOOL; begin Result := FTimerId <> 0; end; function TGMTimerBase.GetInterval: UINT; begin Result := FInterval; end; procedure TGMTimerBase.SetInterval(const AInterval: UINT); var wasRunning: Boolean; begin if AInterval <> FInterval then begin wasRunning := IsRunning; Stop; FInterval := AInterval; if wasRunning then Start; end; end; procedure TGMTimerBase.Restart(const ANewIntervalMS: UINT); begin Stop; if ANewIntervalMS <> cDontChangeTimerInterval then FInterval := ANewIntervalMS; Start; end; { ------------------------ } { ---- TGMThreadTimer ---- } { ------------------------ } function GMTimerList: TGMObjArrayCollection; begin if gGMTimerList = nil then gGMTimerList := TGMObjArrayCollection.Create(False, True, True, GMCompareByHandle); Result := gGMTimerList; end; procedure TimerProc(Wnd: HWnd; Msg: UINT; EventId: UINT; TickCount: DWORD); stdcall; // // This will be called by another thread from inside windows OS // var PIHandle: IGMGetHandle; Timer: TObject; begin try PIHandle := TGMHandleObj.Create(EventId, True); if GMTimerList.Find(PIHandle, Timer) and (Timer is TGMThreadTimer) then TGMThreadTimer(Timer).DoOnTimer; except // vfGMExceptionHandler is secured by a critical section on ex: TObject do vfGMHrExceptionHandler(ex, cDfltPrntWnd); // GMModalDlgParentWnd end; end; constructor TGMThreadTimer.Create(const AOnTimerProc: TGMObjNotifyProc; const ACaller: TObject; const AWaitTimeoutMilliSec: UINT; const AAutoStart, ARefLifeTime: Boolean); begin //inherited Create(ARefLifeTime); FInterval := AWaitTimeoutMilliSec; FOnTimerProc := AOnTimerProc; FCaller := ACaller; if AAutoStart then Start; end; procedure TGMThreadTimer.DoOnTimer; var Caller: TObject; begin if Assigned(OnTimer) then try if FCaller <> nil then Caller := FCaller else Caller := Self; OnTimer(Caller); except Stop; raise; end; end; procedure TGMThreadTimer.Start; begin if IsRunning then Exit; FTimerId := SetTimer(0, 0, FInterval, Addr(TimerProc)); // Using 0 as timer-id will assign a unique id by the system - PtrUint(Self) GMAPICheckObj('SetTimer', '', GetLastError, FTimerId <> 0, Self); GMTimerList.Add(Self); end; procedure TGMThreadTimer.Stop; begin if not IsRunning then Exit; GMTimerList.RemoveByKey(Self); GMAPICheckObj('KillTimer', '', GetLastError, KillTimer(0, FTimerId), Self); FTimerId := 0; end; { --------------------- } { ---- TGMWndTimer ---- } { --------------------- } constructor TGMWndTimer.Create(const AWnd: HWnd; const ATimerID: LongInt; const AWaitTimeoutMilliSec: LongInt; const AAutoStart, ARefLifeTime: Boolean); begin //inherited Create(ARefLifeTime); FInterval := AWaitTimeoutMilliSec; FWnd := AWnd; FClientID := ATimerID; if AAutoStart then Start; end; function TGMWndTimer.GetHandle: THandle; begin Result := FWnd; end; procedure TGMWndTimer.Start; begin if IsRunning then Exit; FTimerID := SetTimer(GetHandle, FClientID, FInterval, nil); // <- FTimerID is checked in IsRunning function! GMAPICheckObj('SetTimer', '', GetLastError, FTimerID <> 0, Self); end; procedure TGMWndTimer.Stop; begin if not IsRunning then Exit; GMAPICheckObj('KillTimer', '', GetLastError, KillTimer(GetHandle, FClientID), Self); FTimerId := 0; end; { ---------------------- } { ---- GMThreadProc ---- } { ---------------------- } // // The default thread code wrapper that will be executed by a new thread // function GMThreadProc(AParam: Pointer): HResult; stdcall; var thread: TGMThread; allowUI: Boolean; dlgParentWnd: HWND; comInit: IUnknown; begin thread := nil; try allowUI := False; try thread := TObject(AParam) as TGMThread; allowUI := thread.FAllowExceptDlg; if thread.FCoInitFlags <> cDontCoInit then comInit := TGMCOMInitializer.Create(thread.FCoInitFlags); try Result := thread.Execute; finally thread.FTerminated := True; end; except on ex: TObject do begin // vfGMExceptionHandler is secured by a critical section if allowUI then dlgParentWnd := GMModalDlgParentWnd else dlgParentWnd := cNoUIWnd; Result := vfGMHrExceptionHandler(ex, dlgParentWnd); end; end; finally if (thread <> nil) and thread.FreeOnTerminate then thread.Free; // <- free may release interface members, do this before CoUninitialize end; end; { ------------------- } { ---- TGMThread ---- } { ------------------- } constructor TGMThread.Create(const ACoInitFlags: LongInt; // <- must be first parameter to avoid ambiguity with inherited constructor const ACreateSuspended: Boolean; const APriority: LongInt; const AAllowExceptDlg: Boolean; AThreadProc: Pointer; const AStackSize: LongWord; const ASecurityAttr: PSecurityAttributes; const ARefLifeTime: Boolean); //const cFlags: array [Boolean] of DWORD = (0, CREATE_SUSPENDED); //const cSuspendCount: array [Boolean] of DWORD = (0, 1); begin IsMultiThread := True; FHasBeenRunning := False; WaitTimeoutOnDestroy := INFINITE; if ACoInitFlags = cCoInitUseDflt then FCoInitFlags := vGMComInitFlags else FCoInitFlags := ACoInitFlags; //FSuspendCount := cSuspendCount[ACreateSuspended]; FSuspendCount := 1; FAllowExceptDlg := AAllowExceptDlg; if AThreadProc = nil then AThreadProc := @GMThreadProc; inherited Create(CreateThread(ASecurityAttr, AStackSize, AThreadProc, Self, CREATE_SUSPENDED, {$IFDEF JEDIAPI}@{$ENDIF}FThreadId), ARefLifeTime); // <- void ambiguity with this constructor! GMApiCheckObj('CreateThread', '', GetLastError, FHandle <> 0, Self); GMApiCheckObj('SetThreadPriority', '', GetLastError, SetThreadPriority(FHandle, APriority), Self); if not ACreateSuspended then Resume; end; destructor TGMThread.Destroy; begin FreeOnTerminate := False; // <- avoid re-enter when called from GMThreadProc, if it had been called from there this has no effect. if FHandle <> 0 then begin if not FTerminated and FHasBeenRunning then begin Cancel; Run; WaitFor(False, WaitTimeoutOnDestroy); end; // else if FHasBeenRunning then TerminateThread(FHandle, DWORD(E_ABORT)); end; inherited Destroy; end; function TGMThread.Obj: TGMThread; begin Result := Self; end; procedure TGMThread.Cancel; begin FCanceled := True; end; function TGMThread.WaitFor(const AProcessMessages: Boolean; const ATimeoutMS: DWORD): HResult; begin if FHandle = 0 then Result := 0 else // <- in case our constructor has been skipped by inherited class begin Result := GMMsgLoopWaitForMultipleObjects(1, @FHandle, AProcessMessages, ATimeoutMS); //if not GetExitCodeThread(FHandle, LongWord(Result)) then Result := 0; //GMApiCheckObj(GetExitCodeThread(FHandle, Result), Self, 'GetExitCodeThread'); end; end; function TGMThread.Suspend: DWORD; begin Result := SuspendThread(FHandle); // <- Returns previous suspend count GMApiCheckObj('SuspendThread', '', GetLastError, Result <> $FFFFFFFF, Self); Inc(FSuspendCount); // := Result; end; function TGMThread.Resume: DWORD; begin if FSuspendCount <= 0 then begin Result := 0; Exit; end; Result := ResumeThread(FHandle); // <- Returns previous suspend count GMApiCheckObj('ResumeThread', '', GetLastError, Result <> $FFFFFFFF, Self); Dec(FSuspendCount); // := Result; FHasBeenRunning := FHasBeenRunning or (FSuspendCount <= 0); end; procedure TGMThread.Run; begin while FSuspendCount > 0 do Resume; end; function TGMThread.GetPriority: LongInt; begin Result := GetThreadPriority(FHandle); GMApiCheckObj('GetThreadPriority', '', GetLastError, Priority <> THREAD_PRIORITY_ERROR_RETURN, Self); end; procedure TGMThread.SetPriority(const AValue: LongInt); begin GMApiCheckObj('SetThreadPriority', '', GetLastError, SetThreadPriority(FHandle, AValue), Self); end; function TGMThread.ExitCode: DWORD; begin GMApiCheckObj('GetExitCodeThread', '', GetLastError, GetExitCodeThread(FHandle, Result), Self); end; { ------------------------- } { ---- TGMSilentThread ---- } { ------------------------- } constructor TGMSilentThread.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FCSTermMsgData := TGMCriticalSection.Create; end; function TGMSilentThread.Obj: TGMSilentThread; begin Result := Self; end; function TGMSilentThread.DfltExceptResult: HResult; begin Result := E_FAIL; // E_UNEXPECTED; end; procedure TGMSilentThread.SetTermMsgData(const ATermMsgData: TGMThreadTermMsgDataRec); begin FCSTermMsgData.EnterCriticalSection; try FTermMsg := ATermMsgData; finally FCSTermMsgData.LeaveCriticalSection; end; end; {function TGMSilentThread.GetExceptInfo: IGMExceptionInformation; begin Result := FExceptInfo; end;} procedure TGMSilentThread.SendTerminationMsg; begin FCSTermMsgData.EnterCriticalSection; try if IsWindow(FTermMsg.TargetWnd) and (FTermMsg.Msg <> 0) then with FTermMsg do PostMessage(TargetWnd, Msg, WParam, LParam); finally FCSTermMsgData.LeaveCriticalSection; end; end; function TGMSilentThread.Execute: HResult; begin try try Result := InternalExecute; except on ex: TObject do begin {$IFDEF CALLSTACK} // if Length(ExceptCallStack) = 0 then GMCaptureCurrentThreadCallStack(ExceptCallStack); if ExceptCallStack = nil then ExceptCallStack := GMGetThreadCallStackData(ThreadID, True); {$ENDIF} GMTraceException(ex); Result := GMGetObjHRCode(ex, DfltExceptResult); //if not GMIsclassByName(GMExceptObject, EAbort) and GMAskBoolean(GMExceptObject, Ord(bevPresentToUI), True) then FExceptInfo := TGMExceptionInformation.CreateFromObj(ex, True); // else GMTraceException(GMExceptObject); end; end; finally // // Message must be send after FExceptInfo has been assigned! // SendTerminationMsg; end; end; { ----------------------- } { ---- TGMTempCursor ---- } { ----------------------- } constructor TGMTempCursor.Create(const ANewCursor: TGMCursor; const APMemberVar: PHandle; const ARefLifeTime: Boolean); var cursor: THandle; begin inherited Create(ARefLifeTime); cursor := LoadCursor(0, cWinCursorRes[ANewCursor]); FOldCursor := SetCursor(cursor); FPMemberVar := APMemberVar; if FPMemberVar <> nil then begin FOldMemeberVarValue := FPMemberVar^; FPMemberVar^ := cursor; end; end; destructor TGMTempCursor.Destroy; begin if FOldCursor <> 0 then SetCursor(FOldCursor); if FPMemberVar <> nil then FPMemberVar^ := FOldMemeberVarValue; inherited Destroy; end; { ---------------------- } { ---- API Checking ---- } { ---------------------- } function GMHrCheckObjParams(const HRCode: HResult; const Params: array of PGMChar; const Obj: TObject; const ARoutineName: TGMString; const AMsgPostfix: TGMString; const Strict: Boolean; const AHelpCtx: LongInt): HResult; begin Result := HRCode; if not GMHrSucceeded(HRCode) or (Strict and (HRCode <> S_OK)) then if (HRCode = E_ABORT) or (HRCode = GMHResultFromWin32(ERROR_CANCELLED)) then raise EGMAbort.Create(RStrOperationCanceled) else raise EGMHrException.ObjError(HRCode, Params, Obj, ARoutineName, AMsgPostfix, AHelpCtx); // case HRCode of // E_ABORT: raise EGMAbort.Create(RStrOperationCanceled); // else raise EGMHrException.ObjError(HRCode, Params, Obj, ARoutineName, AMsgPostfix, AHelpCtx); // end; end; function GMHrCheckObj(const HRCode: HResult; const Obj: TObject; const ARoutineName: TGMString; const AMsgPostfix: TGMString; const Strict: Boolean; const AHelpCtx: LongInt): HResult; begin Result := GMHrCheckObjParams(HRCode, [], Obj, ARoutineName, AMsgPostfix, Strict, AHelpCtx); end; procedure GMHrTraceObjParams(const HRCode: HResult; const Params: array of PGMChar; const Obj: TObject; const ARoutineName: TGMString; const AMsgPostfix: TGMString; const Strict: Boolean; const AHelpCtx: LongInt); var PIExceptInfo: IGMExceptionInformation; begin if not GMHrSucceeded(HRCode) or (Strict and (HRCode <> S_OK)) then begin PIExceptInfo := TGMExceptionInformation.Create(True, False, AMsgPostfix + GMSysErrorMsg(HRCode, Params), EGMHrException.ClassName, ExceptAddr, GMGetObjDisplayName(Obj), GMObjClassName(Obj), ARoutineName, svWarning, AHelpCtx, HRCode); GMTrace(GMBuildExceptionMsg(PIExceptInfo, True), tpWarning); end; end; procedure GMHrCheckIntfParams(const HRCode: HResult; const AMsgFmtParams: array of PGMChar; const Intf: IUnknown; const ARoutineName, AMsgPostfix: TGMString; const Strict: Boolean; const AHelpCtx: LongInt); begin if not GMHrSucceeded(HRCode) or (Strict and (HRCode <> S_OK)) then if (HRCode = E_ABORT) or (HRCode = GMHResultFromWin32(ERROR_CANCELLED)) then raise EGMAbort.Create(RStrOperationCanceled) else raise EGMHrException.IntfError(HRCode, AMsgFmtParams, Intf, ARoutineName, AMsgPostfix, AHelpCtx); end; procedure GMHrCheckIntf(const HRCode: HResult; const Intf: IUnknown; const ARoutineName: TGMString; const AMsgPostfix: TGMString; const Strict: Boolean; const AHelpCtx: LongInt); begin GMHrCheckIntfParams(HRCode, [], Intf, ARoutineName, AMsgPostfix, Strict, AHelpCtx); end; procedure GMAPICheckObjParams(const ARoutineName, AMsgPostfix: TGMString; const AWinApiErrorCode: DWORD; const AWinApiRetVal: BOOL; const Params: array of PGMChar; const Obj: TObject; const AHelpCtx: LongInt); begin if not AWinApiRetVal and (AWinApiErrorCode <> NO_ERROR) then raise EAPIException.ObjError(AWinApiErrorCode, Params, Obj, ARoutineName, AMsgPostfix, AHelpCtx); end; procedure GMAPICheckObj(const ARoutineName, AMsgPostfix: TGMString; const AWinApiErrorCode: DWORD; const AWinApiRetVal: BOOL; const AObj: TObject; const AHelpCtx: LongInt); begin if not AWinApiRetVal and (AWinApiErrorCode <> NO_ERROR) then raise EAPIException.ObjError(AWinApiErrorCode, [], AObj, ARoutineName, AMsgPostfix, AHelpCtx); end; procedure GMAPICheckObjEx(const ARoutineName, AMsgPostfix: TGMString; const AWinApiErrorCode: DWORD; const AWinApiRetVal: BOOL; const SuccessCodes: array of PtrInt; const Obj: TObject; const AHelpCtx: LongInt); begin if AWinApiRetVal then Exit; if GMIsOneOfIntegers(PtrInt(AWinApiErrorCode), SuccessCodes) then Exit; raise EAPIException.ObjError(AWinApiErrorCode, [], Obj, ARoutineName, AMsgPostfix, AHelpCtx); end; type PRaiseFrameRec = ^TRaiseFrameRec; TRaiseFrameRec = packed record NextRaise: PRaiseFrameRec; ExceptAddr: Pointer; ExceptObject: TObject; ExceptionRecord: PExceptionRecord; end; function GMExceptObject: TObject; begin if RaiseList = nil then Result := nil else {$IFDEF FPC} Result := RaiseList^.FObject; {$ELSE} Result := PRaiseFrameRec(RaiseList)^.ExceptObject; {$ENDIF} end; //function GMExceptAddr: Pointer; //begin // if RaiseList <> nil then // Result := PRaiseFrameRec(RaiseList)^.ExceptAddr else // Result := nil; //end; function OLEFormatEtc(const cfFormat: TClipFormat; const ptd: PDVTargetDevice; const dwAspect: LongInt; const lindex: LongInt; const tymed: LongInt): TFormatEtc; begin Result.cfFormat := cfFormat; Result.ptd := ptd; Result.dwAspect := dwAspect; Result.lindex := lindex; Result.tymed := tymed; end; function OLEStgMedium(const tymed: LongInt; const handle: THandle; const unkForRelease: Pointer): TStgMedium; overload; begin Result.tymed := tymed; Result.hGlobal := handle; Result.unkForRelease := unkForRelease; end; function OLEStgMedium(const tymed: LongInt; const pUnknown: Pointer; const unkForRelease: Pointer): TStgMedium; overload; begin Result.tymed := tymed; Result.stm := pUnknown; Result.unkForRelease := unkForRelease; end; function OLEStgMedium(const tymed: LongInt; const lpszFileName: POleStr; const unkForRelease: Pointer): TStgMedium; overload; begin Result.tymed := tymed; Result.lpszFileName := lpszFileName; Result.unkForRelease := unkForRelease; end; //procedure GMFreeMetafileHandle(const HMetaFile: HGlobal); //var P: Pointer; //begin //if HMetaFile <> 0 then // begin // P := GlobalLock(HMetaFile); // try // if P <> nil then DeleteMetaFile(PMetaFilePict(P)^.hMF); // finally // GlobalUnlock(HMetaFile); // end; // GlobalFree(HMetaFile); // end; //end; function GMRegKeyAsString(const ARootKey: HKEY): TGMString; begin case ARootKey of HKEY_CLASSES_ROOT: Result := 'HKEY_CLASSES_ROOT'; HKEY_CURRENT_USER: Result := 'HKEY_CURRENT_USER (' + GMThisUserName + ')'; HKEY_LOCAL_MACHINE: Result := 'HKEY_LOCAL_MACHINE'; HKEY_USERS: Result := 'HKEY_USERS'; HKEY_PERFORMANCE_DATA: Result := 'HKEY_PERFORMANCE_DATA'; HKEY_CURRENT_CONFIG: Result := 'HKEY_CURRENT_CONFIG'; HKEY_DYN_DATA: Result := 'HKEY_DYN_DATA'; else Result := GMFormat('HKEY(Dez: %u, Hex: 0x%x)', [ARootKey, ARootKey]); end; end; { -------------------------- } { ---- Compare Routines ---- } { -------------------------- } function GMCompareNames(const AName1, AName2: TGMString; const ACmpareFlags: DWORD; ALocale: LCID): TGMCompareResult; begin if ALocale = 0 then ALocale := LOCALE_USER_DEFAULT; Result := TGMCompareResult(CompareString(ALocale, ACmpareFlags, PGMChar(AName1), Length(AName1), PGMChar(AName2), Length(AName2)) - 1); end; function GMCompareByInstance(const ItemA, ItemB: IUnknown): TGMCompareResult; begin if PtrUInt(ItemA) > PtrUInt(ItemB) then Result := crAGreaterThanB else if PtrUInt(ItemA) = PtrUInt(ItemB) then Result := crAEqualToB else Result := crALessThanB; end; function GMCompareByLeft(const ItemA, ItemB: IUnknown): TGMCompareResult; var leftA, leftB: IGMGetLeft; begin GMCheckQueryInterface(ItemA, IGMGetLeft, leftA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMGetLeft, leftB, {$I %CurrentRoutine%}); if leftA.Left > leftB.Left then Result := crAGreaterThanB else if leftA.Left = leftB.Left then Result := crAEqualToB else Result := crALessThanB; end; function GMCompareByName(const ItemA, ItemB: IUnknown): TGMCompareResult; var nameA, nameB: IGMGetName; begin GMCheckQueryInterface(ItemA, IGMGetName, nameA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMGetName, nameB, {$I %CurrentRoutine%}); Result := GMCompareNames(nameA.Name, nameB.Name); end; function GMCompareByString(const ItemA, ItemB: IUnknown): TGMCompareResult; var nameA, nameB: IGMGetName; // cmp: LongInt; begin GMCheckQueryInterface(ItemA, IGMGetName, nameA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMGetName, nameB, {$I %CurrentRoutine%}); Result := GMCompareNames(nameA.Name, nameB.Name, 0); end; function GMCompareByNameDigitsAsNumbers(const ItemA, ItemB: IUnknown): TGMCompareResult; var nameA, nameB: IGMGetName; caseFlags: DWORD; begin caseFlags := NORM_IGNORECASE; if gDigitAsNumberSortSupported then caseFlags := caseFlags or SORT_DIGITSASNUMBERS; GMCheckQueryInterface(ItemA, IGMGetName, nameA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMGetName, nameB, {$I %CurrentRoutine%}); Result := GMCompareNames(nameA.Name, nameB.Name, caseFlags); end; function GMCompareByFileName(const ItemA, ItemB: IUnknown): TGMCompareResult; var nameA, nameB: IGMGetFileName; begin GMCheckQueryInterface(ItemA, IGMGetFileName, nameA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMGetFileName, nameB, {$I %CurrentRoutine%}); Result := GMCompareNames(nameA.FileName, nameB.FileName); end; function GMCompareByPosition(const ItemA, ItemB: IUnknown): TGMCompareResult; var positionA, positionB: IGMGetPosition; begin GMCheckQueryInterface(ItemA, IGMGetPosition, positionA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMGetPosition, positionB, {$I %CurrentRoutine%}); if positionA.Position > positionB.Position then Result := crAGreaterThanB else if positionA.Position = positionB.Position then Result := crAEqualToB else Result := crALessThanB; end; //function GMCompareByKeyValue(const ItemA, ItemB: IUnknown): TGMCompareResult; //var keyValueA, keyValueB: IGMGetKeyValue; //begin // GMCheckQueryInterface(ItemA, IGMGetKeyValue, keyValueA, {$I %CurrentRoutine%}); // GMCheckQueryInterface(ItemB, IGMGetKeyValue, keyValueB, {$I %CurrentRoutine%}); // if keyValueA.KeyValue > keyValueB.KeyValue then Result := crAGreaterThanB else // if keyValueA.KeyValue = keyValueB.KeyValue then Result := crAEqualToB else // Result := crALessThanB; //end; function GMCompareByGuid(const ItemA, ItemB: IUnknown): TGMCompareResult; var guidA, guidB: IGMGetGUID; begin GMCheckQueryInterface(ItemA, IGMGetGUID, guidA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMGetGUID, guidB, {$I %CurrentRoutine%}); Result := GMCompareGuids(guidA.Guid, guidB.Guid); end; function GMCompareByHandle(const ItemA, ItemB: IUnknown): TGMCompareResult; var handleA, handleB: IGMGetHandle; begin GMCheckQueryInterface(ItemA, IGMGetHandle, handleA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMGetHandle, handleB, {$I %CurrentRoutine%}); if handleA.Handle > handleB.Handle then Result := crAGreaterThanB else if handleA.Handle = handleB.Handle then Result := crAEqualToB else Result := crALessThanB; end; function GMCompareFileEntryByName(const ItemA, ItemB: IUnknown): TGMCompareResult; var entryA, entryB: IGMFileProperties; begin GMCheckQueryInterface(ItemA, IGMFileProperties, entryA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMFileProperties, entryB, {$I %CurrentRoutine%}); Result := GMCompareNames(entryA.FileName, entryB.FileName); end; function GMCompareFileEntryBySize(const ItemA, ItemB: IUnknown): TGMCompareResult; var entryA, entryB: IGMFileProperties; begin GMCheckQueryInterface(ItemA, IGMFileProperties, entryA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMFileProperties, entryB, {$I %CurrentRoutine%}); if entryA.SizeInBytes > entryB.SizeInBytes then Result := crAGreaterThanB else if entryA.SizeInBytes = entryB.SizeInBytes then Result := crAEqualToB else Result := crALessThanB; end; function GMCompareFileEntryByLastMod(const ItemA, ItemB: IUnknown): TGMCompareResult; var entryA, entryB: IGMFileProperties; begin GMCheckQueryInterface(ItemA, IGMFileProperties, entryA, {$I %CurrentRoutine%}); GMCheckQueryInterface(ItemB, IGMFileProperties, entryB, {$I %CurrentRoutine%}); if entryA.LastWriteTime > entryB.LastWriteTime then Result := crAGreaterThanB else if entryA.LastWriteTime = entryB.LastWriteTime then Result := crAEqualToB else Result := crALessThanB; end; procedure GMParseLines(const AMultiLineText: TGMString; const AAddLineFunc: TGMAddLineFunc; const AData: Pointer; const AddEmptyLines: Boolean = False); const cLineEndSize: array [Boolean] of PtrInt = (1, 2); var lnStart, lnEnd: PGMChar; lineLenInChars, lineEndSizeInChars: PtrInt; i: LongWord; line: TGMString; begin if not Assigned(AAddLineFunc) or (Length(AMultiLineText) <= 0) then Exit; lnStart := PGMChar(AMultiLineText); lnEnd := lnStart; lineEndSizeInChars := 0; SetLength(line, 0); repeat for i:=0 to High(i) do case lnEnd^ of #0: begin lnEnd := nil; Break; end; #10: begin lineEndSizeInChars := cLineEndSize[(lnEnd + 1)^ = #13]; Break; end; #13: begin lineEndSizeInChars := cLineEndSize[(lnEnd + 1)^ = #10]; Break; end; else Inc(lnEnd); end; if lnEnd <> nil then lineLenInChars := lnEnd - lnStart else if lnStart^= #0 then lineLenInChars := 0 else lineLenInChars := PGMChar(AMultiLineText) + Length(AMultiLineText) - lnStart; SetString(line, lnStart, lineLenInChars); if (Length(line) > 0) or AddEmptyLines then if not AAddLineFunc(line, lnEnd <> nil, AData) then Break; if lnEnd <> nil then lnEnd += lineEndSizeInChars; lnStart := lnEnd; until lnEnd = nil; end; function GMAddLineToStrArray(const ALine: TGMString; const AEndsWithLineBreak: Boolean; const AData: Pointer): Boolean; begin if AData = nil then Result := False else begin GMAddStrToArray(ALine, PGMStringArray(AData)^, True); Result := True; end; end; procedure GMParseLinesToStrArray(const AMultiLineText: TGMString; var ADstLines: TGMStringArray; const AddEmptyLines: Boolean = False); begin SetLength(ADstLines, 0); if Length(AMultiLineText) > 0 then GMParseLines(AMultiLineText, GMAddLineToStrArray, @ADstLines, AddEmptyLines); end; procedure GMSplitWordsToStrArray(const AValue, ASeparators: TGMString; const AAllowDuplicates: Boolean; var ADestStrings: TGMStringArray); var chPos: PtrInt; token: TGMString; begin SetLength(ADestStrings, 0); chPos := 1; repeat token := GMNextWord(chPos, AValue, ASeparators); if (Length(token) > 0) and (AAllowDuplicates or not GMIsOneOfStrings(token, ADestStrings)) then GMAddStrToArray(token, ADestStrings); until Length(token) <= 0; end; { --------------------- } { ---- Scroll Data ---- } { --------------------- } function GMScrollData(const fMask: UINT; const nMin: LongInt; const nMax: LongInt; const nPage: UINT; const nPos: LongInt; const nTrackPos: LongInt): TScrollInfo; begin Result.cbSize := SizeOf(Result); Result.fMask := fMask; Result.nMin := nMin; Result.nMax := nMax; Result.nPage := nPage; Result.nPos := nPos; Result.nTrackPos := nTrackPos; end; function GMScrollDataFromWnd(const AHandle: HWnd; const ACtlKind, AMask: LongWord): TScrollInfo; begin //FillByte(Result, SizeOf(Result), 0); Result := Default(TScrollInfo); Result.cbSize := SizeOf(Result); Result.fMask := AMask; GetScrollInfo(AHandle, ACtlKind, Result); // <- leaves Result untouched when it fails end; function GMWheelScrollDelta(const PageSize: LongInt; const Direction: LongInt): LongInt; const cSign: array [Boolean] of LongInt = (1, -1); cPercent: array [Boolean] of Double = (0.13, 0.67); begin Result := Round(PageSize * cSign[Direction < 0] * cPercent[GetKeyState(VK_CONTROL) < 0]); end; function GMCalcScrollPos(const AScrollCode: LongInt; const AScrollData: TScrollInfo): LongInt; //var AScrollData: TScrollInfo; function LineScrollAmmount: LongInt; begin Result := Max(1, Round(AScrollData.nPage * 0.06)); end; function PageScrollAmmount: LongInt; begin Result := Max(1, Round(AScrollData.nPage * 0.95)); end; begin //if AWnd = 0 then begin Result := 0; Exit; end; Result := AScrollData.nPos; case AScrollCode of SB_TOP: Result := AScrollData.nMin; SB_BOTTOM: Result := AScrollData.nMax; SB_LINEDOWN: Inc(Result, LineScrollAmmount); SB_LINEUP: Dec(Result, LineScrollAmmount); SB_PAGEDOWN: Inc(Result, PageScrollAmmount); SB_PAGEUP: Dec(Result, PageScrollAmmount); SB_THUMBPOSITION, SB_THUMBTRACK: Result := AScrollData.nTrackPos; // Result := GMScrollDataFromWnd(Handle, SB_CTL, SIF_TRACKPOS).nTrackPos; //SB_ENDSCROLL: end; Result := GMBoundedInt(Result, AScrollData.nMin, AScrollData.nMax - Max(LongInt(AScrollData.nPage)-1, 0)); end; { ----------------- } { ---- Tracing ---- } { ----------------- } function GMDfltDoTracing: Boolean; begin {$IFDEF DEBUG}Result := True;{$ELSE}Result := False;{$ENDIF} end; procedure GMTrace(const AText: TGMString; const APrefix: TGMTracePrefix); begin vfGMTrace(AText, cGMTracePrefixes[APrefix]); end; procedure GMDfltTraceLine(const ALine: TGMString); begin OutputDebugString(PGMChar(ALine)); end; function GMPrefixedTrace(const ALine: TGMString; const ALastLine: Boolean; const AData: Pointer): Boolean; var prefix: TGMString; begin Result := True; if (AData <> nil) and (PGMChar(AData)^ <> #0) then begin prefix := PGMChar(AData); vfGMTraceLine('[' + prefix + '] ' + ALine); end else vfGMTraceLine(ALine); end; //procedure GMIterateLines(const AText: TGMString; const ALineProc: TProcessLineProc; const AData: Pointer); //var a,b : LongInt; //procedure TellLine; //var s: TGMString; //begin // s := GMStripRight(Copy(AText, a, b-a), cNewLine); // if Length(s) > 0 then ALineProc(s, AData); //end; //begin //if not Assigned(ALineProc) then Exit; //a:=1; b:=1; //while b <= Length(AText) do // if not GMIsDelimiter(cNewLine, AText, b) then Inc(b) else // begin // TellLine; // while GMIsDelimiter(cNewLine, AText, b) do Inc(b); // a:=b; // end; //TellLine; //end; procedure GMDfltTrace(const AText: TGMString; const APrefix: TGMString); var threadSync: RGMCriticalSectionLock; begin threadSync.Lock(gCStraceText); if not vfGMDoTracing then Exit; // <- Do it inside critical section? Maybe it needs some initialization .. GMParseLines(AText, GMPrefixedTrace, PGMChar(APrefix)); end; procedure GMTraceMethod(const AObj: TObject; const AMethodName: TGMString; const AText: TGMString = ''); begin if not vfGMDoTracing then Exit; if AText <> '' then GMTrace(GMFormat('%s[%p].%s: %s', [GMObjClassName(AObj), Pointer(AObj), AMethodName, AText]), tpCall) else GMTrace(GMFormat('%s[%p].%s', [GMObjClassName(AObj), Pointer(AObj), AMethodName]), tpCall); end; procedure GMTraceException(const AException: TObject; const ASingleLine: Boolean); var ExceptInfo: IGMExceptionInformation; Msg: TGMString; begin try //if (AException = nil) or not (AException is Exception) or not vfGMDoTracing then Exit; //with AException as Exception do if AsSingleLine then Msg := GMMakeSingleLine(Message) else Msg := Message; //vfGMTrace(GMFormat('%s: %s', [AException.ClassName, Msg]), tpException); if not vfGMDoTracing then Exit; ExceptInfo := TGMExceptionInformation.CreateFromObj(AException, True); Msg := GMBuildExceptionMsg(ExceptInfo, True); if ASingleLine then Msg := GMMakeSingleLine(Msg); GMTrace(Msg, tpException); except end; end; procedure GMTraceAllInterfaces(const AIntf: IUnknown; const AName: TGMString); var RegKey: IGMRegKey; SubDirNames: TGMStringArray; i: LongInt; PIUnk: IUnknown; begin if AIntf = nil then Exit; RegKey := TGMRegKey.Create; if not RegKey.Obj.OpenKey(HKEY_CLASSES_ROOT, '\Interface') then Exit; RegKey.Obj.ReadSubKeyNames(SubDirNames); for i:=Low(SubDirNames) to High(SubDirNames) do try //if Registry.OpenKey('\Interface\' + SubDirNames[i], False) then IntfName := Registry.ReadString('') else IntfName := ''; if GMQueryInterface(AIntf, GMStringToGuid(SubDirNames[i]), PIUnk) then GMTrace(GMFormat('"%s" Supports Interface: %s %s', [AName, GMIntfIIDName(SubDirNames[i]), SubDirNames[i]]), tpInterface); except end; end; { --------------------------------- } { ---- Complex Data Load Store ---- } { --------------------------------- } function GMRectValName(const ARectName, AValueName: TGMString): TGMString; begin Result := GMStringJoin(ARectName, ' ', AValueName); //GMStrip(GMFormat('%s %s', [ARectName, AValueName]), cWhiteSpace); end; {function GMReadValidRect(const Source: IGMValueStorage; const RectName: TGMString; var Value: TRect; const DefaultValue: LongInt): Boolean; begin if Source <> nil then begin Value.Left := Source.ReadInteger(GMRectValName(RectName, cStrLeft), DefaultValue); Value.Top := Source.ReadInteger(GMRectValName(RectName, cStrTop), DefaultValue); Value.Right := Source.ReadInteger(GMRectValName(RectName, cStrRight), DefaultValue); Value.Bottom := Source.ReadInteger(GMRectValName(RectName, cStrBottom), DefaultValue); end; Result := (Value.Left <> DefaultValue) and (Value.Top <> DefaultValue); end;} function GMReadRect(const ASource: IGMValueStorage; const ARectName: TGMString; const ADefaultRect: TRect): TRect; begin Result := ADefaultRect; if ASource = nil then Exit; Result.Left := ASource.ReadInteger(GMRectValName(ARectName, cStrLeft), ADefaultRect.Left); Result.Top := ASource.ReadInteger(GMRectValName(ARectName, cStrTop), ADefaultRect.Top); Result.Right := ASource.ReadInteger(GMRectValName(ARectName, cStrRight), ADefaultRect.Right); Result.Bottom := ASource.ReadInteger(GMRectValName(ARectName, cStrBottom), ADefaultRect.Bottom); end; procedure GMWriteRect(const ADest: IGMValueStorage; const ARectName: TGMString; const AValue: TRect; const ADefaultValue: LongInt); begin if ADest = nil then Exit; GMStoreInteger(ADest, GMRectValName(ARectName, cStrLeft), AValue.Left, ADefaultValue); GMStoreInteger(ADest, GMRectValName(ARectName, cStrTop), AValue.Top, ADefaultValue); GMStoreInteger(ADest, GMRectValName(ARectName, cStrRight), AValue.Right, ADefaultValue); GMStoreInteger(ADest, GMRectValName(ARectName, cStrBottom), AValue.Bottom, ADefaultValue); end; { cStrFontCharset = 'charset'; cStrFontColor = 'Color'; cStrFontHeight = 'Height'; cStrFontName = 'Name'; cStrFontPitch = 'Pitch'; cStrFontSize = 'Size'; cStrFontStyle = 'Style'; function GMFontStyleToInt(const Value: TFontStyles): LongInt; var i: TFontStyle; begin Result := 0; for i:=Low(i) to High(i) do if i in Value then Result := Result or (1 shl Ord(i)); end; function GMFontStyleFromInt(const Value: LongInt): TFontStyles; var i: TFontStyle; begin Result := []; for i:=Low(i) to High(i) do if Value and (1 shl Ord(i)) <> 0 then Include(Result, i); end; procedure GMReadFont(const Source: IGMValueStorage; const FontName: TGMString; const Font: TFont); begin if Source = nil then Exit; Font.Charset := TFontCharset(Source.ReadInteger(GMFormat('%s %s', [FontName, cStrFontCharset]), cDfltFontCharset)); Font.Color := TColor(Source.ReadInteger(GMFormat('%s %s', [FontName, cStrFontColor]), cDfltFontColor)); Font.Height := Source.ReadInteger(GMFormat('%s %s', [FontName, cStrFontHeight]), cDfltFontHeight); Font.Name := Source.ReadString(GMFormat('%s %s', [FontName, cStrFontName]), cDfltFontName); Font.Pitch := TFontPitch(Source.ReadInteger(GMFormat('%s %s', [FontName, cStrFontPitch]), cDfltFontPitch)); Font.Size := Source.ReadInteger(GMFormat('%s %s', [FontName, cStrFontSize]), cDfltFontSize); Font.Style := GMFontStyleFromInt(Source.ReadInteger(GMFormat('%s %s', [FontName, cStrFontStyle]), GMFontStyleToInt(cDfltFontStyle))); end; procedure GMWriteFont(const Dest: IGMValueStorage; const FontName: TGMString; const Font: TFont); begin if Dest = nil then Exit; GMStoreInteger(Dest, GMFormat('%s %s', [FontName, cStrFontCharset]), LongInt(Font.Charset), cDfltFontCharset); GMStoreInteger(Dest, GMFormat('%s %s', [FontName, cStrFontColor]), Font.Color, cDfltFontColor); GMStoreInteger(Dest, GMFormat('%s %s', [FontName, cStrFontHeight]), Font.Height, cDfltFontHeight); GMStoreString(Dest, GMFormat('%s %s', [FontName, cStrFontName]), Font.Name, cDfltFontName); GMStoreInteger(Dest, GMFormat('%s %s', [FontName, cStrFontPitch]), LongInt(Font.Pitch), cDfltFontPitch); GMStoreInteger(Dest, GMFormat('%s %s', [FontName, cStrFontSize]), Font.Size, cDfltFontSize); GMStoreInteger(Dest, GMFormat('%s %s', [FontName, cStrFontStyle]), GMFontStyleToInt(Font.Style), GMFontStyleToInt(cDfltFontStyle)); end;} { ---------------------------------- } { ---- Core TGMString functions ---- } { ---------------------------------- } function GMStrLScanA(AStr: PAnsiChar; ACh: AnsiChar; AMaxLen: PtrUInt): PAnsiChar; // 64-Bit: RCX = AStr, RDX = ACh, R8 = AMaxLen // 32-Bit: On enter EAX contains AStr, EDX contains ACh and ECX AMaxLen. // On Exit EAX contains Result pointer (may be nil). asm {$IFDEF CPU64} PUSH RDI CMP AMaxLen, 0 JG @@1 MOV RAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV RAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: MOV RDI, AStr // RCX MOV RCX, AMaxLen MOV AL, ACh REPNE SCASB MOV RAX, 0 JNE @@3 MOV RAX, RDI DEC RAX @@3: POP RDI {$ELSE} PUSH EDI CMP ECX, 0 // AMaxLen JG @@1 MOV EAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV EAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: MOV EDI, AStr // prepare SCASx operation MOV AL, ACh REPNE SCASB // <- Scan while unequal MOV EAX, 0 JNE @@3 MOV EAX, EDI DEC EAX @@3: POP EDI {$ENDIF} end; function GMStrLScanW(AStr: PWideChar; ACh: WideChar; AMaxLen: PtrUInt): PWideChar; // 64-Bit: RCX = AStr, RDX = ACh, R8 = AMaxLen // 32-Bit: On enter EAX contains AStr, EDX contains ACh and ECX AMaxLen. // On Exit EAX contains Result pointer (may be nil). asm {$IFDEF CPU64} PUSH RDI CMP AMaxLen, 0 JG @@1 MOV RAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV RAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: MOV RDI, AStr MOV RCX, AMaxLen MOV AX, ACh REPNE SCASW // <- Scan while unequal MOV RAX, 0 JNE @@3 MOV RAX, RDI SUB RAX, 2 @@3: POP RDI {$ELSE} PUSH EDI CMP ECX, 0 // AMaxLen JG @@1 MOV EAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV EAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: MOV EDI, AStr MOV AX, ACh REPNE SCASW // <- Scan while unequal MOV EAX, 0 JNE @@3 MOV EAX, EDI SUB EAX, 2 @@3: POP EDI {$ENDIF} end; function GMStrLScan(AStr: PGMChar; ACh: TGMChar; AMaxLen: PtrUInt): PGMChar; begin {$IFDEF UNICODE} Result := GMStrLScanW(AStr, ACh, AMaxLen); {$ELSE} Result := GMStrLScanA(AStr, ACh, AMaxLen); {$ENDIF} end; function GMStrLScanPos(const AValue: TGMString; AChToFind: TGMChar; AStartChPos: PtrInt): PtrInt; var pEndCh: PGMChar; begin if (AStartChPos < 1) or (AStartChPos > Length(AValue)) then pEndCh := nil else pEndCh := GMStrLScan(PGMChar(@AValue[AStartChPos]), AChToFind, Length(AValue)-AStartChPos+1); if pEndCh <> nil then Result := pEndCh + AStartChPos - PGMChar(@AValue[AStartChPos]) else Result := Length(AValue) + 1; end; function GMStrRLScanA(AStr: PAnsiChar; ACh: AnsiChar; AMaxLen: PtrUInt): PAnsiChar; // 64-Bit: RCX = AStr, RDX = ACh, R8 = AMaxLen // 32-Bit: On enter EAX contains AStr, EDX contains ACh and ECX AMaxLen. // On Exit EAX contains Result pointer (may be nil). asm {$IFDEF CPU64} PUSH RDI CMP AMaxLen, 0 JG @@1 MOV RAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV RAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: STD // <- set direction flag => reverse scan MOV RDI, AStr // RCX MOV RCX, AMaxLen // R8 MOV AL, ACh // RDX REPNE SCASB MOV RAX, 0 CLD // <- direction flag MUST be cleared! JNE @@3 MOV RAX, RDI INC RAX @@3: POP RDI {$ELSE} PUSH EDI CMP ECX, 0 // AMaxLen JG @@1 MOV EAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV EAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: STD // <- set direction flag => reverse scan MOV EDI, AStr MOV AL, ACh REPNE SCASB MOV EAX, 0 CLD // <- direction flag MUST be cleared! JNE @@3 MOV EAX, EDI INC EAX @@3: POP EDI {$ENDIF} end; function GMStrRLScanW(AStr: PWideChar; ACh: WideChar; AMaxLen: PtrUInt): PWideChar; // 64-Bit: RCX = AStr, RDX = ACh, R8 = AMaxLen // 32-Bit: On enter EAX contains AStr, EDX contains ACh and ECX AMaxLen. // On Exit EAX contains Result pointer (may be nil). asm {$IFDEF CPU64} PUSH RDI CMP AMaxLen, 0 JG @@1 MOV RAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV RAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: STD // <- set direction flag => reverse scan MOV RDI, AStr // RCX MOV RCX, AMaxLen // R8 MOV AX, ACh // RDX REPNE SCASW MOV RAX, 0 CLD // <- direction flag MUST be cleared! JNE @@3 MOV RAX, RDI ADD RAX, 2 @@3: POP RDI {$ELSE} PUSH EDI CMP ECX, 0 // AMaxLen JG @@1 MOV EAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV EAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: STD // <- set direction flag => reverse scan MOV EDI, AStr MOV AX, ACh REPNE SCASW MOV EAX, 0 CLD // <- direction flag MUST be cleared! JNE @@3 MOV EAX, EDI ADD EAX, 2 @@3: POP EDI {$ENDIF} end; function GMStrRLScan(AStr: PGMChar; ACh: TGMChar; AMaxLen: PtrUInt): PGMChar; begin {$IFDEF UNICODE} Result := GMStrRLScanW(AStr, ACh, AMaxLen); {$ELSE} Result := GMStrRLScanA(AStr, ACh, AMaxLen); {$ENDIF} end; function GMStrCLScanA(AStr: PAnsiChar; ACh: AnsiChar; AMaxLen: PtrUInt): PAnsiChar; // 64-Bit: RCX = AStr, RDX = ACh, R8 = AMaxLen // 32-Bit: On enter EAX contains AStr, EDX contains ACh and ECX AMaxLen. // On Exit EAX contains Result pointer (may be nil). asm {$IFDEF CPU64} PUSH RDI CMP AMaxLen, 0 JG @@1 MOV RAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV RAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: MOV RDI, AStr MOV RCX, AMaxLen MOV AL, ACh REPE SCASB MOV RAX, 0 JE @@3 MOV RAX, RDI DEC RAX @@3: POP RDI {$ELSE} PUSH EDI CMP ECX, 0 // AMaxLen JG @@1 MOV EAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV EAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: MOV EDI, AStr MOV AL, ACh REPE SCASB MOV EAX, 0 JE @@3 MOV EAX, EDI DEC EAX @@3: POP EDI {$ENDIF} end; function GMStrCLScanW(AStr: PWideChar; ACh: WideChar; AMaxLen: PtrUInt): PWideChar; // 64-Bit: RCX = AStr, RDX = ACh, R8 = AMaxLen // 32-Bit: On enter EAX contains AStr, EDX contains ACh and ECX AMaxLen. // On Exit EAX contains Result pointer (may be nil). asm {$IFDEF CPU64} PUSH RDI CMP AMaxLen, 0 JG @@1 MOV RAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV RAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: MOV RDI, AStr MOV RCX, AMaxLen MOV AX, ACh REPE SCASW MOV RAX, 0 JE @@3 MOV RAX, RDI SUB RAX, 2 @@3: POP RDI {$ELSE} PUSH EDI CMP ECX, 0 // AMaxLen JG @@1 MOV EAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV EAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: MOV EDI, AStr MOV AX, ACh REPE SCASW MOV EAX, 0 JE @@3 MOV EAX, EDI SUB EAX, 2 @@3: POP EDI {$ENDIF} end; function GMStrCLScan(AStr: PGMChar; ACh: TGMChar; AMaxLen: PtrUInt): PGMChar; begin {$IFDEF UNICODE} Result := GMStrCLScanW(AStr, ACh, AMaxLen); {$ELSE} Result := GMStrCLScanA(AStr, ACh, AMaxLen); {$ENDIF} end; function GMStrCRLScanA(AStr: PAnsiChar; ACh: AnsiChar; AMaxLen: PtrUInt): PAnsiChar; // 64-Bit: RCX = AStr, RDX = ACh, R8 = AMaxLen // 32-Bit: On enter EAX contains AStr, EDX contains ACh and ECX AMaxLen. // On Exit EAX contains Result pointer (may be nil). asm {$IFDEF CPU64} PUSH RDI CMP AMaxLen, 0 JG @@1 MOV RAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV RAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: STD // <- set direction flag => reverse scan MOV RDI, AStr // RCX MOV RCX, AMaxLen // R8 MOV AL, ACh // RDX REPE SCASB MOV RAX, 0 CLD // <- direction flag MUST be cleared! JE @@3 MOV RAX, RDI INC RAX @@3: POP RDI {$ELSE} PUSH EDI CMP ECX, 0 // AMaxLen JG @@1 MOV EAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV EAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: STD // <- set direction flag => reverse scan MOV EDI, AStr MOV AL, ACh REPE SCASB MOV EAX, 0 CLD // <- direction flag MUST be cleared! JE @@3 MOV EAX, EDI INC EAX @@3: POP EDI {$ENDIF} end; function GMStrCRLScanW(AStr: PWideChar; ACh: WideChar; AMaxLen: PtrUInt): PWideChar; // 64-Bit: RCX = AStr, RDX = ACh, R8 = AMaxLen // 32-Bit: On enter EAX contains AStr, EDX contains ACh and ECX AMaxLen. // On Exit EAX contains Result pointer (may be nil). asm {$IFDEF CPU64} PUSH RDI CMP AMaxLen, 0 JG @@1 MOV RAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV RAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: STD // <- set direction flag => reverse scan MOV RDI, AStr // RCX MOV RCX, AMaxLen // R8 MOV AX, ACh // RDX REPE SCASW MOV RAX, 0 CLD // <- direction flag MUST be cleared! JE @@3 MOV RAX, RDI ADD RAX, 2 @@3: POP RDI {$ELSE} PUSH EDI CMP ECX, 0 // AMaxLen JG @@1 MOV EAX, 0 JMP @@3 // <- exit returning nil if AMaxLen <= 0 @@1: CMP AStr, 0 JNE @@2 MOV EAX, 0 JMP @@3 // <- exit returning nil if AStr = nil @@2: STD // <- set direction flag => reverse scan MOV EDI, AStr MOV AX, ACh REPE SCASW MOV EAX, 0 CLD // <- direction flag MUST be cleared! JE @@3 MOV EAX, EDI ADD EAX, 2 @@3: POP EDI {$ENDIF} end; function GMStrCRLScan(AStr: PGMChar; ACh: TGMChar; AMaxLen: PtrUInt): PGMChar; begin {$IFDEF UNICODE} Result := GMStrCRLScanW(AStr, ACh, AMaxLen); {$ELSE} Result := GMStrCRLScanA(AStr, ACh, AMaxLen); {$ENDIF} end; function GMStrScanA(AStr: PAnsiChar; ACh: AnsiChar): PAnsiChar; // Searches until it hits either 0 or ACh asm {$IFDEF CPU64} MOV RAX, AStr TEST RAX, RAX JZ @@Exit // <- AStr is nil and Result is nil, Exit! @@Loop: CMP [RAX], DL JE @@Exit CMP BYTE PTR [RAX], 0 JE @@Clear INC RAX JMP @@Loop @@Clear: XOR RAX, RAX @@Exit: {$ELSE} TEST EAX, EAX JZ @@Exit // <- AStr is nil and Result is nil, Exit! @@Loop: CMP [EAX], DL JE @@Exit CMP BYTE PTR [EAX], 0 JE @@Clear INC EAX JMP @@Loop @@Clear: XOR EAX, EAX @@Exit: {$ENDIF} end; function GMStrScanW(AStr: PWideChar; ACh: WideChar): PWideChar; // Searches until it hits either 0 or ACh asm {$IFDEF CPU64} MOV RAX, AStr TEST RAX, RAX JZ @@Exit // <- AStr is nil and Result is nil, Exit! @@Loop: CMP [RAX], DX JE @@Exit CMP WORD PTR [RAX], 0 JE @@Clear ADD RAX, 2 JMP @@Loop @@Clear: XOR RAX, RAX @@Exit: {$ELSE} TEST EAX, EAX JZ @@Exit // <- AStr is nil and Result is nil, Exit! @@Loop: CMP [EAX], DX JE @@Exit CMP WORD PTR [EAX], 0 JE @@Clear ADD EAX, 2 JMP @@Loop @@Clear: XOR EAX, EAX @@Exit: {$ENDIF} end; //function GMStrScanA(AStr: PAnsiChar; ACh: AnsiChar): PAnsiChar; //begin //Result := AStr; //if Result = nil then Exit; //while (Result^ <> ACh) and (Result^ <> #0) do Inc(Result); //if Result^ <> ACh then Result := nil; //end; //function GMStrScanW(AStr: PWideChar; ACh: WideChar): PWideChar; //begin //Result := AStr; //if Result = nil then Exit; //while (Result^ <> ACh) and (Result^ <> #0) do Inc(Result); //if Result^ <> ACh then Result := nil; //end; function GMStrScan(AStr: PGMChar; ACh: TGMChar): PGMChar; begin {$IFDEF UNICODE} Result := GMStrScanW(AStr, ACh); {$ELSE} Result := GMStrScanA(AStr, ACh); {$ENDIF} end; function GMStrLCompA(const AStr1, AStr2: PAnsiChar; AMaxLen: PtrUInt): PtrInt; asm {$IFDEF CPU64} PUSH RDI PUSH RSI MOV RDI, AStr1 MOV RSI, AStr2 MOV RCX, AMaxLen XOR RAX, RAX XOR RDX, RDX OR RCX, RCX JE @@1 // <- check zero length REPE CMPSB MOV AL, [RSI-1] MOV DL, [RDI-1] SUB RAX, RDX @@1: POP RSI POP RDI {$ELSE} PUSH EDI PUSH ESI MOV EDI,EDX MOV ESI,EAX XOR EAX,EAX XOR EDX,EDX OR ECX,ECX JE @@1 // <- check zero length REPE CMPSB MOV AL,[ESI-1] MOV DL,[EDI-1] SUB EAX,EDX @@1: POP ESI POP EDI {$ENDIF} end; function GMStrLCompW(const AStr1, AStr2: PWideChar; AMaxLen: PtrUInt): PtrInt; asm {$IFDEF CPU64} PUSH RDI PUSH RSI MOV RDI, AStr1 MOV RSI, AStr2 MOV RCX, AMaxLen XOR RAX, RAX XOR RDX, RDX OR RCX, RCX JE @@1 // <- check zero length REPE CMPSW MOV AX, [RSI-2] MOV DX, [RDI-2] SUB RAX, RDX @@1: POP RSI POP RDI {$ELSE} PUSH EDI PUSH ESI MOV EDI,EDX MOV ESI,EAX XOR EAX,EAX XOR EDX,EDX OR ECX,ECX JE @@1 // <- check zero length REPE CMPSW MOV AX,[ESI-2] MOV DX,[EDI-2] SUB EAX,EDX @@1: POP ESI POP EDI {$ENDIF} end; function GMStrLComp(const AStr1, AStr2: PGMChar; AMaxLen: PtrUInt): PtrInt; begin {$IFDEF UNICODE} Result := GMStrLCompW(AStr1, AStr2, AMaxLen); {$ELSE} Result := GMStrLCompA(AStr1, AStr2, AMaxLen); {$ENDIF} end; function GMCompareMemory(const AContents1, AContents2: Pointer; const AMaxLenInBytes: PtrUInt): TGMCompareResult; var cmp: PtrInt; begin cmp := GMStrLCompA(AContents1, AContents2, AMaxLenInBytes); if cmp < 0 then Result := crALessThanB else if cmp = 0 then Result := crAEqualToB else Result := crAGreaterThanB; end; //function GMStrComp(const Str1, Str2: TGMString): LongInt; //begin //Result := GMStrLComp(PGMChar(Str1), PGMChar(Str2), Min(Length(Str1), Length(Str2))); //if Result = 0 then // begin // if Length(Str1) < Length(Str2) then Result := -1 // else // if Length(Str1) > Length(Str2) then Result := 1; // end; //end; function GMStrLICompA(const AStr1, AStr2: PAnsiChar; AMaxLen: PtrUInt): LongInt; asm {$IFDEF CPU64} PUSH RDI PUSH RSI MOV RDI, AStr1 MOV RSI, AStr2 MOV RCX, AMaxLen XOR RAX, RAX XOR RDX, RDX OR RCX, RCX JE @@4 // <- check zero length @@1: REPE CMPSB JE @@4 MOV AL, [RSI-1] CMP AL, 'a' JB @@2 CMP AL, 'z' JA @@2 SUB AL, 20H @@2: MOV DL, [RDI-1] CMP DL, 'a' JB @@3 CMP DL, 'z' JA @@3 SUB DL, 20H @@3: SUB RAX, RDX JE @@1 @@4: POP RSI POP RDI {$ELSE} PUSH EDI PUSH ESI MOV EDI,EDX MOV ESI,EAX XOR EAX,EAX XOR EDX,EDX OR ECX,ECX JE @@4 // <- check zero length @@1: REPE CMPSB JE @@4 MOV AL,[ESI-1] CMP AL,'a' JB @@2 CMP AL,'z' JA @@2 SUB AL,20H @@2: MOV DL,[EDI-1] CMP DL,'a' JB @@3 CMP DL,'z' JA @@3 SUB DL,20H @@3: SUB EAX,EDX JE @@1 @@4: POP ESI POP EDI {$ENDIF} end; function GMStrLICompW(const AStr1, AStr2: PWideChar; AMaxLen: PtrUInt): LongInt; asm {$IFDEF CPU64} PUSH RDI PUSH RSI MOV RDI, AStr1 MOV RSI, AStr2 MOV RCX, AMaxLen XOR RAX, RAX XOR RDX, RDX OR RCX, RCX JE @@4 // <- check zero length @@1: REPE CMPSW JE @@4 MOV AX, [RSI-2] CMP AX, 'a' JB @@2 CMP AX, 'z' JA @@2 SUB AX, 20H @@2: MOV DX, [RDI-2] CMP DX, 'a' JB @@3 CMP DX, 'z' JA @@3 SUB DX,20H @@3: SUB RAX,RDX JE @@1 @@4: POP RSI POP RDI {$ELSE} PUSH EDI PUSH ESI MOV EDI,EDX MOV ESI,EAX XOR EAX,EAX XOR EDX,EDX OR ECX,ECX JE @@4 // <- check zero length @@1: REPE CMPSW JE @@4 MOV AX,[ESI-2] CMP AX,'a' JB @@2 CMP AX,'z' JA @@2 SUB AX,20H @@2: MOV DX,[EDI-2] CMP DX,'a' JB @@3 CMP DX,'z' JA @@3 SUB DX,20H @@3: SUB EAX,EDX JE @@1 @@4: POP ESI POP EDI {$ENDIF} end; //function GMStrLICompA(const Str1, Str2: PAnsiChar; MaxLen: Cardinal): Integer; //var P1, P2: PAnsiChar; I: Cardinal; C1, C2: AnsiChar; //begin //P1 := Str1; P2 := Str2; I := 0; //while I < MaxLen do // begin // if P1^ in ['a'..'z'] then // C1 := AnsiChar(Byte(P1^) xor $20) // else // C1 := P1^; // // if P2^ in ['a'..'z'] then // C2 := AnsiChar(Byte(P2^) xor $20) // else // C2 := P2^; // // if (C1 <> C2) or (C1 = #0) then // begin Result := Ord(C1) - Ord(C2); Exit; end; // // Inc(P1); Inc(P2); Inc(I); // end; //Result := 0; //end; //function GMStrLICompW(const Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; //var P1, P2: PWideChar; I: Cardinal; C1, C2: WideChar; //begin //P1 := Str1; P2 := Str2; I := 0; //while I < MaxLen do // begin // if (P1^ >= 'a') and (P1^ <= 'z') then // C1 := WideChar(Word(P1^) xor $20) // else // C1 := P1^; // // if (P2^ >= 'a') and (P2^ <= 'z') then // C2 := WideChar(Word(P2^) xor $20) // else // C2 := P2^; // // if (C1 <> C2) or (C1 = #0) then // begin Result := Ord(C1) - Ord(C2); Exit; end; // // Inc(P1); Inc(P2); Inc(I); // end; //Result := 0; //end; function GMStrLIComp(const AStr1, AStr2: PGMChar; AMaxLen: PtrUInt): LongInt; begin //Result := lstrcmpi(Str1, Str2); CompareStringEx(...); {$IFDEF UNICODE} Result := GMStrLICompW(AStr1, AStr2, AMaxLen); {$ELSE} Result := GMStrLICompA(AStr1, AStr2, AMaxLen); {$ENDIF} end; function GMSameText(const AValue1, AValue2: TGMString): Boolean; begin Result := Length(AValue1) = Length(AValue2); if Result then Result := GMStrLIComp(PGMChar(AVAlue1), PGMChar(AValue2), Length(AValue1)) = 0; end; function GMStrCopyA(ADest, ASrc: PAnsiChar; ADstBufSize: PtrInt): PtrInt; begin if (ADest = nil) or (ASrc = nil) or (ADstBufSize <= 0) then Exit(0); for Result := 1 to ADstBufSize do begin ADest^ := ASrc^; Inc(ADest); Inc(ASrc); if ASrc^ = #0 then Break; end; end; function GMLoCaseW(ACh: WideChar): WideChar; begin Result := ACh; case ACh of 'A'..'Z': Result := WideChar(Word(ACh) or not $FFDF); end; end; function GMLoCaseA(ACh: AnsiChar): AnsiChar; begin Result := ACh; if Result in ['A'..'Z'] then Inc(Result, Ord('a')-Ord('A')); end; function GMLoCase(ACh: TGMChar): TGMChar; begin {$IFDEF UNICODE} Result := GMLoCaseW(ACh); {$ELSE} Result := GMLoCaseA(ACh); {$ENDIF} end; function GMUpCaseA(ACh: AnsiChar): AnsiChar; begin Result := ACh; if Result in ['a'..'z'] then Dec(Result, Ord('a')-Ord('A')); end; function GMUpCaseW(ACh: WideChar): WideChar; begin Result := ACh; case ACh of 'a'..'z': Result := WideChar(Word(ACh) and $FFDF); end; end; function GMUpCase(ACh: TGMChar): TGMChar; begin {$IFDEF UNICODE} Result := GMUpCaseW(ACh); {$ELSE} Result := GMUpCaseA(ACh); {$ENDIF} end; function GMUpperCaseA(const AValue: AnsiString): AnsiString; var i: Integer; begin Result := AValue; for i:= 1 to Length(Result) do Result[i] := GMUpCaseA(Result[i]); end; function GMUpperCaseW(const AValue: UnicodeString): UnicodeString; var i: Integer; begin Result := AValue; for i:= 1 to Length(Result) do Result[i] := GMUpCaseW(Result[i]); end; function GMUpperCase(const AValue: TGMString): TGMString; begin {$IFDEF UNICODE} Result := GMUpperCaseW(AValue); {$ELSE} Result := GMUpperCaseA(AValue); {$ENDIF} end; function GMLowerCase(const AValue: TGMString): TGMString; var i: Integer; begin Result := AValue; for i:= 1 to Length(Result) do Result[i] := GMLoCase(Result[i]); end; //function GMStrScanPas(const AValue: PGMChar; Ch: TGMChar): PGMChar; //begin //Result := AValue; //if Result = nil then Exit; //while (Result^ <> Ch) and (Result^ <> #0) do Inc(Result); //if Result^ = #0 then Result := nil; //end; { ----------------------------- } { ---- TGMString functions ---- } { ----------------------------- } function GMTimeToString(const ADateTime: TDateTime): TGMString; var hour, minute, second, milliSeconds: Word; function LeftPaddedInt(AIntVal: Word; ALen: Word = 2): TGMString; begin Result := GMIntToStr(AIntVal); while Length(Result) < ALen do Result := '0' + Result; end; begin DecodeTime(ADateTime, hour, minute, second, milliSeconds); Result := LeftPaddedInt(hour) + FormatSettings.TimeSeparator + LeftPaddedInt(minute) + FormatSettings.TimeSeparator + LeftPaddedInt(second); if milliSeconds <> 0 then Result += '.' + LeftPaddedInt(milliSeconds, 3); end; function GMDateTimeToStr(const ADateTime: TDateTime): TGMString; var formatStr: TGMString; {$IFDEF UNICODE}dateStr: AnsiString;{$ENDIF} begin if GMDateIsNull(ADateTime) then begin //if GMTimeIsNull(ADateTime) then Exit('') else Exit(GMTimeToString(ADateTime)); Exit(GMTimeToString(ADateTime)); end else begin formatStr := DefaultFormatSettings.ShortDateFormat; {$IFDEF UNICODE} DateTimeToString(dateStr, formatStr, ADateTime); Result := dateStr; {$ELSE} DateTimeToString(Result, FormatStr, ADateTime); {$ENDIF} if not GMTimeIsNull(ADateTime) then Result := GMStringJoin(Result, ' ', GMTimeToString(ADateTime)); end; end; function GMCommonPrefixLen(const Str1, Str2: TGMString; const IngoreCase: Boolean = True): LongInt; begin Result := 0; while (Result < Length(Str1)) and (Result < Length(Str2)) do begin if IngoreCase then begin if GMUpCase(Str1[Result+1]) <> GMUpCase(Str2[Result+1]) then Break; end else begin if Str1[Result+1] <> Str2[Result+1] then Break; end; Inc(Result); end; end; function GMQuote(const AValue: TGMString; const ALeftQuote, ARightQuote: TGMChar): TGMString; begin Result := GMStripRight(GMStripLeft(AValue, ALeftQuote), ARightQuote); //if Result <> '' then Result := ALeftQuote + Result + ARightQuote; end; //function GMRemoveQuotes(const AValue: TGMString; const ALeftQuotes, ARightQuotes: TGMString): TGMString; //begin //Result := AValue; //if (Length(Result) > 0) and (Length(ALeftQuotes) > 0) and GMIsdelimiter(ALeftQuotes, Result, 1) then System.Delete(Result, 1, 1); //if (Length(Result) > 0) and (Length(ARightQuotes) > 0) and GMIsdelimiter(ARightQuotes, Result, Length(Result)) then System.Delete(Result, Length(Result), 1); //end; function GMRemoveQuotes(const AValue: TGMString; const ALeftQuote, ARightQuote: TGMChar): TGMString; var startChPos, endChPos: PtrInt; begin if Length(AValue) <= 0 then Result := AValue else begin if AValue[1] = ALeftQuote then startChPos := 2 else startChPos := 1; if (Length(AValue) >= startChPos) and (AValue[Length(AValue)] = ARightQuote) then endChPos := Length(AValue) else endChPos := Length(AValue) + 1; if (startChPos = 1) and (endChPos = Length(AValue) + 1) then Result := AValue else Result := System.Copy(AValue, startChPos, endChPos - startChPos); end; end; //function GMResolveEscapeChars2(const Value: TGMString; const EscCh: TGMChar): TGMString; //var chPos, startPos, ASCII: LongInt; //begin //Result := Value; //chPos := 1; //while chPos <= Length(Result) do // if not (Result[chPos] = EscCh) then Inc(chPos) else // begin // startPos := chPos; // Inc(chPos); // if (chPos <= Length(Result)) and (Result[chPos] = EscCh) then System.Delete(Result, chPos, 1) // else // begin // while (chPos <= Length(Result)) and GMIsDigit(Result[chPos]) do Inc(chPos); // ASCII := GMStrToInt(GMMakeDezInt(Copy(Result, startPos, chPos - startPos), -1)); // System.Delete(Result, startPos, chPos - startPos); // if GMIsInRange(ASCII, 0, 255) then System.Insert(Chr(ASCII), Result, startPos); // chPos := startPos + 1; // end; // end; //end; function GMIsPrefixStr(const APrefix, AValue: TGMString; const AIngoreCase: Boolean): Boolean; var len: PtrInt; begin if APrefix = '' then Result := False else begin len := Min(Length(APrefix), Length(AValue)); if len < Length(APrefix) then Result := False else if AIngoreCase then Result := GMStrLIComp(PGMChar(APrefix), PGMChar(AValue), len) = 0 else Result := GMStrLComp(PGMChar(APrefix), PGMChar(AValue), len) = 0; end; end; function GMDeleteLastWord(const Value: TGMString; const Separators: TGMString): TGMString; var chPos: PtrInt; begin Result := Value; chPos := Length(Result); while (chPos >= 1) and GMIsDelimiter(Separators, Result, chPos) do Dec(chPos); //if chPos < Length(Result) then System.Delete(Result, chPos+1, Length(Result)-chPos); //chPos := Length(Result); while (chPos >= 1) and not GMIsDelimiter(Separators, Result, chPos) do Dec(chPos); //if chPos < Length(Result) then System.Delete(Result, chPos+1, Length(Result)-chPos); //chPos := Length(Result); while (chPos >= 1) and GMIsDelimiter(Separators, Result, chPos) do Dec(chPos); if chPos < Length(Result) then System.Delete(Result, chPos+1, Length(Result)-chPos); end; function GMDeleteFirstWord(const Value: TGMString; const Separators: TGMString; const StripSeparators: Boolean = True): TGMString; var chPos: PtrInt; begin Result := Value; chPos := 1; While (chPos <= Length(Result)) and GMIsDelimiter(Separators, Result, chPos) do Inc(chPos); if chPos > 1 then System.Delete(Result, 1, chPos-1); chPos := 1; While (chPos <= Length(Result)) and not GMIsDelimiter(Separators, Result, chPos) do Inc(chPos); if chPos > 1 then System.Delete(Result, 1, chPos-1); if not StripSeparators then Exit; chPos := 1; While (chPos <= Length(Result)) and GMIsDelimiter(Separators, Result, chPos) do Inc(chPos); if chPos > 1 then System.Delete(Result, 1, chPos-1); end; function GMDeleteFirstWords(const Value: TGMString; const WordCount: LongInt; const Separators: TGMString): TGMString; var i: LongInt; begin Result := Value; for i:=1 to WordCount do Result := GMDeleteFirstWord(Result, Separators); end; function GMDeleteNextWord(const AchPos: PtrInt; const Value, Separators: TGMString): TGMString; var chps: LongInt; begin Result := Value; if Length(Result) >= AChPos then begin chps := AChPos; While (chps <= Length(Result)) and GMIsDelimiter(Separators, Result, chps) do Inc(chps); if chps > AChPos then System.Delete(Result, AChPos, chps-AChPos); chps := AChPos; While (chps <= Length(Result)) and not GMIsDelimiter(Separators, Result, chps) do Inc(chps); if chps > AChPos then System.Delete(Result, AChPos, chps-AChPos); chps := AChPos; While (chps <= Length(Result)) and GMIsDelimiter(Separators, Result, chps) do Inc(chps); if chps > AChPos then System.Delete(Result, AChPos, chps-AChPos); end; end; function GMFindToken(const AText, AToken: TGMString; var AChPos: PtrInt; const ASeparators: TGMString; AWholeWords: Boolean; const AIgnoreCase: Boolean): Boolean; var len, TokenLen: LongInt; function IsSubStrAtPos(const AText, AToken: TGMString; const AChPos: LongInt): Boolean; begin if AIgnoreCase then Result := GMStrLIComp(@AText[AChPos], PGMChar(AToken), TokenLen) = 0 else Result := GMStrLComp(@AText[AChPos], PGMChar(AToken), TokenLen) = 0; end; begin Result := False; len := Length(AText); TokenLen := Length(AToken); if AChPos < 1 then AChPos := 1; if AChPos > len - TokenLen + 1 then Exit; //if not GMIsInRange(AChPos, 1, len - TokenLen + 1) then Exit; if TokenLen = 0 then Exit; if ASeparators = '' then AWholeWords := False; if AWholeWords then while (AChPos <= len - TokenLen + 1) and GMIsDelimiter(ASeparators, AText, AChPos) do Inc(AChPos); while (AChPos <= len - TokenLen + 1) and not Result do begin if IsSubStrAtPos(AText, AToken, AChPos) then begin if not AWholeWords then Result := True else begin if len < AChPos + TokenLen then Result := True else if GMIsDelimiter(ASeparators, AText, AChPos + TokenLen) then Result := True; end; end; if not Result then if not AWholeWords then Inc(AChPos) else begin while (AChPos <= len - TokenLen + 1) and not GMIsDelimiter(ASeparators, AText, AChPos) do Inc(AChPos); while (AChPos <= len - TokenLen + 1) and GMIsDelimiter(ASeparators, AText, AChPos) do Inc(AChPos); end; end; end; function GMHasToken(const AValue, AToken, ASeparators: TGMString; AWholeWords, AIgnoreCase: Boolean ): Boolean; var chPos: PtrInt; begin chPos := 1; Result := GMFindToken(AValue, AToken, chPos, ASeparators, AWholeWords, AIgnoreCase); end; function GMTokenCount(const AValue, AToken, ASeparators: TGMString; AWholeWords, AIgnoreCase: Boolean): LongInt; var chPos: PtrInt; begin chPos := 1; Result := 0; while GMFindToken(AValue, AToken, chPos, ASeparators, AWholeWords, AIgnoreCase) do begin Inc(Result); Inc(chPos, Length(AToken)); end; end; function GMDeleteWords(const AValue: TGMString; const AWords: array of TGMString; const ASeparators: TGMString; const AWholeWords, AIgnoreCase: Boolean): TGMString; var i, chPos: PtrInt; begin Result := AValue; for i:=Low(AWords) to High(AWords) do if AWords[i] <> '' then begin chPos := 1; while GMFindToken(Result, AWords[i], chPos, ASeparators, AWholeWords, AIgnoreCase) do System.Delete(Result, chPos, Length(AWords[i])); end; end; function GMKeepWords(const AValue: TGMString; const AWords: array of TGMString; const ASeparators: TGMString; const AWholeWords, AIgnoreCase: Boolean): TGMString; var i, chPos: PtrInt; begin Result := ''; for i:=Low(AWords) to High(AWords) do if AWords[i] <> '' then begin chPos := 1; if GMFindToken(AValue, AWords[i], chPos, ASeparators, AWholeWords, AIgnoreCase) then Result := GMStringJoin(Result, ' ', AWords[i]); end; end; function GMReplaceWords(const AValue: TGMString; const AOldWord, ANewWord, Separators: TGMString; const AIgnoreCase: Boolean): TGMString; var chPos: PtrInt; begin Result := AValue; chPos := 1; while GMFindToken(Result, AOldWord, chPos, Separators, True, AIgnoreCase) do begin System.Delete(Result, chPos, Length(AOldWord)); Insert(ANewWord, Result, chPos); chPos := chPos + Length(ANewWord); end; end; function GMFindOneOfWords(const AText, Separators: TGMString; const AWords: array of TGMString; var chPos: PtrInt; const AIgnoreCase: Boolean): Boolean; var i, startPos: LongInt; begin Result := False; if (Length(AWords) > 0) and (AText <> '') then begin startPos := chPos; for i:=Low(AWords) to High(AWords) do if (AWords[i] <> '') and GMFindToken(AText, AWords[i], chPos, Separators, True, AIgnoreCase) then begin Result := True; Break; end else chPos := startPos; if not Result then chPos := startPos; end; end; function GMIsOneOfStrings(const AValue: TGMString; const AStrings: array of TGMString; const AIgnoreCase: Boolean): Boolean; var strng: TGMString; // i: LongInt; function CompareStrings(const Str1, Str2: TGMString): Boolean; begin if AIgnoreCase then Result := GMSameText(Str1, Str2) else Result := Str1 = Str2; end; begin for strng in AStrings do if CompareStrings(AValue, strng) then Exit(True); // begin Result := True; Break; end; Result := False; //for i:=Low(AStrings) to High(AStrings) do // if CompareStrings(AValue, AStrings[i]) then begin Result := True; Break; end; end; function GMFindTextPart(const AText, Separators: TGMString; const AStartWords, EndWords: array of TGMString; const AIgnoreCase: Boolean): TGMString; var startPos, endPos: PtrInt; begin Result := ''; startPos := 1; if GMFindOneOfWords(AText, Separators, AStartWords, startPos, AIgnoreCase) then begin endPos := startPos; if not GMFindOneOfWords(AText, Separators, EndWords, endPos, AIgnoreCase) then endPos := Length(AText) + 1; Result := GMStrip(GMDeleteFirstWord(Copy(AText, startPos, endPos - startPos), cWhiteSpace), cWhiteSpace + ';'); end; end; function GMReplaceTextPart(const AText: TGMString; const ASeparators, NewPart: TGMString; const AStartWords, AEndWords: array of TGMString; const AIgnoreCase: Boolean): TGMString; var startPos, endPos: PtrInt; begin Result := AText; startPos := 1; if not GMFindOneOfWords(Result, ASeparators, AStartWords, startPos, AIgnoreCase) then startPos := Length(Result) else Dec(startPos); while (startPos >= 1) and GMIsDelimiter(cWhiteSpace, Result, startPos) do Dec(startPos); Inc(startPos); endPos := 1; if not GMFindOneOfWords(Result, ASeparators, AEndWords, endPos, AIgnoreCase) then endPos := Length(Result)+1; //While (endPos <= Length(Result)) and GMIsDelimiter(cWhiteSpace, Result, endPos) do Inc(endPos); //if endPos = Length(Result) then Inc(endPos); if startPos < endPos then System.Delete(Result, startPos, endPos - startPos) else startPos := endPos; if NewPart <> '' then Insert(NewPart, Result, startPos); end; function GMNextLine(var AChPos: PtrInt; const AText: TGMString): TGMString; const cIncCount: array [Boolean] of PtrInt = (1, 2); var ch1, ch2: TGMChar; startPos: PtrInt; begin startPos := AChPos; while (AChPos <= Length(AText)) do case AText[AChPos] of #13, #10: Break; else Inc(AChPos); end; if AChPos > startPos then Result := Copy(AText, startPos, AChPos-startPos) else Result := ''; if AChPos <= Length(AText) then ch1 := AText[AChPos] else ch1 := #0; if AChPos+1 <= Length(AText) then ch2 := AText[AChPos+1] else ch2 := #0; //if ch1 = #13 then Inc(AChPos, cIncCount[ch2 = #10]) else if ch1 = #10 then Inc(AChPos, cIncCount[ch2 = #13]); case ch1 of #13: Inc(AChPos, cIncCount[ch2 = #10]); #10: Inc(AChPos, cIncCount[ch2 = #13]); end; end; function GMLimitedTextExtract(const AValue: TGMString; const AMaxLineCount, AMaxLineLength: Integer; const ARemoveEmptyLines: Boolean): TGMString; var lineNo, chPos: PtrInt; line: TGMString; //function NextLine(var AChPos: Integer): TGMString; //var startPos, len: Integer; //begin // while (AChPos <= Length(AValue)) and GMIsDelimiter(#10#13, AValue, chPos) do Inc(AChPos); // startPos := AChPos; // while (AChPos <= Length(AValue)) and not GMIsDelimiter(#10#13, AValue, chPos) do Inc(AChPos); // // len := AChPos - startPos; // if AMaxLineLength > 0 then len := Min(AMaxLineLength, len); // // Result := Copy(AValue, startPos, len); // // if AChPos - startPos > len then Result := Result + cStr_More; //end; begin Result := ''; lineNo := 1; chPos := 1; while ((AMaxLineCount <= 0) or (lineNo <= AMaxLineCount)) and (chPos <= Length(AValue)) do begin line := GMStrip(GMNextLine(chPos, AValue)); if (AMaxLineLength > 0) and (Length(line) > AMaxLineLength) then line := Copy(line, 1, AMaxLineLength) + cStr_More; if not ARemoveEmptyLines or (Length(line) > 0) then begin Result := GMStringJoin(Result, cNewLine, line); Inc(lineNo); end; end; end; function GMNextWord(var AChPos: PtrInt; const AValue, ASeparators: TGMString; const ASkipLeadingSeparators: Boolean): TGMString; var startPos: PtrInt; begin if ASkipLeadingSeparators then while (AChPos <= Length(AValue)) and GMIsDelimiter(ASeparators, AValue, AChPos) do Inc(AChPos); startPos := AChPos; while (AChPos <= Length(AValue)) and not GMIsDelimiter(ASeparators, AValue, AChPos) do Inc(AChPos); if AChPos > startPos then Result := Copy(AValue, startPos, AChPos-startPos) else Result := ''; if (AChPos <= Length(AValue)) and GMIsDelimiter(ASeparators, AValue, AChPos) then Inc(AChPos); // {if SkipSeparators then} while (AChPos <= Length(AValue)) and GMIsDelimiter(ASeparators, AValue, AChPos) do Inc(AChPos); end; function GMNextWord(var AChPos: PtrInt; const AValue: TGMString; ASeparatorChar: TGMChar; const ASkipLeadingSeparators: Boolean): TGMString; const cFoundInc: array [Boolean] of PtrInt = (1, 0); var pChEnd: PGMChar; len: PtrInt; begin if (Length(AValue) <= 0) or (AChPos < 1) or (AChPos > Length(AValue)) then begin Result := ''; Exit; end; if ASkipLeadingSeparators then begin pChEnd := GMStrCLScan(@AValue[AChPos], ASeparatorChar, Length(AValue) - AChPos + 1); if pChEnd <> nil then Inc(AChPos, pChEnd - PGMChar(@AValue[AChPos])) else begin AChPos := Length(AValue) + 1; Result := ''; Exit; end; // <- Note: EXIT Here! end; pChEnd := GMStrLScan(@AValue[AChPos], ASeparatorChar, Length(AValue) - AChPos + 1); if pChEnd = nil then len := Length(AValue) - AChPos + 1 else len := pChEnd - PGMChar(@AValue[AChPos]); Result := System.Copy(AValue, AChPos, len); Inc(AChPos, len + cFoundInc[pChEnd = nil]); end; function GMPreviousWord(var AChPos: PtrInt; const AValue, ASeparators: TGMString; const ASkipTrailingSeparators: Boolean): TGMString; var startPos: LongInt; begin //Result := ''; if ASkipTrailingSeparators then while (AChPos > 0) and GMIsDelimiter(ASeparators, AValue, AChPos) do Dec(AChPos); startPos := AChPos; while (AChPos > 0) and not GMIsDelimiter(ASeparators, AValue, AChPos) do Dec(AChPos); if AChPos < startPos then Result := Copy(AValue, AChPos+1, startPos - AChPos) else Result := ''; //while (AChPos > 0) and GMIsDelimiter(ASeparators, AValue, AChPos) do Dec(AChPos); end; //function GMFirstLine(const Value: TGMString): TGMString; //const cLineBreaks = #10#13; //var i: LongInt; //begin //i:=1; //while (i <= Length(Value)) and not GMIsDelimiter(cLineBreaks, Value, i) do Inc(i); //Result := Copy(Value, 1, i-1); //end; function GMFirstWord(const AValue: TGMString; const ASeparators: TGMString; const ASkipLeadingSeparators: Boolean): TGMString; var chPos: PtrInt; begin chPos := 1; Result := GMNextWord(chPos, AValue, ASeparators, ASkipLeadingSeparators); end; function GMLastWord(const AValue: TGMString; const ASeparators: TGMString; const ASkipTrailingSeparators: Boolean): TGMString; var chPos: PtrInt; begin chPos := Length(AValue); Result := GMPreviousWord(chPos, AValue, ASeparators, ASkipTrailingSeparators); end; function GMNThWord(const AValue: TGMString; const AWordNummber: Word; const ASeparators: TGMString; const AFromSide: ERightLeftSide): TGMString; var i, chPos: PtrInt; begin Result := ''; case AFromSide of rlsLeft: begin chPos := 1; for i:=1 to AWordNummber do Result := GMNextWord(chPos, AValue, ASeparators, True); end; rlsRight: begin chPos := Length(AValue); for i:=1 to AWordNummber do Result := GMPreviousWord(chPos, AValue, ASeparators, True); end; end; end; function GMWordCount(const AText, ASeparators: TGMString): LongInt; var token: TGMString; chPos: PtrInt; begin Result := 0; chPos := 1; token := GMNextWord(chPos, AText, ASeparators); while Length(token) > 0 do begin Inc(Result); token := GMNextWord(chPos, AText, ASeparators); end; end; function GMIsDigitA(ACh: AnsiChar): Boolean; begin Result := (ACh >= '0') and (ACh <= '9'); end; function GMIsDigit(ACh: TGMChar): Boolean; begin Result := (ACh >= '0') and (ACh <= '9'); end; function GMIsLetter(ACh: TGMChar): Boolean; begin Result := ((ACh >= 'A') and (ACh <= 'Z')) or ((ACh >= 'a') and (ACh <= 'z')); end; function GMMakeDezInt(const AValue: TGMString; const ADefaultValue: Int64): TGMString; var isSigned: Boolean; chPos: PtrInt; begin chPos := 1; while (chPos <= Length(AValue)) and GMIsDelimiter(cWhiteSpace, AValue, chPos) do Inc(chPos); isSigned := (chPos <= Length(AValue)) and (AValue[chPos] = '-'); Result := GMDeleteChars(AValue, cStrDigits, True); if Result = '' then Result := GMIntToStr(ADefaultValue) else if isSigned then Result := '-' + Result; end; function GMMakeFloat(const AValue: TGMString; const ADefaultValue: Double = 0): TGMString; var isSigned: Boolean; chPos: PtrInt; begin chPos := 1; while (chPos <= Length(AValue)) and GMIsDelimiter(cWhiteSpace, AValue, chPos) do Inc(chPos); isSigned := (chPos <= Length(AValue)) and (AValue[chPos] = '-'); Result := GMDeleteChars(AValue, cStrDigits + '.,', True); if Result = '' then Result := GMDoubleToStr(ADefaultValue) else if isSigned then Result := '-' + Result; end; {function GMStrip(const AValue: TGMString; const AChars: TGMString; const ANotStripChars: Boolean): TGMString; begin Result := AValue; if ANotStripChars then begin while (Length(Result) > 0) and not GMIsDelimiter(AChars, Result, 1) do System.Delete(Result, 1, 1); while (Length(Result) > 0) and not GMIsDelimiter(AChars, Result, Length(Result)) do System.Delete(Result, Length(Result), 1); end else begin while (Length(Result) > 0) and GMIsDelimiter(AChars, Result, 1) do System.Delete(Result, 1, 1); while (Length(Result) > 0) and GMIsDelimiter(AChars, Result, Length(Result)) do System.Delete(Result, Length(Result), 1); end; end;} function GMTrimLeftA(const AValue: AnsiString; AChar: AnsiChar): AnsiString; var pStart: PAnsiChar; startIdx: Integer; begin pStart := GMStrCLScanA(PAnsiChar(AValue), AChar, Length(AValue)); if pStart = nil then Result := '' else begin startIdx := pStart - PAnsiChar(AValue); if startIdx = 0 then Result := AValue else Result := Copy(AValue, startIdx + 1, Length(AValue) - startIdx); end; end; function GMTrimLeftW(const AValue: UnicodeString; AChar: WideChar): UnicodeString; var pStart: PWideChar; startIdx: Integer; begin pStart := GMStrCLScanW(PWideChar(AValue), AChar, Length(AValue)); if pStart = nil then Result := '' else begin startIdx := pStart - PWideChar(AValue); if startIdx = 0 then Result := AValue else Result := Copy(AValue, startIdx + 1, Length(AValue) - startIdx); end; end; function GMTrimLeft(const AValue: TGMString; AChar: TGMChar): TGMString; begin {$IFDEF UNICODE} Result := GMTrimLeftW(AValue, AChar); {$ELSE} Result := GMTrimLeftA(AValue, AChar); {$ENDIF} end; function GMTrimRightA(const AValue: AnsiString; AChar: AnsiChar): AnsiString; var pEnd: PAnsiChar; begin if Length(AValue) <= 0 then Result := AValue else begin pEnd := GMStrCRLScanA(PAnsiChar(AValue) + Length(AValue)-1, AChar, Length(AValue)); if pEnd = nil then Result := '' else if pEnd = @AValue[Length(AValue)] then Result := AValue else Result := Copy(AValue, 1, pEnd - PAnsiChar(AValue) + 1); end; end; function GMTrimRightW(const AValue: UnicodeString; AChar: WideChar): UnicodeString; var pEnd: PWideChar; begin if Length(AValue) <= 0 then Result := AValue else begin pEnd := GMStrCRLScanW(PWideChar(AValue) + Length(AValue)-1, AChar, Length(AValue)); if pEnd = nil then Result := '' else if pEnd = @AValue[Length(AValue)] then Result := AValue else Result := Copy(AValue, 1, pEnd - PWideChar(AValue) + 1); end; end; function GMTrimRight(const AValue: TGMString; AChar: TGMChar): TGMString; begin {$IFDEF UNICODE} Result := GMTrimRightW(AValue, AChar); {$ELSE} Result := GMTrimRightA(AValue, AChar); {$ENDIF} end; function GMTrim(const AStr: TGMString; AChar: TGMChar = ' '): TGMString; begin Result := GMTrimLeft(GMTrimRight(AStr, AChar), AChar); end; function GMStrip(const AValue: TGMString; const AChars: TGMString; const ANotStripChars: Boolean): TGMString; var l, r, len: Integer; begin len := Length(AValue); l := 1; r := len; if ANotStripChars then begin while (l <= len) and not GMIsDelimiter(AChars, AValue, l) do Inc(l); while (r >= l) and not GMIsDelimiter(AChars, AValue, r) do Dec(r); end else begin while (l <= len) and GMIsDelimiter(AChars, AValue, l) do Inc(l); while (r >= l) and GMIsDelimiter(AChars, AValue, r) do Dec(r); end; // if nothing has to be rmoved from the string, then return AValue directly to avoid copying of content if (l = 1) and (r = len) then Result := AValue else Result := Copy(AValue, l, r-l+1); end; function GMStripRight(const AValue: TGMString; const AChars: TGMString): TGMString; var r: Integer; begin r := Length(AValue); while (r >= 1) and GMIsDelimiter(AChars, AValue, r) do Dec(r); // if nothing has to be rmoved from the string, then return AValue directly to avoid copying of content if r = Length(AValue) then Result := AValue else Result := Copy(AValue, 1, r); end; function GMStripLeft(const AValue: TGMString; const AChars: TGMString): TGMString; var l, len: Integer; begin len := Length(AValue); l := 1; while (l <= len) and GMIsDelimiter(AChars, AValue, l) do Inc(l); // if nothing has to be rmoved from the string, then return AValue directly to avoid copying of content if l = 1 then Result := AValue else Result := Copy(AValue, l, len-l+1); end; function GMReplaceChars(const AValue: TGMString; const AFindChars, AReplacements: TGMString): TGMString; var i, chPos: Integer; pCh: PGMChar; begin Result := AValue; for i:=1 to Length(Result) do begin //chPos := Pos(); pCh := GMStrLScan(PGMCHar(AFindChars), Result[i], Length(AFindChars)); if pCh = nil then Continue; chPos := pCh - PGMChar(AFindChars) + 1; if chPos <= Length(AReplacements) then Result[i] := AReplacements[chPos]; end; end; function GMTerminateStr(const AStr: TGMString; const ATermination: TGMString): TGMString; var lastCh: TGMChar; begin Result := AStr; if Length(Result) <= 0 then Exit; lastCh := Result[Length(Result)]; if lastCh = cChDontTerm then begin System.Delete(Result, Length(Result), 1); Exit; end; if (Length(Result) >= Length(ATermination)) and not GMSameText(Copy(AStr, Length(AStr) - Length(ATermination) + 1, Length(ATermination)), ATermination) and (lastCh <> '.') and (lastCh <> '?') and (lastCh <> '!') and (lastCh <> cChDontTerm) then Result := Result + ATermination; end; function GMDeleteChars(const Value: TGMString; const ADelChars: TGMString; const ANotDelChars: Boolean = False): TGMString; var i: PtrInt; begin Result := Value; i:=1; if ANotDelChars then while i<= Length(Result) do if not GMIsDelimiter(ADelChars, Result, i) then System.Delete(Result, i, 1) else Inc(i) else while i<= Length(Result) do if GMIsDelimiter(ADelChars, Result, i) then System.Delete(Result, i, 1) else Inc(i); end; function GMDeleteCharsA(const AValue: AnsiString; const ADelChars: AnsiString; const ANotDelChars: Boolean = False): AnsiString; var i: PtrInt; begin Result := AValue; i:=1; if ANotDelChars then while i<= Length(Result) do if not GMIsDelimiterA(ADelChars, Result, i) then System.Delete(Result, i, 1) else Inc(i) else while i<= Length(Result) do if GMIsDelimiterA(ADelChars, Result, i) then System.Delete(Result, i, 1) else Inc(i); end; function GMIsDelimiterA(const ADelimiters, AValue: AnsiString; ACharIndex: PtrInt): Boolean; begin if (ACharIndex < 1) or (ACharIndex > Length(AValue)) then Exit(False); Result := GMStrLScanA(PAnsiChar(ADelimiters), AValue[ACharIndex], Length(ADelimiters)) <> nil; end; function GMIsDelimiterW(const ADelimiters, AValue: UnicodeString; ACharIndex: PtrInt): Boolean; begin if (ACharIndex < 1) or (ACharIndex > Length(AValue)) then Exit(False); Result := GMStrLScanW(PWideChar(ADelimiters), AValue[ACharIndex], Length(ADelimiters)) <> nil; end; function GMIsDelimiter(const ADelimiters, AValue: TGMString; ACharIndex: PtrInt): Boolean; begin {$IFDEF UNICODE} Result := GMIsDelimiterW(ADelimiters, AValue, ACharIndex); {$ELSE} Result := GMIsDelimiterA(ADelimiters, AValue, ACharIndex); {$ENDIF} end; function GMLastDelimiter(const ADelimiters, AValue: TGMString): PtrInt; begin for Result := Length(AValue) downto 1 do if GMStrLScan(PGMChar(ADelimiters), AValue[Result], Length(ADelimiters)) <> nil then Exit; Result := 0; end; function GMIsNumber(const AValue: TGMString): Boolean; var i: PtrInt; begin for i:=1 to Length(AValue) do if not GMIsDigit(AValue[i]) then begin Result := False; Exit; end; Result := Length(AValue) > 0; end; //function IsNumber(const ANumVal: TGMString): Boolean; //var chPos: Integer; //begin //for chPos:=1 to Length(ANumVal) do // if not GMIsdelimiter(cStrDigits, ANumVal, chPos) then begin Result := False; Exit; end; // //Result := Length(ANumVal) > 0; //end; function GMHashCodeFromString(const AValue: TGMString): TGMHashCode; var i: LongInt; pb: PByte; begin Result := 0; pb := Pointer(PGMChar(AValue)); for i:=1 to Length(AValue) * SizeOf(TGMChar) do begin Result := Result + (pb^ * (i - 1) * 256); // Result := Result + (Ord(AValue[i]) * (i - 1) * 256); // Result := Result shl 5 + Ord(HashString[i]) + Result; Inc(pb); end; end; //function HashOf(const key: string): cardinal; //asm //xor edx,edx { Result := 0 } //and eax,eax { test if 0 } //jz @End { skip if nil } //mov ecx,[eax-4] { ecx := string length } //jecxz @End { skip if length = 0 } //@loop: { repeat } //rol edx,2 { edx := (edx shl 2) or (edx shr 30)... } //xor dl,[eax] { ... xor Ord(key[eax]) } //inc eax { inc(eax) } //loop @loop { until ecx = 0 } //@End: //mov eax,edx { Result := eax } //end; {function HashOf(const key: string): cardinal; var I: integer; begin Result := 0; for I := 1 to length(key) do begin Result := (Result shl 5) or (Result shr 27); Result := Result xor Cardinal(key[I]); end; end;} function GMInsertEscapeChars(const AValue: TGMString): TGMString; var srcChIdx, dstChIdx, k, n: PtrInt; leadingBlank: Boolean; // startTicks: QWord; procedure AppendDestCh(ACh: TGMChar); begin if (Length(Result)) < dstChIdx then SetLength(Result, Length(Result) + Max(Round(Length(Result) * 0.2), 64)); Result[dstChIdx] := ACh; Inc(dstChIdx); end; begin // // Don't escape all blanks, only leading and trailing blanks. // //startTicks := GetTickCount64(); SetLength(Result, Round(Length(AValue) * 1.3)); dstChIdx := 1; leadingBlank := True; for srcChIdx:=1 to Length(AValue) do begin case AValue[srcChIdx] of ' ': if leadingBlank then begin AppendDestCh('\'); AppendDestCh('s'); end else AppendDestCh(' '); // AppendDestCh(AValue[srcChIdx]); #9: begin AppendDestCh('\'); AppendDestCh('t'); leadingBlank := False; end; #10: begin AppendDestCh('\'); AppendDestCh('n'); leadingBlank := False; end; #13: begin AppendDestCh('\'); AppendDestCh('r'); leadingBlank := False; end; '\': begin AppendDestCh('\'); AppendDestCh('\'); leadingBlank := False; end; else begin AppendDestCh(AValue[srcChIdx]); leadingBlank := False; end; end; end; // // Escape trailing blanks, they may be stripped or ignored otherwise // srcChIdx := dstChIdx-1; while (srcChIdx >= 1) and (Result[srcChIdx] = ' ') do Dec(srcChIdx); if srcChIdx < dstChIdx-1 then begin n := dstChIdx-1; Dec(dstChIdx, dstChIdx-srcChIdx-1); for k:=srcChIdx+1 to n do begin AppendDestCh('\'); AppendDestCh('s'); end; end; SetLength(Result, dstChIdx-1); //vfGMTrace(GMFormat('GMInsertEscapeChars: %d [ms]', [GetTickCount64() - startTicks]), 'SAVE'); end; //function GMInsertEscapeChars(const AValue: TGMString): TGMString; //var i: PtrInt; startTicks: QWord; //begin // startTicks := GetTickCount64(); // Result := ''; // for i:=1 to Length(AValue) do // begin // case AValue[i] of // //' ': begin Result[i] := '\'; System.Insert('s', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #9: Result += '\t'; // begin Result[i] := '\'; System.Insert('t', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #10: Result += '\n'; // begin Result[i] := '\'; System.Insert('n', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #13: Result += '\r'; // begin Result[i] := '\'; System.Insert('r', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // '\': Result += '\\'; // begin System.Insert('\', Result, i); Inc(i); end; // <- i will be incremented another time below! // else Result += AValue[i]; // end; // end; // vfGMTrace(GMFormat('GMInsertEscapeChars: %d [ms]', [GetTickCount64() - startTicks]), 'SAVE'); //end; //function GMInsertEscapeChars(const AValue: TGMString): TGMString; //var i: PtrInt; startTicks: QWord; //begin // startTicks := GetTickCount64(); // Result := AValue; // // // // Don't escape all blanks, only leading and trailing blanks (-> done below) // // // i:=1; // while i <= Length(Result) do // begin // case Result[i] of // //' ': begin Result[i] := '\'; System.Insert('s', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #9: begin Result[i] := '\'; System.Insert('t', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #10: begin Result[i] := '\'; System.Insert('n', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #13: begin Result[i] := '\'; System.Insert('r', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // '\': begin System.Insert('\', Result, i); Inc(i); end; // <- i will be incremented another time below! // end; // Inc(i); // end; // // // // // Escape trailing blanks, they may be stripped or ignored otherwise // // // i := Length(Result); // while (i >= 1) and (Result[i] = ' ') do // begin // Result[i] := '\'; System.Insert('s', Result, i+1); // Dec(i); // end; // // // // // Escape leading blanks, they may be stripped or ignored otherwise // // // i:=1; // while (i <= Length(Result)) and (Result[i] = ' ') do // begin // Result[i] := '\'; // System.Insert('s', Result, i+1); // Inc(i, 2); // end; // vfGMTrace(GMFormat('GMInsertEscapeChars: %d [ms]', [GetTickCount64() - startTicks]), 'SAVE'); //end; function StrExerpt(const AValue: TGMString; const AMaxLen: PtrInt): TGMString; begin if (AMaxLen > 0) and (Length(AValue) > AMaxLen) then Result := Copy(AValue, 1, AMaxLen) + cStr_More else Result := AValue; end; function GMResolveEscapeChars(const AValue: TGMString; const ACaller: TObject): TGMString; var srcChIdx, dstChIdx: PtrInt; ch, prevCh: TGMChar; // startTicks: QWord; begin //startTicks := GetTickCount64(); dstChIdx := 1; SetLength(Result, Length(AValue)); prevCh := #0; for srcChIdx:=1 to Length(AValue) do begin ch := AValue[srcChIdx]; if prevCh <> '\' then begin if ch <> '\' then begin Result[dstChIdx] := ch; Inc(dstChIdx); end; end else case ch of 's': begin Result[dstChIdx] := ' '; Inc(dstChIdx); end; 't': begin Result[dstChIdx] := #9; Inc(dstChIdx); end; 'n': begin Result[dstChIdx] := #10; Inc(dstChIdx); end; 'r': begin Result[dstChIdx] := #13; Inc(dstChIdx); end; '"': begin Result[dstChIdx] := '"'; Inc(dstChIdx); end; '\': begin Result[dstChIdx] := '\'; ch := #0; Inc(dstChIdx); end; else raise EGMException.ObjError(GMFormat(RStrInvalidESCSequenceFmt, ['' + prevCh + ch, StrExerpt(AValue, 4096), srcChIdx-1]), ACaller, 'GMResolveEscapeChars'); // Inc(i); end; prevCh := ch; end; SetLength(Result, dstChIdx-1); //vfGMTrace(GMFormat('GMResolveEscapeChars: %d [ms]', [GetTickCount64() - startTicks]), 'LOAD'); end; //function GMResolveEscapeChars(const AValue: TGMString; const ACaller: TObject): TGMString; //var i: PtrInt; ch, prevCh: TGMChar; // startTicks: QWord; //begin // //startTicks := GetTickCount64(); // i:=1; Result := AValue; prevCh := #0; // while i <= Length(Result) do // begin // ch := Result[i]; // if prevCh <> '\' then Inc(i) else // case ch of // 's': begin Result[i-1] := ' '; System.Delete(Result, i, 1); end; // <- No increment here! // 't': begin Result[i-1] := #9; System.Delete(Result, i, 1); end; // <- No increment here! // 'n': begin Result[i-1] := #10; System.Delete(Result, i, 1); end; // <- No increment here! // 'r': begin Result[i-1] := #13; System.Delete(Result, i, 1); end; // <- No increment here! // '\': begin System.Delete(Result, i, 1); ch := #0; end; // <- No increment here! // else raise EGMException.ObjError(GMFormat(RStrInvalidESCSequenceFmt, ['' + prevCh + ch, AValue, i-1]), ACaller, 'GMResolveEscapeChars'); // Inc(i); // end; // prevCh := ch; // end; // //vfGMTrace(GMFormat('GMResolveEscapeChars: %d [ms]', [GetTickCount64() - startTicks]), 'LOAD'); //end; //function GMInsertQuotedStrEscChars(const AValue: TGMString): TGMString; //var i: PtrInt; //begin // i:=1; Result := AValue; // while i <= Length(Result) do // begin // case Result[i] of // //' ': begin Result[i] := '\'; System.Insert('s', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #9: begin Result[i] := '\'; System.Insert('t', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #10: begin Result[i] := '\'; System.Insert('n', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // #13: begin Result[i] := '\'; System.Insert('r', Result, i+1); Inc(i); end; // <- i will be incremented another time below! // '\', '"': begin System.Insert('\', Result, i); Inc(i); end; // <- i will be incremented another time below! // end; // Inc(i); // end; //end; function GMInsertQuotedStrEscChars(const AValue: TGMString): TGMString; var srcChIdx, dstChIdx: PtrInt; // leadingBlank: Boolean; // startTicks: QWord; procedure AppendDestCh(ACh: TGMChar); //var newLen: PtrInt; begin if (Length(Result)) < dstChIdx then SetLength(Result, Length(Result) + Max(Round(Length(Result) * 0.2), 64)); //begin // newLen := Length(Result) + Max(Round(Length(Result) * 0.2), 64); // SetLength(Result, newLen); //end; Result[dstChIdx] := ACh; Inc(dstChIdx); end; begin //startTicks := GetTickCount64(); SetLength(Result, Round(Length(AValue) * 1.3)); dstChIdx := 1; for srcChIdx:=1 to Length(AValue) do begin case AValue[srcChIdx] of //' ': if leadingBlank then // begin AppendDestCh('\'); AppendDestCh('s'); end // else // AppendDestCh(AValue[srcChIdx]); #9: begin AppendDestCh('\'); AppendDestCh('t'); end; #10: begin AppendDestCh('\'); AppendDestCh('n'); end; #13: begin AppendDestCh('\'); AppendDestCh('r'); end; '"': begin AppendDestCh('\'); AppendDestCh('"'); end; '\': begin AppendDestCh('\'); AppendDestCh('\'); end; else begin AppendDestCh(AValue[srcChIdx]); end; end; end; SetLength(Result, dstChIdx-1); //vfGMTrace(GMFormat('GMInsertEscapeChars: %d [ms]', [GetTickCount64() - startTicks]), 'SAVE'); end; function GMResolveQuotedStrEscChars(const AValue: TGMString; const ACaller: TObject): TGMString; begin Result := GMResolveEscapeChars(AValue, ACaller); end; //function GMResolveQuotedStrEscChars(const AValue: TGMString; const ACaller: TObject): TGMString; //var i: PtrInt; ch, prevCh: TGMChar; //begin // i:=1; Result := AValue; prevCh := #0; // while i <= Length(Result) do // begin // ch := Result[i]; // if prevCh <> '\' then Inc(i) else // case ch of // //'s': begin Result[i-1] := ' '; System.Delete(Result, i, 1); end; // <- No increment here! // 't': begin Result[i-1] := #9; System.Delete(Result, i, 1); end; // <- No increment here! // 'n': begin Result[i-1] := #10; System.Delete(Result, i, 1); end; // <- No increment here! // 'r': begin Result[i-1] := #13; System.Delete(Result, i, 1); end; // <- No increment here! // '\': begin System.Delete(Result, i, 1); ch := #0; end; // <- No increment here! // '"': begin System.Delete(Result, i-1, 1); ch := #0; end; // <- No increment here! // else raise EGMException.ObjError(GMFormat(RStrInvalidESCSequenceFmt, ['' + prevCh + ch, AValue, i-1]), ACaller, 'GMResolveQuotedStrEscChars'); // Inc(i); // end; // prevCh := ch; // end; //end; type PNewLineDataRec = ^RNewLineDataRec; RNewLineDataRec = record Value, NewLineStr: TGMString; end; function AppendSingleLine(const ALine: TGMString; const ALastLine: Boolean; const AData: Pointer): Boolean; begin if AData = nil then begin Result := False; Exit; end; //PNewLineDataRec(AData).Value := GMStringJoin(PNewLineDataRec(AData).Value, PNewLineDataRec(AData).NewLineStr, ALine); if Length(PNewLineDataRec(AData).Value) <= 0 then PNewLineDataRec(AData).Value := ALine else PNewLineDataRec(AData).Value := PNewLineDataRec(AData).Value + PNewLineDataRec(AData).NewLineStr + ALine; Result := True; end; function GMMakeSingleLine(const AValue: TGMString; const ANewLineStr: TGMString; const AEmitEmptyLines: Boolean): TGMString; var newLineData: RNewLineDataRec; begin newLineData.NewLineStr := ANewLineStr; newLineData.Value := ''; GMParseLines(AValue, AppendSingleLine, @newLineData, AEmitEmptyLines); Result := newLineData.Value; end; function GMReduceWhiteSpace(const AValue: TGMString): TGMString; var chPos: PtrInt; begin Result := GMStrip(AValue); chPos := 1; while (chPos <= Length(Result)) do if GMIsDelimiter(cWhiteSpace, Result, chPos) and (chPos < Length(Result)) and GMIsDelimiter(cWhiteSpace, Result, chPos + 1) then System.Delete(Result, chPos + 1, 1) else Inc(chPos); end; //function GMMakeSingleLine(const Value: TGMString; const NewLineStr: TGMString): TGMString; //var chPos: PtrInt; NewLine: Boolean; //begin //chPos := 1; //Result := Value; //while chPos <= Length(Result) do // if GMIsDelimiter(cWhiteSpace, Result, chPos) then // begin // NewLine := False; // while GMIsDelimiter(cWhiteSpace, Result, chPos) and (chPos <= Length(Result)) do // begin // NewLine := NewLine or (Result[chPos] in [#10, #13]); // System.Delete(Result, chPos, 1); // end; // // if chPos <= Length(Result) then // begin // if NewLine then begin Insert(NewLineStr, Result, chPos); Inc(chPos, Length(NewLineStr)); end; // Insert(' ', Result, chPos); // Inc(chPos); // end; // end // else Inc(chPos); //end; //function GMFullLineBreaks(const Value: TGMString): TGMString; //var i: LongInt; //begin // Result := Value; i:=1; // while i <= Length(Result) do // begin // if Result[i] = #10 then if (i <= 1) or (Result[i-1] <> #13) then begin Insert(#13, Result, i); Inc(i); end; // Inc(i); // end; //end; //function GMInsertXMLLineBreaks(const Value: TGMString): TGMString; //const cNewLine = #13#10; CXMLTrail = '</'; CXMLSingle = '/>'; //var chPos: PtrInt; // Start: DWORD; InsCount: LongInt; //begin // //Start := GetTickCount; InsCount := 0; // Result := Value; // chPos:=1; // while GMFindToken(Result, CXMLTrail, chPos, '', False) do // begin // Inc(chPos, Length(CXMLTrail)); // while (chPos <= Length(Result)) and (Result[chPos] <> '>') do Inc(chPos); // if chPos <= Length(Result) then begin Insert(cNewLine, Result, chPos+1); Inc(chPos, Length(cNewLine) + 1); end; // Inc(InsCount); // end; // chPos:=1; // while GMFindToken(Result, CXMLSingle, chPos, '', False) do // begin // Inc(chPos, Length(CXMLSingle)); // if chPos <= Length(Result) then begin Insert(cNewLine, Result, chPos); Inc(chPos, Length(cNewLine)); end; // Inc(InsCount); // end; // //vfGMMEssageBox(GMFormat('ms: %d, Insertions: %d', [GetTickCount - Start, InsCount])); //end; function GMInsertXMLLineBreaks(const AValue: TGMString): TGMString; const chStart: TGMChar = '<'; chEnd: TGMChar = '>'; type TXmlTokenKind = (tkStart, tkSingle, tkEnd); var tokenKind, lastTokenKind: TXmlTokenKind; chPos, lastchPos: PtrInt; pCh: PGMChar; //Start: DWORD; procedure _InsertNewLine(AChPos: LongInt); begin Inc(AChPos); // <- switch from zero base to one base! //if (Ord(Result[AChPos]) > 255) or not (AnsiChar(Result[AChPos]) in [#10, #13]) then //if AChPos <= Length(Result) then case Result[AChPos] of #10, #13: ; // <- Nothing! else begin Insert(cNewLine, Result, AChPos); Inc(chPos, Length(cNewLine)); Inc(lastChPos, Length(cNewLine)); end; end; end; begin //Start := GetTickCount; Result := AValue; if Length(Result) <= 0 then Exit; lastTokenKind := tkSingle; chPos := 0; lastChPos := 0; repeat tokenKind := tkStart; pCh := GMStrLScan(PGMChar(Result) + chPos, chStart, Length(Result) - chPos); if pCh = nil then Break; if (pCh - PGMChar(Result) + 1 < Length(Result)) then begin if ((pCh + 1)^ = '/') then tokenKind := tkEnd; pCh := GMStrLScan(pCh + 1, chEnd, PGMChar(Result) + Length(Result) - pCh - 1); if pCh = nil then Break; if (pCh - 1)^ = '/' then tokenKind := tkSingle; end; chPos := pCh - PGMChar(Result) + 1; if chPos >= Length(Result) then Break; case tokenKind of tkStart: if lastTokenKind = tkStart then _InsertNewLine(lastChPos); tkSingle: if lastTokenKind in [tkEnd, tkSingle] then _InsertNewLine(chPos); tkEnd: _InsertNewLine(chPos); end; lastChPos := chPos; lastTokenKind := tokenKind; until False; // chPos >= Length(Result); //vfGMMEssageBox(IntToStr(GetTickCount - Start)); end; function GMCompareVersions(const AVersionA, AVersionB: TGMString): TGMCompareResult; const //cResult: array [Boolean] of TGMCompareResult = (crALessThanB, crAEqualToB); cVerSep = '.'; LowVer = Low(LongInt); var ChPA, ChPB, SegNoA, SegNoB: PtrInt; begin ChPA := 1; ChPB := 1; repeat SegNoA := GMStrToInt(GMMakeDezInt(GMNextWord(ChPA, AVersionA, cVerSep, False), LowVer)); SegNoB := GMStrToInt(GMMakeDezInt(GMNextWord(ChPB, AVersionB, cVerSep, False), LowVer)); until (SegNoA <> SegNoB) or (SegNoA = LowVer) or (SegNoB = LowVer); if SegNoA < SegNoB then Result := crALessThanB else if SegNoA > SegNoB then Result := crAGreaterThanB else Result := crAEqualToB; end; function GMFixedEncodeDateTime(const AValue: TDateTime): TGMString; var hasDate, hasTime: Boolean; begin hasDate := Trunc(AValue) <> 0.0; hasTime := Frac(AValue) <> 0.0; if hasDate and hasTime then Result := FormatDateTime(cStrFixedDateTimeFmt, AValue) else if hasDate then Result := FormatDateTime(cStrFixedDateFmt, AValue) else Result := FormatDateTime(cStrFixedTimeFmt, AValue) end; function GMFixedDecodeDateTime(const AValue: TGMString): TDateTime; var chPos: PtrInt; tmp, day, month, year, hour, minute, second, milliSec: LongInt; function NextNumber(var AchPos: PtrInt; const AValue: TGMString): LongInt; //const cDigits = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']; var startPos: LongInt; begin while (AChPos <= Length(AValue)) and ((AValue[AChPos] < '0') or (AValue[AChPos] > '9')) do Inc(AChPos); startPos := AChPos; while (AChPos <= Length(AValue)) and (AValue[AChPos] >= '0') and (AValue[AChPos] <= '9') do Inc(AChPos); Result := GMStrToInt(GMMakeDezInt(Copy(AValue, startPos, AChPos - startPos))); end; procedure SetAllZero(AFirstValue: Integer); begin day := 0; month := 0; year := AFirstValue; hour := 0; minute := 0; second := 0; milliSec := 0; end; procedure ReadDate(AFirstValue: Integer); begin if AFirstValue >= 0 then day := AFirstValue else day := NextNumber(chPos, AValue); month := NextNumber(chPos, AValue); year := NextNumber(chPos, AValue); end; procedure ReadTime(AFirstValue: Integer); begin if AFirstValue >= 0 then hour := AFirstValue else hour := NextNumber(chPos, AValue); minute := NextNumber(chPos, AValue); second := NextNumber(chPos, AValue); milliSec := NextNumber(chPos, AValue); end; begin chPos := 1; tmp := NextNumber(chPos, AValue); while (chPos <= Length(AValue)) and GMIsDelimiter(cWhiteSpace, AValue, chPos) do Inc(chPos); // ((AValue[chPos] = ' ') or (AValue[chPos] = #9) or (AValue[chPos] = #10) or (AValue[chPos] = #13)) if chPos > Length(AValue) then begin SetAllZero(tmp); end else if AValue[chPos] = cStrFixedDateSep then begin ReadDate(tmp); ReadTime(-1); end else if AValue[chPos] = cStrFixedTimeSep then begin ReadTime(tmp); day := 0; month := 0; year := 0; end else SetAllZero(tmp); if (year = 0) and (month = 0) and (day = 0) then Result := 0 else Result := EncodeDate(year, month, day); if Result >= 0 then Result := Result + EncodeTime(hour, minute, second, milliSec) else Result := Result - EncodeTime(hour, minute, second, milliSec); end; {function GMFixedDecodeDateTime(const AValue: TGMString): TDateTime; var chPos, day, month, year, hour, minute, second, milliSec: LongInt; function NextNumber(var AchPos: PtrInt; const AValue: TGMString): LongInt; //const cDigits = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']; var startPos: LongInt; begin while (AChPos <= Length(AValue)) and ((AValue[AChPos] < '0') or (AValue[AChPos] > '9')) do Inc(AChPos); startPos := AChPos; while (AChPos <= Length(AValue)) and (AValue[AChPos] >= '0') and (AValue[AChPos] <= '9') do Inc(AChPos); Result := GMStrToInt(GMMakeDezInt(Copy(AValue, startPos, AChPos - startPos))); end; begin chPos := 1; day := NextNumber(chPos, AValue); month := NextNumber(chPos, AValue); year := NextNumber(chPos, AValue); hour := NextNumber(chPos, AValue); minute := NextNumber(chPos, AValue); second := NextNumber(chPos, AValue); milliSec := NextNumber(chPos, AValue); Result := EncodeDate(year, month, day); if Result >= 0 then Result := Result + EncodeTime(hour, minute, second, milliSec) else Result := Result - EncodeTime(hour, minute, second, milliSec); end;} function GMHasDateTimeFormat(const AValue, AFormat: TGMString): Boolean; var fmtChPos, valChPos, startPos: PtrInt; dtp: TGMDateTimePart; valPart: TGMString; // , day, month, year, hour, minute, second, milliSec //function NextNumber: TGMString; //var startPos: Integer; //begin // while (valChPos <= Length(AValue)) and not GMIsDelimiter(cStrDigits, AValue, valChPos) do Inc(valChPos); // startPos := valChPos; // while (valChPos <= Length(AValue)) and GMIsDelimiter(cStrDigits, AValue, valChPos) do Inc(valChPos); // Result := Copy(AValue, startPos, valChPos - startPos); //// while (valChPos <= Length(AValue)) and not GMIsDelimiter(cStrDigits, AValue, valChPos) do Inc(valChPos); //end; begin Result := (Length(AValue) > 0) and (Length(AFormat) > 0); fmtChPos := 1; valChPos := 1; // day := 0; month := 0; year := 0; hour := 0; minute := 0; second := 0; milliSec := 0; while Result and (valChPos <= Length(AValue)) and (fmtChPos <= Length(AFormat)) do begin for dtp := Low(dtp) to High(dtp) do if GMSameText(Copy(AFormat, fmtChPos, Length(cDateTimeFmtPatterns[dtp])), cDateTimeFmtPatterns[dtp]) then Break; Inc(fmtChPos, Length(cDateTimeFmtPatterns[dtp])); case dtp of dtpDD, dtpMM, dtpYYYY, dtpYY, dtpHH, dtpNN, dtpSS: begin valPart := Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtp])); Inc(valChPos, Length(cDateTimeFmtPatterns[dtp])); if not GMIsNumber(valPart) then Exit(False); // <- NOTE: May Exit here! end; dtpHour, dtpMinute, dtpSecond, dtpMilliSecond, dtpDay, dtpMonth: begin startPos := valChPos; while (valChPos <= Length(AValue)) and GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); valPart := Copy(AValue, startPos, valChPos-startPos); if not GMIsNumber(valPart) then Exit(False); // <- NOTE: May Exit here! end; dtpUnknown: raise EGMException.ObjError(GMFormat(RStrInvalidDateTimeFmtStr, [AFormat, fmtChPos]), nil, {$I %CurrentRoutine%}); dtpSep0: while (valChPos <= Length(AValue)) and not GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); else valPart := ''; end; // if not (dtp in [dtpUnknown, dtpSep0]) then // valPart := '' else // begin // valPart := Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtp])); // if not GMIsNumber(valPart) then begin Result := False; Exit; end; // <- NOTE: Exit here! // end; case dtp of dtpDD, dtpDay: Result := GMIsInRange(GMStrToInt(valPart), 1, 31); dtpMM, dtpMonth: Result := GMIsInRange(GMStrToInt(valPart), 1, 12); dtpYYYY: Result := GMIsInRange(GMStrToInt(valPart), 0, 9999); dtpYY: Result := GMIsInRange(GMStrToInt(valPart), 0, 99); dtpHH, dtpHour: Result := GMIsInRange(GMStrToInt(valPart), 0, 23); dtpNN, dtpSS, dtpSecond, dtpMinute: Result := GMIsInRange(GMStrToInt(valPart), 0, 59); dtpMilliSecond: Result := GMIsInRange(GMStrToInt(valPart), 0, 999); end; // if not (dtp in [dtpSep0]) then Inc(valChPos, Length(cDateTimeFmtPatterns[dtp])); end; end; function GMStrToDateTime(const AValue, AFormat: TGMString): TDateTime; var fmtChPos, valChPos, oldValChPos, day, month, year, hour, minute, second, milliSec, i, intVal: Integer; dtPart: TGMDateTimePart; // valStr: TGMString; token: TGMString; isNegative: Boolean; time: TDateTime; function CurrentYear: Integer; var sysTime: TSystemTime; begin //FillByte(sysTime, SizeOf(sysTime), 0); sysTime := Default(TSystemTime); GetLocalTime(sysTime); Result := sysTime.wYear; end; begin fmtChPos := 1; valChPos := 1; day := 0; month := 0; year := 0; hour := 0; minute := 0; second := 0; milliSec := 0; isNegative := False; while (valChPos <= Length(AValue)) and (fmtChPos <= Length(AFormat)) do begin for dtPart := Low(dtPart) to High(dtPart) do if GMSameText(Copy(AFormat, fmtChPos, Length(cDateTimeFmtPatterns[dtPart])), cDateTimeFmtPatterns[dtPart]) then Break; Inc(fmtChPos, Length(cDateTimeFmtPatterns[dtPart])); case dtPart of dtpUnknown: raise EGMException.ObjError(GMFormat(RStrInvalidDateTimeFmtStr, [AFormat, fmtChPos]), nil, {$I %CurrentRoutine%}); dtpSign: begin oldValChPos := valChPos; while (valChPos <= Length(AValue)) and GMIsdelimiter(cWhiteSpace + '+-', AValue, valchPos) do Inc(valchPos); token := Copy(AValue, oldValChPos, valChPos - oldValChPos); // GMStrip( cWhiteSpace); for i:=1 to Length(token) do case token[i] of '-': isNegative := not isNegative; '+': isNegative := False; end; end; dtpSep0: while (valChPos <= Length(AValue)) and not GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); dtpDay, dtpMonth, dtpHour, dtpMinute, dtpSecond, dtpMilliSecond: begin oldValChPos := valChPos; while (valChPos <= Length(AValue)) and GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); intVal := GMStrToInt(Copy(AValue, oldValChPos, valChPos - oldValChPos)); case dtPart of dtpDay: day := intVal; dtpMonth: month := intVal; dtpHour: hour := intVal; dtpMinute: minute := intVal; dtpSecond: second := intVal; dtpMilliSecond: milliSec := intVal; end; end; //dtpDay: // begin // oldValChPos := valChPos; // while (valChPos <= Length(AValue)) and GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); // day := GMStrToInt(Copy(AValue, oldValChPos, valChPos - oldValChPos)); // end; // //dtpMonth: // begin // oldValChPos := valChPos; // while (valChPos <= Length(AValue)) and GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); // month := GMStrToInt(Copy(AValue, oldValChPos, valChPos - oldValChPos)); // end; // //dtpHour: // begin // oldValChPos := valChPos; // while (valChPos <= Length(AValue)) and GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); // hour := GMStrToInt(Copy(AValue, oldValChPos, valChPos - oldValChPos)); // end; // //dtpMinute: // begin // oldValChPos := valChPos; // while (valChPos <= Length(AValue)) and GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); // minute := GMStrToInt(Copy(AValue, oldValChPos, valChPos - oldValChPos)); // end; // //dtpSecond: // begin // oldValChPos := valChPos; // while (valChPos <= Length(AValue)) and GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); // second := GMStrToInt(Copy(AValue, oldValChPos, valChPos - oldValChPos)); // end; // //dtpMilliSecond: // begin // oldValChPos := valChPos; // while (valChPos <= Length(AValue)) and GMIsdelimiter(cStrDigits, AValue, valchPos) do Inc(valchPos); // milliSec := GMStrToInt(Copy(AValue, oldValChPos, valChPos - oldValChPos)); // end; dtpDD: begin day := GMStrToInt32(Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtPart]))); Inc(valChPos, Length(cDateTimeFmtPatterns[dtPart])); end; dtpMM: begin month := GMStrToInt32(Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtPart]))); Inc(valChPos, Length(cDateTimeFmtPatterns[dtPart])); end; dtpYYYY: begin year := GMStrToInt32(Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtPart]))); Inc(valChPos, Length(cDateTimeFmtPatterns[dtPart])); end; dtpHH: begin hour := GMStrToInt32(Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtPart]))); Inc(valChPos, Length(cDateTimeFmtPatterns[dtPart])); end; dtpNN: begin minute := GMStrToInt32(Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtPart]))); Inc(valChPos, Length(cDateTimeFmtPatterns[dtPart])); end; dtpSS: begin second := GMStrToInt32(Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtPart]))); Inc(valChPos, Length(cDateTimeFmtPatterns[dtPart])); end; dtpYY: begin year := GMStrToInt32(Copy(AValue, valChPos, Length(cDateTimeFmtPatterns[dtPart]))) + ((CurrentYear div 100) * 100); Inc(valChPos, Length(cDateTimeFmtPatterns[dtPart])); // year := year + ((CurrentYear div 100) * 100); end; end; // if not (dtPart in [dtpSign, dtpSep0, dtpDay, dtpMonth, dtpHour, dtpMinute, dtpSecond]) then Inc(valChPos, Length(cDateTimeFmtPatterns[dtPart])); end; if (year = 0) and (month = 0) and (day = 0) then Result := 0 else Result := EncodeDate(year, month, day); time := (hour / 24) + (minute / 1440) + (second / 86400) + (milliSec / 86400000); if Result >= 0 then Result := Result + time //EncodeTime(hour, minute, second, milliSec) else Result := Result - time; //EncodeTime(hour, minute, second, milliSec); if isNegative then Result := Result * -1; end; function GMBlockIndent(const AValue, AIndent: TGMString; const AStrip: Boolean): TGMString; var p: LongInt; begin p:=1; Result := AValue; if AStrip then while (p <= Length(Result)) and GMIsDelimiter(cWhiteSpace, Result, p) do System.Delete(Result, p, 1); Result := AIndent + Result; repeat while (p <= Length(Result)) and (Result[p] <> #10) and (Result[p] <> #13) do Inc(p); while (p <= Length(Result)) and (Result[p] = #10) or (Result[p] = #13) do Inc(p); if AStrip then while (p <= Length(Result)) and GMIsDelimiter(cWhiteSpace, Result, p) do System.Delete(Result, p, 1); if (p <= Length(Result)) then begin Insert(AIndent, Result, p); Inc(p, Length(AIndent)); end; until p > Length(Result); end; function GMStringReplaceRec(const ASearchStr, AReplacement: TGMString): TStringReplaceRec; begin Result.SearchStr := ASearchStr; Result.Replacement := AReplacement; end; function GMReplaceStrings(const AValue: TGMString; const AReplacements: array of TStringReplaceRec; const AMatchCase: Boolean): TGMString; var i, chPos: PtrInt; begin Result := AValue; for i:=Low(AReplacements) to High(AReplacements) do begin chPos := 1; while GMFindToken(Result, AReplacements[i].SearchStr, chPos, '', False, not AMatchCase) do begin System.Delete(Result, chPos, Length(AReplacements[i].SearchStr)); Insert(AReplacements[i].Replacement, Result, chPos); Inc(chPos, Length(AReplacements[i].Replacement)); end; end; end; //function GMPresentExceptInfoToUI(const AUnkExceptInfo: IUnknown): Boolean; //var AExceptInfo: IGMExceptionInformation; //begin //Result := GMAskBoolean(AUnkExceptInfo, Ord(bevPresentToUI), True) and // (not GMQueryInterface(AUnkExceptInfo, IGMExceptionInformation, AExceptInfo) or // (CompareText(AExceptInfo.GetExceptionClassName, EAbort.ClassName) <> 0)) //end; function GMPresentExceptionUI(const AException: TObject): Boolean; var AskBoolean: IGMAskBoolean; begin //Result := GMIsClassByName(AException, EAbort); Result := (AException <> nil) and (not GMGetInterface(AException, IGMAskBoolean, AskBoolean) or (AskBoolean.AskBoolean(Ord(bevPresentToUI)) <> Ord(barFalse))) and not GMIsClassByName(AException, EAbort); end; //function GMDfltVerboseExceptionMessages: Boolean; //begin //{$IFDEF DEBUG} Result := True; {$ELSE} Result := False; {$ENDIF} //end; function GMBuildExceptionMsg(const AExceptInfo: IGMExceptionInformation; const AVerbose: Boolean): TGMString; var EClassName, ObjName, ObjClassName, ARoutineName, Msg, FormatStr, Severity: TGMString; EAddr: Pointer; HRCode: HResult; begin if AVerbose then // or vfGMVerboseExceptionMessages then begin FormatStr := RStrExceptionModule + ': %s'+ c2NewLine + RStrExceptionClass + ': %s' + cNewLine + RStrSeverityLevel + ': %s' + cNewLine + RStrObjectName + ': %s' + cNewLine + RStrObjectClass + ': %s' + cNewLine + RStrRoutineName + ': %s' + cNewLine + RStrExceptAddr + ': $%p' + c2NewLine + RStrMessage + ':' + cNewLine + '---------------' + cNewLine + '%s' + c2NewLine; if AExceptInfo <> nil then Severity := GMSeverityName(AExceptInfo.SeverityLevel) else Severity := RStrUnknown; if AExceptInfo <> nil then ObjName := AExceptInfo.RaisorName else ObjName := RStrUnknown; if (AExceptInfo <> nil) and (AExceptInfo.RaisorClassName <> '') then ObjClassName := AExceptInfo.RaisorClassName else ObjClassName := RStrUnknown; if (AExceptInfo <> nil) and (AExceptInfo.RoutineName <> '') then ARoutineName := AExceptInfo.RoutineName else ARoutineName := RStrUnknown; if (AExceptInfo <> nil) and (AExceptInfo.ExceptionClassName <> '') then EClassName := AExceptInfo.ExceptionClassName else EClassName := RStrUnknown; if AExceptInfo <> nil then EAddr := AExceptInfo.ExceptAddress else EAddr := nil; if AExceptInfo <> nil then Msg := AExceptInfo.GMMessage else Msg := RStrNoExceptInfo; HRCode := GMGetIntfHRCode(AExceptInfo, S_OK); if HRCode <> S_OK then Msg := GMStringJoin(GMFormat('(Hex: 0x%X, Dez: %d)', [HRCode, HRCode]), ' ', Msg); Result := GMFormat(FormatStr, [GMUpperCase(GMExtractFileName(GMThisModuleFileName)), EClassName, Severity, ObjName, ObjClassName, ARoutineName, EAddr, Msg]); end else if AExceptInfo <> nil then Result := AExceptInfo.GMMessage else Result := RStrNoExceptInfo; Result := GMTerminateStr(Result); end; function GMMsgFromExceptObj(const AException: TObject; const AVerbose: Boolean): TGMString; var exceptInfo: IGMExceptionInformation; begin if GMGetInterface(AException, IGMExceptionInformation, exceptInfo) then Result := GMBuildExceptionMsg(exceptInfo, AVerbose) else if GMIsClassByName(AException, Exception) then // Result := PChar(Exception(AException).Message) {$IFDEF FPC} Result := Exception(AException).Message {$ELSE} Result := PChar(Exception(AException).Message) {$ENDIF} else Result := GMGetObjText(AException); end; function GMExceptionSeverity(const AException: TObject; const ADefaultValue: TGMSeverityLevel): TGMSeverityLevel; var exceptInfo: IGMExceptionInformation; begin if GMGetInterface(AException, IGMExceptionInformation, exceptInfo) then Result := exceptInfo.SeverityLevel else Result := ADefaultValue; // svError; end; { ----------------------------------- } { ---- TGMString Buffer Routines ---- } { ----------------------------------- } //function GMStrLen(AValue: PGMChar): LongWord; //begin ////{$IFDEF UNICODE}Result := lstrlenw(AValue);{$ELSE}Result := lstrlena(AValue);{$ENDIF} //if AValue = nil then Result := 0 else Result := GMStrLScan(AValue, #0, High(LongInt)) - AValue; //end; function GMStrLenA(const AStr: PAnsiChar; AMaxLenInChars: PtrInt): PtrInt; var pEnd: PAnsiChar; begin if AStr = nil then Result := 0 else begin if AMaxLenInChars < 0 then AMaxLenInChars := High(PtrInt); pEnd := GMStrLScanA(AStr, #0, AMaxLenInChars); if pEnd = nil then Result := AMaxLenInChars else Result := pEnd - AStr; end; end; function GMStrLenW(const AStr: PWideChar; AMaxLenInChars: PtrInt): PtrInt; var pEnd: PWideChar; begin if AStr = nil then Result := 0 else begin if AMaxLenInChars < 0 then AMaxLenInChars := High(PtrInt); pEnd := GMStrLScanW(AStr, #0, AMaxLenInChars); if pEnd = nil then Result := AMaxLenInChars else Result := pEnd - AStr; end; end; function GMStrLen(const AStr: PGMChar; AMaxLenInChars: PtrInt): PtrInt; //var pEnd: PGMChar; begin {$IFDEF UNICODE} Result := GMStrLenW(AStr, AMaxLenInChars); {$ELSE} Result := GMStrLenA(AStr, AMaxLenInChars); {$ENDIF} //if AStr = nil then Result := 0 else // begin // if AMaxLenInChars < 0 then AMaxLenInChars := High(PtrInt); // pEnd := GMStrLScan(AStr, #0, AMaxLenInChars); // if pEnd = nil then Result := AMaxLenInChars else Result := pEnd - AStr; // end; end; //function GMStrNLen(const Value: PAnsiChar; const MaxLen: LongInt): LongWord; //begin //for Result:=0 to MaxLen-1 do if (Value + Result)^ = #0 then Break; //end; // //function GMWStrNLen(const Value: PWideChar; const MaxLen: LongInt): LongWord; //begin //for Result:=0 to MaxLen-1 do if (Value + Result)^ = #0 then Break; //end; // //function GMStrLenA(const Value: PAnsiChar; const MaxLen: LongInt = -1): LongInt; //begin //if MaxLen < 0 then Result := lstrlena(Value) else Result := GMStrNLen(Value, MaxLen); //end; //function GMBufferAsString(const Buffer: Pointer; MaxLen: LongInt = -1): AnsiString; //begin //if (Buffer <> nil) and (MaxLen <> 0) then SetString(Result, PGMChar(Buffer), GMStrLenA(Buffer, MaxLen)); //end; //function GMBufferAsWideString(const Buffer: Pointer; MaxLen: LongInt = -1): UnicodeString; //begin //if (Buffer <> nil) and (MaxLen <> 0) then SetString(Result, PWideChar(Buffer), GMStrLenW(Buffer, MaxLen)); //end; { ------------------------- } { ---- TGMMemoryBuffer ---- } { ------------------------- } constructor TGMMemoryBuffer.Create(const AOwner: TObject = nil; const ASizeInBytes: Int64 = 0; const AAllocAlignment: LongWord = cDfltAllocAlignment; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); begin FOwner := AOwner; inherited Create(ARefLifeTime); AllocAlignment := AAllocAlignment; // <- Use SetAllocAlignment here ZeroInit := AZeroInit; FreeMemoryOnDestroy := AFreeMemoryOnDestroy; FOnAfterRealloc := AOnAfterRealloc; ReallocMemory(ASizeInBytes); end; destructor TGMMemoryBuffer.Destroy; begin if FFreeMemoryOnDestroy then FreeMemory; inherited Destroy; end; function TGMMemoryBuffer.Obj: TGMMemoryBuffer; begin Result := Self; end; function TGMMemoryBuffer.QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} IID: TGUID; out Intf): HResult; var PIUnkOwner: IUnknown; begin Result := inherited QueryInterface(IID, Intf); if (Result <> S_OK) and GMGetInterface(FOwner, IUnknown, PIUnkOwner) then Result := PIUnkOwner.QueryInterface(IID, Intf); end; function TGMMemoryBuffer._AddRef: LongInt; var PIUnkOwner: IUnknown; begin if GMGetInterface(FOwner, IUnknown, PIUnkOwner) then Result := PIUnkOwner._AddRef else Result := inherited _AddRef; end; function TGMMemoryBuffer._Release: LongInt; var PIUnkOwner: IUnknown; begin if GMGetInterface(FOwner, IUnknown, PIUnkOwner) then Result := PIUnkOwner._Release else Result := inherited _Release; end; procedure TGMMemoryBuffer.FreeMemory; begin ReallocMemory(0); end; procedure TGMMemoryBuffer.InternalRealloc(const ANewSizeInBytes: Int64); begin ReallocMem(FMemory, ANewSizeInBytes); end; procedure TGMMemoryBuffer.ReallocMemory(ANewSizeInBytes: Int64); begin ANewSizeInBytes := GMAlignedValue(ANewSizeInBytes, FAllocAlignment); if ANewSizeInBytes <> FSizeInBytes then begin InternalRealloc(ANewSizeInBytes); if FZeroInit and (ANewSizeInBytes > FSizeInBytes) then FillByte(GMAddPtr(FMemory, FSizeInBytes)^, ANewSizeInBytes - FSizeInBytes, 0); FSizeInBytes := ANewSizeInBytes; if Assigned(FOnAfterRealloc) then FOnAfterRealloc(Self); end; end; //function TGMMemoryBuffer.GetMemory: Pointer; //begin // Result := FMemory; //end; // //function TGMMemoryBuffer.GetSizeInBytes: Int64; //begin // Result := FSizeInBytes; //end; // //function TGMMemoryBuffer.GetAllocAlignment: LongWord; //begin // Result := FAllocAlignment; //end; procedure TGMMemoryBuffer.SetAllocAlignment(const AValue: LongWord); begin FAllocAlignment := Max(AValue, 1); ReallocMemory(FSizeInBytes); end; //function TGMMemoryBuffer.GetZeroInit: Boolean; //begin // Result := FZeroInit; //end; // //procedure TGMMemoryBuffer.SetZeroInit(const Value: Boolean); //begin // FZeroInit := Value; //end; // //function TGMMemoryBuffer.GetFreeMemoryOnDestroy: Boolean; //begin // Result := FFreeMemoryOnDestroy; //end; // //procedure TGMMemoryBuffer.SetFreeMemoryOnDestroy(const Value: Boolean); //begin // FFreeMemoryOnDestroy := Value; //end; { ------------------------------- } { ---- TGMGlobalMemoryBuffer ---- } { ------------------------------- } constructor TGMGlobalMemoryBuffer.Create(const AOwner: TObject = nil; const ASizeInBytes: Int64 = 0; const AAllocAlignment: LongWord = cDfltAllocAlignment; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); begin FAllocFlags := cDfltGlobalAllocFlags; inherited Create(AOwner, ASizeInBytes, AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy, AOnAfterRealloc, ARefLifeTime); end; constructor TGMGlobalMemoryBuffer.Create(const AOwner: TObject = nil; const ASizeInBytes: Int64 = 0; const AAllocAlignment: LongWord = cDfltAllocAlignment; const AAllocFlags: LongWord = cDfltGlobalAllocFlags; const AZeroInit: Boolean = False; const AFreeMemoryOnDestroy: Boolean = True; const AOnAfterRealloc: TGMObjNotifyProc = nil; const ARefLifeTime: Boolean = True); begin FAllocFlags := AAllocFlags; inherited Create(AOwner, ASizeInBytes, AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy, AOnAfterRealloc, ARefLifeTime); end; destructor TGMGlobalMemoryBuffer.Destroy; begin inherited Destroy; if FMemory <> nil then GlobalUnlock(FHGlobal); // <- Unlock in case of not FreeMemoryOnDestroy end; procedure TGMGlobalMemoryBuffer.InternalRealloc(const ANewSizeInBytes: Int64); var pBuf: Pointer; oldSize: PtrUInt; begin if (FMemory = nil) and (ANewSizeInBytes = 0) then Exit; if FMemory = nil then begin // FMemory = nil, Size > 0 FHGlobal := GlobalAlloc(FAllocFlags, ANewSizeInBytes); FMemory := GlobalLock(FHGlobal); end else if ANewSizeInBytes > 0 then begin // FMemory <> nil, Size > 0 oldSize := GlobalSize(FHGlobal); GetMem(pBuf, oldSize); try Move(FMemory^, pBuf^, oldSize); GlobalUnlock(FHGlobal); // <- dont check, OS says already unlocked, dont ask me why .. GMAPICheckObj('GlobalFree', '', GetLastError, GlobalFree(FHGlobal) = 0, Self); FHGlobal := GlobalAlloc(FAllocFlags, ANewSizeInBytes); FMemory := GlobalLock(FHGlobal); Move(pBuf^, FMemory^, Min(oldSize, ANewSizeInBytes)); //HGLOBAL(FMemory) := GlobalRealloc(HGLOBAL(FMemory), ANewSizeInBytes, GPTR) <- geht nicht, shit! finally FreeMem(pBuf); end; end else begin // FMemory <> nil, Size = 0 GlobalUnlock(FHGlobal); // <- dont check, OS says already unlocked, dont ask me why .. FHGlobal := GlobalFree(FHGlobal); GMAPICheckObj('GlobalFree', '', GetLastError, FHGlobal = 0, Self); FMemory := nil; end; GMAPICheckObj('GlobalAlloc', '', GetLastError, (ANewSizeInBytes = 0) or (FMemory <> nil), Self); end; function TGMGlobalMemoryBuffer.GetHandle: THandle; begin Result := FHGlobal; end; procedure TGMGlobalMemoryBuffer.SetHandle(const Value: THandle); begin if FFreeMemoryOnDestroy then FreeMemory; FHGlobal := Value; if FHGlobal = 0 then FMemory := nil else FMemory := GlobalLock(FHGlobal); FSizeInBytes := GlobalSize(FHGlobal); end; { ----------------------------------- } { ---- TGMAnsiStringMemoryBuffer ---- } { ----------------------------------- } constructor TGMAnsiStringMemoryBuffer.Create(const AOwner: TObject; const AContentAsString: AnsiString; const AOnAfterRealloc: TGMObjNotifyProc; const ARefLifeTime: Boolean); begin inherited Create(AOwner, Length(AContentAsString), 0, False, True, AOnAfterRealloc, ARefLifeTime); FAnsiStringBuffer := AContentAsString; //FSizeInBytes := Length(AString); FMemory := PAnsiChar(FAnsiStringBuffer); end; procedure TGMAnsiStringMemoryBuffer.InternalRealloc(const ANewSizeInBytes: Int64); begin SetLength(FAnsiStringBuffer, ANewSizeInBytes); FMemory := PAnsiChar(FAnsiStringBuffer); end; function TGMAnsiStringMemoryBuffer.GetText: TGMString; begin Result := FAnsiStringBuffer; end; function TGMAnsiStringMemoryBuffer.GetAnsiText: AnsiString; begin Result := FAnsiStringBuffer; end; { ------------------------------- } { ---- TGMStringMemoryBuffer ---- } { ------------------------------- } constructor TGMStringMemoryBuffer.Create(const AOwner: TObject; const AContentAsString: TGMString; const AOnAfterRealloc: TGMObjNotifyProc; const ARefLifeTime: Boolean); begin inherited Create(AOwner, Length(AContentAsString) * SizeOf(TGMChar), 0, False, True, AOnAfterRealloc, ARefLifeTime); FStringBuffer := AContentAsString; //FSizeInBytes := Length(AString); FMemory := PGMChar(FStringBuffer); end; procedure TGMStringMemoryBuffer.InternalRealloc(const ANewSizeInBytes: Int64); begin SetLength(FStringBuffer, ANewSizeInBytes div SizeOf(TGMChar)); FMemory := PGMChar(FStringBuffer); end; function TGMStringMemoryBuffer.GetText: TGMString; stdcall; begin Result := FStringBuffer; end; //function TGMStringMemoryBuffer.GetAnsiText: AnsiString; //begin // Result := FStringBuffer; //end; { --------------------------------- } { ---- TGMResourceMemoryBuffer ---- } { --------------------------------- } constructor TGMResourceMemoryBuffer.Create(const AOwner: TObject; const AResourceName: PGMChar; const AResourceType: PGMChar; AModuleHandle: THandle; const AOnAfterRealloc: TGMObjNotifyProc; const ARefLifeTime: Boolean); var ResInfo, ResData: THandle; begin inherited Create(AOwner, 0, 0, False, True, AOnAfterRealloc, ARefLifeTime); if AModuleHandle = INVALID_HANDLE_VALUE then AModuleHandle := {$IFNDEF FPC}SysInit.{$ELSE}System.{$ENDIF}HInstance; ResInfo := FindResource(AModuleHandle, AResourceName, AResourceType); GMApiCheckObj('FindResource', '', GetLastError, ResInfo <> 0, Self); ResData := LoadResource(AModuleHandle, ResInfo); GMApiCheckObj('LoadResource', '', GetLastError, ResData <> 0, Self); FSizeInBytes := SizeOfResource(AModuleHandle, ResInfo); FMemory := LockResource(ResData); end; procedure TGMResourceMemoryBuffer.InternalRealloc(const ANewSizeInBytes: Int64); begin if ANewSizeInBytes <> 0 then raise EGMException.ObjError(RStrResWriteNotSupported, Self); end; { ---------------------------- } { ---- TGMMemoryLockBytes ---- } { ---------------------------- } constructor TGMMemoryLockBytes.Create(const AAllocAlignment: LongInt; const AZeroInit: Boolean; const AFreeMemoryOnDestroy: Boolean; const ASizeInBytes: Int64; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); //FMemoryBuffer := CreateMemoryBuffer(ASizeInBytes, AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy); FMemoryBuffer := TGMMemoryBuffer.Create(Self, ASizeInBytes, AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy, OnAfterRealloc, False); GetSystemTimeAsFileTime(FCTime); FATime := FCTime; FMTime := FCTime; end; destructor TGMMemoryLockBytes.Destroy; begin GMFreeAndNil(FMemoryBuffer); inherited Destroy; end; procedure TGMMemoryLockBytes.Clear(const AResetOffset: Boolean = True); begin if AResetOffset then Offset := 0; InternalSetSize(Offset); end; {function TGMMemoryLockBytes.CreateMemoryBuffer(const ASizeInBytes, AAllocAlignment: LongInt; const AZeroInit, AFreeMemoryOnDestroy: Boolean): TGMMemoryBuffer; begin Result := TGMMemoryBuffer.Create(Self, ASizeInBytes, AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy, OnAfterRealloc, False); end;} procedure TGMMemoryLockBytes.OnAfterRealloc(const ASender: TObject); begin end; function TGMMemoryLockBytes.Memory: Pointer; begin Result := GMAddPtr(FMemoryBuffer.Memory, Offset); end; function TGMMemoryLockBytes.GetDataSize: Int64; begin Result := Max(FFullDataSize - Offset, 0); end; procedure TGMMemoryLockBytes.InternalSetSize(ANewSize: Int64); begin // // Offset adding is done in interface method SetSize // ANewSize := Max(ANewSize, 0); if ANewSize <> FFullDataSize then begin FMemoryBuffer.ReallocMemory(ANewSize); FFullDataSize := ANewSize; FOffset := Min(FOffset, ANewSize); end; end; procedure TGMMemoryLockBytes.AssignFromIntf(const ASource: IUnknown); var srcLockBytes: ILockBytes; srcOffset: IGMGetSetOffset; orgSrcOffset: LongInt; begin GMCheckQueryInterface(ASource, ILockBytes, srcLockBytes, {$I %CurrentRoutine%}); GMCheckQueryInterface(ASource, IGMGetSetOffset, srcOffset, {$I %CurrentRoutine%}); Offset := 0; orgSrcOffset := srcOffset.Offset; srcOffset.Offset := 0; try GMCopyLockBytes(srcLockBytes, Self); finally srcOffset.Offset := orgSrcOffset; end; Offset := orgSrcOffset; end; function TGMMemoryLockBytes.GetOffset: PtrInt; begin Result := FOffset; end; procedure TGMMemoryLockBytes.SetOffset(AValue: PtrInt); begin AValue := Max(0, AValue); if AValue <> FOffset then begin if AValue > FFullDataSize then InternalSetSize(AValue); FOffset := AValue; end; end; procedure TGMMemoryLockBytes.SetOffsetAndShiftData(const ANewOffset: LongInt); begin if ANewOffset < Offset then begin Move(Memory^, GMAddPtr(FMemoryBuffer.Memory, ANewOffset)^, Max(0, FFullDataSize - Offset)); InternalSetSize(FFullDataSize - Offset + ANewOffset); end else if ANewOffset > Offset then begin InternalSetSize(FFullDataSize - Offset + ANewOffset); Move(Memory^, GMAddPtr(FMemoryBuffer.Memory, ANewOffset)^, Max(0, FFullDataSize - ANewOffset)); end; Offset := ANewOffset; end; function TGMMemoryLockBytes.ReadAt(ulOffset: Int64; pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; var N: LongInt; begin try if pv = nil then begin Result := STG_E_INVALIDPOINTER; Exit; end; GetSystemTimeAsFileTime(FATime); N := Max(Min(cb, FFullDataSize - Offset - ulOffset), 0); if N > 0 then Move(GMAddPtr(Memory, ulOffset)^, pv^, N); if pcbRead <> nil then pcbRead^ := N; if N <> cb then Result := STG_E_READFAULT else Result := S_OK; //vfGMTrace(GMFormat('ILockBytes.ReadAt(Offset: %d, Size: %d, Read: %d)', [LongInt(ulOffset), cb, N]), tpCall); except on ex: TObject do Result := vfGMHrExceptionHandler(ex, cHrPrntWnd); end; end; function TGMMemoryLockBytes.WriteAt(ulOffset: Int64; pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; begin try if pv = nil then begin Result := STG_E_INVALIDPOINTER; Exit; end; GetSystemTimeAsFileTime(FATime); FMTime := FATime; InternalSetSize(Max(FFullDataSize, Offset + ulOffset + cb)); Move(pv^, GMAddPtr(Memory, ulOffset)^, cb); if pcbWritten <> nil then pcbWritten^ := cb; Result := S_OK; //vfGMTrace(GMFormat('ILockBytes.WriteAt(Offset: %d, Size: %d, Written: %d)', [LongInt(ulOffset), cb, cb]), tpCall); except on ex: TObject do Result := vfGMHrExceptionHandler(ex, cHrPrntWnd); end; end; function TGMMemoryLockBytes.Flush: HResult; begin Result := S_OK; end; function TGMMemoryLockBytes.SetSize(cb: Int64): HResult; begin try GetSystemTimeAsFileTime(FATime); FMTime := FATime; InternalSetSize(cb + Offset); Result := S_OK; except on ex: TObject do Result := vfGMHrExceptionHandler(ex, cHrPrntWnd); end; end; function TGMMemoryLockBytes.LockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; begin Result := STG_E_INVALIDFUNCTION; end; function TGMMemoryLockBytes.UnlockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; begin Result := STG_E_INVALIDFUNCTION; end; function TGMMemoryLockBytes.Stat(out statstg: TStatStg; grfStatFlag: LongInt): HResult; begin try if @statstg = nil then begin Result := STG_E_INVALIDPOINTER; Exit; end; //FillByte(statstg, SizeOf(statstg), 0); statstg := Default(TStatStg); if grfStatFlag and STATFLAG_NONAME = 0 then GMCoTaskStrDupW(ClassName); statstg.mtime := FMTime; statstg.ctime := FCTime; statstg.atime := FATime; statstg.dwType := STGTY_LOCKBYTES; statstg.cbSize := DataSize; statstg.grfMode := STGM_READWRITE; statstg.grfLocksSupported := LOCK_WRITE; Result := S_OK; except on ex: TObject do Result := vfGMHrExceptionHandler(ex, cHrPrntWnd); end; end; { ------------------------ } { ---- TGMIStreamBase ---- } { ------------------------ } constructor TGMIStreamBase.Create(const AMode: DWORD; const AName: UnicodeString = ''; const ARefLifeTime: Boolean = True); begin Create(ARefLifeTime); if Length(AName) > 0 then FName := AName else FName := ClassName; FMode := AMode; end; function TGMIStreamBase.GetName: TGMString; stdcall; begin Result := FName; end; function TGMIStreamBase.CloneCreateClass: TGMIStreamRootClass; begin Result := nil; // <- Cloning is not supported, override it to support cloning end; function TGMIStreamBase.InternalGetSize: Int64; begin Result := 0; end; function TGMIStreamBase.Clone(out stm: IStream): HResult; var Clone: IUnknown; begin try // Override CloneCreateClass to make your stream clonable if CloneCreateClass = nil then begin Result := E_NOTIMPL; Exit; end; Clone := CloneCreateClass.Create(FMode, FName, RefLifeTime); Result := Clone.QueryInterface(IStream, stm); except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd) else raise; end; end; function TGMIStreamBase.CopyTo(stm: IStream; cb: Int64; out cbRead, cbWritten: Int64): HResult; const CResult: array [Boolean] of HResult = (STG_E_WRITEFAULT, S_OK); CBufSize = cDfltCopyBufferSize; var Buffer: IGMMemoryBuffer; R, W: LongWord; RTotal, WTotal: Int64; begin try if stm = nil then begin Result := E_INVALIDARG; Exit; end; RTotal := 0; WTotal := 0; if cb = 0 then Result := S_OK else begin Buffer := TGMMemoryBuffer.Create(nil, CBufSize); repeat GMHrCheckObj(Read(Buffer.Obj.Memory, Min(CBufSize, cb - RTotal), PLongInt(@R)), Self, {$I %CurrentRoutine%}); if R = 0 then Continue; Inc(RTotal, R); GMHrCheckIntf(stm.Write(Buffer.Obj.Memory, R, PLongInt(@W)), stm, {$I %CurrentRoutine%}); Inc(WTotal, W); until (R < CBufSize) or (W <> R); Result := CResult[RTotal = WTotal]; end; if @cbRead <> nil then cbRead := RTotal; if @cbWritten <> nil then cbWritten := WTotal; except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd) else raise; end; end; function TGMIStreamBase.Stat(out statstg: TStatStg; grfStatFlag: LongInt): HResult; begin try if @statstg = nil then begin Result := STG_E_INVALIDPOINTER; Exit; end; //FillByte(statstg, SizeOf(statstg), 0); statstg := Default(TStatStg); if grfStatFlag and STATFLAG_NONAME = 0 then statstg.pwcsName := GMCoTaskStrDupW(FName); statstg.cbSize := InternalGetSize; statstg.dwType := STGTY_STREAM; //statstg.grfLocksSupported := LOCK_WRITE; // <- leave it zero => no locks supported statstg.grfMode := LongInt(FMode); Result := S_OK; except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd) else raise; end; end; function TGMIStreamBase.SetSize(libNewSize: Int64): HResult; begin Result := STG_E_INVALIDFUNCTION; end; function TGMIStreamBase.Revert: HResult; begin Result := STG_E_REVERTED; end; function TGMIStreamBase.Commit(grfCommitFlags: LongInt): HResult; begin Result := S_OK; end; function TGMIStreamBase.LockRegion(libOffset, cb: Int64; dwLockType: LongInt): HResult; begin Result := STG_E_INVALIDFUNCTION; end; function TGMIStreamBase.UnlockRegion(libOffset, cb: Int64; dwLockType: LongInt): HResult; begin Result := STG_E_INVALIDFUNCTION; end; { ------------------------------ } { ---- TGMSequentialIStream ---- } { ------------------------------ } function TGMSequentialIStream.InternalGetSize: Int64; begin Result := FSize; end; function TGMSequentialIStream.Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; var n, rest: LongWord; begin try if pv = nil then begin Result := STG_E_INVALIDPOINTER; if pcbRead <> nil then pcbRead^ := 0; Exit; end; rest := cb; repeat n := 0; InternalRead(GMAddPtr(pv, LongWord(cb) - rest), rest, n); Dec(rest, n); Inc(FPosition, n); until (rest = 0) or (n = 0); if pcbRead <> nil then pcbRead^ := LongWord(cb) - rest; //FPosition := FPosition + cb - rest; FSize := Max(FPosition, FSize); Result := GMIStreamReadResult(pcbRead, rest = 0); except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd, GM_E_STREAMREAD) else raise; end; end; function TGMSequentialIStream.Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; var rest, n: DWORD; begin try if pv = nil then begin Result := STG_E_INVALIDPOINTER; if pcbWritten <> nil then pcbWritten^ := 0; Exit; end; rest := cb; repeat n := 0; InternalWrite(GMAddPtr(pv, LongWord(cb) - rest), rest, n); Dec(rest, n); Inc(FPosition, n); until (rest = 0) or (n = 0); if pcbWritten <> nil then pcbWritten^ := LongWord(cb) - rest; //FPosition := FPosition + cb - rest; FSize := Max(FPosition, FSize); Result := GMIStreamWriteResult(pcbWritten, rest = 0); except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd, GM_E_STREAMWRITE) else raise; end; end; function TGMSequentialIStream.Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; // // Typical implementation for sequential streams // const CResult: array [Boolean] of HResult = (E_FAIL, S_OK); var NewPos: Int64; Buf: IGMMemoryBuffer; begin try Result := CO_E_NOT_SUPPORTED; case dwOrigin of STREAM_SEEK_CUR: NewPos := Max(0, FPosition + dlibMove); STREAM_SEEK_SET: NewPos := Max(0, dlibMove); else Exit; // <- Result is CO_E_NOT_SUPPORTED end; // we cannot seek backward if NewPos < FPosition then Exit; // <- Result is CO_E_NOT_SUPPORTED if NewPos > FPosition then begin // Seeking forward not possible in write mode if FMode = STGM_WRITE then Exit; // <- Result is CO_E_NOT_SUPPORTED // Eat the gap and throw away the data when seeking forward in read mode Buf := TGMMemoryBuffer.Create(nil, NewPos - FPosition); Read(Buf.Obj.Memory, Buf.Obj.SizeInBytes, nil); end; // In write mode NewPos must be equal to FPosition to get here Result := CResult[FPosition = NewPos]; if libNewPosition <> nil then libNewPosition^ := FPosition; except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd) else raise; end; end; { ------------------------------ } { ---- TGMMemoryIStreamBase ---- } { ------------------------------ } destructor TGMMemoryIStreamBase.Destroy; begin GMFreeAndNil(FMemoryBuffer); inherited Destroy; end; function TGMMemoryIStreamBase.Obj: TGMMemoryIStreamBase; begin Result := Self; end; function TGMMemoryIStreamBase.Memory: Pointer; begin Result := FMemoryBuffer.Obj.Memory; end; function TGMMemoryIStreamBase.Size: Int64; begin Result := FSize; end; procedure TGMMemoryIStreamBase.Clear; begin InternalSetSize(0); end; procedure TGMMemoryIStreamBase.OnAfterRealloc(const Sender: TObject); begin end; procedure TGMMemoryIStreamBase.LimitPosition; begin FPosition := Max(0, Min(FPosition, FSize)); end; procedure TGMMemoryIStreamBase.InternalSetSize(NewSize: Int64); begin NewSize := Max(NewSize, 0); if NewSize <> FSize then begin FMemoryBuffer.Obj.ReallocMemory(NewSize); FSize := NewSize; LimitPosition; end; end; function TGMMemoryIStreamBase.SetSize(libNewSize: Int64): HResult; begin try InternalSetSize(libNewSize); Result := S_OK; except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd) else raise; end; end; procedure TGMMemoryIStreamBase.InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); begin //FPosition := Max64(0, FPosition); pcbRead := Max(0, Min(cb, FSize - FPosition)); if pcbRead <= 0 then Exit; System.Move(GMAddPtr(FMemoryBuffer.Obj.Memory, FPosition)^, pv^, pcbRead); //Inc(FPosition, pcbRead); end; procedure TGMMemoryIStreamBase.InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); var NewPos: Int64; begin //FPosition := Max64(0, FPosition); pcbWritten := cb; if pcbWritten <= 0 then Exit; NewPos := FPosition + cb; if NewPos > FSize then InternalSetSize(NewPos); System.Move(pv^, GMAddPtr(FMemoryBuffer.Obj.Memory, FPosition)^, cb); //FPosition := NewPos; end; function TGMMemoryIStreamBase.Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; begin try case dwOrigin of STREAM_SEEK_SET: FPosition := dlibMove; STREAM_SEEK_CUR: FPosition := FPosition + dlibMove; STREAM_SEEK_END: FPosition := FSize + dlibMove; end; //LimitPosition; // <- allow seek beyond end of data! FPosition := Max(0, FPosition); if libNewPosition <> nil then libNewPosition^ := FPosition; //Result := FPosition; Result := S_OK; except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd) else raise; end; end; { -------------------------- } { ---- TGMMemoryIStream ---- } { -------------------------- } constructor TGMMemoryIStream.Create(const AAllocAlignment: LongInt; const AZeroInit, AFreeMemoryOnDestroy: Boolean; const ASizeInBytes: Int64; const ARefLifeTime: Boolean); begin inherited Create(STGM_READWRITE, '', ARefLifeTime); FMemoryBuffer := CreateMemoryBuffer(ASizeInBytes, AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy); FSize := ASizeInBytes; end; function TGMMemoryIStream.CreateMemoryBuffer(const ASizeInBytes: Int64; const AAllocAlignment: LongInt; const AZeroInit, AFreeMemoryOnDestroy: Boolean): TGMMemoryBuffer; begin Result := TGMMemoryBuffer.Create(Self, ASizeInBytes, AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy, OnAfterRealloc, False); end; { -------------------------------- } { ---- TGMGlobalMemoryIStream ---- } { -------------------------------- } constructor TGMGlobalMemoryIStream.Create(const AAllocAlignment: LongInt; const AZeroInit: Boolean; const AFreeMemoryOnDestroy: Boolean; const ASizeInBytes: Int64; const ARefLifeTime: Boolean); begin FAllocFlags := cDfltGlobalAllocFlags; inherited Create(AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy, ASizeInBytes, ARefLifeTime); end; constructor TGMGlobalMemoryIStream.Create(const AAllocAlignment: LongInt; const AAllocFlags: LongWord; const AHGlobal: HGlobal; const AZeroInit: Boolean; const AFreeMemoryOnDestroy: Boolean; const ASizeInBytes: Int64; const ARefLifeTime: Boolean); begin FAllocFlags := AAllocFlags; inherited Create(AAllocAlignment, AZeroInit, AFreeMemoryOnDestroy, ASizeInBytes, ARefLifeTime); if AHGlobal <> 0 then AssignGlobalMemory(AHGlobal); end; function TGMGlobalMemoryIStream.GetHandle: THandle; var PIHandle: IGMGetHandle; begin GMCheckQueryInterface(MemoryBuffer, IGMGetHandle, PIHandle, {$I %CurrentRoutine%}); Result := PIHandle.Handle; end; function TGMGlobalMemoryIStream.CreateMemoryBuffer(const ASizeInBytes: Int64; const AAllocAlignment: LongInt; const AZeroInit, AFreeMemoryOnDestroy: Boolean): TGMMemoryBuffer; begin Result := TGMGlobalMemoryBuffer.Create(Self, ASizeInBytes, AAllocAlignment, FAllocFlags, AZeroInit, AFreeMemoryOnDestroy, OnAfterRealloc, False); end; procedure TGMGlobalMemoryIStream.AssignGlobalMemory(const AHGlobal: HGLOBAL; const ADataSize: Int64; const APosition: LongInt); var PIHandle: IGMGetSetHandle; begin GMCheckQueryInterface(MemoryBuffer, IGMGetSetHandle, PIHandle, {$I %CurrentRoutine%}); PIHandle.Handle := AHGlobal; if ADataSize = -1 then FSize := MemoryBuffer.Obj.SizeInBytes else FSize := Max(0, Min(MemoryBuffer.Obj.SizeInBytes, ADataSize)); FPosition := APosition; LimitPosition; end; { ---------------------------- } { ---- TGMResourceIStream ---- } { ---------------------------- } constructor TGMAnsiStringIStream.Create(const AContentAsString: AnsiString; const ARefLifeTime: Boolean); begin inherited Create(STGM_READWRITE, '', ARefLifeTime); FMemoryBuffer := TGMAnsiStringMemoryBuffer.Create(Self, AContentAsString, OnAfterRealloc, False); FSize := FMemoryBuffer.Obj.FSizeInBytes; end; function TGMAnsiStringIStream.GetText: TGMString; begin Result := GMGetObjText(FMemoryBuffer); end; function TGMAnsiStringIStream.GetAnsiText: AnsiString; var ansiText: IGMGetAnsiText; begin if GMGetInterface(FMemoryBuffer, IGMGetAnsiText, ansiText) then Result := ansiText.GetAnsiText else Result := ''; end; { -------------------------- } { ---- TGMStringIStream ---- } { -------------------------- } constructor TGMStringIStream.Create(const AContentAsString: TGMString; const ARefLifeTime: Boolean); begin inherited Create(STGM_READWRITE, '', ARefLifeTime); FMemoryBuffer := TGMStringMemoryBuffer.Create(Self, AContentAsString, OnAfterRealloc, False); FSize := FMemoryBuffer.Obj.FSizeInBytes; end; function TGMStringIStream.GetText: TGMString; stdcall; begin Result := GMGetObjText(FMemoryBuffer); end; { ---------------------------- } { ---- TGMResourceIStream ---- } { ---------------------------- } constructor TGMResourceIStream.Create(const AResourceName: PGMChar; const AResourceType: PGMChar; const AModuleHandle: THandle; const ARefLifeTime: Boolean); begin inherited Create(STGM_READ, '', ARefLifeTime); FMemoryBuffer := TGMResourceMemoryBuffer.Create(Self, AResourceName, AResourceType, AModuleHandle, OnAfterRealloc, False); FSize := FMemoryBuffer.Obj.FSizeInBytes; end; { ----------------------------- } { ---- TGMLockBytesIStream ---- } { ----------------------------- } constructor TGMLockBytesIStream.Create(const ALockBytes: ILockBytes; const ARefLifeTime: Boolean); begin inherited Create(STGM_READWRITE, '', ARefLifeTime); FLockBytes := ALockBytes; end; {function TGMLockBytesIStream.GetOffset: LongInt; begin end; procedure TGMLockBytesIStream.SetOffset(Value: LongInt); begin end;} procedure TGMLockBytesIStream.InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); begin GMHrCheckObj(FLockBytes.ReadAt(FPosition, pv, cb, PLongInt(@pcbRead)), Self, 'TGMLockBytesIStream.InternalRead'); end; procedure TGMLockBytesIStream.InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); begin GMHrCheckObj(FLockBytes.WriteAt(FPosition, pv, cb, PLongInt(@pcbWritten)), Self, 'TGMLockBytesIStream.InternalWrite'); end; function TGMLockBytesIStream.SetSize(libNewSize: Int64): HResult; begin Result := FLockBytes.SetSize(libNewSize); end; function TGMLockBytesIStream.Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; begin try case dwOrigin of STREAM_SEEK_SET: FPosition := dlibMove; STREAM_SEEK_CUR: FPosition := FPosition + dlibMove; STREAM_SEEK_END: FPosition := FSize + dlibMove; end; //LimitPosition; // <- allow seek beyond end of data! FPosition := Max(0, FPosition); if libNewPosition <> nil then libNewPosition^ := FPosition; //Result := FPosition; Result := S_OK; except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd) else raise; end; end; { ------------------------------ } { ---- TGMFileHandleIStream ---- } { ------------------------------ } constructor TGMFileHandleIStream.Create(const AHandle: LongWord; const AMode: LongInt; const AName: UnicodeString = ''; const ARefLifeTime: Boolean = True); begin inherited Create(AMode, AName, ARefLifeTime); FHandle := AHandle; end; function TGMFileHandleIStream.GetHandle: THandle; begin Result := FHandle; end; function TGMFileHandleIStream.HandleIsValid: Boolean; begin Result := (FHandle <> 0) and (FHandle <> INVALID_HANDLE_VALUE); end; procedure TGMFileHandleIStream.InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); begin if not ReadFile(FHandle, pv{$IFNDEF JEDIAPI}^{$ENDIF}, cb, {$IFDEF JEDIAPI}@{$ENDIF}pcbRead, nil) then GMApiCheckObj('ReadFile', '', GetLastError, False, Self); end; procedure TGMFileHandleIStream.InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); begin if not WriteFile(FHandle, pv{$IFNDEF JEDIAPI}^{$ENDIF}, cb, {$IFDEF JEDIAPI}@{$ENDIF}pcbWritten, nil) then GMApiCheckObj('WriteFile', '', GetLastError, False, Self); end; { ------------------------ } { ---- TGMFileIStream ---- } { ------------------------ } constructor TGMFileIStream.Create(const AFileName: TGMString; const AAccess, AShare, ACreateKind: DWORD; const AFlags: DWORD; const ARefLifeTime: Boolean); var sizeLo, sizeHi: DWORD; mode, lastErr: DWORD; begin if AAccess and (GENERIC_READ or GENERIC_WRITE) = GENERIC_READ or GENERIC_WRITE then mode := STGM_READWRITE else if AAccess and GENERIC_READ = GENERIC_READ then mode := STGM_READ else if AAccess and GENERIC_WRITE = GENERIC_WRITE then mode := STGM_WRITE else mode := 0; inherited Create(mode, AFileName, ARefLifeTime); FHandle := CreateFile(PGMChar(AFileName), AAccess, AShare, nil, ACreateKind, AFlags, 0); // FILE_ATTRIBUTE_NORMAL if not HandleIsValid then begin lastErr := GetLastError; GMApiCheckObjParams('CreateFile("'+AFileName+'")', '', lastErr, False, [PGMChar(AFileName)], Self); //GMApiCheckObj('CreateFile("'+AFileName+'")', ': "'+AFileName+'"', lastErr, False, Self); end; sizeLo := GetFileSize(FHandle, @sizeHi); if sizeLo <> $FFFFFFFF then FSize := (sizeHi shl 32) or sizeLo; end; constructor TGMFileIStream.CreateRead(const AFileName: TGMString; const AShare, AFlags: DWORD; const ARefLifeTime: Boolean); begin Create(AFileName, GENERIC_READ, AShare, OPEN_EXISTING, AFlags, ARefLifeTime); end; constructor TGMFileIStream.CreateOverwrite(const AFileName: TGMString; const AAccess, AFlags: DWORD; const ARefLifeTime: Boolean); begin Create(AFileName, AAccess, FILE_SHARE_READ, CREATE_ALWAYS, AFlags, ARefLifeTime); end; destructor TGMFileIStream.Destroy; begin if HandleIsValid then begin CloseHandle(FHandle); FHandle := 0; end; inherited Destroy; end; function TGMFileIStream.Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; //const CResult: array [Boolean] of HResult = (E_FAIL, S_OK); var Offs: LongInt; NewPos: DWORD; begin try Offs := dlibMove; {ToDo: 64 Bit variante oder SetFilePointerEx verwenden, achtung Win 95/98!} NewPos := SetFilePointer(FHandle, Offs, nil, dwOrigin); if NewPos = $FFFFFFFF then begin Result := E_FAIL; Exit; end; FPosition := NewPos; Result := S_OK; if libNewPosition <> nil then libNewPosition^ := FPosition; except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd) else raise; end; end; { ------------------------------ } { ---- TGMOverlappedIStream ---- } { ------------------------------ } function GMReadFile(hFile: THandle; pBuffer: Pointer; nNumberOfBytesToRead: LongWord; var lpNumberOfBytesRead: LongWord; lpOverlapped: POverlapped): BOOL; begin Result := ReadFile(hFile, pBuffer, nNumberOfBytesToRead, {$IFDEF JEDIAPI}@{$ENDIF}lpNumberOfBytesRead, lpOverlapped); end; function GMWriteFile(hFile: THandle; pBuffer: Pointer; nNumberOfBytesToWrite: LongWord; var lpNumberOfBytesWritten: LongWord; lpOverlapped: POverlapped): BOOL; begin Result := WriteFile(hFile, pBuffer, nNumberOfBytesToWrite, {$IFDEF JEDIAPI}@{$ENDIF}lpNumberOfBytesWritten, lpOverlapped); end; constructor TGMOverlappedIStream.Create(const AHandle: LongWord; const AMode: LongInt; const AEvAbort: IGMGetHandle; const AName: UnicodeString; const ARefLifeTime: Boolean); begin inherited Create(AHandle, AMode, AName, ARefLifeTime); FEvIOCompleted := TGMEvent.Create(True, False, '', nil, True); FOverlappedIOData.hEvent := FEvIOCompleted.Handle; FWaitHandles[owhIOComple] := FEvIOCompleted.Handle; if AEvAbort <> nil then FWaitHandles[owhAbort] := AEvAbort.Handle; end; procedure TGMOverlappedIStream.FileRWWrapper(pv: Pointer; cb: LongWord; var pcbRead: LongWord; const FileRWFunc: TFileRWFunc); const cOverlappedRWSucces: array [0..1] of PtrInt = (ERROR_SUCCESS, ERROR_IO_PENDING); cCount: array [Boolean] of LongWord = (1, 2); begin if not Assigned(FileRWFunc) then Exit; GMApiCheckObj('ResetEvent', '', GetLastError, ResetEvent(FOverlappedIOData.hEvent), Self); GMAPICheckObjEx('FileRWFunc', '', GetLastError, FileRWFunc(FHandle, pv, cb, pcbRead, @FOverlappedIOData), cOverlappedRWSucces, Self); if GMMsgLoopWaitForMultipleObjects(CCount[FWaitHandles[owhAbort] <> 0], @FWaitHandles, False) = WAIT_OBJECT_0 + Ord(owhAbort) then begin GMApiCheckObj('CancelIO', '', GetLastError, CancelIO(FHandle), Self); raise EGMAbort.Create(RStrOperationCanceled); end; GMApiCheckObj('GetOverlappedResult', '', GetLastError, GetOverlappedResult(FHandle, FOverlappedIOData, pcbRead, True), Self); end; procedure TGMOverlappedIStream.InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); begin FileRWWrapper(pv, cb, pcbRead, GMReadFile); end; procedure TGMOverlappedIStream.InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); begin FileRWWrapper(pv, cb, pcbWritten, GMWriteFile); end; { --------------------------- } { ---- TGMChainedIStream ---- } { --------------------------- } constructor TGMChainedIStream.Create(const AChainedStream: IStream; const ARefLifeTime: Boolean = True); begin Assert(AChainedStream <> nil, 'AChainedStream <> nil'); inherited Create(STGM_READWRITE, '', ARefLifeTime); FChainedStream := AChainedStream; end; // ---- ISequentialStream ---- function TGMChainedIStream.Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; begin Result := FChainedStream.Read(pv, cb, pcbRead); end; function TGMChainedIStream.Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; begin Result := FChainedStream.Write(pv, cb, pcbWritten); end; // ---- IStream ---- function TGMChainedIStream.Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; begin Result := FChainedStream.Seek(dlibMove, dwOrigin, libNewPosition); end; function TGMChainedIStream.SetSize(libNewSize: Int64): HResult; begin Result := FChainedStream.SetSize(libNewSize); end; function TGMChainedIStream.Commit(grfCommitFlags: LongInt): HResult; begin Result := FChainedStream.Commit(grfCommitFlags); end; function TGMChainedIStream.Revert: HResult; begin Result := FChainedStream.Revert; end; function TGMChainedIStream.LockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; begin Result := FChainedStream.LockRegion(libOffset, cb, dwLockType); end; function TGMChainedIStream.UnlockRegion(libOffset: Int64; cb: Int64; dwLockType: LongInt): HResult; begin Result := FChainedStream.UnlockRegion(libOffset, cb, dwLockType); end; function TGMChainedIStream.Stat(out statstg: TStatStg; grfStatFlag: LongInt): HResult; begin Result := FChainedStream.Stat(statstg, grfStatFlag); end; { ----------------------------- } { ---- TGMNotifyingIStream ---- } { ----------------------------- } constructor TGMNotifyingIStream.Create(const AChainedStream: IStream; const ARefLifeTime: Boolean = True); begin inherited Create(AChainedStream, ARefLifeTime); FConnectionPointContainer := TGMConnectionPointContainerImpl.Create([IGMDisconnectFromConnectionPoint]); CreateConnectionPoint(IGMOnProgress); end; destructor TGMNotifyingIStream.Destroy; var PIOwnerDestroy: IGMReleaseReferences; begin GMRequestCPCDisconnect(FConnectionPointContainer); if GMQueryInterface(FConnectionPointContainer, IGMReleaseReferences, PIOwnerDestroy) then PIOwnerDestroy.ReleaseReferences; inherited Destroy; end; procedure TGMNotifyingIStream.CallSinkOnProgress(const NotifySink: IUnknown; const Params: array of OleVariant); var Sink: IGMOnProgress; begin if (Length(Params) > 1) and GMQueryInterface(NotifySink, IGMOnProgress, Sink) then {$IFDEF DELPHI5} try Sink.OnProgress(LongInt(Params[Low(Params)]), FCancel, TGMCalcProgressKind(Params[Low(Params)+1])); except end; {$ELSE} try Sink.OnProgress(Params[Low(Params)], FCancel, TGMCalcProgressKind(Params[Low(Params)+1])); except end; {$ENDIF} end; function TGMNotifyingIStream.OnProgress(const AProgress: Int64): Boolean; begin FCancel := False; GMCpcCallNotifySinksObj(Self, IGMOnProgress, CallSinkOnProgress, True, [LongInt(AProgress)]); Result := not FCancel; end; { ---- ISequentialStream ---- } function TGMNotifyingIStream.Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; var N: LongInt; begin try N := 0; Result := inherited Read(pv, cb, @N); if pcbRead <> nil then pcbRead^ := N; if not GMHrSucceeded(Result) then Exit; Inc(FPosition, LongWord(N)); if not OnProgress(FPosition) then Result := E_ABORT; // Result := GMIStreamReadResult(pcbRead, N = cb) except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd, GM_E_STREAMREAD) else raise; end; end; function TGMNotifyingIStream.Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; var N: LongInt; begin try N := 0; Result := inherited Write(pv, cb, @N); if pcbWritten <> nil then pcbWritten^ := N; if not GMHrSucceeded(Result) then Exit; Inc(FPosition, LongWord(N)); if not OnProgress(FPosition) then Result := E_ABORT; // Result := GMIStreamWriteResult(pcbWritten, N = cb) except on ex: TObject do if FCaptureExceptions then Result := vfGMHrExceptionHandler(ex, cHrPrntWnd, GM_E_STREAMWRITE) else raise; end; end; // ---- IGMCreateConnectionPoint ---- procedure TGMNotifyingIStream.CreateConnectionPoint(const IID: TGUID); var CreateCp: IGMCreateConnectionPoint; begin if GMQueryInterface(FConnectionPointContainer, IGMCreateConnectionPoint, CreateCp) then CreateCp.CreateConnectionPoint(IID); end; // ---- IConnectionPointContainer ---- function TGMNotifyingIStream.EnumConnectionPoints(out Enum: IEnumConnectionPoints): HResult; begin Result := FConnectionPointContainer.EnumConnectionPoints(Enum); end; function TGMNotifyingIStream.FindConnectionPoint(const iid: TGUID; out cp: IConnectionPoint): HResult; begin Result := FConnectionPointContainer.FindConnectionPoint(iid, cp); end; { ---------------------------- } { ---- TGMBufferedIStream ---- } { ---------------------------- } constructor TGMBufferedIStream.Create(const AChainedStream: IStream; const ABufSizeInBytes: Integer; const AName: TGMString; const ARefLifeTime: Boolean); begin inherited Create(STGM_READWRITE, AName, ARefLifeTime); FChainedStream := AChainedStream; SetLength(FAnsiStrBuffer, ABufSizeInBytes); end; destructor TGMBufferedIStream.Destroy; begin try FlushBuffer; except end; // <- nerver raise in destructors! inherited Destroy; end; procedure TGMBufferedIStream.InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); begin if FChainedStream <> nil then GMHrCheckObj(FChainedStream.Read(pv, cb, PLongInt(@pcbRead)), Self, 'InternalRead'); end; procedure TGMBufferedIStream.InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); begin if FChainedStream <> nil then GMHrCheckObj(FChainedStream.Write(pv, cb, PLongInt(@pcbWritten)), Self, 'InternalWrite'); end; //function TGMBufferedIStream.Seek(dlibMove: Int64; dwOrigin: LongInt; libNewPosition: PInt64): HResult; //begin //Result := inherited Seek(dlibMove, dwOrigin, libNewPosition); //end; function TGMBufferedIStream.FillBuffer: HResult; begin if (Length(FAnsiStrBuffer) <= 0) then Result := S_OK else begin Result := inherited Read(PAnsiChar(FAnsiStrBuffer), Length(FAnsiStrBuffer), @FBufDataSize); if GMHrSucceeded(Result) then FBufPos := 0; end; end; function TGMBufferedIStream.Read(pv: Pointer; cb: LongInt; pcbRead: PLongint): HResult; var n: LongInt; begin if (pv = nil) or (FChainedStream = nil) then begin Result := STG_E_INVALIDPOINTER; if pcbRead <> nil then pcbRead^ := 0; Exit; end; if Length(FAnsiStrBuffer) <= 0 then begin Result := inherited Read(pv, cb, pcbRead); Exit; end; Result := S_OK; repeat n := Min(FBufDataSize - FBufPos, cb); if n > 0 then begin System.Move(FAnsiStrBuffer[FBufPos+1], pv^, n); Dec(cb, n); if cb > 0 then pv := GMAddPtr(pv, n); Inc(FBufPos, n); if pcbRead <> nil then Inc(pcbRead^, n); end; if FBufPos >= FBufDataSize then if FBufDataSize = Length(FAnsiStrBuffer) then Result := FillBuffer else Break; until (cb = 0) or (Result < 0); end; function TGMBufferedIStream.FlushBuffer: HResult; var written: LongInt; begin if (Length(FAnsiStrBuffer) <= 0) or (FBufWriteCount <= 0) then Result := S_OK else begin written := 0; Result := inherited Write(PAnsiChar(FAnsiStrBuffer), FBufWriteCount, @written); if written <> FBufWriteCount then raise EGMException.IntfError(GMFormat(RStrWriteErrorFmt, [FBufWriteCount, written]), Self, 'FlushBuffer'); if Result = S_OK then FBufWriteCount := 0; end; end; function TGMBufferedIStream.Write(pv: Pointer; cb: LongInt; pcbWritten: PLongint): HResult; var n: LongInt; begin if (pv = nil) or (FChainedStream = nil) then begin Result := STG_E_INVALIDPOINTER; if pcbWritten <> nil then pcbWritten^ := 0; Exit; end; if Length(FAnsiStrBuffer) <= 0 then begin Result := inherited Write(pv, cb, pcbWritten); Exit; end; Result := S_OK; repeat n := Min(Length(FAnsiStrBuffer) - FBufWriteCount, cb); if n > 0 then begin System.Move(pv^, FAnsiStrBuffer[FBufWriteCount+1], n); Dec(cb, n); if cb > 0 then pv := GMAddPtr(pv, n); Inc(FBufWriteCount, n); if pcbWritten <> nil then Inc(pcbWritten^, n); end; if FBufWriteCount >= Length(FAnsiStrBuffer) then Result := FlushBuffer; until (cb = 0) or (Result < 0); FBufPos := FBufWriteCount; FBufDataSize := Max(FBufDataSize, FBufPos); end; { ------------------------------ } { ---- TGMConnectableObject ---- } { ------------------------------ } constructor TGMConnectableObject.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FCallEventsWhenDisabled := cDfltCallEventsWhenDisabled; FConnectionPointContainer := TGMConnectionPointContainerImpl.Create([IGMDisconnectFromConnectionPoint]); FObjectConnectedTo := TGMObjInterfaceConnector.Create(Self, [], []); end; destructor TGMConnectableObject.Destroy; var PIOwnerDestroy: IGMReleaseReferences; begin GMRequestCPCDisconnect(ConnectionPointContainer); if GMQueryInterface(ConnectionPointContainer, IGMReleaseReferences, PIOwnerDestroy) then PIOwnerDestroy.ReleaseReferences; GMFreeAndNil(FObjectConnectedTo); inherited Destroy; end; function TGMConnectableObject.GetPropertyIntf(const PropertyName: TGMString; const IID: TGUID; out Intf): HResult; begin Result := E_NOTIMPL; end; function TGMConnectableObject.DoCallEvents: Boolean; begin Result := CallEventsWhenDisabled or (NotifyDisableCount <= 0); end; function TGMConnectableObject.DoNotifySink(const NotifySink: IUnknown; const IID: TGUID; out Intf): Boolean; //var PIAskBoolean: IGMAskBoolean; begin Result := GMDoNotifySink(NotifyDisableCount = 0, NotifySink, IID, Intf); //if (NotifySink = nil) or (NotifySink.QueryInterface(IID, Intf) <> S_OK) then Result := False else //Result := (NotifyDisableCount <= 0) or ((NotifySink.QueryInterface(IGMAskBoolean, PIAskBoolean) = S_OK) and (PIAskBoolean.AskBoolean(Ord(bvAlwaysNotify)) = Ord(barTrue))); end; procedure TGMConnectableObject.InternalClose; begin GMCpcCallNotifySinks(Self, GUID_NULL, GMCallSinkClose, NotifyDisableCount = 0, []); end; procedure TGMConnectableObject.ConnectInterface(const Container: TObject; const IID: TGUID; var Cookie: LongInt; const CallingRoutineName: TGMString = cDfltRoutineName); var PIUnknown: IUnknown; RtnName: TGMString; begin if Container <> nil then begin if CallingRoutineName <> cDfltRoutineName then RtnName := CallingRoutineName else RtnName := {$I %CurrentRoutine%}; GMCheckGetInterface(Container, IUnknown, PIUnknown, RtnName); GMInterfaceConnect(Self, PIUnknown, IID, Cookie, RtnName); end; end; procedure TGMConnectableObject.ConnectInterface(const Container: IUnknown; const IID: TGUID; var Cookie: LongInt; const CallingRoutineName: TGMString = cDfltRoutineName); var RtnName: TGMString; begin if CallingRoutineName <> cDfltRoutineName then RtnName := CallingRoutineName else RtnName := {$I %CurrentRoutine%}; GMInterfaceConnect(Self, Container, IID, Cookie, RtnName); end; procedure TGMConnectableObject.DisconnectInterface(const Container: TObject; const IID: TGUID; var Cookie: LongInt); var PIUnknown: IUnknown; begin if (Container <> nil) and (Cookie <> cInvalidCPCookie) then begin GMCheckGetInterface(Container, IUnknown, PIUnknown, {$I %CurrentRoutine%}); DisconnectInterface(PIUnknown, IID, Cookie); end; end; procedure TGMConnectableObject.DisconnectInterface(const Container: IUnknown; const IID: TGUID; var Cookie: LongInt); begin GMInterfaceDisconnect(Container, IID, Cookie); end; procedure TGMConnectableObject.NotifyConnectedObjectsOnFirstDisable(const NotificationOnFirstDisable: LongInt = Ord(rgNone)); begin // overridden in derived class end; procedure TGMConnectableObject.NotifyConnectedObjectsOnReEnable(const NotificationOnReEnable: LongInt = Ord(rgNone)); begin // overridden in derived class end; // ---- IGMCreateConnectionPoint ---- procedure TGMConnectableObject.CreateConnectionPoint(const IID: TGUID); var CreateCp: IGMCreateConnectionPoint; begin if GMQueryInterface(ConnectionPointContainer, IGMCreateConnectionPoint, CreateCp) then CreateCp.CreateConnectionPoint(IID); end; // ---- IConnectionPointContainer ---- function TGMConnectableObject.EnumConnectionPoints(out Enum: IEnumConnectionPoints): HResult; begin Result := ConnectionPointContainer.EnumConnectionPoints(Enum); end; function TGMConnectableObject.FindConnectionPoint(const iid: TGUID; out cp: IConnectionPoint): HResult; begin Result := ConnectionPointContainer.FindConnectionPoint(iid, cp); end; // ---- IGMEnableNotifications ---- function TGMConnectableObject.GetNotifyDisableCount: LongInt; begin Result := FNotifyDisableCount; end; function TGMConnectableObject.DisableNotifications(const NotificationOnFirstDisable: LongInt = Ord(rgNone)): LongInt; begin if FNotifyDisableCount = 0 then try NotifyConnectedObjectsOnFirstDisable(NotificationOnFirstDisable); except end; Inc(FNotifyDisableCount); Result := FNotifyDisableCount; end; function TGMConnectableObject.EnableNotifications(const NotificationOnReEnable: LongInt = Ord(rgNone)): LongInt; begin FNotifyDisableCount := Max(0, FNotifyDisableCount-1); Result := FNotifyDisableCount; if FNotifyDisableCount = 0 then NotifyConnectedObjectsOnReEnable(NotificationOnReEnable); end; { --------------------------------- } { ---- TGMActivationProperties ---- } { --------------------------------- } constructor TGMActivationProperties.Create(const AOwner: TObject); begin inherited Create; FOwner := AOwner; FActiveStored := cDfltActiveStored; end; function TGMActivationProperties.GetActive: Boolean; var PIActive: IGMGetActive; begin GMCheckGetInterface(Owner, IGMGetActive, PIActive, {$I %CurrentRoutine%}); Result := PIActive.Active; end; procedure TGMActivationProperties.SetActive(Value: Boolean); var PIActive: IGMGetSetActive; begin GMCheckGetInterface(Owner, IGMGetSetActive, PIActive, {$I %CurrentRoutine%}); PIActive.Active := Value; end; function TGMActivationProperties.IsActiveStored: Boolean; begin Result := StoreActive and GetActive; end; { --------------------------------------- } { ---- TGMActivationStoredProperties ---- } { --------------------------------------- } constructor TGMActivationStoredProperties.Create(const AOwner: TObject); begin inherited Create(AOwner); FActiveStored := cDfltActivePersists; end; { ------------------------------ } { ---- TGMActivatableObject ---- } { ------------------------------ } constructor TGMActivatableObject.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FActivationProperties := ActivationPropertyCreateClass.Create(Self); CreateConnectionPoint(IGMActiveChangeNotifications); end; destructor TGMActivatableObject.Destroy; begin if Active and CloseOnDestroy then Close; GMFreeAndNil(FActivationProperties); inherited Destroy; end; function TGMActivatableObject.ActivationPropertyCreateClass: TGMActivationPropertyClass; begin Result := TGMActivationProperties; end; function TGMActivatableObject.CloseOnDestroy: Boolean; begin Result := True; end; procedure TGMActivatableObject.Open; begin if not Active then Active := True; end; procedure TGMActivatableObject.Close; begin if Active then Active := False; end; procedure TGMActivatableObject.CheckIsActive(const MemberName: TGMString); begin GMCheckObjIsActive(Self, MemberName); end; procedure TGMActivatableObject.CheckIsInactive(const MemberName: TGMString); begin if Active then GMCheckObjIsInActive(Self, MemberName); end; procedure TGMActivatableObject.SetActivationProperties(const Value: TGMActivationProperties); begin Assert(False); end; // ---- CPC Notifications ---- procedure TGMActivatableObject.NotifyBeforeActiveChange(const NewActive: Boolean); begin if Assigned(OnBeforeActiveChange) and DoCallEvents then OnBeforeActiveChange(Self, NewActive); GMCpcCallNotifySinks(Self, IGMActiveChangeNotifications, GMCallSinkBeforeActiveChange, NotifyDisableCount = 0, [NewActive]); end; procedure TGMActivatableObject.NotifyAfterActiveChange(const NewActive: Boolean); begin GMCpcCallNotifySinks(Self, IGMActiveChangeNotifications, GMCallSinkAfterActiveChange, NotifyDisableCount = 0, [NewActive]); if Assigned(OnAfterActiveChange) and DoCallEvents then try OnAfterActiveChange(Self, NewActive); except end; end; { ---- Classic Notifications ---- } procedure TGMActivatableObject.DoBeforeOpen; begin end; procedure TGMActivatableObject.DoAfterOpen; begin end; procedure TGMActivatableObject.DoBeforeClose; begin end; procedure TGMActivatableObject.DoAfterClose; begin end; procedure TGMActivatableObject.SetActive(const Value: Boolean); begin if Value then begin if not Active then begin //CheckFixups('SetActive'); NotifyBeforeActiveChange(Value); DoBeforeOpen; try InternalOpen; except InternalClose; raise; end; DoAfterOpen; NotifyAfterActiveChange(Value); end; end else begin if Active then begin NotifyBeforeActiveChange(Value); DoBeforeClose; InternalClose; DoAfterClose; NotifyAfterActiveChange(Value); end; end; end; { ------------------------------ } { ---- TGMHandleActivateObj ---- } { ------------------------------ } function TGMHandleActivateObj.GetActive: Boolean; begin Result := GetHandleAllocated; end; function TGMHandleActivateObj.GetHandle: THandle; begin Result := FHandle; end; function TGMHandleActivateObj.GetHandleAllocated: Boolean; begin Result := FHandle <> 0; end; procedure TGMHandleActivateObj.InternalOpen; begin if not GetHandleAllocated then AllocHandle; end; procedure TGMHandleActivateObj.InternalClose; begin inherited InternalClose; if GetHandleAllocated then ReleaseHandle; end; { ---------------------- } { ---- TGMClipboard ---- } { ---------------------- } constructor TGMClipboard.Create(const AWnd: HWnd; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); GMAPICheckObj('OpenClipboard', '', GetLastError, OpenClipboard(AWnd), Self); end; destructor TGMClipboard.Destroy; begin if not CloseClipboard then ; // <- dont check, never raise in destructors inherited Destroy; end; function TGMClipboard.Obj: TGMClipboard; begin Result := Self; end; procedure TGMClipboard.SetEmpty; begin GMAPICheckObj('EmptyClipboard', '', GetLastError, EmptyClipboard, Self); end; function TGMClipboard.GetAsHandle(const AFormat: UINT): THandle; begin Result := GetClipboardData(AFormat); GMAPICheckObj('GetClipboardData', '', GetLastError, Result <> 0, Self); end; procedure TGMClipboard.SetAsHandle(const AFormat: UINT; const AValue: THandle; const ASetEmptyBefore: Boolean); begin if ASetEmptyBefore then SetEmpty; GMAPICheckObj('SetClipboardData', '', GetLastError, SetClipboardData(AFormat, AValue) <> 0, Self); end; procedure TGMClipboard.ReplaceByHandle(const AFormat: UINT; const AValue: THandle); begin SetAsHandle(AFormat, AValue, True); end; procedure TGMClipboard.PasteToLockBytes(const AFormat: UINT; const LockBytes: ILockBytes); var HClpBrd: THandle; GlobalBuf: IGMMemoryBuffer; PIHandle: IGMGetSetHandle; begin if LockBytes = nil then Exit; HClpBrd := AsHandle[AFormat]; GlobalBuf := TGMGlobalMemoryBuffer.Create(nil, 0, 1, GMEM_MOVEABLE, False, False); GMCheckQueryInterface(GlobalBuf, IGMGetSetHandle, PIHandle, {$I %CurrentRoutine%}); PIHandle.Handle := HClpBrd; GMLockByteSafeWriteAt(LockBytes, 0, GlobalBuf.Obj.Memory, GlobalBuf.Obj.SizeInBytes, {$I %CurrentRoutine%}); end; function TGMClipboard.GetAsLockBytes(const AFormat: UINT): ILockBytes; begin Result := TGMMemoryLockBytes.Create; PasteToLockBytes(AFormat, Result); end; procedure TGMClipboard.SetAsLockBytes(const AFormat: UINT; const AValue: ILockBytes; const ASetEmptyBefore: Boolean); var GlobalBuf: IGMMemoryBuffer; PIHandle: IGMGetHandle; begin if AValue = nil then Exit; GlobalBuf := TGMGlobalMemoryBuffer.Create(nil, GMLockBytesize(AValue), 1, GMEM_MOVEABLE, False, False); try GMLockByteSafeReadAt(AValue, 0, GlobalBuf.Obj.Memory, GMLockBytesize(AValue), {$I %CurrentRoutine%}); GMCheckQueryInterface(GlobalBuf, IGMGetHandle, PIHandle, {$I %CurrentRoutine%}); SetAsHandle(AFormat, PIHandle.Handle, ASetEmptyBefore); except GlobalBuf.Obj.FreeMemory; raise; end; end; procedure TGMClipboard.ReplaceByLockBytes(const AFormat: UINT; const AValue: ILockBytes); begin SetAsLockBytes(AFormat, AValue, True); end; function TGMClipboard.GetAsText: TGMString; var LockBytes: ILockBytes; begin LockBytes := AsLockBytes[{$IFDEF UNICODE}CF_UNICODETEXT{$ELSE}CF_TEXT{$ENDIF}]; SetLength(Result, (GMLockByteSize(LockBytes) - SizeOf(TGMChar)) div SizeOf(TGMChar)); if Length(Result) = 0 then Exit; GMLockByteSafeReadAt(LockBytes, 0, PGMChar(Result), (Length(Result)+1) * SizeOf(TGMChar), {$I %CurrentRoutine%}); //while (Length(Result) > 0) and (Result[Length(Result)] = #0) do System.Delete(Result, Length(Result), 1); end; procedure TGMClipboard.SetAsText(const AValue: TGMString; const ASetEmptyBefore: Boolean); var LockBytes: ILockBytes; begin LockBytes := TGMMemoryLockBytes.Create; GMLockByteSafeWriteAt(LockBytes, 0, PGMChar(AValue), (Length(AValue)+1) * SizeOf(TGMChar), {$I %CurrentRoutine%}); SetAsLockBytes({$IFDEF UNICODE}CF_UNICODETEXT{$ELSE}CF_TEXT{$ENDIF}, LockBytes, ASetEmptyBefore); end; procedure TGMClipboard.ReplaceByText(const AValue: TGMString); begin SetAsText(AValue, True); end; //function TGMClipboard.GetAsIStream: IStream; //begin //end; // //procedure TGMClipboard.SetAsIStream(const Value: IStream); //begin //end; { ---------------------------- } { ---- Message Processing ---- } { ---------------------------- } function GMHotKeyRec(const AFlags: Byte; const AKey, ACommand: Word): TAccel; // Virtual key codes: // https://docs.microsoft.com/en-us/windows/desktop/inputdev/virtual-key-codes begin REsult.fVirt := AFlags; REsult.key := AKey; Result.cmd := ACommand; end; function GMTranslateAndDispatchMsg(var AMsg: TMsg): LRESULT; begin if (vGMKeyAcceleratorTable <> nil) and (vGMKeyAcceleratorTable.Handle <> 0) and (TranslateAccelerator(vGMKeyAcceleratorTargetWnd, vGMKeyAcceleratorTable.Handle, {$IFDEF JEDIAPI}@{$ENDIF}AMsg) <> 0) then Result := 0 else begin TranslateMessage(AMsg); Result := DispatchMessage(AMsg); end; end; procedure GMProcessAllMessages; var Msg: TMsg; begin {ToDo: Skip WM_ENDSESSION, WM_QUIT, WMCLOSE, WM_QUERYENDSESSION too?} {ToDo: Note: Split in two msg-loops changes the order of msg processing!} // Don't eat UM_DONEMODAL GMMessages! They are needed to unwind ModalMessageLoop calls! //while PeekMessage(Msg, 0, 0, UM_DONEMODAL-1, PM_REMOVE) do GMTranslateAndDispatchMsg(Msg); //while PeekMessage(Msg, 0, UM_DONEMODAL+1, $FFFFFFFF, PM_REMOVE) do GMTranslateAndDispatchMsg(Msg); while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do GMTranslateAndDispatchMsg(Msg); end; procedure GMProcessMessages(const AMessages: array of LongInt); var Msg: TMsg; i: LongInt; begin if Length(AMessages) = 0 then GMProcessAllMessages else for i:=Low(AMessages) to High(AMessages) do while PeekMessage(Msg, 0, AMessages[i], AMessages[i], PM_REMOVE) do GMTranslateAndDispatchMsg(Msg); end; function GMMsgLoopWaitForMultipleObjects(const AHandleCount: DWORD; const AHandles: Pointer; const AProcessMessages: Boolean; const AWaitTimeoutMilliSec: DWORD; const AWaitForAll: BOOL): DWORD; //type RRepeatMsg = record hwnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM; end; //const cWakeMask: array [Boolean] of DWORD = (cMsgAwakeByAll and not (QS_KEY or QS_MOUSEBUTTON or QS_HOTKEY), cMsgAwakeByAll); //const cWakeMask: array [Boolean] of DWORD = (0, cMsgAwakeByAll); // QS_PAINT or QS_ALLPOSTMESSAGE or QS_SENDMESSAGE or QS_POSTMESSAGE or QS_TIMER var wakeMask: DWORD; // pendingMessages: array of RRepeatMsg; i: LongInt; //procedure CaptureDoneModalMessages; //var Msg: TMsg; //begin // // Not consuming UM_DONEMODAL GMMessages will keep MsgWaitForMultipleObjects directing us to // // continue processing messages, never releasing us, even if other wait handles have been signaled. // // Peeking them with PM_NOREMOVE doesnt seem to mark them as seen by MsgWaitForMultipleObjects to release us. // // So we consume and save them here, and post them again after being released later. // while PeekMessage(Msg, 0, UM_DONEMODAL, UM_DONEMODAL, PM_REMOVE) do // begin // SetLength(pendingMessages, Length(pendingMessages)+1); // pendingMessages[High(pendingMessages)].hwnd := Msg.hwnd; // pendingMessages[High(pendingMessages)].msg := Msg.message; // pendingMessages[High(pendingMessages)].wParam := Msg.wParam; // pendingMessages[High(pendingMessages)].lParam := Msg.lParam; // end; //end; //procedure ProcessMessagesWhileWaiting; //var Msg: TMsg; //begin // {#if (WINVER >= 0x0500) // # define PM_QS_INPUT (QS_INPUT << 16) // # define PM_QS_POSTMESSAGE ((QS_POSTMESSAGE|QS_HOTKEY|QS_TIMER) << 16) // # define PM_QS_PAINT (QS_PAINT << 16) // # define PM_QS_SENDMESSAGE (QS_SENDMESSAGE << 16) // #endif} // // // // // MsgWaitForMultipleObjects won't release the waiting thread if not all/most GMMessages // // in the message queue have ebeen marked old. Even if the wait handle(s) have been signaled. // // So Peek all GMMessages, even if not all of them will be dispatched. Peeking a message will // // mark it old even if not removed from the message queue. // // // // Only peek unconsidered GMMessages here instead of consuming them! // // // if AProcessMessages then begin GMProcessAllMessages; CaptureDoneModalMessages; end else // //while PeekMessage(Msg, 0, 0, 0, PM_REMOVE or PM_QS_PAINT or PM_QS_POSTMESSAGE or PM_QS_SENDMESSAGE or PM_QS_INPUT) do GMTranslateAndDispatchMsg(Msg); // begin // // always process WM_QUIT GMMessages // if wakeMask <> 0 then while PeekMessage(Msg, 0, 0, 0, PM_REMOVE or (wakeMask shl 16)) do GMTranslateAndDispatchMsg(Msg); // while PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) do ; // <- mark them as seen by MsgWaitForMultipleObjects // end; // //if GMIsOneOfIntegers(Msg.message, vAliveMessages) then GMTranslateAndDispatchMsg(Msg); // //if Msg.message in vAliveMessages then GMTranslateAndDispatchMsg(Msg); //end; begin if AHandles = nil then begin Result := WAIT_OBJECT_0 + AHandleCount; Exit; end; if not AProcessMessages then case AHandleCount of 1: begin Result := WaitForSingleObject(PHandle(AHandles)^, AWaitTimeoutMilliSec); GMApiCheckObj('WaitForSingleObject', '', GetLastError, Result <> WAIT_FAILED); end; else begin Result := WaitForMultipleObjects(AHandleCount, AHandles, AWaitForAll, AWaitTimeoutMilliSec); GMApiCheckObj('WaitForMultipleObjects', '', GetLastError, Result <> WAIT_FAILED); end; end else begin wakeMask := cMsgAwakeByAll; // cWakeMask[AProcessMessages]; repeat Result := MsgWaitForMultipleObjects(AHandleCount, AHandles{$IFNDEF JEDIAPI}^{$ENDIF}, AWaitForAll, AWaitTimeoutMilliSec, wakeMask); GMApiCheckObj('MsgWaitForMultipleObjects', '', GetLastError, Result <> WAIT_FAILED); // Stay inside wait loop on Exceptions during message handling, so handle them right here! if Result = WAIT_OBJECT_0 + AHandleCount then try GMProcessAllMessages; //CaptureDoneModalMessages; except on ex: TObject do vfGMHrExceptionHandler(ex, cDfltPrntWnd); end; until Result <> WAIT_OBJECT_0 + AHandleCount; end; //for i:=Low(pendingMessages) to High(pendingMessages) do with pendingMessages[i] do PostMessage(hwnd, msg, wParam, lParam); end; function GMExecProcess(const ACmdLine: TGMString; const AProcessFlags: DWORD; const AWaitForTermination: Boolean; const AUserToken: THandle; const AWaitForInputReady: Boolean): DWORD; var processInfo: TProcessInformation; startupInfo: TStartupInfo; rtnName: TGMString; //ExitCode: DWORD; begin //Result := True; Result := 0; GMTrace(ACmdLine, tpExecute); //FillByte(startupInfo, SizeOf(startupInfo), 0); startupInfo := Default(TStartupInfo); //FillByte(processInfo, SizeOf(processInfo), 0); processInfo := Default(TProcessInformation); startupInfo.cb := SizeOf(startupInfo); startupInfo.dwFlags := STARTF_FORCEONFEEDBACK; if AUserToken = 0 then begin rtnName := 'CreateProcess("'+ACmdLine+'")'; GMAPICheckObj(rtnName, '', GetLastError, CreateProcess(nil, PGMChar(ACmdLine), nil, nil, False, AProcessFlags, nil, nil, startupInfo, processInfo)); end else begin rtnName := 'CreateProcessAsUser("'+ACmdLine+'")'; GMAPICheckObj(rtnName, '', GetLastError, CreateProcessAsUser(AUserToken, nil, PGMChar(ACmdLine), nil, nil, False, AProcessFlags, nil, nil, {$IFNDEF JEDIAPI}{$IFDEF FPC}@{$ENDIF}{$ENDIF}startupInfo, {$IFNDEF JEDIAPI}{$IFDEF FPC}@{$ENDIF}{$ENDIF}processInfo)); end; //GMAPICheckObj(CreateProcess(nil, PGMChar(ACmdLine), nil, nil, False, AProcessFlags, nil, nil, startupInfo, processInfo), 'CreateProcess'); try if AWaitForTermination or AWaitForInputReady then WaitForInputIdle(processInfo.hProcess, INFINITE); if AWaitForTermination then begin GMMsgLoopWaitForMultipleObjects(1, @processInfo.hProcess, False); GMAPICheckObj('GetExitCodeProcess', '', GetLastError, GetExitCodeProcess(processInfo.hProcess, Result)); end; finally CloseHandle(processInfo.hThread); CloseHandle(processInfo.hProcess); end; end; { ---------------------------------- } { ---- TGMObjInterfaceConnector ---- } { ---------------------------------- } function GMIntfConnectData(const IID: TGUID; const Required: Boolean = cDfltIIDRequired): TGMIntfConnectDataRec; begin Result.IID := IID; Result.Cookie := cInvalidCPCookie; Result.Required := Required; end; constructor TGMObjInterfaceConnector.Create(const AOwner: TObject; const ANeededInterfaceIDs: array of TGUID; const AIntfIDsToConnect: array of TGMIntfConnectDataRec); begin inherited Create; FOwner := AOwner; FAlwaysNotify := cDfltAlwaysNotify; FObjectToBeConnected := Self; AddNeededIntfIDs(ANeededInterfaceIDs); AddIntfIDToConnect(IGMDisconnectFromConnectionPoint, True); AddIntfIDsToConnect(AIntfIDsToConnect); end; destructor TGMObjInterfaceConnector.Destroy; begin DisconnectAllInterfaces(InterfaceSource); FInterfaceSource := nil; //FInterfaceSourceObject := nil; inherited Destroy; end; function TGMObjInterfaceConnector.IsConnected: Boolean; begin Result := InterfaceSource <> nil; end; procedure TGMObjInterfaceConnector.CheckNotConnected(AMethodName: TGMString); begin if AMethodName = '' then AMethodName := {$I %CurrentRoutine%}; if IsConnected then raise EGMException.ObjError(RStrIntfListCantChange, Self, AMethodName); end; procedure TGMObjInterfaceConnector.AddNeededIntfID(const IID: TGUID); var i: LongInt; Found: Boolean; begin CheckNotConnected({$I %CurrentRoutine%}); Found := False; for i:=Low(NeededInterfaceIDs) to High(NeededInterfaceIDs) do if IsEqualGuid(IID, NeededInterfaceIDs[i]) then begin Found := True; Break; end; if not Found then begin SetLength(FNeededInterfaceIDs, Length(FNeededInterfaceIDs) + 1); NeededInterfaceIDs[High(NeededInterfaceIDs)] := IID; end; end; procedure TGMObjInterfaceConnector.AddNeededIntfIDs(const IIDs: array of TGUID); var i: LongInt; begin for i:=Low(IIDs) to High(IIDs) do AddNeededIntfID(IIDs[i]); end; procedure TGMObjInterfaceConnector.AddIntfIDToConnect(const IID: TGUID; const Required: Boolean = cDfltIIDRequired); var i: LongInt; Found: Boolean; begin CheckNotConnected({$I %CurrentRoutine%}); Found := False; for i:=Low(IntfIDsToConnect) to High(IntfIDsToConnect) do if IsEqualGuid(IID, IntfIDsToConnect[i].IID) then begin Found := True; Break; end; if not Found then begin SetLength(FIntfIDsToConnect, Length(FIntfIDsToConnect) + 1); IntfIDsToConnect[High(IntfIDsToConnect)] := GMIntfConnectData(IID, Required); end; end; procedure TGMObjInterfaceConnector.AddIntfIDsToConnect(const AIntfIDsToConnect: array of TGMIntfConnectDataRec); var i: LongInt; begin for i:=Low(AIntfIDsToConnect) to High(AIntfIDsToConnect) do AddIntfIDToConnect(AIntfIDsToConnect[i].IID, AIntfIDsToConnect[i].Required); end; function TGMObjInterfaceConnector.GetSourceIntf(const IID: TGUID; out Intf): Boolean; begin Result := GMQueryInterface(InterfaceSource, IID, Intf); end; function TGMObjInterfaceConnector.GetPropertyIntf(const PropertyName: TGMString; const IID: TGUID; out Intf): HResult; begin Result := GMGetPropIntfFromIntf(InterfaceSource, PropertyName, IID, Intf); end; procedure TGMObjInterfaceConnector.CheckInterfaceCanBeConnected(const Intf: IUnknown); begin if Intf = nil then Exit; GMCheckAllInterfacesSupported(Intf, NeededInterfaceIDs, {$I %CurrentRoutine%}); if Assigned(OnCheckIntfCanBeConnected) then OnCheckIntfCanBeConnected(Intf); end; function TGMObjInterfaceConnector.InterfaceCanBeConnected(const Intf: IUnknown): Boolean; begin Result := True; try CheckInterfaceCanBeConnected(Intf); except Result := False; end; end; function TGMObjInterfaceConnector.SourceState: LongInt; var PIState: IGMGetState; begin if GetSourceIntf(IGMGetState, PIState) then Result := PIState.State else Result := CGMUnknownState; end; function TGMObjInterfaceConnector.AskBoolean(const ValueId: LongInt): LongInt; begin case ValueId of Ord(bvAlwaysNotify): Result := GMBooleanAskResult(AlwaysNotify); else Result := Ord(barUnknown); end; end; function TGMObjInterfaceConnector.SourceIsActive: Boolean; begin Result := GMIntfIsActive(InterfaceSource); end; procedure TGMObjInterfaceConnector.ConnectInterface(const Container: IUnknown; var GMIntfConnectData: TGMIntfConnectDataRec; const ARoutineName: TGMString = cDfltRoutineName); var RtnName: TGMString; begin if GMIntfConnectData.Required then begin if ARoutineName <> cDfltRoutineName then RtnName := ARoutineName else RtnName := {$I %CurrentRoutine%}; GMInterfaceConnect(ObjectToBeConnected, Container, GMIntfConnectData.IID, GMIntfConnectData.Cookie, RtnName); end else GMQuietInterfaceConnect(ObjectToBeConnected, Container, GMIntfConnectData.IID, GMIntfConnectData.Cookie); end; procedure TGMObjInterfaceConnector.DisconnectInterface(const Container: IUnknown; const IID: TGUID; var Cookie: LongInt); begin GMInterfaceDisconnect(Container, IID, Cookie); end; procedure TGMObjInterfaceConnector.ConnectAllInterfaces(const Container: IUnknown); var i: LongInt; begin if Container <> nil then for i:=Low(IntfIDsToConnect) to High(IntfIDsToConnect) do ConnectInterface(Container, IntfIDsToConnect[i], {$I %CurrentRoutine%}); end; procedure TGMObjInterfaceConnector.DisconnectAllInterfaces(const Container: IUnknown); var i: LongInt; begin if Container <> nil then for i:=Low(IntfIDsToConnect) to High(IntfIDsToConnect) do if IntfIDsToConnect[i].Cookie <> cInvalidCPCookie then DisconnectInterface(Container, IntfIDsToConnect[i].IID, IntfIDsToConnect[i].Cookie); end; function TGMObjInterfaceConnector.GetInterfaceSource: IUnknown; begin Result := FInterfaceSource; end; procedure TGMObjInterfaceConnector.SetInterfaceSource(const AValue: IUnknown); var OldSource: IUnknown; begin if AValue = InterfaceSource then Exit; CheckInterfaceCanBeConnected(AValue); if Assigned(OnBeforeIntfSourceChange) then OnBeforeIntfSourceChange(FInterfaceSource, AValue); DisconnectAllInterfaces(InterfaceSource); try ConnectAllInterfaces(AValue); except try DisconnectAllInterfaces(AValue); ConnectAllInterfaces(InterfaceSource); except end; raise; end; OldSource := InterfaceSource; FInterfaceSource := AValue; if Assigned(OnAfterIntfSourceChange) then try OnAfterIntfSourceChange(OldSource, AValue); except end; //FInterfaceSourceObject := nil; // <- important! end; //procedure TGMObjInterfaceConnector.SetInterfaceSourceObject(const Value: TObject); //var PIUnknown: IUnknown; OldSource: TObject; //begin //if Value = FInterfaceSourceObject then Exit; // if Assigned(OnBeforeIntfSourceObjChange) then OnBeforeIntfSourceObjChange(FInterfaceSourceObject, Value); // OldSource := FInterfaceSourceObject; // <- SetInterfaceSource will clear FInterfaceSourceObject // if Value = nil then SetInterfaceSource(nil) else // begin // GMCheckGetInterface(Value, IUnknown, PIUnknown, {$I %CurrentRoutine%}); // SetInterfaceSource(PIUnknown); // end; // FInterfaceSourceObject := Value; // if Assigned(OnAfterIntfSourceObjChange) then try OnAfterIntfSourceObjChange(OldSource, Value); except end; //end; procedure TGMObjInterfaceConnector.AssignFromObj(const Source: TObject); begin if Source is TGMObjInterfaceConnector then begin FNeededInterfaceIDs := TGMObjInterfaceConnector(Source).NeededInterfaceIDs; FIntfIDsToConnect := TGMObjInterfaceConnector(Source).IntfIDsToConnect; InterfaceSource := TGMObjInterfaceConnector(Source).InterfaceSource; // InterfaceSourceObject := TGMObjInterfaceConnector(Source).InterfaceSourceObject; // <- sets InterfaceSource too end; end; { ---- IGMGetSetActive ---- } function TGMObjInterfaceConnector.GetActive: Boolean; begin Result := GMObjIsActive(Owner); end; procedure TGMObjInterfaceConnector.SetActive(const Value: Boolean); var PIActive: IGMGetSetActive; begin // Better dont force the Owner to support Activation if GMGetInterface(Owner, IGMGetSetActive, PIActive) then PIActive.Active := Value; //GMSetObjActive(Owner, Value, 'TGMObjInterfaceConnector.SetActive'); end; { ---- IGMDisconnectFromConnectionPoint ---- } procedure TGMObjInterfaceConnector.DisconnectFromConnectionPoint(const ConnectionPointContainer: IUnknown; const IID: TGUID; const Cookie: LongInt); begin InterfaceSource := nil; end; { ---------------------------------- } { ---- TGMActivatableIntfSource ---- } { ---------------------------------- } constructor TGMActivatableIntfSource.Create(const AOwner: TObject; const ANeededInterfaceIDs: array of TGUID; const AIntfIDsToConnect: array of TGMIntfConnectDataRec); begin inherited Create(AOwner, ANeededInterfaceIDs, AIntfIDsToConnect); AddIntfIDToConnect(IGMActiveChangeNotifications, True); AddNeededIntfID(IGMGetSetActive); end; procedure TGMActivatableIntfSource.BeforeActiveChange(const NewActive: Boolean); begin if Assigned(OnBeforeActiveChange) then OnBeforeActiveChange(NewActive); end; procedure TGMActivatableIntfSource.AfterActiveChange(const NewActive: Boolean); begin if Assigned(OnAfterActiveChange) then OnAfterActiveChange(NewActive); end; { --------------------------------- } { ---- TGMExceptionInformation ---- } { --------------------------------- } constructor TGMExceptionInformation.Create(const ARefLifeTime: Boolean; const ACaptureCallStack: Boolean; const AMessage: TGMString; const AExceptionClassName: TGMString; const AExceptAddress: Pointer; const ARaisorName: TGMString; const ARaisorClassName: TGMString; const ARoutineName: TGMString; const ASeverityLevel: TGMSeverityLevel; const AHelpContext: LongInt; const AHRCode: HResult); begin inherited Create(ARefLifeTime); FMessage := AMessage; FExceptionClassName := AExceptionClassName; FExceptAddress := AExceptAddress; FRaisorName := ARaisorName; FRaisorClassName := ARaisorClassName; FRoutineName := ARoutineName; FSeverityLevel := ASeverityLevel; FHelpContext := AHelpContext; FHrCode := AHRCode; FCaptureCallStack := ACaptureCallStack; FPresentToUI := Ord(barUnknown); end; constructor TGMExceptionInformation.CreateFromObj(const ASource: TObject; const ARefLifeTime, ACaptureCallStack: Boolean); begin Create(ARefLifeTime, ACaptureCallStack, RStrNoExceptInfo, '', ExceptAddr); if ASource <> nil then AssignFromObj(ASource); end; constructor TGMExceptionInformation.CreateFromIntf(const ASource: IUnknown; const ARefLifeTime, ACaptureCallStack: Boolean); begin Create(ARefLifeTime, ACaptureCallStack, RStrNoExceptInfo, '', ExceptAddr); if ASource <> nil then AssignFromIntf(ASource); end; function TGMExceptionInformation.GetHRCode: HResult; begin Result := FHrCode; end; function TGMExceptionInformation.AskBoolean(const ValueId: Integer): LongInt; begin case ValueId of Ord(bevCaptureCallStack): Result := GMBooleanAskResult(FCaptureCallStack); Ord(bevPresentToUI): Result := FPresentToUI; else Result := Ord(barUnknown); end; end; procedure TGMExceptionInformation.AssignFromIntf(const ASource: IUnknown); // // Strings are passed as PGMChar, this works across DLL Boundaries without MM Sharing. // To be sure to make our own copy of the strings we use SetString instead of simple assignment. // You never know what the assigment really does, and it may vary between compilers .. // var ExceptInfo: IGMExceptionInformation; begin FHrCode := GMGetIntfHRCode(ASource); if not GMQueryInterface(ASource, IGMExceptionInformation, ExceptInfo) then Exit; FExceptAddress := ExceptInfo.ExceptAddress; FSeverityLevel := ExceptInfo.SeverityLevel; FHelpContext := ExceptInfo.HelpContext; SetString(FMessage, ExceptInfo.GMMessage, GMStrLen(ExceptInfo.GMMessage)); SetString(FExceptionClassName, ExceptInfo.ExceptionClassName, GMStrLen(ExceptInfo.ExceptionClassName)); SetString(FRaisorName, ExceptInfo.RaisorName, GMStrLen(ExceptInfo.RaisorName)); SetString(FRaisorClassName, ExceptInfo.RaisorClassName, GMStrLen(ExceptInfo.RaisorClassName)); SetString(FRoutineName, ExceptInfo.RoutineName, GMStrLen(ExceptInfo.RoutineName)); FPresentToUI := Ord(GMAskUnkBoolean(ASource, Ord(bevPresentToUI))); end; procedure TGMExceptionInformation.AssignFromObj(const ASource: TObject); var ExceptInfo: IGMExceptionInformation; //msgStr: String; begin if ASource = nil then Exit; if ASource.GetInterface(IGMExceptionInformation, ExceptInfo) then AssignFromIntf(ExceptInfo) else if GMIsClassByName(ASource, Exception) then // <- Take information from other Exceptions begin FExceptAddress := ExceptAddr; FHrCode := GMGetObjHrCode(ASource); {$IFDEF FPC} //SetString(FMessage, PChar(Exception(ASource).Message), Length(Exception(ASource).Message)); FMessage := Exception(ASource).Message; {$ELSE} //SetString(FMessage, PChar(Exception(ASource).Message), Length(Exception(ASource).Message)); FMessage := PChar(Exception(ASource).Message); {$ENDIF} FExceptionClassName := Exception(ASource).ClassName; // <- ShortStrings can be safely passed across DLL Boundaries, should become a newly allocated TGMString FHelpContext := Exception(ASource).HelpContext; FSeverityLevel := svError; FPresentToUI := GMBooleanAskResult(GMPresentExceptionUI(ASource)); end; end; function TGMExceptionInformation.GetGMMessage: PGMChar; begin Result := PGMChar(FMessage); end; function TGMExceptionInformation.GetExceptionClassName: PGMChar; begin Result := PGMChar(FExceptionClassName); end; function TGMExceptionInformation.GetExceptAddress: Pointer; begin Result := FExceptAddress; end; function TGMExceptionInformation.GetRaisorName: PGMChar; begin Result := PGMChar(FRaisorName); end; function TGMExceptionInformation.GetRaisorClassName: PGMChar; begin Result := PGMChar(FRaisorClassName); end; function TGMExceptionInformation.GetRoutineName: PGMChar; begin Result := PGMChar(FRoutineName); end; function TGMExceptionInformation.GetSeverityLevel: TGMSeverityLevel; begin Result := FSeverityLevel; end; function TGMExceptionInformation.GetHelpCtx: LongInt; begin Result := FHelpContext; end; { ---------------------- } { ---- EGMException ---- } { ---------------------- } //constructor EGMException.Create(const AMessage: TGMString); //begin //inherited Create; //FMessage := AMessage; //end; constructor EGMException.ObjError(const AMsg: TGMString = cDfltExceptionMsg; const AObj: TObject = nil; const ARoutineName: TGMString = cDfltRoutineName; const ASeverityLevel: TGMSeverityLevel = svError; const AHelpCtx: LongInt = cDfltHelpCtx); begin //inherited Create; SetupInformation(AMsg, GMGetObjDisplayName(AObj), GMObjClassName(AObj), ARoutineName, ASeverityLevel, AHelpCtx); inherited CreateHelp(GMBuildExceptionMsg(Self), AHelpCtx); end; constructor EGMException.IntfError(const AMsg: TGMString = cDfltExceptionMsg; const AIntf: IUnknown = nil; const ARoutineName: TGMString = cDfltRoutineName; const ASeverityLevel: TGMSeverityLevel = svError; const AHelpCtx: LongInt = cDfltHelpCtx); begin //inherited Create; SetupInformation(AMsg, GMGetIntfDisplayName(AIntf), GMIntfClassName(AIntf), ARoutineName, ASeverityLevel, AHelpCtx); inherited CreateHelp(GMBuildExceptionMsg(Self), AHelpCtx); end; procedure EGMException.SetupInformation(const AMsg: TGMString = cDfltExceptionMsg; const ARaisorName: TGMString = ''; const ARaisorClassName: TGMString = ''; const ARoutineName: TGMString = cDfltRoutineName; const ASeverityLevel: TGMSeverityLevel = svError; const AHelpCtx: LongInt = cDfltHelpCtx); begin FGMMessage := AMsg; //FExceptAddress := LongWord(ExceptAddr); // <- will be assigned later by TGMExceptionInformation FRaisorName := ARaisorName; FRaisorClassName := ARaisorClassName; FRoutineName := ARoutineName; FSeverityLevel := ASeverityLevel; FHelpContext := AHelpCtx; end; destructor EGMException.Destroy; begin inherited Destroy; if Assigned(vfGMCheckRefCountOnDestroy) then vfGMCheckRefCountOnDestroy(RefCount, Self); end; //procedure EGMException.SetRoutineName(const ARoutineName: PGMChar); //begin //FRoutineName := ARoutineName; //end; //procedure EGMException.SetMessage(const AMessage: PGMChar); //begin //TPubException(Self).FMessage := AMessage; //end; // ---- IGMExceptionInformation ---- // function EGMException.GetGMMessage: PGMChar; begin //Result := PGMChar(FMsg); Result := PGMChar(FGMMessage); end; function EGMException.GetExceptionClassName: PGMChar; begin if FClassName = '' then FClassName := ClassName; Result := PGMChar(FClassName); end; function EGMException.GetExceptAddress: Pointer; begin Result := FExceptAddress; end; function EGMException.GetRaisorName: PGMChar; begin Result := PGMChar(FRaisorName); end; function EGMException.GetRaisorClassName: PGMChar; begin Result := PGMChar(FRaisorClassName); end; function EGMException.GetRoutineName: PGMChar; begin Result := PGMChar(FRoutineName); end; function EGMException.GetSeverityLevel: TGMSeverityLevel; begin Result := FSeverityLevel; end; function EGMException.GetHelpCtx: LongInt; begin Result := FHelpContext; end; // ---- IGMGetSetText ---- // function EGMException.GetText: TGMString; begin Result := FGMMessage; end; procedure EGMException.SetText(const Value: TGMString); begin FGMMessage := Value; end; // ---- IGMSetExceptionInformation ---- // procedure EGMException.SetMessage(AMessage: PGMChar); stdcall; begin FGMMessage := AMessage; end; procedure EGMException.SetSeverityLevel(ASeverityLevel: TGMSeverityLevel); stdcall; begin FSeverityLevel := ASeverityLevel; end; // ---- IUnknown ---- // function EGMException.QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} AIID: TGUID; out AIntf): HResult; begin if GetInterface(AIID, AIntf) then Result := S_OK else Result := E_NOINTERFACE; end; function EGMException._AddRef: LongInt; begin Result := InterlockedIncrement(FRefCount); end; function EGMException._Release: LongInt; begin Result := InterlockedDecrement(FRefCount); end; { ------------------------ } { ---- EGMHrException ---- } { ------------------------ } function _BuildErrMsg(ASysMsg, AMsgPostfix: TGMString): TGMString; begin if (Length(AMsgPostfix) > 0) and ((AMsgPostfix[1] = ':') or (AMsgPostfix[1] = ',') or (AMsgPostfix[1] = '.') or (AMsgPostfix[1] = '?') or (AMsgPostfix[1] = '!')) then ASysMsg := GMStripRight(ASysMsg, ',.;:?!'); Result := GMTerminateStr(ASysMsg + AMsgPostfix); end; constructor EGMHrException.ObjError(const AHRCode: HResult; const AParams: array of PGMChar; const AObj: TObject; const ARoutineName: TGMString; const AMsgPostfix: TGMString; const AHelpCtx: LongInt); begin FHrCode := AHRCode; inherited ObjError(_BuildErrMsg(GMSysErrorMsg(AHRCode, AParams), AMsgPostfix), AObj, ARoutineName, cHRSeverity[AHRCode < 0], AHelpCtx); end; constructor EGMHrException.IntfError(const AHRCode: HResult; const AParams: array of PGMChar; const AIntf: IUnknown; const ARoutineName: TGMString; const AMsgPostfix: TGMString; const AHelpCtx: LongInt); begin FHrCode := AHRCode; inherited IntfError(_BuildErrMsg(GMSysErrorMsg(AHRCode, AParams), AMsgPostfix), AIntf, ARoutineName, cHRSeverity[AHRCode < 0], AHelpCtx); end; function EGMHrException.GetHRCode: HResult; begin Result := FHrCode; end; { ----------------------- } { ---- EAPIException ---- } { ----------------------- } constructor EAPIException.ObjError(const AWinApiErrorCode: LongWord; const AParams: array of PGMChar; const AObj: TObject; const ARoutineName: TGMString; const AMsgPostfix: TGMString; const AHelpCtx: LongInt); begin FErrorCode := AWinApiErrorCode; inherited ObjError(_BuildErrMsg(GMSysErrorMsg(LongInt(AWinApiErrorCode), AParams), AMsgPostfix), AObj, ARoutineName, svError, AHelpCtx); end; function EAPIException.GetHRCode: HResult; begin Result := GMHResultFromWin32(FErrorCode); end; { ------------------ } { ---- EGMAbort ---- } { ------------------ } function EGMAbort.QueryInterface({$IFDEF FPC}constref{$ELSE}const{$ENDIF} AIID: TGUID; out AIntf): HResult; begin if GetInterface(AIID, AIntf) then Result := S_OK else Result := E_NOINTERFACE; end; function EGMAbort._AddRef: LongInt; begin Result := InterlockedIncrement(FRefCount); end; function EGMAbort._Release: LongInt; begin Result := InterlockedDecrement(FRefCount); end; function EGMAbort.GetHRCode: HResult; begin Result := E_ABORT; end; { ---------------------------------- } { ---- TGMConnectedObjListEntry ---- } { ---------------------------------- } constructor TGMConnectedObjListEntry.Create(const AUnkIntf: IUnknown; const ACookie: LongInt); begin inherited Create(True); FUnkIntf := AUnkIntf; FCookie := ACookie; end; destructor TGMConnectedObjListEntry.Destroy; begin inherited Destroy; end; procedure TGMConnectedObjListEntry.AssignTo(var CnData: tagConnectData); begin CnData.pUnk := UnkIntf; cnData.dwCookie := Cookie; end; function TGMConnectedObjListEntry.GetUnkIntf: IUnknown; begin Result := FUnkIntf; end; function TGMConnectedObjListEntry.GetCookie: LongInt; begin Result := FCookie; end; procedure TGMConnectedObjListEntry.SetUnkIntf(const Value: IUnknown); begin FUnkIntf := Value; end; procedure TGMConnectedObjListEntry.SetCookie(const Value: LongInt); begin FCookie := Value; end; { ------------------------- } { ---- TGMEnumXxxxImpl ---- } { ------------------------- } constructor TGMEnumXxxxImpl.Create(const AList: IGMIntfArrayCollection; const AElemIID: TGUID; const AListPos: LongInt = cGMUnknownPosition); begin inherited Create(True); Assert(AList <> nil, 'AList <> nil'); FList := AList; FElemIID := AElemIID; if AListPos = cGMUnknownPosition then FListPos := FList.Count-1 else FListPos := GMBoundedInt(AListPos, 0, FList.Count-1); end; { ---- IEnumXxxx ---- } function TGMEnumXxxxImpl.Skip(celt: LongInt): HResult; begin try Dec(FListPos, celt); Result := S_OK; except Result := E_UNEXPECTED; end; end; function TGMEnumXxxxImpl.Reset: HResult; begin try FListPos := FList.Count-1; Result := S_OK; except Result := E_UNEXPECTED; end; end; function TGMEnumXxxxImpl.CreateClone(const IID: TGUID; out Enum): HResult; var Clone: IUnknown; begin try Clone := CreateCloneClass.Create(FList, ElemIID, FListPos); Result := Clone.QueryInterface(IID, Enum); except Result := E_UNEXPECTED; end; end; { ------------------------------------- } { ---- TGMEnumConnectionPointsImpl ---- } { ------------------------------------- } constructor TGMEnumConnectionPointsImpl.Create(const AList: IGMIntfArrayCollection); begin inherited Create(AList, IConnectionPoint); end; function TGMEnumConnectionPointsImpl.CreateCloneClass: TGMEnumXxxxImplClass; begin Result := TGMEnumXxxxImplClass(ClassType); end; function TGMEnumConnectionPointsImpl.Clone(out Enum: IEnumConnectionPoints): HResult; var threadSync: RGMCriticalSectionLock; begin threadSync.Lock(FList); Result := CreateClone(IEnumConnectionPoints, Enum); end; function TGMEnumConnectionPointsImpl.Next(celt: LongInt; out elt; pceltFetched: PLongint): HResult; var threadSync: RGMCriticalSectionLock; begin try threadSync.Lock(FList); if (FList = nil) or not FList.IsValidIndex(FListPos) then begin if pceltFetched <> nil then pceltFetched^ := 0; Result := S_FALSE; end else if celt = 0 then begin if pceltFetched <> nil then pceltFetched^ := 0; Result := S_OK; end else begin Result := FList[FListPos].QueryInterface(ElemIID, elt); if Result = S_OK then Dec(FListPos); if pceltFetched <> nil then pceltFetched^ := CEnumElementCount[Result = S_OK]; end; except Result := E_UNEXPECTED; end; end; { -------------------------------- } { ---- TGMEnumConnectionsImpl ---- } { -------------------------------- } constructor TGMEnumConnectionsImpl.Create(const AList: IGMIntfArrayCollection); begin inherited Create(AList, IGMDisconnectFromConnectionPoint); end; function TGMEnumConnectionsImpl.CreateCloneClass: TGMEnumXxxxImplClass; begin Result := TGMEnumXxxxImplClass(ClassType); end; function TGMEnumConnectionsImpl.Clone(out Enum: IEnumConnections): HResult; var threadSync: RGMCriticalSectionLock; begin threadSync.Lock(FList); Result := CreateClone(IEnumConnections, Enum); end; function TGMEnumConnectionsImpl.Next(celt: LongInt; out elt; pceltFetched: PLongint): HResult; var ListEntry: IGMConnectedObjListEntry; threadSync: RGMCriticalSectionLock; begin try threadSync.Lock(FList); if (FList = nil) or not FList.IsValidIndex(FListPos) then begin if pceltFetched <> nil then pceltFetched^ := 0; Result := S_FALSE; end else if celt = 0 then begin if pceltFetched <> nil then pceltFetched^ := 0; Result := S_OK; end else begin Result := FList[FListPos].QueryInterface(IGMConnectedObjListEntry, ListEntry); if Result = S_OK then begin ListEntry.AssignTo(CONNECTDATA(elt)); Dec(FListPos); end; if pceltFetched <> nil then pceltFetched^ := CEnumElementCount[Result = S_OK]; end; except Result := E_UNEXPECTED; end; end; { ----------------------------------------- } { ---- TGMConnectionPointContainerImpl ---- } { ----------------------------------------- } constructor TGMConnectionPointContainerImpl.Create(const AConnectionPoints: array of TGUID; const ARefLifeTime: Boolean = True); var i: LongInt; begin inherited Create(ARefLifeTime); FConnectionPoints := TGMIntfArrayCollection.Create; for i:=Low(AConnectionPoints) to High(AConnectionPoints) do CreateConnectionPoint(AConnectionPoints[i]); end; procedure TGMConnectionPointContainerImpl.ReleaseReferences; var threadSync: RGMCriticalSectionLock; begin threadSync.Lock(FConnectionPoints); FConnectionPoints.Clear; end; procedure TGMConnectionPointContainerImpl.CreateConnectionPoint(const IID: TGUID); var cp: IConnectionPoint; threadSync: RGMCriticalSectionLock; begin threadSync.Lock(FConnectionPoints); if FindConnectionPoint(IID, cp) = CONNECT_E_NOCONNECTION then FConnectionPoints.Add(TGMConnectionPointImpl.Create(Self, IID)); end; function TGMConnectionPointContainerImpl.EnumConnectionPoints(out Enum: IEnumConnectionPoints): HResult; var PIEnum: IUnknown; begin try PIEnum := TGMEnumConnectionPointsImpl.Create(FConnectionPoints); Result := PIEnum.QueryInterface(IEnumConnectionPoints, Enum); except Result := E_UNEXPECTED; end; end; function TGMConnectionPointContainerImpl.FindConnectionPoint(const IID: TGUID; out cp: IConnectionPoint): HResult; var i: LongInt; ConnectionPoint: IConnectionPoint; CpIID: TGUID; threadSync: RGMCriticalSectionLock; begin try threadSync.Lock(FConnectionPoints); Result := CONNECT_E_NOCONNECTION; for i:=0 to FConnectionPoints.Count-1 do if GMQueryInterface(FConnectionPoints[i], IConnectionPoint, ConnectionPoint) and (ConnectionPoint.GetConnectionInterface(CpIID) = S_OK) and IsEqualGUID(IID, CpIID) then begin cp := ConnectionPoint; Result := S_OK; Break; end; except Result := E_UNEXPECTED; end; end; { -------------------------------- } { ---- TGMConnectionPointImpl ---- } { -------------------------------- } constructor TGMConnectionPointImpl.Create(const AOwner: IUnknown; const IID: TGUID; const ARefLifeTime: Boolean = True); begin inherited Create(ARefLifeTime); FConnectedObjects := TGMIntfArrayCollection.Create; FOwner := AOwner; FIntfID := IID; end; destructor TGMConnectionPointImpl.Destroy; begin Assert(FConnectedObjects.Count = 0, 'FConnectedObjects.Count = 0'); inherited Destroy; end; { ---- IConnectionPoint ---- } function TGMConnectionPointImpl.GetConnectionInterface(out iid: TGUID): HResult; begin try iid := IntfID; Result := S_OK; except Result := E_UNEXPECTED; end; end; function TGMConnectionPointImpl.GetConnectionPointContainer(out cpc: IConnectionPointContainer): HResult; begin try if FOwner = nil then Result := E_NOINTERFACE else Result := FOwner.QueryInterface(IConnectionPointContainer, cpc); except Result := E_UNEXPECTED; end; end; function TGMConnectionPointImpl.Advise(const unkSink: IUnknown; out dwCookie: LongInt): HResult; var SinkIntf: IUnknown; threadSync: RGMCriticalSectionLock; begin try threadSync.Lock(FConnectedObjects); Result := CONNECT_E_CANNOTCONNECT; if unkSink <> nil then begin Result := unkSink.QueryInterface(IntfID, SinkIntf); if Result = S_OK then begin //Result := unkSink.QueryInterface(IGMDisconnectFromConnectionPoint, SinkIntf); //if Result = S_Ok then begin Inc(FCurrentCookie); FConnectedObjects.Add(TGMConnectedObjListEntry.Create(unkSink, FCurrentCookie)); dwCookie := FCurrentCookie; end; end; end; except Result := E_UNEXPECTED; end; end; function TGMConnectionPointImpl.Unadvise(dwCookie: LongInt): HResult; var ItemIdx: LongInt; threadSync: RGMCriticalSectionLock; function FindListEntry(const dwCookie: LongInt; var Index: LongInt): Boolean; var i: LongInt; ListEntry: IGMConnectedObjListEntry; begin Result := False; Index := -1; for i := FConnectedObjects.Count-1 downto 0 do begin GMCheckQueryInterface(FConnectedObjects[i], IGMConnectedObjListEntry, ListEntry, {$I %CurrentRoutine%}); if ListEntry.Cookie = dwCookie then begin Index := i; Result := True; Break; end; end; end; begin try threadSync.Lock(FConnectedObjects); Result := CONNECT_E_NOCONNECTION; if FindListEntry(dwCookie, ItemIdx) then begin FConnectedObjects.RemoveByIdx(ItemIdx); Result := S_OK; end; except Result := E_UNEXPECTED; end; end; function TGMConnectionPointImpl.EnumConnections(out Enum: IEnumConnections): HResult; var PIEnum: IEnumConnections; begin try PIEnum := TGMEnumConnectionsImpl.Create(FConnectedObjects); Result := PIEnum.QueryInterface(IEnumConnections, Enum); except Result := E_UNEXPECTED; end; end; { --------------------------- } { ---- TGMFileProperties ---- } { --------------------------- } constructor TGMFileProperties.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FCriticalSection := TGMCriticalSection.Create(True); end; constructor TGMFileProperties.Create(const AFileName: TGMString; const AAttributes: TFileAttributes; const ASizeInBytes: Int64; const ACreationTime: TDateTime; const ALastWriteTime: TDateTime; const ALastAccessTime: TDateTime; const ARefLifeTime: Boolean); begin {inherited} Create(ARefLifeTime); FFileName := AFileName; FSizeInBytes := ASizeInBytes; FAttributes := AAttributes; FCreationTime := ACreationTime; FLastWriteTime := ALastWriteTime; FLastAccessTime := ALastAccessTime; end; constructor TGMFileProperties.Create(const FindData: TWin32FindData; const AFilePath: TGMString = ''; const ARefLifeTime: Boolean = True); //var FName: TGMString; begin //if AFilePath <> '' then FName := AFilePath else FName := FindData.cFileName; Create(GMAppendPath(AFilePath, FindData.cFileName), GMDWordToFileAttributes(FindData.dwFileAttributes), GMFindDataFileSize(FindData), GMFileTimeToDateTime(FindData.ftCreationTime, Self), GMFileTimeToDateTime(FindData.ftLastWriteTime, Self), GMFileTimeToDateTime(FindData.ftLastAccessTime, Self), ARefLifeTime); end; constructor TGMFileProperties.CreateFromExisting(const AExistingFileName: TGMString; const ARefLifeTime: Boolean = True); var findData: TWin32FindData; HSearch: THandle; begin Create(AExistingFileName, [], -1, 0, 0, 0, ARefLifeTime); HSearch := FindFirstFile(PGMChar(AExistingFileName), findData); if HSearch <> INVALID_HANDLE_VALUE then begin {$IFNDEF JEDIAPI}windows{$ELSE}jwaWinBase{$ENDIF}.FindClose(HSearch); Create(findData, GMExtractPath(AExistingFileName), ARefLifeTime); end; end; //function TGMFileProperties.CriticalSection: IGMCriticalSection; //begin //if FCriticalSection = nil then FCriticalSection := TGMCriticalSection.Create(True); //Result := FCriticalSection; //end; procedure TGMFileProperties.AssignFromIntf(const Source: IUnknown); var PIFileEntry: IGMFileProperties; // threadSync: IUnknown; begin //threadSync := TGMCriticalSectionLock.Create(CriticalSection); CriticalSection.EnterCriticalSection; try if GMQueryInterface(Source, IGMFileProperties, PIFileEntry) then begin FFileName := PIFileEntry.FileName; FSizeInBytes := PIFileEntry.SizeInBytes; FAttributes := PIFileEntry.Attributes; FCreationTime := PIFileEntry.CreationTime; FLastWriteTime := PIFileEntry.LastWriteTime; FLastAccessTime := PIFileEntry.LastAccessTime; end; finally CriticalSection.LeaveCriticalSection; end; end; function TGMFileProperties.GetFileName: TGMString; //var threadSync: IUnknown; begin CriticalSection.EnterCriticalSection; try //threadSync := TGMCriticalSectionLock.Create(CriticalSection); Result := FFileName; finally CriticalSection.LeaveCriticalSection; end; end; procedure TGMFileProperties.SetFileName(const Value: TGMString); //var threadSync: IUnknown; begin CriticalSection.EnterCriticalSection; try //threadSync := TGMCriticalSectionLock.Create(CriticalSection); FFileName := Value; finally CriticalSection.LeaveCriticalSection; end; end; function TGMFileProperties.GetDisplayName: TGMString; //var threadSync: IUnknown; begin CriticalSection.EnterCriticalSection; try //threadSync := TGMCriticalSectionLock.Create(CriticalSection); if FDisplayName <> '' then Result := FDisplayName else Result := FFileName; finally CriticalSection.LeaveCriticalSection; end; end; function TGMFileProperties.GetAttributes: TFileAttributes; //var threadSync: IUnknown; begin CriticalSection.EnterCriticalSection; try //threadSync := TGMCriticalSectionLock.Create(CriticalSection); Result := FAttributes; finally CriticalSection.LeaveCriticalSection; end; end; function TGMFileProperties.GetCreationTime: TDateTime; //var threadSync: IUnknown; begin CriticalSection.EnterCriticalSection; try //threadSync := TGMCriticalSectionLock.Create(CriticalSection); Result := FCreationTime; finally CriticalSection.LeaveCriticalSection; end; end; function TGMFileProperties.GetLastAccessTime: TDateTime; //var threadSync: IUnknown; begin CriticalSection.EnterCriticalSection; try //threadSync := TGMCriticalSectionLock.Create(CriticalSection); Result := FLastAccessTime; finally CriticalSection.LeaveCriticalSection; end; end; function TGMFileProperties.GetLastWriteTime: TDateTime; //var threadSync: IUnknown; begin CriticalSection.EnterCriticalSection; try //threadSync := TGMCriticalSectionLock.Create(CriticalSection); Result := FLastWriteTime; finally CriticalSection.LeaveCriticalSection; end; end; function TGMFileProperties.GetSizeInBytes: Int64; //var threadSync: IUnknown; begin CriticalSection.EnterCriticalSection; try //threadSync := TGMCriticalSectionLock.Create(CriticalSection); Result := FSizeInBytes; finally CriticalSection.LeaveCriticalSection; end; end; function GMReadBOMCharKind(const AStream: IStream; const ADefaultChKind: TGMCharKind): TGMCharKind; function TestBOM(const ABom: RawByteString): Boolean; var n: LongInt; bomStr: RawByteString; begin n := 0; Result := False; SetLength(bomStr, Length(ABom)); try GMHrCheckObj(AStream.Read(PAnsiChar(bomStr), Length(bomStr), @n), nil, {$I %CurrentRoutine%}); Result := (n = Length(ABom)) and (bomStr = ABom); finally if not Result then GMHrCheckObj(AStream.Seek(-n, STREAM_SEEK_CUR, nil), nil, {$I %CurrentRoutine%}); end; end; begin Result := ADefaultChKind; if AStream = nil then Exit; if TestBOM(cUtf16LEBom) then Result := ckUtf16LE else if TestBOM(cUtf16BEBom) then Result := ckUtf16BE else if TestBOM(cUtf8Bom) then Result := ckUtf8 else Result := ADefaultChKind; end; procedure GMWriteBOM(const ADestStream: ISequentialStream; const ACharKind: TGMCharKind); begin if ADestStream <> nil then case ACharKind of ckUtf8: GMSafeIStreamWrite(ADestStream, PAnsiChar(cUtf8Bom), Length(cUtf8Bom)); ckUtf16LE: GMSafeIStreamWrite(ADestStream, PAnsiChar(cUtf16LEBom), Length(cUtf16LEBom)); ckUtf16BE: GMSafeIStreamWrite(ADestStream, PAnsiChar(cUtf16BEBom), Length(cUtf16BEBom)); end; end; function GMIStreamHasSignature(const AStream: IStream; const AFormatSig: AnsiString): Boolean; const cStrRountineName = 'GMIStreamHasSignature'; var strmSig: AnsiString; n: LongInt; begin Result := False; if AStream = nil then Exit; SetLength(strmSig, Length(AFormatSig)); try GMHrCheckIntf(AStream.Read(PAnsiChar(strmSig), Length(strmSig), @n), AStream, cStrRountineName); Result := (n = Length(AFormatSig)) and (strmSig = AFormatSig); finally if n <> 0 then GMHrCheckIntf(AStream.Seek(-n, STREAM_SEEK_CUR, nil), AStream, cStrRountineName); end; end; function GMIStreamContainsJpeg(const AStream: IStream): boolean; begin Result := GMIStreamHasSignature(AStream, #$FF#$D8); // $D8FF end; function GMIStreamContainsGIF(const AStream: IStream): boolean; begin Result := GMIStreamHasSignature(AStream, 'GIF'); // $D8FF end; function GMIStreamContainsBmp(const AStream: IStream): boolean; begin Result := GMIStreamHasSignature(AStream, #$42#$4D); // $4D42 end; function ReadNextStreamAnsiChar(const AStream: IStream; var ACh: AnsiChar): Boolean; var N: LongInt; begin Result := (AStream <> nil) and (AStream.Read(@ACh, SizeOf(ACh), @N) >= 0) and (N = SizeOf(ACh)); end; function GMIStreamContainsXml(const AStream: IStream): Boolean; var StreamPosKeeper: IUnknown; ch: AnsiChar; function IsIdentifierStartCh(ACh: AnsiChar): Boolean; begin Result := ((ACh >= 'a') and (ACh <= 'z')) or (ACh >= 'A') and (ACh <= 'Z') or (ACh = '_'); end; begin Result := False; if AStream = nil then Exit; StreamPosKeeper := TGMIStreamPosKeeper.Create(AStream); repeat if not ReadNextStreamAnsiChar(AStream, ch) then Exit; until not (ch in [' ', #9, #10, #13]); if ch <> '<' then Exit; if not ReadNextStreamAnsiChar(AStream, ch) then Exit; case ch of '!', '?': begin if not ReadNextStreamAnsiChar(AStream, ch) then Exit; if not IsIdentifierStartCh(ch) then Exit; end; else if not IsIdentifierStartCh(ch) then Exit; end; Result := True; end; function GMIStreamContainsASCIIText(const AStream: IStream): Boolean; const cCheckChCount = 100; var i: LongInt; StreamPosKeeper: IUnknown; ch: AnsiChar; begin if AStream = nil then begin Result := False; Exit; end; StreamPosKeeper := TGMIStreamPosKeeper.Create(AStream); Result := True; for i:=0 to cCheckChCount-1 do begin if not ReadNextStreamAnsiChar(AStream, ch) then begin Result := i > 0; Exit; end; // if not (ch in [#9, #10, #13]) and not ((Ord(ch) >= 32) and ((Ord(ch) <= 127))) then // begin Result := False; Exit; end; if not (ch in [#9, #10, #13]) and not (Ord(ch) >= 32) then begin Result := False; Exit; end; end; end; procedure GMConsumeStreamContent(const AStream: ISequentialStream; const ABufferSize: LongInt); var strBuf: AnsiString; n: LongInt; readHr: HResult; begin if (AStream = nil) or (ABufferSize <= 0) then Exit; SetLength(strBuf, ABufferSize); repeat readHr := AStream.Read(PAnsiChar(strBuf), Length(strBuf), @n); until (n < Length(strBuf)) or not GMHrSucceeded(readHr); end; {function GMIStreamContainsJpeg(const AStream: IStream): boolean; const cStrRountineName = 'GMIStreamContainsJpeg'; //const cJpegDataSig: array [0 .. 1] of Byte = ($FF, $D8); //, $FF, $E0, $00, $10, $4A, $46, $49, $46, $00); const cJpegSig: Word = $D8FF; var JpegSig: Word; n: LongInt; // array [Low(cJpegDataSig) .. High(cJpegDataSig)] of Byte; begin Result := False; if AStream = nil then Exit; //PosKeeper := TGMIStreamPosKeeper.Create(AStream); //if GMIStreamSize(AStream) - GMIStreamPos(AStream) > SizeOf(JpegSig) then GMHrCheckIntf(AStream.Read(@JpegSig, SizeOf(JpegSig), @n), AStream, cStrRountineName); Result := (n >= SizeOf(JpegSig)) and (JpegSig = cJpegSig); GMHrCheckIntf(AStream.Seek(-n, STREAM_SEEK_CUR, PInt64(nil)^), AStream, cStrRountineName); begin GMSafeIStreamRead(AStream, @JpegSig, SizeOf(JpegSig), cStrRountineName); GMHrCheckIntf(AStream.Seek(-Sizeof(JpegSig), STREAM_SEEK_CUR, PInt64(nil)^), AStream, cStrRountineName); //AStream.ReadBuffer(JpegSig, SizeOf(JpegSig)); //AStream.Seek(-Sizeof(JpegSig), soFromCurrent); Result := JpegSig = cJpegSig; //Result := CompareMem(@JpegSig, @cJpegDataSig, Min(SizeOf(JpegSig), SizeOf(cJpegDataSig))); end; end;} function GMIStreamReadStrA(const AStream: ISequentialStream): AnsiString; const cStrRountineName = 'GMIStreamReadStrA'; var len, n: LongWord; begin if AStream = nil then begin Result := ''; Exit; end; AStream.Read(@len, SizeOf(len), PLongInt(@n)); if n < SizeOf(len) then Exit{$IFDEF FPC}(''){$ENDIF}; SetLength(Result, len); if len > 0 then GMSafeIStreamRead(AStream, PAnsiChar(Result), len, cStrRountineName); end; procedure GMIStreamWriteStrA(const AStream: ISequentialStream; const AValue: AnsiString); const cStrRountineName = 'GMIStreamWriteStrA'; var len: LongWord; begin if AStream = nil then Exit; len := Length(AValue); GMSafeIStreamWrite(AStream, @len, SizeOf(len), cStrRountineName); if len > 0 then GMSafeIStreamWrite(AStream, PAnsiChar(AValue), len, cStrRountineName); end; function GMIStreamReadStrW(const AStream: ISequentialStream): UnicodeString; const cStrRountineName = 'GMIStreamReadStrW'; var len, n: LongWord; begin if AStream = nil then begin Result := ''; Exit; end; AStream.Read(@len, SizeOf(len), PLongInt(@n)); if n < SizeOf(len) then Exit{$IFDEF FPC}(''){$ENDIF}; SetLength(Result, len); if len > 0 then GMSafeIStreamRead(AStream, PWideChar(Result), len * SizeOf(WideChar), cStrRountineName); end; procedure GMIStreamWriteStrW(const AStream: ISequentialStream; const AValue: UnicodeString); const cStrRountineName = 'GMIStreamWriteStrW'; var len: LongWord; begin if AStream = nil then Exit; len := Length(AValue); GMSafeIStreamWrite(AStream, @len, SizeOf(len), cStrRountineName); if len > 0 then GMSafeIStreamWrite(AStream, PWideChar(AValue), len * SizeOf(WideChar), cStrRountineName); end; { ------------------------ } { ---- File functions ---- } { ------------------------ } function GMFolderExists(const AFolderName: TGMString): Boolean; var attr, lastErr: DWORD; begin attr := GetFileAttributes(PGMChar(AFolderName)); if attr = INVALID_FILE_ATTRIBUTES then begin lastErr := GetLastError; case lastErr of ERROR_FILE_NOT_FOUND, ERROR_PATH_NOT_FOUND, ERROR_BAD_PATHNAME: ; // <- Nothing! ERROR_ACCESS_DENIED else GMApiCheckObj('GetFileAttributes', '', lastErr, False); end; end; Result := (attr <> INVALID_FILE_ATTRIBUTES) and (FILE_ATTRIBUTE_DIRECTORY and attr <> 0); end; function GMFileExists(const AFileName: TGMString): Boolean; var attr, lastErr: DWORD; begin if Length(AFileName) <= 0 then Exit(False); attr := GetFileAttributes(PGMChar(AFileName)); if attr = INVALID_FILE_ATTRIBUTES then begin lastErr := GetLastError; case lastErr of ERROR_FILE_NOT_FOUND, ERROR_PATH_NOT_FOUND, ERROR_BAD_PATHNAME, ERROR_BAD_NETPATH: ; // <- Nothing! ERROR_ACCESS_DENIED else GMApiCheckObj('GetFileAttributes', '', lastErr, False); end; end; Result := (attr <> INVALID_FILE_ATTRIBUTES) and (FILE_ATTRIBUTE_DIRECTORY and attr = 0); end; function GMFileOrFolderExists(const AFileName: TGMString): Boolean; var attr, lastErr: DWORD; begin attr := GetFileAttributes(PGMChar(AFileName)); if attr = INVALID_FILE_ATTRIBUTES then begin lastErr := GetLastError; case lastErr of ERROR_FILE_NOT_FOUND, ERROR_PATH_NOT_FOUND, ERROR_BAD_PATHNAME: ; // <- Nothing! ERROR_ACCESS_DENIED else GMApiCheckObj('GetFileAttributes', '', lastErr, False); end; end; Result := attr <> INVALID_FILE_ATTRIBUTES; end; function GMFileSystemEntry(const FilePath: TGMString): IGMFileProperties; var Handle: THandle; FindData: TWin32FindData; begin Handle := FindFirstFile(PGMChar(FilePath), FindData); GMAPICheckObj('FindFirstFile', '', GetLastError, Handle <> INVALID_HANDLE_VALUE); {$IFNDEF JEDIAPI}windows{$ELSE}jwaWinBase{$ENDIF}.FindClose(Handle); Result := TGMFileProperties.Create(FindData, FilePath); end; procedure GMCheckFileExists(const AFileName: TGMString; const Caller: TObject = nil; const CallingName: TGMString = cDfltRoutineName); begin if not GMFileExists(AFileName) then raise EGMException.ObjError(GMFormat(RStrFileNotExists, [AFileName]), Caller, CallingName); end; procedure GMCreatePath(DirPath: TGMString; const Caller: TObject); var chPos: PtrInt; dir, path: TGMString; errCode: DWORD; begin path := ExtractFileDrive(DirPath); DirPath := Copy(DirPath, Length(path) + 1, High(LongInt)); chPos := 1; repeat dir := GMNextWord(chPos, DirPath, cDirSep); if Length(dir) > 0 then begin path := GMAppendPath(path, dir); // // GMFolderExists may fail on insufficient rights too! // if not CreateDirectory(PGMChar(path), nil) then // not GMFolderExists(path) and begin errCode := GetLastError; GMAPICheckObjEx('CreateDirectory("'+path+'")', '', errCode, False, [NO_ERROR, ERROR_ALREADY_EXISTS], Caller); end; //if not GMFolderExists(path) then GMApiCheckObj(CreateDirectory(PGMChar(path), nil), Caller, 'CreateDirectory'); end; until dir = ''; end; procedure GMCheckFileOpenReadOnly(const AFileName: TGMString; const OpenReadOnly: Boolean; const Caller: TObject = nil; const CallingName: TGMString = cDfltRoutineName); var FileAttr: LongInt; begin FileAttr := GetFileAttributes(PGMChar(AFileName)); if (FileAttr <> -1) and (FileAttr and FILE_ATTRIBUTE_READONLY <> 0) and not OpenReadOnly then raise EGMException.ObjError(GMFormat(RStrFileReadonlyFmt, [AFileName]), Caller, CallingName); end; function GMAppendPath(const APath1, APath2: TGMString; const APathSep: TGMString): TGMString; //var lPath: TGMString; chPos: PtrInt; begin //chPos := Length(APath1); //while (chPos > 1) and GMIsDelimiter(cDirSep, APath1, chPos) do Dec(chPos); //lPath := Copy(APath1, 1, chPos); //if GMIsOneOfStrings(APath1, ['/', '\', '\\']) then if (APath1 = '\') or (APath1 = '/') or (APath1 = '\\') then Result := APath1 + GMStripLeft(APath2, cDirSep) else Result := GMStringJoin(GMStripRight(APath1, cDirSep), APathSep, GMStripLeft(APath2, cDirSep)); end; function GMBuildPath(const APathParts: array of TGMString; const APathSep: TGMString = '\'): TGMString; var i: Integer; begin Result := ''; for i:=Low(APathParts) to High(APathParts) do Result := GMAppendPath(Result, APathParts[i]); end; function GMAbsPath(const APath: TGMString; const AAbsStart: TGMString): TGMString; begin Result := AAbsStart + GMStripLeft(APath, cDirSep); end; function GMAppendStrippedPath(const Path1, Path2: TGMString; const Separator: TGMString): TGMString; begin Result := GMStringJoin(GMStrip(Path1, cDirSep), Separator, GMStrip(Path2, cDirSep)); end; function GMApplyRelativePath(const Path, RelativePath: TGMString): TGMString; const CUpDir = '..'; CDir = '.'; var chPos: PtrInt; Token: TGMString; begin Result := Path; chPos := 1; repeat Token := GMNextWord(chPos, RelativePath, cDirSep); if Token = CUpDir then Result := GMDeleteLastWord(Result, cDirSep) else if Token <> CDir then Result := GMAppendPath(Result, Token); until Token = ''; end; {$IFDEF JEDIAPI} procedure GMGetUserAndDomainNames(var AUserName, ADomainName: TGMString); // // See: http://support.microsoft.com/kb/111544 // var token: THandle; lastErr, tokenInfoSize, userNameLen, domainLen, snu: DWORD; tokenData: AnsiString; begin token := 0; if not OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, token) then begin lastErr := GetLastError; GMAPICheckObjEx('OpenThreadToken', '', lastErr, False, [ERROR_SUCCESS, ERROR_NO_TOKEN]); GMAPICheckObj('OpenProcessToken', '', GetLastError, OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, token)); end; try GMAPICheckObjEx('GetTokenInformation', '', GetLastError, GetTokenInformation(token, TokenUser, nil, 0, tokenInfoSize), [ERROR_SUCCESS, ERROR_INSUFFICIENT_BUFFER]); SetLength(tokenData, tokenInfoSize); GMAPICheckObj('GetTokenInformation', '', GetLastError, GetTokenInformation(token, TokenUser, PAnsiChar(tokenData), Length(tokenData), tokenInfoSize)); userNameLen := 512; SetLength(AUserName, userNameLen); domainLen := 512; SetLength(ADomainName, domainLen); GMAPICheckObj('LookupAccountSid', '', GetLastError, LookupAccountSid(nil, PTOKEN_USER(PAnsiChar(tokenData)).User.Sid, PGMChar(AUserName), userNameLen, PGMChar(ADomainName), domainLen, snu)); SetLength(AUserName, userNameLen); SetLength(ADomainName, domainLen); finally CloseHandle(token); end; end; {$ENDIF} function GMThisComputerName: TGMString; var len: DWORD; begin len := MAX_COMPUTERNAME_LENGTH + 1; SetLength(Result, LongInt(len)-1); GMAPICheckObj('GetComputerName', '', GetLastError, GetComputerName(PGMChar(Result), len)); SetLength(Result, len); // <- Terminator NOT included in len end; function GMThisUserName: TGMString; const cUnLen = 256; var len: DWORD; begin len := cUnLen + 1; SetLength(Result, LongInt(len)-1); GMAPICheckObj('GetUserName', '', GetLastError, GetUserName(PGMChar(Result), len)); SetLength(Result, LongInt(len)-1); // <- Terminator included in len end; function GMThisUserSID: TGMString; // // See: http://support.microsoft.com/kb/111544 // http://stackoverflow.com/questions/251248/how-can-i-get-the-sid-of-the-current-windows-account // var token: THandle; lastErr, tokenInfoSize: DWORD; tokenData: AnsiString; pszSid: PGMChar; // userNameLen, domainLen, snu begin token := 0; Result := ''; try if not OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, token) then begin lastErr := GetLastError; GMAPICheckObjEx('OpenThreadToken', '', lastErr, False, [ERROR_SUCCESS, ERROR_NO_TOKEN]); GMAPICheckObj('OpenProcessToken', '', GetLastError, OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, token)); end; GMAPICheckObjEx('GetTokenInformation', '', GetLastError, GetTokenInformation(token, TokenUser, nil, 0, tokenInfoSize), [ERROR_SUCCESS, ERROR_INSUFFICIENT_BUFFER]); SetLength(tokenData, tokenInfoSize); GMAPICheckObj('GetTokenInformation', '', GetLastError, GetTokenInformation(token, TokenUser, PAnsiChar(tokenData), Length(tokenData), tokenInfoSize)); try pszSid := nil; GMAPICheckObj('ConvertSidToStringSid', '', GetLastError, ConvertSidToStringSid(PTOKEN_USER(PAnsiChar(tokenData)).User.Sid, pszSid)); SetString(Result, pszSid, GMStrLen(pszSid)); // Result := SetString(pszSid; finally LocalFree(PtrUInt(pszSid)); // if LocalFree(PtrUInt(pszSid)) <> 0 then lastErr := GetLastError; end; // userNameLen := 512; SetLength(AUserName, userNameLen); // domainLen := 512; SetLength(ADomainName, domainLen); // GMAPICheckObj('LookupAccountSid', '', GetLastError, LookupAccountSid(nil, PTOKEN_USER(PAnsiChar(tokenData)).User.Sid, // PGMChar(AUserName), userNameLen, PGMChar(ADomainName), domainLen, snu)); // // SetLength(AUserName, userNameLen); // SetLength(ADomainName, domainLen); finally if token <> 0 then CloseHandle(token); end; end; procedure GMGetAllUserNames(var AUserNames: TGMStringArray); var regKey: IGMRegKey; i: LongInt; subKeyNames: TGMStringArray; begin SetLength(AUserNames, 0); regKey := TGMRegKey.Create(True); if not regKey.Obj.OpenKey(HKEY_LOCAL_MACHINE, '\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList') then Exit; regKey.Obj.ReadSubKeyNames(subKeyNames); for i:=Low(subKeyNames) to High(subKeyNames) do if GMIsPrefixStr('S-1-5-21-', subKeyNames[i]) and regKey.Obj.OpenKey(HKEY_LOCAL_MACHINE, GMAppendPath('SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList', subKeyNames[i])) then GMAddStrToArray(GMStrip(GMLastWord(regKey.Obj.ReadString('ProfileImagePath'), '\')), AUserNames); end; procedure GMGetAllUserSettingsDirectories(var ADirectories: TGMStringArray; const ASubDirName: TGMString); var i: LongInt; userBasePath, userSubDir: TGMString; begin GMGetAllUserNames(ADirectories); userBasePath := GMDeleteLastWord(GMExpandEnvironmentStrings('%USERPROFILE%'), '/\'); if GMWinVersion < wvVista then userSubDir := 'Application Data' else userSubDir := 'AppData\Roaming'; for i:=Low(ADirectories) to High(ADirectories) do ADirectories[i] := GMBuildPath([userBasePath, ADirectories[i], userSubDir, ASubDirName]); end; function GMWinSystemDir: TGMString; begin Setlength(Result, LongInt(GetSystemDirectory(nil, 0)) - 1); // <- SetLength is safe against negative length if Length(Result) > 0 then GetSystemDirectory(PGMChar(Result), Length(Result) + 1); end; function GMWindowsDir: TGMString; begin Setlength(Result, LongInt(GetWindowsDirectory(nil, 0)) - 1); // <- SetLength is safe against negative length if Length(Result) > 0 then GetWindowsDirectory(PGMChar(Result), Length(Result) + 1); end; function GMWinTempDir: TGMString; begin Setlength(Result, LongInt(GetTempPath(0, nil)) - 1); // <- SetLength is safe against negative length if Length(Result) > 0 then GetTempPath(Length(Result) + 1, PGMChar(Result)); end; function GMCurrentDir: TGMString; begin Setlength(Result, LongInt(GetCurrentDirectory(0, nil)) - 1); // <- SetLength is safe against negative length if Length(Result) > 0 then GetCurrentDirectory(Length(Result) + 1, PGMChar(Result)); end; function GMTempFileName(AFolderPath: TGMString = ''; Prefix: TGMString = CGMTempFilePrefix; Extension: TGMString = CGMTempFileExtension): TGMString; var i: Integer; function BuildFileName(const Prefix, Extension: TGMString; No: Integer): TGMString; begin //Result := GMFormat('%s\%s%x.%s', [AFolderPath, Prefix, No, GMStrip(Extension, '.')]); Result := GMAppendPath(AFolderPath, Prefix + GMFormat('%x', [No]) +'.'+ GMStrip(Extension, '.'), DirectorySeparator); end; begin if AFolderPath = '' then AFolderPath := GMWinTempDir; AFolderPath := GMStripRight(AFolderPath, ':\.'); if Length(Prefix) > 3 then Prefix := Copy(Prefix, 1, 3); {$push}{$warnings off} // <- hide annoing deprecated warning i := GetTickCount and ($FFFFFFFF shr (Length(Prefix) * 4)); {$pop} Result := BuildFileName(Prefix, Extension, i); while GMFileExists(Result) do begin Inc(i); Result := BuildFileName(Prefix, Extension, i); end; end; function GMModuleFileName(const ModuleHandle: HMODULE): TGMString; begin SetLength(Result, 2048); SetLength(Result, GetModuleFileName(ModuleHandle, PGMChar(Result), Length(Result))); GMAPICheckObj('GetModuleFileName', '', GetLastError, Length(Result) > 0); Result := GMLongPathName(Result); end; function GMThisModuleFileName: TGMString; begin Result := GMModuleFileName({$IFNDEF FPC}SysInit.{$ELSE}System.{$ENDIF}HInstance); end; function GMApplicationExeName: TGMString; begin Result := ParamStr(0); // GMModuleFileName(0); end; function GMExpandEnvironmentStrings(const APath: TGMString): TGMString; // // For a list of environment Variables see: https://ss64.com/nt/syntax-variables.html // begin SetLength(Result, LongInt(ExpandEnvironmentStrings(PGMChar(APath), nil, 0)) - 1); if Length(Result) = 0 then Exit; GMAPICheckObj('ExpandEnvironmentStrings', '', GetLastError, ExpandEnvironmentStrings(PGMChar(APath), PGMChar(Result), Length(Result) + 1) <> 0); // neccessary because ExpandEnvironmentStrings sometimes calculates buffer size too large //while (Length(Result) > 0) and (Result[Length(Result)] = #0) do System.Delete(Result, Length(Result), 1); Result := PGMChar(Result); end; function GMExpandPath(const APath: TGMString; ARootPath: TGMString; const ADirSep: TGMString): TGMString; var chPos: PtrInt; part, path: TGMString; begin if not GMIsRelativePath(APath) then begin Result := APath; Exit; end; if Length(ARootPath) <= 0 then ARootPath := GMExtractPath(GMThisModuleFileName); chPos := 1; path := ''; repeat part := GMNextWord(chPos, APath, cDirSep); if part = '.' then // Nothing, but canr be omitted else if part = '..' then ARootPath := GMDeleteLastWord(ARootPath, cDirSep) else path := GMAppendPath(path, part); until Length(part) <= 0; Result := GMAppendPath(ARootPath, path); end; function GMChangeFileExt(const AFileName, ANewExtension: TGMString): TGMString; var chPos: PtrInt; extension: TGMString; begin Result := AFileName; extension := GMStrip(ANewExtension, '\. '); if extension <> '' then extension := '.' + extension; chPos := GMLastDelimiter('.', AFileName); //if chPos > 0 then Result := Copy(Result, 1, chPos-1) + extension; if chPos = 0 then chPos := Length(Result) + 1; Result := Copy(Result, 1, chPos-1) + extension; end; function GMAppFileWithExtension(const AExtension: TGMString): TGMString; begin Result := GMChangeFileExt(GMApplicationExeName, AExtension); end; function GMFullPathName(const AFileName: TGMString): TGMString; var PNameStart: PGMChar; begin SetLength(Result, LongInt(GetFullPathName(PGMChar(AFileName), 0, nil, PNameStart)) - 1); if Length(Result) <= 0 then Exit; GetFullPathName(PGMChar(AFileName), Length(Result) + 1, PGMChar(Result), PNameStart); Result := GMLongPathName(Result); end; function GMGetProcAddress(const AModuleName: TGMString; const AProcName: AnsiString; const ACheck: Boolean): Pointer; var moduleHandle: HMODULE; lastErr: DWORD; begin //Result := nil; moduleHandle := GetModuleHandle(PGMChar(AModuleName)); if moduleHandle = 0 then begin moduleHandle := LoadLibrary(PGMChar(AModuleName)); if (moduleHandle = 0) and ACheck then begin lastErr := GetLastError; GMAPICheckObjParams('LoadLibrary("'+AModuleName+'")', '', lastErr, moduleHandle <> 0, [PGMChar(AModuleName)]); //GMAPICheckObj('LoadLibrary("'+AModuleName+'")', ': "'+AModuleName+'"', lastErr, moduleHandle <> 0); end; end; if moduleHandle = 0 then Result := nil else Result := GetProcAddress(moduleHandle, PAnsiChar(AProcName)); if not Assigned(Result) and ACheck then raise EGMException.ObjError(GMFormat(RStrRoutineNotFound, [AProcName, AModuleName]), nil, 'GMGetProcAddress'); end; procedure GMLoadProcAddress(const AModuleName: TGMString; const AProcName: AnsiString; var AProc); //var moduleHandle: HMODULE; lastErr: DWORD; begin if Assigned(Pointer(AProc)) then Exit; Pointer(AProc) := GMGetProcAddress(AModuleName, AProcName, True); //if AModuleName = '' then raise EGMException.ObjError(RStrNoModuleName, nil, 'GetProcAddress'); //moduleHandle := GetModuleHandle(PGMChar(AModuleName)); //if moduleHandle = 0 then // begin // moduleHandle := LoadLibrary(PGMChar(AModuleName)); // if moduleHandle = 0 then // begin // lastErr := GetLastError; // GMAPICheckObjParams('LoadLibrary("'+AModuleName+'")', '', lastErr, moduleHandle <> 0, [PGMChar(AModuleName)]); // end; // end; // //Pointer(AProc) := GetProcAddress(moduleHandle, PAnsiChar(AProcName)); //if not Assigned(Pointer(AProc)) then raise EGMException.ObjError(GMFormat(RStrRoutineNotFound, [AProcName, AModuleName]), nil, 'GetProcAddress'); end; var vfWin32GetLongPathName: function (lpszShortPath: PGMChar; lpszLongPath: PGMChar; cchBuffer: DWORD): LongInt; stdcall; function GMLongPathName(const AShortPathName: TGMString): TGMString; // // Windows NT does not have GetLongPathNameA // function GetLongPathNameProcAddr: Pointer; var hKernel32: THandle; begin hKernel32 := GetModuleHandle('kernel32.dll'); // <- kernel32.dll will be loaded already! if hKernel32 <> 0 then Result := GetProcAddress(hKernel32, {$IFDEF UNICODE}'GetLongPathNameW'{$ELSE}'GetLongPathNameA'{$ENDIF}) else Result := nil; end; begin if not Assigned(vfWin32GetLongPathName) then vfWin32GetLongPathName := GetLongPathNameProcAddr; if not Assigned(vfWin32GetLongPathName) then Result := AShortPathName else begin SetLength(Result, vfWin32GetLongPathName(PGMChar(AShortPathName), nil, 0) - 1); if Length(Result) > 0 then GMAPICheckObj('GetLongPathName', '', GetLastError, vfWin32GetLongPathName(PGMChar(AShortPathName), PGMChar(Result), Length(Result) + 1) <> 0) else // GetLongPathName only works for existing files! Result := AShortPathName; end; end; procedure GMSplitParameterStr(AParameterStr: PGMChar; var ADestParams: TGMStringArray); var pCh, pStart: PGMChar; inStr1, inStr2: Boolean; prevCh: TGMChar; procedure AddParamater; var paramValue: TGMString; begin SetString(paramValue, pStart, pCh - pStart); pStart := pCh + 1; if Length(paramValue) > 0 then begin SetLength(ADestParams, Length(ADestParams)+1); ADestParams[High(ADestParams)] := paramValue; end; end; begin pCh := AParameterStr; SetLength(ADestParams, 0); if pCh = nil then Exit; inStr1 := False; inStr2 := False; pStart := pCh; prevCh := #0; while pCh^ <> #0 do begin // for correct parsing of doubled quotes inside strings, doubled appearances must be replaced by single ones // Test: "something ""wrong?""" if inStr1 then begin inStr1 := (pCh^ <> '"') {or (prevCh = '"')}; end // <- Don't use backslash escaping here it would break: /DataDir="C:\" /NoProgess else if inStr2 then begin inStr2 := (pCh^ <> '''') {or (prevCh = '''')}; end // <- Don't use backslash escaping here it would break: /DataDir="C:\" /NoProgess else case pCh^ of '"': begin inStr1 := True; end; '''': begin inStr2 := True; end; ' ', #9, #10, #13: begin case prevCh of ' ', #9, #10, #13: ; // <- Nothing! But can't be omitted! else AddParamater; end; pStart := pCh + 1; end; else // if prevCh = ' ' then pStart := pCh; case prevCh of ' ', #9, #10, #13: pStart := pCh; end; end; prevCh := pCh^; Inc(pCh); end; AddParamater; end; function GMParseCommandLine(var ADestParams: TGMStringArray): TGMString; var i: Integer; begin GMSplitParameterStr(GetCommandLine, ADestParams); if Length(ADestParams) > 0 then begin Result := GMRemoveQuotes(ADestParams[Low(ADestParams)]); for i:=Low(ADestParams) to High(ADestParams)-1 do ADestParams[i] := ADestParams[i+1]; SetLength(ADestParams, Length(ADestParams)-1); end; end; function GMStringToUtf8(const AValue: UnicodeString): AnsiString; begin SetLength(Result, Length(AValue)*4); if Length(AValue) <= 0 then Exit; SetLength(Result, WideCharToMultiByte(CP_UTF8, 0, PWideChar(AValue), Length(AValue), PAnsiChar(Result), Length(Result), nil, nil)); if Length(Result) <= 0 then GMApiCheckObj('GMStringToUtf8', '', GetLastError, False); end; function GMUtf8ToString(const AValue: AnsiString): UnicodeString; begin SetLength(Result, Length(AValue)); if Length(AValue) <= 0 then Exit; SetLength(Result, MultiByteToWideChar(CP_UTF8, 0, PAnsiChar(AValue), Length(AValue), PWideChar(Result), Length(Result))); if Length(Result) <= 0 then GMApiCheckObj('GMUtf8ToString', '', GetLastError, False); end; function APILayeredWinAttrProcAddr: Pointer; var HUser32: THandle; begin HUser32 := GetModuleHandle('user32.dll'); if HUser32 <> 0 then Result := GetProcAddress(HUser32, 'SetLayeredWindowAttributes') else Result := nil; end; function GMCanUseLayeredWindows: Boolean; begin //Result := GMWinVersion >= wvWin2000; Result := APILayeredWinAttrProcAddr <> nil; end; function GMSetLayeredWindowAttributes(Wnd: HWnd; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): BOOL; var APILayeredWinAttrProc: function (Wnd: HWnd; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): BOOL; stdcall; // // Windows 95/98/ME does not have SetLayeredWindowAttributes // //function APILayeredWinAttrProcAddr: Pointer; //var HUser32: THandle; //begin // HUser32 := GetModuleHandle('user32.dll'); // if HUser32 <> 0 then Result := GetProcAddress(HUser32, 'SetLayeredWindowAttributes') else Result := nil; //end; begin //if vUser32Dll = nil then vUser32Dll := TGMDLLHandleObj.Create('user32.dll'); //if vUser32Dll.Handle = 0 then Exit; //DllProc := GetProcAddress(vUser32Dll.Handle, 'SetLayeredWindowAttributes'); @APILayeredWinAttrProc := APILayeredWinAttrProcAddr; if Assigned(APILayeredWinAttrProc) then Result := APILayeredWinAttrProc(Wnd, crKey, bAlpha, dwFlags) else Result := False; end; function GMFileHasExtension(const AFileName, FileExtension: TGMString): Boolean; begin Result := GMSameText(GMStrip(ExtractFileExt(AFileName), ' .'), FileExtension); end; function GMParentDir(const APath: TGMString): TGMString; var chPos: PtrInt; begin //Result := APath; chPos := GMLastDelimiter(cDirSep, APath); if chPos > 0 then Result := Copy(APath, 1, chPos-1) else Result := ''; end; function GMTermPath(const Path: TGMString; const Separator: TGMString): TGMString; begin Result := GMStripRight(Path, cDirSep + cWhiteSpace + ',.;'); if Length(Result) > 0 then Result := Result + Separator; end; function GMExeVersionInformation(const AVersionInfoKey: TGMVersionResInfo): TGMString; begin Result := GMFileVersionInfo(GMApplicationExeName, AVersionInfoKey); end; function GMFileVersionInfo(const AFileName: TGMString; const VersionInfoKey: TGMVersionResInfo; const AAnsiData: Boolean): TGMString; var Buffer, Value: Pointer; Dummy, BufSize, ValueSize: DWORD; function SwapLongInt(Value: LongInt): LongInt; begin Result := ((Value and $0000FFFF) shl 16) or ((Value and -65536) shr 16); // $FFFF0000 end; begin Result := ''; BufSize := GetFileVersionInfoSize(PGMChar(AFileName), Dummy); if BufSize <= 0 then Exit; Buffer := AllocMem(BufSize); try if GetFileVersionInfo(PGMChar(AFileName), 0, BufSize, Buffer) then if VersionInfoKey <> viFileVersion then begin if AAnsiData then begin if VerQueryValueA(Buffer, '\VarFileInfo\Translation', Value, ValueSize) and (ValueSize >= 4) then if VerQueryValueA(Buffer, PAnsiChar(AnsiString(GMFormat('\StringFileInfo\%.8x\%s', [SwapLongInt(LongInt(Value^)), cVersionInfoKeysA[VersionInfoKey]]))), Value, ValueSize) and (ValueSize > 0) then Result := PAnsiChar(Value); // SetString(Result, PGMChar(Value), ValueSize); end else if VerQueryValue(Buffer, '\VarFileInfo\Translation', Value, ValueSize) and (ValueSize >= 4) then if VerQueryValue(Buffer, PGMChar(GMFormat('\StringFileInfo\%.8x\%s', [SwapLongInt(LongInt(Value^)), cVersionInfoKeys[VersionInfoKey]])), Value, ValueSize) and (ValueSize > 0) then Result := PGMChar(Value); // SetString(Result, PGMChar(Value), ValueSize); end else if VerQueryValue(Buffer, '\', Value, ValueSize) then Result := GMFormat('%d.%d.%d.%d', [Hiword(((TVSFixedFileInfo(Value^)).dwFileVersionMS)), Loword(((TVSFixedFileInfo(Value^)).dwFileVersionMS)), Hiword(((TVSFixedFileInfo(Value^)).dwFileVersionLS)), Loword(((TVSFixedFileInfo(Value^)).dwFileVersionLS))]); finally FreeMem(Buffer); end; end; function GMExecutableForDocExt(DocExt: TGMString): TGMString; var RegKey: IGMRegKey; ProgId: TGMString; ValueNames: TGMStringArray; begin Result := ''; DocExt := GMStrip(DocExt, cWhiteSpace + cDirSep + '.:*'); if DocExt <> '' then DocExt := '.' + DocExt; if Length(DocExt) = 0 then Exit{$IFDEF FPC}(''){$ENDIF}; RegKey := TGMRegKey.Create(True); if RegKey.Obj.OpenKey(HKEY_CLASSES_ROOT, '\' + DocExt) then begin ProgId := RegKey.Obj.ReadString(''); if (Length(ProgId) = 0) and RegKey.Obj.OpenKey(HKEY_CLASSES_ROOT, '\' + DocExt + '\OpenWithProgIds') then begin RegKey.Obj.ReadValueNames(ValueNames); if Length(ValueNames) > 0 then ProgId := ValueNames[0]; end; if (ProgId <> '') and RegKey.Obj.OpenKey(HKEY_CLASSES_ROOT, GMFormat('\%s\shell\open\command', [ProgId])) then Result := GMStrip(RegKey.Obj.ReadString(''), cWhiteSpace); end; end; {function GMFindOleServerForClassId(const ClassId: TGUID; var OleServer: TGMString; var IconIndex: LongInt): Boolean; const CSeparators = '\'; cStripChars = CSeparators + cWhiteSpace + '"'','; var Registry: TRegistry; chPos, IconIdx: LongInt; ValueStr: TGMString; begin Result := False; try Registry := TRegistry.Create(KEY_READ); try Registry.RootKey := HKEY_CLASSES_ROOT; if Registry.OpenKey(GMFormat('\%s\%s\%s', ['CLSID', GMGuidToString(ClassId), 'LocalServer32']), False) then begin OleServer := GMExpandEnvironmentStrings(Registry.ReadString('')); Result := OleServer <> ''; end; if Result and Registry.OpenKey(GMFormat('\%s\%s\%s', ['CLSID', GMGuidToString(ClassId), 'DefaultIcon']), False) then begin ValueStr := Registry.ReadString(''); chPos := Length(ValueStr); IconIdx := GMStrToInt(GMMakeDezInt(GMPreviousWord(chPos, ValueStr, ','), IconIndex)); if CompareText(GMStrip(GMPreviousWord(chPos, ValueStr, CSeparators), cStripChars), GMStrip(GMLastWord(OleServer, CSeparators), cStripChars)) = 0 then IconIndex := IconIdx; end; finally Registry.Free; end; except end; end;} {function GMExecutableForDocExt(DocExt: TGMString): TGMString; var Registry: TRegistry; ProgId: TGMString; begin DocExt := GMStrip(DocExt, cWhiteSpace + cDirSep + '.:*'); if DocExt <> '' then DocExt := '.' + DocExt; if DocExt <> '' then begin Registry := TRegistry.Create(KEY_READ); try Registry.RootKey := HKEY_CLASSES_ROOT; if Registry.OpenKey('\' + DocExt, False) then begin ProgId := Registry.ReadString(''); if (ProgId <> '') and Registry.OpenKey(GMFormat('\%s\shell\open\command', [ProgId]), False) then Result := GMStrip(Registry.ReadString(''), cWhiteSpace); end; finally Registry.Free; end; end; end;} //function GMFileTimeToLocalTime(const Value: TDateTime; const Caller: TObject): TDateTime; //var UTCSystemTime, LocalSystemTime: TSystemTime; UTCFileTime, LocalFileTime: TFileTime; //begin //// //// Based on time zone and daylight saving data of the date/time when the function is called! //// //DateTimeToSystemTime(Value, UTCSystemTime); //GMAPICheckObj('SystemTimeToFileTime', '', GetLastError, SystemTimeToFileTime(UTCSystemTime, UTCFileTime), Caller); //GMApiCheckObj('FileTimeToLocalFileTime', '', GetLastError, FileTimeToLocalFileTime(UTCFileTime, LocalFileTime), Caller); //GMAPICheckObj('FileTimeToSystemTime', '', GetLastError, FileTimeToSystemTime(LocalFileTime, LocalSystemTime), Caller); //Result := SystemTimeToDateTime(LocalSystemTime); //end; //function GMLocalTimeToFileTime(const Value: TDateTime; const Caller: TObject): TDateTime; //var UTCSystemTime, LocalSystemTime: TSystemTime; UTCFileTime, LocalFileTime: TFileTime; //begin //// //// Based on time zone and daylight saving data of the date/time when the function is called! //// //DateTimeToSystemTime(Value, LocalSystemTime); //GMAPICheckObj('SystemTimeToFileTime', '', GetLastError, SystemTimeToFileTime(LocalSystemTime, LocalFileTime), Caller); //GMApiCheckObj('LocalFileTimeToFileTime', '', GetLastError, LocalFileTimeToFileTime(LocalFileTime, UTCFileTime), Caller); //GMAPICheckObj('FileTimeToSystemTime', '', GetLastError, FileTimeToSystemTime(UTCFileTime, UTCSystemTime), Caller); //Result := SystemTimeToDateTime(UTCSystemTime); //end; function GMGetTimeZoneInfoByRegistryKeyName(const ATimeZoneRegKeyName: TGMString; var ATimeZoneData: TIME_ZONE_INFORMATION): Boolean; type REG_TZI_FORMAT = record Bias: LONG; StandardBias: LONG; DaylightBias: LONG; StandardDate: SYSTEMTIME; DaylightDate: SYSTEMTIME; end; var timeZoneRegKey: IGMRegKey; tzi: REG_TZI_FORMAT; readSize: DWORD; strWVal: UnicodeString; begin Result := False; timeZoneRegKey := TGMRegKey.Create(True); if timeZoneRegKey.Obj.OpenKey(HKEY_LOCAL_MACHINE, '\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Time Zones\' + ATimeZoneRegKeyName) then begin readSize := timeZoneRegKey.Obj.ReadBinary('TZI', @tzi, SizeOf(tzi)); //Assert(readSize = SizeOf(tzi)); Result := readSize = SizeOf(tzi); if Result then begin ATimeZoneData.Bias := tzi.Bias; ATimeZoneData.StandardBias := tzi.StandardBias; ATimeZoneData.DaylightBias := tzi.DaylightBias; ATimeZoneData.StandardDate := tzi.StandardDate; ATimeZoneData.DaylightDate := tzi.DaylightDate; strWVal := timeZoneRegKey.Obj.ReadString('Std'); lstrcpynw(ATimeZoneData.StandardName, PWideCHar(strWVal), SizeOf(ATimeZoneData.StandardName) div SizeOf(WideChar)); strWVal := timeZoneRegKey.Obj.ReadString('Dlt'); lstrcpynw(ATimeZoneData.DaylightName, PWideCHar(strWVal), SizeOf(ATimeZoneData.DaylightName) div SizeOf(WideChar)); // ATimeZoneData.StandardName := timeZoneRegKey.Obj.ReadString('Std'); // ATimeZoneData.DaylightName := timeZoneRegKey.Obj.ReadString('Dlt'); end; end; end; function GMUTCToLocalTime(const AUtcTime: TDateTime; const ALocalTimeZone: PTIME_ZONE_INFORMATION; const ACaller: TObject): TDateTime; var utcTime, localTime: TSystemTime; begin //FillByte(utcTime, SizeOf(utcTime), 0); utcTime := Default(TSystemTime); DateTimeToSystemTime(AUtcTime, utcTime); //FillByte(localTime, SizeOf(localTime), 0); localTime := Default(TSystemTime); GMAPICheckObj('SystemTimeToTzSpecificLocalTime', '', GetLastError, SystemTimeToTzSpecificLocalTime(ALocalTimeZone, utcTime, localTime), ACaller); Result := SystemTimeToDateTime(localTime); end; function GMLocalTimeToUTC(const ALocalTime: TDateTime; const ALocalTimeZone: PTIME_ZONE_INFORMATION; const ACaller: TObject): TDateTime; var utcTime, localTime: TSystemTime; begin //FillByte(localTime, SizeOf(localTime), 0); localTime := Default(TSystemTime); DateTimeToSystemTime(ALocalTime, localTime); //FillByte(utcTime, SizeOf(utcTime), 0); utcTime := Default(TSystemTime); GMAPICheckObj('TzSpecificLocalTimeToSystemTime', '', GetLastError, TzSpecificLocalTimeToSystemTime(ALocalTimeZone, localTime, utcTime), ACaller); Result := SystemTimeToDateTime(utcTime); end; function GMDateTimeToFileTime(const AValue: TDateTime; const ACaller: TObject): TFileTime; var sysTime: TSystemTime; {$IFDEF FPC}{$push}{$WARN 5060 off : Function result variable does not seem to be initialized}{$ENDIF} begin Result := Default(TFileTime); DateTimeToSystemTime(AValue, sysTime); GMAPICheckObj('SystemTimeToFileTime', '', GetLastError, SystemTimeToFileTime(sysTime, Result), ACaller); end; {$IFDEF FPC}{$pop}{$ENDIF} function GMFileTimeToDateTime(const AValue: TFileTime; const ACaller: TObject): TDateTime; var sysTime: TSystemTime; begin GMAPICheckObj('FileTimeToSystemTime', '', GetLastError, FileTimeToSystemTime(AValue, sysTime), ACaller); Result := SystemTimeToDateTime(sysTime); end; function GMUnixTimeToDateTime(const AUnixTime: Int64): TDateTime; begin Result := (AUnixTime / 86400) + cUnixStartDate; end; function GMUnixTimeFromDateTime(const ADateTime: TDateTime): Int64; begin Result := Round((ADateTime - cUnixStartDate) * 86400); end; function GMIsRelativePath(const APath: TGMString): Boolean; begin Result := (Length(APath) > 0) and not GMIsDelimiter(cDirSep, APath, 1) and (GMStrLScan(PGMChar(APath), ':', Length(APath)) = nil); end; function GMExtractFileName(const AFilePath: TGMString): TGMString; var i: Integer; begin i := GMLastDelimiter(cDirSep + ':', AFilePath); Result := Copy(AFilePath, i + 1, Length(AFilePath) - i); end; function GMExtractPath(const AFilePath: TGMString): TGMString; var i: Integer; begin i := GMLastDelimiter(cDirSep + ':', AFilePath); Result := Copy(AFilePath, 1, i); end; function GMExtractPathWithoutDrive(const AFilePath: TGMString): TGMString; var i, Start: Integer; begin //Start := Pos(':', AFilePath); start := GMStrLScanPos(AFilePath, ':', 1); i := GMLastDelimiter(cDirSep, AFilePath); Result := Copy(AFilePath, Start+1, i-Start); end; function GMExtractFileExt(const AFilePath: TGMString): TGMString; var i: Integer; begin i := GMLastDelimiter(cDirSep + '.:', AFilePath); if (i > 0) and (AFilePath[i] = '.') then Result := Copy(AFilePath, i+1, Length(AFilePath)-i) else Result := ''; end; function GMExtractFileBaseName(const AFilePath: TGMString): TGMString; var i: Integer; begin Result := GMExtractFileName(AFilePath); i := GMLastDelimiter('.', Result); if i > 0 then Result := Copy(Result, 1, i-1); // else Result := ''; end; function GMExtractDrive(const AFilePath: TGMString): TGMString; var i: Integer; begin i := GMStrLScanPos(AFilePath, ':', 1); if i <= Length(AFilePath) then Result := Copy(AFilePath, 1, i-1) else Result := ''; end; function GMIntWithThousandSep(const Value: Int64): TGMString; var ValueAsDouble: Double; begin ValueAsDouble := Value; Result := GMFormat('%.0n', [ValueAsDouble]); end; function GMFileSizeAsString(const FileSize: Int64): TGMString; begin if FileSize < $400 then Result := GMFormat('%d Byte', [FileSize]) else if (FileSize >= $400) and (FileSize < $100000) then Result := GMFormat('%d KB', [(FileSize + $400 -1) div $400]) else if (FileSize >= $100000) and (FileSize < $40000000) then Result := GMFormat('%f MB', [FileSize / $100000]) else Result := GMFormat('%f GB', [FileSize / $40000000]) end; function GMFileAttrAsString(const FileEntry: IGMFileProperties; const Separator: TGMString = ', '): TGMString; begin if FileEntry = nil then Exit{$IFDEF FPC}(''){$ENDIF}; Result := ''; if faCompressed in FileEntry.Attributes then Result := GMStringJoin(Result, Separator, GMFileAttributeName(faCompressed)); if faHidden in FileEntry.Attributes then Result := GMStringJoin(Result, Separator, GMFileAttributeName(faHidden)); if faReadOnly in FileEntry.Attributes then Result := GMStringJoin(Result, Separator, GMFileAttributeName(faReadOnly)); if faSystem in FileEntry.Attributes then Result := GMStringJoin(Result, Separator, GMFileAttributeName(faSystem)); if faArchive in FileEntry.Attributes then Result := GMStringJoin(Result, Separator, GMFileAttributeName(faArchive)); if faEncrypted in FileEntry.Attributes then Result := GMStringJoin(Result, Separator, GMFileAttributeName(faEncrypted)); end; function GMFileEntryAsString(const FileEntry: IGMFileProperties; const Separator: TGMString = ', '): TGMString; var path, attrStr: TGMString; begin if FileEntry = nil then Exit{$IFDEF FPC}(''){$ENDIF}; path := GMExtractPath(FileEntry.FileName); Result := GMExtractFileName(FileEntry.FileName); if FileEntry.CreationTime > 0 then Result := GMStringJoin(Result, Separator, GMFormat(RStrFileCreatedFmt, [DateTimeToStr(FileEntry.CreationTime)])); if FileEntry.LastWriteTime > 0 then Result := GMStringJoin(Result, Separator, GMFormat(RStrFileModifiedFmt, [DateTimeToStr(FileEntry.LastWriteTime)])); if FileEntry.SizeInBytes >= 0 then Result := GMStringJoin(Result, Separator, GMFormat(RStrFileSizeFmt, [GMFileSizeAsString(FileEntry.SizeInBytes)])); attrStr := GMFileAttrAsString(FileEntry, Separator); if Length(attrStr) > 0 then Result := GMStringJoin(Result, Separator, GMFormat(RStrFileAttrFmt, [attrStr])); if Length(path) > 0 then Result := GMStringJoin(Result, Separator, GMFormat(RStrInFolderFmt, [path])); end; function GMFindDataFileSize(const FindData: TWin32FindData): Int64; var sizeHigh: Int64; begin sizeHigh := FindData.nFileSizeHigh; if sizeHigh > 0 then sizeHigh := sizeHigh shl 32; Result := sizeHigh + FindData.nFileSizeLow; end; function GMIsValidFileName(const AFileName, AInvalidChars: TGMString): Boolean; var i: LongInt; begin Result := GMStrip(AFileName, cWhiteSpace) <> ''; if Result then for i:=1 to Length(AFileName) do if GMIsDelimiter(AInvalidChars, AFileName, i) then begin Result := False; Break; end; //Result := not GMIsOneOfStrings(GMStrip(AFileName), ['', '\', '/', '.', '..']); end; //function GMStrToInt(const AValue: TGMString): LongInt; //var convertCode: Integer; //begin // Val(AValue, Result, convertCode); // if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidIntStrFmt, [AValue, convertCode]), nil, 'GMStrToInt (LongInt)'); //end; { $IFDEF DELPHI9} function GMStrToInt(const AValue: TGMString): Int64; var convertCode: Integer; begin Val(AValue, Result, convertCode); if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidIntStrFmt, [AValue, convertCode]), nil, 'GMStrToInt (Int64)'); end; { $ENDIF} function GMStrToInt32(const AValue: TGMString): LongInt; var convertCode: Integer; begin Val(AValue, Result, convertCode); if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidIntStrFmt, [AValue, convertCode]), nil, 'GMStrToInt32'); end; function GMStrToUInt32(const AValue: TGMString): LongWord; var convertCode: Integer; begin Val(AValue, Result, convertCode); if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidIntStrFmt, [AValue, convertCode]), nil, 'GMStrToUInt32'); end; function GMStrToInt64(const AValue: TGMString): Int64; var convertCode: Integer; begin Val(AValue, Result, convertCode); if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidIntStrFmt, [AValue, convertCode]), nil, 'GMStrToInt64'); end; {$IFDEF DELPHI9} function GMStrToUInt64(const AValue: TGMString): QWord; var convertCode: Integer; begin Val(AValue, Result, convertCode); if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidIntStrFmt, [AValue, convertCode]), nil, 'GMStrToUInt64'); end; {$ENDIF} function GMStrToSingle(AValue: TGMString): Single; var convertCode: Integer; begin AValue := GMReplaceChars(AValue, ',', '.'); // GMDeleteChars(AValue, ThousandSeparator) Val(AValue, Result, convertCode); if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidFloatStrFmt, [AValue, convertCode]), nil, 'GMStrToSingle'); end; function GMStrToDouble(AValue: TGMString): Double; var convertCode: Integer; begin AValue := GMReplaceChars(AValue, ',', '.'); // GMDeleteChars(AValue, ThousandSeparator) Val(AValue, Result, convertCode); if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidFloatStrFmt, [AValue, convertCode]), nil, 'GMStrToDouble'); end; function GMStrToCurrency(AValue: TGMString): Currency; var convertCode: Integer; extendedVal: Extended; begin AValue := GMReplaceChars(AValue, ',', '.'); // GMDeleteChars(AValue, ThousandSeparator) Val(AValue, extendedVal, convertCode); if convertCode <> 0 then raise EGMConvertException.ObjError(GMFormat(RStrInvalidCurrencyStrFmt, [AValue, convertCode]), nil, 'GMStrToCurrency'); Result := extendedVal; end; {$IFDEF DELPHI9} function GMIntToStr(const AValue: QWord): TGMString; begin Str(AValue, Result); end; {$ENDIF} function GMIntToStr(const AValue: LongInt): TGMString; begin Str(AValue, Result); end; function GMIntToStr(const AValue: Int64): TGMString; begin Str(AValue, Result); end; // Trim trailing spaces and zeros function TrimFloat(const AFloatValue: TGMString; const AKeepPointZero: Boolean = True): TGMString; const cIncEndPos: array [Boolean] of PtrInt = (-1, 1); var pCh: PGMChar; startChPos, endChPos: PtrInt; begin Result := AFloatValue; pCh := GMStrCLScan(PGMChar(Result), ' ', Length(Result)); if pCh <> nil then startChPos := pCh - PGMChar(Result) + 1 else startChPos := 1; endChPos := Length(Result); while (endChPos >= 1) and (Result[endChPos] in [' ', '0']) do Dec(endChPos); if GMIsInRange(endChPos, 1, Length(Result)-1) and (Result[endChPos] = '.') then endChPos += cIncEndPos[AKeepPointZero]; // Inc(endChPos); Result := Copy(Result, startChPos, endChPos - startChPos +1); end; function GMSingleToStr(const AValue: Single; const AWidth: Integer; const APrecision: Integer): TGMString; begin if AWidth >= 0 then begin if APrecision >= 0 then Str(AValue:AWidth:APrecision, Result) else Str(AValue:AWidth, Result); end else if APrecision < 0 then Str(AValue, Result) else begin Str(AValue:30:APrecision, Result); Result := TrimFloat(Result); end; end; function GMDoubleToStr(const AValue: Double; const AWidth: Integer; const APrecision: Integer): TGMString; begin if AWidth >= 0 then begin if APrecision >= 0 then Str(AValue:AWidth:APrecision, Result) else Str(AValue:AWidth, Result); end else if APrecision < 0 then Str(AValue, Result) else begin Str(AValue:30:APrecision, Result); Result := TrimFloat(Result); end; end; function GMExtendedToStr(const AValue: Extended; const AWidth: Integer; const APrecision: Integer): TGMString; begin if AWidth >= 0 then begin if APrecision >= 0 then Str(AValue:AWidth:APrecision, Result) else Str(AValue:AWidth, Result); end else if APrecision < 0 then Str(AValue, Result) else begin Str(AValue:30:APrecision, Result); Result := TrimFloat(Result); end; end; function GMCurrencyToStr(const AValue: Currency; const AWidth: Integer; const APrecision: Integer): TGMString; begin if AWidth >= 0 then begin if APrecision >= 0 then Str(AValue:AWidth:APrecision, Result) else Str(AValue:AWidth, Result); end else if APrecision < 0 then Str(AValue, Result) else begin Str(AValue:30:APrecision, Result); Result := TrimFloat(Result); end; end; function GMIntToHexStr(AValue: LongInt): TGMString; var i: Integer; begin Result := ''; for i:=1 to SizeOf(AValue) do begin Result := '' + cStrHexConvertChars[((AValue and $F0) shr 4)+1] + cStrHexConvertChars[(AValue and $F)+1] + Result; AValue := AValue shr 8; end; end; function GMIntToHexStr(AValue: Int64): TGMString; var i: Integer; begin Result := ''; for i:=1 to SizeOf(AValue) do begin Result := '' + cStrHexConvertChars[((AValue and $F0) shr 4)+1] + cStrHexConvertChars[(AValue and $F)+1] + Result; AValue := AValue shr 8; end; end; {$IFDEF DELPHI9} function GMIntToHexStr(AValue: QWord): TGMString; begin Result := GMIntToHexStr(Int64(AValue)); end; {$ENDIF} //var i: Integer; //begin // Result := ''; // for i:=1 to SizeOf(AValue) do // begin // Result := '' + cStrHexConvertChars[((AValue and $F0) shr 4)+1] + cStrHexConvertChars[(AValue and $F)+1] + Result; // AValue := AValue shr 8; // end; //end; type RGMStrFormatData = record IsValid: Boolean; ArgIndex: Integer; LeftJustified: Boolean; Width: Integer; Precision: Integer; FormatChar: TGMChar; end; function TVarRecTypeName(const AVarRecType: Integer): TGMString; begin case AVarRecType of vtInteger: Result := 'Integer'; vtBoolean: Result := 'Boolean'; vtChar: Result := 'Char'; vtExtended: Result := 'Extended'; vtString: Result := 'String'; vtPointer: Result := 'Pointer'; vtPChar: Result := 'PChar'; vtObject: Result := 'Object'; vtClass: Result := 'Class'; vtWideChar: Result := 'WideChar'; vtPWideChar: Result := 'PWideChar'; vtAnsiString: Result := 'AnsiString'; vtCurrency: Result := 'Currency'; vtVariant: Result := 'Variant'; vtInterface: Result := 'Interface'; vtWideString: Result := 'WideString'; {$IFDEF DELPHI9} vtUnicodeString: Result := 'UnicodeString'; vtQWord: Result := 'QWord'; {$ENDIF} vtInt64: Result := 'Int64'; else Result := GMIntToStr(AVarRecType); end; end; function StrScanPos(AChPos: Integer; const AStr: TGMString; ACh: TGMChar): Integer; begin Result := AChPos; while (Result <= Length(AStr)) and (AStr[Result] <> ACh) do Inc(Result); end; function GMFormat(const AFormatStr: TGMString; const Args: array of const): TGMString; var startPos, fmtStartPos, endPos: Integer; fmtData: RGMStrFormatData; fmtArgIdx: Integer; procedure InvalidFormatChar(AFormatCh: TGMChar); begin raise EGMFmtException.ObjError(RStrInvalidFmtChar +': '+AFormatCh, nil, {$I %CurrentRoutine%}); end; procedure InvalidArgTypeForFormatChar(AFormatCh: TGMChar; AArgType: Integer); begin raise EGMFmtException.ObjError(RStrInvalidArgTypeFmtChar +': "'+AFormatCh+'", '+TVarRecTypeName(AArgType), nil, {$I %CurrentRoutine%}); end; function ParseFormatToken(AChPos: Integer; var AResultStr: TGMString): Integer; var token: TGMString; ch: TGMChar; begin //FillByte(fmtData, SizeOf(fmtData), 0); fmtData := Default(RGMStrFormatData); fmtData.ArgIndex := -1; fmtData.Width := -1; Result := AChPos; token := ''; Inc(Result); while Result <= Length(AResultStr) do begin ch := GMLoCase(AResultStr[Result]); case ch of '%': begin System.Delete(AResultStr, Result, 1); Break; end; 's', 'd', 'u', 'p', 'x', 'e', 'f', 'g', 'n', 'm': begin fmtData.Precision := GMStrToInt(GMMakeDezInt(token, 0)); fmtData.FormatChar := ch; fmtData.IsValid := True; Inc(Result); Break; end; ':': begin fmtData.ArgIndex := GMStrToInt(GMMakeDezInt(token, -1)); token := ''; end; '.': begin fmtData.Width := GMStrToInt(GMMakeDezInt(token, -1)); token := ''; end; '-': fmtData.LeftJustified := True; else begin if not GMIsDigit(ch) then raise EGMFmtException.ObjError(RStrFmtDigitExpected +': '+ch, nil, {$I %CurrentRoutine%}); token := token + AResultStr[Result]; end; end; Inc(Result); end; end; function PaddValue(const AValue: TGMString; const ALength: Integer; const APaddChar: TGMChar; ARight: Boolean): TGMString; var paddStr: TGMString; i: LongInt; begin Result := AValue; if Length(Result) >= ALength then Exit; SetLength(paddStr, Max(0, ALength - Length(Result))); for i:=1 to Length(paddStr) do paddStr[i] := APaddChar; if ARight then Result := Result + paddStr else Result := paddStr + Result; end; procedure ReplaceFormatString; var argIdx: Integer; insertStr: TGMString; function ApplyWidth(const AValue: TGMString): TGMString; begin Result := AValue; if fmtData.Precision > 0 then Result := PaddValue(Result, fmtData.Precision, '0', False); if fmtData.Width > 0 then Result := PaddValue(Result, fmtData.Width, ' ', fmtData.LeftJustified); end; function BuildArgInsertStr: TGMString; var argData: TVarRec; begin Result := ''; argData := Args[argIdx]; case fmtData.FormatChar of 's': case argData.VType of vtPChar: Result := argData.VPChar; vtString: Result := PShortString(argData.VString)^; vtWideChar: Result := argData.VWideChar; vtPWideChar: Result := argData.VPWideChar; vtAnsiString: Result := AnsiString(argData.VAnsiString); vtWideString: Result := WideString(argData.VWideString); vtChar: Result := argData.VChar; vtClass: Result := argData.VClass.ClassName; vtVariant: Result := GMVarToStr(argData.VVariant^); {$IFDEF DELPHI9} vtUnicodeString: Result := UnicodeString(argData.VUnicodeString); {$ENDIF} else InvalidArgTypeForFormatChar(fmtData.FormatChar, argData.VType); end; 'd', 'u': case argData.VType of vtInteger: Result := GMIntToStr(argData.VInteger); vtInt64: Result := GMIntToStr(argData.VInt64^); vtPointer: Result := GMIntToStr(PtrInt(argData.VPointer)); vtInterface: Result := GMIntToStr(PtrInt(argData.VInterface)); vtObject: Result := GMIntToStr(PtrInt(argData.VObject)); vtPChar: Result := GMIntToStr(PtrInt(argData.VPChar)); vtPWideChar: Result := GMIntToStr(PtrInt(argData.VPWideChar)); vtAnsiString: Result := GMIntToStr(PtrInt(argData.VAnsiString)); vtWideString: Result := GMIntToStr(PtrInt(argData.VWideString)); vtClass: Result := GMIntToStr(PtrInt(argData.VClass)); {$IFDEF DELPHI9} vtQWord: Result := GMIntToStr(argData.VQWord^); vtUnicodeString: Result := GMIntToStr(PtrInt(argData.VUnicodeString)); {$ENDIF} else InvalidArgTypeForFormatChar(fmtData.FormatChar, argData.VType); end; 'p', 'x': case argData.VType of vtInteger: Result := GMIntToHexStr(argData.VInteger); vtInt64: Result := GMIntToHexStr(argData.VInt64^); vtPointer: Result := GMIntToHexStr(PtrInt(argData.VPointer)); vtInterface: Result := GMIntToHexStr(PtrInt(argData.VInterface)); vtObject: Result := GMIntToHexStr(PtrInt(argData.VObject)); vtPChar: Result := GMIntToHexStr(PtrInt(argData.VPChar)); vtPWideChar: Result := GMIntToHexStr(PtrInt(argData.VPWideChar)); vtAnsiString: Result := GMIntToHexStr(PtrInt(argData.VAnsiString)); vtWideString: Result := GMIntToHexStr(PtrInt(argData.VWideString)); vtClass: Result := GMIntToHexStr(PtrInt(argData.VClass)); {$IFDEF DELPHI9} vtQWord: Result := GMIntToHexStr(argData.VQWord^); vtUnicodeString: Result := GMIntToHexStr(PtrInt(argData.VUnicodeString)); {$ENDIF} else InvalidArgTypeForFormatChar(fmtData.FormatChar, argData.VType); end; 'e', 'f', 'g', 'n', 'm': case argData.VType of vtExtended: Result := GMExtendedToStr(argData.VExtended^, fmtData.Width, fmtData.Precision); vtCurrency: Result := GMCurrencyToStr(argData.VCurrency^, fmtData.Width, fmtData.Precision); vtInteger: Result := GMExtendedToStr(argData.VInteger, fmtData.Width, fmtData.Precision); vtInt64: Result := GMExtendedToStr(argData.VInt64^, fmtData.Width, fmtData.Precision); {$IFDEF DELPHI9} vtQWord: Result := GMExtendedToStr(argData.VQWord^, fmtData.Width, fmtData.Precision); {$ENDIF} else InvalidArgTypeForFormatChar(fmtData.FormatChar, argData.VType); end; else InvalidFormatChar(fmtData.FormatChar); end; end; begin if fmtData.ArgIndex >= 0 then argIdx := fmtData.ArgIndex else begin argIdx := fmtArgIdx; Inc(fmtArgIdx); end; if (argIdx >= Low(Args)) and (argIdx <= High(Args)) then begin insertStr := ApplyWidth(BuildArgInsertStr); System.Delete(Result, fmtStartPos, endPos - fmtStartPos); System.Insert(insertStr, Result, fmtStartPos); endPos := fmtStartPos + Length(insertStr); end; end; begin Result := AFormatStr; startPos := 1; fmtArgIdx := 0; repeat fmtStartPos := StrScanPos(startPos, Result, '%'); if fmtStartPos > Length(Result) then Break; endPos := ParseFormatToken(fmtStartPos, Result); if fmtData.IsValid then ReplaceFormatString; startPos := endPos; until False; end; procedure GMCheckIsValidFileName(const AFileName, AInvalidChars: TGMString; const Caller: TObject; const CallingName: TGMString); begin if not GMIsValidFileName(AFileName, AInvalidChars) then raise EGMException.ObjError(GMFormat(RStrInvalidFileName, [AFileName, AInvalidChars]), Caller, CallingName); end; function GMModuleErrorMessage(const ModuleFileName: TGMString; const ErrorCode: DWORD): TGMString; begin SetLength(Result, cFormatBufSize); SetLength(Result, FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(GetModuleHandle(PGMChar(ModuleFileName))), ErrorCode, 0, PGMChar(Result), Length(Result) + 1, nil)); end; function GMIsStringMatch(const AValue, AMask: TGMString; const AMatchEmptyMask: Boolean; const ACharIndex: LongInt): Boolean; var pValueCh, pMaskCh, pValueResCh, pMaskResCh: PGMChar; begin if Length(AMask) <= 0 then begin Result := AMatchEmptyMask; Exit; end; Result := AMask = '*'; // or (AMask = '*.*') if Result or (Length(AValue) <= 0) then Exit; GMCheckIntRange(RStrCharPos, ACharIndex, 1, Length(AValue)); pValueCh := PGMChar(@AValue[ACharIndex]); pMaskCh := PGMChar(AMask); pValueResCh := nil; pMaskResCh := nil; repeat repeat case pMaskCh^ of #0: begin Result := pValueCh^ = #0; if Result or (pValueResCh = nil) or (pMaskResCh = nil) then Exit; pValueCh := pValueResCh; pMaskCh := pMaskResCh; Break; end; '*': begin Inc(pMaskCh); pMaskResCh := pMaskCh; Break; end; '?': begin if pValueCh^ = #0 then Exit; Inc(pValueCh); Inc(pMaskCh); end; else begin if pValueCh^ = #0 then Exit; if pValueCh^ <> pMaskCh^ then begin if (pValueResCh = nil) or (pMaskResCh = nil) then Exit; pValueCh := pValueResCh; pMaskCh := pMaskResCh; Break; end else begin Inc(pValueCh); Inc(pMaskCh); end; end; end; until False; repeat case pMaskCh^ of #0: begin Result := True; Exit; end; '*': begin Inc(pMaskCh); pMaskResCh := pMaskCh; end; '?': begin if pValueCh^ = #0 then Exit; Inc(pValueCh); Inc(pMaskCh); end; else begin repeat if pValueCh^ = #0 then Exit; if pValueCh^ = pMaskCh^ then Break; Inc(pValueCh); until False; Inc(pValueCh); pValueResCh := pValueCh; Inc(pMaskCh); Break; end; end; until False; until False; end; function GMWalkPathMask(const AValue, AMask, ADirSeparators: TGMString; var AWalkData: RPathWalkData): Boolean; begin with AWalkData do begin ValueChPos := 1; MaskChPos := 1; repeat ValuePart := GMNextWord(ValueChPos, AValue, ADirSeparators); MaskPart := GMNextWord(MaskChPos, AMask, ADirSeparators); Result := GMIsStringMatch(ValuePart, MaskPart, True); // Length(ValuePart) <= 0 until not Result or (Length(ValuePart) <= 0) or (Length(MaskPart) <= 0); end; end; function GMIsAbsPathMatch(const AValue, AMask, ADirSeparators: TGMString): Boolean; var walkData: RPathWalkData; begin //FillByte(walkData, SizeOf(walkData), 0); walkData := Default(RPathWalkData); Result := GMWalkPathMask(AValue, AMask, ADirSeparators, walkData) and (Length(walkData.MaskPart) <= 0); //Result := Result and (Length(walkData.ValuePart) <= 0) and (Length(walkData.MaskPart) <= 0); // (AAllowPartialMatch or (Length(MaskPart) <= 0)); // <- the whole mask must be matched! end; //function GMIsAbsPathMatch(const AValue, AMask, ADirSeparators: TGMString; AIsPartialMatch: PBoolean): Boolean; //var valuePart, maskPart: TGMString; valueChPos, maskchPos: PtrInt; //begin //valueChPos := 1; maskchPos := 1; //repeat // valuePart := GMNextWord(valueChPos, AValue, ADirSeparators); // maskPart := GMNextWord(maskchPos, AMask, ADirSeparators); // Result := GMIsStringMatch(valuePart, maskPart, True); // Length(valuePart) <= 0 //until not Result or (Length(valuePart) <= 0) or (Length(maskPart) <= 0); //if AIsPartialMatch <> nil then AIsPartialMatch^ := (Length(valuePart) <= 0) and (Length(maskPart) > 0); //Result := Result and (Length(valuePart) <= 0) and (Length(maskPart) <= 0); // (AAllowPartialMatch or (Length(maskPart) <= 0)); // <- the whole mask must be matched! //end; function GMIsPathEndMatch(const AValue, AMask, ADirSeparators: TGMString): Boolean; var valuePart, maskPart: TGMString; valueChPos, maskchPos: PtrInt; begin valueChPos := Length(AValue); maskchPos := Length(AMask); repeat valuePart := GMPreviousWord(valueChPos, AValue, ADirSeparators, False); Dec(valueChPos); maskPart := GMPreviousWord(maskchPos, AMask, ADirSeparators, False); Dec(maskchPos); Result := GMIsStringMatch(valuePart, maskPart, True); until not Result or (valueChPos < 1) or (maskchPos < 1); //until not Result or (Length(valuePart) <= 0) or (Length(maskPart) <= 0); Result := Result and (maskchPos < 1); // <- the whole mask must be matched! end; function GMIsPathMatch(const AValue, AMask, ADirSeparators: TGMString): Boolean; begin if (Length(AMask) > 0) and GMIsDelimiter(ADirSeparators, AMask, 1) then Result := GMIsAbsPathMatch(AValue, AMask, ADirSeparators) else Result := GMIsPathEndMatch(AValue, AMask, ADirSeparators); end; function GMIsSingleMaskMatch(const AFileName, ASingleMask, ADirSeparators: TGMString; const AMatchCase: Boolean): Boolean; begin if AMatchCase then Result := GMIsPathMatch(AFileName, ASingleMask, ADirSeparators) else Result := GMIsPathMatch(AnsiUpperCase(AFileName), AnsiUpperCase(ASingleMask), ADirSeparators); end; function GMIsAnyMaskMatch(const AFileName, AMultiMask, ADirSeparators: TGMString; const AMatchEmptyMask: Boolean; const AMatchCase: Boolean; const AMaskSeparators: TGMString): Boolean; var chPos: PtrInt; singleMask: TGMString; begin Result := (Length(AMultiMask) <= 0) and AMatchEmptyMask; chPos:=1; repeat singleMask := GMNextWord(chPos, AMultiMask, AMaskSeparators); // singleMask := GMStrip(GMNextWord(chPos, AMultiMask, AMaskSeparators), cWhiteSpace); if Length(singleMask) > 0 then Result := GMIsSingleMaskMatch(AFileName, singleMask, ADirSeparators, AMatchCase); until Result or (Length(singleMask) <= 0); end; { ---------------------------- } { ---- Type Check/Convert ---- } { ---------------------------- } function GMBoolToStr(AValue: Boolean; const AStrFalse: TGMString = ''; const AStrTrue: TGMString = ''): TGMString; begin if AValue then if AStrTrue = '' then Result := RStrTrue else Result := AStrTrue else if AStrFalse = '' then Result := RStrFalse else Result := AStrFalse; end; function GMVarToStr(const AValue: OleVariant): TGMString; begin if TVarData(AValue).VType in [varNull, varEmpty] then Result := '' else Result := AValue; end; function GMVarToQuotedStr(const AValue: OleVariant): TGMString; begin //if TVarData(AValue).VType in [varNull, varEmpty] then Result := '' else Result := AValue; Result := GMQuote(GMVarToStr(AValue), '"', '"'); end; function GMStrToBool(const AValue: TGMString): Boolean; begin Result := (Length(AValue) > 0) and GMIsDelimiter('tT1wWyYsSqQ', AValue, 1); end; function GMVarToNULLStr(const AValue: OleVariant): TGMString; begin if VarIsEmpty(AValue) or VarIsNull(AValue) then Result := cStrNull else Result := AValue; end; function GMStrToNULLVar(const AValue: TGMString): Variant; begin if AValue = '' then Result := Null else Result := AValue; end; function GMDateIsNull(const AValue: TDateTime): Boolean; begin Result := Trunc(AValue) = 0; end; function GMTimeIsNull(const AValue: TDateTime): Boolean; begin Result := AValue = Trunc(AValue); end; function GMVarToNum(const AValue: OleVariant; const ADefaultValue: LongInt): OleVariant; begin if {VarIsEmpty(AValue) or} VarIsNull(AValue) then Result := ADefaultValue else Result := AValue; end; function GMVarToInt(const AValue: OleVariant; const ADefaultValue: LongInt): LongInt; begin if {VarIsEmpty(AValue) or} VarIsNull(AValue) then Result := ADefaultValue else Result := AValue; end; function GMVarToFloat(const AValue: OleVariant; const ADefaultValue: double): OleVariant; begin if {VarIsEmpty(AValue) or} VarIsNull(AValue) then Result := ADefaultValue else Result := AValue; end; function GMVarIsNullOrEmpty(const AValue: Variant): Boolean; begin Result := VarIsNull(AValue) or VarIsEmpty(AValue); end; { ---------------------------- } { ---- Rectangle Routines ---- } { ---------------------------- } function GMRect(const ALeft, ATop, ARight, ABottom: LongInt): TRect; begin with Result do begin Left := ALeft; Top := ATop; Right := ARight; Bottom := ABottom; end; end; function GMRect(const ATopLeft, ABottomRight: TPoint): TRect; overload; begin with Result do begin TopLeft := ATopLeft; BottomRight := ABottomRight; end; end; function GMPoint(const AX, AY: LongInt): TPoint; begin with Result do begin X := AX; Y := AY; end; end; function GMSize(const cx, cy: LongInt): TSize; begin Result.cx := cx; Result.cy := cy; end; function GMRectSize(const ARect: TRect): TPoint; begin Result := GMPoint(ARect.Right - ARect.Left, ARect.Bottom - ARect.Top); end; function GMCenterExtent(const AValue: LongInt; const ASize: TPoint): TPoint; var size: LongInt; begin size := ASize.y - ASize.x; Result.x := ASize.x + (size - AValue) div 2; Result.y := Result.x + AValue; end; function GMCenterExtentInRect(const ASize: TPoint; const ARect: TRect): TRect; var RSize: TPoint; begin RSize := GMRectSize(ARect); Result.Left := ARect.Left + (RSize.x - ASize.x) div 2; Result.Right := Result.Left + ASize.x; Result.Top := ARect.Top + (RSize.y - ASize.y) div 2; Result.Bottom := Result.Top + ASize.y; end; function GMCenterRectInRect(const Inner, Outer: Trect): TRect; begin Result := GMCenterExtentInRect(GMRectSize(Inner), Outer); end; function GMInflateRect(const R: TRect; const dx: LongInt = 0; const dy: LongInt = 0): TRect; begin Result := R; InflateRect(Result, dx, dy); end; function GMRectIntersection(const R1, R2: TRect): TRect; {$IFDEF FPC}{$push}{$WARN 5060 off : Function result variable does not seem to be initialized}{$ENDIF} begin Result := Default(TRect); IntersectRect(Result, R1, R2); end; {$IFDEF FPC}{$pop}{$ENDIF} function GMRectUnion(const R1, R2: TRect): TRect; {$IFDEF FPC}{$push}{$WARN 5060 off : Function result variable does not seem to be initialized}{$ENDIF} begin Result := Default(TRect); UnionRect(Result, R1, R2); end; {$IFDEF FPC}{$pop}{$ENDIF} function GMMoveRect(const R: TRect; const Delta: TPoint): TRect; begin Result := GMMoveRect(R, Delta.x, Delta.y); end; function GMMoveRect(const R: TRect; const dx: LongInt = 0; const dy: LongInt = 0): TRect; begin Result := R; OffsetRect(Result, dx, dy); //if dx <> 0 then begin Inc(Result.Left, dx); Inc(Result.Right, dx); end; //if dy <> 0 then begin Inc(Result.Top, dy); Inc(Result.Bottom, dy); end; end; function GMRectModifiedBy(const R: TRect; const dLeft: LongInt = 0; const dTop: LongInt = 0; const dRight: LongInt = 0; const dBottom: LongInt = 0): TRect; begin Result := R; if dLeft <> 0 then Inc(Result.Left, dLeft); if dTop <> 0 then Inc(Result.Top, dTop); if dRight <> 0 then Inc(Result.Right, dRight); if dBottom <> 0 then Inc(Result.Bottom, dBottom); end; function GMLayoutRect(const RDraw: TRect; const LayoutSize: TPoint; const HAlignment: TGMHorizontalAlignment; const VAlignment: TGMVerticalAlignment): TRect; var DrawSize: TPoint; begin Result := RDraw; DrawSize := GMRectSize(RDraw); case HAlignment of haLeft: begin Result.Left := RDraw.Left; Result.Right := Min(RDraw.Right, Result.Left + LayoutSize.x); end; haCenter: begin Result.Left := Max(RDraw.Left, RDraw.Left + (DrawSize.x - LayoutSize.x) div 2); Result.Right := Min(RDraw.Right, Result.Left + LayoutSize.x); end; haRight: begin Result.Right := RDraw.Right; Result.Left := Max(RDraw.Left, Result.Right - LayoutSize.x); end; //else raise EGMException.ObjError(MsgUnknownValue('TGMHorizontalAlignment', Ord(HAlignment)), nil, {$I %CurrentRoutine%}); end; case VAlignment of vaTop: begin Result.Top := RDraw.Top; Result.Bottom := Min(RDraw.Bottom, Result.Top + LayoutSize.y); end; vaCenter: begin Result.Top := Max(RDraw.Top, RDraw.Top + (DrawSize.y - LayoutSize.y) div 2); Result.Bottom := Min(RDraw.Bottom, Result.Top + LayoutSize.y); end; vaBottom: begin Result.Bottom := RDraw.Bottom; Result.Top := Max(RDraw.Top, Result.Bottom - LayoutSize.y); end; //else raise EGMException.ObjError(MsgUnknownValue('TGMVerticalAlignment', Ord(VAlignment)), nil, {$I %CurrentRoutine%}); end; end; function GMPointOffsBy(const APoint: TPoint; const ADelta: LongInt): TPoint; begin Result := APoint; Inc(Result.x, ADelta); Inc(Result.y, ADelta); end; function GMAddPoints(const APointA, APointB: TPoint; const AScale: SmallInt = 1): TPoint; begin Result := GMPoint(APointA.x + APointB.x * AScale, APointA.y + APointB.y * AScale); end; function GMEqualPoints(const PointA, PointB: TPoint): Boolean; begin Result := (PointA.x = PointB.x) and (PointA.y = PointB.y); end; procedure GMExchangeLongInt(var AValue1, AValue2: LongInt); var Tmp: LongInt; begin Tmp := AValue1; AValue1 := AValue2; AValue2 := Tmp; end; procedure GMExchangePtrInt(var AValue1, AValue2: PtrInt); var Tmp: PtrInt; begin Tmp := AValue1; AValue1 := AValue2; AValue2 := Tmp; end; { ---------------------- } { ---- window Stack ---- } { ---------------------- } function GMTopwindow: HWnd; begin if Length(vGMModalWndStack) > 0 then Result := vGMModalWndStack[High(vGMModalWndStack)] else Result := 0; end; procedure GMPushModalDlgWnd(AWnd: HWnd); var threadSync: RGMCriticalSectionLock; begin threadSync.Lock(vCSWndStack); AWnd := GMDlgRootWindow(AWnd); if not IsWindow(AWnd) or (AWnd = GMTopWindow) then Exit; SetLength(vGMModalWndStack, Length(vGMModalWndStack) + 1); vGMModalWndStack[High(vGMModalWndStack)] := AWnd; //if vGMTopWindow <> 0 then // begin // SetLength(vGMModalWndStack, Length(vGMModalWndStack) + 1); // vGMModalWndStack[High(vGMModalWndStack)] := vGMTopWindow; // end; //vGMTopWindow := AWnd; end; function GMPopModalDlgWnd: HWnd; var threadSync: RGMCriticalSectionLock; begin threadSync.Lock(vCSWndStack); //Result := vGMTopWindow; if Length(vGMModalWndStack) = 0 then Result := 0 else begin Result := vGMModalWndStack[High(vGMModalWndStack)]; SetLength(vGMModalWndStack, Length(vGMModalWndStack)-1); end; //if Length(vGMModalWndStack) = 0 then vGMTopWindow := 0 else // begin // vGMTopWindow := vGMModalWndStack[High(vGMModalWndStack)]; // SetLength(vGMModalWndStack, Length(vGMModalWndStack)-1); // end; end; function GMWndStackCloseAll(const AStopAtWnd: HWnd; const AModalResult: LongInt; const AMessage: LongInt): LongInt; var threadSync: RGMCriticalSectionLock; i: LongInt; function CloseWnd(const AWnd: HWnd; var ACloseResult: LongInt): Boolean; begin Result := (AWnd <> AStopAtWnd) or (AStopAtWnd = 0); // and (AWnd <> 0) if not Result then Exit; ACloseResult := SendMessage(AWnd, AMessage, AModalResult, 0); end; begin // Modal dialogs better don't remove themself from the stack in WM_NCDESTROY. // This would be a nice "while vGMTopWindow <> 0" loop here, but wont work with // third party dialogs pushed on the stack. // // Use SendMessage to wait for window animation to finish. // Processing WM_CLOSE will post a UM_DONEMODAL message for each closed window. // The UM_DONEMODAL GMMessages will unwind the call stack by leaving GMModalMessageLoop // after we return from here. GMModalMessageLoop also removes dialog window handles // from vGMModalWndStack on termination. // threadSync.Lock(vCSWndStack); Result := AModalResult; //if vGMTopWindow <> 0 then Result := SendMessage(vGMTopWindow, AMessage, AModalResult, 0); //for i:=High(vGMModalWndStack) downto Low(vGMModalWndStack) do Result := SendMessage(vGMModalWndStack[i], AMessage, AModalResult, 0); //if (vGMTopWindow <> 0) and not CloseWnd(vGMTopWindow, Result) then Exit; for i:=High(vGMModalWndStack) downto Low(vGMModalWndStack) do if not CloseWnd(vGMModalWndStack[i], Result) then Exit; end; { ---------------------------- } { ---- Registered Classes ---- } { ---------------------------- } function GMIsClass(AClassInstance, AClass: TClass): Boolean; begin //Result := False; Result := AClass = nil; if AClass <> nil then while (AClassInstance <> nil) and not Result do begin Result := AClassInstance = AClass; AClassInstance := AClassInstance.ClassParent; end; end; function GMIsClassByName(const AObj: TObject; const AClass: TClass): Boolean; //function GMIsClassByName(const Obj: TObject; const ClassName: TGMString): Boolean; var ObjClass: TClass; // // The "is" and "as" operators dont work across DLL boundaries, this one does // begin if (AObj = nil) or (AClass = nil) then Result := False else begin ObjClass := AObj.ClassType; while (ObjClass <> nil) and not GMSameText(ObjClass.ClassName, AClass.ClassName) do ObjClass := ObjClass.ClassParent; Result := ObjClass <> nil; end; end; { ----------------------------------- } { ---- Compiler Design Interface ---- } { ----------------------------------- } function GMGetOrdinalProperty(const AObject: TObject; const PropertyName: TGMString; var PropertyValue: LongInt): Boolean; var PropertyInfo: PPropInfo; begin PropertyValue := 0; if (AObject = nil) or (PropertyName = '') then Result := False else begin PropertyInfo := GetPropInfo(AObject.ClassInfo, PropertyName); if PropertyInfo = nil then Result := False else begin PropertyValue := GetOrdProp(AObject, PropertyInfo); Result := True; end; end; end; function GMGetStringProperty(const AObject: TObject; const PropertyName: TGMString; var PropertyValue: TGMString): Boolean; var PropertyInfo: PPropInfo; begin PropertyValue := ''; if (AObject = nil) or (PropertyName = '') then Result := False else begin PropertyInfo := GetPropInfo(AObject.ClassInfo, PropertyName); if PropertyInfo = nil then Result := False else begin PropertyValue := GetStrProp(AObject, PropertyInfo); Result := True; end; end; end; function GMSetStringProperty(const AObject: TObject; const PropertyName: TGMString; const PropertyValue: TGMString): Boolean; var PropertyInfo: PPropInfo; begin if (AObject = nil) or (PropertyName = '') then Result := False else begin PropertyInfo := GetPropInfo(AObject.ClassInfo, PropertyName); if PropertyInfo = nil then Result := False else begin SetStrProp(AObject, PropertyInfo, PropertyValue); Result := True; end; end; end; function GMCheckGetEnumValFromName(const ATypInfo: PTypeInfo; const AEnumValueName: TGMString): Integer; var TypData: PTypeData; i: LongInt; validValues: TGMString; begin if ATypInfo = nil then raise EGMException.ObjError(RStrNoTypeInfo, nil, {$I %CurrentRoutine%}); if ATypInfo.Kind <> tkEnumeration then raise EGMException.ObjError(GMFormat(RStrNotEnumTypeFmt, [ATypInfo.Name, GetEnumName(TypeInfo(TTypeKind), Ord(ATypInfo.Kind)), GetEnumName(TypeInfo(TTypeKind), Ord(tkEnumeration))]), nil, {$I %CurrentRoutine%}); Result := GetEnumValue(ATypInfo, AEnumValueName); TypData := GetTypeData(ATypInfo); validValues := ''; if (TypData <> nil) and not GMIsInRange(Result, TypData.MinValue, TypData.MaxValue) then begin for i:=TypData.MinValue to TypData.MaxValue do validValues := GMStringJoin(validValues, ', ', GetEnumName(ATypInfo, i)); raise EGMException.ObjError(GMFormat(RStrInvalidEnumValFmt, [AEnumValueName, ATypInfo.Name, validValues]), nil, {$I %CurrentRoutine%}); end; end; {$IFDEF FPC} procedure GMAssignObjProperties(const Source, Dest: TObject; const TypeKinds: TTypeKinds); var i: LongInt; PropList: PPropList; begin if (Source = nil) or (Dest = nil) then Exit; PropList := nil; try for i:=0 to GetPropList(Source, PropList)-1 do if PropList^[i].PropType^.Kind in TypeKinds then SetPropValue(Dest, PropList^[i].Name, GetPropValue(Source, PropList^[i].Name, False)); finally if PropList <> nil then FreeMem(PropList); end; end; {$ELSE} {$IFDEF DELPHI6} procedure GMAssignObjProperties(const Source, Dest: TObject; const TypeKinds: TTypeKinds); var i: LongInt; PropList: PPropList; begin if (Source = nil) or (Dest = nil) then Exit; PropList := nil; try for i:=0 to GetPropList(Source, PropList)-1 do if PropList^[i].PropType^^.Kind in TypeKinds then SetPropValue(Dest, PropList^[i].Name, GetPropValue(Source, PropList^[i].Name, False)); finally if PropList <> nil then FreeMem(PropList); end; end; {$ELSE} procedure GMAssignObjProperties(const Source, Dest: TObject; const TypeKinds: TTypeKinds); var Count, i: LongInt; PropList: PPropList; begin if (Source = nil) or (Dest = nil) then Exit; Count := GetTypeData(PTypeInfo(Source.ClassInfo))^.PropCount; if Count > 0 then begin GetMem(PropList, Count * SizeOf(Pointer)); try GetPropInfos(PTypeInfo(Source.ClassInfo), PropList); for i:=0 to Count-1 do if PropList^[i].PropType^^.Kind in TypeKinds then SetPropValue(Dest, PropList^[i].Name, GetPropValue(Source, PropList^[i].Name, False)); finally FreeMem(PropList); end; end; end; {$ENDIF} {$ENDIF} { ------------------------------ } { ---- Arithmetic functions ---- } { ------------------------------ } function MakeLongInt(Lo, Hi: SmallInt): LongInt; begin Result := Lo or Hi shl 16; end; function Min(A, B: LongInt): LongInt; begin if A < B then Result := A else Result := B; end; function Max(A, B: LongInt): LongInt; begin if A > B then Result := A else Result := B; end; function Min(A, B: Int64): Int64; begin if A < B then Result := A else Result := B; end; function Max(A, B: Int64): Int64; begin if A > B then Result := A else Result := B; end; function GMIsInRange(const Value, Min, Max: LongInt): Boolean; begin Result := (Value >= Min) and (Value <= Max); end; function GMIsInRange(const Value, Min, Max: Int64): Boolean; begin Result := (Value >= Min) and (Value <= Max); end; function GMBoundedInt(Value, Min, Max: LongInt; const MinBased: Boolean = True): LongInt; begin if Min > Max then if MinBased then Max := Min else Min := Max; if Value < Min then Result := Min else if Value > Max then Result := Max else Result := Value; end; function GMBoundedInt(Value, Min, Max: Int64; const MinBased: Boolean = True): Int64; begin if Min > Max then if MinBased then Max := Min else Min := Max; if Value < Min then Result := Min else if Value > Max then Result := Max else Result := Value; end; function GMBoundedDouble(Value, Min, Max: Double; const MinBased: Boolean = True): Double; begin if Min > Max then if MinBased then Max := Min else Min := Max; if Value < Min then Result := Min else if Value > Max then Result := Max else Result := Value; end; //function GMAbsInt(const Value: LongInt): LongInt; //begin // if Value >= 0 then Result := Value else Result := -Value; //end; //function GMAbsPtrInt(AValue: PtrInt): PtrInt; //begin // if AValue > 0 then Result := AValue else Result := -AValue; //end; function GMAddPtr(const APointer: Pointer; const AOffset: LongInt): Pointer; begin {$IFDEF FPC} Result := LPByte(APointer) + AOffset; {$ELSE} Result := PAnsiChar(APtr) + AOffset; {$ENDIF} end; function GMAddPtr(const APointer: Pointer; const AOffset: Int64): Pointer; begin {$IFDEF FPC} Result := LPByte(APointer) + AOffset; {$ELSE} Result := PAnsiChar(APtr) + AOffset; {$ENDIF} end; function GMAlignedValue(const AValue, AlignDelta: PtrInt): PtrInt; begin // works for any alignments not only powers of 2 if (AlignDelta <= 0) or (AValue = 0) or (AValue mod AlignDelta = 0) then Result := AValue else Result := AValue + (AlignDelta - (AValue mod AlignDelta)); end; { ------------------------ } { ---- Misc Functions ---- } { ------------------------ } function GMAddMsgBoxIcon(const Flags: LongWord; const Severity: TGMSeverityLevel): LongWord; begin Result := Flags; if Result and (mb_IconInformation or mb_IconQuestion or mb_IconExclamation or mb_IconStop) = 0 then Result := Result or cMessageBoxIcon[Severity]; end; function GMDlgRootWindow(const AWnd: HWnd): HWnd; begin Result := AWnd; // Don't check for WS_VISIBLE -> allow invisible windows too! while (Result <> 0) and IsWindow(Result) and (GetWindowLong(Result, GWL_STYLE) and WS_CHILD <> 0) do Result := GetParent(Result); end; function GMActiveProcessWindow: HWnd; var wndProcessId: DWORD; begin // // Note: Using Windows of other threads as parent sometimes causes problems .. // Result := GetForegroundWindow; // <- may be a window of a different process! wndProcessId := GetCurrentProcessId; GetWindowThreadProcessId(Result, @wndProcessId); if wndProcessId <> GetCurrentProcessId then Result := 0; // <- window does not belong to our process! if Result = 0 then Result := GMTopWindow; if Result = 0 then Result := GetActiveWindow; // <- our threads message queue! if not IsWindow(Result) then Result := 0 else Result := GMDlgRootWindow(Result); end; function ActiveDlgWindow(const AWnd: HWnd; const ASearchProcess: Boolean): HWnd; begin //if AWnd = cDfltPrntWnd then Result := vGMTopWindow else Result := AWnd; Result := AWnd; if not IsWindow(Result) then Result := 0; if Result <> 0 then Result := GMDlgRootWindow(Result); if (Result = 0) and ASearchProcess then Result := GMActiveProcessWindow; end; function GMAppRootWindow(const AWnd: HWnd; const SearchProcess: Boolean): HWnd; begin Result := ActiveDlgWindow(AWnd, SearchProcess); while (Result <> 0) and IsWindow(Result) and (GetParent(Result) <> GetDesktopWindow) and (GetParent(Result) <> 0) do Result := GetParent(Result); end; function GMModalDlgParentWnd(const AParentWnd: HWnd = cDfltPrntWnd; const ASearchProcess: Boolean = True): HWnd; begin //if AParentWnd = cDfltPrntWnd then Result := vGMTopWindow else Result := AParentWnd; //if not IsWindow(Result) then Result := 0; //if (Result = 0) and ASearchProcess then Result := GMActiveProcessWindow; //Result := AppRootWindow(Result); Result := GMDlgRootWindow(ActiveDlgWindow(AParentWnd, ASearchProcess)); end; procedure GMRemoveAllMenuItems(const Menu: HMenu); begin if Menu = 0 then Exit; while GetMenuItemCount(Menu) > 0 do GMAPICheckObj('DeleteMenu', '', GetLastError, DeleteMenu(Menu, 0, MF_BYPOSITION)); end; function GMWindowsMsgBox(const Msg: TGMString; const Severity: TGMSeverityLevel; Flags: LongWord; const ParentWnd: HWnd): LongInt; begin //if Severity <> svNone then Flags := GMAddMsgBoxIcon(Flags, Severity) or MB_SETFOREGROUND {or MB_TASKMODAL}; Result := MessageBox(GMModalDlgParentWnd(ParentWnd), PGMChar(GMTerminateStr(Msg)), PGMChar(GMSeverityName(Severity)), Flags); end; function GMPointerSizeInBits: Integer; begin Result := SizeOf(Pointer) * 8; end; function GMPointerSizeAsString(const AAddLeft, AAddRight: TGMString): TGMString; begin Result := AAddLeft + GMIntToStr(GMPointersizeInBits) + '-Bit' + AAddRight; end; function GMIs64BitOS: BOOL; const cStrIsWow64Process = 'IsWow64Process'; type TIsWow64Process = function (Handle:THandle; var IsWow64: BOOL): BOOL; stdcall; var hKernel32: THandle; IsWow64Process: TIsWow64Process; //IsWow64: BOOL; begin // // If this is 64-bit code the OS must be 64-bit! // if SizeOf(Pointer) = 8 then begin Result := True; Exit; end; Result := False; hKernel32 := LoadLibrary('kernel32.dll'); if hKernel32 = 0 then Exit; try @IsWow64Process := GetProcAddress(hkernel32, cStrIsWow64Process); if Assigned(IsWow64Process) then GMApiCheckObj(cStrIsWow64Process, '', GetLastError, IsWow64Process(GetCurrentProcess, Result)); finally FreeLibrary(hKernel32); end; end; function GMWinVersion: TGMWinVersion; var VersionInfo: TOSVersionInfo; begin //Result := wvUnknown; Result := wvInvalid; //FillByte(VersionInfo, SizeOf(VersionInfo), 0); VersionInfo := Default(TOSVersionInfo); VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo); if GetVersionEx(VersionInfo) then case VersionInfo.dwPlatformId of VER_PLATFORM_WIN32s: Result := wvWin_3_11; VER_PLATFORM_WIN32_WINDOWS: if (VersionInfo.dwMajorVersion > 4) or ((VersionInfo.dwMajorVersion = 4) and (VersionInfo.dwMinorVersion > 0)) then Result := wvWin98 else Result := wvWin95; VER_PLATFORM_WIN32_NT: case VersionInfo.dwMajorVersion of 0..4: Result := wvWinNT; 5: case VersionInfo.dwMinorVersion of 0: Result := wvWin2000; 1: Result := wvWinXP; 2: Result := wvServer2003; end; 6: //Result := wvVista; case VersionInfo.dwMinorVersion of 0: Result := wvVista; 1: Result := wvWin7_8; 2: Result := wvWin10_11; else Result := wvUnknown; end; else Result := wvUnknown; end; end; end; function GMHResultFromWin32(const AWinErrorCode, AFacilitycode: LongWord): HRESULT; // // Looks like Borland Windows.HResultFromWin32 is not correct, this is the correct C/C++ definition for it: // // #define FACILITY_WIN32 7 // #define HRESULT_FROM_WIN32(x) ((HRESULT)(x) <= 0 ? ((HRESULT)(x)) \ // : ((HRESULT) (((x) & 0x0000FFFF) | (FACILITY_WIN32 << 16) | 0x80000000))) begin Result := HRESULT(AWinErrorCode); if Result > 0 then Result := ((Result and $0000FFFF) or (HRESULT(AFacilitycode) shl 16) or HRESULT($80000000)); end; {function GMWin32FromHResult(const HRCode: HResult): LongWord; begin if (HResultFacility(HRCode) = FACILITY_WIN32) or (HResultFacility(HRCode) = FACILITY_WINDOWS) then Result := LongWord(HRCode and $0000FFFF) else Result := LongWord(HRCode); end;} function GMIsFatalException(const AExceptObject: TObject): Boolean; var hrCode: HResult; begin hrCode := GMGetObjHRCode(AExceptObject, E_UNEXPECTED); Result := (hrCode = E_ABORT) or (HRCode = GMHResultFromWin32(ERROR_CANCELLED)) or GMIsClassByName(AExceptObject, EAbort) or GMIsClassByName(AExceptObject, EStackOverflow) or GMIsClassByName(AExceptObject, EOutOfMemory) or GMIsClassByName(AExceptObject, EControlC); // EAccessViolation EHeapException EInOutError EInvalidPointer EExternalException EBusError EPrivilege end; function GMAskExceptionContinue(const AException: TObject; const ErrorAction: TGMErrorAction; AskContinue: TGMString; const ParentWnd: HWnd): Boolean; begin if AException = nil then Result := True else //if GMIsClassByName(AException, EAbort) then Result := False else if GMIsFatalException(AException) then Result := False else case ErrorAction of eaContinue: Result := True; eaAskUser: begin if AskContinue = '' then AskContinue := RStrContinueOperation; Result := vfGMMessageBox(GMFormat('%s'+c2NewLine+'%s ?', [GMMsgFromExceptObj(AException), AskContinue]), svWarning, mb_YesNo or MB_TASKMODAL, ParentWnd) = IdYes; end; else Result := False; end; end; function GMDfltExecExceptionDlg(const AException: TObject; const AParentWnd: HWnd): LongInt; var ExceptInfo: IGMExceptionInformation; begin ExceptInfo := TGMExceptionInformation.CreateFromObj(AException, True); // MB_TASKMODAL Result := vfGMMessageBox(GMBuildExceptionMsg(ExceptInfo), ExceptInfo.SeverityLevel, 0, GMModalDlgParentWnd(AParentWnd)); end; function GMDfltHrExceptionHandler(const AException: TObject; const AParentWnd: HWnd; const ADefaultCode: HResult): HResult; var threadSync: RGMCriticalSectionLock; begin try threadSync.Lock(gCSExceptHandler); GMTraceException(AException); if (AParentWnd <> cNoUIWnd) and not GMIsClassByName(AException, EAbort) and GMAskBoolean(AException, Ord(bevPresentToUI), True) and Assigned(vfGMExecExceptionDlg) then try vfGMExecExceptionDlg(AException, AParentWnd); except end; if GMIsClassByName(AException, EAbort) then Result := E_ABORT else Result := GMGetObjHRCode(AException, ADefaultCode); except Result := ADefaultCode; end; // <- never raise inside exception handler! end; procedure GMShowURL(const AURL: TGMString; const ACaller: TObject); var mousePtrWait: IUnknown; execRetCode: THandle; begin if Length(GMStrip(AURL)) <= 0 then Exit; mousePtrWait := TGMTempCursor.Create(vGMWaitCursor); execRetCode := ShellExecute(0, 'Open', PGMChar(AUrl), nil, nil, SW_SHOWNORMAL); if execRetCode <= 32 then GMAPICheckObj(GMFormat('ShellExecute("Open", "%s")',[AUrl]), '', execRetCode, False, ACaller); end; function GMIsUrl(const AUrl: TGMString): Boolean; var chPos: PtrInt; begin chPos := 1; Result := GMFindOneOfWords(AUrl, '.:<>|/\', ['www', 'http', 'https', 'ftp'], chPos); end; procedure GMCheckIsValidUrl(const AUrl: TGMString; const Caller: TObject; const CallingName: TGMString); begin if not GMIsUrl(AUrl) then raise EGMException.ObjError(GMFormat(RStrInvalidUrlFmt, [AUrl]), Caller, CallingName); end; function GMMousePosition: TPoint; {$IFDEF FPC}{$push}{$WARN 5060 off : Function result variable does not seem to be initialized}{$ENDIF} begin //GMAPICheckObj(GetCursorPos(Result), 'GetCursorPos'); //Result := Default(TRect); if not GetCursorPos(Result) then Result := cNullPoint; end; {$IFDEF FPC}{$pop}{$ENDIF} procedure GMRefreshMouseCursor; var mousePos: TPoint; begin //SendMessage(FHandle, WM_SETCURSOR, WPARAM(FHandle), 0); <- wrong when mouse in not inside! if GetCursorPos(mousePos) then begin // Trigger a WM_SETCURSOR nmessage by moving the mouse back and forth one pixel if mousePos.x > 0 then SetCursorPos(mousePos.x - 1, mousePos.y) else SetCursorPos(mousePos.x + 1, mousePos.y); SetCursorPos(mousePos.x, mousePos.y); end; end; procedure GMSetCaretPos(const ACaretPos: TPoint); begin GMApiCheckObj('SetCaretPos', '', GetLastError, SetCaretPos(ACaretPos.x, ACaretPos.y)); end; function GMCopyToGlobalMem(const PData: Pointer; const DataSize: LongWord; const AllocFlags: LongWord = GMEM_MOVEABLE): HGlobal; var PGlobal: Pointer; begin if (PData = nil) or (DataSize = 0) then Result := 0 else begin Result := GlobalAlloc(AllocFlags, DataSize); GMAPICheckObj('GlobalAlloc', '', GetLastError, Result <> 0); PGlobal := GlobalLock(Result); GMAPICheckObj('GlobalLock', '', GetLastError, PGlobal <> nil); try System.Move(PData^, PGlobal^, DataSize); finally GlobalUnlock(Result); end; end; end; function GMCopyHGlobal(const Handle: HGLOBAL; const AllocFlags: LongWord = GMEM_MOVEABLE): HGLOBAL; var PSrc: Pointer; begin Result := 0; if Handle <> 0 then begin PSrc := GlobalLock(Handle); GMAPICheckObj('GlobalLock', '', GetLastError, PSrc <> nil); try Result := GMCopyToGlobalMem(PSrc, GlobalSize(Handle), AllocFlags); finally GlobalUnlock(Handle); end; end; end; procedure GMFreeAndNil(var Obj); var PObj: TObject; begin PObj := TObject(Obj); TObject(Obj) := nil; // <- clear the reference argument before destroying the object PObj.Free; end; function GMCompareVariants(const ValueA, ValueB: Variant; const MatchCase: Boolean = True): TGMCompareResult; const cCmpFlags: array [Boolean] of LongWord = (NORM_IGNORECASE, 0); begin if ((VarType(ValueA) = varString) or (VarType(ValueA) = varOleStr)) and ((VarType(ValueB) = varString) or (VarType(ValueB) = varOleStr)) then begin Result := GMCompareNames(ValueA, ValueB, cCmpFlags[MatchCase]); end else begin if ValueA = ValueB then Result := crAEqualToB else if ValueA > ValueB then Result := crAGreaterThanB else Result := crALessThanB; end; end; function GMCompareUnionValues(const ValueA, ValueB: RGMUnionValue; const MatchCase: Boolean = True): TGMCompareResult; const cCmpFlags: array [Boolean] of LongWord = (NORM_IGNORECASE, 0); begin if (ValueA.ValueType = uvtString) and (ValueB.ValueType = uvtString) then begin Result := GMCompareNames(ValueA, ValueB, cCmpFlags[MatchCase]); end else begin if ValueA = ValueB then Result := crAEqualToB else if ValueA < ValueB then Result := crALessThanB else Result := crAGreaterThanB; end; end; initialization //TVarData(EmptyParam).VType := varError; //TVarData(EmptyParam).VError := $80020004; // <-- DISP_E_PARAMNOTFOUND gGMMainThreadID := GetCurrentThreadID; gCSExceptHandler := TGMMutex.Create('', False); // <- works best for "machine-gun" exceptions e.g. from a message handler //gCSExceptHandler := TGMMsgCriticalSection.Create(False); //gCSExceptHandler := TGMCriticalSection.Create(True); gCStraceText := TGMCriticalSection.Create(True); gDigitAsNumberSortSupported := GMWinVersion >= wvWin7_8; finalization GMFreeAndNil(gGMTimerList); vCSWndStack := TGMCriticalSection.Create(True); end.