diff options
Diffstat (limited to 'tests/examplefiles/example.pas')
-rw-r--r-- | tests/examplefiles/example.pas | 2708 |
1 files changed, 2708 insertions, 0 deletions
diff --git a/tests/examplefiles/example.pas b/tests/examplefiles/example.pas new file mode 100644 index 00000000..ab11ee67 --- /dev/null +++ b/tests/examplefiles/example.pas @@ -0,0 +1,2708 @@ +// 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. |