// 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.