{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: Commonly useful Routines/Objects/Types. | } { | | } { | | } { | Copyright (C) - 1996 - Gerrit Moeller. | } { | | } { | Source code distributed 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 Exit(0); 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 += 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)