{ /*************************************************************************** lclproc.pas ----------- Component Library Code ***************************************************************************/ ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.modifiedLGPL.txt, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** Useful lower level helper functions and classes. } unit LCLProc; {$mode objfpc}{$H+} {$inline on} interface uses Classes, SysUtils, Math, TypInfo, Types, FPCAdds, AvgLvlTree, FileUtil, LCLStrConsts, LCLType, WSReferences {$IFNDEF DisableCWString}{$ifdef unix}{$ifndef DisableIconv}, cwstring{$endif}{$endif}{$ENDIF} ; type { TMethodList - array of TMethod } TMethodList = class private FItems: ^TMethod; FCount: integer; function GetItems(Index: integer): TMethod; procedure SetItems(Index: integer; const AValue: TMethod); public destructor Destroy; override; function Count: integer; function NextDownIndex(var Index: integer): boolean; function IndexOf(const AMethod: TMethod): integer; procedure Delete(Index: integer); procedure Remove(const AMethod: TMethod); procedure Add(const AMethod: TMethod); procedure Add(const AMethod: TMethod; AsLast: boolean); procedure Insert(Index: integer; const AMethod: TMethod); procedure Move(OldIndex, NewIndex: integer); procedure RemoveAllMethodsOfObject(const AnObject: TObject); procedure CallNotifyEvents(Sender: TObject); public property Items[Index: integer]: TMethod read GetItems write SetItems; default; end; type TStackTracePointers = array of Pointer; { TDebugLCLItemInfo } TDebugLCLItemInfo = class public Item: Pointer; IsDestroyed: boolean; Info: string; CreationStack: TStackTracePointers; // stack trace at creationg DestructionStack: TStackTracePointers;// stack trace at destruction function AsString(WithStackTraces: boolean): string; destructor Destroy; override; end; { TDebugLCLItems } TDebugLCLItems = class private FItems: TAvgLvlTree;// tree of TDebugLCLItemInfo FName: string; public constructor Create(const TheName: string); destructor Destroy; override; function FindInfo(p: Pointer; CreateIfNotExists: boolean = false ): TDebugLCLItemInfo; function IsDestroyed(p: Pointer): boolean; function IsCreated(p: Pointer): boolean; function MarkCreated(p: Pointer; const InfoText: string): TDebugLCLItemInfo; procedure MarkDestroyed(p: Pointer); function GetInfo(p: Pointer; WithStackTraces: boolean): string; property Name: string read FName; end; TLineInfoCacheItem = record Addr: Pointer; Info: string; end; PLineInfoCacheItem = ^TLineInfoCacheItem; {$IFDEF DebugLCLComponents} var DebugLCLComponents: TDebugLCLItems = nil; {$ENDIF} function CompareDebugLCLItemInfos(Data1, Data2: Pointer): integer; function CompareItemWithDebugLCLItemInfo(Item, DebugItemInfo: Pointer): integer; function CompareLineInfoCacheItems(Data1, Data2: Pointer): integer; function CompareAddrWithLineInfoCacheItem(Addr, Item: Pointer): integer; type TStringsSortCompare = function(const Item1, Item2: string): Integer; procedure MergeSort(List: TFPList; const OnCompare: TListSortCompare); procedure MergeSort(List: TStrings; const OnCompare: TStringsSortCompare); function GetEnumValueDef(TypeInfo: PTypeInfo; const Name: string; const DefaultValue: Integer): Integer; function ShortCutToText(ShortCut: TShortCut): string;// untranslated function TextToShortCut(const ShortCutText: string): TShortCut;// untranslated function GetCompleteText(sText: string; iSelStart: Integer; bCaseSensitive, bSearchAscending: Boolean; slTextList: TStrings): string; function IsEditableTextKey(Key: Word): Boolean; // Hooks used to prevent unit circles type TSendApplicationMessageFunction = function(Msg: Cardinal; WParam: WParam; LParam: LParam):Longint; TOwnerFormDesignerModifiedProc = procedure(AComponent: TComponent); var SendApplicationMessageFunction: TSendApplicationMessageFunction=nil; OwnerFormDesignerModifiedProc: TOwnerFormDesignerModifiedProc=nil; function SendApplicationMessage(Msg: Cardinal; WParam: WParam; LParam: LParam):Longint; procedure OwnerFormDesignerModified(AComponent: TComponent); procedure FreeThenNil(var AnObject: TObject); { the LCL interfaces finalization sections are called before the finalization sections of the LCL. Those parts, that should be finalized after the LCL, can be registered here. } procedure RegisterInterfaceInitializationHandler(p: TProcedure); procedure CallInterfaceInitializationHandlers; procedure RegisterInterfaceFinalizationHandler(p: TProcedure); procedure CallInterfaceFinalizationHandlers; function OffsetRect(var ARect: TRect; dx, dy: Integer): Boolean; procedure MoveRect(var ARect: TRect; x, y: Integer); procedure MoveRectToFit(var ARect: TRect; const MaxRect: TRect); procedure MakeMinMax(var i1, i2: integer); procedure CalculateLeftTopWidthHeight(X1,Y1,X2,Y2: integer; var Left,Top,Width,Height: integer); function DeleteAmpersands(var Str : String) : Longint; function BreakString(const s: string; MaxLineLength, Indent: integer): string; function ComparePointers(p1, p2: Pointer): integer; function CompareHandles(h1, h2: THandle): integer; function CompareLCLHandles(h1, h2: TLCLHandle): integer; function CompareRect(R1, R2: PRect): Boolean; function ComparePoints(const p1, p2: TPoint): integer; function RoundToInt(const e: Extended): integer; function RoundToCardinal(const e: Extended): cardinal; function TruncToInt(const e: Extended): integer; function TruncToCardinal(const e: Extended): cardinal; function StrToDouble(const s: string): double; // debugging procedure RaiseGDBException(const Msg: string); procedure DumpExceptionBackTrace; procedure DumpStack; function GetStackTrace(UseCache: boolean): string; procedure GetStackTracePointers(var AStack: TStackTracePointers); function StackTraceAsString(const AStack: TStackTracePointers; UseCache: boolean): string; function GetLineInfo(Addr: Pointer; UseCache: boolean): string; procedure DebugLn(Args: array of const); procedure DebugLn(const S: String; Args: array of const);// similar to Format(s,Args) procedure DebugLn; procedure DebugLn(const s: string); procedure DebugLn(const s1,s2: string); procedure DebugLn(const s1,s2,s3: string); procedure DebugLn(const s1,s2,s3,s4: string); procedure DebugLn(const s1,s2,s3,s4,s5: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15: string); procedure DebugLn(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15,s16: string); function ConvertLineEndings(const s: string): string; procedure DbgOut(const S: String; Args: array of const); procedure DbgOut(const s: string); procedure DbgOut(const s1,s2: string); procedure DbgOut(const s1,s2,s3: string); procedure DbgOut(const s1,s2,s3,s4: string); procedure DbgOut(const s1,s2,s3,s4,s5: string); procedure DbgOut(const s1,s2,s3,s4,s5,s6: string); procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7: string); procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8: string); procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9: string); procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10: string); procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11: string); procedure DbgOut(const s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12: string); function DbgS(const c: cardinal): string; overload; function DbgS(const i: longint): string; overload; function DbgS(const i: int64): string; overload; function DbgS(const q: qword): string; overload; function DbgS(const r: TRect): string; overload; function DbgS(const p: TPoint): string; overload; function DbgS(const p: pointer): string; overload; function DbgS(const e: extended; MaxDecimals: integer = 999): string; overload; function DbgS(const b: boolean): string; overload; function DbgS(const s: TComponentState): string; overload; function DbgSName(const p: TObject): string; overload; function DbgSName(const p: TClass): string; overload; function DbgStr(const StringWithSpecialChars: string): string; overload; function DbgWideStr(const StringWithSpecialChars: widestring): string; overload; function dbgMemRange(P: PByte; Count: integer; Width: integer = 0): string; overload; function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string; overload; function dbgObjMem(AnObject: TObject): string; overload; function dbghex(i: Int64): string; overload; function DbgS(const i1,i2,i3,i4: integer): string; overload; function DbgS(const Shift: TShiftState): string; overload; function DbgsVKCode(c: word): string; function DbgS(const ASize: TSize): string; overload; function DbgS(const ATM: TTextMetric): string; overload; function DbgS(const AScrollInfo: TScrollInfo): string; overload; procedure DbgOutThreadLog(const Msg: string); overload; procedure DebuglnThreadLog(const Msg: string); overload; procedure DebuglnThreadLog(Args: array of const); overload; procedure DebuglnThreadLog; overload; procedure DbgSaveData(FileName: String; AData: PChar; ADataSize: PtrUInt); procedure DbgAppendToFile(FileName, S: String); procedure CloseDebugOutput; // some string manipulation functions function StripLN(const ALine: String): String; function GetPart(const ASkipTo, AnEnd: String; var ASource: String): String; overload; function GetPart(const ASkipTo, AnEnd: String; var ASource: String; const AnIgnoreCase: Boolean): String; overload; function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String): String; overload; function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String; const AnIgnoreCase: Boolean): String; overload; function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String; const AnIgnoreCase, AnUpdateSource: Boolean): String; overload; function TextToSingleLine(const AText: string): string; // case..of utility functions function StringCase(const AString: String; const ACase: array of String {; const AIgnoreCase = False, APartial = false: Boolean}): Integer; overload; function StringCase(const AString: String; const ACase: array of String; const AIgnoreCase, APartial: Boolean): Integer; overload; function ClassCase(const AClass: TClass; const ACase: array of TClass {; const ADescendant: Boolean = True}): Integer; overload; function ClassCase(const AClass: TClass; const ACase: array of TClass; const ADecendant: Boolean): Integer; overload; // UTF utility functions // MG: Should be moved to the RTL // MWE: define (missing) UTF16string similar to UTF8 // strictly spoken, a widestring <> utf16string // todo: use it in existing functions type UTF16String = type WideString; PUTF16String = ^UTF16String; function UTF8CharacterLength(p: PChar): integer; function UTF8Length(const s: string): integer; function UTF8Length(p: PChar; ByteCount: integer): integer; function UTF8CharacterToUnicode(p: PChar; out CharLen: integer): Cardinal; function UnicodeToUTF8(u: cardinal; Buf: PChar): integer; function UnicodeToUTF8(u: cardinal): shortstring; inline; function UTF8ToDoubleByteString(const s: string): string; function UTF8ToDoubleByte(UTF8Str: PChar; Len: integer; DBStr: PByte): integer; function UTF8FindNearestCharStart(UTF8Str: PChar; Len: integer; BytePos: integer): integer; // find the n-th UTF8 character, ignoring BIDI function UTF8CharStart(UTF8Str: PChar; Len, CharIndex: integer): PChar; // find the byte index of the n-th UTF8 character, ignoring BIDI (byte len of substr) function UTF8CharToByteIndex(UTF8Str: PChar; Len, CharIndex: integer): Integer; procedure UTF8FixBroken(P: PChar); function UTF8CharacterStrictLength(P: PChar): integer; function UTF8CStringToUTF8String(SourceStart: PChar; SourceLen: SizeInt) : string; function UTF8Pos(const SearchForText, SearchInText: string): integer; function UTF8Copy(const s: string; StartCharIndex, CharCount: integer): string; procedure UTF8Delete(var s: String; StartCharIndex, CharCount: integer); procedure UTF8Insert(const source: String; var s: string; StartCharIndex: integer); function UTF8LowerCase(const s: String): String; function UTF8UpperCase(const s: String): String; {$ifdef NewLowerCase} function UTF8LowerCaseNew(const s: String): String; {$endif} function FindInvalidUTF8Character(p: PChar; Count: integer; StopOnNonASCII: Boolean = false): integer; function ValidUTF8String(const s: String): String; procedure AssignUTF8ListToAnsi(UTF8List, AnsiList: TStrings); function UTF16CharacterLength(p: PWideChar): integer; function UTF16Length(const s: widestring): integer; function UTF16Length(p: PWideChar; WordCount: integer): integer; function UTF16CharacterToUnicode(p: PWideChar; out CharLen: integer): Cardinal; function UnicodeToUTF16(u: cardinal): widestring; type TConvertResult = (trNoError, trNullSrc, trNullDest, trDestExhausted, trInvalidChar, trUnfinishedChar); TConvertOption = (toInvalidCharError, toInvalidCharToSymbol, toUnfinishedCharError, toUnfinishedCharToSymbol); TConvertOptions = set of TConvertOption; function ConvertUTF8ToUTF16(Dest: PWideChar; DestWideCharCount: SizeUInt; Src: PChar; SrcCharCount: SizeUInt; Options: TConvertOptions; out ActualWideCharCount: SizeUInt): TConvertResult; function ConvertUTF16ToUTF8(Dest: PChar; DestCharCount: SizeUInt; Src: PWideChar; SrcWideCharCount: SizeUInt; Options: TConvertOptions; out ActualCharCount: SizeUInt): TConvertResult; function UTF8ToUTF16(const S: UTF8String): UTF16String; function UTF16ToUTF8(const S: UTF16String): UTF8String; // identifier function CreateFirstIdentifier(const Identifier: string): string; function CreateNextIdentifier(const Identifier: string): string; implementation var InterfaceInitializationHandlers: TFPList = nil; InterfaceFinalizationHandlers: TFPList = nil; DebugTextAllocated: boolean; DebugText: ^Text; LineInfoCache: TAvgLvlTree = nil; {$ifdef NewLowerCase} var UnicodeLower00C0_00DE: array[$00C0..$00DE] of word; UnicodeLower0100_024E: array[$0100..$024E] of word; UnicodeLower0386_03AB: array[$0386..$03AB] of word; UnicodeLower03D8_042F: array[$03D8..$042F] of word; UnicodeLower0460_0512: array[$0460..$0512] of word; UnicodeLower1E00_1FFC: array[$1E00..$1FFC] of word; UnicodeLower2126_2183: array[$2126..$2183] of word; UnicodeLower2C60_2CE2: array[$2C60..$2CE2] of word; procedure InitUnicodeTables; var i: Integer; begin for i:=Low(UnicodeLower00C0_00DE) to High(UnicodeLower00C0_00DE) do UnicodeLower00C0_00DE[i]:=i+32; UnicodeLower00C0_00DE[$00D7]:=$00D7; for i:=Low(UnicodeLower0100_024E) to High(UnicodeLower0100_024E) do UnicodeLower0100_024E[i]:=i; UnicodeLower0100_024E[$0100]:=$0101; UnicodeLower0100_024E[$0102]:=$0103; UnicodeLower0100_024E[$0104]:=$0105; UnicodeLower0100_024E[$0106]:=$0107; UnicodeLower0100_024E[$0108]:=$0109; UnicodeLower0100_024E[$010A]:=$010B; UnicodeLower0100_024E[$010C]:=$010D; UnicodeLower0100_024E[$010E]:=$010F; UnicodeLower0100_024E[$0110]:=$0111; UnicodeLower0100_024E[$0112]:=$0113; UnicodeLower0100_024E[$0114]:=$0115; UnicodeLower0100_024E[$0116]:=$0117; UnicodeLower0100_024E[$0118]:=$0119; UnicodeLower0100_024E[$011A]:=$011B; UnicodeLower0100_024E[$011C]:=$011D; UnicodeLower0100_024E[$011E]:=$011F; UnicodeLower0100_024E[$0120]:=$0121; UnicodeLower0100_024E[$0122]:=$0123; UnicodeLower0100_024E[$0124]:=$0125; UnicodeLower0100_024E[$0126]:=$0127; UnicodeLower0100_024E[$0128]:=$0129; UnicodeLower0100_024E[$012A]:=$012B; UnicodeLower0100_024E[$012C]:=$012D; UnicodeLower0100_024E[$012E]:=$012F; UnicodeLower0100_024E[$0130]:=$0069; UnicodeLower0100_024E[$0132]:=$0133; UnicodeLower0100_024E[$0134]:=$0135; UnicodeLower0100_024E[$0136]:=$0137; UnicodeLower0100_024E[$0139]:=$013A; UnicodeLower0100_024E[$013B]:=$013C; UnicodeLower0100_024E[$013D]:=$013E; UnicodeLower0100_024E[$013F]:=$0140; UnicodeLower0100_024E[$0141]:=$0142; UnicodeLower0100_024E[$0143]:=$0144; UnicodeLower0100_024E[$0145]:=$0146; UnicodeLower0100_024E[$0147]:=$0148; UnicodeLower0100_024E[$014A]:=$014B; UnicodeLower0100_024E[$014C]:=$014D; UnicodeLower0100_024E[$014E]:=$014F; UnicodeLower0100_024E[$0150]:=$0151; UnicodeLower0100_024E[$0152]:=$0153; UnicodeLower0100_024E[$0154]:=$0155; UnicodeLower0100_024E[$0156]:=$0157; UnicodeLower0100_024E[$0158]:=$0159; UnicodeLower0100_024E[$015A]:=$015B; UnicodeLower0100_024E[$015C]:=$015D; UnicodeLower0100_024E[$015E]:=$015F; UnicodeLower0100_024E[$0160]:=$0161; UnicodeLower0100_024E[$0162]:=$0163; UnicodeLower0100_024E[$0164]:=$0165; UnicodeLower0100_024E[$0166]:=$0167; UnicodeLower0100_024E[$0168]:=$0169; UnicodeLower0100_024E[$016A]:=$016B; UnicodeLower0100_024E[$016C]:=$016D; UnicodeLower0100_024E[$016E]:=$016F; UnicodeLower0100_024E[$0170]:=$0171; UnicodeLower0100_024E[$0172]:=$0173; UnicodeLower0100_024E[$0174]:=$0175; UnicodeLower0100_024E[$0176]:=$0177; UnicodeLower0100_024E[$0178]:=$00FF; UnicodeLower0100_024E[$0179]:=$017A; UnicodeLower0100_024E[$017B]:=$017C; UnicodeLower0100_024E[$017D]:=$017E; UnicodeLower0100_024E[$0181]:=$0253; UnicodeLower0100_024E[$0182]:=$0183; UnicodeLower0100_024E[$0184]:=$0185; UnicodeLower0100_024E[$0186]:=$0254; UnicodeLower0100_024E[$0187]:=$0188; UnicodeLower0100_024E[$0189]:=$0256; UnicodeLower0100_024E[$018A]:=$0257; UnicodeLower0100_024E[$018B]:=$018C; UnicodeLower0100_024E[$018E]:=$01DD; UnicodeLower0100_024E[$018F]:=$0259; UnicodeLower0100_024E[$0190]:=$025B; UnicodeLower0100_024E[$0191]:=$0192; UnicodeLower0100_024E[$0193]:=$0260; UnicodeLower0100_024E[$0194]:=$0263; UnicodeLower0100_024E[$0196]:=$0269; UnicodeLower0100_024E[$0197]:=$0268; UnicodeLower0100_024E[$0198]:=$0199; UnicodeLower0100_024E[$019C]:=$026F; UnicodeLower0100_024E[$019D]:=$0272; UnicodeLower0100_024E[$019F]:=$0275; UnicodeLower0100_024E[$01A0]:=$01A1; UnicodeLower0100_024E[$01A2]:=$01A3; UnicodeLower0100_024E[$01A4]:=$01A5; UnicodeLower0100_024E[$01A6]:=$0280; UnicodeLower0100_024E[$01A7]:=$01A8; UnicodeLower0100_024E[$01A9]:=$0283; UnicodeLower0100_024E[$01AC]:=$01AD; UnicodeLower0100_024E[$01AE]:=$0288; UnicodeLower0100_024E[$01AF]:=$01B0; UnicodeLower0100_024E[$01B1]:=$028A; UnicodeLower0100_024E[$01B2]:=$028B; UnicodeLower0100_024E[$01B3]:=$01B4; UnicodeLower0100_024E[$01B5]:=$01B6; UnicodeLower0100_024E[$01B7]:=$0292; UnicodeLower0100_024E[$01B8]:=$01B9; UnicodeLower0100_024E[$01BC]:=$01BD; UnicodeLower0100_024E[$01C4]:=$01C6; UnicodeLower0100_024E[$01C5]:=$01C6; UnicodeLower0100_024E[$01C7]:=$01C9; UnicodeLower0100_024E[$01C8]:=$01C9; UnicodeLower0100_024E[$01CA]:=$01CC; UnicodeLower0100_024E[$01CB]:=$01CC; UnicodeLower0100_024E[$01CD]:=$01CE; UnicodeLower0100_024E[$01CF]:=$01D0; UnicodeLower0100_024E[$01D1]:=$01D2; UnicodeLower0100_024E[$01D3]:=$01D4; UnicodeLower0100_024E[$01D5]:=$01D6; UnicodeLower0100_024E[$01D7]:=$01D8; UnicodeLower0100_024E[$01D9]:=$01DA; UnicodeLower0100_024E[$01DB]:=$01DC; UnicodeLower0100_024E[$01DE]:=$01DF; UnicodeLower0100_024E[$01E0]:=$01E1; UnicodeLower0100_024E[$01E2]:=$01E3; UnicodeLower0100_024E[$01E4]:=$01E5; UnicodeLower0100_024E[$01E6]:=$01E7; UnicodeLower0100_024E[$01E8]:=$01E9; UnicodeLower0100_024E[$01EA]:=$01EB; UnicodeLower0100_024E[$01EC]:=$01ED; UnicodeLower0100_024E[$01EE]:=$01EF; UnicodeLower0100_024E[$01F1]:=$01F3; UnicodeLower0100_024E[$01F2]:=$01F3; UnicodeLower0100_024E[$01F4]:=$01F5; UnicodeLower0100_024E[$01F6]:=$0195; UnicodeLower0100_024E[$01F7]:=$01BF; UnicodeLower0100_024E[$01F8]:=$01F9; UnicodeLower0100_024E[$01FA]:=$01FB; UnicodeLower0100_024E[$01FC]:=$01FD; UnicodeLower0100_024E[$01FE]:=$01FF; UnicodeLower0100_024E[$0200]:=$0201; UnicodeLower0100_024E[$0202]:=$0203; UnicodeLower0100_024E[$0204]:=$0205; UnicodeLower0100_024E[$0206]:=$0207; UnicodeLower0100_024E[$0208]:=$0209; UnicodeLower0100_024E[$020A]:=$020B; UnicodeLower0100_024E[$020C]:=$020D; UnicodeLower0100_024E[$020E]:=$020F; UnicodeLower0100_024E[$0210]:=$0211; UnicodeLower0100_024E[$0212]:=$0213; UnicodeLower0100_024E[$0214]:=$0215; UnicodeLower0100_024E[$0216]:=$0217; UnicodeLower0100_024E[$0218]:=$0219; UnicodeLower0100_024E[$021A]:=$021B; UnicodeLower0100_024E[$021C]:=$021D; UnicodeLower0100_024E[$021E]:=$021F; UnicodeLower0100_024E[$0220]:=$019E; UnicodeLower0100_024E[$0222]:=$0223; UnicodeLower0100_024E[$0224]:=$0225; UnicodeLower0100_024E[$0226]:=$0227; UnicodeLower0100_024E[$0228]:=$0229; UnicodeLower0100_024E[$022A]:=$022B; UnicodeLower0100_024E[$022C]:=$022D; UnicodeLower0100_024E[$022E]:=$022F; UnicodeLower0100_024E[$0230]:=$0231; UnicodeLower0100_024E[$0232]:=$0233; UnicodeLower0100_024E[$023A]:=$2C65; UnicodeLower0100_024E[$023B]:=$023C; UnicodeLower0100_024E[$023D]:=$019A; UnicodeLower0100_024E[$023E]:=$2C66; UnicodeLower0100_024E[$0241]:=$0242; UnicodeLower0100_024E[$0243]:=$0180; UnicodeLower0100_024E[$0244]:=$0289; UnicodeLower0100_024E[$0245]:=$028C; UnicodeLower0100_024E[$0246]:=$0247; UnicodeLower0100_024E[$0248]:=$0249; UnicodeLower0100_024E[$024A]:=$024B; UnicodeLower0100_024E[$024C]:=$024D; UnicodeLower0100_024E[$024E]:=$024F; for i:=Low(UnicodeLower0386_03AB) to High(UnicodeLower0386_03AB) do UnicodeLower0386_03AB[i]:=i; UnicodeLower0386_03AB[$0386]:=$03AC; UnicodeLower0386_03AB[$0388]:=$03AD; UnicodeLower0386_03AB[$0389]:=$03AE; UnicodeLower0386_03AB[$038A]:=$03AF; UnicodeLower0386_03AB[$038C]:=$03CC; UnicodeLower0386_03AB[$038E]:=$03CD; UnicodeLower0386_03AB[$038F]:=$03CE; UnicodeLower0386_03AB[$0391]:=$03B1; UnicodeLower0386_03AB[$0392]:=$03B2; UnicodeLower0386_03AB[$0393]:=$03B3; UnicodeLower0386_03AB[$0394]:=$03B4; UnicodeLower0386_03AB[$0395]:=$03B5; UnicodeLower0386_03AB[$0396]:=$03B6; UnicodeLower0386_03AB[$0397]:=$03B7; UnicodeLower0386_03AB[$0398]:=$03B8; UnicodeLower0386_03AB[$0399]:=$03B9; UnicodeLower0386_03AB[$039A]:=$03BA; UnicodeLower0386_03AB[$039B]:=$03BB; UnicodeLower0386_03AB[$039C]:=$03BC; UnicodeLower0386_03AB[$039D]:=$03BD; UnicodeLower0386_03AB[$039E]:=$03BE; UnicodeLower0386_03AB[$039F]:=$03BF; UnicodeLower0386_03AB[$03A0]:=$03C0; UnicodeLower0386_03AB[$03A1]:=$03C1; UnicodeLower0386_03AB[$03A3]:=$03C3; UnicodeLower0386_03AB[$03A4]:=$03C4; UnicodeLower0386_03AB[$03A5]:=$03C5; UnicodeLower0386_03AB[$03A6]:=$03C6; UnicodeLower0386_03AB[$03A7]:=$03C7; UnicodeLower0386_03AB[$03A8]:=$03C8; UnicodeLower0386_03AB[$03A9]:=$03C9; UnicodeLower0386_03AB[$03AA]:=$03CA; UnicodeLower0386_03AB[$03AB]:=$03CB; for i:=Low(UnicodeLower03D8_042F) to High(UnicodeLower03D8_042F) do UnicodeLower03D8_042F[i]:=i; UnicodeLower03D8_042F[$03D8]:=$03D9; UnicodeLower03D8_042F[$03DA]:=$03DB; UnicodeLower03D8_042F[$03DC]:=$03DD; UnicodeLower03D8_042F[$03DE]:=$03DF; UnicodeLower03D8_042F[$03E0]:=$03E1; UnicodeLower03D8_042F[$03E2]:=$03E3; UnicodeLower03D8_042F[$03E4]:=$03E5; UnicodeLower03D8_042F[$03E6]:=$03E7; UnicodeLower03D8_042F[$03E8]:=$03E9; UnicodeLower03D8_042F[$03EA]:=$03EB; UnicodeLower03D8_042F[$03EC]:=$03ED; UnicodeLower03D8_042F[$03EE]:=$03EF; UnicodeLower03D8_042F[$03F4]:=$03B8; UnicodeLower03D8_042F[$03F7]:=$03F8; UnicodeLower03D8_042F[$03F9]:=$03F2; UnicodeLower03D8_042F[$03FA]:=$03FB; UnicodeLower03D8_042F[$03FD]:=$037B; UnicodeLower03D8_042F[$03FE]:=$037C; UnicodeLower03D8_042F[$03FF]:=$037D; UnicodeLower03D8_042F[$0400]:=$0450; UnicodeLower03D8_042F[$0401]:=$0451; UnicodeLower03D8_042F[$0402]:=$0452; UnicodeLower03D8_042F[$0403]:=$0453; UnicodeLower03D8_042F[$0404]:=$0454; UnicodeLower03D8_042F[$0405]:=$0455; UnicodeLower03D8_042F[$0406]:=$0456; UnicodeLower03D8_042F[$0407]:=$0457; UnicodeLower03D8_042F[$0408]:=$0458; UnicodeLower03D8_042F[$0409]:=$0459; UnicodeLower03D8_042F[$040A]:=$045A; UnicodeLower03D8_042F[$040B]:=$045B; UnicodeLower03D8_042F[$040C]:=$045C; UnicodeLower03D8_042F[$040D]:=$045D; UnicodeLower03D8_042F[$040E]:=$045E; UnicodeLower03D8_042F[$040F]:=$045F; UnicodeLower03D8_042F[$0410]:=$0430; UnicodeLower03D8_042F[$0411]:=$0431; UnicodeLower03D8_042F[$0412]:=$0432; UnicodeLower03D8_042F[$0413]:=$0433; UnicodeLower03D8_042F[$0414]:=$0434; UnicodeLower03D8_042F[$0415]:=$0435; UnicodeLower03D8_042F[$0416]:=$0436; UnicodeLower03D8_042F[$0417]:=$0437; UnicodeLower03D8_042F[$0418]:=$0438; UnicodeLower03D8_042F[$0419]:=$0439; UnicodeLower03D8_042F[$041A]:=$043A; UnicodeLower03D8_042F[$041B]:=$043B; UnicodeLower03D8_042F[$041C]:=$043C; UnicodeLower03D8_042F[$041D]:=$043D; UnicodeLower03D8_042F[$041E]:=$043E; UnicodeLower03D8_042F[$041F]:=$043F; UnicodeLower03D8_042F[$0420]:=$0440; UnicodeLower03D8_042F[$0421]:=$0441; UnicodeLower03D8_042F[$0422]:=$0442; UnicodeLower03D8_042F[$0423]:=$0443; UnicodeLower03D8_042F[$0424]:=$0444; UnicodeLower03D8_042F[$0425]:=$0445; UnicodeLower03D8_042F[$0426]:=$0446; UnicodeLower03D8_042F[$0427]:=$0447; UnicodeLower03D8_042F[$0428]:=$0448; UnicodeLower03D8_042F[$0429]:=$0449; UnicodeLower03D8_042F[$042A]:=$044A; UnicodeLower03D8_042F[$042B]:=$044B; UnicodeLower03D8_042F[$042C]:=$044C; UnicodeLower03D8_042F[$042D]:=$044D; UnicodeLower03D8_042F[$042E]:=$044E; UnicodeLower03D8_042F[$042F]:=$044F; for i:=Low(UnicodeLower0460_0512) to High(UnicodeLower0460_0512) do UnicodeLower0460_0512[i]:=i; UnicodeLower0460_0512[$0460]:=$0461; UnicodeLower0460_0512[$0462]:=$0463; UnicodeLower0460_0512[$0464]:=$0465; UnicodeLower0460_0512[$0466]:=$0467; UnicodeLower0460_0512[$0468]:=$0469; UnicodeLower0460_0512[$046A]:=$046B; UnicodeLower0460_0512[$046C]:=$046D; UnicodeLower0460_0512[$046E]:=$046F; UnicodeLower0460_0512[$0470]:=$0471; UnicodeLower0460_0512[$0472]:=$0473; UnicodeLower0460_0512[$0474]:=$0475; UnicodeLower0460_0512[$0476]:=$0477; UnicodeLower0460_0512[$0478]:=$0479; UnicodeLower0460_0512[$047A]:=$047B; UnicodeLower0460_0512[$047C]:=$047D; UnicodeLower0460_0512[$047E]:=$047F; UnicodeLower0460_0512[$0480]:=$0481; UnicodeLower0460_0512[$048A]:=$048B; UnicodeLower0460_0512[$048C]:=$048D; UnicodeLower0460_0512[$048E]:=$048F; UnicodeLower0460_0512[$0490]:=$0491; UnicodeLower0460_0512[$0492]:=$0493; UnicodeLower0460_0512[$0494]:=$0495; UnicodeLower0460_0512[$0496]:=$0497; UnicodeLower0460_0512[$0498]:=$0499; UnicodeLower0460_0512[$049A]:=$049B; UnicodeLower0460_0512[$049C]:=$049D; UnicodeLower0460_0512[$049E]:=$049F; UnicodeLower0460_0512[$04A0]:=$04A1; UnicodeLower0460_0512[$04A2]:=$04A3; UnicodeLower0460_0512[$04A4]:=$04A5; UnicodeLower0460_0512[$04A6]:=$04A7; UnicodeLower0460_0512[$04A8]:=$04A9; UnicodeLower0460_0512[$04AA]:=$04AB; UnicodeLower0460_0512[$04AC]:=$04AD; UnicodeLower0460_0512[$04AE]:=$04AF; UnicodeLower0460_0512[$04B0]:=$04B1; UnicodeLower0460_0512[$04B2]:=$04B3; UnicodeLower0460_0512[$04B4]:=$04B5; UnicodeLower0460_0512[$04B6]:=$04B7; UnicodeLower0460_0512[$04B8]:=$04B9; UnicodeLower0460_0512[$04BA]:=$04BB; UnicodeLower0460_0512[$04BC]:=$04BD; UnicodeLower0460_0512[$04BE]:=$04BF; UnicodeLower0460_0512[$04C0]:=$04CF; UnicodeLower0460_0512[$04C1]:=$04C2; UnicodeLower0460_0512[$04C3]:=$04C4; UnicodeLower0460_0512[$04C5]:=$04C6; UnicodeLower0460_0512[$04C7]:=$04C8; UnicodeLower0460_0512[$04C9]:=$04CA; UnicodeLower0460_0512[$04CB]:=$04CC; UnicodeLower0460_0512[$04CD]:=$04CE; UnicodeLower0460_0512[$04D0]:=$04D1; UnicodeLower0460_0512[$04D2]:=$04D3; UnicodeLower0460_0512[$04D4]:=$04D5; UnicodeLower0460_0512[$04D6]:=$04D7; UnicodeLower0460_0512[$04D8]:=$04D9; UnicodeLower0460_0512[$04DA]:=$04DB; UnicodeLower0460_0512[$04DC]:=$04DD; UnicodeLower0460_0512[$04DE]:=$04DF; UnicodeLower0460_0512[$04E0]:=$04E1; UnicodeLower0460_0512[$04E2]:=$04E3; UnicodeLower0460_0512[$04E4]:=$04E5; UnicodeLower0460_0512[$04E6]:=$04E7; UnicodeLower0460_0512[$04E8]:=$04E9; UnicodeLower0460_0512[$04EA]:=$04EB; UnicodeLower0460_0512[$04EC]:=$04ED; UnicodeLower0460_0512[$04EE]:=$04EF; UnicodeLower0460_0512[$04F0]:=$04F1; UnicodeLower0460_0512[$04F2]:=$04F3; UnicodeLower0460_0512[$04F4]:=$04F5; UnicodeLower0460_0512[$04F6]:=$04F7; UnicodeLower0460_0512[$04F8]:=$04F9; UnicodeLower0460_0512[$04FA]:=$04FB; UnicodeLower0460_0512[$04FC]:=$04FD; UnicodeLower0460_0512[$04FE]:=$04FF; UnicodeLower0460_0512[$0500]:=$0501; UnicodeLower0460_0512[$0502]:=$0503; UnicodeLower0460_0512[$0504]:=$0505; UnicodeLower0460_0512[$0506]:=$0507; UnicodeLower0460_0512[$0508]:=$0509; UnicodeLower0460_0512[$050A]:=$050B; UnicodeLower0460_0512[$050C]:=$050D; UnicodeLower0460_0512[$050E]:=$050F; UnicodeLower0460_0512[$0510]:=$0511; UnicodeLower0460_0512[$0512]:=$0513; for i:=Low(UnicodeLower1E00_1FFC) to High(UnicodeLower1E00_1FFC) do UnicodeLower1E00_1FFC[i]:=i; UnicodeLower1E00_1FFC[$1E00]:=$1E01; UnicodeLower1E00_1FFC[$1E02]:=$1E03; UnicodeLower1E00_1FFC[$1E04]:=$1E05; UnicodeLower1E00_1FFC[$1E06]:=$1E07; UnicodeLower1E00_1FFC[$1E08]:=$1E09; UnicodeLower1E00_1FFC[$1E0A]:=$1E0B; UnicodeLower1E00_1FFC[$1E0C]:=$1E0D; UnicodeLower1E00_1FFC[$1E0E]:=$1E0F; UnicodeLower1E00_1FFC[$1E10]:=$1E11; UnicodeLower1E00_1FFC[$1E12]:=$1E13; UnicodeLower1E00_1FFC[$1E14]:=$1E15; UnicodeLower1E00_1FFC[$1E16]:=$1E17; UnicodeLower1E00_1FFC[$1E18]:=$1E19; UnicodeLower1E00_1FFC[$1E1A]:=$1E1B; UnicodeLower1E00_1FFC[$1E1C]:=$1E1D; UnicodeLower1E00_1FFC[$1E1E]:=$1E1F; UnicodeLower1E00_1FFC[$1E20]:=$1E21; UnicodeLower1E00_1FFC[$1E22]:=$1E23; UnicodeLower1E00_1FFC[$1E24]:=$1E25; UnicodeLower1E00_1FFC[$1E26]:=$1E27; UnicodeLower1E00_1FFC[$1E28]:=$1E29; UnicodeLower1E00_1FFC[$1E2A]:=$1E2B; UnicodeLower1E00_1FFC[$1E2C]:=$1E2D; UnicodeLower1E00_1FFC[$1E2E]:=$1E2F; UnicodeLower1E00_1FFC[$1E30]:=$1E31; UnicodeLower1E00_1FFC[$1E32]:=$1E33; UnicodeLower1E00_1FFC[$1E34]:=$1E35; UnicodeLower1E00_1FFC[$1E36]:=$1E37; UnicodeLower1E00_1FFC[$1E38]:=$1E39; UnicodeLower1E00_1FFC[$1E3A]:=$1E3B; UnicodeLower1E00_1FFC[$1E3C]:=$1E3D; UnicodeLower1E00_1FFC[$1E3E]:=$1E3F; UnicodeLower1E00_1FFC[$1E40]:=$1E41; UnicodeLower1E00_1FFC[$1E42]:=$1E43; UnicodeLower1E00_1FFC[$1E44]:=$1E45; UnicodeLower1E00_1FFC[$1E46]:=$1E47; UnicodeLower1E00_1FFC[$1E48]:=$1E49; UnicodeLower1E00_1FFC[$1E4A]:=$1E4B; UnicodeLower1E00_1FFC[$1E4C]:=$1E4D; UnicodeLower1E00_1FFC[$1E4E]:=$1E4F; UnicodeLower1E00_1FFC[$1E50]:=$1E51; UnicodeLower1E00_1FFC[$1E52]:=$1E53; UnicodeLower1E00_1FFC[$1E54]:=$1E55; UnicodeLower1E00_1FFC[$1E56]:=$1E57; UnicodeLower1E00_1FFC[$1E58]:=$1E59; UnicodeLower1E00_1FFC[$1E5A]:=$1E5B; UnicodeLower1E00_1FFC[$1E5C]:=$1E5D; UnicodeLower1E00_1FFC[$1E5E]:=$1E5F; UnicodeLower1E00_1FFC[$1E60]:=$1E61; UnicodeLower1E00_1FFC[$1E62]:=$1E63; UnicodeLower1E00_1FFC[$1E64]:=$1E65; UnicodeLower1E00_1FFC[$1E66]:=$1E67; UnicodeLower1E00_1FFC[$1E68]:=$1E69; UnicodeLower1E00_1FFC[$1E6A]:=$1E6B; UnicodeLower1E00_1FFC[$1E6C]:=$1E6D; UnicodeLower1E00_1FFC[$1E6E]:=$1E6F; UnicodeLower1E00_1FFC[$1E70]:=$1E71; UnicodeLower1E00_1FFC[$1E72]:=$1E73; UnicodeLower1E00_1FFC[$1E74]:=$1E75; UnicodeLower1E00_1FFC[$1E76]:=$1E77; UnicodeLower1E00_1FFC[$1E78]:=$1E79; UnicodeLower1E00_1FFC[$1E7A]:=$1E7B; UnicodeLower1E00_1FFC[$1E7C]:=$1E7D; UnicodeLower1E00_1FFC[$1E7E]:=$1E7F; UnicodeLower1E00_1FFC[$1E80]:=$1E81; UnicodeLower1E00_1FFC[$1E82]:=$1E83; UnicodeLower1E00_1FFC[$1E84]:=$1E85; UnicodeLower1E00_1FFC[$1E86]:=$1E87; UnicodeLower1E00_1FFC[$1E88]:=$1E89; UnicodeLower1E00_1FFC[$1E8A]:=$1E8B; UnicodeLower1E00_1FFC[$1E8C]:=$1E8D; UnicodeLower1E00_1FFC[$1E8E]:=$1E8F; UnicodeLower1E00_1FFC[$1E90]:=$1E91; UnicodeLower1E00_1FFC[$1E92]:=$1E93; UnicodeLower1E00_1FFC[$1E94]:=$1E95; UnicodeLower1E00_1FFC[$1EA0]:=$1EA1; UnicodeLower1E00_1FFC[$1EA2]:=$1EA3; UnicodeLower1E00_1FFC[$1EA4]:=$1EA5; UnicodeLower1E00_1FFC[$1EA6]:=$1EA7; UnicodeLower1E00_1FFC[$1EA8]:=$1EA9; UnicodeLower1E00_1FFC[$1EAA]:=$1EAB; UnicodeLower1E00_1FFC[$1EAC]:=$1EAD; UnicodeLower1E00_1FFC[$1EAE]:=$1EAF; UnicodeLower1E00_1FFC[$1EB0]:=$1EB1; UnicodeLower1E00_1FFC[$1EB2]:=$1EB3; UnicodeLower1E00_1FFC[$1EB4]:=$1EB5; UnicodeLower1E00_1FFC[$1EB6]:=$1EB7; UnicodeLower1E00_1FFC[$1EB8]:=$1EB9; UnicodeLower1E00_1FFC[$1EBA]:=$1EBB; UnicodeLower1E00_1FFC[$1EBC]:=$1EBD; UnicodeLower1E00_1FFC[$1EBE]:=$1EBF; UnicodeLower1E00_1FFC[$1EC0]:=$1EC1; UnicodeLower1E00_1FFC[$1EC2]:=$1EC3; UnicodeLower1E00_1FFC[$1EC4]:=$1EC5; UnicodeLower1E00_1FFC[$1EC6]:=$1EC7; UnicodeLower1E00_1FFC[$1EC8]:=$1EC9; UnicodeLower1E00_1FFC[$1ECA]:=$1ECB; UnicodeLower1E00_1FFC[$1ECC]:=$1ECD; UnicodeLower1E00_1FFC[$1ECE]:=$1ECF; UnicodeLower1E00_1FFC[$1ED0]:=$1ED1; UnicodeLower1E00_1FFC[$1ED2]:=$1ED3; UnicodeLower1E00_1FFC[$1ED4]:=$1ED5; UnicodeLower1E00_1FFC[$1ED6]:=$1ED7; UnicodeLower1E00_1FFC[$1ED8]:=$1ED9; UnicodeLower1E00_1FFC[$1EDA]:=$1EDB; UnicodeLower1E00_1FFC[$1EDC]:=$1EDD; UnicodeLower1E00_1FFC[$1EDE]:=$1EDF; UnicodeLower1E00_1FFC[$1EE0]:=$1EE1; UnicodeLower1E00_1FFC[$1EE2]:=$1EE3; UnicodeLower1E00_1FFC[$1EE4]:=$1EE5; UnicodeLower1E00_1FFC[$1EE6]:=$1EE7; UnicodeLower1E00_1FFC[$1EE8]:=$1EE9; UnicodeLower1E00_1FFC[$1EEA]:=$1EEB; UnicodeLower1E00_1FFC[$1EEC]:=$1EED; UnicodeLower1E00_1FFC[$1EEE]:=$1EEF; UnicodeLower1E00_1FFC[$1EF0]:=$1EF1; UnicodeLower1E00_1FFC[$1EF2]:=$1EF3; UnicodeLower1E00_1FFC[$1EF4]:=$1EF5; UnicodeLower1E00_1FFC[$1EF6]:=$1EF7; UnicodeLower1E00_1FFC[$1EF8]:=$1EF9; UnicodeLower1E00_1FFC[$1F08]:=$1F00; UnicodeLower1E00_1FFC[$1F09]:=$1F01; UnicodeLower1E00_1FFC[$1F0A]:=$1F02; UnicodeLower1E00_1FFC[$1F0B]:=$1F03; UnicodeLower1E00_1FFC[$1F0C]:=$1F04; UnicodeLower1E00_1FFC[$1F0D]:=$1F05; UnicodeLower1E00_1FFC[$1F0E]:=$1F06; UnicodeLower1E00_1FFC[$1F0F]:=$1F07; UnicodeLower1E00_1FFC[$1F18]:=$1F10; UnicodeLower1E00_1FFC[$1F19]:=$1F11; UnicodeLower1E00_1FFC[$1F1A]:=$1F12; UnicodeLower1E00_1FFC[$1F1B]:=$1F13; UnicodeLower1E00_1FFC[$1F1C]:=$1F14; UnicodeLower1E00_1FFC[$1F1D]:=$1F15; UnicodeLower1E00_1FFC[$1F28]:=$1F20; UnicodeLower1E00_1FFC[$1F29]:=$1F21; UnicodeLower1E00_1FFC[$1F2A]:=$1F22; UnicodeLower1E00_1FFC[$1F2B]:=$1F23; UnicodeLower1E00_1FFC[$1F2C]:=$1F24; UnicodeLower1E00_1FFC[$1F2D]:=$1F25; UnicodeLower1E00_1FFC[$1F2E]:=$1F26; UnicodeLower1E00_1FFC[$1F2F]:=$1F27; UnicodeLower1E00_1FFC[$1F38]:=$1F30; UnicodeLower1E00_1FFC[$1F39]:=$1F31; UnicodeLower1E00_1FFC[$1F3A]:=$1F32; UnicodeLower1E00_1FFC[$1F3B]:=$1F33; UnicodeLower1E00_1FFC[$1F3C]:=$1F34; UnicodeLower1E00_1FFC[$1F3D]:=$1F35; UnicodeLower1E00_1FFC[$1F3E]:=$1F36; UnicodeLower1E00_1FFC[$1F3F]:=$1F37; UnicodeLower1E00_1FFC[$1F48]:=$1F40; UnicodeLower1E00_1FFC[$1F49]:=$1F41; UnicodeLower1E00_1FFC[$1F4A]:=$1F42; UnicodeLower1E00_1FFC[$1F4B]:=$1F43; UnicodeLower1E00_1FFC[$1F4C]:=$1F44; UnicodeLower1E00_1FFC[$1F4D]:=$1F45; UnicodeLower1E00_1FFC[$1F59]:=$1F51; UnicodeLower1E00_1FFC[$1F5B]:=$1F53; UnicodeLower1E00_1FFC[$1F5D]:=$1F55; UnicodeLower1E00_1FFC[$1F5F]:=$1F57; UnicodeLower1E00_1FFC[$1F68]:=$1F60; UnicodeLower1E00_1FFC[$1F69]:=$1F61; UnicodeLower1E00_1FFC[$1F6A]:=$1F62; UnicodeLower1E00_1FFC[$1F6B]:=$1F63; UnicodeLower1E00_1FFC[$1F6C]:=$1F64; UnicodeLower1E00_1FFC[$1F6D]:=$1F65; UnicodeLower1E00_1FFC[$1F6E]:=$1F66; UnicodeLower1E00_1FFC[$1F6F]:=$1F67; UnicodeLower1E00_1FFC[$1F88]:=$1F80; UnicodeLower1E00_1FFC[$1F89]:=$1F81; UnicodeLower1E00_1FFC[$1F8A]:=$1F82; UnicodeLower1E00_1FFC[$1F8B]:=$1F83; UnicodeLower1E00_1FFC[$1F8C]:=$1F84; UnicodeLower1E00_1FFC[$1F8D]:=$1F85; UnicodeLower1E00_1FFC[$1F8E]:=$1F86; UnicodeLower1E00_1FFC[$1F8F]:=$1F87; UnicodeLower1E00_1FFC[$1F98]:=$1F90; UnicodeLower1E00_1FFC[$1F99]:=$1F91; UnicodeLower1E00_1FFC[$1F9A]:=$1F92; UnicodeLower1E00_1FFC[$1F9B]:=$1F93; UnicodeLower1E00_1FFC[$1F9C]:=$1F94; UnicodeLower1E00_1FFC[$1F9D]:=$1F95; UnicodeLower1E00_1FFC[$1F9E]:=$1F96; UnicodeLower1E00_1FFC[$1F9F]:=$1F97; UnicodeLower1E00_1FFC[$1FA8]:=$1FA0; UnicodeLower1E00_1FFC[$1FA9]:=$1FA1; UnicodeLower1E00_1FFC[$1FAA]:=$1FA2; UnicodeLower1E00_1FFC[$1FAB]:=$1FA3; UnicodeLower1E00_1FFC[$1FAC]:=$1FA4; UnicodeLower1E00_1FFC[$1FAD]:=$1FA5; UnicodeLower1E00_1FFC[$1FAE]:=$1FA6; UnicodeLower1E00_1FFC[$1FAF]:=$1FA7; UnicodeLower1E00_1FFC[$1FB8]:=$1FB0; UnicodeLower1E00_1FFC[$1FB9]:=$1FB1; UnicodeLower1E00_1FFC[$1FBA]:=$1F70; UnicodeLower1E00_1FFC[$1FBB]:=$1F71; UnicodeLower1E00_1FFC[$1FBC]:=$1FB3; UnicodeLower1E00_1FFC[$1FC8]:=$1F72; UnicodeLower1E00_1FFC[$1FC9]:=$1F73; UnicodeLower1E00_1FFC[$1FCA]:=$1F74; UnicodeLower1E00_1FFC[$1FCB]:=$1F75; UnicodeLower1E00_1FFC[$1FCC]:=$1FC3; UnicodeLower1E00_1FFC[$1FD8]:=$1FD0; UnicodeLower1E00_1FFC[$1FD9]:=$1FD1; UnicodeLower1E00_1FFC[$1FDA]:=$1F76; UnicodeLower1E00_1FFC[$1FDB]:=$1F77; UnicodeLower1E00_1FFC[$1FE8]:=$1FE0; UnicodeLower1E00_1FFC[$1FE9]:=$1FE1; UnicodeLower1E00_1FFC[$1FEA]:=$1F7A; UnicodeLower1E00_1FFC[$1FEB]:=$1F7B; UnicodeLower1E00_1FFC[$1FEC]:=$1FE5; UnicodeLower1E00_1FFC[$1FF8]:=$1F78; UnicodeLower1E00_1FFC[$1FF9]:=$1F79; UnicodeLower1E00_1FFC[$1FFA]:=$1F7C; UnicodeLower1E00_1FFC[$1FFB]:=$1F7D; UnicodeLower1E00_1FFC[$1FFC]:=$1FF3; for i:=Low(UnicodeLower2126_2183) to High(UnicodeLower2126_2183) do UnicodeLower2126_2183[i]:=i; UnicodeLower2126_2183[$2126]:=$03C9; UnicodeLower2126_2183[$212A]:=$006B; UnicodeLower2126_2183[$212B]:=$00E5; UnicodeLower2126_2183[$2132]:=$214E; UnicodeLower2126_2183[$2160]:=$2170; UnicodeLower2126_2183[$2161]:=$2171; UnicodeLower2126_2183[$2162]:=$2172; UnicodeLower2126_2183[$2163]:=$2173; UnicodeLower2126_2183[$2164]:=$2174; UnicodeLower2126_2183[$2165]:=$2175; UnicodeLower2126_2183[$2166]:=$2176; UnicodeLower2126_2183[$2167]:=$2177; UnicodeLower2126_2183[$2168]:=$2178; UnicodeLower2126_2183[$2169]:=$2179; UnicodeLower2126_2183[$216A]:=$217A; UnicodeLower2126_2183[$216B]:=$217B; UnicodeLower2126_2183[$216C]:=$217C; UnicodeLower2126_2183[$216D]:=$217D; UnicodeLower2126_2183[$216E]:=$217E; UnicodeLower2126_2183[$216F]:=$217F; UnicodeLower2126_2183[$2183]:=$2184; for i:=Low(UnicodeLower2C60_2CE2) to High(UnicodeLower2C60_2CE2) do UnicodeLower2C60_2CE2[i]:=i; UnicodeLower2C60_2CE2[$2C60]:=$2C61; UnicodeLower2C60_2CE2[$2C62]:=$026B; UnicodeLower2C60_2CE2[$2C63]:=$1D7D; UnicodeLower2C60_2CE2[$2C64]:=$027D; UnicodeLower2C60_2CE2[$2C67]:=$2C68; UnicodeLower2C60_2CE2[$2C69]:=$2C6A; UnicodeLower2C60_2CE2[$2C6B]:=$2C6C; UnicodeLower2C60_2CE2[$2C75]:=$2C76; UnicodeLower2C60_2CE2[$2C80]:=$2C81; UnicodeLower2C60_2CE2[$2C82]:=$2C83; UnicodeLower2C60_2CE2[$2C84]:=$2C85; UnicodeLower2C60_2CE2[$2C86]:=$2C87; UnicodeLower2C60_2CE2[$2C88]:=$2C89; UnicodeLower2C60_2CE2[$2C8A]:=$2C8B; UnicodeLower2C60_2CE2[$2C8C]:=$2C8D; UnicodeLower2C60_2CE2[$2C8E]:=$2C8F; UnicodeLower2C60_2CE2[$2C90]:=$2C91; UnicodeLower2C60_2CE2[$2C92]:=$2C93; UnicodeLower2C60_2CE2[$2C94]:=$2C95; UnicodeLower2C60_2CE2[$2C96]:=$2C97; UnicodeLower2C60_2CE2[$2C98]:=$2C99; UnicodeLower2C60_2CE2[$2C9A]:=$2C9B; UnicodeLower2C60_2CE2[$2C9C]:=$2C9D; UnicodeLower2C60_2CE2[$2C9E]:=$2C9F; UnicodeLower2C60_2CE2[$2CA0]:=$2CA1; UnicodeLower2C60_2CE2[$2CA2]:=$2CA3; UnicodeLower2C60_2CE2[$2CA4]:=$2CA5; UnicodeLower2C60_2CE2[$2CA6]:=$2CA7; UnicodeLower2C60_2CE2[$2CA8]:=$2CA9; UnicodeLower2C60_2CE2[$2CAA]:=$2CAB; UnicodeLower2C60_2CE2[$2CAC]:=$2CAD; UnicodeLower2C60_2CE2[$2CAE]:=$2CAF; UnicodeLower2C60_2CE2[$2CB0]:=$2CB1; UnicodeLower2C60_2CE2[$2CB2]:=$2CB3; UnicodeLower2C60_2CE2[$2CB4]:=$2CB5; UnicodeLower2C60_2CE2[$2CB6]:=$2CB7; UnicodeLower2C60_2CE2[$2CB8]:=$2CB9; UnicodeLower2C60_2CE2[$2CBA]:=$2CBB; UnicodeLower2C60_2CE2[$2CBC]:=$2CBD; UnicodeLower2C60_2CE2[$2CBE]:=$2CBF; UnicodeLower2C60_2CE2[$2CC0]:=$2CC1; UnicodeLower2C60_2CE2[$2CC2]:=$2CC3; UnicodeLower2C60_2CE2[$2CC4]:=$2CC5; UnicodeLower2C60_2CE2[$2CC6]:=$2CC7; UnicodeLower2C60_2CE2[$2CC8]:=$2CC9; UnicodeLower2C60_2CE2[$2CCA]:=$2CCB; UnicodeLower2C60_2CE2[$2CCC]:=$2CCD; UnicodeLower2C60_2CE2[$2CCE]:=$2CCF; UnicodeLower2C60_2CE2[$2CD0]:=$2CD1; UnicodeLower2C60_2CE2[$2CD2]:=$2CD3; UnicodeLower2C60_2CE2[$2CD4]:=$2CD5; UnicodeLower2C60_2CE2[$2CD6]:=$2CD7; UnicodeLower2C60_2CE2[$2CD8]:=$2CD9; UnicodeLower2C60_2CE2[$2CDA]:=$2CDB; UnicodeLower2C60_2CE2[$2CDC]:=$2CDD; UnicodeLower2C60_2CE2[$2CDE]:=$2CDF; UnicodeLower2C60_2CE2[$2CE0]:=$2CE1; UnicodeLower2C60_2CE2[$2CE2]:=$2CE3; end; {$endif NewLowerCase} function DeleteAmpersands(var Str : String) : Longint; // Replace all &x with x // and return the position of the first ampersand letter in the resulting Str. // double ampersands && are converted to a single & and are ignored. var SrcPos, DestPos, SrcLen: Integer; begin Result:=-1; SrcLen:=length(Str); SrcPos:=1; DestPos:=1; while SrcPos<=SrcLen do begin if (Str[SrcPos]='&') and (SrcPos'&') and (Result<1) then Result:=DestPos; end; if DestPos '' then begin Result := ''; if ShortCut and scShift <> 0 then Result := Result + MenuKeyCaps[mkcShift]; if ShortCut and scCtrl <> 0 then Result := Result + MenuKeyCaps[mkcCtrl]; if ShortCut and scMeta <> 0 then Result := Result + MenuKeyCaps[mkcMeta]; if ShortCut and scAlt <> 0 then Result := Result + MenuKeyCaps[mkcAlt]; Result := Result + Name; end else Result := ''; end; function TextToShortCut(const ShortCutText: string): TShortCut; function CompareFront(var StartPos: integer; const Front: string): Boolean; begin if (Front<>'') and (StartPos+length(Front)-1<=length(ShortCutText)) and (AnsiStrLIComp(@ShortCutText[StartPos], PChar(Front), Length(Front))= 0) then begin Result:=true; inc(StartPos,length(Front)); end else Result:=false; end; var Key: TShortCut; Shift: TShortCut; StartPos: integer; Name: string; begin Result := 0; Shift := 0; StartPos:=1; while True do begin if CompareFront(StartPos, MenuKeyCaps[mkcShift]) then Shift := Shift or scShift else if CompareFront(StartPos, '^') then Shift := Shift or scCtrl else if CompareFront(StartPos, MenuKeyCaps[mkcCtrl]) then Shift := Shift or scCtrl else if CompareFront(StartPos, MenuKeyCaps[mkcAlt]) then Shift := Shift or scAlt else if CompareFront(StartPos, MenuKeyCaps[mkcMeta]) then Shift := Shift or scMeta else Break; end; if ShortCutText = '' then Exit; for Key := $08 to $FF do begin { Copy range from table in ShortCutToText } Name:=ShortCutToText(Key); if (Name<>'') and (length(Name)=length(ShortCutText)-StartPos+1) and (AnsiStrLIComp(@ShortCutText[StartPos], PChar(Name), length(Name)) = 0) then begin Result := Key or Shift; Exit; end; end; end; function GetCompleteText(sText: string; iSelStart: Integer; bCaseSensitive, bSearchAscending: Boolean; slTextList: TStrings): string; function IsSamePrefix(sCompareText, sPrefix: string; iStart: Integer; var ResultText: string): Boolean; var sTempText: string; begin Result := False; sTempText := UTF8Copy(sCompareText, 1, iStart); if not bCaseSensitive then sTempText := UTF8UpperCase(sTempText); if (sTempText = sPrefix) then begin ResultText := sCompareText; Result := True; end; end; var i: Integer; sPrefixText: string; begin //DebugLn(['GetCompleteText sText=',sText,' iSelStart=',iSelStart,' bCaseSensitive=',bCaseSensitive,' bSearchAscending=',bSearchAscending,' slTextList.Count=',slTextList.Count]); Result := sText;//Default to return original text if no identical text are found if (sText = '') then Exit;//Everything is compatible with nothing, Exit. if (iSelStart = 0) then Exit;//Cursor at beginning if (slTextList.Count = 0) then Exit;//No text list to search for idtenticals, Exit. sPrefixText := UTF8Copy(sText, 1, iSelStart);//Get text from beginning to cursor position. if not bCaseSensitive then sPrefixText := UTF8UpperCase(sPrefixText); if bSearchAscending then begin for i := 0 to slTextList.Count - 1 do if IsSamePrefix(slTextList[i], sPrefixText, iSelStart, Result) then break; end else begin for i := slTextList.Count - 1 downto 0 do if IsSamePrefix(slTextList[i], sPrefixText, iSelStart, Result) then break; end; end; function IsEditableTextKey(Key: Word): Boolean; begin Result := (((Key >= VK_A) and (Key <= VK_Z)) or ((Key >= VK_NUMPAD0) and (Key <= VK_DIVIDE)) or ((Key >= 186) and (Key <= 188)) or ((Key >= 190) and (Key <= 192)) or ((Key >= 219) and (Key <= 222))); end; function SendApplicationMessage(Msg: Cardinal; WParam: WParam; LParam: LParam ): Longint; begin if SendApplicationMessageFunction<>nil then Result:=SendApplicationMessageFunction(Msg, WParam, LParam) else Result:=0; end; procedure OwnerFormDesignerModified(AComponent: TComponent); begin if ([csDesigning,csLoading,csDestroying]*AComponent.ComponentState =[csDesigning]) then begin if OwnerFormDesignerModifiedProc<>nil then OwnerFormDesignerModifiedProc(AComponent); end; end; function OffSetRect(var ARect: TRect; dx,dy: Integer): Boolean; Begin with ARect do begin Left := Left + dx; Right := Right + dx; Top := Top + dy; Bottom := Bottom + dy; end; if (ARect.Left >= 0) and (ARect.Top >= 0) then Result := True else Result := False; end; procedure FreeThenNil(var AnObject: TObject); begin if AnObject<>nil then begin AnObject.Free; AnObject:=nil; end; end; procedure RegisterInterfaceInitializationHandler(p: TProcedure); begin InterfaceInitializationHandlers.Add(p); end; procedure CallInterfaceInitializationHandlers; var i: Integer; begin for i:=0 to InterfaceInitializationHandlers.Count-1 do TProcedure(InterfaceInitializationHandlers[i])(); end; procedure RegisterInterfaceFinalizationHandler(p: TProcedure); begin InterfaceFinalizationHandlers.Add(p); end; procedure CallInterfaceFinalizationHandlers; var i: Integer; begin for i:=0 to InterfaceFinalizationHandlers.Count-1 do TProcedure(InterfaceFinalizationHandlers[i])(); end; { TMethodList } function TMethodList.GetItems(Index: integer): TMethod; begin Result:=FItems[Index]; end; procedure TMethodList.SetItems(Index: integer; const AValue: TMethod); begin FItems[Index]:=AValue; end; destructor TMethodList.Destroy; begin ReAllocMem(FItems,0); inherited Destroy; end; function TMethodList.Count: integer; begin if Self<>nil then Result:=FCount else Result:=0; end; function TMethodList.NextDownIndex(var Index: integer): boolean; begin if Self<>nil then begin dec(Index); if (Index>=FCount) then Index:=FCount-1; end else Index:=-1; Result:=(Index>=0); end; function TMethodList.IndexOf(const AMethod: TMethod): integer; begin if Self<>nil then begin Result:=FCount-1; while Result>=0 do begin if (FItems[Result].Code=AMethod.Code) and (FItems[Result].Data=AMethod.Data) then exit; dec(Result); end; end else Result:=-1; end; procedure TMethodList.Delete(Index: integer); begin dec(FCount); if FCount>Index then System.Move(FItems[Index+1],FItems[Index],(FCount-Index)*SizeOf(TMethod)); ReAllocMem(FItems,FCount*SizeOf(TMethod)); end; procedure TMethodList.Remove(const AMethod: TMethod); var i: integer; begin if Self<>nil then begin i:=IndexOf(AMethod); if i>=0 then Delete(i); end; end; procedure TMethodList.Add(const AMethod: TMethod); begin inc(FCount); ReAllocMem(FItems,FCount*SizeOf(TMethod)); FItems[FCount-1]:=AMethod; end; procedure TMethodList.Add(const AMethod: TMethod; AsLast: boolean); begin if AsLast then Add(AMethod) else Insert(0,AMethod); end; procedure TMethodList.Insert(Index: integer; const AMethod: TMethod); begin inc(FCount); ReAllocMem(FItems,FCount*SizeOf(TMethod)); if IndexNewIndex then System.Move(FItems[NewIndex],FItems[NewIndex+1], SizeOf(TMethod)*(OldIndex-NewIndex)) else System.Move(FItems[NewIndex+1],FItems[NewIndex], SizeOf(TMethod)*(NewIndex-OldIndex)); FItems[NewIndex]:=MovingMethod; end; procedure TMethodList.RemoveAllMethodsOfObject(const AnObject: TObject); var i: Integer; begin if Self=nil then exit; i:=FCount-1; while i>=0 do begin if TObject(FItems[i].Data)=AnObject then Delete(i); dec(i); end; end; procedure TMethodList.CallNotifyEvents(Sender: TObject); var i: LongInt; begin i:=Count; while NextDownIndex(i) do TNotifyEvent(Items[i])(Sender); end; {------------------------------------------------------------------------------ procedure RaiseGDBException(const Msg: string); Raises an exception. gdb does normally not catch fpc Exception objects, therefore this procedure raises a standard AV which is catched by gdb. ------------------------------------------------------------------------------} procedure RaiseGDBException(const Msg: string); begin debugln(rsERRORInLCL, Msg); // creates an exception, that gdb catches: debugln(rsCreatingGdbCatchableError); DumpStack; if (length(Msg) div (length(Msg) div 10000))=0 then ; end; procedure DumpExceptionBackTrace; var FrameCount: integer; Frames: PPointer; FrameNumber:Integer; begin DebugLn(' Stack trace:'); DebugLn(BackTraceStrFunc(ExceptAddr)); FrameCount:=ExceptFrameCount; Frames:=ExceptFrames; for FrameNumber := 0 to FrameCount-1 do DebugLn(BackTraceStrFunc(Frames[FrameNumber])); end; procedure DumpStack; Begin if assigned(DebugText) then Dump_Stack(DebugText^, get_frame); End; function GetStackTrace(UseCache: boolean): string; var bp: Pointer; addr: Pointer; oldbp: Pointer; CurAddress: Shortstring; begin Result:=''; { retrieve backtrace info } bp:=get_caller_frame(get_frame); while bp<>nil do begin addr:=get_caller_addr(bp); CurAddress:=GetLineInfo(addr,UseCache); //DebugLn('GetStackTrace ',CurAddress); Result:=Result+CurAddress+LineEnding; oldbp:=bp; bp:=get_caller_frame(bp); if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then bp:=nil; end; end; procedure GetStackTracePointers(var AStack: TStackTracePointers); var Depth: Integer; bp: Pointer; oldbp: Pointer; begin // get stack depth Depth:=0; bp:=get_caller_frame(get_frame); while bp<>nil do begin inc(Depth); oldbp:=bp; bp:=get_caller_frame(bp); if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then bp:=nil; end; SetLength(AStack,Depth); if Depth>0 then begin Depth:=0; bp:=get_caller_frame(get_frame); while bp<>nil do begin AStack[Depth]:=get_caller_addr(bp); inc(Depth); oldbp:=bp; bp:=get_caller_frame(bp); if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then bp:=nil; end; end; end; function StackTraceAsString(const AStack: TStackTracePointers; UseCache: boolean): string; var i: Integer; CurAddress: String; begin Result:=''; for i:=0 to length(AStack)-1 do begin CurAddress:=GetLineInfo(AStack[i],UseCache); Result:=Result+CurAddress+LineEnding; end; end; function GetLineInfo(Addr: Pointer; UseCache: boolean): string; var ANode: TAvgLvlTreeNode; Item: PLineInfoCacheItem; begin if UseCache then begin if LineInfoCache=nil then LineInfoCache:=TAvgLvlTree.Create(@CompareLineInfoCacheItems); ANode:=LineInfoCache.FindKey(Addr,@CompareAddrWithLineInfoCacheItem); if ANode=nil then begin Result:=BackTraceStrFunc(Addr); New(Item); Item^.Addr:=Addr; Item^.Info:=Result; LineInfoCache.Add(Item); end else begin Result:=PLineInfoCacheItem(ANode.Data)^.Info; end; end else Result:=BackTraceStrFunc(Addr); end; procedure MoveRect(var ARect: TRect; x, y: Integer); begin inc(ARect.Right,x-ARect.Left); inc(ARect.Bottom,y-ARect.Top); ARect.Left:=x; ARect.Top:=y; end; procedure MoveRectToFit(var ARect: TRect; const MaxRect: TRect); // move ARect, so it fits into MaxRect // if MaxRect is too small, ARect is resized. begin if ARect.LeftMaxRect.Right then begin // move rectangle left ARect.Left:=Max(ARect.Left-ARect.Right+MaxRect.Right,MaxRect.Left); ARect.Right:=MaxRect.Right; end; if ARect.Bottom>MaxRect.Bottom then begin // move rectangle left ARect.Top:=Max(ARect.Top-ARect.Bottom+MaxRect.Bottom,MaxRect.Top); ARect.Bottom:=MaxRect.Bottom; end; end; procedure MakeMinMax(var i1, i2: integer); var h: Integer; begin if i1>i2 then begin h:=i1; i1:=i2; i2:=h; end; end; procedure CalculateLeftTopWidthHeight(X1, Y1, X2, Y2: integer; var Left, Top, Width, Height: integer); begin if X1 <= X2 then begin Left := X1; Width := X2 - X1; end else begin Left := X2; Width := X1 - X2; end; if Y1 <= Y2 then begin Top := Y1; Height := Y2 - Y1; end else begin Top := Y2; Height := Y1 - Y2; end; end; function BreakString(const s: string; MaxLineLength, Indent: integer): string; var SrcLen: Integer; APos: Integer; Src: String; SplitPos: Integer; CurMaxLineLength: Integer; begin Result:=''; Src:=s; CurMaxLineLength:=MaxLineLength; if Indent>MaxLineLength-2 then Indent:=MaxLineLength-2; if Indent<0 then MaxLineLength:=0; repeat SrcLen:=length(Src); if SrcLen<=CurMaxLineLength then begin Result:=Result+Src; break; end; // split line SplitPos:=0; // search new line chars APos:=1; while (APos<=CurMaxLineLength) do begin if Src[APos] in [#13,#10] then begin SplitPos:=APos; break; end; inc(APos); end; // search a space boundary if SplitPos=0 then begin APos:=CurMaxLineLength; while APos>1 do begin if (Src[APos-1] in [' ',#9]) and (not (Src[APos] in [' ',#9])) then begin SplitPos:=APos; break; end; dec(APos); end; end; // search a word boundary if SplitPos=0 then begin APos:=CurMaxLineLength; while APos>1 do begin if (Src[APos] in ['A'..'Z','a'..'z']) and (not (Src[APos-1] in ['A'..'Z','a'..'z'])) then begin SplitPos:=APos; break; end; dec(APos); end; end; if SplitPos=0 then begin // no word boundary found -> split chars SplitPos:=CurMaxLineLength; end; // append part and newline if (SplitPos<=SrcLen) and (Src[SplitPos] in [#10,#13]) then begin // there is already a new line char at position inc(SplitPos); if (SplitPos<=SrcLen) and (Src[SplitPos] in [#10,#13]) and (Src[SplitPos]<>Src[SplitPos-1]) then inc(SplitPos); Result:=Result+copy(Src,1,SplitPos-1); end else begin Result:=Result+copy(Src,1,SplitPos-1)+LineEnding; end; // append indent if Indent>0 then Result:=Result+StringOfChar(' ',Indent); // calculate new LineLength CurMaxLineLength:=MaxLineLength-Indent; // cut string Src:=copy(Src,SplitPos,length(Src)-SplitPos+1); until false; end; function ComparePointers(p1, p2: Pointer): integer; begin if p1>p2 then Result:=1 else if p1h2 then Result:=1 else if h1

h2 then Result:=1 else if h1

',R2^.Left,',',R2^.Top,',',R2^.Right,',',R2^.Bottom); end;} end; function ComparePoints(const p1, p2: TPoint): integer; begin if p1.Y>p2.Y then Result:=1 else if p1.Yp2.X then Result:=1 else if p1.X=Pos2) and (OnCompare(List[Pos2-1],List[Pos3])<=0) do dec(Pos3); if (Pos1>=Pos2) or (Pos2>Pos3) then exit; Src1Pos:=Pos2-1; Src2Pos:=Pos3; DestPos:=Pos3; while (Src2Pos>=Pos2) and (Src1Pos>=Pos1) do begin cmp:=OnCompare(List[Src1Pos],List[Src2Pos]); if cmp>0 then begin MergeList[DestPos]:=List[Src1Pos]; dec(Src1Pos); end else begin MergeList[DestPos]:=List[Src2Pos]; dec(Src2Pos); end; dec(DestPos); end; while Src2Pos>=Pos2 do begin MergeList[DestPos]:=List[Src2Pos]; dec(Src2Pos); dec(DestPos); end; for a:=DestPos+1 to Pos3 do List[a]:=MergeList[a]; end; procedure Sort(StartPos, EndPos: PtrInt); // sort an interval in List. Use MergeList as work space. var cmp, mid: integer; p: Pointer; begin if StartPos=EndPos then begin end else if StartPos+1=EndPos then begin cmp:=OnCompare(List[StartPos],List[EndPos]); if cmp>0 then begin p:=List[StartPos]; List[StartPos]:=List[EndPos]; List[EndPos]:=p; end; end else if EndPos>StartPos then begin mid:=(StartPos+EndPos) shr 1; Sort(StartPos,mid); Sort(mid+1,EndPos); Merge(StartPos,mid+1,EndPos); end; end; begin if (List=nil) or (List.Count<=1) then exit; MergeList:=GetMem(List.Count*SizeOf(Pointer)); Sort(0,List.Count-1); Freemem(MergeList); end; procedure MergeSort(List: TStrings; const OnCompare: TStringsSortCompare); var MergeList: PAnsiString; procedure Merge(Pos1, Pos2, Pos3: PtrInt); // merge two sorted arrays // the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3 var Src1Pos,Src2Pos,DestPos,cmp,a:integer; begin while (Pos3>=Pos2) and (OnCompare(List[Pos2-1],List[Pos3])<=0) do dec(Pos3); if (Pos1>=Pos2) or (Pos2>Pos3) then exit; Src1Pos:=Pos2-1; Src2Pos:=Pos3; DestPos:=Pos3; while (Src2Pos>=Pos2) and (Src1Pos>=Pos1) do begin cmp:=OnCompare(List[Src1Pos],List[Src2Pos]); if cmp>0 then begin MergeList[DestPos]:=List[Src1Pos]; dec(Src1Pos); end else begin MergeList[DestPos]:=List[Src2Pos]; dec(Src2Pos); end; dec(DestPos); end; while Src2Pos>=Pos2 do begin MergeList[DestPos]:=List[Src2Pos]; dec(Src2Pos); dec(DestPos); end; for a:=DestPos+1 to Pos3 do List[a]:=MergeList[a]; end; procedure Sort(StartPos, EndPos: PtrInt); // sort an interval in List. Use MergeList as work space. var cmp, mid: integer; s: string; begin if StartPos=EndPos then begin end else if StartPos+1=EndPos then begin cmp:=OnCompare(List[StartPos],List[EndPos]); if cmp>0 then begin s:=List[StartPos]; List[StartPos]:=List[EndPos]; List[EndPos]:=s; end; end else if EndPos>StartPos then begin mid:=(StartPos+EndPos) shr 1; Sort(StartPos,mid); Sort(mid+1,EndPos); Merge(StartPos,mid+1,EndPos); end; end; var CurSize: PtrInt; i: PtrInt; begin if (List=nil) or (List.Count<=1) then exit; CurSize:=PtrInt(List.Count)*SizeOf(Pointer); MergeList:=GetMem(CurSize); FillChar(MergeList^,CurSize,0); Sort(0,List.Count-1); for i:=0 to List.Count-1 do MergeList[i]:=''; Freemem(MergeList); end; procedure InitializeDebugOutput; var DebugFileName: string; function GetDebugFileName: string; const DebugLogStart = '--debug-log='; DebugLogStartLength = length(DebugLogStart); var i: integer; EnvVarName: string; begin Result := ''; // first try to find the log file name in the command line parameters for i:= 1 to Paramcount do begin if copy(ParamStrUTF8(i),1, DebugLogStartLength)=DebugLogStart then begin Result := copy(ParamStrUTF8(i), DebugLogStartLength+1, Length(ParamStrUTF8(i))-DebugLogStartLength); end; end; // if not found yet, then try to find in the environment variables if (length(result)=0) then begin EnvVarName:= ChangeFileExt(ExtractFileName(ParamStrUTF8(0)),'') + '_debuglog'; Result := GetEnvironmentVariableUTF8(EnvVarName); end; if (length(result)>0) then Result := ExpandFileNameUTF8(Result); end; begin DebugText := nil; DebugFileName := GetDebugFileName; if (length(DebugFileName)>0) and (DirPathExists(ExtractFileDir(DebugFileName))) then begin new(DebugText); try Assign(DebugText^, DebugFileName); if FileExistsUTF8(DebugFileName) then Append(DebugText^) else Rewrite(DebugText^); except Freemem(DebugText); DebugText := nil; // Add extra line ending: a dialog will be shown in windows gui application writeln(StdOut, 'Cannot open file: ', DebugFileName+LineEnding); end; end; if DebugText=nil then begin if TextRec(Output).Mode=fmClosed then DebugText := nil else DebugText := @Output; DebugTextAllocated := false; end else DebugTextAllocated := true; end; procedure CloseDebugOutput; begin if DebugTextAllocated then begin Close(DebugText^); Dispose(DebugText); DebugTextAllocated := false; end; DebugText := nil; end; procedure FinalizeDebugOutput; begin CloseDebugOutput; end; procedure DebugLn(Args: array of const); var i: Integer; begin for i:=Low(Args) to High(Args) do begin case Args[i].VType of vtInteger: DbgOut(dbgs(Args[i].vinteger)); vtInt64: DbgOut(dbgs(Args[i].VInt64^)); vtQWord: DbgOut(dbgs(Args[i].VQWord^)); vtBoolean: DbgOut(dbgs(Args[i].vboolean)); vtExtended: DbgOut(dbgs(Args[i].VExtended^)); {$ifdef FPC_CURRENCY_IS_INT64} // MWE: // fpc 2.x has troubles in choosing the right dbgs() // so we convert here vtCurrency: DbgOut(dbgs(int64(Args[i].vCurrency^)/10000, 4)); {$else} vtCurrency: DbgOut(dbgs(Args[i].vCurrency^)); {$endif} vtString: DbgOut(Args[i].VString^); vtAnsiString: DbgOut(AnsiString(Args[i].VAnsiString)); vtChar: DbgOut(Args[i].VChar); vtPChar: DbgOut(Args[i].VPChar); vtPWideChar: DbgOut(Args[i].VPWideChar); vtWideChar: DbgOut(Args[i].VWideChar); vtWidestring: DbgOut(WideString(Args[i].VWideString)); vtObject: DbgOut(DbgSName(Args[i].VObject)); vtClass: DbgOut(DbgSName(Args[i].VClass)); vtPointer: DbgOut(Dbgs(Args[i].VPointer)); else DbgOut('?unknown variant?'); end; end; DebugLn; end; procedure DebugLn(const S: String; Args: array of const); begin DebugLn(Format(S, Args)); end; procedure DebugLn; begin DebugLn(''); end; procedure DebugLn(const s: string); begin if not Assigned(DebugText) then exit; writeln(DebugText^, ConvertLineEndings(s)); end; procedure DebugLn(const s1, s2: string); begin DebugLn(s1+s2); end; procedure DebugLn(const s1, s2, s3: string); begin DebugLn(s1+s2+s3); end; procedure DebugLn(const s1, s2, s3, s4: string); begin DebugLn(s1+s2+s3+s4); end; procedure DebugLn(const s1, s2, s3, s4, s5: string); begin DebugLn(s1+s2+s3+s4+s5); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6: string); begin DebugLn(s1+s2+s3+s4+s5+s6); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15); end; procedure DebugLn(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16: string); begin DebugLn(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15+s16); end; function ConvertLineEndings(const s: string): string; var i: Integer; EndingStart: LongInt; begin Result:=s; i:=1; while (i<=length(Result)) do begin if Result[i] in [#10,#13] then begin EndingStart:=i; inc(i); if (i<=length(Result)) and (Result[i] in [#10,#13]) and (Result[i]<>Result[i-1]) then begin inc(i); end; if (length(LineEnding)<>i-EndingStart) or (LineEnding<>copy(Result,EndingStart,length(LineEnding))) then begin // line end differs => replace with current LineEnding Result:= copy(Result,1,EndingStart-1)+LineEnding+copy(Result,i,length(Result)); i:=EndingStart+length(LineEnding); end; end else inc(i); end; end; procedure DbgOut(const S: String; Args: array of const); begin DbgOut(Format(S, Args)); end; procedure DBGOut(const s: string); begin if Assigned(DebugText) then write(DebugText^, s); end; procedure DBGOut(const s1, s2: string); begin DbgOut(s1+s2); end; procedure DbgOut(const s1, s2, s3: string); begin DbgOut(s1+s2+s3); end; procedure DbgOut(const s1, s2, s3, s4: string); begin DbgOut(s1+s2+s3+s4); end; procedure DbgOut(const s1, s2, s3, s4, s5: string); begin DbgOut(s1+s2+s3+s4+s5); end; procedure DbgOut(const s1, s2, s3, s4, s5, s6: string); begin DbgOut(s1+s2+s3+s4+s5+s6); end; procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7: string); begin DbgOut(s1+s2+s3+s4+s5+s6+s7); end; procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8: string); begin DbgOut(s1+s2+s3+s4+s5+s6+s7+s8); end; procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8, s9: string); begin DbgOut(s1+s2+s3+s4+s5+s6+s7+s8+s9); end; procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10: string); begin DbgOut(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10); end; procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11: string); begin DbgOut(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11); end; procedure DbgOut(const s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12: string ); begin DbgOut(s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12); end; function DbgS(const c: cardinal): string; begin Result:=IntToStr(c); end; function DbgS(const i: longint): string; begin Result:=IntToStr(i); end; function DbgS(const i: int64): string; begin Result:=IntToStr(i); end; function DbgS(const q: qword): string; begin Result:=IntToStr(q); end; function DbgS(const r: TRect): string; begin Result:=' x1='+IntToStr(r.Left)+',y1='+IntToStr(r.Top) +',x2='+IntToStr(r.Right)+',y2='+IntToStr(r.Bottom); end; function DbgS(const p: TPoint): string; begin Result:='(x='+IntToStr(p.x)+',y='+IntToStr(p.y)+')'; end; function DbgS(const p: pointer): string; begin Result:=HexStr(PtrUInt(p),2*sizeof(PtrInt)); end; function DbgS(const e: extended; MaxDecimals: integer): string; begin Result:=copy(FloatToStr(e),1,MaxDecimals); end; function DbgS(const b: boolean): string; begin if b then Result:='True' else Result:='False'; end; function DbgS(const s: TComponentState): string; procedure Add(const a: string); begin if Result<>'' then Result:=Result+','; Result:=Result+a; end; begin Result:=''; if csLoading in s then Add('csLoading'); if csReading in s then Add('csReading'); if csWriting in s then Add('csWriting'); if csDestroying in s then Add('csDestroying'); if csDesigning in s then Add('csDesigning'); if csAncestor in s then Add('csAncestor'); if csUpdating in s then Add('csUpdating'); if csFixups in s then Add('csFixups'); if csFreeNotification in s then Add('csFreeNotification'); if csInline in s then Add('csInline'); if csDesignInstance in s then Add('csDesignInstance'); Result:='['+Result+']'; end; function DbgSName(const p: TObject): string; begin if p=nil then Result:='nil' else if p is TComponent then Result:=TComponent(p).Name+':'+p.ClassName else Result:=p.ClassName; end; function DbgSName(const p: TClass): string; begin if p=nil then Result:='nil' else Result:=p.ClassName; end; function DbgStr(const StringWithSpecialChars: string): string; var i: Integer; s: String; begin Result:=StringWithSpecialChars; i:=1; while (i<=length(Result)) do begin case Result[i] of ' '..#126: inc(i); else s:='#'+HexStr(ord(Result[i]),2); Result:=copy(Result,1,i-1)+s+copy(Result,i+1,length(Result)-i); inc(i,length(s)); end; end; end; function DbgWideStr(const StringWithSpecialChars: widestring): string; var s: String; SrcPos: Integer; DestPos: Integer; i: Integer; begin SetLength(Result,length(StringWithSpecialChars)); SrcPos:=1; DestPos:=1; while SrcPos<=length(StringWithSpecialChars) do begin i:=ord(StringWithSpecialChars[SrcPos]); case i of 32..126: begin Result[DestPos]:=chr(i); inc(SrcPos); inc(DestPos); end; else s:='#'+HexStr(i,4); inc(SrcPos); Result:=copy(Result,1,DestPos-1)+s+copy(Result,DestPos+1,length(Result)); inc(DestPos,length(s)); end; end; end; function dbgMemRange(P: PByte; Count: integer; Width: integer): string; const HexChars: array[0..15] of char = '0123456789ABCDEF'; LineEnd: shortstring = LineEnding; var i: Integer; NewLen: Integer; Dest: PChar; Col: Integer; j: Integer; begin Result:=''; if (p=nil) or (Count<=0) then exit; NewLen:=Count*2; if Width>0 then begin inc(NewLen,(Count div Width)*length(LineEnd)); end; SetLength(Result,NewLen); Dest:=PChar(Result); Col:=1; for i:=0 to Count-1 do begin Dest^:=HexChars[PByte(P)[i] shr 4]; inc(Dest); Dest^:=HexChars[PByte(P)[i] and $f]; inc(Dest); inc(Col); if (Width>0) and (Col>Width) then begin Col:=1; for j:=1 to length(LineEnd) do begin Dest^:=LineEnd[j]; inc(Dest); end; end; end; end; function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string; var s: string; begin Result:=''; if (MemStream=nil) or (not (MemStream is TCustomMemoryStream)) or (Count<=0) then exit; Count:=Min(Count,MemStream.Size); if Count<=0 then exit; SetLength(s,Count); Count:=MemStream.Read(s[1],Count); Result:=dbgMemRange(PByte(s),Count); end; function dbgObjMem(AnObject: TObject): string; begin Result:=''; if AnObject=nil then exit; Result:=dbgMemRange(PByte(AnObject),AnObject.InstanceSize); end; function dbghex(i: Int64): string; const Hex = '0123456789ABCDEF'; var Negated: Boolean; begin Result:=''; if i<0 then begin Negated:=true; i:=-i; end else Negated:=false; repeat Result:=Hex[(i mod 16)+1]+Result; i:=i div 16; until i=0; if Negated then Result:='-'+Result; end; function DbgS(const i1, i2, i3, i4: integer): string; begin Result:=dbgs(i1)+','+dbgs(i2)+','+dbgs(i3)+','+dbgs(i4); end; function DbgS(const Shift: TShiftState): string; procedure Add(const s: string); begin if Result<>'' then Result:=Result+','; Result:=Result+s; end; begin Result:=''; if ssShift in Shift then Add('ssShift'); if ssAlt in Shift then Add('ssAlt'); if ssCtrl in Shift then Add('ssCtrl'); if ssLeft in Shift then Add('ssLeft'); if ssRight in Shift then Add('ssRight'); if ssMiddle in Shift then Add('ssMiddle'); if ssDouble in Shift then Add('ssDouble'); if ssMeta in Shift then Add('ssMeta'); if ssSuper in Shift then Add('ssSuper'); if ssHyper in Shift then Add('ssHyper'); if ssAltGr in Shift then Add('ssAltGr'); if ssCaps in Shift then Add('ssCaps'); if ssNum in Shift then Add('ssNum'); if ssScroll in Shift then Add('ssScroll'); if ssTriple in Shift then Add('ssTriple'); if ssQuad in Shift then Add('ssQuad'); Result:='['+Result+']'; end; function DbgsVKCode(c: word): string; begin case c of VK_UNKNOWN: Result:='VK_UNKNOWN'; VK_LBUTTON: Result:='VK_LBUTTON'; VK_RBUTTON: Result:='VK_RBUTTON'; VK_CANCEL: Result:='VK_CANCEL'; VK_MBUTTON: Result:='VK_MBUTTON'; VK_BACK: Result:='VK_BACK'; VK_TAB: Result:='VK_TAB'; VK_CLEAR: Result:='VK_CLEAR'; VK_RETURN: Result:='VK_RETURN'; VK_SHIFT: Result:='VK_SHIFT'; VK_CONTROL: Result:='VK_CONTROL'; VK_MENU: Result:='VK_MENU'; VK_PAUSE: Result:='VK_PAUSE'; VK_CAPITAL: Result:='VK_CAPITAL'; VK_KANA: Result:='VK_KANA'; VK_JUNJA: Result:='VK_JUNJA'; VK_FINAL: Result:='VK_FINAL'; VK_HANJA: Result:='VK_HANJA'; VK_ESCAPE: Result:='VK_ESCAPE'; VK_CONVERT: Result:='VK_CONVERT'; VK_NONCONVERT: Result:='VK_NONCONVERT'; VK_ACCEPT: Result:='VK_ACCEPT'; VK_MODECHANGE: Result:='VK_MODECHANGE'; VK_SPACE: Result:='VK_SPACE'; VK_PRIOR: Result:='VK_PRIOR'; VK_NEXT: Result:='VK_NEXT'; VK_END: Result:='VK_END'; VK_HOME: Result:='VK_HOME'; VK_LEFT: Result:='VK_LEFT'; VK_UP: Result:='VK_UP'; VK_RIGHT: Result:='VK_RIGHT'; VK_DOWN: Result:='VK_DOWN'; VK_SELECT: Result:='VK_SELECT'; VK_PRINT: Result:='VK_PRINT'; VK_EXECUTE: Result:='VK_EXECUTE'; VK_SNAPSHOT: Result:='VK_SNAPSHOT'; VK_INSERT: Result:='VK_INSERT'; VK_DELETE: Result:='VK_DELETE'; VK_HELP: Result:='VK_HELP'; VK_0: Result:='VK_0'; VK_1: Result:='VK_1'; VK_2: Result:='VK_2'; VK_3: Result:='VK_3'; VK_4: Result:='VK_4'; VK_5: Result:='VK_5'; VK_6: Result:='VK_6'; VK_7: Result:='VK_7'; VK_8: Result:='VK_8'; VK_9: Result:='VK_9'; VK_A: Result:='VK_A'; VK_B: Result:='VK_B'; VK_C: Result:='VK_C'; VK_D: Result:='VK_D'; VK_E: Result:='VK_E'; VK_F: Result:='VK_F'; VK_G: Result:='VK_G'; VK_H: Result:='VK_H'; VK_I: Result:='VK_I'; VK_J: Result:='VK_J'; VK_K: Result:='VK_K'; VK_L: Result:='VK_L'; VK_M: Result:='VK_M'; VK_N: Result:='VK_N'; VK_O: Result:='VK_O'; VK_P: Result:='VK_P'; VK_Q: Result:='VK_Q'; VK_R: Result:='VK_R'; VK_S: Result:='VK_S'; VK_T: Result:='VK_T'; VK_U: Result:='VK_U'; VK_V: Result:='VK_V'; VK_W: Result:='VK_W'; VK_X: Result:='VK_X'; VK_Y: Result:='VK_Y'; VK_Z: Result:='VK_Z'; VK_LWIN: Result:='VK_LWIN'; VK_RWIN: Result:='VK_RWIN'; VK_APPS: Result:='VK_APPS'; VK_SLEEP: Result:='VK_SLEEP'; VK_NUMPAD0: Result:='VK_NUMPAD0'; VK_NUMPAD1: Result:='VK_NUMPAD1'; VK_NUMPAD2: Result:='VK_NUMPAD2'; VK_NUMPAD3: Result:='VK_NUMPAD3'; VK_NUMPAD4: Result:='VK_NUMPAD4'; VK_NUMPAD5: Result:='VK_NUMPAD5'; VK_NUMPAD6: Result:='VK_NUMPAD6'; VK_NUMPAD7: Result:='VK_NUMPAD7'; VK_NUMPAD8: Result:='VK_NUMPAD8'; VK_NUMPAD9: Result:='VK_NUMPAD9'; VK_MULTIPLY: Result:='VK_MULTIPLY'; VK_ADD: Result:='VK_ADD'; VK_SEPARATOR: Result:='VK_SEPARATOR'; VK_SUBTRACT: Result:='VK_SUBTRACT'; VK_DECIMAL: Result:='VK_DECIMAL'; VK_DIVIDE: Result:='VK_DIVIDE'; VK_F1: Result:='VK_F1'; VK_F2: Result:='VK_F2'; VK_F3: Result:='VK_F3'; VK_F4: Result:='VK_F4'; VK_F5: Result:='VK_F5'; VK_F6: Result:='VK_F6'; VK_F7: Result:='VK_F7'; VK_F8: Result:='VK_F8'; VK_F9: Result:='VK_F9'; VK_F10: Result:='VK_F10'; VK_F11: Result:='VK_F11'; VK_F12: Result:='VK_F12'; VK_F13: Result:='VK_F13'; VK_F14: Result:='VK_F14'; VK_F15: Result:='VK_F15'; VK_F16: Result:='VK_F16'; VK_F17: Result:='VK_F17'; VK_F18: Result:='VK_F18'; VK_F19: Result:='VK_F19'; VK_F20: Result:='VK_F20'; VK_F21: Result:='VK_F21'; VK_F22: Result:='VK_F22'; VK_F23: Result:='VK_F23'; VK_F24: Result:='VK_F24'; VK_NUMLOCK: Result:='VK_NUMLOCK'; VK_SCROLL: Result:='VK_SCROLL'; VK_LSHIFT: Result:='VK_LSHIFT'; VK_RSHIFT: Result:='VK_RSHIFT'; VK_LCONTROL: Result:='VK_LCONTROL'; VK_RCONTROL: Result:='VK_RCONTROL'; VK_LMENU: Result:='VK_LMENU'; VK_RMENU: Result:='VK_RMENU'; VK_BROWSER_BACK: Result:='VK_BROWSER_BACK'; VK_BROWSER_FORWARD: Result:='VK_BROWSER_FORWARD'; VK_BROWSER_REFRESH: Result:='VK_BROWSER_REFRESH'; VK_BROWSER_STOP: Result:='VK_BROWSER_STOP'; VK_BROWSER_SEARCH: Result:='VK_BROWSER_SEARCH'; VK_BROWSER_FAVORITES: Result:='VK_BROWSER_FAVORITES'; VK_BROWSER_HOME: Result:='VK_BROWSER_HOME'; VK_VOLUME_MUTE: Result:='VK_VOLUME_MUTE'; VK_VOLUME_DOWN: Result:='VK_VOLUME_DOWN'; VK_VOLUME_UP: Result:='VK_VOLUME_UP'; VK_MEDIA_NEXT_TRACK: Result:='VK_MEDIA_NEXT_TRACK'; VK_MEDIA_PREV_TRACK: Result:='VK_MEDIA_PREV_TRACK'; VK_MEDIA_STOP: Result:='VK_MEDIA_STOP'; VK_MEDIA_PLAY_PAUSE: Result:='VK_MEDIA_PLAY_PAUSE'; VK_LAUNCH_MAIL: Result:='VK_LAUNCH_MAIL'; VK_LAUNCH_MEDIA_SELECT: Result:='VK_LAUNCH_MEDIA_SELECT'; VK_LAUNCH_APP1: Result:='VK_LAUNCH_APP1'; VK_LAUNCH_APP2: Result:='VK_LAUNCH_APP2'; else Result:='VK_('+dbgs(c)+')'; end; end; function DbgS(const ASize: TSize): string; begin Result := 'cx: ' + DbgS(ASize.cx) + ' cy: ' + DbgS(ASize.cy); end; function DbgS(const ATM: TTextMetric): string; begin with ATM do Result := 'tmHeight: ' + DbgS(tmHeight) + ' tmAscent: ' + DbgS(tmAscent) + ' tmDescent: ' + DbgS(tmDescent) + ' tmInternalLeading: ' + DbgS(tmInternalLeading) + ' tmExternalLeading: ' + DbgS(tmExternalLeading) + ' tmAveCharWidth: ' + DbgS(tmAveCharWidth) + ' tmMaxCharWidth: ' + DbgS(tmMaxCharWidth) + ' tmWeight: ' + DbgS(tmWeight) + ' tmOverhang: ' + DbgS(tmOverhang) + ' tmDigitizedAspectX: ' + DbgS(tmDigitizedAspectX) + ' tmDigitizedAspectY: ' + DbgS(tmDigitizedAspectY) + ' tmFirstChar: ' + tmFirstChar + ' tmLastChar: ' + tmLastChar + ' tmDefaultChar: ' + tmDefaultChar + ' tmBreakChar: ' + tmBreakChar + ' tmItalic: ' + DbgS(tmItalic) + ' tmUnderlined: ' + DbgS(tmUnderlined) + ' tmStruckOut: ' + DbgS(tmStruckOut) + ' tmPitchAndFamily: ' + DbgS(tmPitchAndFamily) + ' tmCharSet: ' + DbgS(tmCharSet); end; function DbgS(const AScrollInfo: TScrollInfo): string; begin Result := ''; if (SIF_POS and AScrollInfo.fMask) > 0 then Result := 'Pos: ' + DbgS(AScrollInfo.nPos); if (SIF_RANGE and AScrollInfo.fMask) > 0 then Result := Result + ' Min: ' + DbgS(AScrollInfo.nMin) + ' Max: ' + DbgS(AScrollInfo.nMax); if (SIF_PAGE and AScrollInfo.fMask) > 0 then Result := Result + ' Page: ' + DbgS(AScrollInfo.nPage); if (SIF_TRACKPOS and AScrollInfo.fMask) > 0 then Result := Result + ' TrackPos: ' + DbgS(AScrollInfo.nTrackPos); if Result = '' then Result := '(no scrollinfo)'; end; procedure DbgOutThreadLog(const Msg: string); var PID: PtrInt; fs: TFileStream; Filename: string; begin PID:=PtrInt(GetThreadID); Filename:='Log'+IntToStr(PID); if FileExistsUTF8(Filename) then fs:=TFileStream.Create(UTF8ToSys(Filename),fmOpenWrite) else fs:=TFileStream.Create(UTF8ToSys(Filename),fmCreate); fs.Position:=fs.Size; fs.Write(Msg[1], length(Msg)); fs.Free; end; procedure DebuglnThreadLog(const Msg: string); var PID: PtrInt; begin PID:=PtrInt(GetThreadID); DbgOutThreadLog(IntToStr(PtrInt(PID))+' : '+Msg+LineEnding); end; procedure DebuglnThreadLog(Args: array of const); var i: Integer; s: String; begin s:=''; for i:=Low(Args) to High(Args) do begin case Args[i].VType of vtInteger: s:=s+dbgs(Args[i].vinteger); vtInt64: s:=s+dbgs(Args[i].VInt64^); vtQWord: s:=s+dbgs(Args[i].VQWord^); vtBoolean: s:=s+dbgs(Args[i].vboolean); vtExtended: s:=s+dbgs(Args[i].VExtended^); {$ifdef FPC_CURRENCY_IS_INT64} // MWE: // ppcppc 2.0.2 has troubles in choosing the right dbgs() // so we convert here (i don't know about other versions vtCurrency: s:=s+dbgs(int64(Args[i].vCurrency^)/10000, 4); {$else} vtCurrency: s:=s+dbgs(Args[i].vCurrency^); {$endif} vtString: s:=s+Args[i].VString^; vtAnsiString: s:=s+AnsiString(Args[i].VAnsiString); vtChar: s:=s+Args[i].VChar; vtPChar: s:=s+Args[i].VPChar; vtPWideChar: s:=s+Args[i].VPWideChar; vtWideChar: s:=s+Args[i].VWideChar; vtWidestring: s:=s+WideString(Args[i].VWideString); vtObject: s:=s+DbgSName(Args[i].VObject); vtClass: s:=s+DbgSName(Args[i].VClass); vtPointer: s:=s+Dbgs(Args[i].VPointer); else DbgOutThreadLog('?unknown variant?'); end; end; DebuglnThreadLog(s); end; procedure DebuglnThreadLog; begin DebuglnThreadLog(''); end; procedure DbgSaveData(FileName: String; AData: PChar; ADataSize: PtrUInt); var S: TStream; begin S := TFileStream.Create(UTF8ToSys(FileName), fmCreate); S.Write(AData^, ADataSize); S.Free; end; procedure DbgAppendToFile(FileName, S: String); var F: TextFile; begin AssignFile(F, FileName); {$I-} Append(F); if IOResult <> 0 then Rewrite(F); {$I+} WriteLn(F, S); CloseFile(F); end; function StripLN(const ALine: String): String; var idx: Integer; begin idx := Pos(#10, ALine); if idx = 0 then begin idx := Pos(#13, ALine); if idx = 0 then begin Result := ALine; Exit; end; end else begin if (idx > 1) and (ALine[idx - 1] = #13) then Dec(idx); end; Result := Copy(ALine, 1, idx - 1); end; function GetPart(const ASkipTo, AnEnd: String; var ASource: String): String; begin Result := GetPart([ASkipTo], [AnEnd], ASource, False, True); end; function GetPart(const ASkipTo, AnEnd: String; var ASource: String; const AnIgnoreCase: Boolean): String; overload; begin Result := GetPart([ASkipTo], [AnEnd], ASource, AnIgnoreCase, True); end; function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String): String; overload; begin Result := GetPart(ASkipTo, AnEnd, ASource, False, True); end; function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String; const AnIgnoreCase: Boolean): String; overload; begin Result := GetPart(ASkipTo, AnEnd, ASource, AnIgnoreCase, True); end; function GetPart(const ASkipTo, AnEnd: array of String; var ASource: String; const AnIgnoreCase, AnUpdateSource: Boolean): String; overload; var n, i, idx: Integer; S, Source, Match: String; HasEscape: Boolean; begin Source := ASource; if High(ASkipTo) >= 0 then begin idx := 0; HasEscape := False; if AnIgnoreCase then S := UpperCase(Source) else S := Source; for n := Low(ASkipTo) to High(ASkipTo) do begin if ASkipTo[n] = '' then begin HasEscape := True; Continue; end; if AnIgnoreCase then i := Pos(UpperCase(ASkipTo[n]), S) else i := Pos(ASkipTo[n], S); if i > idx then begin idx := i; Match := ASkipTo[n]; end; end; if (idx = 0) and not HasEscape then begin Result := ''; Exit; end; if idx > 0 then Delete(Source, 1, idx + Length(Match) - 1); end; if AnIgnoreCase then S := UpperCase(Source) else S := Source; idx := MaxInt; for n := Low(AnEnd) to High(AnEnd) do begin if AnEnd[n] = '' then Continue; if AnIgnoreCase then i := Pos(UpperCase(AnEnd[n]), S) else i := Pos(AnEnd[n], S); if (i > 0) and (i < idx) then idx := i; end; if idx = MaxInt then begin Result := Source; Source := ''; end else begin Result := Copy(Source, 1, idx - 1); Delete(Source, 1, idx - 1); end; if AnUpdateSource then ASource := Source; end; { Ensures the covenient look of multiline string when displaying it in the single line * Replaces CR and LF with spaces * Removes duplicate spaces } function TextToSingleLine(const AText: string): string; var str: string; i, wstart, wlen: Integer; begin str := Trim(AText); wstart := 0; wlen := 0; i := 1; while i < Length(str) - 1 do begin if (str[i] in [' ', #13, #10]) then begin if (wstart = 0) then begin wstart := i; wlen := 1; end else Inc(wlen); end else begin if wstart > 0 then begin str[wstart] := ' '; Delete(str, wstart+1, wlen-1); Dec(i, wlen-1); wstart := 0; end; end; Inc(i); end; Result := str; end; function StringCase(const AString: String; const ACase: array of String {; const AIgnoreCase = False, APartial = false: Boolean}): Integer; begin Result := StringCase(AString, ACase, False, False); end; function StringCase(const AString: String; const ACase: array of String; const AIgnoreCase, APartial: Boolean): Integer; var Search, S: String; begin if High(ACase) = -1 then begin Result := -1; Exit; end; if AIgnoreCase then Search := UpperCase(AString) else Search := AString; for Result := Low(ACase) to High(ACase) do begin if AIgnoreCase then S := UpperCase(ACase[Result]) else S := ACase[Result]; if Search = S then Exit; if not APartial then Continue; if Length(Search) >= Length(S) then Continue; if StrLComp(PChar(Search), PChar(S), Length(Search)) = 0 then Exit; end; Result := -1; end; function ClassCase(const AClass: TClass; const ACase: array of TClass {; const ADecendant: Boolean = True}): Integer; begin Result := ClassCase(AClass, ACase, True); end; function ClassCase(const AClass: TClass; const ACase: array of TClass; const ADecendant: Boolean): Integer; begin for Result := Low(ACase) to High(ACase) do begin if AClass = ACase[Result] then Exit; if not ADecendant then Continue; if AClass.InheritsFrom(ACase[Result]) then Exit; end; Result := -1; end; function UTF8CharacterLength(p: PChar): integer; begin if p<>nil then begin if ord(p^)<%11000000 then begin // regular single byte character (#0 is a character, this is pascal ;) Result:=1; end else if ((ord(p^) and %11100000) = %11000000) then begin // could be 2 byte character if (ord(p[1]) and %11000000) = %10000000 then Result:=2 else Result:=1; end else if ((ord(p^) and %11110000) = %11100000) then begin // could be 3 byte character if ((ord(p[1]) and %11000000) = %10000000) and ((ord(p[2]) and %11000000) = %10000000) then Result:=3 else Result:=1; end else if ((ord(p^) and %11111000) = %11110000) then begin // could be 4 byte character if ((ord(p[1]) and %11000000) = %10000000) and ((ord(p[2]) and %11000000) = %10000000) and ((ord(p[3]) and %11000000) = %10000000) then Result:=4 else Result:=1; end else Result:=1 end else Result:=0; end; function UTF8Length(const s: string): integer; begin Result:=UTF8Length(PChar(s),length(s)); end; function UTF8Length(p: PChar; ByteCount: integer): integer; var CharLen: LongInt; begin Result:=0; while (ByteCount>0) do begin inc(Result); CharLen:=UTF8CharacterLength(p); inc(p,CharLen); dec(ByteCount,CharLen); end; end; function UTF8CharacterToUnicode(p: PChar; out CharLen: integer): Cardinal; begin if p<>nil then begin if ord(p^)<%11000000 then begin // regular single byte character (#0 is a normal char, this is pascal ;) Result:=ord(p^); CharLen:=1; end else if ((ord(p^) and %11100000) = %11000000) then begin // could be double byte character if (ord(p[1]) and %11000000) = %10000000 then begin Result:=((ord(p^) and %00011111) shl 6) or (ord(p[1]) and %00111111); CharLen:=2; end else begin Result:=ord(p^); CharLen:=1; end; end else if ((ord(p^) and %11110000) = %11100000) then begin // could be triple byte character if ((ord(p[1]) and %11000000) = %10000000) and ((ord(p[2]) and %11000000) = %10000000) then begin Result:=((ord(p^) and %00011111) shl 12) or ((ord(p[1]) and %00111111) shl 6) or (ord(p[2]) and %00111111); CharLen:=3; end else begin Result:=ord(p^); CharLen:=1; end; end else if ((ord(p^) and %11111000) = %11110000) then begin // could be 4 byte character if ((ord(p[1]) and %11000000) = %10000000) and ((ord(p[2]) and %11000000) = %10000000) and ((ord(p[3]) and %11000000) = %10000000) then begin Result:=((ord(p^) and %00001111) shl 18) or ((ord(p[1]) and %00111111) shl 12) or ((ord(p[2]) and %00111111) shl 6) or (ord(p[3]) and %00111111); CharLen:=4; end else begin Result:=ord(p^); CharLen:=1; end; end else begin // invalid character Result:=ord(p^); CharLen:=1; end; end else begin Result:=0; CharLen:=0; end; end; function UnicodeToUTF8(u: cardinal; Buf: PChar): integer; procedure RaiseInvalidUnicode; begin raise Exception.Create('UnicodeToUTF8: invalid unicode: '+IntToStr(u)); end; begin case u of 0..$7f: begin Result:=1; Buf[0]:=char(byte(u)); end; $80..$7ff: begin Result:=2; Buf[0]:=char(byte($c0 or (u shr 6))); Buf[1]:=char(byte($80 or (u and $3f))); end; $800..$ffff: begin Result:=3; Buf[0]:=char(byte($e0 or (u shr 12))); Buf[1]:=char(byte((u shr 6) and $3f) or $80); Buf[2]:=char(byte(u and $3f) or $80); end; $10000..$10ffff: begin Result:=4; Buf[0]:=char(byte($f0 or (u shr 18))); Buf[1]:=char(byte((u shr 12) and $3f) or $80); Buf[2]:=char(byte((u shr 6) and $3f) or $80); Buf[3]:=char(byte(u and $3f) or $80); end; else RaiseInvalidUnicode; end; end; function UnicodeToUTF8(u: cardinal): shortstring; begin Result[0]:=chr(UnicodeToUTF8(u,@Result[1])); end; function UTF8ToDoubleByteString(const s: string): string; var Len: Integer; begin Len:=UTF8Length(s); SetLength(Result,Len*2); if Len=0 then exit; UTF8ToDoubleByte(PChar(s),length(s),PByte(Result)); end; { returns number of double bytes } function UTF8ToDoubleByte(UTF8Str: PChar; Len: integer; DBStr: PByte): integer; var SrcPos: PChar; CharLen: LongInt; DestPos: PByte; u: Cardinal; begin SrcPos:=UTF8Str; DestPos:=DBStr; Result:=0; while Len>0 do begin u:=UTF8CharacterToUnicode(SrcPos,CharLen); DestPos^:=byte((u shr 8) and $ff); inc(DestPos); DestPos^:=byte(u and $ff); inc(DestPos); inc(SrcPos,CharLen); dec(Len,CharLen); inc(Result); end; end; function UTF8FindNearestCharStart(UTF8Str: PChar; Len: integer; BytePos: integer): integer; var CharLen: LongInt; begin Result:=0; if UTF8Str<>nil then begin if BytePos>Len then BytePos:=Len; while (BytePos>0) do begin CharLen:=UTF8CharacterLength(UTF8Str); dec(BytePos,CharLen); if (BytePos<0) then exit; inc(Result,CharLen); if (BytePos=0) then exit; inc(UTF8Str,CharLen); end; end; end; { Len is the length in bytes of UTF8Str CharIndex is the position of the desired char, in chars This function is similar to UTF8FindNearestCharStart } function UTF8CharStart(UTF8Str: PChar; Len, CharIndex: integer): PChar; var CharLen: LongInt; begin Result:=UTF8Str; if Result<>nil then begin while (CharIndex>0) and (Len>0) do begin CharLen:=UTF8CharacterLength(Result); dec(Len,CharLen); dec(CharIndex); inc(Result,CharLen); end; if (CharIndex>0) or (Len<0) then Result:=nil; end; end; function UTF8CharToByteIndex(UTF8Str : PChar; Len, CharIndex : integer) : Integer; var p: PChar; begin p := UTF8CharStart(UTF8Str, Len, CharIndex); if p = nil then Result := -1 else Result := p - UTF8Str; end; { fix any broken UTF8 sequences with spaces } procedure UTF8FixBroken(P: PChar); begin if p=nil then exit; while p^<>#0 do begin if ord(p^)<%10000000 then begin // regular single byte character inc(p); end else if ord(p^)<%11000000 then begin // invalid p^:=' '; inc(p); end else if ((ord(p^) and %11100000) = %11000000) then begin // should be 2 byte character if (ord(p[1]) and %11000000) = %10000000 then inc(p,2) else if p[1]<>#0 then p^:=' '; end else if ((ord(p^) and %11110000) = %11100000) then begin // should be 3 byte character if ((ord(p[1]) and %11000000) = %10000000) and ((ord(p[2]) and %11000000) = %10000000) then inc(p,3) else p^:=' '; end else if ((ord(p^) and %11111000) = %11110000) then begin // should be 4 byte character if ((ord(p[1]) and %11000000) = %10000000) and ((ord(p[2]) and %11000000) = %10000000) and ((ord(p[3]) and %11000000) = %10000000) then inc(p,4) else p^:=' '; end else begin p^:=' '; inc(p); end; end; end; function UTF8CharacterStrictLength(P: PChar): integer; begin if p=nil then exit(0); if ord(p^)<%10000000 then begin // regular single byte character exit(1); end else if ord(p^)<%11000000 then begin // invalid single byte character exit(0); end else if ((ord(p^) and %11100000) = %11000000) then begin // should be 2 byte character if (ord(p[1]) and %11000000) = %10000000 then exit(2) else exit(0); end else if ((ord(p^) and %11110000) = %11100000) then begin // should be 3 byte character if ((ord(p[1]) and %11000000) = %10000000) and ((ord(p[2]) and %11000000) = %10000000) then exit(3) else exit(0); end else if ((ord(p^) and %11111000) = %11110000) then begin // should be 4 byte character if ((ord(p[1]) and %11000000) = %10000000) and ((ord(p[2]) and %11000000) = %10000000) and ((ord(p[3]) and %11000000) = %10000000) then exit(4) else exit(0); end else exit(0); end; function UTF8CStringToUTF8String(SourceStart: PChar; SourceLen: SizeInt) : string; var Source: PChar; Dest: PChar; SourceEnd: PChar; CharLen: integer; SourceCopied: PChar; // Copies from SourceStart till Source to Dest and updates Dest procedure CopyPart; inline; var CopyLength: SizeInt; begin CopyLength := Source - SourceCopied; if CopyLength=0 then exit; move(SourceCopied^ , Dest^, CopyLength); SourceCopied:=Source; inc(Dest, CopyLength); end; begin SetLength(Result, SourceLen); if SourceLen=0 then exit; SourceCopied:=SourceStart; Source:=SourceStart; Dest:=PChar(Result); SourceEnd := Source + SourceLen; while Source0 then Result:=UTF8Length(PChar(SearchInText),p-1)+1 else Result:=0; end; function UTF8Copy(const s: string; StartCharIndex, CharCount: integer): string; // returns substring var StartBytePos: PChar; EndBytePos: PChar; MaxBytes: PtrInt; begin StartBytePos:=UTF8CharStart(PChar(s),length(s),StartCharIndex-1); if StartBytePos=nil then Result:='' else begin MaxBytes:=PtrInt(PChar(s)+length(s)-StartBytePos); EndBytePos:=UTF8CharStart(StartBytePos,MaxBytes,CharCount); if EndBytePos=nil then Result:=copy(s,StartBytePos-PChar(s)+1,MaxBytes) else Result:=copy(s,StartBytePos-PChar(s)+1,EndBytePos-StartBytePos); end; end; procedure UTF8Delete(var s: String; StartCharIndex, CharCount: integer); var StartBytePos: PChar; EndBytePos: PChar; MaxBytes: PtrInt; begin StartBytePos:=UTF8CharStart(PChar(s),length(s),StartCharIndex-1); if StartBytePos <> nil then begin MaxBytes:=PtrInt(PChar(s)+length(s)-StartBytePos); EndBytePos:=UTF8CharStart(StartBytePos,MaxBytes,CharCount); if EndBytePos=nil then Delete(s,StartBytePos-PChar(s)+1,MaxBytes) else Delete(s,StartBytePos-PChar(s)+1,EndBytePos-StartBytePos); end; end; procedure UTF8Insert(const source: String; var s: string; StartCharIndex: integer); var StartBytePos: PChar; begin StartBytePos:=UTF8CharStart(PChar(s),length(s),StartCharIndex-1); if StartBytePos <> nil then Insert(source, s, StartBytePos-PChar(s)+1); end; function UTF8LowerCase(const s: String): String; begin Result := UTF8Encode(WideLowerCase(UTF8Decode(s))); end; function UTF8UpperCase(const s: String): String; begin Result := UTF8Encode(WideUpperCase(UTF8Decode(s))); end; {$ifdef NewLowerCase} function UnicodeLowercase(u: cardinal): cardinal; begin if u<$00C0 then begin // most common if (u>=$0041) and (u<=$0061) then Result:=u+32 else Result:=u; end else case u of $00C0..$00DE: Result:=UnicodeLower00C0_00DE[u]; $0100..$024E: Result:=UnicodeLower0100_024E[u]; $0386..$03AB: Result:=UnicodeLower0386_03AB[u]; $03D8..$042F: Result:=UnicodeLower03D8_042F[u]; $0460..$0512: Result:=UnicodeLower0460_0512[u]; $0531..$0556: Result:=u+48; $10A0..$10C5: Result:=u+7264; $1E00..$1FFC: Result:=UnicodeLower1E00_1FFC[u]; $2126..$2183: Result:=UnicodeLower2126_2183[u]; $24B6..$24CF: Result:=u+26; $2C00..$2C2E: Result:=u+48; $2C60..$2CE2: Result:=UnicodeLower2C60_2CE2[u]; $FF21..$FF3A: Result:=u+32; else Result:=u; end; end; function UTF8LowercaseDynLength(const s: string): string; var Buf: shortstring; SrcPos: PtrInt; DstPos: PtrInt; CharLen: integer; OldCode: LongWord; NewCode: LongWord; begin // first compute needed length SrcPos:=1; DstPos:=1; while SrcPos<=length(s) do begin case s[SrcPos] of #192..#240: begin OldCode:=UTF8CharacterToUnicode(@s[SrcPos],CharLen); NewCode:=UnicodeLowercase(OldCode); if NewCode=OldCode then begin inc(DstPos,CharLen); end else begin inc(DstPos,UnicodeToUTF8(NewCode,@Buf[1])); end; inc(SrcPos,CharLen); end; else inc(SrcPos); inc(DstPos); end; end; SetLength(Result,DstPos-1); if Result='' then exit; // create the new string SrcPos:=1; DstPos:=1; while SrcPos<=length(s) do begin case s[SrcPos] of #192..#240: begin OldCode:=UTF8CharacterToUnicode(@s[SrcPos],CharLen); NewCode:=UnicodeLowercase(OldCode); if NewCode=OldCode then begin System.Move(s[SrcPos],Result[DstPos],CharLen); inc(DstPos,CharLen); end else begin inc(DstPos,UnicodeToUTF8(NewCode,@Result[DstPos])); end; inc(SrcPos,CharLen); end; else Result[DstPos]:=s[SrcPos]; inc(SrcPos); inc(DstPos); end; end; end; function UTF8LowerCaseNew(const s: string): string; var i: PtrInt; CharLen: integer; OldCode: LongWord; NewCode: LongWord; NewCharLen: integer; begin Result:=s; i:=1; while i<=length(Result) do begin case Result[i] of { First ASCII chars } 'A'..'Z': begin Result[i]:=chr(ord(Result[i])+32); inc(i); end; { Now chars with multiple bytes } #192..#240: begin OldCode:=UTF8CharacterToUnicode(@Result[i],CharLen); NewCode:=UnicodeLowercase(OldCode); if NewCode=OldCode then begin inc(i,CharLen); end else begin UniqueString(Result); NewCharLen:=UnicodeToUTF8(NewCode,@Result[i]); if CharLen=NewCharLen then begin inc(i,NewCharLen); end else begin // string size changed => use slower function Result:=UTF8LowercaseDynLength(s); exit; end; end; end; else inc(i); end; end; end; {$endif NewLowerCase} function FindInvalidUTF8Character(p: PChar; Count: integer; StopOnNonASCII: Boolean): integer; // return -1 if ok var CharLen: Integer; begin if p<>nil then begin Result:=0; while ResultCount then begin dec(Result,CharLen); exit; // missing following bytes end; end; end; // ok Result:=-1; end; function ValidUTF8String(const s: String): String; var p, cur: PChar; l, lr: integer; NeedFree: Boolean; begin if FindInvalidUTF8Character(PChar(s), Length(s)) <> -1 then begin NeedFree := True; GetMem(p, Length(s) + 1); StrPCopy(p, s); UTF8FixBroken(p); end else begin p := PChar(s); NeedFree := False; end; Result := ''; cur := p; while cur^ <> #0 do begin l := UTF8CharacterLength(cur); if (l = 1) and (cur^ < #32) then Result := Result + '#' + IntToStr(Ord(cur^)) else begin lr := Length(Result); SetLength(Result, lr + l); Move(cur^, Result[lr + 1], l); end; inc(cur, l) end; if NeedFree then FreeMem(p); end; procedure AssignUTF8ListToAnsi(UTF8List, AnsiList: TStrings); var i: Integer; begin AnsiList.Clear; if UTF8List=nil then exit; for i:=0 to UTF8List.Count-1 do AnsiList.Add(UTF8ToSys(UTF8List[i])); end; function UTF16CharacterLength(p: PWideChar): integer; // returns length of UTF16 character in number of words // The endianess of the machine will be taken. begin if p<>nil then begin if (ord(p[0]) < $D800) or (ord(p[0]) > $DFFF) then Result:=1 else Result:=2; end else begin Result:=0; end; end; function UTF16Length(const s: widestring): integer; begin Result:=UTF16Length(PWideChar(s),length(s)); end; function UTF16Length(p: PWideChar; WordCount: integer): integer; var CharLen: LongInt; begin Result:=0; while (WordCount>0) do begin inc(Result); CharLen:=UTF16CharacterLength(p); inc(p,CharLen); dec(WordCount,CharLen); end; end; function UTF16CharacterToUnicode(p: PWideChar; out CharLen: integer): Cardinal; var w1: cardinal; w2: Cardinal; begin if p<>nil then begin w1:=ord(p[0]); if (w1 < $D800) or (w1 > $DFFF) then begin // is 1 word character Result:=w1; CharLen:=1; end else begin // could be 2 word character w2:=ord(p[1]); if (w2>=$DC00) then begin // is 2 word character Result:=(w1-$D800) shl 10 + (w2-$DC00) + $10000; CharLen:=2; end else begin // invalid character Result:=w1; CharLen:=1; end; end; end else begin Result:=0; CharLen:=0; end; end; function UnicodeToUTF16(u: cardinal): widestring; begin // u should be <= $10FFFF to fit into UTF-16 if u < $10000 then // Note: codepoints $D800 - $DFFF are reserved Result:=widechar(u) else Result:=widechar($D800+((u - $10000) shr 10))+widechar($DC00+((u - $10000) and $3ff)); end; {------------------------------------------------------------------------------ Name: ConvertUTF8ToUTF16 Params: Dest - Pointer to destination string DestWideCharCount - Wide char count allocated in destination string Src - Pointer to source string SrcCharCount - Char count allocated in source string Options - Conversion options, if none is set, both invalid and unfinished source chars are skipped toInvalidCharError - Stop on invalid source char and report error toInvalidCharToSymbol - Replace invalid source chars with '?' toUnfinishedCharError - Stop on unfinished source char and report error toUnfinishedCharToSymbol - Replace unfinished source char with '?' ActualWideCharCount - Actual wide char count converted from source string to destination string Returns: trNoError - The string was successfully converted without any error trNullSrc - Pointer to source string is nil trNullDest - Pointer to destination string is nil trDestExhausted - Destination buffer size is not big enough to hold converted string trInvalidChar - Invalid source char has occured trUnfinishedChar - Unfinished source char has occured Converts the specified UTF-8 encoded string to UTF-16 encoded (system endian) ------------------------------------------------------------------------------} function ConvertUTF8ToUTF16(Dest: PWideChar; DestWideCharCount: SizeUInt; Src: PChar; SrcCharCount: SizeUInt; Options: TConvertOptions; out ActualWideCharCount: SizeUInt): TConvertResult; var DestI, SrcI: SizeUInt; B1, B2, B3, B4: Byte; W: Word; C: Cardinal; function UnfinishedCharError: Boolean; begin if toUnfinishedCharToSymbol in Options then begin Dest[DestI] := WideChar('?'); Inc(DestI); Result := False; end else if toUnfinishedCharError in Options then begin ConvertUTF8ToUTF16 := trUnfinishedChar; Result := True; end else Result := False; end; function InvalidCharError(Count: SizeUInt): Boolean; inline; begin if not (toInvalidCharError in Options) then begin if toInvalidCharToSymbol in Options then begin Dest[DestI] := WideChar('?'); Inc(DestI); end; Dec(SrcI, Count); // skip trailing UTF-8 char bytes while (Count > 0) do begin if (Byte(Src[SrcI]) and %11000000) <> %10000000 then Break; Inc(SrcI); Dec(Count); end; Result := False; end else if toInvalidCharError in Options then begin ConvertUTF8ToUTF16 := trUnfinishedChar; Result := True; end; end; begin ActualWideCharCount := 0; if not Assigned(Src) then begin Result := trNullSrc; Exit; end; if not Assigned(Dest) then begin Result := trNullDest; Exit; end; SrcI := 0; DestI := 0; while (DestI < DestWideCharCount) and (SrcI < SrcCharCount) do begin B1 := Byte(Src[SrcI]); Inc(SrcI); if B1 < 128 then // single byte UTF-8 char begin Dest[DestI] := WideChar(B1); Inc(DestI); end else begin if SrcI >= SrcCharCount then if UnfinishedCharError then Exit(trInvalidChar) else Break; B2 := Byte(Src[SrcI]); Inc(SrcI); if (B1 and %11100000) = %11000000 then // double byte UTF-8 char begin if (B2 and %11000000) = %10000000 then begin Dest[DestI] := WideChar(((B1 and %00011111) shl 6) or (B2 and %00111111)); Inc(DestI); end else // invalid character, assume single byte UTF-8 char if InvalidCharError(1) then Exit(trInvalidChar); end else begin if SrcI >= SrcCharCount then if UnfinishedCharError then Exit(trInvalidChar) else Break; B3 := Byte(Src[SrcI]); Inc(SrcI); if (B1 and %11110000) = %11100000 then // triple byte UTF-8 char begin if ((B2 and %11000000) = %10000000) and ((B3 and %11000000) = %10000000) then begin W := ((B1 and %00011111) shl 12) or ((B2 and %00111111) shl 6) or (B3 and %00111111); if (W < $D800) or (W > $DFFF) then // to single wide char UTF-16 char begin Dest[DestI] := WideChar(W); Inc(DestI); end else // invalid UTF-16 character, assume double byte UTF-8 char if InvalidCharError(2) then Exit(trInvalidChar); end else // invalid character, assume double byte UTF-8 char if InvalidCharError(2) then Exit(trInvalidChar); end else begin if SrcI >= SrcCharCount then if UnfinishedCharError then Exit(trInvalidChar) else Break; B4 := Byte(Src[SrcI]); Inc(SrcI); if ((B1 and %11111000) = %11110000) and ((B2 and %11000000) = %10000000) and ((B3 and %11000000) = %10000000) and ((B4 and %11000000) = %10000000) then begin // 4 byte UTF-8 char C := ((B1 and %00011111) shl 18) or ((B2 and %00111111) shl 12) or ((B3 and %00111111) shl 6) or (B4 and %00111111); // to double wide char UTF-16 char Dest[DestI] := WideChar($D800 or ((C - $10000) shr 10)); Inc(DestI); if DestI >= DestWideCharCount then Break; Dest[DestI] := WideChar($DC00 or ((C - $10000) and %0000001111111111)); Inc(DestI); end else // invalid character, assume triple byte UTF-8 char if InvalidCharError(3) then Exit(trInvalidChar); end; end; end; end; if DestI >= DestWideCharCount then begin DestI := DestWideCharCount - 1; Result := trDestExhausted; end else Result := trNoError; Dest[DestI] := #0; ActualWideCharCount := DestI + 1; end; {------------------------------------------------------------------------------ Name: ConvertUTF16ToUTF8 Params: Dest - Pointer to destination string DestCharCount - Char count allocated in destination string Src - Pointer to source string SrcWideCharCount - Wide char count allocated in source string Options - Conversion options, if none is set, both invalid and unfinished source chars are skipped. See ConvertUTF8ToUTF16 for details. ActualCharCount - Actual char count converted from source string to destination string Returns: See ConvertUTF8ToUTF16 Converts the specified UTF-16 encoded string (system endian) to UTF-8 encoded ------------------------------------------------------------------------------} function ConvertUTF16ToUTF8(Dest: PChar; DestCharCount: SizeUInt; Src: PWideChar; SrcWideCharCount: SizeUInt; Options: TConvertOptions; out ActualCharCount: SizeUInt): TConvertResult; var DestI, SrcI: SizeUInt; W1, W2: Word; C: Cardinal; function UnfinishedCharError: Boolean; begin if toUnfinishedCharToSymbol in Options then begin Dest[DestI] := Char('?'); Inc(DestI); Result := False; end else if toUnfinishedCharError in Options then begin ConvertUTF16ToUTF8 := trUnfinishedChar; Result := True; end else Result := False; end; function InvalidCharError(Count: SizeUInt): Boolean; inline; begin if not (toInvalidCharError in Options) then begin if toInvalidCharToSymbol in Options then begin Dest[DestI] := Char('?'); Inc(DestI); end; Dec(SrcI, Count); // skip trailing UTF-16 wide char if (Word(Src[SrcI]) and $FC00) = $DC00 then Inc(SrcI); Result := False; end else if toInvalidCharError in Options then begin ConvertUTF16ToUTF8 := trUnfinishedChar; Result := True; end; end; begin ActualCharCount := 0; if not Assigned(Src) then begin Result := trNullSrc; Exit; end; if not Assigned(Dest) then begin Result := trNullDest; Exit; end; SrcI := 0; DestI := 0; while (DestI < DestCharCount) and (SrcI < SrcWideCharCount) do begin W1 := Word(Src[SrcI]); Inc(SrcI); if (W1 < $D800) or (W1 > $DFFF) then // single wide char UTF-16 char begin if W1 < $0080 then // to single byte UTF-8 char begin Dest[DestI] := Char(W1); Inc(DestI); end else if W1 < $0800 then // to double byte UTF-8 char begin Dest[DestI] := Char(%11000000 or ((W1 and %11111000000) shr 6)); Inc(DestI); if DestI >= DestCharCount then Break; Dest[DestI] := Char(%10000000 or (W1 and %111111)); Inc(DestI); end else begin // to triple byte UTF-8 char Dest[DestI] := Char(%11100000 or ((W1 and %1111000000000000) shr 12)); Inc(DestI); if DestI >= DestCharCount then Break; Dest[DestI] := Char(%10000000 or ((W1 and %111111000000) shr 6)); Inc(DestI); if DestI >= DestCharCount then Break; Dest[DestI] := Char(%10000000 or (W1 and %111111)); Inc(DestI); end; end else begin if SrcI >= SrcWideCharCount then if UnfinishedCharError then Exit(trInvalidChar) else Break; W2 := Word(Src[SrcI]); Inc(SrcI); if (W1 and $F800) = $D800 then // double wide char UTF-16 char begin if (W2 and $FC00) = $DC00 then begin C := (W1 - $D800) shl 10 + (W2 - $DC00) + $10000; // to 4 byte UTF-8 char Dest[DestI] := Char(%11110000 or (C shr 18)); Inc(DestI); if DestI >= DestCharCount then Break; Dest[DestI] := Char(%10000000 or ((C and $3F000) shr 12)); Inc(DestI); if DestI >= DestCharCount then Break; Dest[DestI] := Char(%10000000 or ((C and %111111000000) shr 6)); Inc(DestI); if DestI >= DestCharCount then Break; Dest[DestI] := Char(%10000000 or (C and %111111)); Inc(DestI); end else // invalid character, assume single wide char UTF-16 char if InvalidCharError(1) then Exit(trInvalidChar); end else // invalid character, assume single wide char UTF-16 char if InvalidCharError(1) then Exit(trInvalidChar); end; end; if DestI >= DestCharCount then begin DestI := DestCharCount - 1; Result := trDestExhausted; end else Result := trNoError; Dest[DestI] := #0; ActualCharCount := DestI + 1; end; {------------------------------------------------------------------------------ Name: UTF8ToUTF16 Params: S - Source UTF-8 string Returns: UTF-16 encoded string Converts the specified UTF-8 encoded string to UTF-16 encoded (system endian) Avoid copying the result string since on windows a widestring requires a full copy ------------------------------------------------------------------------------} function UTF8ToUTF16(const S: UTF8String): UTF16String; var L: SizeUInt; begin if S = '' then begin Result := ''; Exit; end; SetLength(Result, Length(S)); // wide chars of UTF-16 <= bytes of UTF-8 string if ConvertUTF8ToUTF16(PWideChar(Result), Length(Result) + 1, PChar(S), Length(S), [toInvalidCharToSymbol], L) = trNoError then SetLength(Result, L - 1) else Result := ''; end; {------------------------------------------------------------------------------ Name: UTF16ToUTF8 Params: S - Source UTF-16 string (system endian) Returns: UTF-8 encoded string Converts the specified UTF-16 encoded string (system endian) to UTF-8 encoded ------------------------------------------------------------------------------} function UTF16ToUTF8(const S: UTF16String): UTF8String; var L: SizeUInt; R: UTF8String; begin Result := ''; if S = '' then Exit; SetLength(R, Length(S) * 3); // bytes of UTF-8 <= 3 * wide chars of UTF-16 string // e.g. %11100000 10100000 10000000 (UTF-8) is $0800 (UTF-16) if ConvertUTF16ToUTF8(PChar(R), Length(R) + 1, PWideChar(S), Length(S), [toInvalidCharToSymbol], L) = trNoError then begin SetLength(R, L - 1); Result := R; end; end; function CreateFirstIdentifier(const Identifier: string): string; // example: Ident59 becomes Ident1 var p: Integer; begin p:=length(Identifier); while (p>=1) and (Identifier[p] in ['0'..'9']) do dec(p); Result:=copy(Identifier,1,p)+'1'; end; function CreateNextIdentifier(const Identifier: string): string; // example: Ident59 becomes Ident60 var p: Integer; begin p:=length(Identifier); while (p>=1) and (Identifier[p] in ['0'..'9']) do dec(p); Result:=copy(Identifier,1,p) +IntToStr(1+StrToIntDef(copy(Identifier,p+1,length(Identifier)-p),0)); end; procedure FreeLineInfoCache; var ANode: TAvgLvlTreeNode; Item: PLineInfoCacheItem; begin if LineInfoCache=nil then exit; ANode:=LineInfoCache.FindLowest; while ANode<>nil do begin Item:=PLineInfoCacheItem(ANode.Data); Dispose(Item); ANode:=LineInfoCache.FindSuccessor(ANode); end; LineInfoCache.Free; LineInfoCache:=nil; end; { TDebugLCLItems } constructor TDebugLCLItems.Create(const TheName: string); begin FName:=TheName; FItems:=TAvgLvlTree.Create(@CompareDebugLCLItemInfos); end; destructor TDebugLCLItems.Destroy; begin FItems.FreeAndClear; FreeAndNil(FItems); inherited Destroy; end; function TDebugLCLItems.FindInfo(p: Pointer; CreateIfNotExists: boolean ): TDebugLCLItemInfo; var ANode: TAvgLvlTreeNode; begin ANode:=FItems.FindKey(p,@CompareItemWithDebugLCLItemInfo); if ANode<>nil then Result:=TDebugLCLItemInfo(ANode.Data) else begin // does not yet exists if CreateIfNotExists then begin Result:=MarkCreated(p,'TDebugLCLItems.FindInfo'); end else begin Result:=nil; end; end; end; function TDebugLCLItems.IsDestroyed(p: Pointer): boolean; var Info: TDebugLCLItemInfo; begin Info:=FindInfo(p); if Info=nil then Result:=false else Result:=Info.IsDestroyed; end; function TDebugLCLItems.IsCreated(p: Pointer): boolean; var Info: TDebugLCLItemInfo; begin Info:=FindInfo(p); if Info=nil then Result:=false else Result:=not Info.IsDestroyed; end; procedure TDebugLCLItems.MarkDestroyed(p: Pointer); var Info: TDebugLCLItemInfo; procedure RaiseNotCreated; begin DebugLn('TDebugLCLItems.MarkDestroyed not created: p=',dbgs(p)); DumpStack; RaiseGDBException('TDebugLCLItems.MarkDestroyed'); end; procedure RaiseDoubleDestroyed; begin debugLn('TDebugLCLItems.MarkDestroyed Double destroyed:'); debugln(Info.AsString(true)); debugln('Now:'); DebugLn(GetStackTrace(true)); RaiseGDBException('RaiseDoubleDestroyed'); end; begin Info:=FindInfo(p); if Info=nil then RaiseNotCreated; if Info.IsDestroyed then RaiseDoubleDestroyed; Info.IsDestroyed:=true; GetStackTracePointers(Info.DestructionStack); //DebugLn(['TDebugLCLItems.MarkDestroyed ',dbgs(p)]); end; function TDebugLCLItems.GetInfo(p: Pointer; WithStackTraces: boolean): string; var Info: TDebugLCLItemInfo; begin Info:=FindInfo(p,false); if Info<>nil then Result:=Info.AsString(WithStackTraces) else Result:=''; end; function TDebugLCLItems.MarkCreated(p: Pointer; const InfoText: string): TDebugLCLItemInfo; var Info: TDebugLCLItemInfo; procedure RaiseDoubleCreated; begin debugLn('TDebugLCLItems.MarkCreated CREATED TWICE. Old:'); debugln(Info.AsString(true)); debugln(' New=',dbgs(p),' InfoText="',InfoText,'"'); DebugLn(GetStackTrace(true)); RaiseGDBException('RaiseDoubleCreated'); end; begin Info:=FindInfo(p); if Info=nil then begin Info:=TDebugLCLItemInfo.Create; Info.Item:=p; FItems.Add(Info); end else if not Info.IsDestroyed then begin RaiseDoubleCreated; end; Info.IsDestroyed:=false; Info.Info:=InfoText; GetStackTracePointers(Info.CreationStack); SetLength(Info.DestructionStack,0); //DebugLn(['TDebugLCLItems.MarkCreated ',Name,' ',dbgs(p),' ',FItems.Count]); //DebugLn(GetStackTrace(true)); Result:=Info; end; { TDebugLCLItemInfo } function TDebugLCLItemInfo.AsString(WithStackTraces: boolean): string; begin Result:='Item='+Dbgs(Item)+LineEnding +'Info="'+DbgStr(Info)+LineEnding; if WithStackTraces then Result:=Result+'Creation:'+LineEnding+StackTraceAsString(CreationStack,true); if IsDestroyed then begin Result:=Result+'Destroyed:'+LineEnding; if WithStackTraces then Result:=Result+StackTraceAsString(DestructionStack,true); end; end; destructor TDebugLCLItemInfo.Destroy; begin SetLength(CreationStack,0); SetLength(DestructionStack,0); inherited Destroy; end; initialization InitializeDebugOutput; InterfaceInitializationHandlers := TFPList.Create; InterfaceFinalizationHandlers := TFPList.Create; {$IFDEF DebugLCLComponents} DebugLCLComponents:=TDebugLCLItems.Create('LCLComponents'); {$ENDIF} {$ifdef NewLowerCase} InitUnicodeTables; {$endif NewLowerCase} finalization InterfaceInitializationHandlers.Free; InterfaceInitializationHandlers:=nil; InterfaceFinalizationHandlers.Free; InterfaceFinalizationHandlers:=nil; {$IFDEF DebugLCLComponents} DebugLCLComponents.Free; DebugLCLComponents:=nil; {$ENDIF} FreeLineInfoCache; FinalizeDebugOutput; end.