summaryrefslogtreecommitdiff
path: root/tests/examplefiles/example.pas
diff options
context:
space:
mode:
Diffstat (limited to 'tests/examplefiles/example.pas')
-rw-r--r--tests/examplefiles/example.pas2708
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.
View Lorry Controller Status