diff options
author | Matth?us G. Chajdas <dev@anteru.net> | 2019-11-10 13:56:53 +0100 |
---|---|---|
committer | Matth?us G. Chajdas <dev@anteru.net> | 2019-11-10 13:56:53 +0100 |
commit | 1dd3124a9770e11b6684e5dd1e6bc15a0aa3bc67 (patch) | |
tree | 87a171383266dd1f64196589af081bc2f8e497c3 /tests/examplefiles/example.pas | |
parent | f1c080e184dc1bbc36eaa7cd729ff3a499de568a (diff) | |
download | pygments-master.tar.gz |
Diffstat (limited to 'tests/examplefiles/example.pas')
-rw-r--r-- | tests/examplefiles/example.pas | 2708 |
1 files changed, 0 insertions, 2708 deletions
diff --git a/tests/examplefiles/example.pas b/tests/examplefiles/example.pas deleted file mode 100644 index ab11ee67..00000000 --- a/tests/examplefiles/example.pas +++ /dev/null @@ -1,2708 +0,0 @@ -// vim:ft=pascal - -unit YTools; - -{=============================================================================== - - cYcnus.YTools 1.0.3 Beta for Delphi 4+ - by licenser and Murphy - - ©2000-2003 by cYcnus - visit www.cYcnus.de - - licenser@cYcnus.de (Heinz N. Gies) - murphy@cYcnus.de (Kornelius Kalnbach) - - this unit is published under the terms of the GPL - -===============================================================================} - -interface - -uses - Windows, SysUtils, Classes, YTypes; - -const - BackSpace = #8; - Tab = #9; - LF = #10; //Line Feed - CR = #13; //Carriage Return - Space = #32; - EOLChars = [CR, LF]; -{$IFNDEF VER140} - sLineBreak = #13#10; - SwitchChars = ['/', '-']; -{$ENDIF} - EOL = sLineBreak; - MaxCard = High(Cardinal); - AllChars = [#0..#255]; - Alphabetical = ['A'..'Z', 'a'..'z']; - DecimalChars = ['0'..'9']; - AlphaNumerical = Alphabetical + DecimalChars; - StrangeChars = [#0..#31, #127, #129, #141..#144, #157, #158]; - - HexadecimalChars = DecimalChars + ['A'..'F', 'a'..'f']; - OctalChars = ['0'..'7']; - BinaryChars = ['0', '1']; - - QuoteChars = ['''', '"']; - WildCards = ['*', '?']; - FileNameEnemies = WildCards + ['\', '/', ':', '<', '>', '|']; - - HexChar: array[THex] of Char = ( - '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); - LowerHexChar: array[THex] of Char = ( - '0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f'); - BaseNChar: array[TBaseN] of Char = ( - '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','G','H', - 'I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'); - - cYcnusOverlayColor = $050001; - - faFindEveryFile = faReadOnly + faHidden + faSysFile + faArchive; - - platWin9x = [VER_PLATFORM_WIN32s, VER_PLATFORM_WIN32_WINDOWS]; - - -{ Debugging } -procedure ClearReport(const ReportName: string); -procedure Report(const ReportName, Text: string); -procedure ReportFmt(const ReportName, Fmt: string; const Args: array of const); - -{ Params } -procedure GetParams(Strings: TStrings); overload; -function GetParams(const Separator: string = ' '): string; overload; - -function ParamNum(const S: string): Integer; -function ParamPrefixNum(const Prefix: string): Integer; -function Param(const S: string): Boolean; -function ParamPrefix(const Prefix: string): Boolean; - -function Switch(const Switch: string; const PrefixChars: TCharSet = SwitchChars; - IgnoreCase: Boolean = True): Boolean; -function GetParam(const Prefix: string = ''; const Default: string = ''): string; - -{ Dirs & UserName} -function GetMyDir(FullPath: Boolean = False): string; -function WinDir: string; -function SysDir: string; -function UserName: string; - -{ Strings & Chars} -function FirstChar(const S: string): Char; -function LastChar(const S: string): Char; - -function CharPos(C: Char; const S: string; Offset: Integer = 1): Integer; overload; -function CharPos(C: TCharSet; const S: string; Offset: Integer = 1): Integer; overload; -function CharPosR(C: Char; const S: string; Offset: Integer = -1): Integer; -function PosEx(const SubStr, S: string; Offset: Integer = 1): Integer; -function PosExText(const SubStr, S: string; Offset: Integer = 1): Integer; -function PosExAnsiText(const SubStr, S: string; Offset: Integer = 1): Integer; - -function UntilChar(const S: string; Brake: Char): string; overload; -function UntilChar(const S: string; Brake: TCharSet): string; overload; -function UntilLastChar(const S: string; Brake: Char; - IgnoreNoBrake: Boolean = True): string; - -function FromChar(const S: string; Brake: Char): string; overload; -function FromChar(const S: string; Brake: TCharSet): string; overload; -function FromLastChar(const S: string; Brake: Char; - IgnoreNoBrake: Boolean = False): string; - -function BetweenChars(const S: string; Start, Finish: Char; - Inclusive: Boolean = False): string; - -function UntilStr(const S: string; Brake: string): string; -function FromStr(const S: string; Brake: string): string; - -function StringWrap(const S: string; Width: Integer; const LineEnd: string = EOL): string; - -{ Splitting & Combining } -function Split(const S, Separator: string; IgnoreMultiSep: Boolean = True; - MinCount: Integer = 0): TStrA; overload; -procedure Split(const S, Separator: string; Strings: TStrings; - IgnoreMultiSep: Boolean = True); overload; -function Split(const S: string; Separators: TCharSet; - IgnoreMultiSep: Boolean = True; MinCount: Integer = 0): TStrA; overload; - -procedure TileStr(const S: string; BrakeStart: Integer; BrakeEnd: Integer; - out Left, Right: string); - -function Join(Strings: TStrings; Separator: string = ' '): string; overload; -function Join(StrA: TStrA; Separator: string = ' '): string; overload; - -function MulStr(const S: string; Count: Integer): string; - -{ Strings ausrichten } -function AlignR(const S: string; Width: Integer; Filler: Char = ' '): string; -function MaxStr(const S: string; MaxLen: Integer): string; - -{ Stringing } -function TrimAll(const S: string): string; - -function ControlChar(C: Char): Boolean; -function FriendlyChar(C: Char): Char; - -function FriendlyStr(const S: string): string; overload; -function FriendlyStr(a: TByteA): string; overload; - -function Quote(const S: string; Quoter: Char = '"'): string; -function UnQuote(const S: string): string; -function DeQuote(const S: string): string; - -function StrNumerus(const Value: Integer; const Singular, Plural: string; - const Zero: string = '0'): string; - -function MakeStr(const Items: array of const; Separator: string = ''): string; -procedure ShowText(const Items: array of const; Separator: string = ''); - -{ Delete } -function DeleteChars(const S: string; C: Char): string; overload; -function DeleteChars(const S: string; C: TCharSet): string; overload; -function ExtractChars(const S: string; C: TCharSet): string; - -{ Find } -function CharCount(const S: string; C: Char): Integer; - -function CharIn(const S: string; C: Char): Boolean; overload; -function CharIn(const S: string; C: TCharSet): Boolean; overload; - -function StrAtPos(const S: string; Pos: Integer; const Str: string): Boolean; -function StrAtBegin(const S, Str: string): Boolean; -function StrIn(const S, SubStr: string): Boolean; overload; -function StrIn(A: TStrA; const S: string): Boolean; overload; -function StrIn(SL: TStrings; const S: string): Boolean; overload; -function StrIndex(A: TStrA; const S: string): Integer; overload; -function StrIndex(SL: TStrings; const S: string): Integer; overload; - -function TextAtPos(const S: string; Pos: Integer; const Text: string): Boolean; -function TextAtBegin(const S, Text: string): Boolean; -function TextIn(const S, Text: string): Boolean; overload; -function TextIn(A: TStrA; const Text: string): Boolean; overload; -function TextIn(SL: TStrings; const Text: string): Boolean; overload; -function TextIndex(A: TStrA; const Text: string): Integer; overload; -function TextIndex(SL: TStrings; const Text: string): Integer; overload; - -{ Replace } -function ReplaceChars(const S: string; Old, New: Char): string; overload; -function ReplaceChars(const S: string; Old: TCharSet; New: Char): string; overload; - -function Replace(const S, Old, New: string): string; - -{ TStrings } -function SLOfFile(const FileName: string): TStringList; -function ContainsEmptyLines(SL: TStrings): Boolean; -procedure DeleteEmptyLines(SL: TStrings); -procedure DeleteCommentLines(SL: TStrings; const CommentSign: string = '//'); -procedure WriteSL(Strings: TStrings; const Prefix: string = ''; - const Suffix: string = ''); - -function FindLine(SL: TStrings; const S: string): Integer; - -procedure QuickSortSL(SL: TStringList); - -{ TStrA } -function IncStrA(StrA: TStrA): Integer; - -{ TByteA } -function StrOfByteA(a: TByteA): string; -function ByteAOfStr(const S: string): TByteA; -function ByteAOfInt(i: Integer): TByteA; -function IntOfByteA(A: TByteA): Integer; -function ByteAOfHex(const Hex: string): TByteA; - -function SameByteA(const A, B: TByteA): Boolean; -function Reverse(a: TByteA): TByteA; -function SaveByteA(Data: TByteA; const FileName: string; Overwrite: Boolean = True): Boolean; -function LoadByteA(const FileName: string): TByteA; - -function Endian(i: Integer): Integer; - -{ Files } -function SizeOfFile(const FileName: string): Integer; -function FileEx(const FileName: string; AllowFolders: Boolean = False): Boolean; -function LWPSolve(const Dir: string): string; -function LWPSlash(const Dir: string): string; - -function ExtractDrive(const FileName: string): string; -function ExtractPath(const FileName: string): string; -function ExtractPrefix(const FileName: string): string; -function ExtractSuffix(const FileName: string): string; - -function IsValidFileName(const FileName: string): Boolean; -function MakeValidFileName(FileName: string; const Default: string = 'File'): string; - -{ Converting } -function IsValidInteger(const S: string): Boolean; -function IsValidCardinal(const S: string): Boolean; - -function StrOfBool(flag: Boolean; const TrueStr: string = 'True'; - const FalseStr: string = 'False'): string; -function StrOfInt(i: Integer): string; -function CardOfStr(const S: string): Cardinal; - -function HexOrd(Hex: Char): THex; -function ByteOfHex(Hex: THexByteStr): Byte; - -function DecOfHex(const Hex: string): string; -function HexOfByte(b: Byte): THexByteStr; -function HexOfCard(i: Cardinal): string; overload; -function HexOfCard(i: Cardinal; Digits: Integer): string; overload; - -function PascalHexArray(a: TByteA; Name: string): string; - -function HexOfByteA(a: TByteA; Blocks: Integer = 1; - const Splitter: string = ' '): string; -function BinOfByteA(a: TByteA; Blocks: Integer = 4; - const Splitter: string = ' '): string; - -function CardOfHex(Hex: string): Cardinal; -function IntOfBin(Bin: string): Cardinal; - -function BinOfIntFill(n: cardinal; MinCount: Integer = 8): string; -function BinOfInt(n: cardinal): string; - -function BaseNOfInt(I: Cardinal; B: TBaseN): string; -function IntOfBaseN(V: string; B: TBaseN): Cardinal; - -{ Ranges } -function KeepIn(i, Bottom, Top: Variant): Variant; -function InRange(Value, Bottom, Top: Variant): Boolean; -function InStrictRange(Value, Bottom, Top: Variant): Boolean; -function Min(const A, B: Integer): Integer; overload; -function Min(const A: TIntA): Integer; overload; -function Max(const A, B: Integer): Integer; overload; -function Max(const A: TIntA): Integer; overload; - -const - RangesSeparator = ','; - RangeInnerSeparator = '-'; - RangeInfinite = '*'; - RangeSpecialChars = [RangesSeparator, RangeInnerSeparator, RangeInfinite]; - -function RangesOfStr(const S: string): TRanges; -function InRanges(Ranges: TRanges; TestValue: Cardinal): Boolean; - -function Success(Res: Integer; ResultOnSuccess: Integer = ERROR_SUCCESS): Boolean; -function Failure(Res: Integer; ResultOnSuccess: Integer = ERROR_SUCCESS): Boolean; - -function ExpandString(const S: string): string; - -{ Files } -procedure DeleteFiles(const Mask: string; ScanSubDirs: Boolean = True; - Attributes: Integer = faFindEveryFile); -procedure FileNew(const FileName: string); -function DateTimeOfFileTime(const FileTime: TFileTime): TDateTime; - -{ FileNames } -function GetFileNew(FileName: string; NoFloppyDrives: Boolean = True): string; - -{ Finding Files } -function FindAll(Strings: TStrings; const Mask: string; - ScanSubDirs: Boolean = True; Attributes: Integer = faFindEveryFile; - FileReturn: TFileNameFunc = nil): Boolean; -function FindAllFirst(const Mask: string; ScanSubDirs: Boolean = True; - Attributes: Integer = faFindEveryFile): string; - -function FullOSInfo: string; -function Win32PlatformStr: string; -function Win9x: Boolean; -function WinNT: Boolean; -function Win2000: Boolean; -function WinXP: Boolean; - -var - MyDir: string = ''; - LastSuccessRes: Integer = 0; - -{ Backward compatibility } -{$IFNDEF VER130} -function SameText(const S1, S2: string): Boolean; -{$ENDIF} - -implementation -{$IFNDEF VER140} -uses FileCtrl; -{$ENDIF} - -{$IFNDEF VER130} -function SameText(const S1, S2: string): Boolean; -begin - Result := CompareText(S1, S2) = 0; -end; -{$ENDIF} - -procedure Report(const ReportName, Text: string); -var - F: TextFile; - FileName: string; -begin - FileName := MyDir + ReportName + '.rep'; - Assign(F, FileName); - try - if not FileExists(FileName) then - Rewrite(F) - else - Append(F); - WriteLn(F, Text); - finally - Close(F); - end; -end; - -procedure ClearReport(const ReportName: string); -var - FileName: string; -begin - FileName := MyDir + ReportName + '.rep'; - DeleteFile(FileName); -end; - -procedure ReportFmt(const ReportName, Fmt: string; const Args: array of const); -begin - Report(ReportName, Format(Fmt, Args)); -end; - -procedure GetParams(Strings: TStrings); -var - P: PChar; - Param: string; - - function GetParamStr(var P: PChar; var Param: string): Boolean; - var - Quoted: Boolean; - begin - Param := ''; - - repeat - while (P[0] <> #0) and (P[0] <= ' ') do - Inc(P); - - Quoted := False; - while P[0] <> #0 do begin - if P[0] = '"' then begin - Quoted := not Quoted; - Inc(P); - Continue; end; - if (P[0] <= ' ') and not Quoted then - Break; - Param := Param + P[0]; - Inc(P); - end; - until (Param <> '') or (P[0] = #0); - - Result := Param <> ''; - end; - -begin - Strings.Clear; - P := GetCommandLine; - GetParamStr(P, Param); - while GetParamStr(P, Param) do - Strings.Add(Param); -end; - -function GetParams(const Separator: string = ' '): string; -var - SL: TStringList; -begin - SL := TStringList.Create; - GetParams(SL); - Result := Join(SL, Separator); - SL.Free; -end; - -function Switch(const Switch: string; const PrefixChars: TCharSet = SwitchChars; - IgnoreCase: Boolean = True): Boolean; -//= SysUtils.FindCmdLineSwitch -var - i: Integer; - s: string; -begin - Result := True; - - for i := 1 to ParamCount do begin - s := ParamStr(i); - - if (s <> '') and (s[1] in PrefixChars) then begin - //i know that always s <> '', but this is saver - s := Copy(s, 2, MaxInt); - if (s = Switch) or (IgnoreCase and (0=AnsiCompareText(s, Switch))) then - Exit; - end; - end; - - Result := False; -end; - -function ParamNum(const S: string): Integer; -begin - for Result := 1 to ParamCount do - if 0=AnsiCompareText(ParamStr(Result), S) then - Exit; - - Result := 0; -end; - -function ParamPrefixNum(const Prefix: string): Integer; -var - Len: Integer; -begin - Len := Length(Prefix); - for Result := 1 to ParamCount do - if 0=AnsiCompareText(Copy(ParamStr(Result), 1, Len), Prefix) then - Exit; - - Result := 0; -end; - -function Param(const S: string): Boolean; -begin - Result := ParamNum(S) > 0; -end; - -function ParamPrefix(const Prefix: string): Boolean; -begin - Result := ParamPrefixNum(Prefix) > 0; -end; - -function GetParam(const Prefix: string = ''; const Default: string = ''): string; -var - i: Integer; -begin - Result := Default; - - if Prefix = '' then begin - Result := ParamStr(1); - Exit; end; - - i := ParamPrefixNum(Prefix); - if i > 0 then - Result := Copy(ParamStr(i), Length(Prefix) + 1, MaxInt); -end; - -function GetMyDir(FullPath: Boolean = False): string; -var - Buffer: array[0..260] of Char; -begin - Result := ''; - SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))); - if FullPath then - Result := GetFileNew(Result); - Result := ExtractPath(Result); -end; - -function WinDir: string; -var - Res: PChar; -begin - Result := '\'; - GetMem(Res, MAX_PATH); - GetWindowsDirectory(Res, MAX_PATH); - Result := Res + '\'; - FreeMem(Res, MAX_PATH); -end; - -function SysDir: string; -var - Res: PChar; -begin - Result := '\'; - GetMem(Res, MAX_PATH); - GetSystemDirectory(Res, MAX_PATH); - Result := Res + '\'; - FreeMem(Res, MAX_PATH); -end; - -function UserName: string; -var - Len: Cardinal; - Res: PChar; -begin - Result := ''; - GetMem(Res, MAX_PATH); - Len := MAX_PATH; - GetUserName(Res, Len); - Result := Res; - FreeMem(Res, MAX_PATH); -end; - -function FirstChar(const S: string): Char; -begin - if s = '' then - Result := #0 - else - Result := s[1]; -end; - -function LastChar(const S: string): Char; -begin - if s = '' then - Result := #0 - else - Result := s[Length(s)]; -end; - -function CharPos(C: Char; const S: string; Offset: Integer = 1): Integer; -var - MaxPosToSearch: Integer; -begin - Result := Offset; - MaxPosToSearch := Length(S); - - while Result <= MaxPosToSearch do begin - if S[Result] = C then - Exit; - Inc(Result); - end; - - Result := 0; -end; - -function CharPos(C: TCharSet; const S: string; Offset: Integer = 1): Integer; -var - MaxPosToSearch: Integer; -begin - Result := Offset; - MaxPosToSearch := Length(S); - - while Result <= MaxPosToSearch do begin - if S[Result] in C then - Exit; - Inc(Result); - end; - - Result := 0; -end; - -function CharPosR(C: Char; const S: string; Offset: Integer = -1): Integer; -begin - if Offset < 0 then - Result := Length(S) + 1 - Offset - else - Result := Offset; - if Result > Length(S) then - Result := Length(S); - - while Result > 0 do begin - if S[Result] = C then - Exit; - Dec(Result); - end; -end; - -function PosEx(const SubStr, S: string; Offset: Integer = 1): Integer; -var - MaxPosToSearch, LenSubStr, i: Integer; -begin - if SubStr = '' then begin - Result := 0; - Exit; end; - - if Offset < 1 then - Result := 1 - else - Result := Offset; - - LenSubStr := Length(SubStr); - MaxPosToSearch := Length(S) - LenSubStr + 1; - - while Result <= MaxPosToSearch do begin - if S[Result] = SubStr[1] then begin - i := 1; - - while (i < LenSubStr) - and (S[Result + i] = SubStr[i + 1]) do - Inc(i); - - if i = LenSubStr then - Exit; - end; - Inc(Result); - end; - - Result := 0; -end; - -function PosExText(const SubStr, S: string; Offset: Integer = 1): Integer; -var - MaxPosToSearch, LenSubStr, i: Integer; - - function SameChar(a, b: Char): Boolean; - begin - Result := UpCase(a) = UpCase(b) - end; - -begin - if SubStr = '' then begin - Result := 0; - Exit; end; - - if Offset < 1 then - Result := 1 - else - Result := Offset; - - LenSubStr := Length(SubStr); - MaxPosToSearch := Length(S) - LenSubStr + 1; - - while Result <= MaxPosToSearch do begin - if SameChar(S[Result], SubStr[1]) then begin - i := 1; - - while (i < LenSubStr) - and (SameChar(S[Result + i], SubStr[i + 1])) do - Inc(i); - - if i = LenSubStr then - Exit; - end; - Inc(Result); - end; - - Result := 0; -end; - -function PosExAnsiText(const SubStr, S: string; Offset: Integer = 1): Integer; -var - MaxPosToSearch, LenSubStr, i: Integer; - - function SameChar(a, b: Char): Boolean; - begin - Result := CharLower(PChar(a)) = CharLower(PChar(b)); - end; - -begin - if SubStr = '' then begin - Result := 0; - Exit; end; - - if Offset < 1 then - Result := 1 - else - Result := Offset; - - LenSubStr := Length(SubStr); - MaxPosToSearch := Length(S) - LenSubStr + 1; - - while Result <= MaxPosToSearch do begin - if SameChar(S[Result], SubStr[1]) then begin - i := 1; - - while (i < LenSubStr) - and (SameChar(S[Result + i], SubStr[i + 1])) do - Inc(i); - - if i = LenSubStr then - Exit; - end; - Inc(Result); - end; - - Result := 0; -end; - -function UntilChar(const S: string; Brake: Char): string; -var - p: Integer; -begin - p := CharPos(Brake, S); - - if p > 0 then - Result := Copy(S, 1, p - 1) - else - Result := S; -end; - -function UntilChar(const S: string; Brake: TCharSet): string; -var - p: Integer; -begin - Result := ''; - p := CharPos(Brake, S); - - if p > 0 then - Result := Copy(S, 1, p - 1) - else - Result := S; -end; - -function UntilLastChar(const S: string; Brake: Char; - IgnoreNoBrake: Boolean = True): string; -var - p: Integer; -begin - Result := ''; - p := CharPosR(Brake, S); - - if p > 0 then - Result := Copy(S, 1, p - 1) - else if IgnoreNoBrake then - Result := S; -end; - -function FromChar(const S: string; Brake: Char): string; -var - p: Integer; -begin - Result := ''; - p := CharPos(Brake, S); - - if p > 0 then - Result := Copy(S, p + 1, Length(S) - p); -end; - -function FromChar(const S: string; Brake: TCharSet): string; -var - p: Integer; -begin - Result := ''; - p := CharPos(Brake, S); - - if p > 0 then - Result := Copy(S, p + 1, Length(S) - p); -end; - -function FromLastChar(const S: string; Brake: Char; - IgnoreNoBrake: Boolean = False): string; -var - p: Integer; -begin - Result := ''; - p := CharPosR(Brake, S); - - if p > 0 then - Result := Copy(S, p + 1, Length(S) - p) - else if IgnoreNoBrake then - Result := S; -end; - -function BetweenChars(const S: string; Start, Finish: Char; - Inclusive: Boolean = False): string; -var - p, fin: Integer; -begin - Result := ''; - - p := CharPos(Start, S); - if p = 0 then - Exit; - - fin := CharPos(Finish, S, p + 1); - if fin = 0 then - Exit; - - if not Inclusive then begin - Inc(p); - Dec(fin); - end; - - Result := Copy(S, p, fin - p + 1); -end; - -function UntilStr(const S: string; Brake: string): string; -var - p: Integer; -begin - if Length(Brake) = 1 then begin - Result := UntilChar(S, Brake[1]); - Exit; end; - - p := PosEx(Brake, S); - - if p > 0 then - Result := Copy(S, 1, p - 1) - else - Result := S; -end; - -function FromStr(const S: string; Brake: string): string; -var - p: Integer; -begin - if Length(Brake) = 1 then begin - Result := FromChar(S, Brake[1]); - Exit; end; - - Result := ''; - p := PosEx(Brake, s); - - if p > 0 then begin - Inc(p, Length(Brake)); - Result := Copy(S, p, Length(S) - p + 1); - end; -end; - -function StringWrap(const S: string; Width: Integer; const LineEnd: string = EOL): string; -var - i: Integer; -begin - Result := ''; - if (S = '') or (Width < 1) then - Exit; - - i := 1; - while True do begin - Result := Result + Copy(S, i, Width); - Inc(i, Width); - if i <= Length(S) then - Result := Result + LineEnd - else - Exit; - end; -end; - -function Split(const S, Separator: string; IgnoreMultiSep: Boolean = True; - MinCount: Integer = 0): TStrA; -var - p, fin, SepLen: Integer; - - procedure Add(const S: string); - begin - if IgnoreMultiSep and (S = '') then - Exit; - SetLength(Result, Length(Result) + 1); - Result[High(Result)] := S; - end; - -begin - if S = '' then begin - if Length(Result) < MinCount then - SetLength(Result, MinCount); - Exit; end; - - Result := nil; - SepLen := Length(Separator); - - p := 1; - fin := PosEx(Separator, S); - while fin > 0 do begin - Add(Copy(S, p, fin - p)); - p := fin + SepLen; - fin := PosEx(Separator, S, p); - end; - Add(Copy(S, p, Length(S) - p + 1)); - - if Length(Result) < MinCount then - SetLength(Result, MinCount); -end; - -procedure Split(const S, Separator: string; Strings: TStrings; - IgnoreMultiSep: Boolean = True); -var - p, fin, SepLen: Integer; - - procedure Add(const S: string); - begin - if IgnoreMultiSep and (S = '') then - Exit; - Strings.Add(S); - end; - -begin - if S = '' then - Exit; - - Strings.BeginUpdate; - SepLen := Length(Separator); - p := 1; - fin := PosEx(Separator, S); - while fin > 0 do begin - Add(Copy(S, p, fin - p)); - p := fin + SepLen; - fin := PosEx(Separator, S, p); - end; - Add(Copy(S, p, Length(S) - p + 1)); - Strings.EndUpdate; -end; - -function Split(const S: string; Separators: TCharSet; - IgnoreMultiSep: Boolean = True; MinCount: Integer = 0): TStrA; -var - p, fin: Integer; - - procedure Add(const S: string); - begin - if IgnoreMultiSep and (S = '') then - Exit; - SetLength(Result, Length(Result) + 1); - Result[High(Result)] := S; - end; - -begin - if S = '' then begin - if Length(Result) < MinCount then - SetLength(Result, MinCount); - Exit; end; - - Result := nil; - - p := 1; - fin := CharPos(Separators, S); - while fin > 0 do begin - Add(Copy(S, p, fin - p)); - p := fin + 1; - fin := CharPos(Separators, S, p); - end; - Add(Copy(S, p, Length(S) - p + 1)); - - if Length(Result) < MinCount then - SetLength(Result, MinCount); -end; - -procedure TileStr(const S: string; BrakeStart: Integer; BrakeEnd: Integer; - out Left, Right: string); -begin - Left := Copy(S, 1, BrakeStart-1); - Right := Copy(S, BrakeEnd + 1, MaxInt); -end; - -function Join(Strings: TStrings; Separator: string = ' '): string; -var - i, imax: Integer; -begin - Result := ''; - imax := Strings.Count-1; - for i := 0 to imax do begin - Result := Result + Strings[i]; - if i < imax then - Result := Result + Separator; - end; -end; - -function Join(StrA: TStrA; Separator: string = ' '): string; overload; -var - i: Integer; -begin - Result := ''; - for i := 0 to High(StrA) do begin - Result := Result + StrA[i]; - if i < High(StrA) then - Result := Result + Separator; - end; -end; - -function MulStr(const S: string; Count: Integer): string; -var - P: PChar; - Len, i: Integer; -begin - Result := ''; - if Count = 0 then - Exit; - - Len := Length(S); - SetLength(Result, Len * Count); - - P := Pointer(Result); - for i := 1 to Count do begin - Move(Pointer(S)^, P^, Len); - Inc(P, Len); - end; -end; - -function AlignR(const S: string; Width: Integer; Filler: Char = ' '): string; -begin - Result := MulStr(Filler, Width - Length(S)) + S; -end; - -function MaxStr(const S: string; MaxLen: Integer): string; -var - Len: Integer; -begin - Len := Length(S); - if Len <= MaxLen then begin - Result := S; - Exit end; - - Result := Copy(S, 1, MaxLen - 3) + '...'; -end; - -function TrimAll(const S: string): string; -var - i: Integer; -begin - for i := 1 to Length(S) do - if S[i] > #32 then - Result := Result + S[i]; -end; - -function ControlChar(C: Char): Boolean; -begin - Result := C in StrangeChars; -end; - -function FriendlyChar(C: Char): Char; -begin - case C of - #0: Result := '.'; - #1..#31: Result := '?'; - #255: Result := '#'; - else - Result := C; - end; -end; - -function FriendlyStr(const S: string): string; -var - i: Integer; -begin - SetLength(Result, Length(S)); - for i := 1 to Length(S) do - Result[i] := FriendlyChar(S[i]); -end; - -function FriendlyStr(a: TByteA): string; -var - i: Integer; -begin - SetLength(Result, Length(a)); - for i := 0 to High(a) do - Result[i + 1] := FriendlyChar(Char(a[i])); -end; - -function Quote(const S: string; Quoter: Char = '"'): string; -begin - Result := S; - - if FirstChar(S) <> Quoter then - Result := Quoter + Result; - - if LastChar(S) <> Quoter then - Result := Result + Quoter; -end; - -function DeQuote(const S: string): string; -begin - Result := ''; - if Length(S) > 2 then - Result := Copy(S, 2, Length(S) - 2); -end; - -function UnQuote(const S: string): string; -var - Start, Len: Integer; -begin - Start := 1; - Len := Length(S); - - if (S <> '') and (S[1] in ([#0..#32] + QuoteChars)) then begin - if (LastChar(S) = S[1]) then - Dec(Len); - Inc(Start); - end; - - Result := Copy(S, Start, Len - Start + 1); -end; - -function StrNumerus(const Value: Integer; const Singular, Plural: string; - const Zero: string = '0'): string; -begin - if Abs(Value) = 1 then - Result := IntToStr(Value) + ' ' + Singular - else if Value = 0 then - Result := Zero + ' ' + Plural - else - Result := IntToStr(Value) + ' ' + Plural; -end; - -function MakeStr(const Items: array of const; Separator: string = ''): string; -const - BoolStrings: array[Boolean] of string = ('False', 'True'); - -var - i: Integer; - - function StrOfP(P: Pointer): string; - begin - if P = nil then - Result := '[nil]' - else - Result := '[' + IntToStr(Cardinal(P)) + ']'; - end; - - procedure Add(const S: string); - begin - Result := Result + s + Separator; - end; - -begin - Result := ''; - for i := 0 to High(Items) do - with Items[i] do - case VType of - vtString: Add(VString^); - vtInteger: Add(IntToStr(VInteger)); - vtBoolean: Add(BoolStrings[VBoolean]); - vtChar: Add(VChar); - vtPChar: Add(VPChar); - vtExtended: Add(FloatToStr(VExtended^)); - vtObject: if VObject is TComponent then - Add(TComponent(VObject).Name) - else - Add(VObject.ClassName); - vtClass: Add(VClass.ClassName); - vtAnsiString: Add(string(VAnsiString)); - vtCurrency: Add(CurrToStr(VCurrency^)); - vtInt64: Add(IntToStr(VInt64^)); - vtVariant: Add(string(VVariant^)); - - vtWideChar: Add(VWideChar); - vtPWideChar: Add(VPWideChar); - vtInterface: Add(StrOfP(VInterface)); - vtPointer: Add(StrOfP(VPointer)); - vtWideString: Add(WideString(VWideString)); - end; - if Result <> '' then - SetLength(result, Length(Result) - Length(Separator)); -end; - -procedure ShowText(const Items: array of const; Separator: string = ''); -var - Text: string; -begin - Text := MakeStr(Items, Separator); - - MessageBox(0, PChar(Text), 'Info', MB_OK and MB_APPLMODAL); -end; - -function DeleteChars(const S: string; C: Char): string; -var - i: Integer; -begin - Result := ''; - for i := 1 to Length(S) do - if S[i] <> C then - Result := Result + S[i]; -end; - -function DeleteChars(const S: string; C: TCharSet): string; -var - i: Integer; -begin - Result := ''; - for i := 1 to Length(S) do - if not (S[i] in C) then - Result := Result + S[i]; -end; - -function ExtractChars(const S: string; C: TCharSet): string; -var - i: Integer; -begin - Result := ''; - for i := 1 to Length(S) do - if S[i] in C then - Result := Result + S[i]; -end; - -function CharCount(const S: string; C: Char): Integer; -var - i: Integer; -begin - Result := 0; - for i := 1 to Length(S) do - if S[i] = C then - Inc(Result); -end; - -function StrAtPos(const S: string; Pos: Integer; const Str: string): Boolean; -begin - Result := (Str <> '') and (Str = Copy(S, Pos, Length(Str))); -end; - -function TextAtPos(const S: string; Pos: Integer; const Text: string): Boolean; -begin - Result := (Text <> '') and SameText(Text, Copy(S, Pos, Length(Text))); -end; - -function StrAtBegin(const S, Str: string): Boolean; -begin - Result := StrAtPos(S, 1, Str); -end; - -function TextAtBegin(const S, Text: string): Boolean; -begin - Result := TextAtPos(S, 1, Text); -end; - -function CharIn(const S: string; C: Char): Boolean; -var - i: Integer; -begin - Result := True; - for i := 1 to Length(S) do - if S[i] = C then Exit; - Result := False; -end; - -function CharIn(const S: string; C: TCharSet): Boolean; -var - i: Integer; -begin - Result := False; - for i := 1 to Length(S) do begin - Result := S[i] in C; - if Result then - Exit; - end; -end; - -function StrIn(const S, SubStr: string): Boolean; -begin - Result := PosEx(SubStr, S) > 0; -end; - -function StrIn(SL: TStrings; const S: string): Boolean; -var - i: Integer; -begin - Result := False; - for i := 0 to SL.Count-1 do begin - Result := (S = SL[i]); - if Result then - Exit; - end; -end; - -function StrIn(A: TStrA; const S: string): Boolean; -var - i: Integer; -begin - Result := False; - for i := Low(A) to High(A) do begin - Result := (S = A[i]); - if Result then - Exit; - end; -end; - -function TextIn(const S, Text: string): Boolean; -begin - Result := PosExText(Text, S) > 0; -end; - -function TextIn(SL: TStrings; const Text: string): Boolean; -var - i: Integer; -begin - Result := False; - for i := 0 to SL.Count-1 do begin - Result := SameText(Text, SL[i]); - if Result then - Exit; - end; -end; - -function TextIn(A: TStrA; const Text: string): Boolean; -var - i: Integer; -begin - Result := False; - for i := Low(A) to High(A) do begin - Result := SameText(Text, A[i]); - if Result then - Exit; - end; -end; - -function StrIndex(SL: TStrings; const S: string): Integer; -begin - for Result := 0 to SL.Count-1 do - if S = SL[Result] then - Exit; - Result := -1; -end; - -function StrIndex(A: TStrA; const S: string): Integer; -begin - for Result := Low(A) to High(A) do - if S = A[Result] then - Exit; - Result := -1; -end; - -function TextIndex(SL: TStrings; const Text: string): Integer; -begin - for Result := 0 to SL.Count-1 do - if SameText(Text, SL[Result]) then - Exit; - Result := -1; -end; - -function TextIndex(A: TStrA; const Text: string): Integer; -begin - for Result := Low(A) to High(A) do - if SameText(Text, A[Result]) then - Exit; - Result := -1; -end; - -function ReplaceChars(const S: string; Old, New: Char): string; -var - i: Integer; -begin - Result := S; - for i := 1 to Length(Result) do - if Result[i] = Old then - Result[i] := New; -end; - -function ReplaceChars(const S: string; Old: TCharSet; New: Char): string; -var - i: Integer; -begin - Result := S; - for i := 1 to Length(Result) do - if Result[i] in Old then - Result[i] := New; -end; - -function Replace(const S, Old, New: string): string; -var - oldp, ps: Integer; -begin - ps := 1; - Result := ''; - while True do begin - oldp := ps; - ps := PosEx(Old, S, oldp); - if ps = 0 then begin - Result := Result + Copy(S, oldp, Length(S) - oldp + 1); - Exit; end; - Result := Result + Copy(S, oldp, ps - oldp) + New; - Inc(ps, Length(Old)); - end; -end; - -function SLOfFile(const FileName: string): TStringList; -begin - Result := TStringList.Create; - if FileExists(FileName) then - Result.LoadFromFile(FileName); -end; - -function ContainsEmptyLines(SL: TStrings): Boolean; -begin - Result := StrIn(SL, ''); -end; - -procedure DeleteEmptyLines(SL: TStrings); -var - i: Integer; -begin - i := 0; - while i < SL.Count do begin - if SL[i] = '' then - SL.Delete(i) - else - Inc(i); - end; -end; - -procedure DeleteCommentLines(SL: TStrings; const CommentSign: string = '//'); -var - i: Integer; -begin - i := 0; - while i < SL.Count do begin - if (SL[i] = '') or (StrAtBegin(TrimLeft(SL[i]), CommentSign)) then - SL.Delete(i) - else - Inc(i); - end; -end; - -function FindLine(SL: TStrings; const S: string): Integer; -begin - for Result := 0 to SL.Count-1 do - if TextAtBegin(SL[Result], S) then - Exit; - Result := -1; -end; - -procedure QuickSortSL(SL: TStringList); - - procedure Sort(l, r: Integer); - var - i,j: Integer; - z,x: string; - begin - i := l; - j := r; - x := SL[(j + i) div 2]; - repeat - while SL[i] < x do Inc(i); - while SL[j] > x do Dec(j); - if i <= j then begin - z := SL[i]; - SL[i] := SL[j]; - SL[j] := z; - Inc(i); Dec(j); - end; - until i > j; - if j > l then Sort(l, j); - if i < r then Sort(i, r); - end; - -begin - if SL.Count > 0 then - Sort(0, SL.Count-1); -end; - -function IncStrA(StrA: TStrA): Integer; -begin - SetLength(StrA, Length(StrA) + 1); - Result := High(StrA); -end; - -function StrOfByteA(a: TByteA): string; -begin - Result := string(Copy(a, 0, Length(a))); -end; - -function ByteAOfStr(const S: string): TByteA; -begin - Result := TByteA(Copy(S, 1, Length(s))); -end; - -function ByteAOfInt(i: Integer): TByteA; -begin - SetLength(Result, SizeOf(Integer)); - Move(i, Pointer(Result)^, SizeOf(Integer)); -end; - -function IntOfByteA(A: TByteA): Integer; -begin - Result := 0; - Move(Pointer(A)^, Result, Min(Length(A), SizeOf(Integer))); -end; - -function ByteAOfHex(const Hex: string): TByteA; -var - i: Integer; - h: string; -begin - h := ExtractChars(Hex, HexadecimalChars); - SetLength(Result, Length(h) div 2); - for i := 0 to High(Result) do - Result[i] := ByteOfHex(Copy(h, (i shl 1) + 1, 2)); -end; - -function SizeOfFile(const FileName: string): Integer; -var - F: file; -begin - AssignFile(F, FileName); - {$I-}Reset(F, 1);{$I+} - if IOResult = 0 then begin - Result := FileSize(F); - CloseFile(F); - end else - Result := 0; -end; - -function FileEx(const FileName: string; AllowFolders: Boolean = False): Boolean; -var - FindData: TWin32FindData; -begin - if FileName = '' then begin - Result := False; - Exit; end; - - Result := (AllowFolders and DirectoryExists(FileName)) or - (FindFirstFile(PChar(FileName), FindData) <> INVALID_HANDLE_VALUE); - Result := Result and not CharIn(FileName, WildCards); - Result := Result and (AllowFolders - or ((FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0)); -end; - -function LWPSolve(const Dir: string): string; -begin - if (Dir <> '') and (Dir[Length(Dir)] = '\') then begin - Result := Copy(Dir, 1, Length(Dir) - 1); - end else - Result := Dir; -end; - -function LWPSlash(const Dir: string): string; -begin - if (Dir <> '') and (Dir[Length(Dir)] = '\') then begin - Result := Copy(Dir, 1, Length(Dir)); - end else - Result := Dir + '\'; -end; - -function ExtractDrive(const FileName: string): string; -begin - Result := ''; - if (Length(FileName) >= 2) and (FileName[2] = ':') then - Result := UpperCase(FileName[1] + ':\'); -end; - -function ExtractPath(const FileName: string): string; -var - p: Integer; -begin - p := CharPosR('\', FileName); - if P > 0 then - Result := Copy(FileName, 1, p) - else - Result := FileName; -end; - -function ExtractPrefix(const FileName: string): string; -begin - Result := UntilLastChar(ExtractFileName(FileName), '.'); -end; - -function ExtractSuffix(const FileName: string): string; -begin - Result := FromLastChar(ExtractFileName(FileName), '.'); -end; - -function SameByteA(const A, B: TByteA): Boolean; -begin - Result := (A = B) or ((Length(A) = Length(B)) and CompareMem(A, B, Length(A))); -end; - -function Reverse(A: TByteA): TByteA; -var - i: Integer; -begin - SetLength(Result, Length(A)); - - for i := 0 to High(A) do - Result[High(Result) - i] := A[i]; -end; - -function Endian(i: Integer): Integer; -type - EndianArray = packed array[0..3] of Byte; -var - a, b: EndianArray; -begin - a := EndianArray(i); - b[0] := a[3]; - b[1] := a[2]; - b[2] := a[1]; - b[3] := a[0]; - Result := Integer(b); -end; - -function SaveByteA(Data: TByteA; const FileName: string; - Overwrite: Boolean = True): Boolean; -var - F: file; -begin - if FileExists(FileName) and not Overwrite then begin - Result := False; - Exit end; - - AssignFile(F, FileName); - {$I-}Rewrite(F, 1);{$I+} - if IOResult = 0 then begin - if Length(Data) > 0 then - BlockWrite(F, Data[0], Length(Data)); - CloseFile(F); - Result := True; - end else - Result := False; -end; - -function LoadByteA(const FileName: string): TByteA; -var - F: file; -begin - AssignFile(F, FileName); - {$I-}Reset(F, 1);{$I+} - if IOResult = 0 then begin - SetLength(Result, FileSize(F)); - if Length(Result) > 0 then - BlockRead(F, Result[0], FileSize(F)); - CloseFile(F); - end else - SetLength(Result, 0); -end; - -function IsValidFileName(const FileName: string): Boolean; -begin - Result := (FileName <> '') and not CharIn(FileName, FileNameEnemies) - and CharIn(Trim(FileName), AllChars - ['.']); -end; - -function MakeValidFileName(FileName: string; const Default: string = 'File'): string; -begin - if FileName = '' then - FileName := Default; - - if CharIn(FileName, FileNameEnemies) then - Result := ReplaceChars(FileName, FileNameEnemies, '_') - else if not CharIn(Trim(FileName), AllChars - ['.']) then - Result := Default - else - Result := FileName; -end; - -function IsValidInteger(const S: string): Boolean; -{const - LowInt = '2147483648'; - HighInt = '2147483647'; -var - len, RealLen, i, o: Integer; - c: Char; -begin - Result := False; - if S = '' then - Exit; - - len := Length(S); - o := 1; - - if S[1] = '-' then begin - if len = 1 then - Exit; - Inc(o); - while (o <= len) and (S[o] = '0') do - Inc(o); - if o > len then - Exit; - if o < len then begin - RealLen := len - o + 1; - if RealLen > Length(LowInt) then - Exit - else if RealLen = Length(LowInt) then begin - for i := 1 to Length(LowInt) do begin - c := S[i + o - 1]; - if (c < '0') or (c > LowInt[i]) then - Exit; - if c in ['0'..Char((Byte(LowInt[i])-1))] then - Break; - end; - Inc(o, i); - end; - end; - end else begin - while (o <= len) and (S[o] = '0') do - Inc(o); - if o <= len then begin - RealLen := len - o + 1; - if RealLen > Length(HighInt) then - Exit - else if RealLen = Length(HighInt) then begin - for i := 1 to Length(HighInt) do begin - c := S[i + o - 1]; - if (c < '0') or (c > HighInt[i]) then - Exit; - if c in ['0'..Char((Byte(HighInt[i])-1))] then - Break; - end; - Inc(o, i); - end; - end; - end; - - for i := o to len do - if not (S[i] in ['0'..'9']) then - Exit; - - Result := True; } -var - i: Int64; -begin - i := StrToInt64Def(S, High(Int64)); - Result := (i >= Low(Integer)) and (i <= High(Integer)); -end; - -function IsValidCardinal(const S: string): Boolean; -{const - HighCard = '4294967295'; -var - len, RealLen, i, o: Integer; -begin - Result := False; - if S = '' then - Exit; - - len := Length(S); - o := 1; - - while (o <= len) and (S[o] = '0') do - Inc(o); - if o <= len then begin - RealLen := len - o + 1; - if RealLen > Length(HighCard) then - Exit - else if RealLen = Length(HighCard) then begin - for i := 1 to Length(HighCard) do begin - if S[i + o - 1] > HighCard[i] then - Exit; - if S[i + o - 1] in ['0'..Char((Byte(HighCard[i])-1))] then - Break; - end; - Inc(o, i); - end; - end; - - for i := o to len do - if not (S[i] in ['0'..'9']) then - Exit; - - Result := True; } -var - i: Int64; -begin - i := StrToInt64Def(S, -1); - Result := (i >= 0) and (i <= High(Cardinal)); -end; - -function StrOfBool(flag: Boolean; const TrueStr: string = 'True'; - const FalseStr: string = 'False'): string; -begin - if Flag then - Result := TrueStr - else - Result := FalseStr; -end; - -function StrOfInt(i: Integer): string; -begin -{ if i = 0 then begin - Result := '0'; - Exit end; - - while i > 0 do begin - Result := Char(Byte('0') + (i mod 10)) + Result; - i := i div 10; - end;} - Result := IntToStr(i); -end; - -function CardOfStr(const S: string): Cardinal; -var - Res: Int64; -begin - Res := StrToInt64Def(S, -1); - if Res > High(Cardinal) then - Res := High(Cardinal) - else if Res < 0 then - Res := 0; - Result := Cardinal(Res); -end; - -function HexOrd(Hex: Char): THex; -begin - case Hex of - '0'..'9': - Result := Byte(Hex) - 48; - 'A'..'F': - Result := Byte(Hex) - 55; - 'a'..'f': - Result := Byte(Hex) - 87; - else - Result := 0; - end; -end; - -function ByteOfHex(Hex: THexByteStr): Byte; -begin - Result := (HexOrd(Hex[1]) shl 4) + HexOrd(Hex[2]); -end; - -function DecOfHex(const Hex: string): string; -begin - Result := IntToStr(CardOfHex(Hex)); -end; - -function HexOfByte(b: Byte): THexByteStr; -begin - Result := HexChar[(b and $F0) shr 4] - + HexChar[ b and $0F ]; -end; - -{function HexOfCard2(c: Cardinal): string; -var - Data: array[0..(1 shl 4) - 1] of Char; - i: Integer; -begin - for i := 0 to (1 shl 4) - 1 do - if i < 10 then - Data[i] := Char(Ord('0') + i) - else - Data[i] := Char(Ord('A') + i - 10); - - Result := Data[(c and (((1 shl (1 shl 2)) - 1) shl (7 shl 2))) shr (7 shl 2)] - + Data[(c and (((1 shl (1 shl 2)) - 1) shl (6 shl 2))) shr (6 shl 2)] - + Data[(c and (((1 shl (1 shl 2)) - 1) shl (5 shl 2))) shr (5 shl 2)] - + Data[(c and (((1 shl (1 shl 2)) - 1) shl (4 shl 2))) shr (4 shl 2)] - + Data[(c and (((1 shl (1 shl 2)) - 1) shl (3 shl 2))) shr (3 shl 2)] - + Data[(c and (((1 shl (1 shl 2)) - 1) shl (2 shl 2))) shr (2 shl 2)] - + Data[(c and (((1 shl (1 shl 2)) - 1) shl (1 shl 2))) shr (1 shl 2)] - + Data[(c and (((1 shl (1 shl 2)) - 1) shl (0 shl 2))) shr (0 shl 2)]; -end; } - -function HexOfCard(i: Cardinal): string; -var - a: Cardinal; -begin - Result := ''; - while i > 0 do begin - a := i and $F; - Result := HexChar[a] + Result; - i := i shr 4; - end; -end; - -function HexOfCard(i: Cardinal; Digits: Integer): string; -var - a: Cardinal; -begin - Result := ''; - while i > 0 do begin - a := i and $F; - Result := HexChar[a] + Result; - i := i shr 4; - end; - Result := MulStr('0', Digits - Length(Result)) + Result; -end; - -function PascalHexArray(a: TByteA; Name: string): string; -var - i, len: Integer; -begin - Result := 'const' + EOL + - ' ' + Name + ': array[0..' + IntToStr(High(a)) + '] of Byte = ('; - - len := Length(a); - for i := 0 to len-1 do begin - if (i mod 19) = 0 then - Result := Result + EOL + ' ' + ' '; - Result := Result + '$' + HexOfByte(a[i]); - if i < len-1 then - Result := Result + ','; - end; - Result := Result + EOL + ' );'; -end; - -function HexOfByteA(a: TByteA; Blocks: Integer = 1; - const Splitter: string = ' '): string; -var - i: Integer; -begin - Result := ''; - - if Blocks > 0 then - for i := 0 to High(a) do begin - Result := Result + HexOfByte(a[i]); - if i < High(a) then - if ((i+1) mod Blocks) = 0 then - Result := Result + Splitter; - end - else - for i := 0 to High(a) do - Result := Result + HexOfByte(a[i]); -end; - -function BinOfByteA(a: TByteA; Blocks: Integer = 4; - const Splitter: string = ' '): string; -var - i, max: Integer; - Bit: Boolean; -begin - Result := ''; - - if Blocks > 0 then begin - max := 8 * (High(a)) + 7; - for i := 0 to max do begin - Bit := 7-(i mod 8) in TBitSet(a[i div 8]); - Result := Result + Char(Byte('0') + Byte(Bit)); - if i < max then - if ((i+1) mod Blocks) = 0 then - Result := Result + Splitter; - end; - end else - for i := 0 to High(a) do - Result := Result + Char(Byte('0') + a[i] shr (i and 8)); -end; - -function CardOfHex(Hex: string): Cardinal; -var - i: Integer; -begin - Result := 0; - Hex := Copy(ExtractChars(Hex, HexadecimalChars), 1, 8); - - for i := 1 to Length(Hex) do - if Hex[i] <> '0' then - Inc(Result, HexOrd(Hex[i]) shl ((Length(Hex) - i) shl 2)); -end; - -function IntOfBin(Bin: string): Cardinal; -var - i: Integer; -begin - Result := 0; - Bin := Copy(ExtractChars(Bin, BinaryChars), 1, 32); - - for i := Length(Bin) downto 1 do - if Bin[i] = '1' then - Inc(Result, 1 shl (Length(Bin) - i)); -end; - -function BinOfInt(n: Cardinal): string; -var - a: Integer; -begin - if n = 0 then begin - Result := '0'; - exit; end; - - Result := ''; - while n > 0 do begin - a := n and 1; - Result := Char(a + Byte('0')) + Result; - n := n shr 1; - end; -end; - -function BinOfIntFill(n: Cardinal; MinCount: Integer = 8): string; -var - a: Integer; -begin - if n = 0 then begin - Result := MulStr('0', MinCount); - Exit; end; - - Result := ''; - while n > 0 do begin - a := n and 1; - Result := Char(a + Byte('0')) + Result; - n := n shr 1; - end; - Result := MulStr('0', MinCount - Length(Result)) + Result; -end; - -function BaseNOfInt(I: Cardinal; B: TBaseN): string; -var - a: Integer; -begin - if (B < 2) or (i = 0) then begin - Result := '0'; - Exit; end; - - Result := ''; - while i > 0 do begin - a := i mod B; - Result := BaseNChar[a] + Result; - i := i div B; - end; -end; - -function IntOfBaseN(V: string; B: TBaseN): Cardinal; -var - i: Integer; - F: Cardinal; - c: Byte; -begin - Result := 0; - V := TrimAll(V); - F := 1; - for i := Length(V) downto 1 do begin - c := Byte(UpCase(V[i])); - case Char(c) of - '0'..'9': c := c - 48; - 'A'..'Z': c := c - 55; - end; - if c < B then - Result := Result + Byte(c) * F; - F := F * B; - end; -end; - -function KeepIn(i, Bottom, Top: Variant): Variant; -begin - Result := i; - if Result > Top then - Result := Top - else if Result < Bottom then - Result := Bottom; -end; - -function InRange(Value, Bottom, Top: Variant): Boolean; -begin - Result := (Value >= Bottom) and (Value <= Top); -end; - -function InStrictRange(Value, Bottom, Top: Variant): Boolean; -begin - Result := (Value > Bottom) and (Value < Top); -end; - -function Min(const A, B: Integer): Integer; -begin - if A < B then - Result := A - else - Result := B; -end; - -function Min(const A: TIntA): Integer; -var - i: Integer; -begin - Result := 0; - if Length(A) = 0 then - Exit; - - Result := A[0]; - for i := 1 to High(A) do - if A[i] < Result then - Result := A[i]; -end; - -function Max(const A, B: Integer): Integer; -begin - if A > B then - Result := A - else - Result := B; -end; - -function Max(const A: TIntA): Integer; -var - i: Integer; -begin - Result := 0; - if Length(A) = 0 then - Exit; - - Result := A[0]; - for i := 1 to High(A) do - if A[i] > Result then - Result := A[i]; -end; - -function RangesOfStr(const S: string): TRanges; -var - SL: TStringList; - r, b, t: string; - i, p: Integer; - - function TryStrToCard(const S: string; out Value: Cardinal): Boolean; - var - E: Integer; - begin - Val(S, Value, E); - Result := E = 0; - end; - -begin - Result := nil; - SL := TStringList.Create; - try - Split(S, RangesSeparator, SL); - SetLength(Result, SL.Count); - for i := 0 to SL.Count-1 do begin - r := SL[i]; - with Result[i] do begin - p := CharPos(RangeInnerSeparator, r); - Simple := p = 0; // no '-' found - if Simple then begin - if r = RangeInfinite then begin // * --> *-* - Simple := False; - Bottom := Low(Bottom); - Top := High(Top); - end else if not TryStrToCard(r, Value) then - Break; - - end else begin - TileStr(r, p, p, b, t); - - if b = RangeInfinite then - Bottom := Low(Bottom) - else if not TryStrToCard(b, Bottom) then - Break; - - if t = RangeInfinite then - Top := High(Top) - else if not TryStrToCard(t, Top) then - Break; - if Bottom > Top then begin - p := Bottom; Bottom := Top; Top := p; - end; - end; - end; - end; - - if i <> SL.Count then - Result := nil; - - finally - SL.Free; - end; -end; - -function InRanges(Ranges: TRanges; TestValue: Cardinal): Boolean; -var - i: Integer; -begin - Result := True; - - for i := 0 to High(Ranges) do - with Ranges[i] do - if Simple then begin - if TestValue = Value then - Exit; - end else begin - if InRange(TestValue, Bottom, Top) then - Exit; - end; - - Result := False; -end; - -procedure WriteSL(Strings: TStrings; const Prefix: string = ''; - const Suffix: string = ''); -var - i: Integer; -begin - for i := 0 to Strings.Count-1 do - WriteLn(Prefix + Strings[i] + Suffix); -end; - -function Success(Res: Integer; ResultOnSuccess: Integer = ERROR_SUCCESS): Boolean; -begin - Result := (Res = ResultOnSuccess); - LastSuccessRes := Res; -end; - -function Failure(Res: Integer; ResultOnSuccess: Integer = ERROR_SUCCESS): Boolean; -begin - Result := not Success(Res, ResultOnSuccess); -end; - -function ExpandString(const S: string): string; -var - Len: Integer; - P, Res: PChar; -begin - Result := ''; - P := PChar(S); - Len := ExpandEnvironmentStrings(P, nil, 0); - if Len = 0 then - Exit; - - GetMem(Res, Len); - ExpandEnvironmentStrings(P, Res, Len); - - Result := Res; - FreeMem(Res, Len); -end; - -function FindAll(Strings: TStrings; const Mask: string; - ScanSubDirs: Boolean = True; Attributes: Integer = faFindEveryFile; - FileReturn: TFileNameFunc = nil): Boolean; -var - Path, FileName: string; - - procedure ScanDir(const Path, FileName: string); - var - PSR: TSearchRec; - Res: Integer; - - procedure Add(const S: string); - begin - if S <> '' then - Strings.Add(S); - end; - - begin - Res := FindFirst(Path + FileName, Attributes, PSR); - while Success(Res, 0) do begin - if Assigned(FileReturn) then - Add(FileReturn(Path + PSR.Name)) - else - Add(Path + PSR.Name); - Res := FindNext(PSR); - end; - FindClose(PSR); - if not ScanSubDirs then - Exit; - - Res := FindFirst(Path + '*', faDirectory, PSR); - while Success(Res, 0) do begin - if (PSR.Attr and faDirectory > 0) - and (PSR.Name <> '.') and (PSR.Name <> '..') then - ScanDir(Path + PSR.Name + '\', FileName); - Res := FindNext(PSR); - end; - FindClose(PSR); - end; - -begin - Strings.Clear; - Path := ExtractPath(Mask); - FileName := ExtractFileName(Mask); - ScanDir(Path, FileName); - Result := Strings.Count > 0; -end; - -function FindAllFirst(const Mask: string; ScanSubDirs: Boolean = True; - Attributes: Integer = faFindEveryFile): string; -var - Path, FileName: string; - - function ScanDir(const Path, FileName: string): Boolean; - var - PSR: TSearchRec; - Res: Integer; - begin - Result := False; - if Success(FindFirst(Path + FileName, Attributes, PSR), 0) then begin - FindAllFirst := Path + PSR.Name; - Result := True; - FindClose(PSR); - Exit; end; - if not ScanSubDirs then - Exit; - - Res := FindFirst(Path + '*', faDirectory, PSR); - while not Result and Success(Res, 0) do begin - if (PSR.Attr and faDirectory > 0) - and (PSR.Name <> '.') and (PSR.Name <> '..') then - Result := ScanDir(Path + PSR.Name + '\', FileName); - Res := FindNext(PSR); - end; - FindClose(PSR); - end; -begin - Result := ''; - Path := ExtractPath(Mask); - FileName := ExtractFileName(Mask); - ScanDir(Path, FileName); -end; - -procedure DeleteFiles(const Mask: string; ScanSubDirs: Boolean = True; - Attributes: Integer = faFindEveryFile); -var - Path, FileName: string; - - procedure ScanDir(const Path, FileName: string); - var - PSR: TSearchRec; - Res: Integer; - - procedure TryDeleteFile(const FileName: string); - begin - try - DeleteFile(Path + PSR.Name); - except - end; - end; - - begin - Res := FindFirst(Path + FileName, Attributes, PSR); - while Success(Res, 0) do begin - TryDeleteFile(Path + PSR.Name); - Res := FindNext(PSR); - end; - FindClose(PSR); - if not ScanSubDirs then - Exit; - - Res := FindFirst(Path + '*', faDirectory, PSR); - while Success(Res, 0) do begin - if (PSR.Attr and faDirectory > 0) - and (PSR.Name <> '.') and (PSR.Name <> '..') then begin - ScanDir(Path + PSR.Name + '\', FileName); - TryDeleteFile(Path + PSR.Name); - end; - Res := FindNext(PSR); - end; - FindClose(PSR); - end; -begin - Path := ExtractPath(Mask); - FileName := ExtractFileName(Mask); - ScanDir(Path, FileName); -end; - -function GetFileNew(FileName: string; NoFloppyDrives: Boolean = True): string; -var - Drive: string; - pf, pd, Len: Integer; - PSR: TSearchRec; -begin - Result := ''; - FileName := Trim(FileName); - if Length(FileName) < 2 then - Exit; - - Drive := ExtractDrive(FileName); - if not DirectoryExists(Drive) then - Exit; - - if NoFloppyDrives and (Drive[1] in ['A', 'B']) then - Exit; - - Len := Length(FileName); - Result := Drive; - pf := Length(Drive) + 1; - while pf <= Len do begin - if FileName[pf] = '\' then begin - Result := Result + '\'; - Inc(pf); - Continue; end; - - pd := CharPos('\', FileName, pf); - if pd = 0 then begin - if 0=FindFirst(Result + Copy(FileName, pf, MaxInt), faFindEveryFile, PSR) then begin - Result := Result + PSR.Name; - Break; end else begin - FindClose(PSR); - if 0=FindFirst(Result + Copy(FileName, pf, MaxInt), faDirectory, PSR) then - Result := Result + PSR.Name + '\' - else - Result := ''; - FindClose(PSR); - if Result = '' then - Break; - end; - end; - - if 0=FindFirst(Result + Copy(FileName, pf, pd - pf), faDirectory, PSR) then - Result := Result + PSR.Name + '\' - else - Result := ''; - FindClose(PSR); - if Result = '' then - Break; - - pf := pd + 1; - end; - - if (Result <> '') and not FileEx(Result, True) then - Result := ''; -end; - -function DateTimeOfFileTime(const FileTime: TFileTime): TDateTime; -var - LocalFileTime: TFileTime; - Res: Integer; -begin - Result := 0; - - FileTimeToLocalFileTime(FileTime, LocalFileTime); - if not FileTimeToDosDateTime(LocalFileTime, LongRec(Res).Hi, - LongRec(Res).Lo) then - Res := -1; - - if (Res = -1) or (Res = 0) then - Exit; - try - Result := FileDateToDateTime(Res); - except - end; -end; - -procedure FileNew(const FileName: string); -var - Handle: Integer; -begin - Handle := FileCreate(FileName); - FileClose(Handle); -end; - -function Win32PlatformStr: string; -const - PlatformStrings: array[VER_PLATFORM_WIN32s..VER_PLATFORM_WIN32_NT] of string = - ('VER_PLATFORM_WIN32s', 'VER_PLATFORM_WIN32_WINDOWS', 'VER_PLATFORM_WIN32_NT'); -begin - Result := PlatformStrings[Win32Platform]; -end; - -function FullOSInfo: string; -begin - Result := Format( - 'Platform: %s' + EOL + - 'Version: %d.%d Build %d' + EOL + - 'CSD: %s', - [ - Win32PlatformStr, - Win32MajorVersion, Win32MinorVersion, Win32BuildNumber, - Win32CSDVersion - ] - ); -end; - -function Win9x: Boolean; -begin - Result := Win32Platform = VER_PLATFORM_WIN32_WINDOWS; -end; - -function WinNT: Boolean; -begin - Result := Win32Platform = VER_PLATFORM_WIN32_NT; -end; - -function Win2000: Boolean; -begin - Result := (Win32Platform = VER_PLATFORM_WIN32_NT) - and (Win32MajorVersion = 4); -end; - -function WinXP: Boolean; -begin - Result := Win32MajorVersion >= 5; -end; - -initialization - MyDir := GetMyDir; - -end. - -unit FifoStream; - -interface - -uses Classes, windows, Dialogs; - -const - DefaultChunksize = 32768; // 32kb per chunk as default. - -type - PMemChunk = ^TMemChunk; - TMemChunk = record - Filled: Longword; - Read: Longword; - Data: pointer; - end; - - TFifo = class - private - FBuffers: TList; - FChunksize: Longword; - FCritSect: TRTLCriticalSection; - FIsWinNT: boolean; - FBytesInFifo: LongWord; - protected - function GetBytesInFifo: LongWord; - public - constructor Create; - destructor Destroy; override; - procedure Write(Data: pointer; Size: LongWord); - procedure Read(Buff: pointer; var ReqSize: LongWord); - procedure PeekData(Buff: pointer; var ReqSize: LongWord); - published - property BytesInFifo: LongWord read FBytesInFifo; - end; - -implementation - -constructor TFifo.Create; -begin - inherited; - FBuffers := TList.Create; - // set default chunksize... - FChunksize := DefaultChunksize; - InitializeCriticalSection(FCritSect); -end; - -destructor TFifo.Destroy; -var - I: Integer; -begin - EnterCriticalSection(FCritSect); - for I := 0 to FBuffers.count - 1 do - begin - FreeMem(PMemChunk(Fbuffers[I]).Data); - Dispose(PMemChunk(Fbuffers[I])); - end; - FBuffers.Clear; - FBuffers.Free; - LeaveCriticalSection(FCritSect); - - DeleteCriticalSection(FCritSect); - inherited; -end; - -function TFifo.GetBytesInFifo: LongWord; -begin - Result := 0; - if FBuffers.Count = 0 then - begin - exit; - end - else - begin - if FBuffers.Count > 1 then - Inc(Result, (FBuffers.Count - 1) * FChunkSize); - Inc(Result, PMemChunk(FBuffers[Fbuffers.Count - 1]).Filled); - Dec(Result, PMemChunk(FBuffers[0]).Read); - end; -end; - -procedure TFifo.Write(Data: pointer; Size: LongWord); -var - Privpointer: pointer; - PrivSize: LongWord; - Chunk: PMemChunk; - PosInChunk: pointer; -begin - if LongWord(Data) = 0 then - begin - // null pointer? somebody is trying to fool us, get out... - Exit; - end; - EnterCriticalSection(FCritSect); - PrivPointer := Data; - PrivSize := 0; - // are already buffers there? - if FBuffers.count > 0 then - begin - // is the last one of them not completely filled? - if PMemChunk(FBuffers[FBuffers.count - 1]).filled < FChunksize then - // not completely filled, so fill up the buffer. - begin - Chunk := PMemChunk(FBuffers[FBuffers.count - 1]); - // fetch chunkdata. - PosInChunk := Chunk.Data; - // move to current fill pos... - Inc(LongWord(PosInChunk), Chunk.Filled); - // can we fill the chunk completely? - if Size > FChunksize - Chunk.Filled then - begin - // yes we can. - Move(PrivPointer^, PosInChunk^, FChunksize - Chunk.Filled); - Inc(PrivSize, FChunksize - Chunk.Filled); - Inc(LongWord(PrivPointer), FChunksize - Chunk.Filled); - Chunk.Filled := FChunkSize; - end - else - // we have to less data for filling the chunk completely, - // just put everything in. - begin - Move(PrivPointer^, PosInChunk^, Size); - Inc(PrivSize, Size); - Inc(Chunk.Filled, Size); - end; - end; - end; - // as long as we have remaining stuff put it into new chunks. - while (PrivSize < Size) do - begin - new(Chunk); - GetMem(Chunk.Data, FChunksize); - Chunk.Read := 0; - // can we fill an entire chunk with the remaining data? - if Privsize + FChunksize < Size then - begin - // yes we can, so put the stuff in. - Move(Privpointer^, Chunk.Data^, FChunksize); - Inc(LongWord(PrivPointer), FChunksize); - Inc(PrivSize, FChunksize); - Chunk.Filled := FChunksize; - end - else // we have to less data to fill the entire chunk, just put the remaining stuff in. - begin - Move(Privpointer^, Chunk.Data^, Size - Privsize); - Chunk.Filled := Size - Privsize; - Inc(PrivSize, Size - Privsize); - end; - Fbuffers.Add(Chunk); - end; - if Size <> Privsize then - Showmessage('miscalculation in TFifo.write'); - FBytesInFifo := GetBytesInFifo; - LeaveCriticalSection(FCritSect); -end; - -procedure TFifo.Read(Buff: pointer; var ReqSize: LongWord); -var - PrivSize: Integer; - Privpos: pointer; - Chunk: PMemChunk; - ChunkPos: pointer; -begin - if LongWord(Buff) = 0 then - begin - // null pointer? somebody is trying to fool us, get out... - Exit; - end; - EnterCriticalSection(FCritSect); - PrivSize := 0; - Privpos := Buff; - while FBuffers.Count > 0 do - begin - Chunk := PMemChunk(FBuffers[0]); - ChunkPos := Chunk.data; - Inc(LongWord(ChunkPos), Chunk.Read); - // does the remaining part of the chunk fit into the buffer? - if PrivSize + (Chunk.Filled - Chunk.read) < ReqSize then - begin // yep, it fits - Move(ChunkPos^, Privpos^, Chunk.Filled - Chunk.read); - Inc(PrivSize, Chunk.Filled - Chunk.read); - FreeMem(Chunk.Data); - Dispose(Chunk); - FBuffers.Delete(0); - end - else // remaining part didn't fit, get as much as we can and increment the - // read attribute. - begin - Move(ChunkPos^, Privpos^, ReqSize - PrivSize); - Inc(Chunk.read, ReqSize - PrivSize); - Inc(PrivSize, ReqSize - PrivSize); - // as we filled the buffer, we'll have to break here. - break; - end; - end; - FBytesInFifo := GetBytesInFifo; - LeaveCriticalSection(FCritSect); - ReqSize := PrivSize; -end; - -// read Data from Stream without removing it from the Stream... - -procedure TFifo.PeekData(Buff: pointer; var ReqSize: LongWord); -var - PrivSize: Integer; - Privpos: pointer; - Chunk: PMemChunk; - ChunkPos: pointer; - ChunkNr: Integer; -begin - if LongWord(Buff) = 0 then - begin - // null pointer? somebody is trying to fool us, get out... - Exit; - end; - EnterCriticalSection(FCritSect); - PrivSize := 0; - Privpos := Buff; - ChunkNr := 0; - while FBuffers.Count > ChunkNr do - begin - Chunk := PMemChunk(FBuffers[ChunkNr]); - ChunkPos := Chunk.data; - Inc(LongWord(ChunkPos), Chunk.Read); - // does the remaining part of the chunk fit into the buffer? - if PrivSize + (Chunk.Filled - Chunk.read) < ReqSize then - begin // yep, it fits - Move(ChunkPos^, Privpos^, Chunk.Filled - Chunk.read); - Inc(PrivSize, Chunk.Filled - Chunk.read); - Inc(ChunkNr); - end - else // remaining part didn't fit, get as much as we can and increment the - // read attribute. - begin - Move(ChunkPos^, Privpos^, ReqSize - PrivSize); - Inc(PrivSize, ReqSize - PrivSize); - // as we filled the buffer, we'll have to break here. - break; - end; - end; - LeaveCriticalSection(FCritSect); - ReqSize := PrivSize; -end; - -end. |