{ /*************************************************************************** lclproc.pas ----------- Component Library Code ***************************************************************************/ ***************************************************************************** This file is part of the Lazarus Component Library (LCL) See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** Useful lower level helper functions and classes. } unit LCLProc; {$MODE ObjFPC}{$H+} {$I lcl_defines.inc} {$inline on} interface uses {$IFDEF Darwin}MacOSAll, {$ENDIF} Classes, SysUtils, Math, Types, AVL_Tree, // LazUtils LazFileUtils, LazUtilities, LazMethodList, LazUTF8, LazUTF16, LazLoggerBase, LazTracer, GraphMath, // LCL LCLStrConsts, LCLType; type TMethodList = LazMethodList.TMethodList; { TDebugLCLItemInfo } TDebugLCLItemInfo = class public Item: Pointer; IsDestroyed: boolean; Info: string; CreationStack: TStackTracePointers; // stack trace at creation DestructionStack: TStackTracePointers;// stack trace at destruction function AsString(WithStackTraces: boolean): string; destructor Destroy; override; end; { TDebugLCLItems } TDebugLCLItems = class private FItems: TAvlTree;// tree of TDebugLCLItemInfo FName: string; public constructor Create(const TheName: string); destructor Destroy; override; function FindInfo(p: Pointer; CreateIfNotExists: boolean = false ): TDebugLCLItemInfo; function IsDestroyed(p: Pointer): boolean; function IsCreated(p: Pointer): boolean; function MarkCreated(p: Pointer; const InfoText: string): TDebugLCLItemInfo; procedure MarkDestroyed(p: Pointer); function GetInfo(p: Pointer; WithStackTraces: boolean): string; property Name: string read FName; end; {$IFDEF DebugLCLComponents} var DebugLCLComponents: TDebugLCLItems = nil; {$ENDIF} function CompareDebugLCLItemInfos(Data1, Data2: Pointer): integer; function CompareItemWithDebugLCLItemInfo(Item, DebugItemInfo: Pointer): integer; // sort so that for each i is OnCompare(List[i],List[i+1])<=0 // Deprecated in version 3.99, April 2024. procedure MergeSort(List: TFPList; const OnCompare: TListSortCompare); overload; deprecated 'Use LazUtilities.MergeSort instead'; procedure MergeSort(List: TFPList; StartIndex, EndIndex: integer; const OnCompare: TListSortCompare); overload; deprecated 'Use LazUtilities.MergeSort instead'; procedure MergeSort(List: TStrings; const OnCompare: TStringsSortCompare); overload; deprecated 'Use LazUtilities.MergeSort instead'; function KeyAndShiftStateToKeyString(Key: word; ShiftState: TShiftState): String; function KeyStringIsIrregular(const s: string): boolean; function ShortCutToText(ShortCut: TShortCut): string; inline; // localized output function ShortCutToTextRaw(ShortCut: TShortCut): string; inline; // NOT localized output function TextToShortCut(const ShortCutText: string): TShortCut; inline; // localized input function TextToShortCutRaw(const ShortCutText: string): TShortCut; inline;// NOT localized input function GetCompleteText(const sText: string; iSelStart: Integer; bCaseSensitive, bSearchAscending: Boolean; slTextList: TStrings): string; function IsEditableTextKey(Key: Word): Boolean; // Hooks used to prevent unit circles type TSendApplicationMessageFunction = function(Msg: Cardinal; WParam: WParam; LParam: LParam):Longint; TOwnerFormDesignerModifiedProc = procedure(AComponent: TComponent); var SendApplicationMessageFunction: TSendApplicationMessageFunction=nil; OwnerFormDesignerModifiedProc: TOwnerFormDesignerModifiedProc=nil; function SendApplicationMessage(Msg: Cardinal; WParam: WParam; LParam: LParam):Longint; procedure OwnerFormDesignerModified(AComponent: TComponent); { the LCL interfaces finalization sections are called before the finalization sections of the LCL. Those parts, that should be finalized after the LCL, can be registered here. } procedure RegisterInterfaceInitializationHandler(p: TProcedure); procedure CallInterfaceInitializationHandlers; procedure RegisterInterfaceFinalizationHandler(p: TProcedure); procedure CallInterfaceFinalizationHandlers; // Ampersands function DeleteAmpersands(var Str : String) : Integer; function RemoveAmpersands(const ASource: String): String; function RemoveAmpersands(Src: PChar; var LineLength: Longint): PChar; function CompareHandles(h1, h2: TLCLHandle): integer; function ComparePoints(const p1, p2: TPoint): integer; function CompareCaret(const FirstCaret, SecondCaret: TPoint): integer; // Call debugging procedures in LazLoggerBase and RaiseGDBException in LazTracer. // Deprecated in version 3.99, April 2024. procedure RaiseGDBException(const Msg: string); deprecated 'Use LazTracer.RaiseGDBException instead'; procedure DbgOut(const s: string = ''); overload; deprecated 'Use DebugLogger.DbgOut instead'; procedure DbgOut(Args: array of const); overload; deprecated 'Use DebugLogger.DbgOut instead'; procedure DbgOut(const S: String; Args: array of const); overload; deprecated 'Use DebugLogger.DbgOut instead'; procedure DbgOut(const s1, s2: string; const s3: string = ''; const s4: string = ''; const s5: string = ''; const s6: string = ''; const s7: string = ''; const s8: string = ''; const s9: string = ''; const s10: string = ''; const s11: string = ''; const s12: string = ''; const s13: string = ''; const s14: string = ''; const s15: string = ''; const s16: string = ''; const s17: string = ''; const s18: string = ''); overload; deprecated 'Use DebugLogger.DbgOut instead'; procedure DebugLn(const s: string = ''); overload; deprecated 'Use DebugLogger.DebugLn instead'; procedure DebugLn(Args: array of const); overload; deprecated 'Use DebugLogger.DebugLn instead'; procedure DebugLn(const S: String; Args: array of const); overload; deprecated 'Use DebugLogger.DebugLn instead'; procedure DebugLn(const s1, s2: string; const s3: string = ''; const s4: string = ''; const s5: string = ''; const s6: string = ''; const s7: string = ''; const s8: string = ''; const s9: string = ''; const s10: string = ''; const s11: string = ''; const s12: string = ''; const s13: string = ''; const s14: string = ''; const s15: string = ''; const s16: string = ''; const s17: string = ''; const s18: string = ''); overload; deprecated 'Use DebugLogger.DebugLn instead'; procedure DebugLnEnter(const s: string = ''); overload; deprecated 'Use DebugLogger.DebugLnEnter instead'; procedure DebugLnEnter(Args: array of const); overload; deprecated 'Use DebugLogger.DebugLnEnter instead'; procedure DebugLnEnter(s: string; Args: array of const); overload; deprecated 'Use DebugLogger.DebugLnEnter instead'; procedure DebugLnEnter(const s1, s2: string; const s3: string = ''; const s4: string = ''; const s5: string = ''; const s6: string = ''; const s7: string = ''; const s8: string = ''; const s9: string = ''; const s10: string = ''; const s11: string = ''; const s12: string = ''; const s13: string = ''; const s14: string = ''; const s15: string = ''; const s16: string = ''; const s17: string = ''; const s18: string = ''); overload; deprecated 'Use DebugLogger.DebugLnEnter instead'; procedure DebugLnExit(const s: string = ''); overload; deprecated 'Use DebugLogger.DebugLnExit instead'; procedure DebugLnExit(Args: array of const); overload; deprecated 'Use DebugLogger.DebugLnExit instead'; procedure DebugLnExit(s: string; Args: array of const); overload; deprecated 'Use DebugLogger.DebugLnExit instead'; procedure DebugLnExit (const s1, s2: string; const s3: string = ''; const s4: string = ''; const s5: string = ''; const s6: string = ''; const s7: string = ''; const s8: string = ''; const s9: string = ''; const s10: string = ''; const s11: string = ''; const s12: string = ''; const s13: string = ''; const s14: string = ''; const s15: string = ''; const s16: string = ''; const s17: string = ''; const s18: string = ''); overload; deprecated 'Use DebugLogger.DebugLnExit instead'; procedure CloseDebugOutput; deprecated 'Use DebugLogger.Finish instead'; function DbgS(const c: cardinal): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const i: longint): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const i: int64): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const q: qword): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const r: TRect): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const p: TPoint): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const p: pointer): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const e: extended; MaxDecimals: integer = 999): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const b: boolean): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const s: TComponentState): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const m: TMethod): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgSName(const p: TObject): string; overload; deprecated 'Use LazLoggerBase.DbgSName instead'; function DbgSName(const p: TClass): string; overload; deprecated 'Use LazLoggerBase.DbgSName instead'; function DbgStr(const StringWithSpecialChars: string): string; overload; deprecated 'Use LazLoggerBase.DbgStr instead'; function DbgWideStr(const StringWithSpecialChars: widestring): string; overload; deprecated 'Use LazLoggerBase.DbgWideStr instead'; function dbgMemRange(P: PByte; Count: integer; Width: integer = 0): string; overload; deprecated 'Use LazLoggerBase.dbgMemRange instead'; function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string; overload; deprecated 'Use LazLoggerBase.dbgMemStream instead'; function dbgObjMem(AnObject: TObject): string; overload; deprecated 'Use LazLoggerBase.dbgObjMem instead'; function dbgHex(i: Int64): string; overload; deprecated 'Use LazLoggerBase.dbgHex instead'; function DbgS(const i1,i2,i3,i4: integer): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const Shift: TShiftState): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgS(const ASize: TSize): string; overload; deprecated 'Use LazLoggerBase.Dbgs instead'; function DbgSWindowPosFlags(Flags: UInt): String; function DbgsVKCode(c: word): string; function DbgS(const ATM: TTextMetric): string; function DbgS(const AScrollInfo: TScrollInfo): string; overload; function DbgS(const AVariant: Variant): string; overload; procedure DbgOutThreadLog(const Msg: string); overload; procedure DebuglnThreadLog(const Msg: string); overload; procedure DebuglnThreadLog(Args: array of const); overload; procedure DebuglnThreadLog; overload; procedure DbgSaveData(FileName: String; AData: PChar; ADataSize: PtrUInt); procedure DbgAppendToFile(FileName, S: String); procedure DbgAppendToFileWithoutLn(FileName, S: String); // case..of utility functions function ClassCase(const AClass: TClass; const ACase: array of TClass {; const ADescendant: Boolean = True}): Integer; overload; function ClassCase(const AClass: TClass; const ACase: array of TClass; const ADescendant: Boolean): Integer; overload; // Font function IsFontNameDefault(const AName: string): boolean; inline; procedure ExtractFontFaceSuffixes(var AFontName: string; out AStretch: integer; out AWeight: integer); function ExtractFontWeightSuffix(var AFontName: string; out AWeight: integer): boolean; function AppendFontFaceSuffixes(AFamilyName: string; AStretch: integer; AWeight: integer): string; function GetFontFamilyDefaultStretch(const AFamilyName: string): integer; // Help procedure AddCmdLineParamDesc(var aText: TStringList; aParamOpts: array of string; aDescr: string); implementation const UNKNOWN_VK_PREFIX = 'Word('''; UNKNOWN_VK_POSTFIX = ''')'; var InterfaceInitializationHandlers: TFPList = nil; InterfaceFinalizationHandlers: TFPList = nil; function DeleteAmpersands(var Str : String) : Integer; // Replace all &x with x and return the position of the first accelerator letter in // the resulting Str, meaning the letter following the first & in the original Str. // Double ampersands && are converted to a single & and ignored. var SrcPos, DestPos, SrcLen: Integer; begin Result:=-1; SrcLen:=length(Str); SrcPos:=1; DestPos:=1; while SrcPos<=SrcLen do begin if (Str[SrcPos]='&') and (SrcPos'&') and (Result<1) then // Ignore && as accelerator Result:=DestPos; end; if DestPos '' then Result := Result + '+'; Result := Result + APart; end; var s: string; begin Result := ''; if ssCtrl in ShiftState then AddPart(ifsCtrl); if ssAlt in ShiftState then AddPart(ifsAlt); if ssShift in ShiftState then AddPart(ifsVK_SHIFT); if ssMeta in ShiftState then {$IFDEF LCLcarbon} AddPart(ifsVK_CMD); {$ELSE} AddPart(ifsVK_META); {$ENDIF} if ssSuper in ShiftState then AddPart(ifsVK_SUPER); s := KeyCodeToKeyString(Key, true); // function returned "Word(nnn)" previously, keep this if s = '' then s := UNKNOWN_VK_PREFIX + IntToStr(Key) + UNKNOWN_VK_POSTFIX; AddPart(s); end; function KeyStringIsIrregular(const s: string): boolean; begin Result:=(length(UNKNOWN_VK_PREFIX) '' then begin if ShortCut and scShift <> 0 then Result := Result + KeyCodeToKeyString(scShift, Localized); if ShortCut and scCtrl <> 0 then Result := Result + KeyCodeToKeyString(scCtrl, Localized); if ShortCut and scMeta <> 0 then Result := Result + KeyCodeToKeyString(scMeta, Localized); if ShortCut and scAlt <> 0 then Result := Result + KeyCodeToKeyString(scAlt, Localized); Result := Result + Name; end; end; function ShortCutToText(ShortCut: TShortCut): string; begin Result:=ShortCutToTextGeneric(ShortCut, true); end; function ShortCutToTextRaw(ShortCut: TShortCut): string; begin Result:=ShortCutToTextGeneric(ShortCut, false); end; function TextToShortCutGeneric(const ShortCutText: string; Localized: boolean): TShortCut; var StartPos: integer; function HasFront(const Front: string): Boolean; begin Result := (Front<>'') and (StartPos+length(Front)-1 <= length(ShortCutText)) and (AnsiStrLIComp(@ShortCutText[StartPos],@Front[1],Length(Front))=0); if Result then inc(StartPos,length(Front)); end; var Key: TShortCut; Shift: TShortCut; Name: string; begin Result := 0; if ShortCutText = '' then Exit; Shift := 0; StartPos := 1; while True do begin if HasFront(KeyCodeToKeyString(scShift, Localized)) then Shift := Shift or scShift else if HasFront('^') then Shift := Shift or scCtrl else if HasFront(KeyCodeToKeyString(scCtrl, Localized)) then Shift := Shift or scCtrl else if HasFront(KeyCodeToKeyString(scAlt, Localized)) then Shift := Shift or scAlt else if HasFront(KeyCodeToKeyString(scMeta, Localized)) then Shift := Shift or scMeta else Break; end; for Key := Low(KeyCodeStrings) to High(KeyCodeStrings) do begin Name := KeyCodeToKeyString(Key, Localized); if (Name<>'') and (length(Name)=length(ShortCutText)-StartPos+1) and (AnsiStrLIComp(@ShortCutText[StartPos], PChar(Name), length(Name)) = 0) then Exit(Key or Shift); end; end; function TextToShortCut(const ShortCutText: string): TShortCut; begin Result:=TextToShortCutGeneric(ShortCutText, true); end; function TextToShortCutRaw(const ShortCutText: string): TShortCut; begin Result:=TextToShortCutGeneric(ShortCutText, false); end; function GetCompleteText(const sText: string; iSelStart: Integer; bCaseSensitive, bSearchAscending: Boolean; slTextList: TStrings): string; function IsSamePrefix(const sCompareText, sPrefix: string; iStart: Integer; var ResultText: string): Boolean; var sTempText: string; begin Result := False; sTempText := UTF8Copy(sCompareText, 1, iStart); if not bCaseSensitive then sTempText := UTF8UpperCase(sTempText); if (sTempText = sPrefix) then begin ResultText := sCompareText; Result := True; end; end; var i: Integer; sPrefixText: string; begin //DebugLn(['GetCompleteText sText=',sText,' iSelStart=',iSelStart,' bCaseSensitive=',bCaseSensitive,' bSearchAscending=',bSearchAscending,' slTextList.Count=',slTextList.Count]); Result := sText;//Default to return original text if no identical text are found if (sText = '') then Exit;//Everything is compatible with nothing, Exit. if (iSelStart = 0) then Exit;//Cursor at beginning if (slTextList.Count = 0) then Exit;//No text list to search for idtenticals, Exit. sPrefixText := UTF8Copy(sText, 1, iSelStart);//Get text from beginning to cursor position. if not bCaseSensitive then sPrefixText := UTF8UpperCase(sPrefixText); if bSearchAscending then begin for i := 0 to slTextList.Count - 1 do if IsSamePrefix(slTextList[i], sPrefixText, iSelStart, Result) then break; end else begin for i := slTextList.Count - 1 downto 0 do if IsSamePrefix(slTextList[i], sPrefixText, iSelStart, Result) then break; end; end; function IsEditableTextKey(Key: Word): Boolean; begin Result := Key in [ VK_A..VK_Z, VK_0..VK_9, VK_NUMPAD0..VK_DIVIDE, VK_OEM_1..VK_OEM_3, VK_OEM_4..VK_OEM_7 ]; end; function SendApplicationMessage(Msg: Cardinal; WParam: WParam; LParam: LParam ): Longint; begin if SendApplicationMessageFunction<>nil then Result:=SendApplicationMessageFunction(Msg, WParam, LParam) else Result:=0; end; procedure OwnerFormDesignerModified(AComponent: TComponent); begin if ([csDesigning,csLoading,csDestroying]*AComponent.ComponentState=[csDesigning]) then begin if OwnerFormDesignerModifiedProc<>nil then OwnerFormDesignerModifiedProc(AComponent); end; end; procedure RegisterInterfaceInitializationHandler(p: TProcedure); begin InterfaceInitializationHandlers.Add(p); end; procedure CallInterfaceInitializationHandlers; var i: Integer; begin for i:=0 to InterfaceInitializationHandlers.Count-1 do TProcedure(InterfaceInitializationHandlers[i])(); end; procedure RegisterInterfaceFinalizationHandler(p: TProcedure); begin InterfaceFinalizationHandlers.Add(p); end; procedure CallInterfaceFinalizationHandlers; var i: Integer; begin for i:=InterfaceFinalizationHandlers.Count-1 downto 0 do TProcedure(InterfaceFinalizationHandlers[i])(); end; function CompareHandles(h1, h2: TLCLHandle): integer; begin if h1>h2 then Result:=1 else if h1

p2.Y then Result:=1 else if p1.Yp2.X then Result:=1 else if p1.XSecondCaret.Y) then Result:=-1 else if (FirstCaret.XSecondCaret.X) then Result:=-1 else Result:=0; end; procedure MergeSort(List: TFPList; const OnCompare: TListSortCompare); begin LazUtilities.MergeSort(List, OnCompare); end; procedure MergeSort(List: TFPList; StartIndex, EndIndex: integer; const OnCompare: TListSortCompare); begin LazUtilities.MergeSort(List, StartIndex, EndIndex, OnCompare); end; procedure MergeSort(List: TStrings; const OnCompare: TStringsSortCompare); begin LazUtilities.MergeSort(List, OnCompare); end; // Debug funcs : procedure RaiseGDBException(const Msg: string); begin LazTracer.RaiseGDBException(Msg); end; procedure CloseDebugOutput; begin DebugLogger.Finish; end; procedure DbgOut(const s: string); begin DebugLogger.DbgOut(s); end; procedure DbgOut(Args: array of const); begin DebugLogger.DbgOut(Args); end; procedure DbgOut(const S: String; Args: array of const); begin DebugLogger.DbgOut(S, Args); end; procedure DbgOut(const s1, s2: string; const s3: string; const s4: string; const s5: string; const s6: string; const s7: string; const s8: string; const s9: string; const s10: string; const s11: string; const s12: string; const s13: string; const s14: string; const s15: string; const s16: string; const s17: string; const s18: string); begin DebugLogger.DbgOut(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18); end; procedure DebugLn(const s: string); begin DebugLogger.DebugLn(s); end; procedure DebugLn(Args: array of const); begin DebugLogger.DebugLn(Args); end; procedure DebugLn(const S: String; Args: array of const); begin DebugLogger.DebugLn(S, Args); end; procedure DebugLn(const s1, s2: string; const s3: string; const s4: string; const s5: string; const s6: string; const s7: string; const s8: string; const s9: string; const s10: string; const s11: string; const s12: string; const s13: string; const s14: string; const s15: string; const s16: string; const s17: string; const s18: string); begin DebugLogger.DebugLn(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18); end; procedure DebugLnEnter(const s: string); begin DebugLogger.DebugLnEnter(s); end; procedure DebugLnEnter(Args: array of const); begin DebugLogger.DebugLnEnter(Args); end; procedure DebugLnEnter(s: string; Args: array of const); begin DebugLogger.DebugLnEnter(s, Args); end; procedure DebugLnEnter(const s1, s2: string; const s3: string; const s4: string; const s5: string; const s6: string; const s7: string; const s8: string; const s9: string; const s10: string; const s11: string; const s12: string; const s13: string; const s14: string; const s15: string; const s16: string; const s17: string; const s18: string); begin DebugLogger.DebugLnEnter(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18); end; procedure DebugLnExit(const s: string); begin DebugLogger.DebugLnExit(s); end; procedure DebugLnExit(Args: array of const); begin DebugLogger.DebugLnExit(Args); end; procedure DebugLnExit(s: string; Args: array of const); begin DebugLogger.DebugLnExit(s, Args); end; procedure DebugLnExit(const s1, s2: string; const s3: string; const s4: string; const s5: string; const s6: string; const s7: string; const s8: string; const s9: string; const s10: string; const s11: string; const s12: string; const s13: string; const s14: string; const s15: string; const s16: string; const s17: string; const s18: string); begin DebugLogger.DebugLnExit(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18); end; function DbgS(const c: cardinal): string; begin Result:=LazLoggerBase.DbgS(c); end; function DbgS(const i: longint): string; begin Result:=LazLoggerBase.DbgS(i); end; function DbgS(const i: int64): string; begin Result:=LazLoggerBase.DbgS(i); end; function DbgS(const q: qword): string; begin Result:=LazLoggerBase.DbgS(q); end; function DbgS(const r: TRect): string; begin Result:=LazLoggerBase.DbgS(r); end; function DbgS(const p: TPoint): string; begin Result:=LazLoggerBase.DbgS(p); end; function DbgS(const p: pointer): string; begin Result:=LazLoggerBase.DbgS(p); end; function DbgS(const e: extended; MaxDecimals: integer): string; begin Result:=LazLoggerBase.DbgS(e,MaxDecimals); end; function DbgS(const b: boolean): string; begin Result:=LazLoggerBase.DbgS(b); end; function DbgS(const s: TComponentState): string; begin Result:=LazLoggerBase.DbgS(s); end; function DbgS(const m: TMethod): string; begin Result:=LazLoggerBase.DbgS(m); end; function DbgSName(const p: TObject): string; begin Result:=LazLoggerBase.DbgSName(p); end; function DbgSName(const p: TClass): string; begin Result:=LazLoggerBase.DbgSName(p); end; function DbgStr(const StringWithSpecialChars: string): string; begin Result:=LazLoggerBase.DbgStr(StringWithSpecialChars); end; function DbgWideStr(const StringWithSpecialChars: widestring): string; begin Result:=LazLoggerBase.DbgWideStr(StringWithSpecialChars); end; function dbgMemRange(P: PByte; Count: integer; Width: integer): string; begin Result:=LazLoggerBase.dbgMemRange(P,Count,Width); end; function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string; begin Result:=LazLoggerBase.dbgMemStream(MemStream,Count); end; function dbgObjMem(AnObject: TObject): string; begin Result:=LazLoggerBase.dbgObjMem(AnObject); end; function dbgHex(i: Int64): string; begin Result:=LazLoggerBase.dbghex(i); end; function DbgS(const i1, i2, i3, i4: integer): string; begin Result:=LazLoggerBase.DbgS(i1,i2,i3,i4); end; function DbgS(const Shift: TShiftState): string; begin Result:=LazLoggerBase.DbgS(Shift); end; function DbgS(const ASize: TSize): string; begin Result:=LazLoggerBase.DbgS(ASize); end; function DbgSWindowPosFlags(Flags: UInt): String; begin Result := ''; if (SWP_NOSIZE and Flags) <> 0 then Result := Result + 'SWP_NOSIZE, '; if (SWP_NOMOVE and Flags) <> 0 then Result := Result + 'SWP_NOMOVE, '; if (SWP_NOZORDER and Flags) <> 0 then Result := Result + 'SWP_NOZORDER, '; if (SWP_NOREDRAW and Flags) <> 0 then Result := Result + 'SWP_NOREDRAW, '; if (SWP_NOACTIVATE and Flags) <> 0 then Result := Result + 'SWP_NOACTIVATE, '; if (SWP_DRAWFRAME and Flags) <> 0 then Result := Result + 'SWP_DRAWFRAME, '; if (SWP_SHOWWINDOW and Flags) <> 0 then Result := Result + 'SWP_SHOWWINDOW, '; if (SWP_HIDEWINDOW and Flags) <> 0 then Result := Result + 'SWP_HIDEWINDOW, '; if (SWP_NOCOPYBITS and Flags) <> 0 then Result := Result + 'SWP_NOCOPYBITS, '; if (SWP_NOOWNERZORDER and Flags) <> 0 then Result := Result + 'SWP_NOOWNERZORDER, '; if (SWP_NOSENDCHANGING and Flags) <> 0 then Result := Result + 'SWP_NOSENDCHANGING, '; if (SWP_DEFERERASE and Flags) <> 0 then Result := Result + 'SWP_DEFERERASE, '; if (SWP_ASYNCWINDOWPOS and Flags) <> 0 then Result := Result + 'SWP_ASYNCWINDOWPOS, '; if (SWP_STATECHANGED and Flags) <> 0 then Result := Result + 'SWP_STATECHANGED, '; if (SWP_SourceIsInterface and Flags) <> 0 then Result := Result + 'SWP_SourceIsInterface, '; if Result <> '' then Delete(Result, Length(Result) - 1, 2); end; function DbgsVKCode(c: word): string; begin case c of VK_UNKNOWN: Result:='VK_UNKNOWN'; VK_LBUTTON: Result:='VK_LBUTTON'; VK_RBUTTON: Result:='VK_RBUTTON'; VK_CANCEL: Result:='VK_CANCEL'; VK_MBUTTON: Result:='VK_MBUTTON'; VK_BACK: Result:='VK_BACK'; VK_TAB: Result:='VK_TAB'; VK_CLEAR: Result:='VK_CLEAR'; VK_RETURN: Result:='VK_RETURN'; VK_SHIFT: Result:='VK_SHIFT'; VK_CONTROL: Result:='VK_CONTROL'; VK_MENU: Result:='VK_MENU'; VK_PAUSE: Result:='VK_PAUSE'; VK_CAPITAL: Result:='VK_CAPITAL'; VK_KANA: Result:='VK_KANA'; VK_JUNJA: Result:='VK_JUNJA'; VK_FINAL: Result:='VK_FINAL'; VK_HANJA: Result:='VK_HANJA'; VK_ESCAPE: Result:='VK_ESCAPE'; VK_CONVERT: Result:='VK_CONVERT'; VK_NONCONVERT: Result:='VK_NONCONVERT'; VK_ACCEPT: Result:='VK_ACCEPT'; VK_MODECHANGE: Result:='VK_MODECHANGE'; VK_SPACE: Result:='VK_SPACE'; VK_PRIOR: Result:='VK_PRIOR'; VK_NEXT: Result:='VK_NEXT'; VK_END: Result:='VK_END'; VK_HOME: Result:='VK_HOME'; VK_LEFT: Result:='VK_LEFT'; VK_UP: Result:='VK_UP'; VK_RIGHT: Result:='VK_RIGHT'; VK_DOWN: Result:='VK_DOWN'; VK_SELECT: Result:='VK_SELECT'; VK_PRINT: Result:='VK_PRINT'; VK_EXECUTE: Result:='VK_EXECUTE'; VK_SNAPSHOT: Result:='VK_SNAPSHOT'; VK_INSERT: Result:='VK_INSERT'; VK_DELETE: Result:='VK_DELETE'; VK_HELP: Result:='VK_HELP'; VK_0: Result:='VK_0'; VK_1: Result:='VK_1'; VK_2: Result:='VK_2'; VK_3: Result:='VK_3'; VK_4: Result:='VK_4'; VK_5: Result:='VK_5'; VK_6: Result:='VK_6'; VK_7: Result:='VK_7'; VK_8: Result:='VK_8'; VK_9: Result:='VK_9'; VK_A: Result:='VK_A'; VK_B: Result:='VK_B'; VK_C: Result:='VK_C'; VK_D: Result:='VK_D'; VK_E: Result:='VK_E'; VK_F: Result:='VK_F'; VK_G: Result:='VK_G'; VK_H: Result:='VK_H'; VK_I: Result:='VK_I'; VK_J: Result:='VK_J'; VK_K: Result:='VK_K'; VK_L: Result:='VK_L'; VK_M: Result:='VK_M'; VK_N: Result:='VK_N'; VK_O: Result:='VK_O'; VK_P: Result:='VK_P'; VK_Q: Result:='VK_Q'; VK_R: Result:='VK_R'; VK_S: Result:='VK_S'; VK_T: Result:='VK_T'; VK_U: Result:='VK_U'; VK_V: Result:='VK_V'; VK_W: Result:='VK_W'; VK_X: Result:='VK_X'; VK_Y: Result:='VK_Y'; VK_Z: Result:='VK_Z'; VK_LWIN: Result:='VK_LWIN'; VK_RWIN: Result:='VK_RWIN'; VK_APPS: Result:='VK_APPS'; VK_SLEEP: Result:='VK_SLEEP'; VK_NUMPAD0: Result:='VK_NUMPAD0'; VK_NUMPAD1: Result:='VK_NUMPAD1'; VK_NUMPAD2: Result:='VK_NUMPAD2'; VK_NUMPAD3: Result:='VK_NUMPAD3'; VK_NUMPAD4: Result:='VK_NUMPAD4'; VK_NUMPAD5: Result:='VK_NUMPAD5'; VK_NUMPAD6: Result:='VK_NUMPAD6'; VK_NUMPAD7: Result:='VK_NUMPAD7'; VK_NUMPAD8: Result:='VK_NUMPAD8'; VK_NUMPAD9: Result:='VK_NUMPAD9'; VK_MULTIPLY: Result:='VK_MULTIPLY'; VK_ADD: Result:='VK_ADD'; VK_SEPARATOR: Result:='VK_SEPARATOR'; VK_SUBTRACT: Result:='VK_SUBTRACT'; VK_DECIMAL: Result:='VK_DECIMAL'; VK_DIVIDE: Result:='VK_DIVIDE'; VK_F1: Result:='VK_F1'; VK_F2: Result:='VK_F2'; VK_F3: Result:='VK_F3'; VK_F4: Result:='VK_F4'; VK_F5: Result:='VK_F5'; VK_F6: Result:='VK_F6'; VK_F7: Result:='VK_F7'; VK_F8: Result:='VK_F8'; VK_F9: Result:='VK_F9'; VK_F10: Result:='VK_F10'; VK_F11: Result:='VK_F11'; VK_F12: Result:='VK_F12'; VK_F13: Result:='VK_F13'; VK_F14: Result:='VK_F14'; VK_F15: Result:='VK_F15'; VK_F16: Result:='VK_F16'; VK_F17: Result:='VK_F17'; VK_F18: Result:='VK_F18'; VK_F19: Result:='VK_F19'; VK_F20: Result:='VK_F20'; VK_F21: Result:='VK_F21'; VK_F22: Result:='VK_F22'; VK_F23: Result:='VK_F23'; VK_F24: Result:='VK_F24'; VK_NUMLOCK: Result:='VK_NUMLOCK'; VK_SCROLL: Result:='VK_SCROLL'; VK_LSHIFT: Result:='VK_LSHIFT'; VK_RSHIFT: Result:='VK_RSHIFT'; VK_LCONTROL: Result:='VK_LCONTROL'; VK_RCONTROL: Result:='VK_RCONTROL'; VK_LMENU: Result:='VK_LMENU'; VK_RMENU: Result:='VK_RMENU'; VK_BROWSER_BACK: Result:='VK_BROWSER_BACK'; VK_BROWSER_FORWARD: Result:='VK_BROWSER_FORWARD'; VK_BROWSER_REFRESH: Result:='VK_BROWSER_REFRESH'; VK_BROWSER_STOP: Result:='VK_BROWSER_STOP'; VK_BROWSER_SEARCH: Result:='VK_BROWSER_SEARCH'; VK_BROWSER_FAVORITES: Result:='VK_BROWSER_FAVORITES'; VK_BROWSER_HOME: Result:='VK_BROWSER_HOME'; VK_VOLUME_MUTE: Result:='VK_VOLUME_MUTE'; VK_VOLUME_DOWN: Result:='VK_VOLUME_DOWN'; VK_VOLUME_UP: Result:='VK_VOLUME_UP'; VK_MEDIA_NEXT_TRACK: Result:='VK_MEDIA_NEXT_TRACK'; VK_MEDIA_PREV_TRACK: Result:='VK_MEDIA_PREV_TRACK'; VK_MEDIA_STOP: Result:='VK_MEDIA_STOP'; VK_MEDIA_PLAY_PAUSE: Result:='VK_MEDIA_PLAY_PAUSE'; VK_LAUNCH_MAIL: Result:='VK_LAUNCH_MAIL'; VK_LAUNCH_MEDIA_SELECT: Result:='VK_LAUNCH_MEDIA_SELECT'; VK_LAUNCH_APP1: Result:='VK_LAUNCH_APP1'; VK_LAUNCH_APP2: Result:='VK_LAUNCH_APP2'; // New keys in 0.9.31+ VK_LCL_EQUAL: Result:='VK_LCL_EQUAL'; VK_LCL_COMMA: Result:='VK_LCL_COMMA'; VK_LCL_POINT: Result:='VK_LCL_POINT'; VK_LCL_SLASH: Result:='VK_LCL_SLASH'; VK_LCL_SEMI_COMMA:Result:='VK_LCL_SEMI_COMMA'; VK_LCL_MINUS :Result:='VK_LCL_MINUS'; VK_LCL_OPEN_BRACKET: Result:='VK_LCL_OPEN_BRACKET'; VK_LCL_CLOSE_BRACKET: Result:='VK_LCL_CLOSE_BRACKET'; VK_LCL_BACKSLASH :Result:='VK_LCL_BACKSLASH'; VK_LCL_TILDE :Result:='VK_LCL_TILDE'; VK_LCL_QUOTE :Result:='VK_LCL_QUOTE'; // VK_LCL_POWER: Result:='VK_LCL_POWER'; VK_LCL_CALL: Result:='VK_LCL_CALL'; VK_LCL_ENDCALL: Result:='VK_LCL_ENDCALL'; VK_LCL_AT: Result:='VK_LCL_AT'; else Result:='VK_('+LazLoggerBase.dbgs(c)+')'; end; end; function DbgS(const ATM: TTextMetric): string; begin with ATM do Result := 'tmHeight: ' + LazLoggerBase.DbgS(tmHeight) + ' tmAscent: ' + LazLoggerBase.DbgS(tmAscent) + ' tmDescent: ' + LazLoggerBase.DbgS(tmDescent) + ' tmInternalLeading: ' + LazLoggerBase.DbgS(tmInternalLeading) + ' tmExternalLeading: ' + LazLoggerBase.DbgS(tmExternalLeading) + ' tmAveCharWidth: ' + LazLoggerBase.DbgS(tmAveCharWidth) + ' tmMaxCharWidth: ' + LazLoggerBase.DbgS(tmMaxCharWidth) + ' tmWeight: ' + LazLoggerBase.DbgS(tmWeight) + ' tmOverhang: ' + LazLoggerBase.DbgS(tmOverhang) + ' tmDigitizedAspectX: ' + LazLoggerBase.DbgS(tmDigitizedAspectX) + ' tmDigitizedAspectY: ' + LazLoggerBase.DbgS(tmDigitizedAspectY) + ' tmFirstChar: ' + tmFirstChar + ' tmLastChar: ' + tmLastChar + ' tmDefaultChar: ' + tmDefaultChar + ' tmBreakChar: ' + tmBreakChar + ' tmItalic: ' + LazLoggerBase.DbgS(tmItalic) + ' tmUnderlined: ' + LazLoggerBase.DbgS(tmUnderlined) + ' tmStruckOut: ' + LazLoggerBase.DbgS(tmStruckOut) + ' tmPitchAndFamily: ' + LazLoggerBase.DbgS(tmPitchAndFamily) + ' tmCharSet: ' + LazLoggerBase.DbgS(tmCharSet); end; function DbgS(const AScrollInfo: TScrollInfo): string; begin Result := ''; if (SIF_POS and AScrollInfo.fMask) > 0 then Result := 'Pos: ' + LazLoggerBase.DbgS(AScrollInfo.nPos); if (SIF_RANGE and AScrollInfo.fMask) > 0 then Result := Result + ' Min: ' + LazLoggerBase.DbgS(AScrollInfo.nMin) + ' Max: ' + LazLoggerBase.DbgS(AScrollInfo.nMax); if (SIF_PAGE and AScrollInfo.fMask) > 0 then Result := Result + ' Page: ' + LazLoggerBase.DbgS(AScrollInfo.nPage); if (SIF_TRACKPOS and AScrollInfo.fMask) > 0 then Result := Result + ' TrackPos: ' + LazLoggerBase.DbgS(AScrollInfo.nTrackPos); if Result = '' then Result := '(no scrollinfo)'; end; function DbgS(const AVariant: Variant): string; begin if TVarData(AVariant).VType = varEmpty then result := '' else if TVarData(AVariant).vtype = varNull then result := '' else result := AVariant; end; procedure DbgOutThreadLog(const Msg: string); var PID: PtrInt; fs: TFileStream; Filename: string; begin PID:=PtrInt(GetThreadID); Filename:='Log'+IntToStr(PID); if FileExistsUTF8(Filename) then fs:=TFileStream.Create(Filename,fmOpenWrite or fmShareDenyNone) else fs:=TFileStream.Create(Filename,fmCreate); fs.Position:=fs.Size; fs.Write(Msg[1], length(Msg)); fs.Free; end; procedure DebuglnThreadLog(const Msg: string); var PID: PtrInt; begin PID:=PtrInt(GetThreadID); DbgOutThreadLog(IntToStr(PtrInt(PID))+' : '+Msg+LineEnding); end; procedure DebuglnThreadLog(Args: array of const); var i: Integer; s: String; begin s:=''; for i:=Low(Args) to High(Args) do begin case Args[i].VType of vtInteger: s:=s+LazLoggerBase.dbgs(Args[i].vinteger); vtInt64: s:=s+LazLoggerBase.dbgs(Args[i].VInt64^); vtQWord: s:=s+LazLoggerBase.dbgs(Args[i].VQWord^); vtBoolean: s:=s+LazLoggerBase.dbgs(Args[i].vboolean); vtExtended: s:=s+LazLoggerBase.dbgs(Args[i].VExtended^); {$ifdef FPC_CURRENCY_IS_INT64} // MWE: // ppcppc 2.0.2 has troubles in choosing the right dbgs() // so we convert here (i don't know about other versions vtCurrency: s:=s+LazLoggerBase.dbgs(int64(Args[i].vCurrency^)/10000, 4); {$else} vtCurrency: s:=s+LazLoggerBase.dbgs(Args[i].vCurrency^); {$endif} vtString: s:=s+Args[i].VString^; vtAnsiString: s:=s+AnsiString(Args[i].VAnsiString); vtChar: s:=s+Args[i].VChar; vtPChar: s:=s+Args[i].VPChar; vtPWideChar: s:=AnsiString(WideString(s)+Args[i].VPWideChar); vtWideChar: s:=AnsiString(WideString(s)+Args[i].VWideChar); vtWidestring: s:=AnsiString(WideString(s)+WideString(Args[i].VWideString)); vtUnicodeString: s:=AnsiString(UnicodeString(s)+UnicodeString(Args[i].VUnicodeString)); vtObject: s:=s+LazLoggerBase.DbgSName(Args[i].VObject); vtClass: s:=s+LazLoggerBase.DbgSName(Args[i].VClass); vtPointer: s:=s+LazLoggerBase.Dbgs(Args[i].VPointer); else DbgOutThreadLog('?unknown variant?'); end; end; DebuglnThreadLog(s); end; procedure DebuglnThreadLog; begin DebuglnThreadLog(''); end; procedure DbgSaveData(FileName: String; AData: PChar; ADataSize: PtrUInt); var S: TStream; begin S := TFileStream.Create(FileName, fmCreate); S.Write(AData^, ADataSize); S.Free; end; procedure DbgAppendToFile(FileName, S: String); var F: TextFile; begin AssignFile(F, FileName); {$I-} Append(F); if IOResult <> 0 then Rewrite(F); {$I+} WriteLn(F, S); CloseFile(F); end; procedure DbgAppendToFileWithoutLn(FileName, S: String); var F: TextFile; begin AssignFile(F, FileName); {$I-} Append(F); if IOResult <> 0 then Rewrite(F); {$I+} Write(F, S); CloseFile(F); end; function ClassCase(const AClass: TClass; const ACase: array of TClass {; const ADescendant: Boolean = True}): Integer; begin Result := ClassCase(AClass, ACase, True); end; function ClassCase(const AClass: TClass; const ACase: array of TClass; const ADescendant: Boolean): Integer; begin for Result := Low(ACase) to High(ACase) do begin if AClass = ACase[Result] then Exit; if not ADescendant then Continue; if AClass.InheritsFrom(ACase[Result]) then Exit; end; Result := -1; end; function IsFontNameDefault(const AName: string): boolean; begin Result := CompareText(AName, 'default') = 0; end; function PeekFontSuffix(AFontName: string; out ASuffix: string): boolean; var index: SizeInt; begin index := length(AFontName); while index > 0 do begin if AFontName[index] in [#0..' '] then begin ASuffix := copy(AFontName, index+1, length(AFontName)-index); exit(length(ASuffix) > 0); end; dec(index); end; ASuffix := ''; result := false; end; function ExtractFontSuffix(var AFontName: string; const ASuffix: string): boolean; begin if (length(AFontName) > length(ASuffix)) and AFontName.EndsWith(ASuffix, true) and (AFontName[length(AFontName) - length(ASuffix)] in [#0..' ']) then begin AFontName := copy(AFontName, 1, length(AFontName) - length(ASuffix) - 1).TrimRight; exit(true); end; exit(false); end; function ExtractFontStrecthSuffix(var AFontName: string; out AStretch: integer): boolean; var stretch, count: integer; suffix: String; begin AFontName := AFontName.TrimRight; for stretch := low(FontStretchNames) to high(FontStretchNames) do if (stretch <> FONT_STRETCH_NORMAL) and ExtractFontSuffix(AFontName, FontStretchNames[stretch]) then begin AStretch := stretch; exit(true); end; if (length(AFontName) >= LF_FACESIZE - 1) and PeekFontSuffix(AFontName, suffix) then begin // try to guess from truncated suffix count := 0; for stretch := low(FontStretchNames) to high(FontStretchNames) do begin if FontStretchNames[stretch].StartsWith(suffix, true) then begin AStretch := stretch; inc(count); end; end; // if only one suffix matches if (count = 1) and ExtractFontSuffix(AFontName, suffix) then begin exit(true); end; end; AStretch := FONT_STRETCH_NORMAL; exit(false); end; function ExtractFontWeightSuffix(var AFontName: string; out AWeight: integer): boolean; var i, count: Integer; suffix: String; begin AFontName := AFontName.TrimRight; for i := 0 to high(FontWeightValueNames) do if ExtractFontSuffix(AFontName, FontWeightValueNames[i].Name) then begin AWeight := FontWeightValueNames[i].Value; exit(true); end; if (length(AFontName) >= LF_FACESIZE - 1) and PeekFontSuffix(AFontName, suffix) then begin // try to guess from truncated suffix count := 0; for i := 0 to high(FontWeightValueNames) do begin if FontWeightValueNames[i].Name.StartsWith(suffix, true) then begin AWeight := FontWeightValueNames[i].Value; inc(count); end; end; // if only one suffix matches if (count = 1) and ExtractFontSuffix(AFontName, suffix) then begin exit(true); end; end; AWeight := FW_NORMAL; exit(false); end; procedure ExtractFontFaceSuffixes(var AFontName: string; out AStretch: integer; out AWeight: integer); var foundWeight: Boolean; begin foundWeight := ExtractFontWeightSuffix(AFontName, AWeight); if ExtractFontStrecthSuffix(AFontName, AStretch) then begin if not foundWeight then begin // accept weight after or before stretch specifier ExtractFontWeightSuffix(AFontName, AWeight); end; end; end; function AppendFontFaceSuffixes(AFamilyName: string; AStretch: integer; AWeight: integer): string; var weightSuffix: String; begin result := AFamilyName; // stretch is generally specified before weight if (AStretch <> FONT_STRETCH_NORMAL) and (AStretch >= low(FontStretchNames)) and (AStretch <= high(FontStretchNames)) then begin if (AStretch <> GetFontFamilyDefaultStretch(AFamilyName)) then result := result + ' ' + FontStretchNames[AStretch]; end; // bold is not added as a suffix in the font name because if is a font style if (AWeight <> FW_NORMAL) and (AWeight <> FW_BOLD) then begin weightSuffix := FontWeightToStr(integer(AWeight), ''); if (weightSuffix <> '') and (weightSuffix <> FontWeightToStr(FW_BOLD)) then result := result + ' ' + weightSuffix; end; end; function GetFontFamilyDefaultStretch(const AFamilyName: string): integer; begin if AFamilyName.EndsWith(' Narrow', true) then result := FONT_STRETCH_SEMI_CONDENSED else result := FONT_STRETCH_NORMAL; end; procedure AddCmdLineParamDesc(var aText: TStringList; aParamOpts: array of string; aDescr: string); var i: Integer; s: String; begin if Length(aParamOpts) = 0 then exit; // parameter options (one line) s := aParamOpts[0]; for i := 1 to high(aParamOpts) do s := s + ', ' + aParamOpts[i]; aText.Add(s); // description aText.Add(aDescr); // extra line between parameters aText.Add(''); end; { TDebugLCLItems } constructor TDebugLCLItems.Create(const TheName: string); begin FName:=TheName; FItems:=TAvlTree.Create(@CompareDebugLCLItemInfos); end; destructor TDebugLCLItems.Destroy; begin FItems.FreeAndClear; FreeAndNil(FItems); inherited Destroy; end; function TDebugLCLItems.FindInfo(p: Pointer; CreateIfNotExists: boolean): TDebugLCLItemInfo; var ANode: TAvlTreeNode; begin ANode:=FItems.FindKey(p,@CompareItemWithDebugLCLItemInfo); if ANode<>nil then Result:=TDebugLCLItemInfo(ANode.Data) else begin // does not yet exists if CreateIfNotExists then begin Result:=MarkCreated(p,'TDebugLCLItems.FindInfo'); end else begin Result:=nil; end; end; end; function TDebugLCLItems.IsDestroyed(p: Pointer): boolean; var Info: TDebugLCLItemInfo; begin Info:=FindInfo(p); if Info=nil then Result:=false else Result:=Info.IsDestroyed; end; function TDebugLCLItems.IsCreated(p: Pointer): boolean; var Info: TDebugLCLItemInfo; begin Info:=FindInfo(p); if Info=nil then Result:=false else Result:=not Info.IsDestroyed; end; procedure TDebugLCLItems.MarkDestroyed(p: Pointer); var Info: TDebugLCLItemInfo; procedure RaiseNotCreated; begin LazLoggerBase.DebugLn('TDebugLCLItems.MarkDestroyed not created: p=',LazLoggerBase.dbgs(p)); DumpStack; LazTracer.RaiseGDBException('TDebugLCLItems.MarkDestroyed'); end; procedure RaiseDoubleDestroyed; begin LazLoggerBase.debugLn('TDebugLCLItems.MarkDestroyed Double destroyed:'); LazLoggerBase.debugln(Info.AsString(true)); LazLoggerBase.debugln('Now:'); LazLoggerBase.DebugLn(GetStackTrace(true)); LazTracer.RaiseGDBException('RaiseDoubleDestroyed'); end; begin Info:=FindInfo(p); if Info=nil then RaiseNotCreated; if Info.IsDestroyed then RaiseDoubleDestroyed; Info.IsDestroyed:=true; GetStackTracePointers(Info.DestructionStack); //DebugLn(['TDebugLCLItems.MarkDestroyed ',dbgs(p)]); end; function TDebugLCLItems.GetInfo(p: Pointer; WithStackTraces: boolean): string; var Info: TDebugLCLItemInfo; begin Info:=FindInfo(p,false); if Info<>nil then Result:=Info.AsString(WithStackTraces) else Result:=''; end; function TDebugLCLItems.MarkCreated(p: Pointer; const InfoText: string): TDebugLCLItemInfo; var Info: TDebugLCLItemInfo; procedure RaiseDoubleCreated; begin LazLoggerBase.debugLn('TDebugLCLItems.MarkCreated CREATED TWICE. Old:'); LazLoggerBase.debugln(Info.AsString(true)); LazLoggerBase.debugln(' New=',LazLoggerBase.dbgs(p),' InfoText="',InfoText,'"'); LazLoggerBase.DebugLn(GetStackTrace(true)); LazTracer.RaiseGDBException('RaiseDoubleCreated'); end; begin Info:=FindInfo(p); if Info=nil then begin Info:=TDebugLCLItemInfo.Create; Info.Item:=p; FItems.Add(Info); end else if not Info.IsDestroyed then begin RaiseDoubleCreated; end; Info.IsDestroyed:=false; Info.Info:=InfoText; GetStackTracePointers(Info.CreationStack); SetLength(Info.DestructionStack,0); //DebugLn(['TDebugLCLItems.MarkCreated ',Name,' ',dbgs(p),' ',FItems.Count]); //DebugLn(GetStackTrace(true)); Result:=Info; end; { TDebugLCLItemInfo } function TDebugLCLItemInfo.AsString(WithStackTraces: boolean): string; begin Result:='Item='+LazLoggerBase.Dbgs(Item)+LineEnding +'Info="'+LazLoggerBase.DbgStr(Info)+LineEnding; if WithStackTraces then Result:=Result+'Creation:'+LineEnding+StackTraceAsString(CreationStack,true); if IsDestroyed then begin Result:=Result+'Destroyed:'+LineEnding; if WithStackTraces then Result:=Result+StackTraceAsString(DestructionStack,true); end; end; destructor TDebugLCLItemInfo.Destroy; begin SetLength(CreationStack,0); SetLength(DestructionStack,0); inherited Destroy; end; initialization {$ifdef WinCE} // The stabs based back trace function crashes on wince, // see http://bugs.freepascal.org/view.php?id=14330 // To prevent crashes, replace it with the default system back trace function // that just outputs addresses and not source and line number BackTraceStrFunc := @SysBackTraceStr; {$endif} {$ifdef AROS} EnableBackTraceStr; {$endif} InterfaceInitializationHandlers := TFPList.Create; InterfaceFinalizationHandlers := TFPList.Create; {$IFDEF DebugLCLComponents} DebugLCLComponents:=TDebugLCLItems.Create('LCLComponents'); {$ENDIF} finalization InterfaceInitializationHandlers.Free; InterfaceInitializationHandlers:=nil; InterfaceFinalizationHandlers.Free; InterfaceFinalizationHandlers:=nil; {$IFDEF DebugLCLComponents} DebugLCLComponents.Free; DebugLCLComponents:=nil; {$ENDIF} end.