1 {
2  /***************************************************************************
3                                   lclproc.pas
4                                   -----------
5                              Component Library Code
6 
7 
8  ***************************************************************************/
9 
10  *****************************************************************************
11   This file is part of the Lazarus Component Library (LCL)
12 
13   See the file COPYING.modifiedLGPL.txt, included in this distribution,
14   for details about the license.
15  *****************************************************************************
16 
17   Useful lower level helper functions and classes.
18 }
19 unit LCLProc;
20 
21 {$MODE ObjFPC}{$H+}
22 {$I lcl_defines.inc}
23 {$inline on}
24 
25 interface
26 
27 uses
28   {$IFDEF Darwin}MacOSAll, {$ENDIF}
29   Classes, SysUtils, Math, TypInfo, Types, Laz_AVL_Tree,
30   // LazUtils
31   FPCAdds, LazFileUtils, LazUtilities, LazMethodList, LazUTF8, LazUTF8Classes,
32   LazLoggerBase, LazTracer,
33   // LCL
34   LCLStrConsts, LCLType;
35 
36 type
37   TMethodList = LazMethodList.TMethodList;
38 
39   { TDebugLCLItemInfo }
40 
41   TDebugLCLItemInfo = class
42   public
43     Item: Pointer;
44     IsDestroyed: boolean;
45     Info: string;
46     CreationStack: TStackTracePointers; // stack trace at creationg
47     DestructionStack: TStackTracePointers;// stack trace at destruction
AsStringnull48     function AsString(WithStackTraces: boolean): string;
49     destructor Destroy; override;
50   end;
51 
52   { TDebugLCLItems }
53 
54   TDebugLCLItems = class
55   private
56     FItems: TAvlTree;// tree of TDebugLCLItemInfo
57     FName: string;
58   public
59     constructor Create(const TheName: string);
60     destructor Destroy; override;
FindInfonull61     function FindInfo(p: Pointer; CreateIfNotExists: boolean = false
62                       ): TDebugLCLItemInfo;
IsDestroyednull63     function IsDestroyed(p: Pointer): boolean;
IsCreatednull64     function IsCreated(p: Pointer): boolean;
MarkCreatednull65     function MarkCreated(p: Pointer; const InfoText: string): TDebugLCLItemInfo;
66     procedure MarkDestroyed(p: Pointer);
GetInfonull67     function GetInfo(p: Pointer; WithStackTraces: boolean): string;
68     property Name: string read FName;
69   end;
70 
71 {$IFDEF DebugLCLComponents}
72 var
73   DebugLCLComponents: TDebugLCLItems = nil;
74 {$ENDIF}
75 
CompareDebugLCLItemInfosnull76 function CompareDebugLCLItemInfos(Data1, Data2: Pointer): integer;
CompareItemWithDebugLCLItemInfonull77 function CompareItemWithDebugLCLItemInfo(Item, DebugItemInfo: Pointer): integer;
78 
79 
80 type
onstnull81   TStringsSortCompare = function(const Item1, Item2: string): Integer;
82 
83 procedure MergeSort(List: TFPList; const OnCompare: TListSortCompare); overload;// sort so that for each i is OnCompare(List[i],List[i+1])<=0
84 procedure MergeSort(List: TFPList; StartIndex, EndIndex: integer; const OnCompare: TListSortCompare); overload;// sort so that for each i is OnCompare(List[i],List[i+1])<=0
85 procedure MergeSort(List: TStrings; const OnCompare: TStringsSortCompare); overload;// sort so that for each i is OnCompare(List[i],List[i+1])<=0
86 
GetEnumValueDefnull87 function GetEnumValueDef(TypeInfo: PTypeInfo; const Name: string;
88                          const DefaultValue: Integer): Integer;
89 
KeyAndShiftStateToKeyStringnull90 function KeyAndShiftStateToKeyString(Key: word; ShiftState: TShiftState): String;
KeyStringIsIrregularnull91 function KeyStringIsIrregular(const s: string): boolean;
ShortCutToTextnull92 function ShortCutToText(ShortCut: TShortCut): string;// localized output
ShortCutToTextRawnull93 function ShortCutToTextRaw(ShortCut: TShortCut): string;// NOT localized output
TextToShortCutnull94 function TextToShortCut(const ShortCutText: string): TShortCut;// localized input
TextToShortCutRawnull95 function TextToShortCutRaw(const ShortCutText: string): TShortCut;// NOT localized input
96 
GetCompleteTextnull97 function GetCompleteText(const sText: string; iSelStart: Integer;
98   bCaseSensitive, bSearchAscending: Boolean; slTextList: TStrings): string;
IsEditableTextKeynull99 function IsEditableTextKey(Key: Word): Boolean;
100 
101 // Hooks used to prevent unit circles
102 type
103   TSendApplicationMessageFunction =
104     function(Msg: Cardinal; WParam: WParam; LParam: LParam):Longint;
105   TOwnerFormDesignerModifiedProc =
106     procedure(AComponent: TComponent);
107 
108 
109 var
TSendApplicationMessageFunctionnull110   SendApplicationMessageFunction: TSendApplicationMessageFunction=nil;
111   OwnerFormDesignerModifiedProc: TOwnerFormDesignerModifiedProc=nil;
112 
SendApplicationMessagenull113 function SendApplicationMessage(Msg: Cardinal; WParam: WParam; LParam: LParam):Longint;
114 procedure OwnerFormDesignerModified(AComponent: TComponent);
115 procedure FreeThenNil(var obj);
116 
117 { the LCL interfaces finalization sections are called before the finalization
118   sections of the LCL. Those parts, that should be finalized after the LCL, can
119   be registered here. }
120 procedure RegisterInterfaceInitializationHandler(p: TProcedure);
121 procedure CallInterfaceInitializationHandlers;
122 procedure RegisterInterfaceFinalizationHandler(p: TProcedure);
123 procedure CallInterfaceFinalizationHandlers;
124 
OffsetRectnull125 function OffsetRect(var ARect: TRect; dx, dy: Integer): Boolean;
126 procedure MoveRect(var ARect: TRect; x, y: Integer);
127 procedure MoveRectToFit(var ARect: TRect; const MaxRect: TRect);
128 procedure MakeMinMax(var i1, i2: integer);
129 procedure CalculateLeftTopWidthHeight(X1,Y1,X2,Y2: integer;
130   out Left,Top,Width,Height: integer);
131 
DeleteAmpersandsnull132 function DeleteAmpersands(var Str : String) : Longint;
133 
ComparePointersnull134 function ComparePointers(p1, p2: Pointer): integer; inline;
CompareHandlesnull135 function CompareHandles(h1, h2: THandle): integer;
CompareRectnull136 function CompareRect(R1, R2: PRect): Boolean;
ComparePointsnull137 function ComparePoints(const p1, p2: TPoint): integer;
CompareCaretnull138 function CompareCaret(const FirstCaret, SecondCaret: TPoint): integer;
CompareMethodsnull139 function CompareMethods(const m1, m2: TMethod): boolean; inline;
140 
RoundToIntnull141 function RoundToInt(const e: Extended): integer;
RoundToCardinalnull142 function RoundToCardinal(const e: Extended): cardinal;
TruncToIntnull143 function TruncToInt(const e: Extended): integer;
TruncToCardinalnull144 function TruncToCardinal(const e: Extended): cardinal;
StrToDoublenull145 function StrToDouble(const s: string): double;
146 
147 // Call debugging procedure in LazLoggerBase.
148 procedure RaiseGDBException(const Msg: string); inline;
149 
150 {$IFnDEF WithOldDebugln}
151 procedure DbgOut(const s: string = ''); inline; overload;
152 procedure DbgOut(Args: array of const); {inline;} overload;
153 procedure DbgOut(const S: String; Args: array of const); {inline;} overload;// similar to Format(s,Args)
154 procedure DbgOut(const s1, s2: string; const s3: string = '';
155                  const s4: string = ''; const s5: string = ''; const s6: string = '';
156                  const s7: string = ''; const s8: string = ''; const s9: string = '';
157                  const s10: string = ''; const s11: string = ''; const s12: string = '';
158                  const s13: string = ''; const s14: string = ''; const s15: string = '';
159                  const s16: string = ''; const s17: string = ''; const s18: string = ''); inline; overload;
160 
161 procedure DebugLn(const s: string = ''); inline; overload;
162 procedure DebugLn(Args: array of const); {inline;} overload;
163 procedure DebugLn(const S: String; Args: array of const); {inline;} overload;// similar to Format(s,Args)
164 procedure DebugLn(const s1, s2: string; const s3: string = '';
165                   const s4: string = ''; const s5: string = ''; const s6: string = '';
166                   const s7: string = ''; const s8: string = ''; const s9: string = '';
167                   const s10: string = ''; const s11: string = ''; const s12: string = '';
168                   const s13: string = ''; const s14: string = ''; const s15: string = '';
169                   const s16: string = ''; const s17: string = ''; const s18: string = ''); inline; overload;
170 
171 procedure DebugLnEnter(const s: string = ''); inline; overload;
172 procedure DebugLnEnter(Args: array of const); {inline;} overload;
173 procedure DebugLnEnter(s: string; Args: array of const); {inline;} overload;
174 procedure DebugLnEnter(const s1, s2: string; const s3: string = '';
175                        const s4: string = ''; const s5: string = ''; const s6: string = '';
176                        const s7: string = ''; const s8: string = ''; const s9: string = '';
177                        const s10: string = ''; const s11: string = ''; const s12: string = '';
178                        const s13: string = ''; const s14: string = ''; const s15: string = '';
179                        const s16: string = ''; const s17: string = ''; const s18: string = ''); inline; overload;
180 
181 procedure DebugLnExit(const s: string = ''); inline; overload;
182 procedure DebugLnExit(Args: array of const); {inline;} overload;
183 procedure DebugLnExit(s: string; Args: array of const); {inline;} overload;
184 procedure DebugLnExit (const s1, s2: string; const s3: string = '';
185                        const s4: string = ''; const s5: string = ''; const s6: string = '';
186                        const s7: string = ''; const s8: string = ''; const s9: string = '';
187                        const s10: string = ''; const s11: string = ''; const s12: string = '';
188                        const s13: string = ''; const s14: string = ''; const s15: string = '';
189                        const s16: string = ''; const s17: string = ''; const s18: string = ''); inline; overload;
190 
191 procedure CloseDebugOutput;
192 {$ELSE}
193 procedure DebugLn(Args: array of const); overload;
194 procedure DebugLn(const S: String; Args: array of const); overload;// similar to Format(s,Args)
195 procedure DebugLn; overload;
196 procedure DebugLn(const s: string); overload;
197 procedure DebugLn(const s1,s2: string); overload;
198 procedure DebugLn(const s1,s2,s3: string); overload;
199 procedure DebugLn(const s1,s2,s3,s4: string); overload;
200 procedure DebugLn(const s1,s2,s3,s4,s5: string); overload;
201 procedure DebugLn(const s1,s2,s3,s4,s5,s6: string); overload;
202 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7: string); overload;
203 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8: string); overload;
204 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9: string); overload;
205 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string); overload;
206 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string); overload;
207 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string); overload;
208 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13: string); overload;
209 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14: string); overload;
210 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15: string); overload;
211 procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15,s16: string); overload;
212 
213 procedure DebugLnEnter(const s: string = ''); overload;
214 procedure DebugLnEnter(Args: array of const); overload;
215 procedure DebugLnEnter(s: string; Args: array of const); overload;
216 procedure DebugLnEnter(const s1, s2: string; const s3: string = '';
217                      const s4: string = ''; const s5: string = ''; const s6: string = '';
218                      const s7: string = ''; const s8: string = ''; const s9: string = '';
219                      const s10: string = ''; const s11: string = ''; const s12: string = '';
220                      const s13: string = ''; const s14: string = ''; const s15: string = '';
221                      const s16: string = ''; const s17: string = ''; const s18: string = ''); overload;
222 procedure DebugLnExit(const s: string = ''); overload;
223 procedure DebugLnExit(Args: array of const); overload;
224 procedure DebugLnExit(s: string; Args: array of const); overload;
225 procedure DebugLnExit (const s1, s2: string; const s3: string = '';
226                      const s4: string = ''; const s5: string = ''; const s6: string = '';
227                      const s7: string = ''; const s8: string = ''; const s9: string = '';
228                      const s10: string = ''; const s11: string = ''; const s12: string = '';
229                      const s13: string = ''; const s14: string = ''; const s15: string = '';
230                      const s16: string = ''; const s17: string = ''; const s18: string = ''); overload;
231 
232 procedure DbgOut(const S: String; Args: array of const); overload;
233 procedure DbgOut(const s: string); overload;
234 procedure DbgOut(const s1,s2: string); overload;
235 procedure DbgOut(const s1,s2,s3: string); overload;
236 procedure DbgOut(const s1,s2,s3,s4: string); overload;
237 procedure DbgOut(const s1,s2,s3,s4,s5: string); overload;
238 procedure DbgOut(const s1,s2,s3,s4,s5,s6: string); overload;
239 procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7: string); overload;
240 procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8: string); overload;
241 procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9: string); overload;
242 procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string); overload;
243 procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string); overload;
244 procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string); overload;
245 
246 procedure CloseDebugOutput;
247 {$ENDIF}
248 
DbgSnull249 function DbgS(const c: cardinal): string; overload; inline;
DbgSnull250 function DbgS(const i: longint): string; overload; inline;
DbgSnull251 function DbgS(const i: int64): string; overload; inline;
DbgSnull252 function DbgS(const q: qword): string; overload; inline;
DbgSnull253 function DbgS(const r: TRect): string; overload; inline;
DbgSnull254 function DbgS(const p: TPoint): string; overload; inline;
DbgSnull255 function DbgS(const p: pointer): string; overload; inline;
DbgSnull256 function DbgS(const e: extended; MaxDecimals: integer = 999): string; overload; inline;
DbgSnull257 function DbgS(const b: boolean): string; overload; inline;
DbgSnull258 function DbgS(const s: TComponentState): string; overload; inline;
DbgSnull259 function DbgS(const m: TMethod): string; overload; inline;
DbgSNamenull260 function DbgSName(const p: TObject): string; overload; inline;
DbgSNamenull261 function DbgSName(const p: TClass): string; overload; inline;
DbgStrnull262 function DbgStr(const StringWithSpecialChars: string): string; overload; inline;
DbgWideStrnull263 function DbgWideStr(const StringWithSpecialChars: widestring): string; overload; inline;
dbgMemRangenull264 function dbgMemRange(P: PByte; Count: integer; Width: integer = 0): string; overload; inline;
dbgMemStreamnull265 function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string; overload; inline;
dbgObjMemnull266 function dbgObjMem(AnObject: TObject): string; overload; inline;
dbgHexnull267 function dbgHex(i: Int64): string; overload; inline;
DbgSWindowPosFlagsnull268 function DbgSWindowPosFlags(Flags: UInt): String;
269 
DbgSnull270 function DbgS(const i1,i2,i3,i4: integer): string; overload; inline;
DbgSnull271 function DbgS(const Shift: TShiftState): string; overload; inline;
DbgsVKCodenull272 function DbgsVKCode(c: word): string;
273 
DbgSnull274 function DbgS(const ASize: TSize): string; overload; inline;
DbgSnull275 function DbgS(const ATM: TTextMetric): string; overload;
DbgSnull276 function DbgS(const AScrollInfo: TScrollInfo): string; overload;
DbgSnull277 function DbgS(const AVariant: Variant): string; overload;
278 
279 procedure DbgOutThreadLog(const Msg: string); overload;
280 procedure DebuglnThreadLog(const Msg: string); overload;
281 procedure DebuglnThreadLog(Args: array of const); overload;
282 procedure DebuglnThreadLog; overload;
283 procedure DbgSaveData(FileName: String; AData: PChar; ADataSize: PtrUInt);
284 procedure DbgAppendToFile(FileName, S: String);
285 procedure DbgAppendToFileWithoutLn(FileName, S: String);
286 
287 // some string manipulation functions
StripLNnull288 function StripLN(const ALine: String): String;
GetPartnull289 function GetPart(const ASkipTo, AnEnd: String; var ASource: String;
290   const AnIgnoreCase: Boolean = False; const AnUpdateSource: Boolean = True): String; overload;
GetPartnull291 function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String;
292   const AnIgnoreCase: Boolean = False; const AnUpdateSource: Boolean = True): String; overload;
TextToSingleLinenull293 function TextToSingleLine(const AText: string): string;
SwapCasenull294 function SwapCase(Const S: String): String;
295 
296 // case..of utility functions
StringCasenull297 function StringCase(const AString: String; const ACase: array of String {; const AIgnoreCase = False, APartial = false: Boolean}): Integer; overload;
StringCasenull298 function StringCase(const AString: String; const ACase: array of String; const AIgnoreCase, APartial: Boolean): Integer; overload;
ClassCasenull299 function ClassCase(const AClass: TClass; const ACase: array of TClass {; const ADescendant: Boolean = True}): Integer; overload;
ClassCasenull300 function ClassCase(const AClass: TClass; const ACase: array of TClass; const ADecendant: Boolean): Integer; overload;
301 
302 // MWE: define (missing) UTF16string similar to UTF8
303 //      strictly spoken, a widestring <> utf16string
304 // todo: use it in existing functions
305 type
306   UTF16String = type UnicodeString;
307   PUTF16String = ^UTF16String;
308 
309 // Felipe: Don't substitute with calls to lazutf16 because lazutf16 includes
310 // some initialization code and tables, which are not necessary for the LCL
311 function UTF16CharacterLength(p: PWideChar): integer;
312 function UTF16Length(const s: UTF16String): PtrInt;
313 function UTF16Length(p: PWideChar; WordCount: PtrInt): PtrInt;
314 function UTF16CharacterToUnicode(p: PWideChar; out CharLen: integer): Cardinal;
315 function UnicodeToUTF16(u: cardinal): UTF16String;
316 
317 // identifier
318 function CreateFirstIdentifier(const Identifier: string): string;
319 function CreateNextIdentifier(const Identifier: string): string;
320 // Font
321 function IsFontNameDefault(const AName: string): boolean; inline;
322 
323 {$IFDEF WithOldDebugln}
324 type
325   TDebugLnProc = procedure (s: string) of object;
326 
327 var
328   DebugLnMaxNestPrefixLen: Integer = 15;
329   DebugLnNestLvlIndent: Integer = 2;
330   DebugText: ^Text;
331 
332   DebugLnProc: TDebugLnProc = nil;
333   DebugOutProc: TDebugLnProc = nil;
334 {$ENDIF}
335 
336 implementation
337 
338 uses gettext;
339 
340 const
341   {$IFDEF WithOldDebugln}
342   Str_LCL_Debug_File = 'lcldebug.log';
343   {$ENDIF}
344   UNKNOWN_VK_PREFIX = 'Word(''';
345   UNKNOWN_VK_POSTFIX = ''')';
346 
347 var
348   InterfaceInitializationHandlers: TFPList = nil;
349   InterfaceFinalizationHandlers: TFPList = nil;
350   {$IFDEF WithOldDebugln}
351   DebugTextAllocated: boolean;
352   DebugNestLvl: Integer = 0;
353   DebugNestPrefix: PChar = nil;
354   DebugNestAtBOL: Boolean;
355   {$ENDIF}
356 
357 function DeleteAmpersands(var Str : String) : Longint;
358 // Replace all &x with x
359 // and return the position of the first ampersand letter in the resulting Str.
360 // double ampersands && are converted to a single & and are ignored.
361 var
362   SrcPos, DestPos, SrcLen: Integer;
363 begin
364   Result:=-1;
365   SrcLen:=length(Str);
366   SrcPos:=1;
367   DestPos:=1;
368   while SrcPos<=SrcLen do begin
369     if (Str[SrcPos]='&') and (SrcPos<SrcLen) then begin
370       // & found
371       inc(SrcPos); // skip &
372       if (Str[SrcPos]<>'&') and (Result<1) then
373         Result:=DestPos;
374     end;
375     if DestPos<SrcPos then
376       Str[DestPos]:=Str[SrcPos];
377     inc(SrcPos);
378     inc(DestPos);
379   end;
380   if DestPos<SrcPos then
381     SetLength(Str,DestPos-1);
382 end;
383 
384 //-----------------------------------------------------------------------------
385 // Keys and shortcuts
386 
387 const
388   // MS documentation:
389   // https://msdn.microsoft.com/en-us/library/windows/desktop/dd375731(v=vs.85).aspx
390   //
391   // Note: ShortcutToText must ignore single key Ctrl, Alt, Shift, Win,
392   // so these items have empty str here
393   //
394   KeyCodeStrings: array[0..$FF] of string = (
395     'Unknown',
396     'Mouse_Left', // 0x1 - VK_LBUTTON
397     'Mouse_Right', // 0x2 - VK_RBUTTON
398     'Cancel', // 0x3 - VK_CANCEL - generated by Ctrl+Break
399     'Mouse_Middle', // 0x4 - VK_MBUTTON
400     'Mouse_X1', // 0x5 - VK_XBUTTON1
401     'Mouse_X2', // 0x6 - VK_XBUTTON2
402     '', // 0x7
403     'Backspace', // 0x8 - VK_BACK
404     'Tab', // 0x9 - VK_TAB
405     '', // 0xa
406     '', // 0xb
407     'NumClear', // 0xc - VK_CLEAR - generated by Num5 (NumLock off)
408     'Enter', // 0xd - VK_RETURN
409     '', // 0xe
410     '', // 0xf
411     '', //'Shift', // 0x10 - VK_SHIFT
412     '', //'Ctrl', // 0x11 - VK_CONTROL
413     '', //'Alt', // 0x12 - VK_MENU
414     'Break', // 0x13 - VK_PAUSE - Pause/Break key
415     'CapsLock', // 0x14 - VK_CAPITAL
416     'IME_Kana', // 0x15 - VK_KANA
417     '', // 0x16
418     'IME_Junja', // 0x17 - VK_JUNJA
419     'IME_final', // 0x18 - VK_FINAL
420     'IME_Hanja', // 0x19 - VK_HANJA
421     '', // 0x1a
422     'Esc', // 0x1b - VK_ESCAPE
423     'IME_convert', // 0x1c - VK_CONVERT
424     'IME_nonconvert', // 0x1d - VK_NONCONVERT
425     'IME_accept', // 0x1e - VK_ACCEPT
426     'IME_mode_change', // 0x1f - VK_MODECHANGE
427     'Space', // 0x20 - VK_SPACE
428     'PgUp', // 0x21 - VK_PRIOR
429     'PgDown', // 0x22 - VK_NEXT
430     'End', // 0x23 - VK_END
431     'Home', // 0x24 - VK_HOME
432     'Left', // 0x25 - VK_LEFT
433     'Up', // 0x26 - VK_UP
434     'Right', // 0x27 - VK_RIGHT
435     'Down', // 0x28 - VK_DOWN
436     'Select', // 0x29 - VK_SELECT
437     'Print', // 0x2a - VK_PRINT
438     'Execute', // 0x2b - VK_EXECUTE
439     'PrintScreen', // 0x2c - VK_SNAPSHOT
440     'Ins', // 0x2d - VK_INSERT
441     'Del', // 0x2e - VK_DELETE
442     'Help', // 0x2f - VK_HELP
443     '0', // 0x30
444     '1', // 0x31
445     '2', // 0x32
446     '3', // 0x33
447     '4', // 0x34
448     '5', // 0x35
449     '6', // 0x36
450     '7', // 0x37
451     '8', // 0x38
452     '9', // 0x39
453     '', // 0x3a
454     '', // 0x3b
455     '', // 0x3c
456     '', // 0x3d
457     '', // 0x3e
458     '', // 0x3f
459     '', // 0x40
460     'A', // 0x41
461     'B', // 0x42
462     'C', // 0x43
463     'D', // 0x44
464     'E', // 0x45
465     'F', // 0x46
466     'G', // 0x47
467     'H', // 0x48
468     'I', // 0x49
469     'J', // 0x4a
470     'K', // 0x4b
471     'L', // 0x4c
472     'M', // 0x4d
473     'N', // 0x4e
474     'O', // 0x4f
475     'P', // 0x50
476     'Q', // 0x51
477     'R', // 0x52
478     'S', // 0x53
479     'T', // 0x54
480     'U', // 0x55
481     'V', // 0x56
482     'W', // 0x57
483     'X', // 0x58
484     'Y', // 0x59
485     'Z', // 0x5a
486     '', //'LWindows', // 0x5b - VK_LWIN
487     '', //'RWindows', // 0x5c - VK_RWIN
488     'PopUp', // 0x5d - VK_APPS - PC, key near right Ctrl
489     '', // 0x5e
490     'Sleep', // 0x5f - VK_SLEEP
491     'Num0', // 0x60 - VK_NUMPAD0
492     'Num1', // 0x61
493     'Num2', // 0x62
494     'Num3', // 0x63
495     'Num4', // 0x64
496     'Num5', // 0x65
497     'Num6', // 0x66
498     'Num7', // 0x67
499     'Num8', // 0x68
500     'Num9', // 0x69 - VK_NUMPAD9
501     'NumMul', // 0x6a - VK_MULTIPLY
502     'NumPlus', // 0x6b - VK_ADD
503     'NumSepar', // 0x6c - VK_SEPARATOR
504     'NumMinus', // 0x6d - VK_SUBTRACT
505     'NumDot', // 0x6e - VK_DECIMAL
506     'NumDiv', // 0x6f - VK_DIVIDE
507     'F1', // 0x70 - VK_F1
508     'F2', // 0x71
509     'F3', // 0x72
510     'F4', // 0x73
511     'F5', // 0x74
512     'F6', // 0x75
513     'F7', // 0x76
514     'F8', // 0x77
515     'F9', // 0x78
516     'F10', // 0x79
517     'F11', // 0x7a
518     'F12', // 0x7b
519     'F13', // 0x7c
520     'F14', // 0x7d
521     'F15', // 0x7e
522     'F16', // 0x7f
523     'F17', // 0x80
524     'F18', // 0x81
525     'F19', // 0x82
526     'F20', // 0x83
527     'F21', // 0x84
528     'F22', // 0x85
529     'F23', // 0x86
530     'F24', // 0x87 - VK_F24
531     '', // 0x88
532     '', // 0x89
533     '', // 0x8a
534     '', // 0x8b
535     '', // 0x8c
536     '', // 0x8d
537     '', // 0x8e
538     '', // 0x8f
539     'NumLock', // 0x90 - VK_NUMLOCK
540     'ScrollLock', // 0x91 - VK_SCROLL
541     'OEM_0x92', // 0x92
542     'OEM_0x93', // 0x93
543     'OEM_0x94', // 0x94
544     'OEM_0x95', // 0x95
545     'OEM_0x96', // 0x96
546     '', // 0x97
547     '', // 0x98
548     '', // 0x99
549     '', // 0x9a
550     '', // 0x9b
551     '', // 0x9c
552     '', // 0x9d
553     '', // 0x9e
554     '', // 0x9f
555     '', //'LShift', // 0xa0 - VK_LSHIFT
556     '', //'RShift', // 0xa1 - VK_RSHIFT
557     '', //'LCtrl', // 0xa2 - VK_LCONTROL
558     '', //'RCtrl', // 0xa3 - VK_RCONTROL
559     '', //'LAlt', // 0xa4 - VK_LMENU
560     '', //'RAlt', // 0xa5 - VK_RMENU
561     'BrowserBack', // 0xa6 - VK_BROWSER_BACK
562     'BrowserForward', // 0xa7 - VK_BROWSER_FORWARD
563     'BrowserRefresh', // 0xa8 - VK_BROWSER_REFRESH
564     'BrowserStop', // 0xa9 - VK_BROWSER_STOP
565     'BrowserSearch', // 0xaa - VK_BROWSER_SEARCH
566     'BrowserFav', // 0xab - VK_BROWSER_FAVORITES
567     'BrowserHome', // 0xac - VK_BROWSER_HOME
568     'VolumeMute', // 0xad - VK_VOLUME_MUTE
569     'VolumeDown', // 0xae - VK_VOLUME_DOWN
570     'VolumeUp', // 0xaf - VK_VOLUME_UP
571     'MediaNext', // 0xb0 - VK_MEDIA_NEXT_TRACK
572     'MediaPrev', // 0xb1 - VK_MEDIA_PREV_TRACK
573     'MediaStop', // 0xb2 - VK_MEDIA_STOP
574     'MediaPlayPause', // 0xb3 - VK_MEDIA_PLAY_PAUSE
575     'LaunchMail', // 0xb4 - VK_LAUNCH_MAIL
576     'LaunchMedia', // 0xb5 - VK_LAUNCH_MEDIA_SELECT
577     'LaunchApp1', // 0xb6 - VK_LAUNCH_APP1
578     'LaunchApp2', // 0xb7 - VK_LAUNCH_APP2
579     '', // 0xb8
580     '', // 0xb9
581     ';', // 0xba - VK_OEM_1 - Can vary by keyboard, US keyboard, the ';:' key
582     '+', // 0xbb - VK_OEM_PLUS - For any country/region, the '+' key
583     ',', // 0xbc - VK_OEM_COMMA - For any country/region, the ',' key
584     '-', // 0xbd - VK_OEM_MINUS - For any country/region, the '-' key
585     '.', // 0xbe - VK_OEM_PERIOD - For any country/region, the '.' key
586     '/', // 0xbf - VK_OEM_2 - Can vary by keyboard, US keyboard, the '/?' key
587     '`', // 0xc0 - VK_OEM_3 - Can vary by keyboard, US keyboard, the '`~' key
588     '', // 0xc1
589     '', // 0xc2
590     '', // 0xc3
591     '', // 0xc4
592     '', // 0xc5
593     '', // 0xc6
594     '', // 0xc7
595     '', // 0xc8
596     '', // 0xc9
597     '', // 0xca
598     '', // 0xcb
599     '', // 0xcc
600     '', // 0xcd
601     '', // 0xce
602     '', // 0xcf
603     '', // 0xd0
604     '', // 0xd1
605     '', // 0xd2
606     '', // 0xd3
607     '', // 0xd4
608     '', // 0xd5
609     '', // 0xd6
610     '', // 0xd7
611     '', // 0xd8
612     '', // 0xd9
613     '', // 0xda
614     '[', // 0xdb - VK_OEM_4 - Can vary by keyboard, US keyboard, the '[{' key
615     '\', // 0xdc - VK_OEM_5 - Can vary by keyboard, US keyboard, the '\|' key
616     ']', // 0xdd - VK_OEM_6 - Can vary by keyboard, US keyboard, the ']}' key
617     '''', // 0xde - VK_OEM_7 - Can vary by keyboard, US keyboard, the 'single-quote/double-quote' key
618     'OEM_8', // 0xdf - VK_OEM_8
619     '', // 0xe0
620     'OEM_0xE1', // 0xe1
621     '\', // 0xe2 - VK_OEM_102 - Either the angle bracket key or the backslash key on the RT 102-key keyboard
622     'OEM_0xE3', // 0xe3
623     'OEM_0xE4', // 0xe4
624     'IME_process', // 0xe5 - VK_PROCESSKEY
625     'OEM_0xE6', // 0xe6
626     'UnicodePacket', // 0xe7 - VK_PACKET
627     '', // 0xe8
628     'OEM_0xE9', // 0xe9
629     'OEM_0xEA', // 0xea
630     'OEM_0xEB', // 0xeb
631     'OEM_0xEC', // 0xec
632     'OEM_0xED', // 0xed
633     'OEM_0xEE', // 0xee
634     'OEM_0xEF', // 0xef
635     'OEM_0xF0', // 0xf0
636     'OEM_0xF1', // 0xf1
637     'OEM_0xF2', // 0xf2
638     'OEM_0xF3', // 0xf3
639     'OEM_0xF4', // 0xf4
640     'OEM_0xF5', // 0xf5
641     'Attn', // 0xf6 - VK_ATTN
642     'CrSel', // 0xf7 - VK_CRSEL
643     'ExSel', // 0xf8 - VK_EXSEL
644     'EraseEOF', // 0xf9 - VK_EREOF
645     'Play', // 0xfa - VK_PLAY
646     'Zoom', // 0xfb - VK_ZOOM
647     '', // 0xfc
648     'PA1', // 0xfd - VK_PA1
649     'OEM_Clear', // 0xfe - VK_OEM_CLEAR
650     '' // 0xff
651   );
652 
653 
654 function CompareDebugLCLItemInfos(Data1, Data2: Pointer): integer;
655 begin
656   Result:=ComparePointers(TDebugLCLItemInfo(Data1).Item,
657                           TDebugLCLItemInfo(Data2).Item);
658 end;
659 
660 function CompareItemWithDebugLCLItemInfo(Item, DebugItemInfo: Pointer): integer;
661 begin
662   Result:=ComparePointers(Item,TDebugLCLItemInfo(DebugItemInfo).Item);
663 end;
664 
665 function GetEnumValueDef(TypeInfo: PTypeInfo; const Name: string;
666   const DefaultValue: Integer): Integer;
667 begin
668   Result:=GetEnumValue(TypeInfo,Name);
669   if Result<0 then
670     Result:=DefaultValue;
671 end;
672 
673 function KeyCodeToKeyString(Key: TShortCut; Localized: boolean): string;
674 begin
675   if Key <= High(KeyCodeStrings) then
676   begin
677     if Localized then
678       case Key of
679         VK_UNKNOWN: Result:=ifsVK_UNKNOWN;
680         VK_BACK: Result:=SmkcBkSp;
681         VK_TAB: Result:=SmkcTab;
682         VK_ESCAPE: Result:=SmkcEsc;
683         VK_RETURN: Result:=SmkcEnter;
684         VK_SPACE: Result:=SmkcSpace;
685         VK_PRIOR: Result:=SmkcPgUp;
686         VK_NEXT: Result:=SmkcPgDn;
687         VK_END: Result:=SmkcEnd;
688         VK_HOME: Result:=SmkcHome;
689         VK_LEFT: Result:=SmkcLeft;
690         VK_UP: Result:=SmkcUp;
691         VK_RIGHT: Result:=SmkcRight;
692         VK_DOWN: Result:=SmkcDown;
693         VK_INSERT: Result:=SmkcIns;
694         VK_DELETE: Result:=SmkcDel;
695         VK_HELP: Result:=ifsVK_HELP;
696         // must ignore single Shift, Alt, Ctrl in KeyCodeStrings
697         //VK_SHIFT: Result:=SmkcShift;
698         //VK_CONTROL: Result:=SmkcCtrl;
699         //VK_MENU: Result:=SmkcAlt;
700       otherwise
701         Result := KeyCodeStrings[Key];
702       end
703     else
704       Result := KeyCodeStrings[Key];
705   end
706   else
707     case Key of
708       scMeta: if Localized then Result:=SmkcMeta else Result:='Meta+';
709       scShift: if Localized then Result:=SmkcShift else Result:='Shift+';
710       scCtrl: if Localized then Result:=SmkcCtrl else Result:='Ctrl+';
711       scAlt: if Localized then Result:=SmkcAlt else Result:='Alt+';
712     otherwise
713       Result:='';
714     end;
715 end;
716 
717 // Used also by TWidgetSet.GetAcceleratorString
718 function KeyAndShiftStateToKeyString(Key: word; ShiftState: TShiftState): String;
719 
720   procedure AddPart(const APart: string);
721   begin
722     if Result <> '' then
723       Result := Result + '+';
724     Result := Result + APart;
725   end;
726 
727 var
728   s: string;
729 begin
730   Result := '';
731   if ssCtrl in ShiftState then AddPart(ifsCtrl);
732   if ssAlt in ShiftState then AddPart(ifsAlt);
733   if ssShift in ShiftState then AddPart(ifsVK_SHIFT);
734   if ssMeta in ShiftState then
735     {$IFDEF LCLcarbon}
736     AddPart(ifsVK_CMD);
737     {$ELSE}
738     AddPart(ifsVK_META);
739     {$ENDIF}
740   if ssSuper in ShiftState then AddPart(ifsVK_SUPER);
741 
742   s := KeyCodeToKeyString(Key, true);
743   // function returned "Word(nnn)" previously, keep this
744   if s = '' then
745     s := UNKNOWN_VK_PREFIX + IntToStr(Key) + UNKNOWN_VK_POSTFIX;
746   AddPart(s);
747 end;
748 
749 function KeyStringIsIrregular(const s: string): boolean;
750 begin
751   Result:=(length(UNKNOWN_VK_PREFIX)<length(s)) and
752     (AnsiStrLComp(PChar(s),PChar(UNKNOWN_VK_PREFIX),length(UNKNOWN_VK_PREFIX))=0);
753 end;
754 
755 function ShortCutToTextGeneric(ShortCut: TShortCut; Localized: boolean): string;
756 var
757   Name: string;
758 begin
759   Result := '';
760   Name := KeyCodeToKeyString(ShortCut and $FF, Localized);
761   if Name <> '' then
762   begin
763     if ShortCut and scShift <> 0 then Result := Result + KeyCodeToKeyString(scShift, Localized);
764     if ShortCut and scCtrl <> 0 then Result := Result + KeyCodeToKeyString(scCtrl, Localized);
765     if ShortCut and scMeta <> 0 then Result := Result + KeyCodeToKeyString(scMeta, Localized);
766     if ShortCut and scAlt <> 0 then Result := Result + KeyCodeToKeyString(scAlt, Localized);
767     Result := Result + Name;
768   end;
769 end;
770 
771 function ShortCutToText(ShortCut: TShortCut): string;
772 begin
773   Result:=ShortCutToTextGeneric(ShortCut, true);
774 end;
775 
776 function ShortCutToTextRaw(ShortCut: TShortCut): string;
777 begin
778   Result:=ShortCutToTextGeneric(ShortCut, false);
779 end;
780 
781 function TextToShortCutGeneric(const ShortCutText: string; Localized: boolean): TShortCut;
782 
783   function CompareFront(var StartPos: integer; const Front: string): Boolean;
784   begin
785     if (Front<>'') and (StartPos+length(Front)-1<=length(ShortCutText))
786     and (AnsiStrLIComp(@ShortCutText[StartPos], PChar(Front), Length(Front))= 0)
787     then begin
788       Result:=true;
789       inc(StartPos,length(Front));
790     end else
791       Result:=false;
792   end;
793 
794 var
795   Key: TShortCut;
796   Shift: TShortCut;
797   StartPos: integer;
798   Name: string;
799 begin
800   Result := 0;
801   if ShortCutText = '' then Exit;
802   Shift := 0;
803   StartPos := 1;
804   while True do
805   begin
806     if CompareFront(StartPos, KeyCodeToKeyString(scShift, Localized)) then
807       Shift := Shift or scShift
808     else if CompareFront(StartPos, '^') then
809       Shift := Shift or scCtrl
810     else if CompareFront(StartPos, KeyCodeToKeyString(scCtrl, Localized)) then
811       Shift := Shift or scCtrl
812     else if CompareFront(StartPos, KeyCodeToKeyString(scAlt, Localized)) then
813       Shift := Shift or scAlt
814     else if CompareFront(StartPos, KeyCodeToKeyString(scMeta, Localized)) then
815       Shift := Shift or scMeta
816     else
817       Break;
818   end;
819 
820   for Key := Low(KeyCodeStrings) to High(KeyCodeStrings) do
821   begin
822     Name := KeyCodeToKeyString(Key, Localized);
823     if (Name<>'') and (length(Name)=length(ShortCutText)-StartPos+1)
824     and (AnsiStrLIComp(@ShortCutText[StartPos], PChar(Name), length(Name)) = 0)
825     then begin
826       Result := Key or Shift;
827       Exit;
828     end;
829   end;
830 end;
831 
832 function TextToShortCut(const ShortCutText: string): TShortCut;
833 begin
834   Result:=TextToShortCutGeneric(ShortCutText, true);
835 end;
836 
837 function TextToShortCutRaw(const ShortCutText: string): TShortCut;
838 begin
839   Result:=TextToShortCutGeneric(ShortCutText, false);
840 end;
841 
842 function GetCompleteText(const sText: string; iSelStart: Integer;
843   bCaseSensitive, bSearchAscending: Boolean; slTextList: TStrings): string;
844 
845   function IsSamePrefix(const sCompareText, sPrefix: string; iStart: Integer;
846     var ResultText: string): Boolean;
847   var
848     sTempText: string;
849   begin
850     Result := False;
851     sTempText := UTF8Copy(sCompareText, 1, iStart);
852     if not bCaseSensitive then
853       sTempText := UTF8UpperCase(sTempText);
854     if (sTempText = sPrefix) then
855     begin
856       ResultText := sCompareText;
857       Result := True;
858     end;
859   end;
860 
861 var
862   i: Integer;
863   sPrefixText: string;
864 begin
865   //DebugLn(['GetCompleteText sText=',sText,' iSelStart=',iSelStart,' bCaseSensitive=',bCaseSensitive,' bSearchAscending=',bSearchAscending,' slTextList.Count=',slTextList.Count]);
866   Result := sText;//Default to return original text if no identical text are found
867   if (sText = '') then Exit;//Everything is compatible with nothing, Exit.
868   if (iSelStart = 0) then Exit;//Cursor at beginning
869   if (slTextList.Count = 0) then Exit;//No text list to search for idtenticals, Exit.
870   sPrefixText := UTF8Copy(sText, 1, iSelStart);//Get text from beginning to cursor position.
871   if not bCaseSensitive then
872     sPrefixText := UTF8UpperCase(sPrefixText);
873   if bSearchAscending then
874   begin
875     for i := 0 to slTextList.Count - 1 do
876       if IsSamePrefix(slTextList[i], sPrefixText, iSelStart, Result) then
877         break;
878   end else
879   begin
880     for i := slTextList.Count - 1 downto 0 do
881       if IsSamePrefix(slTextList[i], sPrefixText, iSelStart, Result) then
882         break;
883   end;
884 end;
885 
886 function IsEditableTextKey(Key: Word): Boolean;
887 begin
888  Result := (((Key >= VK_A) and (Key <= VK_Z)) or
889             ((Key >= VK_NUMPAD0) and (Key <= VK_DIVIDE)) or
890             ((Key >= VK_0) and (Key <= VK_9)) or
891             ((Key >= 186) and (Key <= 188)) or
892             ((Key >= 190) and (Key <= 192)) or
893             ((Key >= 219) and (Key <= 222)));
894 end;
895 
896 function SendApplicationMessage(Msg: Cardinal; WParam: WParam; LParam: LParam
897   ): Longint;
898 begin
899   if SendApplicationMessageFunction<>nil then
900     Result:=SendApplicationMessageFunction(Msg, WParam, LParam)
901   else
902     Result:=0;
903 end;
904 
905 procedure OwnerFormDesignerModified(AComponent: TComponent);
906 begin
907   if ([csDesigning,csLoading,csDestroying]*AComponent.ComponentState
908     =[csDesigning])
909   then begin
910     if OwnerFormDesignerModifiedProc<>nil then
911       OwnerFormDesignerModifiedProc(AComponent);
912   end;
913 end;
914 
915 function OffSetRect(var ARect: TRect; dx,dy: Integer): Boolean;
916 Begin
917   with ARect do
918   begin
919     Left := Left + dx;
920     Right := Right + dx;
921     Top := Top + dy;
922     Bottom := Bottom + dy;
923   end;
924   Result := (ARect.Left >= 0) and (ARect.Top >= 0);
925 end;
926 
927 procedure FreeThenNil(var obj);
928 begin
929   LazUtilities.FreeThenNil(obj);
930 end;
931 
932 procedure RegisterInterfaceInitializationHandler(p: TProcedure);
933 begin
934   InterfaceInitializationHandlers.Add(p);
935 end;
936 
937 procedure CallInterfaceInitializationHandlers;
938 var
939   i: Integer;
940 begin
941   for i:=0 to InterfaceInitializationHandlers.Count-1 do
942     TProcedure(InterfaceInitializationHandlers[i])();
943 end;
944 
945 procedure RegisterInterfaceFinalizationHandler(p: TProcedure);
946 begin
947   InterfaceFinalizationHandlers.Add(p);
948 end;
949 
950 procedure CallInterfaceFinalizationHandlers;
951 var
952   i: Integer;
953 begin
954   for i:=InterfaceFinalizationHandlers.Count-1 downto 0 do
955     TProcedure(InterfaceFinalizationHandlers[i])();
956 end;
957 
958 procedure MoveRect(var ARect: TRect; x, y: Integer);
959 begin
960   inc(ARect.Right,x-ARect.Left);
961   inc(ARect.Bottom,y-ARect.Top);
962   ARect.Left:=x;
963   ARect.Top:=y;
964 end;
965 
966 procedure MoveRectToFit(var ARect: TRect; const MaxRect: TRect);
967 // move ARect, so it fits into MaxRect
968 // if MaxRect is too small, ARect is resized.
969 begin
970   if ARect.Left<MaxRect.Left then begin
971     // move rectangle right
972     ARect.Right:=Min(ARect.Right+MaxRect.Left-ARect.Left,MaxRect.Right);
973     ARect.Left:=MaxRect.Left;
974   end;
975   if ARect.Top<MaxRect.Top then begin
976     // move rectangle down
977     ARect.Bottom:=Min(ARect.Bottom+MaxRect.Top-ARect.Top,MaxRect.Bottom);
978     ARect.Top:=MaxRect.Top;
979   end;
980   if ARect.Right>MaxRect.Right then begin
981     // move rectangle left
982     ARect.Left:=Max(ARect.Left-ARect.Right+MaxRect.Right,MaxRect.Left);
983     ARect.Right:=MaxRect.Right;
984   end;
985   if ARect.Bottom>MaxRect.Bottom then begin
986     // move rectangle left
987     ARect.Top:=Max(ARect.Top-ARect.Bottom+MaxRect.Bottom,MaxRect.Top);
988     ARect.Bottom:=MaxRect.Bottom;
989   end;
990 end;
991 
992 procedure MakeMinMax(var i1, i2: integer);
993 var
994   h: Integer;
995 begin
996   if i1>i2 then begin
997     h:=i1;
998     i1:=i2;
999     i2:=h;
1000   end;
1001 end;
1002 
1003 procedure CalculateLeftTopWidthHeight(X1, Y1, X2, Y2: integer;
1004   out Left, Top, Width, Height: integer);
1005 begin
1006   if X1 <= X2 then
1007    begin
1008     Left := X1;
1009     Width := X2 - X1;
1010   end
1011   else
1012   begin
1013     Left := X2;
1014     Width := X1 - X2;
1015   end;
1016   if Y1 <= Y2 then
1017   begin
1018     Top := Y1;
1019     Height := Y2 - Y1;
1020   end
1021   else
1022   begin
1023     Top := Y2;
1024     Height := Y1 - Y2;
1025   end;
1026 end;
1027 
1028 function ComparePointers(p1, p2: Pointer): integer;
1029 begin
1030   Result:=LazUtilities.ComparePointers(p1, p2);
1031 end;
1032 
1033 function CompareHandles(h1, h2: THandle): integer;
1034 begin
1035   if h1>h2 then
1036     Result:=1
1037   else if h1<h2 then
1038     Result:=-1
1039   else
1040     Result:=0;
1041 end;
1042 
1043 function CompareRect(R1, R2: PRect): Boolean;
1044 begin
1045   Result:=(R1^.Left=R2^.Left) and (R1^.Top=R2^.Top) and
1046           (R1^.Bottom=R2^.Bottom) and (R1^.Right=R2^.Right);
1047   {if not Result then begin
1048     DebugLn(' DIFFER: ',R1^.Left,',',R1^.Top,',',R1^.Right,',',R1^.Bottom
1049       ,' <> ',R2^.Left,',',R2^.Top,',',R2^.Right,',',R2^.Bottom);
1050   end;}
1051 end;
1052 
1053 function ComparePoints(const p1, p2: TPoint): integer;
1054 begin
1055   if p1.Y>p2.Y then
1056     Result:=1
1057   else if p1.Y<p2.Y then
1058     Result:=-1
1059   else if p1.X>p2.X then
1060     Result:=1
1061   else if p1.X<p2.X then
1062     Result:=-1
1063   else
1064     Result:=0;
1065 end;
1066 
1067 function CompareCaret(const FirstCaret, SecondCaret: TPoint): integer;
1068 begin
1069   if (FirstCaret.Y<SecondCaret.Y) then
1070     Result:=1
1071   else if (FirstCaret.Y>SecondCaret.Y) then
1072     Result:=-1
1073   else if (FirstCaret.X<SecondCaret.X) then
1074     Result:=1
1075   else if (FirstCaret.X>SecondCaret.X) then
1076     Result:=-1
1077   else
1078     Result:=0;
1079 end;
1080 
1081 function CompareMethods(const m1, m2: TMethod): boolean;
1082 begin
1083   Result:=LazMethodList.CompareMethods(m1, m2);
1084 end;
1085 
1086 function RoundToInt(const e: Extended): integer;
1087 begin
1088   Result:=integer(Round(e));
1089   {$IFDEF VerboseRound}
1090   DebugLn('RoundToInt ',e,' ',Result);
1091   {$ENDIF}
1092 end;
1093 
1094 function RoundToCardinal(const e: Extended): cardinal;
1095 begin
1096   Result:=cardinal(Round(e));
1097   {$IFDEF VerboseRound}
1098   DebugLn('RoundToCardinal ',e,' ',Result);
1099   {$ENDIF}
1100 end;
1101 
1102 function TruncToInt(const e: Extended): integer;
1103 begin
1104   Result:=integer(Trunc(e));
1105   {$IFDEF VerboseRound}
1106   DebugLn('TruncToInt ',e,' ',Result);
1107   {$ENDIF}
1108 end;
1109 
1110 function TruncToCardinal(const e: Extended): cardinal;
1111 begin
1112   Result:=cardinal(Trunc(e));
1113   {$IFDEF VerboseRound}
1114   DebugLn('TruncToCardinal ',e,' ',Result);
1115   {$ENDIF}
1116 end;
1117 
1118 function StrToDouble(const s: string): double;
1119 begin
1120   {$IFDEF VerboseRound}
1121   DebugLn('StrToDouble "',s,'"');
1122   {$ENDIF}
1123   Result:=Double(StrToFloat(s));
1124 end;
1125 
1126 procedure MergeSort(List: TFPList; const OnCompare: TListSortCompare);
1127 begin
1128   if List=nil then exit;
1129   MergeSort(List,0,List.Count-1,OnCompare);
1130 end;
1131 
1132 procedure MergeSort(List: TFPList; StartIndex, EndIndex: integer;
1133   const OnCompare: TListSortCompare);
1134 // sort so that for each i is OnCompare(List[i],List[i+1])<=0
1135 var
1136   MergeList: PPointer;
1137 
1138   procedure SmallSort(StartPos, EndPos: PtrInt);
1139   // use insertion sort for small lists
1140   var
1141     i: PtrInt;
1142     Best: PtrInt;
1143     j: PtrInt;
1144     Item: Pointer;
1145   begin
1146     for i:=StartPos to EndPos-1 do begin
1147       Best:=i;
1148       for j:=i+1 to EndPos do
1149         if OnCompare(List[Best],List[j])>0 then
1150           Best:=j;
1151       if Best>i then begin
1152         Item:=List[i];
1153         List[i]:=List[Best];
1154         List[Best]:=Item;
1155       end;
1156     end;
1157   end;
1158 
1159   procedure Merge(Pos1, Pos2, Pos3: PtrInt);
1160   // merge two sorted arrays
1161   // the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3
1162   var Src1Pos,Src2Pos,DestPos,cmp,a:PtrInt;
1163   begin
1164     while (Pos3>=Pos2) and (OnCompare(List[Pos2-1],List[Pos3])<=0) do
1165       dec(Pos3);
1166     if (Pos1>=Pos2) or (Pos2>Pos3) then exit;
1167     Src1Pos:=Pos2-1;
1168     Src2Pos:=Pos3;
1169     DestPos:=Pos3;
1170     while (Src2Pos>=Pos2) and (Src1Pos>=Pos1) do begin
1171       cmp:=OnCompare(List[Src1Pos],List[Src2Pos]);
1172       if cmp>0 then begin
1173         MergeList[DestPos]:=List[Src1Pos];
1174         dec(Src1Pos);
1175       end else begin
1176         MergeList[DestPos]:=List[Src2Pos];
1177         dec(Src2Pos);
1178       end;
1179       dec(DestPos);
1180     end;
1181     while Src2Pos>=Pos2 do begin
1182       MergeList[DestPos]:=List[Src2Pos];
1183       dec(Src2Pos);
1184       dec(DestPos);
1185     end;
1186     for a:=DestPos+1 to Pos3 do
1187       List[a]:=MergeList[a];
1188   end;
1189 
1190   procedure Sort(StartPos, EndPos: PtrInt);
1191   // sort an interval in List. Use MergeList as work space.
1192   var
1193     mid: integer;
1194   begin
1195     if EndPos-StartPos<6 then begin
1196       SmallSort(StartPos,EndPos);
1197     end else begin
1198       mid:=(StartPos+EndPos) shr 1;
1199       Sort(StartPos,mid);
1200       Sort(mid+1,EndPos);
1201       Merge(StartPos,mid+1,EndPos);
1202     end;
1203   end;
1204 
1205 var
1206   Cnt: Integer;
1207 begin
1208   if (List=nil) then exit;
1209   Cnt:=List.Count;
1210   if StartIndex<0 then StartIndex:=0;
1211   if EndIndex>=Cnt then EndIndex:=Cnt-1;
1212   if StartIndex>=EndIndex then exit;
1213   MergeList:=GetMem(List.Count*SizeOf(Pointer));
1214   Sort(StartIndex,EndIndex);
1215   Freemem(MergeList);
1216 end;
1217 
1218 procedure MergeSort(List: TStrings; const OnCompare: TStringsSortCompare);
1219 // sort so that for each i is OnCompare(List[i],List[i+1])<=0
1220 var
1221   MergeList: PAnsiString;
1222 
1223   procedure SmallSort(StartPos, EndPos: PtrInt);
1224   // use insertion sort for small lists
1225   var
1226     i: PtrInt;
1227     Best: PtrInt;
1228     j: PtrInt;
1229     Item: string;
1230   begin
1231     for i:=StartPos to EndPos-1 do begin
1232       Best:=i;
1233       for j:=i+1 to EndPos do
1234         if OnCompare(List[Best],List[j])>0 then
1235           Best:=j;
1236       if Best>i then begin
1237         Item:=List[i];
1238         List[i]:=List[Best];
1239         List[Best]:=Item;
1240       end;
1241     end;
1242   end;
1243 
1244   procedure Merge(Pos1, Pos2, Pos3: PtrInt);
1245   // merge two sorted arrays
1246   // the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3
1247   var Src1Pos,Src2Pos,DestPos,cmp,a:integer;
1248   begin
1249     while (Pos3>=Pos2) and (OnCompare(List[Pos2-1],List[Pos3])<=0) do
1250       dec(Pos3);
1251     if (Pos1>=Pos2) or (Pos2>Pos3) then exit;
1252     Src1Pos:=Pos2-1;
1253     Src2Pos:=Pos3;
1254     DestPos:=Pos3;
1255     while (Src2Pos>=Pos2) and (Src1Pos>=Pos1) do begin
1256       cmp:=OnCompare(List[Src1Pos],List[Src2Pos]);
1257       if cmp>0 then begin
1258         MergeList[DestPos]:=List[Src1Pos];
1259         dec(Src1Pos);
1260       end else begin
1261         MergeList[DestPos]:=List[Src2Pos];
1262         dec(Src2Pos);
1263       end;
1264       dec(DestPos);
1265     end;
1266     while Src2Pos>=Pos2 do begin
1267       MergeList[DestPos]:=List[Src2Pos];
1268       dec(Src2Pos);
1269       dec(DestPos);
1270     end;
1271     for a:=DestPos+1 to Pos3 do
1272       List[a]:=MergeList[a];
1273   end;
1274 
1275   procedure Sort(StartPos, EndPos: PtrInt);
1276   // sort an interval in List. Use MergeList as work space.
1277   var
1278     mid: integer;
1279   begin
1280     if EndPos-StartPos<6 then begin
1281       SmallSort(StartPos,EndPos);
1282     end else begin
1283       mid:=(StartPos+EndPos) shr 1;
1284       Sort(StartPos,mid);
1285       Sort(mid+1,EndPos);
1286       Merge(StartPos,mid+1,EndPos);
1287     end;
1288   end;
1289 
1290 var
1291   CurSize: PtrInt;
1292   i: PtrInt;
1293 begin
1294   if (List=nil) or (List.Count<=1) then exit;
1295   CurSize:=PtrInt(List.Count)*SizeOf(Pointer);
1296   MergeList:=GetMem(CurSize);
1297   FillChar(MergeList^,CurSize,0);
1298   Sort(0,List.Count-1);
1299   for i:=0 to List.Count-1 do MergeList[i]:='';
1300   Freemem(MergeList);
1301 end;
1302 
1303 
1304 // Debug funcs :
1305 
1306 procedure RaiseGDBException(const Msg: string);
1307 begin
1308   LazTracer.RaiseGDBException(Msg);
1309 end;
1310 
1311 {$IFnDEF WithOldDebugln}
1312 procedure CloseDebugOutput;
1313 begin
1314   DebugLogger.Finish;
1315 end;
1316 
1317 procedure DbgOut(const s: string);
1318 begin
1319   DebugLogger.DbgOut(s);
1320 end;
1321 
1322 procedure DbgOut(Args: array of const);
1323 begin
1324   DebugLogger.DbgOut(Args);
1325 end;
1326 
1327 procedure DbgOut(const S: String; Args: array of const);
1328 begin
1329   DebugLogger.DbgOut(S, Args);
1330 end;
1331 
1332 procedure DbgOut(const s1, s2: string; const s3: string; const s4: string; const s5: string;
1333   const s6: string; const s7: string; const s8: string; const s9: string; const s10: string;
1334   const s11: string; const s12: string; const s13: string; const s14: string;
1335   const s15: string; const s16: string; const s17: string; const s18: string);
1336 begin
1337   DebugLogger.DbgOut(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18);
1338 end;
1339 
1340 procedure DebugLn(const s: string);
1341 begin
1342   DebugLogger.DebugLn(s);
1343 end;
1344 
1345 procedure DebugLn(Args: array of const);
1346 begin
1347   DebugLogger.DebugLn(Args);
1348 end;
1349 
1350 procedure DebugLn(const S: String; Args: array of const);
1351 begin
1352   DebugLogger.DebugLn(S, Args);
1353 end;
1354 
1355 procedure DebugLn(const s1, s2: string; const s3: string; const s4: string; const s5: string;
1356   const s6: string; const s7: string; const s8: string; const s9: string; const s10: string;
1357   const s11: string; const s12: string; const s13: string; const s14: string;
1358   const s15: string; const s16: string; const s17: string; const s18: string);
1359 begin
1360   DebugLogger.DebugLn(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18);
1361 end;
1362 
1363 procedure DebugLnEnter(const s: string);
1364 begin
1365   DebugLogger.DebugLnEnter(s);
1366 end;
1367 
1368 procedure DebugLnEnter(Args: array of const);
1369 begin
1370   DebugLogger.DebugLnEnter(Args);
1371 end;
1372 
1373 procedure DebugLnEnter(s: string; Args: array of const);
1374 begin
1375   DebugLogger.DebugLnEnter(s, Args);
1376 end;
1377 
1378 procedure DebugLnEnter(const s1, s2: string; const s3: string; const s4: string;
1379   const s5: string; const s6: string; const s7: string; const s8: string; const s9: string;
1380   const s10: string; const s11: string; const s12: string; const s13: string;
1381   const s14: string; const s15: string; const s16: string; const s17: string;
1382   const s18: string);
1383 begin
1384   DebugLogger.DebugLnEnter(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18);
1385 end;
1386 
1387 procedure DebugLnExit(const s: string);
1388 begin
1389   DebugLogger.DebugLnExit(s);
1390 end;
1391 
1392 procedure DebugLnExit(Args: array of const);
1393 begin
1394   DebugLogger.DebugLnExit(Args);
1395 end;
1396 
1397 procedure DebugLnExit(s: string; Args: array of const);
1398 begin
1399   DebugLogger.DebugLnExit(s, Args);
1400 end;
1401 
1402 procedure DebugLnExit(const s1, s2: string; const s3: string; const s4: string;
1403   const s5: string; const s6: string; const s7: string; const s8: string; const s9: string;
1404   const s10: string; const s11: string; const s12: string; const s13: string;
1405   const s14: string; const s15: string; const s16: string; const s17: string;
1406   const s18: string);
1407 begin
1408   DebugLogger.DebugLnExit(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18);
1409 end;
1410 
1411 
1412 {$ELSE}
1413 
1414 procedure InitializeDebugOutput;
1415 var
1416   DebugFileName: string;
1417 
1418   function GetDebugFileName: string;
1419   const
1420     DebugLogStart = '--debug-log=';
1421     DebugLogStartLength = length(DebugLogStart);
1422   var
1423     i: integer;
1424     EnvVarName: string;
1425   begin
1426     Result := '';
1427     // first try to find the log file name in the command line parameters
1428     for i:= 1 to Paramcount do begin
1429       if copy(ParamStrUTF8(i),1, DebugLogStartLength)=DebugLogStart then begin
1430         Result := copy(ParamStrUTF8(i), DebugLogStartLength+1,
1431                    Length(ParamStrUTF8(i))-DebugLogStartLength);
1432       end;
1433     end;
1434     // if not found yet, then try to find in the environment variables
1435     if (length(result)=0) then begin
1436       EnvVarName:= ChangeFileExt(ExtractFileName(ParamStrUTF8(0)),'') + '_debuglog';
1437       Result := GetEnvironmentVariableUTF8(EnvVarName);
1438     end;
1439     if (length(result)>0) then
1440       Result := ExpandFileNameUTF8(Result);
1441   end;
1442 
1443 var
1444   fm: Byte;
1445 begin
1446   DebugText := nil;
1447   DebugFileName := GetDebugFileName;
1448   if (length(DebugFileName)>0) and
1449     (DirPathExists(ExtractFileDir(DebugFileName))) then
1450   begin
1451     fm:=Filemode;
1452     new(DebugText);
1453     try
1454       Filemode:=fmShareDenyNone;
1455       Assign(DebugText^, DebugFileName);
1456       if FileExistsUTF8(DebugFileName) then
1457         Append(DebugText^)
1458       else
1459         Rewrite(DebugText^);
1460     except
1461       Freemem(DebugText);
1462       DebugText := nil;
1463       // Add extra line ending: a dialog will be shown in windows gui application
1464       writeln(StdOut, 'Cannot open file: ', DebugFileName+LineEnding);
1465     end;
1466     Filemode:=fm;
1467   end;
1468   if DebugText=nil then
1469   begin
1470     if TextRec(Output).Mode=fmClosed then
1471       DebugText := nil
1472     else
1473       DebugText := @Output;
1474     DebugTextAllocated := false;
1475   end else
1476     DebugTextAllocated := true;
1477 end;
1478 
1479 procedure CloseDebugOutput;
1480 begin
1481   if DebugTextAllocated then begin
1482     Close(DebugText^);
1483     Dispose(DebugText);
1484     DebugTextAllocated := false;
1485   end;
1486   DebugText := nil;
1487 end;
1488 
1489 procedure FinalizeDebugOutput;
1490 begin
1491   CloseDebugOutput;
1492 end;
1493 
1494 procedure DebugLnNestCreatePrefix;
1495 const
1496   CurrentLen: Integer = 0;
1497 var
1498   s: String;
1499   NewLen: Integer;
1500 begin
1501   NewLen := DebugNestLvl * DebugLnNestLvlIndent;
1502   if NewLen < 0 then NewLen := 0;
1503   if (NewLen >= DebugLnMaxNestPrefixLen) then begin
1504     NewLen := DebugLnMaxNestPrefixLen;
1505     s := IntToStr(DebugNestLvl);
1506     if length(s)+1 > NewLen then
1507       NewLen := length(s)+1;
1508   end else
1509     s := '';
1510 
1511   if NewLen > CurrentLen then
1512     ReAllocMem(DebugNestPrefix, NewLen+21);
1513   CurrentLen := NewLen+20;
1514 
1515   FillChar(DebugNestPrefix^, NewLen, ' ');
1516   if s <> '' then
1517     System.Move(s[1], DebugNestPrefix[0], length(s));
1518 
1519   if (NewLen >= DebugLnMaxNestPrefixLen) then
1520     DebugNestPrefix[DebugLnMaxNestPrefixLen] := #0
1521   else
1522     DebugNestPrefix[NewLen] := #0;
1523 end;
1524 
1525 procedure DebugLnNestFreePrefix;
1526 begin
1527   if DebugNestPrefix <> nil then
1528     ReAllocMem(DebugNestPrefix, 0);
1529 end;
1530 
1531 procedure DumpStack;
1532 begin
1533   if Assigned(DebugText) then
1534     Dump_Stack(DebugText^, get_frame);
1535 end;
1536 
1537 procedure DebugLn(Args: array of const);
1538 var
1539   i: Integer;
1540 begin
1541   for i:=Low(Args) to High(Args) do begin
1542     case Args[i].VType of
1543     vtInteger: DbgOut(dbgs(Args[i].vinteger));
1544     vtInt64: DbgOut(dbgs(Args[i].VInt64^));
1545     vtQWord: DbgOut(dbgs(Args[i].VQWord^));
1546     vtBoolean: DbgOut(dbgs(Args[i].vboolean));
1547     vtExtended: DbgOut(dbgs(Args[i].VExtended^));
1548 {$ifdef FPC_CURRENCY_IS_INT64}
1549     // MWE:
1550     // fpc 2.x has troubles in choosing the right dbgs()
1551     // so we convert here
1552     vtCurrency: DbgOut(dbgs(int64(Args[i].vCurrency^)/10000, 4));
1553 {$else}
1554     vtCurrency: DbgOut(dbgs(Args[i].vCurrency^));
1555 {$endif}
1556     vtString: DbgOut(Args[i].VString^);
1557     vtAnsiString: DbgOut(AnsiString(Args[i].VAnsiString));
1558     vtChar: DbgOut(Args[i].VChar);
1559     vtPChar: DbgOut(Args[i].VPChar);
1560     vtPWideChar: DbgOut(Args[i].VPWideChar);
1561     vtWideChar: DbgOut(AnsiString(Args[i].VWideChar));
1562     vtWidestring: DbgOut(AnsiString(WideString(Args[i].VWideString)));
1563     vtUnicodeString: DbgOut(AnsiString(UnicodeString(Args[i].VUnicodeString)));
1564     vtObject: DbgOut(DbgSName(Args[i].VObject));
1565     vtClass: DbgOut(DbgSName(Args[i].VClass));
1566     vtPointer: DbgOut(Dbgs(Args[i].VPointer));
1567     else
1568       DbgOut('?unknown variant?');
1569     end;
1570   end;
1571   DebugLn;
1572 end;
1573 
1574 procedure DebugLn(const S: String; Args: array of const);
1575 begin
1576   DebugLn(Format(S, Args));
1577 end;
1578 
1579 procedure DebugLn;
1580 begin
1581   DebugLn('');
1582 end;
1583 
1584 procedure DebugLn(const s: string);
1585 begin
1586   {$ifdef WinCE}
1587   if DebugNestAtBOL and (s <> '') then
1588     DbgAppendToFile(ExtractFilePath(ParamStr(0)) + Str_LCL_Debug_File, DebugNestPrefix+s)
1589   else
1590     DbgAppendToFile(ExtractFilePath(ParamStr(0)) + Str_LCL_Debug_File, s);
1591   {$else}
1592   // First of all verify if a widgetset has override DebugLn
1593   if DebugLnProc <> nil then
1594   begin
1595     DebugLnProc(s);
1596     Exit;
1597   end;
1598 
1599   // Now the default code
1600   if not Assigned(DebugText) then exit;
1601   if DebugNestAtBOL and (s <> '') then
1602     write(DebugText^, DebugNestPrefix);
1603   writeln(DebugText^, ConvertLineEndings(s));
1604   {$endif}
1605   DebugNestAtBOL := True;
1606 end;
1607 
1608 procedure DebugLn(const s1, s2: string);
1609 begin
1610   DebugLn(s1+s2);
1611 end;
1612 
1613 procedure DebugLn(const s1, s2, s3: string);
1614 begin
1615   DebugLn(s1+s2+s3);
1616 end;
1617 
1618 procedure DebugLn(const s1, s2, s3, s4: string);
1619 begin
1620   DebugLn(s1+s2+s3+s4);
1621 end;
1622 
1623 procedure DebugLn(const s1, s2, s3, s4, s5: string);
1624 begin
1625   DebugLn(s1+s2+s3+s4+s5);
1626 end;
1627 
1628 procedure DebugLn(const s1, s2, s3, s4, s5, s6: string);
1629 begin
1630   DebugLn(s1+s2+s3+s4+s5+s6);
1631 end;
1632 
1633 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7: string);
1634 begin
1635   DebugLn(s1+s2+s3+s4+s5+s6+s7);
1636 end;
1637 
1638 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8: string);
1639 begin
1640   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8);
1641 end;
1642 
1643 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9: string);
1644 begin
1645   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9);
1646 end;
1647 
1648 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10: string);
1649 begin
1650   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10);
1651 end;
1652 
1653 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11: string);
1654 begin
1655   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11);
1656 end;
1657 
1658 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11,
1659   s12: string);
1660 begin
1661   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12);
1662 end;
1663 
1664 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12,
1665   s13: string);
1666 begin
1667   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13);
1668 end;
1669 
1670 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13,
1671   s14: string);
1672 begin
1673   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14);
1674 end;
1675 
1676 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13,
1677   s14, s15: string);
1678 begin
1679   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15);
1680 end;
1681 
1682 procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13,
1683   s14, s15, s16: string);
1684 begin
1685   DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15+s16);
1686 end;
1687 
1688 procedure DebugLnEnter(const s: string);
1689 begin
1690   if not DebugNestAtBOL then
1691     DebugLn;
1692   if s <> '' then
1693     DebugLn(s);
1694   inc(DebugNestLvl);
1695   DebugLnNestCreatePrefix;
1696 end;
1697 
1698 procedure DebugLnEnter(Args: array of const);
1699 begin
1700   if not DebugNestAtBOL then
1701     DebugLn;
1702   DebugLn(Args);
1703   inc(DebugNestLvl);
1704   DebugLnNestCreatePrefix;
1705 end;
1706 
1707 procedure DebugLnEnter(s: string; Args: array of const);
1708 begin
1709   DebugLnEnter(Format(s, Args));
1710 end;
1711 
1712 procedure DebugLnEnter(const s1: string; const s2: string; const s3: string;
1713   const s4: string; const s5: string; const s6: string; const s7: string;
1714   const s8: string; const s9: string; const s10: string; const s11: string;
1715   const s12: string; const s13: string; const s14: string; const s15: string;
1716   const s16: string; const s17: string; const s18: string);
1717 begin
1718   DebugLnEnter(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15+s16+s17+s18);
1719 end;
1720 
1721 procedure DebugLnExit(const s: string);
1722 begin
1723   dec(DebugNestLvl);
1724   if DebugNestLvl < 0 then DebugNestLvl := 0;
1725   DebugLnNestCreatePrefix;
1726   if not DebugNestAtBOL then
1727     DebugLn;
1728   if s <> '' then
1729     DebugLn(s);
1730 end;
1731 
1732 procedure DebugLnExit(Args: array of const);
1733 begin
1734   dec(DebugNestLvl);
1735   if DebugNestLvl < 0 then DebugNestLvl := 0;
1736   DebugLnNestCreatePrefix;
1737   if not DebugNestAtBOL then
1738     DebugLn;
1739   DebugLn(Args);
1740 end;
1741 
1742 procedure DebugLnExit(s: string; Args: array of const);
1743 begin
1744   DebugLnExit(Format(s, Args));
1745 end;
1746 
1747 procedure DebugLnExit(const s1: string; const s2: string; const s3: string;
1748   const s4: string; const s5: string; const s6: string; const s7: string;
1749   const s8: string; const s9: string; const s10: string; const s11: string;
1750   const s12: string; const s13: string; const s14: string; const s15: string;
1751   const s16: string; const s17: string; const s18: string);
1752 begin
1753   DebugLnExit(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15+s16+s17+s18);
1754 end;
1755 
1756 procedure DbgOut(const S: String; Args: array of const);
1757 begin
1758   DbgOut(Format(S, Args));
1759 end;
1760 
1761 procedure DBGOut(const s: string);
1762 begin
1763   {$ifdef WinCE}
1764   if DebugNestAtBOL and (s <> '') then
1765     DbgAppendToFileWithoutLn(ExtractFilePath(ParamStr(0)) + Str_LCL_Debug_File, DebugNestPrefix);
1766   DbgAppendToFileWithoutLn(ExtractFilePath(ParamStr(0)) + Str_LCL_Debug_File, s);
1767   {$else}
1768   if DebugOutProc <> nil then
1769   begin
1770     DebugOutProc(s);
1771     Exit;
1772   end;
1773 
1774   if Assigned(DebugText) then begin
1775     if DebugNestAtBOL and (s <> '') then
1776       write(DebugText^, DebugNestPrefix);
1777     write(DebugText^, s);
1778   end;
1779   {$endif}
1780   DebugNestAtBOL := (s = '') or (s[length(s)] in [#10,#13]);
1781 end;
1782 
1783 procedure DBGOut(const s1, s2: string);
1784 begin
1785   DbgOut(s1+s2);
1786 end;
1787 
1788 procedure DbgOut(const s1, s2, s3: string);
1789 begin
1790   DbgOut(s1+s2+s3);
1791 end;
1792 
1793 procedure DbgOut(const s1, s2, s3, s4: string);
1794 begin
1795   DbgOut(s1+s2+s3+s4);
1796 end;
1797 
1798 procedure DbgOut(const s1, s2, s3, s4, s5: string);
1799 begin
1800   DbgOut(s1+s2+s3+s4+s5);
1801 end;
1802 
1803 procedure DbgOut(const s1, s2, s3, s4, s5, s6: string);
1804 begin
1805   DbgOut(s1+s2+s3+s4+s5+s6);
1806 end;
1807 
1808 procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7: string);
1809 begin
1810   DbgOut(s1+s2+s3+s4+s5+s6+s7);
1811 end;
1812 
1813 procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8: string);
1814 begin
1815   DbgOut(s1+s2+s3+s4+s5+s6+s7+s8);
1816 end;
1817 
1818 procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8, s9: string);
1819 begin
1820   DbgOut(s1+s2+s3+s4+s5+s6+s7+s8+s9);
1821 end;
1822 
1823 procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10: string);
1824 begin
1825   DbgOut(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10);
1826 end;
1827 
1828 procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11: string);
1829 begin
1830   DbgOut(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11);
1831 end;
1832 
1833 procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12: string);
1834 begin
1835   DbgOut(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12);
1836 end;
1837 {$ENDIF}
1838 
1839 function DbgS(const c: cardinal): string;
1840 begin
1841   Result:=LazLoggerBase.DbgS(c);
1842 end;
1843 
1844 function DbgS(const i: longint): string;
1845 begin
1846   Result:=LazLoggerBase.DbgS(i);
1847 end;
1848 
1849 function DbgS(const i: int64): string;
1850 begin
1851   Result:=LazLoggerBase.DbgS(i);
1852 end;
1853 
1854 function DbgS(const q: qword): string;
1855 begin
1856   Result:=LazLoggerBase.DbgS(q);
1857 end;
1858 
1859 function DbgS(const r: TRect): string;
1860 begin
1861   Result:=LazLoggerBase.DbgS(r);
1862 end;
1863 
1864 function DbgS(const p: TPoint): string;
1865 begin
1866   Result:=LazLoggerBase.DbgS(p);
1867 end;
1868 
1869 function DbgS(const p: pointer): string;
1870 begin
1871   Result:=LazLoggerBase.DbgS(p);
1872 end;
1873 
1874 function DbgS(const e: extended; MaxDecimals: integer): string;
1875 begin
1876   Result:=LazLoggerBase.DbgS(e,MaxDecimals);
1877 end;
1878 
1879 function DbgS(const b: boolean): string;
1880 begin
1881   Result:=LazLoggerBase.DbgS(b);
1882 end;
1883 
1884 function DbgS(const s: TComponentState): string;
1885 begin
1886   Result:=LazLoggerBase.DbgS(s);
1887 end;
1888 
1889 function DbgS(const m: TMethod): string;
1890 begin
1891   Result:=LazLoggerBase.DbgS(m);
1892 end;
1893 
1894 function DbgSName(const p: TObject): string;
1895 begin
1896   Result:=LazLoggerBase.DbgSName(p);
1897 end;
1898 
1899 function DbgSName(const p: TClass): string;
1900 begin
1901   Result:=LazLoggerBase.DbgSName(p);
1902 end;
1903 
1904 function DbgStr(const StringWithSpecialChars: string): string;
1905 begin
1906   Result:=LazLoggerBase.DbgStr(StringWithSpecialChars);
1907 end;
1908 
1909 function DbgWideStr(const StringWithSpecialChars: widestring): string;
1910 begin
1911   Result:=LazLoggerBase.DbgWideStr(StringWithSpecialChars);
1912 end;
1913 
1914 function dbgMemRange(P: PByte; Count: integer; Width: integer): string;
1915 begin
1916   Result:=LazLoggerBase.dbgMemRange(P,Count,Width);
1917 end;
1918 
1919 function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string;
1920 begin
1921   Result:=LazLoggerBase.dbgMemStream(MemStream,Count);
1922 end;
1923 
1924 function dbgObjMem(AnObject: TObject): string;
1925 begin
1926   Result:=LazLoggerBase.dbgObjMem(AnObject);
1927 end;
1928 
1929 function dbghex(i: Int64): string;
1930 begin
1931   Result:=LazLoggerBase.dbghex(i);
1932 end;
1933 
1934 function DbgSWindowPosFlags(Flags: UInt): String;
1935 begin
1936   Result := '';
1937   if (SWP_NOSIZE and Flags) <> 0 then
1938     Result := Result + 'SWP_NOSIZE, ';
1939   if (SWP_NOMOVE and Flags) <> 0 then
1940     Result := Result + 'SWP_NOMOVE, ';
1941   if (SWP_NOZORDER and Flags) <> 0 then
1942     Result := Result + 'SWP_NOZORDER, ';
1943   if (SWP_NOREDRAW and Flags) <> 0 then
1944     Result := Result + 'SWP_NOREDRAW, ';
1945   if (SWP_NOACTIVATE and Flags) <> 0 then
1946     Result := Result + 'SWP_NOACTIVATE, ';
1947   if (SWP_DRAWFRAME and Flags) <> 0 then
1948     Result := Result + 'SWP_DRAWFRAME, ';
1949   if (SWP_SHOWWINDOW and Flags) <> 0 then
1950     Result := Result + 'SWP_SHOWWINDOW, ';
1951   if (SWP_HIDEWINDOW and Flags) <> 0 then
1952     Result := Result + 'SWP_HIDEWINDOW, ';
1953   if (SWP_NOCOPYBITS and Flags) <> 0 then
1954     Result := Result + 'SWP_NOCOPYBITS, ';
1955   if (SWP_NOOWNERZORDER and Flags) <> 0 then
1956     Result := Result + 'SWP_NOOWNERZORDER, ';
1957   if (SWP_NOSENDCHANGING and Flags) <> 0 then
1958     Result := Result + 'SWP_NOSENDCHANGING, ';
1959   if (SWP_DEFERERASE and Flags) <> 0 then
1960     Result := Result + 'SWP_DEFERERASE, ';
1961   if (SWP_ASYNCWINDOWPOS and Flags) <> 0 then
1962     Result := Result + 'SWP_ASYNCWINDOWPOS, ';
1963   if (SWP_STATECHANGED and Flags) <> 0 then
1964     Result := Result + 'SWP_STATECHANGED, ';
1965   if (SWP_SourceIsInterface and Flags) <> 0 then
1966     Result := Result + 'SWP_SourceIsInterface, ';
1967   if Result <> '' then
1968     Delete(Result, Length(Result) - 1, 2);
1969 end;
1970 
1971 function DbgS(const i1, i2, i3, i4: integer): string;
1972 begin
1973   Result:=LazLoggerBase.DbgS(i1,i2,i3,i4);
1974 end;
1975 
1976 function DbgS(const Shift: TShiftState): string;
1977 begin
1978   Result:=LazLoggerBase.DbgS(Shift);
1979 end;
1980 
1981 function DbgsVKCode(c: word): string;
1982 begin
1983   case c of
1984   VK_UNKNOWN: Result:='VK_UNKNOWN';
1985   VK_LBUTTON: Result:='VK_LBUTTON';
1986   VK_RBUTTON: Result:='VK_RBUTTON';
1987   VK_CANCEL: Result:='VK_CANCEL';
1988   VK_MBUTTON: Result:='VK_MBUTTON';
1989   VK_BACK: Result:='VK_BACK';
1990   VK_TAB: Result:='VK_TAB';
1991   VK_CLEAR: Result:='VK_CLEAR';
1992   VK_RETURN: Result:='VK_RETURN';
1993   VK_SHIFT: Result:='VK_SHIFT';
1994   VK_CONTROL: Result:='VK_CONTROL';
1995   VK_MENU: Result:='VK_MENU';
1996   VK_PAUSE: Result:='VK_PAUSE';
1997   VK_CAPITAL: Result:='VK_CAPITAL';
1998   VK_KANA: Result:='VK_KANA';
1999   VK_JUNJA: Result:='VK_JUNJA';
2000   VK_FINAL: Result:='VK_FINAL';
2001   VK_HANJA: Result:='VK_HANJA';
2002   VK_ESCAPE: Result:='VK_ESCAPE';
2003   VK_CONVERT: Result:='VK_CONVERT';
2004   VK_NONCONVERT: Result:='VK_NONCONVERT';
2005   VK_ACCEPT: Result:='VK_ACCEPT';
2006   VK_MODECHANGE: Result:='VK_MODECHANGE';
2007   VK_SPACE: Result:='VK_SPACE';
2008   VK_PRIOR: Result:='VK_PRIOR';
2009   VK_NEXT: Result:='VK_NEXT';
2010   VK_END: Result:='VK_END';
2011   VK_HOME: Result:='VK_HOME';
2012   VK_LEFT: Result:='VK_LEFT';
2013   VK_UP: Result:='VK_UP';
2014   VK_RIGHT: Result:='VK_RIGHT';
2015   VK_DOWN: Result:='VK_DOWN';
2016   VK_SELECT: Result:='VK_SELECT';
2017   VK_PRINT: Result:='VK_PRINT';
2018   VK_EXECUTE: Result:='VK_EXECUTE';
2019   VK_SNAPSHOT: Result:='VK_SNAPSHOT';
2020   VK_INSERT: Result:='VK_INSERT';
2021   VK_DELETE: Result:='VK_DELETE';
2022   VK_HELP: Result:='VK_HELP';
2023 
2024   VK_0: Result:='VK_0';
2025   VK_1: Result:='VK_1';
2026   VK_2: Result:='VK_2';
2027   VK_3: Result:='VK_3';
2028   VK_4: Result:='VK_4';
2029   VK_5: Result:='VK_5';
2030   VK_6: Result:='VK_6';
2031   VK_7: Result:='VK_7';
2032   VK_8: Result:='VK_8';
2033   VK_9: Result:='VK_9';
2034 
2035   VK_A: Result:='VK_A';
2036   VK_B: Result:='VK_B';
2037   VK_C: Result:='VK_C';
2038   VK_D: Result:='VK_D';
2039   VK_E: Result:='VK_E';
2040   VK_F: Result:='VK_F';
2041   VK_G: Result:='VK_G';
2042   VK_H: Result:='VK_H';
2043   VK_I: Result:='VK_I';
2044   VK_J: Result:='VK_J';
2045   VK_K: Result:='VK_K';
2046   VK_L: Result:='VK_L';
2047   VK_M: Result:='VK_M';
2048   VK_N: Result:='VK_N';
2049   VK_O: Result:='VK_O';
2050   VK_P: Result:='VK_P';
2051   VK_Q: Result:='VK_Q';
2052   VK_R: Result:='VK_R';
2053   VK_S: Result:='VK_S';
2054   VK_T: Result:='VK_T';
2055   VK_U: Result:='VK_U';
2056   VK_V: Result:='VK_V';
2057   VK_W: Result:='VK_W';
2058   VK_X: Result:='VK_X';
2059   VK_Y: Result:='VK_Y';
2060   VK_Z: Result:='VK_Z';
2061 
2062   VK_LWIN: Result:='VK_LWIN';
2063   VK_RWIN: Result:='VK_RWIN';
2064   VK_APPS: Result:='VK_APPS';
2065   VK_SLEEP: Result:='VK_SLEEP';
2066 
2067   VK_NUMPAD0: Result:='VK_NUMPAD0';
2068   VK_NUMPAD1: Result:='VK_NUMPAD1';
2069   VK_NUMPAD2: Result:='VK_NUMPAD2';
2070   VK_NUMPAD3: Result:='VK_NUMPAD3';
2071   VK_NUMPAD4: Result:='VK_NUMPAD4';
2072   VK_NUMPAD5: Result:='VK_NUMPAD5';
2073   VK_NUMPAD6: Result:='VK_NUMPAD6';
2074   VK_NUMPAD7: Result:='VK_NUMPAD7';
2075   VK_NUMPAD8: Result:='VK_NUMPAD8';
2076   VK_NUMPAD9: Result:='VK_NUMPAD9';
2077   VK_MULTIPLY: Result:='VK_MULTIPLY';
2078   VK_ADD: Result:='VK_ADD';
2079   VK_SEPARATOR: Result:='VK_SEPARATOR';
2080   VK_SUBTRACT: Result:='VK_SUBTRACT';
2081   VK_DECIMAL: Result:='VK_DECIMAL';
2082   VK_DIVIDE: Result:='VK_DIVIDE';
2083   VK_F1: Result:='VK_F1';
2084   VK_F2: Result:='VK_F2';
2085   VK_F3: Result:='VK_F3';
2086   VK_F4: Result:='VK_F4';
2087   VK_F5: Result:='VK_F5';
2088   VK_F6: Result:='VK_F6';
2089   VK_F7: Result:='VK_F7';
2090   VK_F8: Result:='VK_F8';
2091   VK_F9: Result:='VK_F9';
2092   VK_F10: Result:='VK_F10';
2093   VK_F11: Result:='VK_F11';
2094   VK_F12: Result:='VK_F12';
2095   VK_F13: Result:='VK_F13';
2096   VK_F14: Result:='VK_F14';
2097   VK_F15: Result:='VK_F15';
2098   VK_F16: Result:='VK_F16';
2099   VK_F17: Result:='VK_F17';
2100   VK_F18: Result:='VK_F18';
2101   VK_F19: Result:='VK_F19';
2102   VK_F20: Result:='VK_F20';
2103   VK_F21: Result:='VK_F21';
2104   VK_F22: Result:='VK_F22';
2105   VK_F23: Result:='VK_F23';
2106   VK_F24: Result:='VK_F24';
2107 
2108   VK_NUMLOCK: Result:='VK_NUMLOCK';
2109   VK_SCROLL: Result:='VK_SCROLL';
2110 
2111   VK_LSHIFT: Result:='VK_LSHIFT';
2112   VK_RSHIFT: Result:='VK_RSHIFT';
2113   VK_LCONTROL: Result:='VK_LCONTROL';
2114   VK_RCONTROL: Result:='VK_RCONTROL';
2115   VK_LMENU: Result:='VK_LMENU';
2116   VK_RMENU: Result:='VK_RMENU';
2117 
2118   VK_BROWSER_BACK: Result:='VK_BROWSER_BACK';
2119   VK_BROWSER_FORWARD: Result:='VK_BROWSER_FORWARD';
2120   VK_BROWSER_REFRESH: Result:='VK_BROWSER_REFRESH';
2121   VK_BROWSER_STOP: Result:='VK_BROWSER_STOP';
2122   VK_BROWSER_SEARCH: Result:='VK_BROWSER_SEARCH';
2123   VK_BROWSER_FAVORITES: Result:='VK_BROWSER_FAVORITES';
2124   VK_BROWSER_HOME: Result:='VK_BROWSER_HOME';
2125   VK_VOLUME_MUTE: Result:='VK_VOLUME_MUTE';
2126   VK_VOLUME_DOWN: Result:='VK_VOLUME_DOWN';
2127   VK_VOLUME_UP: Result:='VK_VOLUME_UP';
2128   VK_MEDIA_NEXT_TRACK: Result:='VK_MEDIA_NEXT_TRACK';
2129   VK_MEDIA_PREV_TRACK: Result:='VK_MEDIA_PREV_TRACK';
2130   VK_MEDIA_STOP: Result:='VK_MEDIA_STOP';
2131   VK_MEDIA_PLAY_PAUSE: Result:='VK_MEDIA_PLAY_PAUSE';
2132   VK_LAUNCH_MAIL: Result:='VK_LAUNCH_MAIL';
2133   VK_LAUNCH_MEDIA_SELECT: Result:='VK_LAUNCH_MEDIA_SELECT';
2134   VK_LAUNCH_APP1: Result:='VK_LAUNCH_APP1';
2135   VK_LAUNCH_APP2: Result:='VK_LAUNCH_APP2';
2136   // New keys in 0.9.31+
2137   VK_LCL_EQUAL: Result:='VK_LCL_EQUAL';
2138   VK_LCL_COMMA: Result:='VK_LCL_COMMA';
2139   VK_LCL_POINT: Result:='VK_LCL_POINT';
2140   VK_LCL_SLASH: Result:='VK_LCL_SLASH';
2141   VK_LCL_SEMI_COMMA:Result:='VK_LCL_SEMI_COMMA';
2142   VK_LCL_MINUS     :Result:='VK_LCL_MINUS';
2143   VK_LCL_OPEN_BRAKET:Result:='VK_LCL_OPEN_BRAKET';
2144   VK_LCL_CLOSE_BRAKET:Result:='VK_LCL_CLOSE_BRAKET';
2145   VK_LCL_BACKSLASH :Result:='VK_LCL_BACKSLASH';
2146   VK_LCL_TILDE     :Result:='VK_LCL_TILDE';
2147   VK_LCL_QUOTE     :Result:='VK_LCL_QUOTE';
2148   //
2149   VK_LCL_POWER: Result:='VK_LCL_POWER';
2150   VK_LCL_CALL: Result:='VK_LCL_CALL';
2151   VK_LCL_ENDCALL: Result:='VK_LCL_ENDCALL';
2152   VK_LCL_AT: Result:='VK_LCL_AT';
2153   else
2154     Result:='VK_('+dbgs(c)+')';
2155   end;
2156 end;
2157 
2158 function DbgS(const ASize: TSize): string;
2159 begin
2160   Result:=LazLoggerBase.DbgS(ASize);
2161 end;
2162 
2163 function DbgS(const ATM: TTextMetric): string;
2164 begin
2165   with ATM do
2166     Result :=
2167       'tmHeight: ' + DbgS(tmHeight) +
2168       ' tmAscent: ' + DbgS(tmAscent) +
2169       ' tmDescent: ' + DbgS(tmDescent) +
2170       ' tmInternalLeading: ' + DbgS(tmInternalLeading) +
2171       ' tmExternalLeading: ' + DbgS(tmExternalLeading) +
2172       ' tmAveCharWidth: ' + DbgS(tmAveCharWidth) +
2173       ' tmMaxCharWidth: ' + DbgS(tmMaxCharWidth) +
2174       ' tmWeight: ' + DbgS(tmWeight) +
2175       ' tmOverhang: ' + DbgS(tmOverhang) +
2176       ' tmDigitizedAspectX: ' + DbgS(tmDigitizedAspectX) +
2177       ' tmDigitizedAspectY: ' + DbgS(tmDigitizedAspectY) +
2178       ' tmFirstChar: ' + tmFirstChar +
2179       ' tmLastChar: ' + tmLastChar +
2180       ' tmDefaultChar: ' + tmDefaultChar +
2181       ' tmBreakChar: ' + tmBreakChar +
2182       ' tmItalic: ' + DbgS(tmItalic) +
2183       ' tmUnderlined: ' + DbgS(tmUnderlined) +
2184       ' tmStruckOut: ' + DbgS(tmStruckOut) +
2185       ' tmPitchAndFamily: ' + DbgS(tmPitchAndFamily) +
2186       ' tmCharSet: ' + DbgS(tmCharSet);
2187 end;
2188 
2189 function DbgS(const AScrollInfo: TScrollInfo): string;
2190 begin
2191   Result := '';
2192 
2193   if (SIF_POS and AScrollInfo.fMask) > 0 then
2194     Result := 'Pos: ' + DbgS(AScrollInfo.nPos);
2195   if (SIF_RANGE and AScrollInfo.fMask) > 0 then
2196     Result := Result + ' Min: ' + DbgS(AScrollInfo.nMin) + ' Max: ' +
2197       DbgS(AScrollInfo.nMax);
2198   if (SIF_PAGE and AScrollInfo.fMask) > 0 then
2199     Result := Result + ' Page: ' + DbgS(AScrollInfo.nPage);
2200   if (SIF_TRACKPOS and AScrollInfo.fMask) > 0 then
2201     Result := Result + ' TrackPos: ' + DbgS(AScrollInfo.nTrackPos);
2202 
2203   if Result = '' then Result := '(no scrollinfo)';
2204 end;
2205 
2206 function DbgS(const AVariant: Variant): string;
2207 begin
2208   if TVarData(AVariant).VType = varEmpty then
2209     result := '<empty>'
2210   else
2211   if TVarData(AVariant).vtype = varNull then
2212     result := '<null>'
2213   else
2214     result := AVariant;
2215 end;
2216 
2217 procedure DbgOutThreadLog(const Msg: string);
2218 var
2219   PID: PtrInt;
2220   fs: TFileStreamUTF8;
2221   Filename: string;
2222 begin
2223   PID:=PtrInt(GetThreadID);
2224   Filename:='Log'+IntToStr(PID);
2225   if FileExistsUTF8(Filename) then
2226     fs:=TFileStreamUTF8.Create(Filename,fmOpenWrite or fmShareDenyNone)
2227   else
2228     fs:=TFileStreamUTF8.Create(Filename,fmCreate);
2229   fs.Position:=fs.Size;
2230   fs.Write(Msg[1], length(Msg));
2231   fs.Free;
2232 end;
2233 
2234 procedure DebuglnThreadLog(const Msg: string);
2235 var
2236   PID: PtrInt;
2237 begin
2238   PID:=PtrInt(GetThreadID);
2239   DbgOutThreadLog(IntToStr(PtrInt(PID))+' : '+Msg+LineEnding);
2240 end;
2241 
2242 procedure DebuglnThreadLog(Args: array of const);
2243 var
2244   i: Integer;
2245   s: String;
2246 begin
2247   s:='';
2248   for i:=Low(Args) to High(Args) do begin
2249     case Args[i].VType of
2250     vtInteger: s:=s+dbgs(Args[i].vinteger);
2251     vtInt64: s:=s+dbgs(Args[i].VInt64^);
2252     vtQWord: s:=s+dbgs(Args[i].VQWord^);
2253     vtBoolean: s:=s+dbgs(Args[i].vboolean);
2254     vtExtended: s:=s+dbgs(Args[i].VExtended^);
2255 {$ifdef FPC_CURRENCY_IS_INT64}
2256     // MWE:
2257     // ppcppc 2.0.2 has troubles in choosing the right dbgs()
2258     // so we convert here (i don't know about other versions
2259     vtCurrency: s:=s+dbgs(int64(Args[i].vCurrency^)/10000, 4);
2260 {$else}
2261     vtCurrency: s:=s+dbgs(Args[i].vCurrency^);
2262 {$endif}
2263     vtString: s:=s+Args[i].VString^;
2264     vtAnsiString: s:=s+AnsiString(Args[i].VAnsiString);
2265     vtChar: s:=s+Args[i].VChar;
2266     vtPChar: s:=s+Args[i].VPChar;
2267     vtPWideChar: s:=AnsiString(WideString(s)+Args[i].VPWideChar);
2268     vtWideChar: s:=AnsiString(WideString(s)+Args[i].VWideChar);
2269     vtWidestring: s:=AnsiString(WideString(s)+WideString(Args[i].VWideString));
2270 {$IF FPC_FULLVERSION>=20701}
2271     vtUnicodeString: s:=AnsiString(UnicodeString(s)+UnicodeString(Args[i].VUnicodeString));
2272 {$endif}
2273     vtObject: s:=s+DbgSName(Args[i].VObject);
2274     vtClass: s:=s+DbgSName(Args[i].VClass);
2275     vtPointer: s:=s+Dbgs(Args[i].VPointer);
2276     else
2277       DbgOutThreadLog('?unknown variant?');
2278     end;
2279   end;
2280   DebuglnThreadLog(s);
2281 end;
2282 
2283 procedure DebuglnThreadLog;
2284 begin
2285   DebuglnThreadLog('');
2286 end;
2287 
2288 procedure DbgSaveData(FileName: String; AData: PChar; ADataSize: PtrUInt);
2289 var
2290   S: TStream;
2291 begin
2292   S := TFileStreamUTF8.Create(FileName, fmCreate);
2293   S.Write(AData^, ADataSize);
2294   S.Free;
2295 end;
2296 
2297 procedure DbgAppendToFile(FileName, S: String);
2298 var
2299   F: TextFile;
2300 begin
2301   AssignFile(F, FileName);
2302   {$I-}
2303   Append(F);
2304   if IOResult <> 0 then
2305     Rewrite(F);
2306   {$I+}
2307   WriteLn(F, S);
2308   CloseFile(F);
2309 end;
2310 
2311 procedure DbgAppendToFileWithoutLn(FileName, S: String);
2312 var
2313   F: TextFile;
2314 begin
2315   AssignFile(F, FileName);
2316   {$I-}
2317   Append(F);
2318   if IOResult <> 0 then
2319     Rewrite(F);
2320   {$I+}
2321   Write(F, S);
2322   CloseFile(F);
2323 end;
2324 
StripLNnull2325 function StripLN(const ALine: String): String;
2326 var
2327   idx: Integer;
2328 begin
2329   Result := ALine;
2330   idx := Pos(#10, Result);
2331   if idx = 0
2332   then begin
2333     idx := Pos(#13, Result);
2334     if idx = 0 then Exit;
2335   end
2336   else begin
2337     if (idx > 1)
2338     and (Result[idx - 1] = #13)
2339     then Dec(idx);
2340   end;
2341   SetLength(Result, idx - 1);
2342 end;
2343 
GetPartnull2344 function GetPart(const ASkipTo, AnEnd: String; var ASource: String;
2345   const AnIgnoreCase, AnUpdateSource: Boolean): String;
2346 begin
2347   Result := GetPart([ASkipTo], [AnEnd], ASource, AnIgnoreCase, AnUpdateSource);
2348 end;
2349 
GetPartnull2350 function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String;
2351   const AnIgnoreCase: Boolean = False; const AnUpdateSource: Boolean = True): String;
2352 var
2353   n, i, idx: Integer;
2354   S, Source, Match: String;
2355   HasEscape: Boolean;
2356 begin
2357   Source := ASource;
2358 
2359   if High(ASkipTo) >= 0
2360   then begin
2361     idx := 0;
2362     Match := '';
2363     HasEscape := False;
2364     if AnIgnoreCase
2365     then S := UpperCase(Source)
2366     else S := Source;
2367     for n := Low(ASkipTo) to High(ASkipTo) do
2368     begin
2369       if ASkipTo[n] = ''
2370       then begin
2371         HasEscape := True;
2372         Continue;
2373       end;
2374       if AnIgnoreCase
2375       then i := Pos(UpperCase(ASkipTo[n]), S)
2376       else i := Pos(ASkipTo[n], S);
2377       if i > idx
2378       then begin
2379         idx := i;
2380         Match := ASkipTo[n];
2381       end;
2382     end;
2383     if (idx = 0) and not HasEscape
2384     then begin
2385       Result := '';
2386       Exit;
2387     end;
2388     if idx > 0
2389     then Delete(Source, 1, idx + Length(Match) - 1);
2390   end;
2391 
2392   if AnIgnoreCase
2393   then S := UpperCase(Source)
2394   else S := Source;
2395   idx := MaxInt;
2396   for n := Low(AnEnd) to High(AnEnd) do
2397   begin
2398     if AnEnd[n] = '' then Continue;
2399     if AnIgnoreCase
2400     then i := Pos(UpperCase(AnEnd[n]), S)
2401     else i := Pos(AnEnd[n], S);
2402     if (i > 0) and (i < idx) then idx := i;
2403   end;
2404 
2405   if idx = MaxInt
2406   then begin
2407     Result := Source;
2408     Source := '';
2409   end
2410   else begin
2411     Result := Copy(Source, 1, idx - 1);
2412     Delete(Source, 1, idx - 1);
2413   end;
2414 
2415   if AnUpdateSource
2416   then ASource := Source;
2417 end;
2418 
2419 {
2420   Ensures the covenient look of multiline string
2421   when displaying it in the single line
2422   * Replaces CR and LF with spaces
2423   * Removes duplicate spaces
2424 }
TextToSingleLinenull2425 function TextToSingleLine(const AText: string): string;
2426 var
2427   str: string;
2428   i, wstart, wlen: Integer;
2429 begin
2430   str := Trim(AText);
2431   wstart := 0;
2432   wlen := 0;
2433   i := 1;
2434   while i < Length(str) - 1 do
2435   begin
2436     if (str[i] in [' ', #13, #10]) then
2437     begin
2438       if (wstart = 0) then
2439       begin
2440         wstart := i;
2441         wlen := 1;
2442       end else
2443         Inc(wlen);
2444     end else
2445     begin
2446       if wstart > 0 then
2447       begin
2448         str[wstart] := ' ';
2449         Delete(str, wstart+1, wlen-1);
2450         Dec(i, wlen-1);
2451         wstart := 0;
2452       end;
2453     end;
2454     Inc(i);
2455   end;
2456   Result := str;
2457 end;
2458 
SwapCasenull2459 function SwapCase(Const S: String): String;
2460 // Inverts the character case. Like LowerCase and UpperCase combined.
2461 var
2462   i : Integer;
2463   P : PChar;
2464 begin
2465   Result := S;
2466   if not assigned(pointer(result)) then exit;
2467   UniqueString(Result);
2468   P:=Pchar(pointer(Result));
2469   for i := 1 to Length(Result) do begin
2470     if (P^ in ['a'..'z']) then
2471       P^ := char(byte(p^) - 32)
2472     else if (P^ in ['A'..'Z']) then
2473       P^ := char(byte(p^) + 32);
2474     Inc(P);
2475   end;
2476 end;
2477 
StringCasenull2478 function StringCase(const AString: String; const ACase: array of String {; const AIgnoreCase = False, APartial = false: Boolean}): Integer;
2479 begin
2480   Result := StringCase(AString, ACase, False, False);
2481 end;
2482 
StringCasenull2483 function StringCase(const AString: String; const ACase: array of String; const AIgnoreCase, APartial: Boolean): Integer;
2484 var
2485   Search, S: String;
2486 begin
2487   if High(ACase) = -1
2488   then begin
2489     Result := -1;
2490     Exit;
2491   end;
2492 
2493   if AIgnoreCase
2494   then Search := UpperCase(AString)
2495   else Search := AString;
2496 
2497   for Result := Low(ACase) to High(ACase) do
2498   begin
2499     if AIgnoreCase
2500     then S := UpperCase(ACase[Result])
2501     else S := ACase[Result];
2502 
2503     if Search = S then Exit;
2504     if not APartial then Continue;
2505     if Length(Search) >= Length(S) then Continue;
2506     if StrLComp(PChar(Search), PChar(S), Length(Search)) = 0 then Exit;
2507   end;
2508 
2509   Result := -1;
2510 end;
2511 
ClassCasenull2512 function ClassCase(const AClass: TClass; const ACase: array of TClass {; const ADecendant: Boolean = True}): Integer;
2513 begin
2514   Result := ClassCase(AClass, ACase, True);
2515 end;
2516 
ClassCasenull2517 function ClassCase(const AClass: TClass; const ACase: array of TClass; const ADecendant: Boolean): Integer;
2518 begin
2519   for Result := Low(ACase) to High(ACase) do
2520   begin
2521     if AClass = ACase[Result] then Exit;
2522     if not ADecendant then Continue;
2523     if AClass.InheritsFrom(ACase[Result]) then Exit;
2524   end;
2525 
2526   Result := -1;
2527 end;
2528 
UTF16CharacterLengthnull2529 function UTF16CharacterLength(p: PWideChar): integer;
2530 // returns length of UTF16 character in number of words
2531 // The endianess of the machine will be taken.
2532 begin
2533   if p<>nil then begin
2534     if (ord(p[0]) < $D800) or (ord(p[0]) > $DFFF) then
2535       Result:=1
2536     else
2537       Result:=2;
2538   end else begin
2539     Result:=0;
2540   end;
2541 end;
2542 
UTF16Lengthnull2543 function UTF16Length(const s: UTF16String): PtrInt;
2544 begin
2545   Result:=UTF16Length(PWideChar(s),length(s));
2546 end;
2547 
UTF16Lengthnull2548 function UTF16Length(p: PWideChar; WordCount: PtrInt): PtrInt;
2549 var
2550   CharLen: LongInt;
2551 begin
2552   Result:=0;
2553   while (WordCount>0) do begin
2554     inc(Result);
2555     CharLen:=UTF16CharacterLength(p);
2556     inc(p,CharLen);
2557     dec(WordCount,CharLen);
2558   end;
2559 end;
2560 
UTF16CharacterToUnicodenull2561 function UTF16CharacterToUnicode(p: PWideChar; out CharLen: integer): Cardinal;
2562 var
2563   w1: cardinal;
2564   w2: Cardinal;
2565 begin
2566   if p<>nil then begin
2567     w1:=ord(p[0]);
2568     if (w1 < $D800) or (w1 > $DFFF) then begin
2569       // is 1 word character
2570       Result:=w1;
2571       CharLen:=1;
2572     end else begin
2573       // could be 2 word character
2574       w2:=ord(p[1]);
2575       if (w2>=$DC00) then begin
2576         // is 2 word character
2577         Result:=(w1-$D800) shl 10 + (w2-$DC00) + $10000;
2578         CharLen:=2;
2579       end else begin
2580         // invalid character
2581         Result:=w1;
2582         CharLen:=1;
2583       end;
2584     end;
2585   end else begin
2586     Result:=0;
2587     CharLen:=0;
2588   end;
2589 end;
2590 
UnicodeToUTF16null2591 function UnicodeToUTF16(u: cardinal): UTF16String;
2592 begin
2593   // u should be <= $10FFFF to fit into UTF-16
2594 
2595   if u < $10000 then
2596     // Note: codepoints $D800 - $DFFF are reserved
2597     Result:=system.widechar(u)
2598   else
2599     Result:=system.widechar($D800+((u - $10000) shr 10))+system.widechar($DC00+((u - $10000) and $3ff));
2600 end;
2601 
CreateFirstIdentifiernull2602 function CreateFirstIdentifier(const Identifier: string): string;
2603 // example: Ident59 becomes Ident1
2604 var
2605   p: Integer;
2606 begin
2607   p:=length(Identifier);
2608   while (p>=1) and (Identifier[p] in ['0'..'9']) do dec(p);
2609   Result:=copy(Identifier,1,p)+'1';
2610 end;
2611 
CreateNextIdentifiernull2612 function CreateNextIdentifier(const Identifier: string): string;
2613 // example: Ident59 becomes Ident60
2614 var
2615   p: Integer;
2616 begin
2617   p:=length(Identifier);
2618   while (p>=1) and (Identifier[p] in ['0'..'9']) do dec(p);
2619   Result:=copy(Identifier,1,p)
2620           +IntToStr(1+StrToIntDef(copy(Identifier,p+1,length(Identifier)-p),0));
2621 end;
2622 
IsFontNameDefaultnull2623 function IsFontNameDefault(const AName: string): boolean;
2624 begin
2625   Result := CompareText(AName, 'default') = 0;
2626 end;
2627 
2628 { TDebugLCLItems }
2629 
2630 constructor TDebugLCLItems.Create(const TheName: string);
2631 begin
2632   FName:=TheName;
2633   FItems:=TAvlTree.Create(@CompareDebugLCLItemInfos);
2634 end;
2635 
2636 destructor TDebugLCLItems.Destroy;
2637 begin
2638   FItems.FreeAndClear;
2639   FreeAndNil(FItems);
2640   inherited Destroy;
2641 end;
2642 
TDebugLCLItems.FindInfonull2643 function TDebugLCLItems.FindInfo(p: Pointer; CreateIfNotExists: boolean): TDebugLCLItemInfo;
2644 var
2645   ANode: TAvlTreeNode;
2646 begin
2647   ANode:=FItems.FindKey(p,@CompareItemWithDebugLCLItemInfo);
2648   if ANode<>nil then
2649     Result:=TDebugLCLItemInfo(ANode.Data)
2650   else begin
2651     // does not yet exists
2652     if CreateIfNotExists then begin
2653       Result:=MarkCreated(p,'TDebugLCLItems.FindInfo');
2654     end else begin
2655       Result:=nil;
2656     end;
2657   end;
2658 end;
2659 
TDebugLCLItems.IsDestroyednull2660 function TDebugLCLItems.IsDestroyed(p: Pointer): boolean;
2661 var
2662   Info: TDebugLCLItemInfo;
2663 begin
2664   Info:=FindInfo(p);
2665   if Info=nil then
2666     Result:=false
2667   else
2668     Result:=Info.IsDestroyed;
2669 end;
2670 
TDebugLCLItems.IsCreatednull2671 function TDebugLCLItems.IsCreated(p: Pointer): boolean;
2672 var
2673   Info: TDebugLCLItemInfo;
2674 begin
2675   Info:=FindInfo(p);
2676   if Info=nil then
2677     Result:=false
2678   else
2679     Result:=not Info.IsDestroyed;
2680 end;
2681 
2682 procedure TDebugLCLItems.MarkDestroyed(p: Pointer);
2683 var
2684   Info: TDebugLCLItemInfo;
2685 
2686   procedure RaiseNotCreated;
2687   begin
2688     DebugLn('TDebugLCLItems.MarkDestroyed not created: p=',dbgs(p));
2689     DumpStack;
2690     RaiseGDBException('TDebugLCLItems.MarkDestroyed');
2691   end;
2692 
2693   procedure RaiseDoubleDestroyed;
2694   begin
2695     debugLn('TDebugLCLItems.MarkDestroyed Double destroyed:');
2696     debugln(Info.AsString(true));
2697     debugln('Now:');
2698     DebugLn(GetStackTrace(true));
2699     RaiseGDBException('RaiseDoubleDestroyed');
2700   end;
2701 
2702 begin
2703   Info:=FindInfo(p);
2704   if Info=nil then
2705     RaiseNotCreated;
2706   if Info.IsDestroyed then
2707     RaiseDoubleDestroyed;
2708   Info.IsDestroyed:=true;
2709   GetStackTracePointers(Info.DestructionStack);
2710   //DebugLn(['TDebugLCLItems.MarkDestroyed ',dbgs(p)]);
2711 end;
2712 
TDebugLCLItems.GetInfonull2713 function TDebugLCLItems.GetInfo(p: Pointer; WithStackTraces: boolean): string;
2714 var
2715   Info: TDebugLCLItemInfo;
2716 begin
2717   Info:=FindInfo(p,false);
2718   if Info<>nil then
2719     Result:=Info.AsString(WithStackTraces)
2720   else
2721     Result:='';
2722 end;
2723 
MarkCreatednull2724 function TDebugLCLItems.MarkCreated(p: Pointer;
2725   const InfoText: string): TDebugLCLItemInfo;
2726 var
2727   Info: TDebugLCLItemInfo;
2728 
2729   procedure RaiseDoubleCreated;
2730   begin
2731     debugLn('TDebugLCLItems.MarkCreated CREATED TWICE. Old:');
2732     debugln(Info.AsString(true));
2733     debugln(' New=',dbgs(p),' InfoText="',InfoText,'"');
2734     DebugLn(GetStackTrace(true));
2735     RaiseGDBException('RaiseDoubleCreated');
2736   end;
2737 
2738 begin
2739   Info:=FindInfo(p);
2740   if Info=nil then begin
2741     Info:=TDebugLCLItemInfo.Create;
2742     Info.Item:=p;
2743     FItems.Add(Info);
2744   end else if not Info.IsDestroyed then begin
2745     RaiseDoubleCreated;
2746   end;
2747   Info.IsDestroyed:=false;
2748   Info.Info:=InfoText;
2749   GetStackTracePointers(Info.CreationStack);
2750   SetLength(Info.DestructionStack,0);
2751   //DebugLn(['TDebugLCLItems.MarkCreated ',Name,' ',dbgs(p),' ',FItems.Count]);
2752   //DebugLn(GetStackTrace(true));
2753   Result:=Info;
2754 end;
2755 
2756 { TDebugLCLItemInfo }
2757 
AsStringnull2758 function TDebugLCLItemInfo.AsString(WithStackTraces: boolean): string;
2759 begin
2760   Result:='Item='+Dbgs(Item)+LineEnding
2761           +'Info="'+DbgStr(Info)+LineEnding;
2762   if WithStackTraces then
2763     Result:=Result+'Creation:'+LineEnding+StackTraceAsString(CreationStack,true);
2764   if IsDestroyed then begin
2765     Result:=Result+'Destroyed:'+LineEnding;
2766     if WithStackTraces then
2767       Result:=Result+StackTraceAsString(DestructionStack,true);
2768   end;
2769 end;
2770 
2771 destructor TDebugLCLItemInfo.Destroy;
2772 begin
2773   SetLength(CreationStack,0);
2774   SetLength(DestructionStack,0);
2775   inherited Destroy;
2776 end;
2777 
2778 initialization
2779   {$IFDEF WithOldDebugln} InitializeDebugOutput; {$ENDIF}
2780   {$ifdef WinCE}
crashesnull2781   // The stabs based back trace function crashes on wince,
2782   // see http://bugs.freepascal.org/view.php?id=14330
2783   // To prevent crashes, replace it with the default system back trace function
2784   // that just outputs addresses and not source and line number
2785   BackTraceStrFunc := @SysBackTraceStr;
2786   {$endif}
2787   {$ifdef AROS}
2788     {$if FPC_FULLVERSION>=30101}
2789     EnableBackTraceStr;
2790     {$endif}
2791   {$endif}
2792   InterfaceInitializationHandlers := TFPList.Create;
2793   InterfaceFinalizationHandlers := TFPList.Create;
2794   {$IFDEF DebugLCLComponents}
2795   DebugLCLComponents:=TDebugLCLItems.Create('LCLComponents');
2796   {$ENDIF}
2797 finalization
2798   InterfaceInitializationHandlers.Free;
2799   InterfaceInitializationHandlers:=nil;
2800   InterfaceFinalizationHandlers.Free;
2801   InterfaceFinalizationHandlers:=nil;
2802   {$IFDEF DebugLCLComponents}
2803   DebugLCLComponents.Free;
2804   DebugLCLComponents:=nil;
2805   {$ENDIF}
2806   {$IFDEF WithOldDebugln}
2807   FinalizeDebugOutput;
2808   DebugLnNestFreePrefix;
2809   {$ENDIF}
2810 
2811 end.
2812