pairs }
+ IniStrm.ReadSectionValues(Sections[i], Entries);
+
+ { build new rate item from settings }
+ CurRate := TStExchangeRate.Create;
+ CurRate.LoadFromList(Entries);
+
+ { add to list }
+ Add(CurRate);
+ CurRate := nil;
+ end;
+ finally
+ Sections.Free;
+ Entries.Free;
+ IniStrm.Free;
+ CurRate.Free;
+ end;
+end;
+
+function TStExchangeRateList.MakeEntry(const Source, Target : String) : String;
+{ format conversion entry header from Source and Target }
+begin
+ Result := Source + ':' + Target;
+end;
+
+procedure TStExchangeRateList.SaveToFile(const AFileName: TFileName);
+var
+ FS : TFileStream;
+begin
+ if not FileExists(AFileName) then begin
+ FS := TFileStream.Create(AFileName, fmCreate);
+ FS.Free;
+ end;
+
+ FS := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyNone);
+ try
+ SaveToStream(FS);
+ finally
+ FS.Free;
+ end;
+end;
+
+procedure TStExchangeRateList.SaveToStream(AStream: TStream);
+{ persist list of Rate data to a stream }
+var
+ i : Integer;
+ IniStrm : TStIniStream;
+ Entries : TStringList;
+ CurRate : TStExchangeRate;
+begin
+ IniStrm := nil;
+ Entries := nil;
+ try
+ IniStrm := TStIniStream.Create(AStream);
+ Entries := TStringList.Create;
+ { for each maintained Rate item }
+ for i := 0 to Pred(FRates.Count) do begin
+
+ { get reference to the Rate }
+ CurRate := (FRates.Objects[i] as TStExchangeRate);
+
+ { make entries for Rate }
+ CurRate.SaveToList(Entries);
+
+ { write entries as a new section to INI stream }
+ IniStrm.WriteSection(MakeEntry(CurRate.Source, CurRate.Target),
+ Entries);
+ end;
+ finally
+ Entries.Free;
+ IniStrm.Free;
+ end;
+end;
+
+procedure TStExchangeRateList.UpdateRate(const Source,
+ Target: String; Rate: TStDecimal);
+{
+Modifies the exchange rate specified by the source and target
+assumes rate already exists, use Add or AddByValues to add new rates
+}
+var
+ Idx : Integer;
+begin
+ if not Assigned(Rate) then
+ raise EStException.CreateResTP(stscMoneyNilParameter, 0);
+
+ Idx := FRates.IndexOf(MakeEntry(Source, Target));
+ if Idx >= 0 then begin { conversion already exists for source and target }
+ { update Rate to reflect new rate }
+ (FRates.Objects[Idx] as TStExchangeRate).Rate.Assign(Rate);
+ end
+ { else no such rate }
+end;
+
+initialization
+ ExchBaseDate := EncodeDate(1980, 1, 1);
+end.
+
diff --git a/components/systools/source/run/ststrl.pas b/components/systools/source/run/ststrl.pas
new file mode 100644
index 000000000..369a10c7e
--- /dev/null
+++ b/components/systools/source/run/ststrl.pas
@@ -0,0 +1,3557 @@
+// TODO-UNICODE
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower SysTools
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{*********************************************************}
+{* SysTools: StStrL.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Long string routines *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+unit StStrL;
+
+interface
+
+uses
+ {$IFDEF FPC}
+ LCLType, StrUtils,
+ {$ELSE}
+ Windows,
+ {$ENDIF}
+ Classes,
+ SysUtils,
+ StConst,
+ StBase;
+
+{.Z+}
+type
+ LStrRec = record
+ AllocSize : Longint;
+ RefCount : Longint;
+ Length : Longint;
+ end;
+
+const
+ StrOffset = SizeOf(LStrRec);
+{.Z-}
+
+ {-------- Numeric conversion -----------}
+
+function HexBL(B : Byte) : AnsiString;
+ {-Return the hex string for a byte.}
+
+function HexWL(W : Word) : AnsiString;
+ {-Return the hex string for a word.}
+
+function HexLL(L : LongInt) : AnsiString;
+ {-Return the hex string for a long integer.}
+
+function HexPtrL(P : Pointer) : AnsiString;
+ {-Return the hex string for a pointer.}
+
+function BinaryBL(B : Byte) : AnsiString;
+ {-Return a binary string for a byte.}
+
+function BinaryWL(W : Word) : AnsiString;
+ {-Return the binary string for a word.}
+
+function BinaryLL(L : LongInt) : AnsiString;
+ {-Return the binary string for a long integer.}
+
+function OctalBL(B : Byte) : AnsiString;
+ {-Return an octal string for a byte.}
+
+function OctalWL(W : Word) : AnsiString;
+ {-Return an octal string for a word.}
+
+function OctalLL(L : LongInt) : AnsiString;
+ {-Return an octal string for a long integer.}
+
+function Str2Int16L(const S : AnsiString; var I : SmallInt) : Boolean;
+ {-Convert a string to an SmallInt.}
+
+function Str2WordL(const S : AnsiString; var I : Word) : Boolean;
+ {-Convert a string to a word.}
+
+function Str2LongL(const S : AnsiString; var I : LongInt) : Boolean;
+ {-Convert a string to a long integer.}
+
+{$IFDEF VER93}
+function Str2RealL(const S : AnsiString; var R : Double) : Boolean;
+{$ELSE}
+function Str2RealL(const S : AnsiString; var R : Real) : Boolean;
+ {-Convert a string to a real.}
+{$ENDIF}
+
+function Str2ExtL(const S : AnsiString; var R : Extended) : Boolean;
+ {-Convert a string to an extended.}
+
+function Long2StrL(L : LongInt) : String;
+ {-Convert an integer type to a string.}
+
+function Real2StrL(R : Double; Width : Byte; Places : ShortInt) : String;
+ {-Convert a real to a string.}
+
+function Ext2StrL(R : Extended; Width : Byte; Places : ShortInt) : String;
+ {-Convert an extended to a string.}
+
+function ValPrepL(const S : String) : String;
+ {-Prepares a string for calling Val.}
+
+ {-------- General purpose string manipulation --------}
+
+function CharStrL(C : Char; Len : Cardinal) : String;
+ {-Return a string filled with the specified character.}
+
+function PadChL(const S : String; C : Char; Len : Cardinal) : String;
+ {-Pad a string on the right with a specified character.}
+
+function PadL(const S : String; Len : Cardinal) : String;
+ {-Pad a string on the right with spaces.}
+
+function LeftPadChL(const S : String; C : Char; Len : Cardinal) : String;
+ {-Pad a string on the left with a specified character.}
+
+function LeftPadL(const S : String; Len : Cardinal) : String;
+ {-Pad a string on the left with spaces.}
+
+function TrimLeadL(const S : String) : String;
+ {-Return a string with leading white space removed.}
+
+function TrimTrailL(const S : String) : String;
+ {-Return a string with trailing white space removed.}
+
+function TrimL(const S : String) : String;
+ {-Return a string with leading and trailing white space removed.}
+
+function TrimSpacesL(const S : String) : String;
+ {-Return a string with leading and trailing spaces removed.}
+
+function CenterChL(const S : String; C : Char; Len : Cardinal) : String;
+ {-Pad a string on the left and right with a specified character.}
+
+function CenterL(const S : String; Len : Cardinal) : String;
+ {-Pad a string on the left and right with spaces.}
+
+function EntabL(const S : AnsiString; TabSize : Byte) : AnsiString;
+ {-Convert blanks in a string to tabs.}
+
+function DetabL(const S : AnsiString; TabSize : Byte) : AnsiString;
+ {-Expand tabs in a string to blanks.}
+
+function ScrambleL(const S, Key : AnsiString) : AnsiString;
+ {-Encrypt / Decrypt string with enhanced XOR encryption.}
+
+function SubstituteL(const S, FromStr, ToStr : String) : String;
+ {-Map the characters found in FromStr to the corresponding ones in ToStr.}
+
+function FilterL(const S, Filters : String) : String;
+ {-Remove characters from a string. The characters to remove are specified in
+ ChSet.}
+
+ {--------------- Word / Char manipulation -------------------------}
+
+function CharExistsL(const S : String; C : Char) : Boolean;
+ {-Determine whether a given character exists in a string. }
+
+function CharCountL(const S : String; C : Char) : Cardinal;
+ {-Count the number of a given character in a string. }
+
+function WordCountL(const S, WordDelims : String) : Cardinal;
+ {-Given an array of word delimiters, return the number of words in a string.}
+
+function WordPositionL(N : Cardinal; const S, WordDelims : String;
+ var Pos : Cardinal) : Boolean;
+ {-Given an array of word delimiters, set Pos to the start position of the
+ N'th word in a string. Result indicates success/failure.}
+
+function ExtractWordL(N : Cardinal; const S, WordDelims : String) : String;
+ {-Given an array of word delimiters, return the N'th word in a string.}
+
+function AsciiCountL(const S, WordDelims : String; Quote : Char) : Cardinal;
+ {-Return the number of words in a string.}
+
+function AsciiPositionL(N : Cardinal; const S, WordDelims : String;
+ Quote : Char; var Pos : Cardinal) : Boolean;
+ {-Return the position of the N'th word in a string.}
+
+function ExtractAsciiL(N : Cardinal; const S, WordDelims : String;
+ Quote : Char) : String;
+ {-Given an array of word delimiters, return the N'th word in a string. Any
+ text within Quote characters is counted as one word.}
+
+procedure WordWrapL(const InSt : String; var OutSt, Overlap : String;
+ Margin : Cardinal; PadToMargin : Boolean);
+ {-Wrap a text string at a specified margin.}
+
+ {--------------- String comparison and searching -----------------}
+function CompStringL(const S1, S2 : String) : Integer;
+ {-Compare two strings.}
+
+function CompUCStringL(const S1, S2 : String) : Integer;
+ {-Compare two strings. This compare is not case sensitive.}
+
+function SoundexL(const S : AnsiString) : AnsiString;
+ {-Return 4 character soundex of an input string.}
+
+(*
+function MakeLetterSetL(const S : AnsiString) : Longint;
+ {-Return a bit-mapped long storing the individual letters contained in S.}
+
+{$IFDEF UNICODE}
+procedure BMMakeTableL(const MatchString : UnicodeString; var BT : BTable); overload;
+{$ELSE}
+procedure BMMakeTableL(const MatchString : AnsiString; var BT : BTable); overload;
+{$ENDIF}
+ {-Build a Boyer-Moore link table}
+
+{$IFDEF UNICODE}
+function BMSearchL(var Buffer; BufLength: Cardinal; var BT: BTable;
+ const MatchString : String; out Pos : Cardinal) : Boolean; overload;
+{$ELSE}
+function BMSearchL(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : AnsiString; var Pos : Cardinal) : Boolean; overload;
+{$ENDIF}
+ {-Use the Boyer-Moore search method to search a buffer for a string.}
+
+{$IFDEF UNICODE}
+function BMSearchUCL(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : String ; var Pos : Cardinal) : Boolean;
+{$ELSE}
+function BMSearchUCL(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : AnsiString ; var Pos : Cardinal) : Boolean;
+{$ENDIF}
+ {-Use the Boyer-Moore search method to search a buffer for a string. This
+ search is not case sensitive.}
+*)
+
+ {--------------- DOS pathname parsing -----------------}
+
+function DefaultExtensionL(const Name, Ext : String) : String;
+ {-Return a file name with a default extension attached.}
+
+function ForceExtensionL(const Name, Ext : String) : String;
+ {-Force the specified extension onto the file name.}
+
+function JustFilenameL(const PathName : String) : String;
+ {-Return just the filename and extension of a pathname.}
+
+function JustNameL(const PathName : String) : String;
+ {-Return just the filename (no extension, path, or drive) of a pathname.}
+
+function JustExtensionL(const Name : String) : String;
+ {-Return just the extension of a pathname.}
+
+function JustPathnameL(const PathName : String) : String;
+ {-Return just the drive and directory portion of a pathname.}
+
+function AddBackSlashL(const DirName : String) : String;
+ {-Add a default backslash to a directory name.}
+
+function CleanPathNameL(const PathName : String) : String;
+ {-Return a pathname cleaned up as DOS does it.}
+
+function HasExtensionL(const Name : String; var DotPos : Cardinal) : Boolean;
+ {-Determine if a pathname contains an extension and, if so, return the
+ position of the dot in front of the extension.}
+
+ {------------------ Formatting routines --------------------}
+
+function CommaizeL(L : LongInt) : String;
+ {-Convert a long integer to a string with commas.}
+
+function CommaizeChL(L : Longint; Ch : Char) : String;
+ {-Convert a long integer to a string with Ch in comma positions.}
+
+function FloatFormL(const Mask : String ; R : TstFloat ; const LtCurr,
+ RtCurr : String ; Sep, DecPt : Char) : String;
+ {-Return a formatted string with digits from R merged into mask.}
+
+function LongIntFormL(const Mask : String ; L : LongInt ; const LtCurr,
+ RtCurr : String ; Sep : Char) : String;
+ {-Return a formatted string with digits from L merged into mask.}
+
+function StrChPosL(const P : String; C : Char; var Pos : Cardinal) : Boolean;
+ {-Return the position of a specified character within a string.}
+
+function StrStPosL(const P, S : String; var Pos : Cardinal) : Boolean;
+ {-Return the position of a specified substring within a string.}
+
+function StrStCopyL(const S : String; Pos, Count : Cardinal) : String;
+ {-Copy characters at a specified position in a string.}
+
+function StrChInsertL(const S : String; C : Char; Pos : Cardinal) : String;
+ {-Insert a character into a string at a specified position.}
+
+function StrStInsertL(const S1, S2 : String; Pos : Cardinal) : String;
+ {-Insert a string into another string at a specified position.}
+
+function StrChDeleteL(const S : String; Pos : Cardinal) : String;
+ {-Delete the character at a specified position in a string.}
+
+function StrStDeleteL(const S : String; Pos, Count : Cardinal) : String;
+ {-Delete characters at a specified position in a string.}
+
+
+{-------------------------- New Functions -----------------------------------}
+
+function ContainsOnlyL(const S, Chars : String;
+ var BadPos : Cardinal) : Boolean;
+
+function ContainsOtherThanL(const S, Chars : String;
+ var BadPos : Cardinal) : Boolean;
+
+function CopyLeftL(const S : String; Len : Cardinal) : String;
+ {-Return the left Len characters of a string}
+
+function CopyMidL(const S : String; First, Len : Cardinal) : String;
+ {-Return the mid part of a string}
+
+function CopyRightL(const S : String; First : Cardinal) : String;
+ {-Return the right Len characters of a string}
+
+function CopyRightAbsL(const S : String; NumChars : Cardinal) : String;
+ {-Return NumChar characters starting from end}
+
+function CopyFromNthWordL(const S, WordDelims : String;
+ const AWord : String; N : Cardinal; {!!.02}
+ var SubString : String) : Boolean;
+
+function CopyFromToWordL(const S, WordDelims, Word1, Word2 : String;
+ N1, N2 : Cardinal;
+ var SubString : String) : Boolean;
+
+function CopyWithinL(const S, Delimiter : String;
+ Strip : Boolean) : String;
+
+function DeleteFromNthWordL(const S, WordDelims : String;
+ const AWord : String; N : Cardinal; {!!.02}
+ var SubString : String) : Boolean;
+
+function DeleteFromToWordL(const S, WordDelims, Word1, Word2 : String;
+ N1, N2 : Cardinal;
+ var SubString : String) : Boolean;
+
+function DeleteWithinL(const S, Delimiter : String) : String;
+
+function ExtractTokensL(const S, Delims: String;
+ QuoteChar : Char;
+ AllowNulls : Boolean;
+ Tokens : TStrings) : Cardinal;
+
+function IsChAlphaL(C : Char) : Boolean;
+ {-Returns true if Ch is an alpha}
+
+function IsChNumericL(C : Char; const Numbers : String) : Boolean; {!!.02}
+ {-Returns true if Ch in numeric set}
+
+function IsChAlphaNumericL(C : Char; const Numbers : String) : Boolean; {!!.02}
+ {-Returns true if Ch is an alpha or numeric}
+
+function IsStrAlphaL(const S : String) : Boolean;
+ {-Returns true if all characters in string are an alpha}
+
+function IsStrNumericL(const S, Numbers : String) : Boolean;
+ {-Returns true if all characters in string are in numeric set}
+
+function IsStrAlphaNumericL(const S, Numbers : String) : Boolean;
+ {-Returns true if all characters in string are alpha or numeric}
+
+function KeepCharsL(const S, Chars : String) : String;
+
+function LastWordL(const S, WordDelims, AWord : String;
+ var Position : Cardinal) : Boolean;
+
+function LastWordAbsL(const S, WordDelims : String;
+ var Position : Cardinal) : Boolean;
+
+function LastStringL(const S, AString : String;
+ var Position : Cardinal) : Boolean;
+
+function LeftTrimCharsL(const S, Chars : String) : String;
+
+function ReplaceWordL(const S, WordDelims, OldWord, NewWord : String;
+ N : Cardinal;
+ var Replacements : Cardinal) : String;
+
+function ReplaceWordAllL(const S, WordDelims, OldWord, NewWord : String;
+ var Replacements : Cardinal) : String;
+
+function ReplaceStringL(const S, OldString, NewString : String;
+ N : Cardinal;
+ var Replacements : Cardinal) : String;
+
+function ReplaceStringAllL(const S, OldString, NewString : String;
+ var Replacements : Cardinal) : String;
+
+function RepeatStringL(const RepeatString : String;
+ var Repetitions : Cardinal;
+ MaxLen : Cardinal) : String;
+
+function RightTrimCharsL(const S, Chars : String) : String;
+
+function StrWithinL(const S, SearchStr : string;
+ Start : Cardinal;
+ var Position : Cardinal) : boolean;
+ {-finds the position of a substring within a string starting at a given point}
+
+function TrimCharsL(const S, Chars : String) : String;
+
+function WordPosL(const S, WordDelims, AWord : String;
+ N : Cardinal; var Position : Cardinal) : Boolean;
+ {-returns the Occurrence instance of a word within a string}
+
+
+implementation
+
+ {-------- Numeric conversion -----------}
+
+function HexBL(B : Byte) : AnsiString;
+ {-Return the hex string for a byte.}
+begin
+ SetLength(Result, 2);
+ Result[1] := StHexDigits[B shr 4];
+ Result[2] := StHexDigits[B and $F];
+end;
+
+function HexWL(W : Word) : AnsiString;
+ {-Return the hex string for a word.}
+begin
+ SetLength(Result, 4);
+ Result[1] := StHexDigits[hi(W) shr 4];
+ Result[2] := StHexDigits[hi(W) and $F];
+ Result[3] := StHexDigits[lo(W) shr 4];
+ Result[4] := StHexDigits[lo(W) and $F];
+end;
+
+function HexLL(L : LongInt) : AnsiString;
+ {-Return the hex string for a long integer.}
+begin
+ SetLength(Result, 8);
+ Result := HexWL(HiWord(DWORD(L))) + HexWL(LoWord(DWORD(L))); {!!.02}
+end;
+
+function HexPtrL(P : Pointer) : AnsiString;
+ {-Return the hex string for a pointer.}
+begin
+ SetLength(Result, 9);
+ Result := ':' + HexLL(LongInt(P));
+end;
+
+function BinaryBL(B : Byte) : AnsiString;
+ {-Return a binary string for a byte.}
+var
+ I, N : Word;
+begin
+ N := 1;
+ SetLength(Result, 8);
+ for I := 7 downto 0 do begin
+ Result[N] := StHexDigits[Ord(B and (1 shl I) <> 0)]; {0 or 1}
+ Inc(N);
+ end;
+end;
+
+function BinaryWL(W : Word) : AnsiString;
+ {-Return the binary string for a word.}
+var
+ I, N : Word;
+begin
+ N := 1;
+ SetLength(Result, 16);
+ for I := 15 downto 0 do begin
+ Result[N] := StHexDigits[Ord(W and (1 shl I) <> 0)]; {0 or 1}
+ Inc(N);
+ end;
+end;
+
+function BinaryLL(L : LongInt) : AnsiString;
+ {-Return the binary string for a long integer.}
+var
+ I : Longint;
+ N : Byte;
+begin
+ N := 1;
+ SetLength(Result, 32);
+ for I := 31 downto 0 do begin
+ Result[N] := StHexDigits[Ord(L and LongInt(1 shl I) <> 0)]; {0 or 1}
+ Inc(N);
+ end;
+end;
+
+function OctalBL(B : Byte) : AnsiString;
+ {-Return an octal string for a byte.}
+var
+ I : Word;
+begin
+ SetLength(Result, 3);
+ for I := 0 to 2 do begin
+ Result[3-I] := StHexDigits[B and 7];
+ B := B shr 3;
+ end;
+end;
+
+function OctalWL(W : Word) : AnsiString;
+ {-Return an octal string for a word.}
+var
+ I : Word;
+begin
+ SetLength(Result, 6);
+ for I := 0 to 5 do begin
+ Result[6-I] := StHexDigits[W and 7];
+ W := W shr 3;
+ end;
+end;
+
+function OctalLL(L : LongInt) : AnsiString;
+ {-Return an octal string for a long integer.}
+var
+ I : Word;
+begin
+ SetLength(Result, 12);
+ for I := 0 to 11 do begin
+ Result[12-I] := StHexDigits[L and 7];
+ L := L shr 3;
+ end;
+end;
+
+function Str2Int16L(const S : AnsiString; var I : SmallInt) : Boolean;
+ {-Convert a string to an SmallInt.}
+
+var
+ ec : Integer;
+begin
+ {note the automatic string conversion}
+ ValSmallint(S, I, ec);
+ if (ec = 0) then
+ Result := true
+ else begin
+ Result := false;
+ if (ec < 0) then
+ I := succ(length(S))
+ else
+ I := ec;
+ end;
+end;
+
+function Str2WordL(const S : AnsiString; var I : Word) : Boolean;
+ {-Convert a string to a word.}
+
+var
+ ec : Integer;
+begin
+ {note the automatic string conversion}
+ ValWord(S, I, ec);
+ if (ec = 0) then
+ Result := true
+ else begin
+ Result := false;
+ if (ec < 0) then
+ I := succ(length(S))
+ else
+ I := ec;
+ end;
+end;
+
+function Str2LongL(const S : AnsiString; var I : LongInt) : Boolean;
+ {-Convert a string to a long integer.}
+
+var
+ ec : Integer;
+begin
+ {note the automatic string conversion}
+ ValLongint(S, I, ec);
+ if (ec = 0) then
+ Result := true
+ else begin
+ Result := false;
+ if (ec < 0) then
+ I := succ(length(S))
+ else
+ I := ec;
+ end;
+end;
+
+{$IFDEF VER93}
+function Str2RealL(const S : AnsiString; var R : Double) : Boolean;
+{$ELSE}
+function Str2RealL(const S : AnsiString; var R : Real) : Boolean;
+{$ENDIF}
+ {-Convert a string to a real.}
+var
+ Code : Integer;
+ St : AnsiString;
+begin
+ Result := False;
+ if S = '' then Exit;
+ St := TrimTrailL(S);
+ if St = '' then Exit;
+ Val(ValPrepL(St), R, Code);
+ if Code <> 0 then begin
+ R := Code;
+ end else
+ Result := True;
+end;
+
+function Str2ExtL(const S : AnsiString; var R : Extended) : Boolean;
+ {-Convert a string to an extended.}
+var
+ Code : Integer;
+ P : AnsiString;
+begin
+ Result := False;
+ if S = '' then Exit;
+ P := TrimTrailL(S);
+ if P = '' then Exit;
+ Val(ValPrepL(P), R, Code);
+ if Code <> 0 then begin
+ R := Code - 1;
+ end else
+ Result := True;
+end;
+
+function Long2StrL(L : LongInt) : String;
+ {-Convert an integer type to a string.}
+begin
+ Str(L, Result);
+end;
+
+function Real2StrL(R : Double; Width : Byte; Places : ShortInt) : String;
+ {-Convert a real to a string.}
+begin
+ Str(R:Width:Places, Result);
+end;
+
+function Ext2StrL(R : Extended; Width : Byte; Places : ShortInt) : String;
+ {-Convert an extended to a string.}
+begin
+ Str(R:Width:Places, Result);
+end;
+
+function ValPrepL(const S : String) : String;
+ {-Prepares a string for calling Val.}
+var
+ P : Cardinal;
+ C : Longint;
+begin
+ Result := TrimSpacesL(S);
+ if Result <> '' then begin
+ if StrChPosL(Result, {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator, P) then begin
+ C := P;
+ Result[C] := '.';
+ if C = Length(Result) then
+ SetLength(Result, Pred(C));
+ end;
+ end else
+ Result := '0';
+end;
+
+ {-------- General purpose string manipulation --------}
+
+function CharStrL(C : Char; Len : Cardinal) : String;
+ {-Return a string filled with the specified character.}
+begin
+ Result := StringOfChar(C, Len)
+end;
+
+function PadChL(const S : String; C : Char; Len : Cardinal) : String;
+ {-Pad a string on the right with a specified character.}
+{$IFDEF UNICODE}
+begin
+ Result := S;
+ if Length(Result) < Len then
+ Result := Result + StringOfChar(C, Len - Length(Result));
+end;
+{$ELSE}
+begin
+ if Length(S) >= LongInt(Len) then
+ Result := S
+ else begin
+ SetLength(Result, Len);
+ { copy current contents (if any) of S to Result }
+ if (Length(S) > 0) then {!!.01}
+ Move(S[1], Result[1], Length(S));
+
+ { add pad chars }
+ FillChar(Result[Succ(Length(S))], LongInt(Len)-Length(S), C);
+ end;
+end;
+{$ENDIF}
+
+function PadL(const S : String; Len : Cardinal) : String;
+ {-Pad a string on the right with spaces.}
+begin
+ Result := PadChL(S, ' ', Len);
+end;
+
+function LeftPadChL(const S : String; C : Char; Len : Cardinal) : String;
+ {-Pad a string on the left with a specified character.}
+begin
+ {$IFDEF UNICODE}
+ if Length(S) > Len then
+ Result := S
+ else
+ Result := StringOfChar(C, Len - Length(S)) + S;
+ {$ELSE}
+ if Length(S) >= LongInt(Len) then
+ Result := S
+ else if Length(S) < MaxLongInt then begin
+ SetLength(Result, Len);
+
+ { copy current contents (if any) of S to Result }
+ if (Length(S) > 0) then {!!.01}
+ Move(S[1], Result[Succ(Word(Len))-Length(S)], Length(S));
+
+ { add pad chars }
+ FillChar(Result[1], LongInt(Len)-Length(S), C);
+ end;
+ {$ENDIF}
+end;
+
+function LeftPadL(const S : String; Len : Cardinal) : String;
+ {-Pad a string on the left with spaces.}
+begin
+ Result := LeftPadChL(S, ' ', Len);
+end;
+
+function TrimLeadL(const S : String) : String;
+ {-Return a string with leading white space removed}
+begin
+ Result := TrimLeft(S);
+end;
+
+function TrimTrailL(const S : String) : String;
+ {-Return a string with trailing white space removed.}
+begin
+ Result := TrimRight(S);
+end;
+
+function TrimL(const S : String) : String;
+ {-Return a string with leading and trailing white space removed.}
+var
+ I : Longint;
+begin
+ Result := S;
+ while (Length(Result) > 0) and (Result[Length(Result)] <= ' ') do
+ SetLength(Result, Pred(Length(Result)));
+
+ I := 1;
+ while (I <= Length(Result)) and (Result[I] <= ' ') do
+ Inc(I);
+ Dec(I);
+ if I > 0 then
+ System.Delete(Result, 1, I);
+end;
+
+function TrimSpacesL(const S : String) : String;
+ {-Return a string with leading and trailing spaces removed.}
+var
+ I : Longint;
+begin
+ Result := S;
+ while (Length(Result) > 0) and (Result[Length(Result)] = ' ') do
+ SetLength(Result, Pred(Length(Result)));
+ I := 1;
+ while (I <= Length(Result)) and (S[I] = ' ') do
+ Inc(I);
+ Dec(I);
+ if I > 0 then
+ System.Delete(Result, 1, I);
+end;
+
+function CenterChL(const S : String; C : Char; Len : Cardinal) : String;
+ {-Pad a string on the left and right with a specified character.}
+begin
+ if Length(S) >= LongInt(Len) then
+ Result := S
+ else if Length(S) < MaxLongInt then begin
+// SetLength(Result, Len);
+// FillChar(Result[1], Len, C);
+ Result := StringOfChar(C, Len);
+ if Length(S) > 0 then {!!.01}
+ Move(S[1], Result[Succ((LongInt(Len)-Length(S)) shr 1)], Length(S)*SizeOf(Char));
+ end;
+end;
+
+function CenterL(const S : String; Len : Cardinal) : String;
+ {-Pad a string on the left and right with spaces.}
+begin
+ Result := CenterChL(S, ' ', Len);
+end;
+
+function EntabL(const S : AnsiString; TabSize : Byte) : AnsiString; //TODO-UNICODE
+ {-Convert blanks in a string to tabs.}
+var
+ InLen, OutLen : Cardinal;
+begin
+ if S = '' then Exit;
+ InLen := Length(S);
+ OutLen := 0;
+ SetLength(Result, InLen);
+asm
+ push ebx { Save registers }
+ push edi
+ push esi
+
+ mov edi, [Result]
+ mov edi, [edi]
+ xor ecx, ecx
+ add cl, TabSize
+ jz @@Done
+
+ mov esi, S
+ xor ebx, ebx { Zero EBX and EDX }
+ xor edx, edx
+ inc edx { Set output length to 1 }
+
+@@Next:
+ or ebx, ebx
+ je @@NoTab { Jump to NoTab if spacecount is zero }
+ mov eax, edx { IPos to EAX }
+ push edx
+ xor edx, edx
+ div ecx
+ cmp edx, 1 { Is mod = 1? }
+ pop edx
+ jne @@NoTab { If not, no tab }
+
+ sub edi, ebx
+ sub OutLen, ebx
+ inc OutLen
+ xor ebx, ebx { Reset spacecount }
+ mov byte ptr [edi], 9h { Store a tab }
+ inc edi
+
+@@NoTab:
+ mov al, [esi] { Get next input character }
+ inc esi
+ cmp edx, InLen { End of string? }
+ jg @@Done { Yes, done }
+ inc ebx { Increment SpaceCount }
+ cmp al, 20h { Is character a space? }
+ jz @@Store { Yes, store it for now }
+ xor ebx, ebx { Reset SpaceCount }
+ cmp al, 27h { Is it a quote? }
+ jz @@Quotes { Yep, enter quote loop }
+ cmp al, 22h { Is it a doublequote? }
+ jnz @@Store { Nope, store it }
+
+@@Quotes:
+ mov ah, al { Save quote start }
+
+@@NextQ:
+ mov [edi], al { Store quoted character }
+ inc edi
+ inc OutLen
+ mov al, [esi] { Get next character }
+ inc esi
+ inc edx { Increment Ipos }
+
+ cmp edx, ecx { At end of line? }
+ jae @@Store { If so, exit quote loop }
+
+ cmp al, ah { Matching end quote? }
+ jnz @@NextQ { Nope, stay in quote loop }
+
+ cmp al, 27h { Single quote? }
+ jz @@Store { Exit quote loop }
+
+ cmp byte ptr [esi-2],'\' { Previous character an escape? }
+ jz @@NextQ { Stay in if so }
+
+@@Store:
+ mov [edi], al { Store last character }
+ inc edi
+ inc OutLen
+ inc edx { Increment input position }
+ jmp @@Next { Repeat while characters left }
+
+@@Done:
+ mov byte ptr [edi], 0h
+ pop esi
+ pop edi
+ pop ebx
+end;
+ SetLength(Result, OutLen);
+end;
+
+function DetabL(const S : AnsiString; TabSize : Byte) : AnsiString; //TODO-UNICODE
+ {-Expand tabs in a string to blanks.}
+var
+ NumTabs : Integer;
+begin
+ Result := '';
+ if S = '' then Exit;
+ if TabSize = 0 then Exit;
+ Result := S;
+ NumTabs := CharCountL(S, #9);
+ if NumTabs = 0 then Exit;
+ SetLength(Result, Length(Result)+NumTabs*(Pred(TabSize)));
+asm
+ push ebx { Save registers since we'll be changing them. }
+ push edi
+ push esi
+
+ mov edi, Result { EDI => output string. }
+ mov esi, S { ESI => input string. }
+ xor ebx, ebx
+ mov bl, TabSize
+ mov edi, [edi]
+ xor ecx, ecx { Default input length = 0. }
+ xor edx, edx { Zero EDX for output length }
+ xor eax, eax { Zero EAX }
+ mov ecx, [esi-StrOffset].LStrRec.Length { Get input length. }
+ or ebx, ebx { TabSize = 0? }
+ jnz @@DefLength
+ mov ecx, edx { Return zero length string if TabSize = 0. }
+
+@@DefLength:
+ mov [edi-StrOffset].LStrRec.Length, ecx { Store default output length. }
+ or ecx, ecx
+ jz @@Done { Done if empty input string. }
+
+@@Next:
+ mov al, [esi] { Next input character. }
+ inc esi
+ cmp al, 09h { Is it a tab? }
+ jz @@Tab { Yes, compute next tab stop. }
+ mov [edi], al { No, store to output. }
+ inc edi
+ inc edx { Increment output length. }
+ dec ecx { Decrement input length. }
+ jnz @@Next
+ jmp @@StoreLen { Loop termination. }
+
+@@Tab:
+ push ecx { Save input length. }
+ push edx { Save output length. }
+ mov eax, edx { Get current output length in EDX:EAX. }
+ xor edx, edx
+ div ebx { Output length MOD TabSize in DX. }
+ mov ecx, ebx { Calc number of spaces to insert... }
+ sub ecx, edx { = TabSize - Mod value. }
+ pop edx
+ add edx, ecx { Add count of spaces into current output length. }
+
+ mov eax,$2020 { Blank in AH, Blank in AL. }
+ shr ecx, 1 { Store blanks. }
+ rep stosw
+ adc ecx, ecx
+ rep stosb
+ pop ecx { Restore input length. }
+ dec ecx
+ jnz @@Next
+ {jmp @@Next} { Back for next input. }
+
+@@StoreLen:
+ xor ebx, ebx
+ mov [edi], bl { Store terminating null }
+ mov eax, edx
+ sub edi, eax
+ mov [edi-StrOffset].LStrRec.Length, edx { Store final length. }
+
+@@Done:
+ pop esi
+ pop edi
+ pop ebx
+end;
+end;
+
+function ScrambleL(const S, Key : AnsiString) : AnsiString;
+ {-Encrypt / Decrypt string with enhanced XOR encryption.}
+var
+ I, J, LKey, LStr : Cardinal;
+begin
+ Result := S;
+ if Key = '' then Exit;
+ if S = '' then Exit;
+ LKey := Length(Key);
+ LStr := Length(S);
+ I := 1;
+ J := LKey;
+ while I <= LStr do begin
+ if J = 0 then
+ J := LKey;
+ if (S[I] <> Key[J]) then
+ Result[I] := AnsiChar(Byte(S[I]) xor Byte(Key[J]));
+ Inc(I);
+ Dec(J);
+ end;
+end;
+
+function SubstituteL(const S, FromStr, ToStr : String) : String;
+ {-Map the characters found in FromStr to the corresponding ones in ToStr.}
+var
+ I : Cardinal;
+ P : Cardinal;
+begin
+ Result := S;
+ if Length(FromStr) = Length(ToStr) then
+ for I := 1 to Length(Result) do begin
+ {P := System.Pos(S[I], FromStr);}
+ {if P <> 0 then}
+ if StrChPosL(FromStr, S[I], P) then
+ Result[I] := ToStr[P];
+ end;
+end;
+
+function FilterL(const S, Filters : String) : String;
+ {-Remove characters from a string. The characters to remove are specified in
+ ChSet.}
+var
+ I : Cardinal;
+ Len : Cardinal;
+begin
+ Len := 0;
+ SetLength(Result, Length(S));
+ for I := 1 to Length(S) do
+ if not CharExistsL(Filters, S[I]) then begin
+ Inc(Len);
+ Result[Len] := S[I];
+ end;
+ SetLength(Result, Len);
+end;
+
+ {--------------- Word / Char manipulation -------------------------}
+
+function CharExistsL(const S : String; C : Char) : Boolean; register;
+ {-Count the number of a given character in a string. }
+{$IFDEF UNICODE}
+var
+ I: Integer;
+begin
+ Result := False;
+ for I := 1 to Length(S) do
+ begin
+ if S[I] = C then
+ begin
+ Result := True;
+ Break;
+ end;
+ end;
+end;
+{$ELSE}
+asm
+ push ebx
+ xor ecx, ecx
+ or eax, eax
+ jz @@Done
+ mov ebx, [eax-StrOffset].LStrRec.Length
+ or ebx, ebx
+ jz @@Done
+ jmp @@5
+
+@@Loop:
+ cmp dl, [eax+3]
+ jne @@1
+ inc ecx
+ jmp @@Done
+
+@@1:
+ cmp dl, [eax+2]
+ jne @@2
+ inc ecx
+ jmp @@Done
+
+@@2:
+ cmp dl, [eax+1]
+ jne @@3
+ inc ecx
+ jmp @@Done
+
+@@3:
+ cmp dl, [eax+0]
+ jne @@4
+ inc ecx
+ jmp @@Done
+
+@@4:
+ add eax, 4
+ sub ebx, 4
+
+@@5:
+ cmp ebx, 4
+ jge @@Loop
+
+ cmp ebx, 3
+ je @@1
+
+ cmp ebx, 2
+ je @@2
+
+ cmp ebx, 1
+ je @@3
+
+@@Done:
+ mov eax, ecx
+ pop ebx
+end;
+{$ENDIF}
+
+function CharCountL(const S : String; C : Char) : Cardinal; register;
+ {-Count the number of a given character in a string. }
+{$IFDEF UNICODE}
+var
+ I: Integer;
+begin
+ Result := 0;
+ for I := 1 to Length(S) do
+ if S[I] = C then
+ Inc(Result);
+end;
+{$ELSE}
+asm
+ push ebx
+ xor ecx, ecx
+ or eax, eax
+ jz @@Done
+ mov ebx, [eax-StrOffset].LStrRec.Length
+ or ebx, ebx
+ jz @@Done
+ jmp @@5
+
+@@Loop:
+ cmp dl, [eax+3]
+ jne @@1
+ inc ecx
+
+@@1:
+ cmp dl, [eax+2]
+ jne @@2
+ inc ecx
+
+@@2:
+ cmp dl, [eax+1]
+ jne @@3
+ inc ecx
+
+@@3:
+ cmp dl, [eax+0]
+ jne @@4
+ inc ecx
+
+@@4:
+ add eax, 4
+ sub ebx, 4
+
+@@5:
+ cmp ebx, 4
+ jge @@Loop
+
+ cmp ebx, 3
+ je @@1
+
+ cmp ebx, 2
+ je @@2
+
+ cmp ebx, 1
+ je @@3
+
+@@Done:
+ mov eax, ecx
+ pop ebx
+end;
+{$ENDIF}
+
+function WordCountL(const S, WordDelims : String) : Cardinal;
+ {-Given an array of word delimiters, return the number of words in a string.}
+var
+ I : Cardinal;
+ SLen : Cardinal;
+begin
+ Result := 0;
+ I := 1;
+ SLen := Length(S);
+
+ while I <= SLen do begin
+ {skip over delimiters}
+ while (I <= SLen) and CharExistsL(WordDelims, S[I]) do
+ Inc(I);
+
+ {if we're not beyond end of S, we're at the start of a word}
+ if I <= SLen then
+ Inc(Result);
+
+ {find the end of the current word}
+ while (I <= SLen) and not CharExistsL(WordDelims, S[I]) do
+ Inc(I);
+ end;
+end;
+
+function WordPositionL(N : Cardinal; const S, WordDelims : String;
+ var Pos : Cardinal) : Boolean;
+ {-Given an array of word delimiters, set Pos to the start position of the
+ N'th word in a string. Result indicates success/failure.}
+var
+ Count : Longint;
+ I : Longint;
+begin
+ Count := 0;
+ I := 1;
+ Result := False;
+
+ while (I <= Length(S)) and (Count <> LongInt(N)) do begin
+ {skip over delimiters}
+ while (I <= Length(S)) and CharExistsL(WordDelims, S[I]) do
+ Inc(I);
+
+ {if we're not beyond end of S, we're at the start of a word}
+ if I <= Length(S) then
+ Inc(Count);
+
+ {if not finished, find the end of the current word}
+ if Count <> LongInt(N) then
+ while (I <= Length(S)) and not CharExistsL(WordDelims, S[I]) do
+ Inc(I)
+ else begin
+ Pos := I;
+ Result := True;
+ end;
+ end;
+end;
+
+function ExtractWordL(N : Cardinal; const S, WordDelims : String) : String;
+ {-Given an array of word delimiters, return the N'th word in a string.}
+var
+ C : Cardinal;
+ I, J : Longint;
+begin
+ Result := '';
+ if WordPositionL(N, S, WordDelims, C) then begin
+ I := C;
+ {find the end of the current word}
+ J := I;
+ while (I <= Length(S)) and not
+ CharExistsL(WordDelims, S[I]) do
+ Inc(I);
+ SetLength(Result, I-J);
+ Move(S[J], Result[1], (I-J) * SizeOf(Char));
+ end;
+end;
+
+
+function AsciiCountL(const S, WordDelims : String; Quote : Char) : Cardinal;
+ {-Return the number of words in a string.}
+var
+ I : Longint;
+ InQuote : Boolean;
+begin
+ Result := 0;
+ I := 1;
+ InQuote := False;
+ while I <= Length(S) do begin
+ {skip over delimiters}
+ while (I <= Length(S)) and (S[I] <> Quote)
+ and CharExistsL(WordDelims, S[I]) do
+ Inc(I);
+ {if we're not beyond end of S, we're at the start of a word}
+ if I <= Length(S) then
+ Inc(Result);
+ {find the end of the current word}
+ while (I <= Length(S)) and
+ (InQuote or not CharExistsL(WordDelims, S[I])) do begin
+ if S[I] = Quote then
+ InQuote := not InQuote;
+ Inc(I);
+ end;
+ end;
+end;
+
+function AsciiPositionL(N : Cardinal; const S, WordDelims : String;
+ Quote : Char; var Pos : Cardinal) : Boolean;
+ {-Return the position of the N'th word in a string.}
+var
+ Count, I : Longint;
+ InQuote : Boolean;
+begin
+ Count := 0;
+ InQuote := False;
+ Result := False;
+ I := 1;
+ while (I <= Length(S)) and (Count <> LongInt(N)) do begin
+ {skip over delimiters}
+ while (I <= Length(S)) and (S[I] <> Quote) and
+ CharExistsL(WordDelims, S[I]) do
+ Inc(I);
+ {if we're not beyond end of S, we're at the start of a word}
+ if I <= Length(S) then
+ Inc(Count);
+ {if not finished, find the end of the current word}
+ if Count <> LongInt(N) then
+ while (I <= Length(S)) and (InQuote or not
+ CharExistsL(WordDelims, S[I])) do begin
+ if S[I] = Quote then
+ InQuote := not InQuote;
+ Inc(I);
+ end
+ else begin
+ Pos := I;
+ Result := True;
+ end;
+ end;
+end;
+
+function ExtractAsciiL(N : Cardinal; const S, WordDelims : String;
+ Quote : Char) : String;
+ {-Given an array of word delimiters, return the N'th word in a string. Any
+ text within Quote characters is counted as one word.}
+var
+ C : Cardinal;
+ I, J : Longint;
+ InQuote : Boolean;
+begin
+ InQuote := False;
+ if AsciiPositionL(N, S, WordDelims, Quote, C) then begin
+ I := C;
+ J := I;
+ {find the end of the current word}
+ while (I <= Length(S)) and ((InQuote)
+ or not CharExistsL(WordDelims, S[I])) do begin
+ if S[I] = Quote then
+ InQuote := not(InQuote);
+ Inc(I);
+ end;
+ SetLength(Result, I-J);
+ Move(S[J], Result[1], I-J);
+ end;
+end;
+
+procedure WordWrapL(const InSt : String; var OutSt, Overlap : String;
+ Margin : Cardinal; PadToMargin : Boolean);
+ {-Wrap a text string at a specified margin.}
+var
+ InStLen : Cardinal;
+ EOS, BOS : Cardinal;
+ Len : Integer; {!!.02}
+begin
+ InStLen := Length(InSt);
+
+{!!.02 - Added }
+ { handle empty string on input }
+ if InStLen = 0 then begin
+ OutSt := '';
+ Overlap := '';
+ Exit;
+ end;
+{!!.02 - End Added }
+
+ {find the end of the output string}
+ if InStLen > Margin then begin
+ {find the end of the word at the margin, if any}
+ EOS := Margin;
+ while (EOS <= InStLen) and (InSt[EOS] <> ' ') do
+ Inc(EOS);
+ if EOS > InStLen then
+ EOS := InStLen;
+
+ {trim trailing blanks}
+ while (EOS > 0) and (InSt[EOS] = ' ') do {!!.04}
+ Dec(EOS);
+
+ if EOS > Margin then begin
+ {look for the space before the current word}
+ while (EOS > 0) and (InSt[EOS] <> ' ') do
+ Dec(EOS);
+
+ {if EOS = 0 then we can't wrap it}
+ if EOS = 0 then
+ EOS := Margin
+ else
+ {trim trailing blanks}
+ while (EOS > 0) and (InSt[EOS] = ' ') do {!!.04}
+ Dec(EOS);
+ end;
+ end else
+ EOS := InStLen;
+
+ {copy the unwrapped portion of the line}
+ if EOS > 0 then begin {!!.04}
+ SetLength(OutSt, EOS);
+ Move(InSt[1], OutSt[1], Length(OutSt) * SizeOf(Char));
+ end; {!!.04}
+
+ {find the start of the next word in the line}
+ BOS := Succ(EOS);
+ while (BOS <= InStLen) and (InSt[BOS] = ' ') do
+ Inc(BOS);
+
+ if BOS > InStLen then
+ SetLength(OverLap, 0)
+ else begin
+ {copy from the start of the next word to the end of the line}
+
+ SetLength(OverLap, InStLen);
+ Move(InSt[BOS], Overlap[1], Succ(InStLen-BOS) * SizeOf(Char));
+ SetLength(OverLap, Succ(InStLen-BOS));
+ end;
+
+ {pad the end of the output string if requested}
+{!!.02 - Rewritten}
+ Len := Length(OutSt);
+ if PadToMargin and (Len < LongInt(Margin)) then begin
+// SetLength(OutSt, Margin);
+// FillChar(OutSt[Succ(Len)], LongInt(Margin)-Length(OutSt), ' ');
+ OutSt := OutSt + StringOfChar(' ', Margin - Length(OutSt));
+ end;
+{!!.02 - End Rewritten}
+end;
+
+ {--------------- String comparison and searching -----------------}
+function CompStringL(const S1, S2 : String) : Integer; register;
+ {-Compare two strings.}
+{$IFDEF FPC}
+begin
+ Result := CompareStr(S1, S2);
+end;
+{$ELSE}
+{$IFDEF UNICODE}
+begin
+ Result := AnsiCompareStr(S1, S2);
+end;
+{$ELSE}
+asm
+ push edi
+ mov edi, edx { EDI points to S2 }
+ push esi
+ mov esi, eax { ESI points to S1 }
+
+ xor edx, edx
+ xor ecx, ecx
+
+ or edi, edi
+ jz @@1
+ mov edx, [edi-StrOffset].LStrRec.Length
+
+@@1:
+ or esi, esi
+ jz @@2
+ mov ecx, [esi-StrOffset].LStrRec.Length
+
+@@2:
+ or eax, -1 { EAX holds temporary result }
+
+ cmp ecx, edx { Compare lengths }
+ je @@EqLen { Lengths equal? }
+ jb @@Comp { Jump if S1 shorter than S1 }
+
+ inc eax { S1 longer than S2 }
+ mov ecx, edx { Length(S2) in CL }
+
+@@EqLen:
+ inc eax { Equal or greater }
+
+@@Comp:
+ or ecx, ecx
+ jz @@Done { Done if either is empty }
+
+ repe cmpsb { Compare until no match or ECX = 0 }
+ je @@Done { If Equal, result ready based on length }
+
+ mov eax, 1
+ ja @@Done { S1 Greater? Return 1 }
+ or eax, -1 { Else S1 Less, Return -1 }
+
+@@Done:
+ pop esi
+ pop edi
+end;
+{$ENDIF}
+{$ENDIF}
+
+function CompUCStringL(const S1, S2 : String) : Integer; register;
+ {-Compare two strings. This compare is not case sensitive.}
+{$IFDEF FPC}
+begin
+ Result := Comparetext(S1, S2);
+end;
+{$ELSE}
+{$IFDEF UNICODE}
+begin
+ Result := AnsiCompareText(S1, S2);
+end;
+{$ELSE}
+asm
+ push ebx { Save registers }
+ push edi
+ push esi
+
+ mov edi, edx { EDI points to S2 }
+ mov esi, eax { ESI points to S1 }
+
+ xor eax, eax
+ xor ecx, ecx
+ xor edx, edx { DL chars from S2 }
+ or ebx, -1
+
+ or edi, edi
+ jz @@1
+ mov eax, [edi-StrOffset].LStrRec.Length
+
+@@1:
+ or esi, esi
+ jz @@2
+ mov ecx, [esi-StrOffset].LStrRec.Length
+
+@@2:
+ cmp ecx, eax { Compare lengths }
+ je @@EqLen { Lengths equal? }
+ jb @@Comp { Jump if S1 shorter than S1 }
+
+ inc ebx { S1 longer than S2 }
+ mov ecx, eax { Shorter length in ECX }
+
+@@EqLen:
+ inc ebx { Equal or greater }
+
+@@Comp:
+ or ecx, ecx
+ jz @@Done { Done if lesser string is empty }
+
+@@Start:
+ xor eax, eax { EAX holds chars from S1 }
+ mov al, [esi] { S1[?] into AL }
+ inc esi
+
+ push ecx { Save registers }
+ push edx
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper
+ pop edx { Restore registers }
+ pop ecx
+
+ mov dl, [edi] { S2[?] into DL }
+ inc edi { Point EDI to next char in S2 }
+ mov dh, al
+ mov al, dl
+ mov dl, dh
+
+ push ecx { Save registers }
+ push edx
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper
+ pop edx { Restore registers }
+ pop ecx
+
+ cmp dl, al { Compare until no match }
+ jne @@Output
+ dec ecx
+ jnz @@Start
+
+ je @@Done { If Equal, result ready based on length }
+
+@@Output:
+ mov ebx, 1
+ ja @@Done { S1 Greater? Return 1 }
+ or ebx, -1 { Else S1 Less, Return -1 }
+
+@@Done:
+ mov eax, ebx { Result into EAX }
+ pop esi { Restore Registers }
+ pop edi
+ pop ebx
+end;
+{$ENDIF}
+{$ENDIF}
+
+function SoundexL(const S : AnsiString) : AnsiString;
+ {-Return 4 character soundex of an input string}
+{$IFDEF FPC}
+begin
+ Result := StrUtils.SoundEx(S);
+end;
+{$ELSE}
+const
+ SoundexTable : array[0..255] of Char =
+ (#0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0,
+ { A B C D E F G H I J K L M }
+ #0, '1', '2', '3', #0, '1', '2', #0, #0, '2', '2', '4', '5',
+ { N O P Q R S T U V W X Y X }
+ '5', #0, '1', '2', '6', '2', '3', #0, '1', #0, '2', #0, '2',
+ #0, #0, #0, #0, #0, #0,
+ { a b c d e f g h i j k l m }
+ #0, '1', '2', '3', #0, '1', '2', #0, #0, '2', '2', '4', '5',
+ { n o p q r s t u v w x y x }
+ '5', #0, '1', '2', '6', '2', '3', #0, '1', #0, '2', #0, '2',
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0);
+begin
+ if S = '' then Exit;
+ SetLength(Result, 4);
+asm
+ push edi
+ mov edi, [Result] { EDI => output string. }
+ mov edi, [edi]
+ push ebx
+ push esi
+
+ mov esi, S { ESI => input string. }
+ mov dword ptr [edi], '0000' { Initialize output string to '0000'. }
+ xor eax, eax
+ mov [edi+4], al { Set null at end of string. }
+
+ mov ecx, [esi-StrOffset].LStrRec.Length
+ or ecx, ecx { Exit if null string. }
+ jz @@Done
+
+ mov al, [esi] { Get first character of input string. }
+ inc esi
+
+ push ecx { Save ECX across call to CharUpper. }
+ push eax { Push Char onto stack for CharUpper. }
+ call CharUpper { Uppercase AL. }
+ pop ecx { Restore saved register. }
+
+ mov [edi], al { Store first output character. }
+ inc edi
+
+ dec ecx { One input character used. }
+ jz @@Done { Was input string one char long?. }
+
+ mov bh, 03h { Output max 3 chars beyond first. }
+ mov edx, offset SoundexTable { EDX => Soundex table. }
+ xor eax, eax { Prepare for address calc. }
+ xor bl, bl { BL will be used to store 'previous char'. }
+
+@@Next:
+ mov al, [esi] { Get next char in AL. }
+ inc esi
+ mov al, [edx+eax] { Get soundex code into AL. }
+ or al, al { Is AL zero? }
+ jz @@NoStore { If yes, skip this char. }
+ cmp bl, al { Is it the same as the previous stored char? }
+ je @@NoStore { If yes, skip this char. }
+ mov [edi], al { Store char to Dest. }
+ inc edi
+ dec bh { Decrement output counter. }
+ jz @@Done { If zero, we're done. }
+ mov bl, al { New previous character. }
+
+@@NoStore:
+ dec ecx { Decrement input counter. }
+ jnz @@Next
+
+@@Done:
+ pop esi
+ pop ebx
+ pop edi
+end;
+end;
+{$ENDIF}
+
+(* ---------------- deactivated for Lazarus
+
+function MakeLetterSetL(const S : AnsiString) : Longint; register;
+ {-Return a bit-mapped long storing the individual letters contained in S.}
+asm
+ push ebx { Save registers }
+ push esi
+
+ mov esi, eax { ESI => string }
+ xor ecx, ecx { Zero ECX }
+ xor edx, edx { Zero EDX }
+ {or edx, edx}
+ or eax, eax
+ jz @@Exit
+ xor eax, eax { Zero EAX }
+ add ecx, [esi-StrOffset].LStrRec.Length
+ jz @@Exit { Done if ECX is 0 }
+
+@@Next:
+ mov al, [esi] { EAX has next char in S }
+ inc esi
+
+ push ecx { Save registers }
+ push edx
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper
+ pop edx { Restore registers }
+ pop ecx
+
+ sub eax, 'A' { Convert to bit number }
+ cmp eax, 'Z'-'A' { Was char in range 'A'..'Z'? }
+ ja @@Skip { Skip it if not }
+
+ mov ebx, eax { Exchange EAX and ECX }
+ mov eax, ecx
+ mov ecx, ebx
+ ror edx, cl
+ or edx, 01h { Set appropriate bit }
+ rol edx, cl
+ mov ebx, eax { Exchange EAX and ECX }
+ mov eax, ecx
+ mov ecx, ebx
+
+@@Skip:
+ dec ecx
+ jnz @@Next { Get next character }
+
+@@Exit:
+ mov eax, edx { Move EDX to result }
+ pop esi { Restore registers }
+ pop ebx
+end;
+
+{$IFDEF UNICODE}
+procedure BMMakeTableL(const MatchString : UnicodeString; var BT : BTable);
+begin
+ // Do nothing until BMSearchL is fixed
+{var
+ I: Integer;
+ Len: Byte;
+begin
+ Len := Length(MatchString);
+ if Len > 255 then
+ Len := 255;
+
+ FillChar(BT, SizeOf(BT), Len);
+ for I := 1 to Length(MatchString) - 1 do
+ BT[Word(MatchString[I])] := Len - I; }
+end;
+{$ELSE}
+procedure BMMakeTableL(const MatchString : AnsiString; var BT : BTable); register;
+ {-Build a Boyer-Moore link table}
+asm
+ push edi { Save registers because they will be changed }
+ push esi
+ mov esi, eax { Move EAX to ESI }
+ push ebx
+
+ or eax, eax
+ jz @@MTDone
+
+ xor eax, eax { Zero EAX }
+ mov ecx, [esi-StrOffset].LStrRec.Length
+ cmp ecx, 0FFh { If ECX > 255, force to 255 }
+ jbe @@1
+ mov ecx, 0FFh
+
+@@1:
+ mov ch, cl { Duplicate CL in CH }
+ mov eax, ecx { Fill each byte in EAX with length }
+ shl eax, 16
+ mov ax, cx
+ mov edi, edx { Point to the table }
+ mov ecx, 64 { Fill table bytes with length }
+ rep stosd
+ cmp al, 1 { If length <= 1, we're done }
+ jbe @@MTDone
+ mov edi, edx { Reset EDI to beginning of table }
+ xor ebx, ebx { Zero EBX }
+ mov cl, al { Restore CL to length of string }
+ dec ecx
+
+@@MTNext:
+ mov al, [esi] { Load table with positions of letters }
+ mov bl, al { that exist in the search string }
+ inc esi
+ mov [edi+ebx], cl
+ dec cl
+ jnz @@MTNext
+
+@@MTDone:
+ pop ebx { Restore registers }
+ pop esi
+ pop edi
+end;
+{$ENDIF}
+
+{$IFDEF UNICODE}
+function BMSearchL(var Buffer; BufLength: Cardinal; var BT: BTable; // TODO-UNICODE
+ const MatchString : String; out Pos : Cardinal) : Boolean;
+var
+ BufPtr: PChar;
+// s: string;
+// Len: Integer;
+// I,J,K: Integer;
+begin
+ // the commented code doesn't work correctly, so use a simple Pos for now
+ BufPtr := PChar(@Buffer);
+ Pos := System.Pos(MatchString, BufPtr);
+ Exit(Pos <> 0);
+end;
+{$ELSE}
+function BMSearchL(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : AnsiString; var Pos : Cardinal) : Boolean; register;
+ {-Use the Boyer-Moore search method to search a buffer for a string.}
+var
+ BufPtr : Pointer;
+asm
+ push edi { Save registers since we will be changing }
+ push esi
+ push ebx
+
+ mov BufPtr, eax { Copy Buffer to local variable and ESI }
+ mov esi, MatchString { Set ESI to beginning of MatchString }
+ or esi, esi
+ jz @@BMSNotFound
+ mov edi, eax
+ mov ebx, ecx { Copy BT ptr to EBX }
+ mov ecx, edx { Length of buffer to ECX }
+ xor eax, eax { Zero EAX }
+
+ mov edx, [esi-StrOffset].LStrRec.Length
+ cmp edx, 0FFh { If EDX > 255, force to 255 }
+ jbe @@1
+ mov edx, 0FFh
+
+@@1:
+ cmp dl, 1 { Check to see if we have a trivial case }
+ ja @@BMSInit { If Length(MatchString) > 1 do BM search }
+ jb @@BMSNotFound { If Length(MatchString) = 0 we're done }
+
+ mov al,[esi] { If Length(MatchString) = 1 do a REPNE SCASB }
+ mov ebx, edi
+ repne scasb
+ jne @@BMSNotFound { No match during REP SCASB }
+ mov esi, Pos { Set position in Pos }
+ {dec edi} { Found, calculate position }
+ sub edi, ebx
+ mov eax, 1 { Set result to True }
+ mov [esi], edi
+ jmp @@BMSDone { We're done }
+
+@@BMSInit:
+ dec edx { Set up for BM Search }
+ add esi, edx { Set ESI to end of MatchString }
+ add ecx, edi { Set ECX to end of buffer }
+ add edi, edx { Set EDI to first check point }
+ std { Backward string ops }
+ mov dh, [esi] { Set DH to character we'll be looking for }
+ dec esi { Dec ESI in prep for BMSFound loop }
+ jmp @@BMSComp { Jump to first comparison }
+
+@@BMSNext:
+ mov al, [ebx+eax] { Look up skip distance from table }
+ add edi, eax { Skip EDI ahead to next check point }
+
+@@BMSComp:
+ cmp edi, ecx { Have we reached end of buffer? }
+ jae @@BMSNotFound { If so, we're done }
+ mov al, [edi] { Move character from buffer into AL for comparison }
+ cmp dh, al { Compare }
+ jne @@BMSNext { If not equal, go to next checkpoint }
+
+ push ecx { Save ECX }
+ dec edi
+ xor ecx, ecx { Zero ECX }
+ mov cl, dl { Move Length(MatchString) to ECX }
+ repe cmpsb { Compare MatchString to buffer }
+ je @@BMSFound { If equal, string is found }
+
+ mov al, dl { Move Length(MatchString) to AL }
+ sub al, cl { Calculate offset that string didn't match }
+ add esi, eax { Move ESI back to end of MatchString }
+ add edi, eax { Move EDI to pre-string compare location }
+ inc edi
+ mov al, dh { Move character back to AL }
+ pop ecx { Restore ECX }
+ jmp @@BMSNext { Do another compare }
+
+@@BMSFound: { EDI points to start of match }
+ mov edx, BufPtr { Move pointer to buffer into EDX }
+ mov esi, Pos
+ sub edi, edx { Calculate position of match }
+ mov eax, edi
+ inc eax
+ inc eax
+ mov [esi], eax { Set Pos to position of match }
+ mov eax, 1 { Set result to True }
+ pop ecx { Restore ESP }
+ jmp @@BMSDone
+
+@@BMSNotFound:
+ xor eax, eax { Set result to False }
+
+@@BMSDone:
+ cld { Restore direction flag }
+ pop ebx { Restore registers }
+ pop esi
+ pop edi
+end;
+{$ENDIF}
+
+{$IFDEF UNICODE}
+function BMSearchUCL(var Buffer; BufLength : Cardinal; var BT : BTable; // TODO-UNICODE
+ const MatchString : String ; var Pos : Cardinal) : Boolean; register;
+var
+ BufPtr: PChar;
+begin
+ BufPtr := PChar(@Buffer);
+ Pos := System.Pos(AnsiUpperCase(MatchString), AnsiUpperCase(BufPtr));
+ Exit(Pos <> 0);
+end;
+{$ELSE}
+
+function BMSearchUCL(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : AnsiString ; var Pos : Cardinal) : Boolean; register;
+ {-Use the Boyer-Moore search method to search a buffer for a string. This
+ search is not case sensitive.}
+var
+ BufPtr : Pointer;
+asm
+ push edi { Save registers since we will be changing }
+ push esi
+ push ebx
+
+ mov BufPtr, eax { Copy Buffer to local variable and ESI }
+ mov esi, MatchString { Set ESI to beginning of MatchString }
+ or esi, esi
+ jz @@BMSNotFound
+ mov edi, eax
+ mov ebx, ecx { Copy BT ptr to EBX }
+ mov ecx, edx { Length of buffer to ECX }
+ xor eax, eax { Zero EAX }
+
+ mov edx, [esi-StrOffset].LStrRec.Length
+ cmp edx, 0FFh { If EDX > 255, force to 255 }
+ jbe @@1
+ mov edx, 0FFh
+
+@@1:
+ or dl, dl { Check to see if we have a trivial case }
+ jz @@BMSNotFound { If Length(MatchString) = 0 we're done }
+
+@@BMSInit:
+ dec edx { Set up for BM Search }
+ add esi, edx { Set ESI to end of MatchString }
+ add ecx, edi { Set ECX to end of buffer }
+ add edi, edx { Set EDI to first check point }
+ mov dh, [esi] { Set DH to character we'll be looking for }
+ dec esi { Dec ESI in prep for BMSFound loop }
+ jmp @@BMSComp { Jump to first comparison }
+
+@@BMSNext:
+ mov al, [ebx+eax] { Look up skip distance from table }
+ add edi, eax { Skip EDI ahead to next check point }
+
+@@BMSComp:
+ cmp edi, ecx { Have we reached end of buffer? }
+ jae @@BMSNotFound { If so, we're done }
+
+ push ebx { Save registers }
+ push ecx
+ push edx
+ mov al, [edi] { Move character from buffer into AL for comparison }
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper
+ pop edx { Restore registers }
+ pop ecx
+ pop ebx
+
+ cmp dh, al { Compare }
+ jne @@BMSNext { If not equal, go to next checkpoint }
+
+ push ecx { Save ECX }
+ dec edi
+ xor ecx, ecx { Zero ECX }
+ mov cl, dl { Move Length(MatchString) to ECX }
+ jecxz @@BMSFound { If ECX is zero, string is found }
+
+@@StringComp:
+ xor eax, eax
+ mov al, [edi] { Get char from buffer }
+ dec edi { Dec buffer index }
+
+ push ebx { Save registers }
+ push ecx
+ push edx
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper
+ pop edx { Restore registers }
+ pop ecx
+ pop ebx
+
+ mov ah, al { Move buffer char to AH }
+ mov al, [esi] { Get MatchString char }
+ dec esi
+ cmp ah, al { Compare }
+ loope @@StringComp { OK? Get next character }
+ je @@BMSFound { Matched! }
+
+ xor ah, ah { Zero AH }
+ mov al, dl { Move Length(MatchString) to AL }
+ sub al, cl { Calculate offset that string didn't match }
+ add esi, eax { Move ESI back to end of MatchString }
+ add edi, eax { Move EDI to pre-string compare location }
+ inc edi
+ mov al, dh { Move character back to AL }
+ pop ecx { Restore ECX }
+ jmp @@BMSNext { Do another compare }
+
+@@BMSFound: { EDI points to start of match }
+ mov edx, BufPtr { Move pointer to buffer into EDX }
+ mov esi, Pos
+ sub edi, edx { Calculate position of match }
+ mov eax, edi
+ inc eax
+ inc eax
+ mov [esi], eax { Set Pos to position of match }
+ mov eax, 1 { Set result to True }
+ pop ecx { Restore ESP }
+ jmp @@BMSDone
+
+@@BMSNotFound:
+ xor eax, eax { Set result to False }
+
+@@BMSDone:
+ pop ebx { Restore registers }
+ pop esi
+ pop edi
+end;
+{$ENDIF}
+
+*)
+ {--------------- DOS pathname parsing -----------------}
+
+function DefaultExtensionL(const Name, Ext : String) : String;
+ {-Return a file name with a default extension attached.}
+var
+ DotPos : Cardinal;
+begin
+ if HasExtensionL(Name, DotPos) then
+ Result := Name
+ else if Name = '' then
+ Result := ''
+ else
+ Result := Name + '.' + Ext;
+end;
+
+function ForceExtensionL(const Name, Ext : String) : String;
+ {-Force the specified extension onto the file name.}
+var
+ DotPos : Cardinal;
+begin
+ if HasExtensionL(Name, DotPos) then
+ Result := System.Copy(Name, 1, DotPos) + Ext
+ else if Name = '' then
+ Result := ''
+ else
+ Result := Name + '.' + Ext;
+end;
+
+function JustFilenameL(const PathName : String) : String;
+ {-Return just the filename and extension of a pathname.}
+var
+ I : Cardinal;
+begin
+ Result := '';
+ if PathName = '' then Exit;
+ I := Succ(Cardinal(Length(PathName)));
+ repeat
+ Dec(I);
+ until (I = 0) or (PathName[I] in DosDelimSet); {!!.01}
+ Result := System.Copy(PathName, Succ(I), StMaxFileLen);
+end;
+
+function JustNameL(const PathName : String) : String;
+ {-Return just the filename (no extension, path, or drive) of a pathname.}
+var
+ DotPos : Cardinal;
+ S : AnsiString;
+begin
+ S := JustFileNameL(PathName);
+ if HasExtensionL(S, DotPos) then
+ S := System.Copy(S, 1, DotPos-1);
+ Result := S;
+end;
+
+function JustExtensionL(const Name : String) : String;
+ {-Return just the extension of a pathname.}
+var
+ DotPos : Cardinal;
+begin
+ if HasExtensionL(Name, DotPos) then
+ Result := System.Copy(Name, Succ(DotPos), StMaxFileLen)
+ else
+ Result := '';
+end;
+
+function JustPathnameL(const PathName : String) : String;
+ {-Return just the drive and directory portion of a pathname.}
+var
+ I : Cardinal;
+begin
+ if PathName = '' then Exit;
+
+ I := Succ(Cardinal(Length(PathName)));
+ repeat
+ Dec(I);
+ until (I = 0) or (PathName[I] in DosDelimSet); {!!.01}
+
+ if I = 0 then
+ {Had no drive or directory name}
+ SetLength(Result, 0)
+ else if I = 1 then
+ {Either the root directory of default drive or invalid pathname}
+ Result := PathName[1]
+ else if (PathName[I] = '\') then begin
+ if PathName[Pred(I)] = ':' then
+ {Root directory of a drive, leave trailing backslash}
+ Result := System.Copy(PathName, 1, I)
+ else
+ {Subdirectory, remove the trailing backslash}
+ Result := System.Copy(PathName, 1, Pred(I));
+ end else
+ {Either the default directory of a drive or invalid pathname}
+ Result := System.Copy(PathName, 1, I);
+end;
+
+function AddBackSlashL(const DirName : String) : String;
+ {-Add a default backslash to a directory name}
+begin
+ Result := DirName;
+ if (Length(Result) = 0) then
+ Exit;
+ if ((Length(Result) = 2) and (Result[2] = ':')) or
+ ((Length(Result) > 2) and (Result[Length(Result)] <> '\')) then
+ Result := Result + '\';
+end;
+
+function CleanFileNameL(const FileName : AnsiString) : AnsiString;
+ {-Return filename with at most 8 chars of name and 3 of extension}
+var
+ DotPos : Cardinal;
+ NameLen : Word;
+begin
+ if HasExtensionL(FileName, DotPos) then begin
+ {Take the first 8 chars of name and first 3 chars of extension}
+ NameLen := Pred(DotPos);
+ if NameLen > 8 then
+ NameLen := 8;
+ Result := System.Copy(FileName, 1, NameLen)+System.Copy(FileName, DotPos, 4);
+ end else
+ {Take the first 8 chars of name}
+ Result := System.Copy(FileName, 1, 8);
+end;
+
+function CleanPathNameL(const PathName : String) : String;
+ {-Return a pathname cleaned up as DOS does it.}
+var
+ I : Cardinal;
+ S : String;
+begin
+ SetLength(Result, 0);
+ S := PathName;
+
+ I := Succ(Cardinal(Length(S)));
+ repeat
+ dec(I);
+ if I > 2 then
+ if (S[I] = '\') and (S[I-1] = '\') then
+ if (S[I-2] <> ':') then
+ System.Delete(S, I, 1);
+ until I <= 0;
+
+ I := Succ(Cardinal(Length(S)));
+ repeat
+ {Get the next directory or drive portion of pathname}
+ repeat
+ Dec(I);
+ until (I = 0) or (S[I] in DosDelimSet); {!!.02}
+
+ {Clean it up and prepend it to output string}
+ Result := CleanFileNameL(System.Copy(S, Succ(I), StMaxFileLen)) + Result;
+ if I > 0 then begin
+ Result := S[I] + Result;
+ System.Delete(S, I, 255);
+ end;
+ until I <= 0;
+
+end;
+
+function HasExtensionL(const Name : String; var DotPos : Cardinal) : Boolean;
+ {-Determine if a pathname contains an extension and, if so, return the
+ position of the dot in front of the extension.}
+var
+ I : Cardinal;
+begin
+ DotPos := 0;
+ for I := Length(Name) downto 1 do
+ if (Name[I] = '.') and (DotPos = 0) then
+ DotPos := I;
+ Result := (DotPos > 0)
+ and not CharExistsL(System.Copy(Name, Succ(DotPos), StMaxFileLen), '\');
+end;
+
+ {------------------ Formatting routines --------------------}
+
+
+function CommaizeChL(L : Longint; Ch : Char) : String;
+ {-Convert a long integer to a string with Ch in comma positions}
+var
+ Temp : string;
+ NumCommas, I, Len : Cardinal;
+ Neg : Boolean;
+begin
+ SetLength(Temp, 1);
+ Temp[1] := Ch;
+ if L < 0 then begin
+ Neg := True;
+ L := Abs(L);
+ end else
+ Neg := False;
+ Result := Long2StrL(L);
+ Len := Length(Result);
+ NumCommas := (Pred(Len)) div 3;
+ for I := 1 to NumCommas do
+ System.Insert(Temp, Result, Succ(Len-(I * 3)));
+ if Neg then
+ System.Insert('-', Result, 1);
+end;
+
+function CommaizeL(L : LongInt) : String;
+ {-Convert a long integer to a string with commas}
+begin
+ Result := CommaizeChL(L, ',');
+end;
+
+function FormPrimL(const Mask : String; R : TstFloat; const LtCurr, RtCurr : String;
+ Sep, DecPt : Char; AssumeDP : Boolean) : String;
+ {-Returns a formatted string with digits from R merged into the Mask}
+const
+ Blank = 0;
+ Asterisk = 1;
+ Zero = 2;
+const
+{$IFOPT N+}
+ MaxPlaces = 18;
+{$ELSE}
+ MaxPlaces = 11;
+{$ENDIF}
+ FormChars : string = '#@*$-+,.';
+ PlusArray : array[Boolean] of Char = ('+', '-');
+ MinusArray : array[Boolean] of Char = (' ', '-');
+ FillArray : array[Blank..Zero] of Char = (' ', '*', '0');
+var
+ S : string; {temporary string}
+ Filler : Integer; {char for unused digit slots: ' ', '*', '0'}
+ WontFit, {true if number won't fit in the mask}
+ AddMinus, {true if minus sign needs to be added}
+ Dollar, {true if floating dollar sign is desired}
+ Negative : Boolean; {true if B is negative}
+ StartF, {starting point of the numeric field}
+ EndF : Longint; {end of numeric field}
+ RtChars, {# of chars to add to right}
+ LtChars, {# of chars to add to left}
+ DotPos, {position of '.' in Mask}
+ Digits, {total # of digits}
+ Blanks, {# of blanks returned by Str}
+ Places, {# of digits after the '.'}
+ FirstDigit, {pos. of first digit returned by Str}
+ Extras, {# of extra digits needed for special cases}
+ DigitPtr : Byte; {pointer into temporary string of digits}
+ I : Cardinal;
+label
+ EndFound,
+ RedoCase,
+ Done;
+begin
+ {assume decimal point at end?}
+ Result := Mask;
+ if (not AssumeDP) and (not CharExistsL(Result, '.')) then
+ AssumeDP := true;
+ if AssumeDP and (Result <> '') then begin
+ SetLength(Result, Succ(Length(Result)));
+ Result[Length(Result)] := '.';
+ end;
+
+ RtChars := 0;
+ LtChars := 0;
+
+ {check for empty string}
+ if Length(Result) = 0 then
+ goto Done;
+
+ {initialize variables}
+ Filler := Blank;
+ DotPos := 0;
+ Places := 0;
+ Digits := 0;
+ Dollar := False;
+ AddMinus := True;
+ StartF := 1;
+
+ {store the sign of the real and make it positive}
+ Negative := (R < 0);
+ R := Abs(R);
+
+ {strip and count c's}
+ for I := Length(Result) downto 1 do begin
+ if Result[I] = 'C' then begin
+ Inc(RtChars);
+ System.Delete(Result, I, 1);
+ end else if Result[I] = 'c' then begin
+ Inc(LtChars);
+ System.Delete(Result, I, 1);
+ end;
+ end;
+
+ {find the starting point for the field}
+ while (StartF <= Length(Result))
+ {and (System.Pos(Result[StartF], FormChars) = 0) do}
+ and not CharExistsL(FormChars, Result[StartF]) do
+ Inc(StartF);
+ if StartF > Length(Result) then
+ goto Done;
+
+ {find the end point for the field}
+ EndF := StartF;
+ for I := StartF to Length(Result) do begin
+ EndF := I;
+ case Result[EndF] of
+ '*' : Filler := Asterisk;
+ '@' : Filler := Zero;
+ '$' : Dollar := True;
+ '-',
+ '+' : AddMinus := False;
+ '#' : {ignore} ;
+ ',',
+ '.' : DotPos := EndF;
+ else
+ goto EndFound;
+ end;
+ {Inc(EndF);}
+ end;
+
+ {if we get here at all, the last char was part of the field}
+ Inc(EndF);
+
+EndFound:
+ {if we jumped to here instead, it wasn't}
+ Dec(EndF);
+
+ {disallow Dollar if Filler is Zero}
+ if Filler = Zero then
+ Dollar := False;
+
+ {we need an extra slot if Dollar is True}
+ Extras := Ord(Dollar);
+
+ {get total # of digits and # after the decimal point}
+ for I := StartF to EndF do
+ case Result[I] of
+ '#', '@',
+ '*', '$' :
+ begin
+ Inc(Digits);
+ if (I > DotPos) and (DotPos <> 0) then
+ Inc(Places);
+ end;
+ end;
+
+ {need one more 'digit' if Places > 0}
+ Inc(Digits, Ord(Places > 0));
+
+ {also need an extra blank if (1) Negative is true, and (2) Filler is Blank,
+ and (3) AddMinus is true}
+ if Negative and AddMinus and (Filler = Blank) then
+ Inc(Extras)
+ else
+ AddMinus := False;
+
+ {translate the real to a string}
+ Str(R:Digits:Places, S);
+
+ {add zeros that Str may have left out}
+ if Places > MaxPlaces then begin
+ I := Length(S);
+// SetLength(S, LongInt(I) + (Places-MaxPlaces));
+// FillChar(S[Succ(I)], Places-MaxPlaces, '0');
+ S := StringOfChar('0', Places-MaxPlaces) + S;
+ while (Length(S) > Digits) and (S[1] = ' ') do
+ System.Delete(S, 1, 1);
+ end;
+
+ {count number of initial blanks}
+ Blanks := 1;
+ while S[Blanks] = ' ' do
+ Inc(Blanks);
+ FirstDigit := Blanks;
+ Dec(Blanks);
+
+ {the number won't fit if (a) S is longer than Digits or (b) the number of
+ initial blanks is less than Extras}
+ WontFit := (Length(S) > Digits) or (Blanks < Extras);
+
+ {if it won't fit, fill decimal slots with '*'}
+ if WontFit then begin
+ for I := StartF to EndF do
+ case Result[I] of
+ '#', '@', '*', '$' : Result[I] := '*';
+ '+' : Result[I] := PlusArray[Negative];
+ '-' : Result[I] := MinusArray[Negative];
+ end;
+ goto Done;
+ end;
+
+ {fill initial blanks in S with Filler; insert floating dollar sign}
+ if Blanks > 0 then begin
+ //FillChar(S[1], Blanks, FillArray[Filler]);
+ Delete(S, 1, Blanks);
+ S := StringOfChar(FillArray[Filler], Blanks) + S;
+
+ {put floating dollar sign in last blank slot if necessary}
+ if Dollar then begin
+ S[Blanks] := LtCurr[1];
+ Dec(Blanks);
+ end;
+
+ {insert a minus sign if necessary}
+ if AddMinus then
+ S[Blanks] := '-';
+ end;
+
+ {put in the digits / signs}
+ DigitPtr := Length(S);
+ for I := EndF downto StartF do begin
+RedoCase:
+ case Result[I] of
+ '#', '@', '*', '$' :
+ if DigitPtr <> 0 then begin
+ Result[I] := S[DigitPtr];
+ Dec(DigitPtr);
+ if (DigitPtr <> 0) and (S[DigitPtr] = '.') then {!!.01}
+ Dec(DigitPtr);
+ end
+ else
+ Result[I] := FillArray[Filler];
+ ',' :
+ begin
+ Result[I] := Sep;
+ if (I < DotPos) and (DigitPtr < FirstDigit) then begin
+ Result[I] := '#';
+ goto RedoCase;
+ end;
+ end;
+ '.' :
+ begin
+ Result[I] := DecPt;
+ if (I < DotPos) and (DigitPtr < FirstDigit) then begin
+ Result[I] := '#';
+ goto RedoCase;
+ end;
+ end;
+ '+' : Result[I] := PlusArray[Negative];
+ '-' : Result[I] := MinusArray[Negative];
+ end;
+ end;
+
+Done:
+ if AssumeDP then
+ SetLength(Result, Pred(Length(Result)));
+ if RtChars > 0 then begin
+ S := RtCurr;
+ if Length(S) > RtChars then
+ SetLength(S, RtChars)
+ else
+ S := LeftPadL(S, RtChars);
+ Result := Result + S;
+ end;
+ if LtChars > 0 then begin
+ S := LtCurr;
+ if Length(S) > LtChars then
+ SetLength(S, LtChars)
+ else
+ S := PadL(S, LtChars);
+ Result := S + Result;
+ end;
+end;
+
+function FloatFormL(const Mask : String ; R : TstFloat ; const LtCurr,
+ RtCurr : String ; Sep, DecPt : Char) : String;
+ {-Return a formatted string with digits from R merged into mask.}
+begin
+ Result := FormPrimL(Mask, R, LtCurr, RtCurr, Sep, DecPt, False);
+end;
+
+function LongIntFormL(const Mask : String ; L : LongInt ; const LtCurr,
+ RtCurr : String ; Sep : Char) : String;
+ {-Return a formatted string with digits from L merged into mask.}
+begin
+ Result := FormPrimL(Mask, L, LtCurr, RtCurr, Sep, '.', True);
+end;
+
+function StrChPosL(const P : String; C : Char; var Pos : Cardinal) : Boolean;
+ {-Return the position of a specified character within a string.}
+{$IFDEF UNICODE}
+begin
+ Pos := System.Pos(C, P);
+ Result := Pos <> 0;
+end;
+{$ELSE}
+asm
+ push ebx { Save registers }
+ push edi
+
+ or eax, eax { Protect against null string }
+ jz @@NotFound
+
+ xor edi, edi { Zero counter }
+ mov ebx, [eax-StrOffset].LStrRec.Length { Get input length }
+
+@@Loop:
+ inc edi { Increment counter }
+ cmp [eax], dl { Did we find it? }
+ jz @@Found
+ inc eax { Increment pointer }
+
+ cmp edi, ebx { End of string? }
+ jnz @@Loop { If not, loop }
+
+@@NotFound:
+ xor eax, eax { Not found, zero EAX for False }
+ mov [ecx], eax
+ jmp @@Done
+
+@@Found:
+ mov [ecx], edi { Set Pos }
+ mov eax, 1 { Set EAX to True }
+
+@@Done:
+ pop edi { Restore registers }
+ pop ebx
+end;
+{$ENDIF}
+
+function StrStPosL(const P, S : String; var Pos : Cardinal) : Boolean;
+ {-Return the position of a specified substring within a string.}
+begin
+ Pos := System.Pos(S, P);
+ Result := Pos <> 0;
+end;
+
+function StrStCopyL(const S : String; Pos, Count : Cardinal) : String;
+ {-Copy characters at a specified position in a string.}
+begin
+ Result := System.Copy(S, Pos, Count);
+end;
+
+function StrChInsertL(const S : String; C : Char; Pos : Cardinal) : String;
+var
+ Temp : string;
+begin
+ SetLength(Temp, 1);
+ Temp[1] := C;
+ Result := S;
+ System.Insert(Temp, Result, Pos);
+end;
+
+function StrStInsertL(const S1, S2 : String; Pos : Cardinal) : String;
+ {-Insert a string into another string at a specified position.}
+begin
+ Result := S1;
+ System.Insert(S2, Result, Pos);
+end;
+
+function StrChDeleteL(const S : String; Pos : Cardinal) : String;
+ {-Delete the character at a specified position in a string.}
+begin
+ Result := S;
+ System.Delete(Result, Pos, 1);
+end;
+
+function StrStDeleteL(const S : String; Pos, Count : Cardinal) : String;
+ {-Delete characters at a specified position in a string.}
+begin
+ Result := S;
+ System.Delete(Result, Pos, Count);
+end;
+
+
+{----------------------------------------------------------------------------}
+
+function CopyLeftL(const S : String; Len : Cardinal) : String;
+ {-Return the left Len characters of a string}
+begin
+ if (Len < 1) or (S = '') then
+ Result := ''
+ else
+ Result := Copy(S, 1, Len);
+end;
+
+{----------------------------------------------------------------------------}
+
+function CopyMidL(const S : String; First, Len : Cardinal) : String;
+ {-Return the mid part of a string}
+begin
+ if (LongInt(First) > Length(S)) or (LongInt(Len) < 1) or (S = '') then
+ Result := ''
+ else
+ Result := Copy(S, First, Len);
+end;
+
+{----------------------------------------------------------------------------}
+
+function CopyRightL(const S : String; First : Cardinal) : String;
+ {-Return the right Len characters of a string}
+begin
+ if (LongInt(First) > Length(S)) or (First < 1) or (S = '') then
+ Result := ''
+ else
+ Result := Copy(S, First, Length(S));
+end;
+
+{----------------------------------------------------------------------------}
+
+function CopyRightAbsL(const S : String; NumChars : Cardinal) : String;
+ {-Return NumChar characters starting from end}
+begin
+ if (Cardinal(Length(S)) > NumChars) then
+ Result := Copy(S, (Cardinal(Length(S)) - NumChars)+1, NumChars)
+ else
+ Result := S;
+end;
+
+{----------------------------------------------------------------------------}
+
+function WordPosL(const S, WordDelims, AWord : String;
+ N : Cardinal; var Position : Cardinal) : Boolean;
+ {-returns the Nth instance of a given word within a string}
+var
+ TmpStr : String;
+ Len,
+ I,
+ P1,
+ P2 : Cardinal;
+begin
+ if (S = '') or (AWord = '') or (pos(AWord, S) = 0) or (N < 1) then begin
+ Result := False;
+ Position := 0;
+ Exit;
+ end;
+
+ Result := False;
+ Position := 0;
+
+ TmpStr := S;
+ I := 0;
+ Len := Length(AWord);
+ P1 := pos(AWord, TmpStr);
+
+ while (P1 > 0) and (Length(TmpStr) > 0) do begin
+ P2 := P1 + pred(Len);
+ if (P1 = 1) then begin
+ if (pos(TmpStr[P2+1], WordDelims) > 0) then begin
+ Inc(I);
+ end else
+ System.Delete(TmpStr, 1, P2);
+ end else if (pos(TmpStr[P1-1], WordDelims) > 0) and
+// ((pos(TmpStr[P2+1], WordDelims) > 0) or {!!.02}
+// (LongInt(P2+1) = Length(TmpStr))) then begin {!!.02}
+ ((LongInt(P2+1) >= Length(TmpStr)) or {!!.02}
+ (pos(TmpStr[P2+1], WordDelims) > 0)) then begin {!!.02}
+ Inc(I);
+ end else if ((LongInt(P1 + pred(Len))) = Length(TmpStr)) then begin
+ if (P1 > 1) and (pos(TmpStr[P1-1], WordDelims) > 0) then
+ Inc(I);
+ end;
+
+ if (I = N) then begin
+ Result := True;
+ Position := Position + P1;
+ Exit;
+ end;
+ System.Delete(TmpStr, 1, P2);
+ Position := Position + P2;
+ P1 := pos(AWord, TmpStr);
+ end;
+end;
+
+
+{----------------------------------------------------------------------------}
+
+function CopyFromNthWordL(const S, WordDelims : String;
+ const AWord : String; N : Cardinal; {!!.02}
+ var SubString : String) : Boolean;
+var
+ P : Cardinal;
+begin
+ if (WordPosL(S, WordDelims, AWord, N, P)) then begin
+ SubString := Copy(S, P, Length(S));
+ Result := True;
+ end else begin
+ SubString := '';
+ Result := False;
+ end;
+end;
+
+{----------------------------------------------------------------------------}
+
+function DeleteFromNthWordL(const S, WordDelims : String;
+ const AWord : String; N : Cardinal; {!!.02}
+ var SubString : String) : Boolean;
+var
+ P : Cardinal;
+begin
+ SubString := S;
+ if (WordPosL(S, WordDelims, AWord, N, P)) then begin
+ Result := True;
+ SubString := Copy(S, 1, P-1);
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+end;
+
+{----------------------------------------------------------------------------}
+
+function CopyFromToWordL(const S, WordDelims, Word1, Word2 : String;
+ N1, N2 : Cardinal;
+ var SubString : String) : Boolean;
+var
+ P1,
+ P2 : Cardinal;
+begin
+ if (WordPosL(S, WordDelims, Word1, N1, P1)) then begin
+ if (WordPosL(S, WordDelims, Word2, N2, P2)) then begin
+ Dec(P2);
+ if (P2 > P1) then begin
+ Result := True;
+ SubString := Copy(S, P1, P2-P1);
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+end;
+
+{----------------------------------------------------------------------------}
+
+function DeleteFromToWordL(const S, WordDelims, Word1, Word2 : String;
+ N1, N2 : Cardinal;
+ var SubString : String) : Boolean;
+var
+ P1,
+ P2 : Cardinal;
+begin
+ SubString := S;
+ if (WordPosL(S, WordDelims, Word1, N1, P1)) then begin
+ if (WordPosL(S, WordDelims, Word2, N2, P2)) then begin
+ Dec(P2);
+ if (P2 > P1) then begin
+ Result := True;
+ System.Delete(SubString, P1, P2-P1+1);
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+end;
+
+{----------------------------------------------------------------------------}
+
+function CopyWithinL(const S, Delimiter : String;
+ Strip : Boolean) : String;
+var
+ P1,
+ P2 : Cardinal;
+ TmpStr : String;
+begin
+ if (S = '') or (Delimiter = '') or (pos(Delimiter, S) = 0) then
+ Result := ''
+ else begin
+ if (StrStPosL(S, Delimiter, P1)) then begin
+ TmpStr := Copy(S, LongInt(P1) + Length(Delimiter), Length(S));
+ if StrStPosL(TmpStr, Delimiter, P2) then begin
+ Result := Copy(TmpStr, 1, P2-1);
+ if (not Strip) then
+ Result := Delimiter + Result + Delimiter;
+ end else begin
+ Result := TmpStr;
+ if (not Strip) then
+ Result := Delimiter + Result;
+ end;
+ end;
+ end;
+end;
+
+{----------------------------------------------------------------------------}
+
+function DeleteWithinL(const S, Delimiter : String) : String;
+var
+ P1,
+ P2 : Cardinal;
+ TmpStr : String;
+begin
+ if (S = '') or (Delimiter = '') or (pos(Delimiter, S) = 0) then
+ Result := ''
+ else begin
+ if (StrStPosL(S, Delimiter, P1)) then begin
+ TmpStr := Copy(S, LongInt(P1) + Length(Delimiter), Length(S));
+ if (pos(Delimiter, TmpStr) = 0) then
+ Result := Copy(S, 1, P1-1)
+ else begin
+ if (StrStPosL(TmpStr, Delimiter, P2)) then begin
+ Result := S;
+ P2 := LongInt(P2) + (2*Length(Delimiter));
+ System.Delete(Result, P1, P2);
+ end;
+ end;
+ end;
+ end;
+end;
+
+{----------------------------------------------------------------------------}
+
+function ReplaceWordL(const S, WordDelims, OldWord, NewWord : String;
+ N : Cardinal;
+ var Replacements : Cardinal) : String;
+var
+ I,
+ C,
+ P1 : Cardinal;
+begin
+ if (S = '') or (WordDelims = '') or (OldWord = '') or
+ (pos(OldWord, S) = 0) then begin
+ Result := S;
+ Replacements := 0;
+ Exit;
+ end;
+
+ if (WordPosL(S, WordDelims, OldWord, N, P1)) then begin
+ Result := S;
+ System.Delete(Result, P1, Length(OldWord));
+
+ C := 0;
+ for I := 1 to Replacements do begin
+ if ((Length(NewWord)) + Length(Result)) < MaxLongInt then begin
+ Inc(C);
+ System.Insert(NewWord, Result, P1);
+ Inc(P1, Length(NewWord) + 1);
+ end else begin
+ Replacements := C;
+ Exit;
+ end;
+ end;
+ end else begin
+ Result := S;
+ Replacements := 0;
+ end;
+end;
+
+
+function ReplaceWordAllL(const S, WordDelims, OldWord, NewWord : String;
+ var Replacements : Cardinal) : String;
+var
+ I,
+ C,
+ P1 : Cardinal;
+begin
+ if (S = '') or (WordDelims = '') or (OldWord = '') or
+ (Pos(OldWord, S) = 0) then begin
+ Result := S;
+ Replacements := 0;
+ end else begin
+ Result := S;
+ C := 0;
+ while (WordPosL(Result, WordDelims, OldWord, 1, P1)) do begin
+ System.Delete(Result, P1, Length(OldWord));
+ for I := 1 to Replacements do begin
+ if ((Length(NewWord) + Length(Result)) < MaxLongInt) then begin
+ Inc(C);
+ System.Insert(NewWord, Result, P1);
+ end else begin
+ Replacements := C;
+ Exit;
+ end;
+ end;
+ end;
+ Replacements := C;
+ end;
+end;
+
+
+{----------------------------------------------------------------------------}
+
+function ReplaceStringL(const S, OldString, NewString : String;
+ N : Cardinal;
+ var Replacements : Cardinal) : String;
+var
+ I,
+ C,
+ P1 : Cardinal;
+ TmpStr : String;
+begin
+ if (S = '') or (OldString = '') or (pos(OldString, S) = 0) then begin
+ Result := S;
+ Replacements := 0;
+ Exit;
+ end;
+ TmpStr := S;
+
+ I := 1;
+ P1 := pos(OldString, TmpStr);
+ C := P1;
+ while (I < N) and (LongInt(C) < Length(TmpStr)) do begin
+ Inc(I);
+ System.Delete(TmpStr, 1, LongInt(P1) + Length(OldString));
+ Inc(C, LongInt(P1) + Length(OldString));
+ end;
+ Result := S;
+ System.Delete(Result, C, Length(OldString));
+
+ C := 0;
+ for I := 1 to Replacements do begin
+ if (((Length(NewString)) + Length(Result)) < MaxLongInt) then begin
+ Inc(C);
+ System.Insert(NewString, Result, P1);
+ Inc(P1, Length(NewString) + 1);
+ end else begin
+ Replacements := C;
+ Exit;
+ end;
+ end;
+end;
+
+
+function ReplaceStringAllL(const S, OldString, NewString : String;
+ var Replacements : Cardinal) : String;
+var
+ I,
+ C : Cardinal;
+ P1 : longint;
+ Tmp: String;
+begin
+ if (S = '') or (OldString = '') or (Pos(OldString, S) = 0) then
+ begin
+ Result := S;
+ Replacements := 0;
+ end
+ else begin
+ Tmp := S;
+ P1 := AnsiPos(OldString, S);
+ if (P1 > 0) then begin
+ Result := Copy(Tmp, 1, P1-1);
+ C := 0;
+ while (P1 > 0) do begin
+ for I := 1 to Replacements do begin
+ Inc(C);
+ Result := Result + NewString;
+ end;
+ Tmp := Copy(Tmp, P1+Length(OldString), MaxLongInt);
+ P1 := AnsiPos(OldString, Tmp);
+ if (P1 > 0) then begin
+ Result := Result + Copy(Tmp, 1, P1-1);
+ end else
+ Result := Result + Tmp;
+ end;
+ Replacements := C;
+ end else begin
+ Result := S;
+ Replacements := 0;
+ end;
+ end;
+end;
+
+
+function LastWordL(const S, WordDelims, AWord : String;
+ var Position : Cardinal) : Boolean;
+var
+ TmpStr : String;
+ I : Cardinal;
+begin
+ if (S = '') or (WordDelims = '') or
+ (AWord = '') or (pos(AWord, S) = 0) then begin
+ Result := False;
+ Position := 0;
+ Exit;
+ end;
+
+ TmpStr := S;
+ I := Length(TmpStr);
+ while (pos(TmpStr[I], WordDelims) > 0) do begin
+ System.Delete(TmpStr, I, 1);
+ I := Length(TmpStr);
+ end;
+
+ Position := Length(TmpStr);
+ repeat
+ while (pos(TmpStr[Position], WordDelims) = 0) and (Position > 1) do
+ Dec(Position);
+ if (Copy(TmpStr, Position + 1, Length(AWord)) = AWord) then begin
+ Inc(Position);
+ Result := True;
+ Exit;
+ end;
+ System.Delete(TmpStr, Position, Length(TmpStr));
+ Position := Length(TmpStr);
+ until (Length(TmpStr) = 0);
+ Result := False;
+ Position := 0;
+end;
+
+
+
+function LastWordAbsL(const S, WordDelims : String;
+ var Position : Cardinal) : Boolean;
+begin
+ if (S = '') or (WordDelims = '') then begin
+ Result := False;
+ Position := 0;
+ Exit;
+ end;
+
+{find first non-delimiter character, if any. If not a "one-word wonder"}
+ Position := Length(S);
+ while (Position > 0) and (pos(S[Position], WordDelims) > 0) do
+ Dec(Position);
+
+ if (Position = 0) then begin
+ Result := True;
+ Position := 1;
+ Exit;
+ end;
+
+{find next delimiter character}
+ while (Position > 0) and (pos(S[Position], WordDelims) = 0) do
+ Dec(Position);
+ Inc(Position);
+ Result := True;
+end;
+
+
+
+function LastStringL(const S, AString : String;
+ var Position : Cardinal) : Boolean;
+var
+ TmpStr : String;
+ I, C : Cardinal;
+begin
+ if (S = '') or (AString = '') or (pos(AString, S) = 0) then begin
+ Result := False;
+ Position := 0;
+ Exit;
+ end;
+
+ TmpStr := S;
+ C := 0;
+ I := pos(AString, TmpStr);
+ while (I > 0) do begin
+ Inc(C, LongInt(I) + Length(AString));
+ System.Delete(TmpStr, 1, LongInt(I) + Length(AString));
+ I := pos(AString, TmpStr);
+ end;
+{Go back the length of AString since the while loop deletes the last instance}
+ Dec(C, Length(AString));
+ Position := C;
+ Result := True;
+end;
+
+
+
+function KeepCharsL(const S, Chars : String) : String;
+var
+ FromInx : Cardinal;
+ ToInx : Cardinal;
+begin
+ {if either the input string or the list of acceptable chars is empty
+ the destination string will also be empty}
+ if (S = '') or (Chars = '') then begin
+ Result := '';
+ Exit;
+ end;
+
+ {set the maximum length of the result string (it could be less than
+ this, of course}
+ SetLength(Result, length(S));
+
+ {start off the to index}
+ ToInx := 0;
+
+ {in a loop, copy over the chars that match the list}
+ for FromInx := 1 to length(S) do
+ if CharExistsL(Chars, S[FromInx]) then begin
+ inc(ToInx);
+ Result[ToInx] := S[FromInx];
+ end;
+
+ {make sure that the length of the result string is correct}
+ SetLength(Result, ToInx);
+end;
+
+
+
+function RepeatStringL(const RepeatString : String;
+ var Repetitions : Cardinal;
+ MaxLen : Cardinal) : String;
+var
+ i : Cardinal;
+ Len : Cardinal;
+ ActualReps : Cardinal;
+begin
+ Result := '';
+ if (MaxLen <> 0) and
+ (Repetitions <> 0) and
+ (RepeatString <> '') then begin
+ Len := length(RepeatString);
+ ActualReps := MaxLen div Len;
+ if (ActualReps > Repetitions) then
+ ActualReps := Repetitions
+ else
+ Repetitions := ActualReps;
+ if (ActualReps > 0) then begin
+ SetLength(Result, ActualReps * Len);
+ for i := 0 to pred(ActualReps) do
+ Move(RepeatString[1], Result[i * Len + 1], Len * SizeOf(Char));
+ end;
+ end;
+end;
+
+
+
+function TrimCharsL(const S, Chars : String) : String;
+begin
+ Result := RightTrimCharsL(S, Chars);
+ Result := LeftTrimCharsL(Result, Chars);
+end;
+
+
+
+function RightTrimCharsL(const S, Chars : String) : String;
+var
+ CutOff : integer;
+begin
+ CutOff := length(S);
+ while (CutOff > 0) do begin
+ if not CharExistsL(Chars, S[CutOff]) then
+ Break;
+ dec(CutOff);
+ end;
+ if (CutOff = 0) then
+ Result := ''
+ else
+ Result := Copy(S, 1, CutOff);
+end;
+
+
+
+function LeftTrimCharsL(const S, Chars : String) : String;
+var
+ CutOff : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ CutOff := 1;
+ while (CutOff <= LenS) do begin
+ if not CharExistsL(Chars, S[CutOff]) then
+ Break;
+ inc(CutOff);
+ end;
+ if (CutOff > LenS) then
+ Result := ''
+ else
+ Result := Copy(S, CutOff, LenS - CutOff + 1);
+end;
+
+
+
+function ExtractTokensL(const S, Delims: String;
+ QuoteChar : Char;
+ AllowNulls : Boolean;
+ Tokens : TStrings) : Cardinal; //overload;
+var
+ State : (ScanStart,
+ ScanQuotedToken,
+ ScanQuotedTokenEnd,
+ ScanNormalToken,
+ ScanNormalTokenWithQuote);
+ CurChar : Char;
+ TokenStart : integer;
+ Inx : integer;
+begin
+ {Notes: this routine implements the following state machine
+ start ----> ScanStart
+ ScanStart-----quote----->ScanQuotedToken
+ ScanStart-----delim----->ScanStart (1)
+ ScanStart-----other----->ScanNormalToken
+ ScanQuotedToken-----quote----->ScanQuotedTokenEnd
+ ScanQuotedToken-----other----->ScanQuotedToken
+ ScanQuotedTokenEnd-----quote----->ScanNormalTokenWithQuote
+ ScanQuotedTokenEnd-----delim----->ScanStart (2)
+ ScanQuotedTokenEnd-----other----->ScanNormalToken
+ ScanNormalToken-----quote----->ScanNormalTokenWithQuote
+ ScanNormalToken-----delim----->ScanStart (3)
+ ScanNormalToken-----other----->ScanNormalToken
+ ScanNormalTokenWithQuote-----quote----->ScanNormalTokenWithQuote
+ ScanNormalTokenWithQuote-----other----->ScanNormalToken
+
+ (1) output a null token if allowed
+ (2) output a token, stripping quotes (if the dequoted token is
+ empty, output a null token if allowed)
+ (3) output a token; no quote stripping
+
+ If the quote character is #0, it's taken to mean that the routine
+ should not check for quoted substrings.}
+
+ {clear the tokens string list, set the return value to zero}
+ Tokens.Clear;
+ Result := 0;
+
+ {if the input string is empty or the delimiter list is empty or
+ the quote character is found in the delimiter list, return zero
+ tokens found}
+ if (S = '') or
+ (Delims = '') or
+ CharExistsL(Delims, QuoteChar) then
+ Exit;
+
+ {start off in the normal scanning state}
+ State := ScanStart;
+
+ {the first token starts at position 1}
+ TokenStart := 1;
+
+ {read through the entire string}
+ for Inx := 1 to length(S) do begin
+
+ {get the current character}
+ CurChar := S[Inx];
+
+ {process the character according to the current state}
+ case State of
+ ScanStart :
+ begin
+ {if the current char is the quote character, switch states}
+ if (QuoteChar <> #0) and (CurChar = QuoteChar) then
+ State := ScanQuotedToken
+
+ {if the current char is a delimiter, output a null token}
+ else if CharExistsL(Delims, CurChar) then begin
+
+ {if allowed to, output a null token}
+ if AllowNulls then begin
+ Tokens.Add('');
+ inc(Result);
+ end;
+
+ {set the start of the next token to be one character after
+ this delimiter}
+ TokenStart := succ(Inx);
+ end
+
+ {otherwise, the current char is starting a normal token, so
+ switch states}
+ else
+ State := ScanNormalToken
+ end;
+
+ ScanQuotedToken :
+ begin
+ {if the current char is the quote character, switch states}
+ if (CurChar = QuoteChar) then
+ State := ScanQuotedTokenEnd
+ end;
+
+ ScanQuotedTokenEnd :
+ begin
+ {if the current char is the quote character, we have a token
+ consisting of two (or more) quoted substrings, so switch
+ states}
+ if (CurChar = QuoteChar) then
+ State := ScanNormalTokenWithQuote
+
+ {if the current char is a delimiter, output the token
+ without the quotes}
+ else if CharExistsL(Delims, CurChar) then begin
+
+ {if the token is empty without the quotes, output a null
+ token only if allowed to}
+ if ((Inx - TokenStart) = 2) then begin
+ if AllowNulls then begin
+ Tokens.Add('');
+ inc(Result);
+ end
+ end
+
+ {else output the token without the quotes}
+ else begin
+ Tokens.Add(Copy(S, succ(TokenStart), Inx - TokenStart - 2));
+ inc(Result);
+ end;
+
+ {set the start of the next token to be one character after
+ this delimiter}
+ TokenStart := succ(Inx);
+
+ {switch states back to the start state}
+ State := ScanStart;
+ end
+
+ {otherwise it's a (complex) normal token, so switch states}
+ else
+ State := ScanNormalToken
+ end;
+
+ ScanNormalToken :
+ begin
+ {if the current char is the quote character, we have a
+ complex token with at least one quoted substring, so switch
+ states}
+ if (QuoteChar <> #0) and (CurChar = QuoteChar) then
+ State := ScanNormalTokenWithQuote
+
+ {if the current char is a delimiter, output the token}
+ else if CharExistsL(Delims, CurChar) then begin
+ Tokens.Add(Copy(S, TokenStart, Inx - TokenStart));
+ inc(Result);
+
+ {set the start of the next token to be one character after
+ this delimiter}
+ TokenStart := succ(Inx);
+
+ {switch states back to the start state}
+ State := ScanStart;
+ end;
+ end;
+
+ ScanNormalTokenWithQuote :
+ begin
+ {if the current char is the quote character, switch states
+ back to scanning a normal token}
+ if (CurChar = QuoteChar) then
+ State := ScanNormalToken;
+ end;
+
+ end;
+ end;
+
+ {we need to process the (possible) final token: first assume that
+ the current character index is just beyond the end of the string}
+ Inx := succ(length(S));
+
+ {if we are in the scanning quoted token state, we've read an opening
+ quote, but no closing one; increment the token start value}
+ if (State = ScanQuotedToken) then
+ inc(TokenStart)
+
+ {if we've finished scanning a quoted token, we've read both quotes;
+ increment the token start value, and decrement the current index}
+ else if (State = ScanQuotedTokenEnd) then begin
+ inc(TokenStart);
+ dec(Inx);
+ end;
+
+ {if the final token is not empty, output the token}
+ if (TokenStart < Inx) then begin
+ Tokens.Add(Copy(S, TokenStart, Inx - TokenStart));
+ inc(Result);
+ end
+ {otherwise the final token is empty, so output a null token if
+ allowed to}
+ else if AllowNulls then begin
+ Tokens.Add('');
+ inc(Result);
+ end;
+end;
+
+function ContainsOnlyL(const S, Chars : String;
+ var BadPos : Cardinal) : Boolean;
+var
+ I : Cardinal;
+begin
+ if (S = '') then begin
+ Result := False;
+ BadPos := 0;
+ end else begin
+ for I := 1 to Length(S) do begin
+ if (not CharExistsL(Chars, S[I])) then begin
+ BadPos := I;
+ Result := False;
+ Exit;
+ end;
+ end;
+ Result := True;
+ BadPos := 0;
+ end;
+end;
+
+
+
+function ContainsOtherThanL(const S, Chars : String;
+ var BadPos : Cardinal) : Boolean;
+var
+ I : Cardinal;
+begin
+ if (S = '') then begin
+ Result := False;
+ BadPos := 0;
+ end else begin
+ for I := 1 to Length(S) do begin
+ if (CharExistsL(Chars, S[I])) then begin
+ BadPos := I;
+ Result := True;
+ Exit;
+ end;
+ end;
+ Result := False;
+ BadPos := 0;
+ end;
+end;
+
+
+
+function IsChAlphaL(C : Char) : Boolean;
+ {-Returns true if Ch is an alpha}
+begin
+ {$IFDEF FPC}
+ Result := (C in ['a'..'z', 'A'..'Z']);
+ {$ELSE}
+ Result := Windows.IsCharAlpha(C);
+ {$ENDIF}
+end;
+
+
+
+function IsChNumericL(C : Char; const Numbers : String) : Boolean; {!!.02}
+ {-Returns true if Ch in numeric set}
+begin
+ Result := CharExistsL(Numbers, C);
+end;
+
+
+
+function IsChAlphaNumericL(C : Char; const Numbers : String) : Boolean; {!!.02}
+ {-Returns true if Ch is an alpha or numeric}
+begin
+ {$IFDEF FPC}
+ Result := IsChAlphaL(C) or CharExistsL(Numbers, C);
+ {$ELSE}
+ Result := Windows.IsCharAlpha(C) or CharExistsL(Numbers, C);
+ {$ENDIF}
+end;
+
+
+
+function IsStrAlphaL(const S : String) : Boolean;
+ {-Returns true if all characters in string are an alpha}
+var
+ I : Cardinal;
+begin
+ Result := false;
+ if (length(S) > 0) then begin
+ for I := 1 to Length(S) do
+ {$IFDEF FPC}
+ if not IsChAlphaL(S[I]) then
+ {$ELSE}
+ if not Windows.IsCharAlpha(S[I]) then
+ {$ENDIF}
+ Exit;
+ Result := true;
+ end;
+end;
+
+
+
+function IsStrNumericL(const S, Numbers : String) : Boolean;
+ {-Returns true if all characters in string are in numeric set}
+var
+ i : Cardinal;
+begin
+ Result := false;
+ if (length(S) > 0) then begin
+ for i := 1 to Length(S) do
+ if not CharExistsL(Numbers, S[i]) then
+ Exit;
+ Result := true;
+ end;
+end;
+
+
+
+function IsStrAlphaNumericL(const S, Numbers : String) : Boolean;
+ {-Returns true if all characters in string are alpha or numeric}
+var
+ i : Cardinal;
+begin
+ Result := false;
+ if (length(S) > 0) then begin
+ for I := 1 to Length(S) do
+ {$IFDEF FPC}
+ if (not IsChAlphaL(S[i])) and
+ {$ELSE}
+ if (not Windows.IsCharAlpha(S[i])) and
+ {$ENDIF}
+ (not CharExistsL(Numbers, S[i])) then
+ Exit;
+ Result := true;
+ end;
+end;
+
+
+function StrWithinL(const S, SearchStr : string;
+ Start : Cardinal;
+ var Position : Cardinal) : boolean;
+var
+ TmpStr : string;
+begin
+ TmpStr := S;
+ if (Start > 1) then
+ System.Delete(TmpStr, 1, Start-1);
+ Position := pos(SearchStr, TmpStr);
+ if (Position > 0) then begin
+ Position := Position + Start - 1;
+ Result := True;
+ end else
+ Result := False;
+end;
+
+
+end.
diff --git a/components/systools/source/run/ststrms.pas b/components/systools/source/run/ststrms.pas
new file mode 100644
index 000000000..71190c2af
--- /dev/null
+++ b/components/systools/source/run/ststrms.pas
@@ -0,0 +1,1424 @@
+// Upgraded to Delphi 2009: Sebastian Zierer
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower SysTools
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{*********************************************************}
+{* SysTools: StStrms.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Specialized Stream Classes for SysTools *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StStrms;
+
+interface
+
+uses
+ {$IFDEF FPC}
+ LCLIntf, LCLType,
+ {$ELSE}
+ Windows,
+ {$ENDIF}
+ SysUtils,
+ Classes,
+
+ StBase,
+ StConst;
+
+type
+ TStMemSize = Integer;
+
+ TStBufferedStream = class(TStream)
+ private
+ FBufCount: TStMemSize; {count of valid bytes in buffer}
+ FBuffer : PAnsiChar; {buffer into underlying stream}
+ FBufOfs : longint; {offset of buffer in underlying stream}
+ FBufPos : TStMemSize; {current position in buffer}
+ FBufSize : TStMemSize; {size of buffer}
+ FDirty : boolean; {has data in buffer been changed?}
+ FSize : Int64; {size of underlying stream}
+ FStream : TStream; {underlying stream}
+ {$IFNDEF VERSION3}
+ FOnSetStreamSize : TStSetStreamSize;
+ {event to set underlying stream's size}
+ {$ENDIF}
+ protected
+ procedure bsSetStream(aValue : TStream);
+
+ procedure bsInitForNewStream; virtual;
+ function bsReadChar(var aCh : AnsiChar) : boolean;
+ procedure bsReadFromStream;
+ procedure bsWriteToStream;
+
+ {$IFDEF VERSION3}
+ procedure SetSize(NewSize : longint); override;
+ {$ENDIF}
+ public
+ constructor Create(aStream : TStream);
+ constructor CreateEmpty;
+ destructor Destroy; override;
+
+ function Read(var Buffer; Count : longint) : longint; override;
+ function Seek(Offset : longint; Origin : word) : longint; override;
+ function Write(const Buffer; Count : longint) : longint; override;
+ {$IFNDEF VERSION3}
+ procedure SetSize(NewSize : longint);
+ {$ENDIF}
+
+ property FastSize : Int64 read FSize;
+ property Stream : TStream read FStream write bsSetStream;
+
+ {$IFNDEF VERSION3}
+ property OnSetStreamSize : TStSetStreamSize
+ read FOnSetStreamSize write FOnSetStreamSize;
+ {$ENDIF}
+ end;
+
+type
+{!!.01 - moved to StBase.pas }
+(*
+ TStLineTerminator = ( {possible line terminators...}
+ ltNone, {..no terminator, ie fixed length lines}
+ ltCR, {..carriage return (#13)}
+ ltLF, {..line feed (#10)}
+ ltCRLF, {..carriage return/line feed (#13/#10)}
+ ltOther); {..another character}
+*)
+{!!.01 - end moved }
+
+
+ // TODO-UNICODE: add TStUnicodeTextStream
+
+ TStAnsiTextStream = class(TStBufferedStream)
+ private
+ FLineEndCh : AnsiChar;
+ FLineLen : integer;
+ FLineTerm : TStLineTerminator;
+ FFixedLine : PAnsiChar;
+ FLineCount : longint;
+ FLineCurrent : longint;
+ FLineCurOfs : longint;
+ FLineIndex : TList;
+ FLineInxStep : longint;
+ FLineInxTop : integer;
+ protected
+ function atsGetLineCount : longint;
+
+ procedure atsSetLineTerm(aValue : TStLineTerminator);
+ procedure atsSetLineEndCh(aValue : AnsiChar);
+ procedure atsSetLineLen(aValue : integer);
+
+ procedure atsGetLine(var aStartPos : longint;
+ var aEndPos : longint;
+ var aLen : longint);
+ procedure atsResetLineIndex;
+
+ procedure bsInitForNewStream; override;
+ public
+ constructor Create(aStream : TStream);
+ destructor Destroy; override;
+
+ function AtEndOfStream : boolean;
+
+ function ReadLine : AnsiString;
+ function ReadLineArray(aCharArray : PAnsiChar; aLen : TStMemSize)
+ : TStMemSize;
+ function ReadLineZ(aSt : PAnsiChar; aMaxLen : TStMemSize) : PAnsiChar;
+
+ function SeekNearestLine(aOffset : longint) : longint;
+ function SeekLine(aLineNum : longint) : longint;
+
+ procedure WriteLine(const aSt : AnsiString);
+ procedure WriteLineArray(aCharArray : PAnsiChar; aLen : TStMemSize);
+ procedure WriteLineZ(aSt : PAnsiChar);
+
+ property FixedLineLength : integer
+ read FLineLen write atsSetLineLen;
+ property LineCount : longint
+ read atsGetLineCount;
+ property LineTermChar : AnsiChar
+ read FLineEndCh write atsSetLineEndCh;
+ property LineTerminator : TStLineTerminator
+ read FLineTerm write atsSetLineTerm;
+ end;
+
+ {$IFNDEF FPC}
+ TStMemoryMappedFile = class(TStream)
+ protected {private}
+ FBuffer : Pointer;
+ FHeaderSize : Word;
+ FDataSize : Cardinal;
+ FHandle : THandle;
+ FMapObj : THandle;
+ FMaxHi : Cardinal;
+ FMaxLo : Cardinal;
+ FMutex : THandle;
+ FPos : Cardinal;
+ FReadOnly : Boolean;
+ FSharedData : Boolean;
+
+ protected
+ function GetDataSize : Cardinal;
+
+ public
+ constructor Create(const FileName : string; {!!.02}
+ MaxSize : Cardinal;
+ ReadOnly : Boolean;
+ SharedData : Boolean);
+ destructor Destroy; override;
+
+ function Read(var Buffer; Count : Longint) : Longint; override;
+ function Seek(Offset : Longint; Origin : Word) : Longint; override;
+ function Write(const Buffer; Count : Longint) : Longint; override;
+
+ property DataSize : Cardinal
+ read GetDataSize;
+
+ property MaxSize : Cardinal
+ read FMaxLo;
+
+ property Position : Cardinal
+ read FPos;
+
+ property ReadOnly : Boolean
+ read FReadOnly;
+
+ property SharedData : Boolean
+ read FSharedData;
+ end;
+ {$ENDIF}
+
+implementation
+
+const
+ LineTerm : array [TStLineTerminator] of
+ array [0..1] of AnsiChar =
+ ('', #13, #10, #13#10, '');
+
+const
+ LineIndexCount = 1024;
+ LineIndexMax = pred(LineIndexCount);
+
+
+{--- Helper routines ---------------------------------------------------------}
+
+function MinLong(A, B : longint) : longint;
+begin
+ if A < B then
+ Result := A
+ else
+ Result := B;
+end;
+
+
+{-----------------------------------------------------------------------------}
+{ TStBufferedStream }
+{-----------------------------------------------------------------------------}
+
+constructor TStBufferedStream.Create(aStream : TStream);
+begin
+ inherited Create;
+
+ {allocate the buffer}
+ FBufSize := 4096;
+ GetMem(FBuffer, FBufSize);
+
+ {save the stream}
+ if (aStream = nil) then
+ RaiseStError(EStBufStreamError, stscNilStream);
+ FStream := aStream;
+
+ bsInitForNewStream;
+end;
+
+{-----------------------------------------------------------------------------}
+
+constructor TStBufferedStream.CreateEmpty;
+begin
+ inherited Create;
+
+ {allocate the buffer}
+ FBufSize := 4096;
+ GetMem(FBuffer, FBufSize);
+
+ bsInitForNewStream
+end;
+
+{-----------------------------------------------------------------------------}
+
+destructor TStBufferedStream.Destroy;
+begin
+ if (FBuffer <> nil) then begin
+ if FDirty and (FStream <> nil) then
+ bsWriteToStream;
+ FreeMem(FBuffer, FBufSize);
+ end;
+
+ inherited Destroy;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStBufferedStream.bsInitForNewStream;
+begin
+ if (FStream <> nil) then
+ FSize := FStream.Size
+ else
+ FSize := 0;
+ FBufCount := 0;
+ FBufOfs := 0;
+ FBufPos := 0;
+ FDirty := false;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStBufferedStream.bsReadChar(var aCh : AnsiChar) : boolean;
+begin
+ {is there anything to read?}
+ if (FSize = (FBufOfs + FBufPos)) then begin
+ Result := false;
+ Exit;
+ end;
+ {if we get here, we'll definitely read a character}
+ Result := true;
+ {make sure that the buffer has some data in it}
+ if (FBufCount = 0) then
+ bsReadFromStream
+ else if (FBufPos = FBufCount) then begin
+ if FDirty then
+ bsWriteToStream;
+ FBufPos := 0;
+ inc(FBufOfs, FBufSize);
+ bsReadFromStream;
+ end;
+ {get the next character}
+ aCh := AnsiChar(FBuffer[FBufPos]);
+ inc(FBufPos);
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStBufferedStream.bsReadFromStream;
+var
+ NewPos : longint;
+begin
+ {assumptions: FBufOfs is where to read the buffer
+ FBufSize is the number of bytes to read
+ FBufCount will be the number of bytes read}
+ NewPos := FStream.Seek(FBufOfs, soFromBeginning);
+ if (NewPos <> FBufOfs) then
+ RaiseStError(EStBufStreamError, stscNoSeekForRead);
+ FBufCount := FStream.Read(FBuffer^, FBufSize);
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStBufferedStream.bsSetStream(aValue : TStream);
+begin
+ if (aValue <> FStream) then begin
+ {if the buffer is dirty, flush it to the current stream}
+ if FDirty and (FStream <> nil) then
+ bsWriteToStream;
+ {remember the stream and initialize all fields}
+ FStream := aValue;
+ bsInitForNewStream;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStBufferedStream.bsWriteToStream;
+var
+ NewPos : longint;
+ BytesWritten : longint;
+begin
+ {assumptions: FDirty is true
+ FBufOfs is where to write the buffer
+ FBufCount is the number of bytes to write
+ FDirty will be set false afterwards}
+ NewPos := FStream.Seek(FBufOfs, soFromBeginning);
+ if (NewPos <> FBufOfs) then
+ RaiseStError(EStBufStreamError, stscNoSeekForWrite);
+ BytesWritten := FStream.Write(FBuffer^, FBufCount);
+ if (BytesWritten <> FBufCount) then
+ RaiseStError(EStBufStreamError, stscCannotWrite);
+ FDirty := false;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStBufferedStream.Read(var Buffer; Count : longint) : longint;
+var
+ BytesToGo : longint;
+ BytesToRead : longint;
+// BufAsBytes : TByteArray absolute Buffer; {!!.02}
+// DestPos : longint; {!!.02}
+ BufAsBytes : PByte; {!!.02}
+begin
+ BufAsBytes := @Buffer; {!!.02}
+
+ if (FStream = nil) then
+ RaiseStError(EStBufStreamError, stscNilStream);
+ {calculate the number of bytes we could read if possible}
+ BytesToGo := MinLong(Count, FSize - (FBufOfs + FBufPos));
+ {we will return this number of bytes or raise an exception}
+ Result := BytesToGo;
+ {are we going to read some data after all?}
+ if (BytesToGo > 0) then begin
+ {make sure that the buffer has some data in it}
+ if (FBufCount = 0) then
+ bsReadFromStream;
+ {read as much as we can from the current buffer}
+ BytesToRead := MinLong(BytesToGo, FBufCount - FBufPos);
+ {transfer that number of bytes}
+// Move(FBuffer[FBufPos], BufAsBytes[0], BytesToRead); {!!.02}
+ Move(FBuffer[FBufPos], BufAsBytes^, BytesToRead); {!!.02}
+ {update our counters}
+ inc(FBufPos, BytesToRead);
+ dec(BytesToGo, BytesToRead);
+ {if we have more bytes to read then we've reached the end of the
+ buffer and so we need to read another, and another, etc}
+// DestPos := 0; {!!.02}
+ while BytesToGo > 0 do begin
+ {if the current buffer is dirty, write it out}
+ if FDirty then
+ bsWriteToStream;
+ {position and read the next buffer}
+ FBufPos := 0;
+ inc(FBufOfs, FBufSize);
+ bsReadFromStream;
+ {calculate the new destination position, and the number of bytes
+ to read from this buffer}
+// inc(DestPos, BytesToRead); {!!.02}
+ Inc(BufAsBytes, BytesToRead); {!!.02}
+ BytesToRead := MinLong(BytesToGo, FBufCount - FBufPos);
+ {transfer that number of bytes}
+// Move(FBuffer[FBufPos], BufAsBytes[DestPos], BytesToRead); {!!.02}
+ Move(FBuffer[FBufPos], BufAsBytes^, BytesToRead); {!!.02}
+
+ {update our counters}
+ inc(FBufPos, BytesToRead);
+ dec(BytesToGo, BytesToRead);
+ end;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStBufferedStream.Seek(Offset : longint; Origin : word) : longint;
+var
+ NewPos : longint;
+ NewOfs : longint;
+begin
+ if (FStream = nil) then
+ RaiseStError(EStBufStreamError, stscNilStream);
+ {optimization: to help code that just wants the current stream
+ position (ie, reading the Position property), check for this as a
+ special case}
+ if (Offset = 0) and (Origin = soFromCurrent) then begin
+ Result := FBufOfs + FBufPos;
+ Exit;
+ end;
+ {calculate the desired position}
+ case Origin of
+ soFromBeginning : NewPos := Offset;
+ soFromCurrent : NewPos := (FBufOfs + FBufPos) + Offset;
+ soFromEnd : NewPos := FSize + Offset;
+ else
+ RaiseStError(EStBufStreamError, stscBadOrigin);
+ NewPos := 0; {to fool the compiler's warning--we never get here}
+ end;
+ {force the new position to be valid}
+ if (NewPos < 0) then
+ NewPos := 0
+ else if (NewPos > FSize) then
+ NewPos := FSize;
+ {calculate the offset for the buffer}
+ NewOfs := (NewPos div FBufSize) * FBufSize;
+ {if the offset differs, we have to move the buffer window}
+ if (NewOfs <> FBufOfs) then begin
+ {check to see whether we have to write the current buffer to the
+ original stream first}
+ if FDirty then
+ bsWriteToStream;
+ {mark the buffer as empty}
+ FBufOfs := NewOfs;
+ FBufCount := 0;
+ end;
+ {set the position within the buffer}
+ FBufPos := NewPos - FBufOfs;
+ Result := NewPos;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStBufferedStream.SetSize(NewSize : longint);
+var
+ NewPos : longint;
+begin
+ {get rid of the simple case first where the new size and the old
+ size are the same}
+ if (NewSize = FSize) then
+ Exit;
+ {if the buffer is dirty, write it out}
+ if FDirty then
+ bsWriteToStream;
+ {now set the size of the underlying stream}
+ FStream.Size := NewSize;
+ {patch up the buffer fields so that the buffered stream points to
+ somewhere in the newly resized stream}
+ NewPos := FBufOfs + FBufPos;
+ if (NewPos > NewSize) then
+ NewPos := NewSize;
+ bsInitForNewStream;
+ Seek(NewPos, soFromBeginning);
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStBufferedStream.Write(const Buffer; Count : longint) : longint;
+var
+ BytesToGo : longint;
+ BytesToWrite: longint;
+// BufAsBytes : TByteArray absolute Buffer; {!!.02}
+// DestPos : longint; {!!.02}
+ BufAsBytes : PByte; {!!.02}
+begin
+ BufAsBytes := @Buffer; {!!.02}
+
+ if (FStream = nil) then
+ RaiseStError(EStBufStreamError, stscNilStream);
+ {calculate the number of bytes we should be able to write}
+ BytesToGo := Count;
+ {we will return this number of bytes or raise an exception}
+ Result := BytesToGo;
+ {are we going to write some data?}
+ if (BytesToGo > 0) then begin
+ {try and make sure that the buffer has some data in it}
+ if (FBufCount = 0) then
+ bsReadFromStream;
+ {write as much as we can to the current buffer}
+ BytesToWrite := MinLong(BytesToGo, FBufSize - FBufPos);
+ {transfer that number of bytes}
+// Move(BufAsBytes[0], FBuffer[FBufPos], BytesToWrite); {!!.02}
+ Move(BufAsBytes^, FBuffer[FBufPos], BytesToWrite); {!!.02}
+ FDirty := true;
+ {update our counters}
+ inc(FBufPos, BytesToWrite);
+ if (FBufCount < FBufPos) then begin
+ FBufCount := FBufPos;
+ FSize := FBufOfs + FBufPos;
+ end;
+ dec(BytesToGo, BytesToWrite);
+ {if we have more bytes to write then we've reached the end of the
+ buffer and so we need to write another, and another, etc}
+// DestPos := 0; {!!.02}
+ while BytesToGo > 0 do begin
+ {as the current buffer is dirty, write it out}
+ bsWriteToStream;
+ {position and read the next buffer, if required}
+ FBufPos := 0;
+ inc(FBufOfs, FBufSize);
+ if (FBufOfs < FSize) then
+ bsReadFromStream
+ else
+ FBufCount := 0;
+ {calculate the new destination position, and the number of bytes
+ to write to this buffer}
+// inc(DestPos, BytesToWrite); {!!.02}
+ Inc(BufAsBytes, BytesToWrite); {!!.02}
+ BytesToWrite := MinLong(BytesToGo, FBufSize - FBufPos);
+ {transfer that number of bytes}
+// Move(BufAsBytes[DestPos], FBuffer[0], BytesToWrite); {!!.02}
+ Move(BufAsBytes^, FBuffer[0], BytesToWrite); {!!.02}
+ FDirty := true;
+ {update our counters}
+ inc(FBufPos, BytesToWrite);
+ if (FBufCount < FBufPos) then begin
+ FBufCount := FBufPos;
+ FSize := FBufOfs + FBufPos;
+ end;
+ dec(BytesToGo, BytesToWrite);
+ end;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+{ TStAnsiTextStream }
+{-----------------------------------------------------------------------------}
+
+constructor TStAnsiTextStream.Create(aStream : TStream);
+begin
+ inherited Create(aStream);
+
+ {set up the line index variables}
+ atsResetLineIndex;
+end;
+
+{-----------------------------------------------------------------------------}
+
+destructor TStAnsiTextStream.Destroy;
+begin
+ {if needed, free the fixed line buffer}
+ if (FFixedLine <> nil) then
+ FreeMem(FFixedLine, FixedLineLength);
+ {free the line index}
+ FLineIndex.Free;
+ inherited Destroy;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStAnsiTextStream.AtEndOfStream : boolean;
+begin
+ Result := FSize = (FBufOfs + FBufPos);
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.atsGetLine(var aStartPos : longint;
+ var aEndPos : longint;
+ var aLen : longint);
+var
+ Done : boolean;
+ Ch : AnsiChar;
+ PrevCh : AnsiChar;
+begin
+ if (LineTerminator = ltNone) then begin
+ aStartPos := FBufOfs + FBufPos;
+ aEndPos := Seek(aStartPos + FixedLineLength, soFromBeginning);
+ aLen := aEndPos - aStartPos;
+ end
+ else begin
+ aStartPos := FBufOfs + FBufPos;
+ Ch := #0;
+ Done := false;
+ while not Done do begin
+ PrevCh := Ch;
+ if not bsReadChar(Ch) then begin
+ Done := true;
+ aEndPos := FBufOfs + FBufPos;
+ aLen := aEndPos - aStartPos;
+ end
+ else begin
+ case LineTerminator of
+ ltNone : {this'll never get hit};
+ ltCR : if (Ch = #13) then begin
+ Done := true;
+ aEndPos := FBufOfs + FBufPos;
+ aLen := aEndPos - aStartPos - 1;
+ end;
+ ltLF : if (Ch = #10) then begin
+ Done := true;
+ aEndPos := FBufOfs + FBufPos;
+ aLen := aEndPos - aStartPos - 1;
+ end;
+ ltCRLF : if (Ch = #10) then begin
+ Done := true;
+ aEndPos := FBufOfs + FBufPos;
+ if PrevCh = #13 then
+ aLen := aEndPos - aStartPos - 2
+ else
+ aLen := aEndPos - aStartPos - 1;
+ end;
+ ltOther: if (Ch = LineTermChar) then begin
+ Done := true;
+ aEndPos := FBufOfs + FBufPos;
+ aLen := aEndPos - aStartPos - 1;
+ end;
+ else
+ RaiseStError(EStBufStreamError, stscBadTerminator);
+ end;
+ end;
+ end;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStAnsiTextStream.atsGetLineCount : longint;
+begin
+ if FLineCount < 0 then
+ Result := MaxLongInt
+ else
+ Result := FLineCount;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.atsResetLineIndex;
+begin
+ {make sure we have a line index}
+ if (FLineIndex = nil) then begin
+ FLineIndex := TList.Create; {create the index: even elements are}
+ FLineIndex.Count := LineIndexCount * 2; {linenums, odd are offsets}
+
+ {if we didn't have a line index, set up some reasonable defaults}
+ FLineTerm := ltCRLF; {normal Windows text file terminator}
+ FLineEndCh := #10; {not used straight away}
+ FLineLen := 80; {not used straight away}
+ end;
+ FLineIndex[0] := pointer(0); {the first line is line 0 and...}
+ FLineIndex[1] := pointer(0); {...it starts at position 0}
+ FLineInxTop := 0; {the top valid index}
+ FLineInxStep := 1; {step count before add a line to index}
+ FLineCount := -1; {number of lines (-1 = don't know)}
+ FLineCurrent := 0; {current line}
+ FLineCurOfs := 0; {current line offset}
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.atsSetLineTerm(aValue : TStLineTerminator);
+begin
+ if (aValue <> LineTerminator) and ((FBufOfs + FBufPos) = 0) then begin
+ {if there was no terminator, free the line buffer}
+ if (LineTerminator = ltNone) then begin
+ FreeMem(FFixedLine, FixedLineLength);
+ FFixedLine := nil;
+ end;
+ {set the new value}
+ FLineTerm := aValue;
+ {if there is no terminator now, allocate the line buffer}
+ if (LineTerminator = ltNone) then begin
+ GetMem(FFixedLine, FixedLineLength);
+ end;
+ atsResetLineIndex;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.atsSetLineEndCh(aValue : AnsiChar);
+begin
+ if ((FBufOfs + FBufPos) = 0) then begin
+ FLineEndCh := aValue;
+ atsResetLineIndex;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.atsSetLineLen(aValue : integer);
+begin
+ if (aValue <> FixedLineLength) and ((FBufOfs + FBufPos) = 0) then begin
+ {validate the new length first}
+ if (aValue < 1) or (aValue > 1024) then
+ RaiseStError(EStBufStreamError, stscBadLineLength);
+
+ {set the new value; note that if there is no terminator we need to
+ free the old line buffer, and then allocate a new one}
+ if (LineTerminator = ltNone) then
+ FreeMem(FFixedLine, FixedLineLength);
+ FLineLen := aValue;
+ if (LineTerminator = ltNone) then
+ GetMem(FFixedLine, FixedLineLength);
+ atsResetLineIndex;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.bsInitForNewStream;
+begin
+ inherited bsInitForNewStream;
+ atsResetLineIndex;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStAnsiTextStream.ReadLine : AnsiString;
+var
+ CurPos : longint;
+ EndPos : longint;
+ Len : longint;
+ StLen : longint;
+begin
+ atsGetLine(CurPos, EndPos, Len);
+ if (LineTerminator = ltNone) then begin
+ {at this point, Len will either equal FixedLineLength, or it will
+ be less than it because we read the last line of all and it was
+ short}
+ StLen := FixedLineLength;
+ SetLength(Result, StLen);
+ if (Len < StLen) then
+ FillChar(Result[Len+1], StLen-Len, ' ');
+ end
+ else {LineTerminator is not ltNone} begin
+ SetLength(Result, Len);
+ end;
+ {read the line}
+ if Len > 0 then begin
+ Seek(CurPos, soFromBeginning);
+ Read(Result[1], Len);
+ end
+ else {it's a blank line }
+ Result := '';
+ Seek(EndPos, soFromBeginning);
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStAnsiTextStream.ReadLineArray(aCharArray : PAnsiChar;
+ aLen : TStMemSize)
+ : TStMemSize;
+var
+ CurPos : longint;
+ EndPos : longint;
+ Len : longint;
+ StLen : longint;
+begin
+ atsGetLine(CurPos, EndPos, Len);
+ if (LineTerminator = ltNone) then begin
+ {at this point, Len will either equal FixedLineLength, or it will
+ be less than it because we read the last line of all and it was
+ short}
+ StLen := FixedLineLength;
+ if (StLen > aLen) then
+ StLen := aLen;
+ if (Len < StLen) then
+ FillChar(aCharArray[Len], StLen-Len, ' ');
+ Result := StLen;
+ end
+ else {LineTerminator is not ltNone} begin
+ if (Len > aLen) then
+ Len := aLen;
+ Result := Len;
+ end;
+ Seek(CurPos, soFromBeginning);
+ Read(aCharArray[0], Len);
+ Seek(EndPos, soFromBeginning);
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStAnsiTextStream.ReadLineZ(aSt : PAnsiChar; aMaxLen : TStMemSize) : PAnsiChar;
+var
+ CurPos : longint;
+ EndPos : longint;
+ Len : longint;
+ StLen : longint;
+begin
+ Result := aSt;
+ atsGetLine(CurPos, EndPos, Len);
+ if (LineTerminator = ltNone) then begin
+ {at this point, Len will either equal FixedLineLength, or it will
+ be less than it because we read the last line of all and it was
+ short}
+ StLen := FixedLineLength;
+ if (StLen > aMaxLen) then
+ StLen := aMaxLen;
+ if (Len < StLen) then
+ FillChar(Result[Len], StLen-Len, ' ');
+ Result[StLen] := #0;
+ end
+ else {LineTerminator is not ltNone} begin
+ if (Len > aMaxLen) then
+ Len := aMaxLen;
+ Result[Len] := #0;
+ end;
+ Seek(CurPos, soFromBeginning);
+ Read(Result[0], Len);
+ Seek(EndPos, soFromBeginning);
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStAnsiTextStream.SeekNearestLine(aOffset : longint) : longint;
+var
+ CurLine : longint;
+ CurOfs : longint;
+ CurPos : longint;
+ EndPos : longint;
+ Len : longint;
+ i : longint;
+ Done : boolean;
+ L, R, M : integer;
+begin
+ {if the offset we want is for the current line, reposition at the
+ current line offset, return the current line number and exit}
+ if (aOffset = FLineCurOfs) then begin
+ Seek(FLineCurOfs, soFromBeginning);
+ Result := FLineCurrent;
+ Exit;
+ end;
+ {if the offset requested is less than or equal to zero, just
+ position at line zero (ie, the start of the stream)}
+ if (aOffset <= 0) then begin
+ Seek(0, soFromBeginning);
+ FLineCurrent := 0;
+ FLineCurOfs := 0;
+ Result := 0;
+ Exit;
+ end;
+ {if the offset requested is greater than or equal to the size of the
+ stream, position at the end of the stream (note that if we don't
+ know the number of lines in the stream yet, FLineCount is set to
+ -1 and we can't take this shortcut because we need to return the
+ true value)}
+ if (FLineCount >= 0) and (aOffset >= FSize) then begin
+ Seek(0, soFromEnd);
+ FLineCurrent := FLineCount;
+ FLineCurOfs := FSize;
+ Result := FLineCount;
+ Exit;
+ end;
+ {if the offset requested is greater than the top item in the
+ line index, we shall have to build up the index until we get to the
+ line we require, or just beyond}
+ if (aOffset > longint(FLineIndex[FLineInxTop+1])) then begin
+ {position at the last known line offset}
+ CurLine := longint(FLineIndex[FLineInxTop]);
+ CurOfs := longint(FLineIndex[FLineInxTop+1]);
+ Seek(CurOfs, soFromBeginning);
+ Done := false;
+ {continue reading lines in chunks of FLineInxStep and add an index
+ entry for each chunk}
+ while not Done do begin
+ for i := 0 to pred(FLineInxStep) do begin
+ atsGetLine(CurPos, EndPos, Len);
+ inc(CurLine);
+ CurOfs := EndPos;
+ if (EndPos = FSize) then begin
+ Done := true;
+ Break;
+ end;
+ end;
+ if Done then
+ FLineCount := CurLine
+ else begin
+ inc(FLineInxTop, 2);
+ if (FLineInxTop = (LineIndexCount * 2)) then begin
+ {we've exhausted the space in the index: rescale}
+ FLineInxTop := FLineInxTop div 2;
+ for i := 0 to pred(FLineInxTop) do begin
+ if Odd(i) then
+ FLineIndex.Exchange((i*2)-1, i)
+ else
+ FLineIndex.Exchange(i*2, i);
+ end;
+ FLineInxStep := FLineInxStep * 2;
+ end;
+ FLineIndex[FLineInxTop] := pointer(CurLine);
+ FLineIndex[FLineInxTop+1] := pointer(CurOfs);
+ if (aOffset <= CurOfs) then
+ Done := true;
+ end;
+ end;
+ end;
+ {we can now work out where the nearest item in the index is to the
+ line we require}
+ L := 1;
+ R := FLineInxTop+1;
+ while (L <= R) do begin
+ M := (L + R) div 2;
+ if not Odd(M) then
+ inc(M);
+ if (aOffset < longint(FLineIndex[M])) then
+ R := M - 2
+ else if (aOffset > longint(FLineIndex[M])) then
+ L := M + 2
+ else begin
+ FLineCurrent := longint(FLineIndex[M-1]);
+ FLineCurOfs := longint(FLineIndex[M]);
+ Seek(FLineCurOfs, soFromBeginning);
+ Result := FLineCurrent;
+ Exit;
+ end;
+ end;
+ {the item at L-2 will have the nearest smaller offset than the
+ one we want, hence the nearest smaller line is at L-3; start here
+ and read through the stream forwards}
+ CurLine := longint(FLineIndex[L-3]);
+ Seek(longint(FLineIndex[L-2]), soFromBeginning);
+ while true do begin
+ atsGetLine(CurPos, EndPos, Len);
+ inc(CurLine);
+ if (EndPos > aOffset) then begin
+ FLineCurrent := CurLine - 1;
+ FLineCurOfs := CurPos;
+ Seek(CurPos, soFromBeginning);
+ Result := CurLine - 1;
+ Exit;
+ end
+ else if (CurLine = FLineCount) or (EndPos = aOffset) then begin
+ FLineCurrent := CurLine;
+ FLineCurOfs := EndPos;
+ Seek(EndPos, soFromBeginning);
+ Result := CurLine;
+ Exit;
+ end;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStAnsiTextStream.SeekLine(aLineNum : longint) : longint;
+var
+ CurLine : longint;
+ CurOfs : longint;
+ CurPos : longint;
+ EndPos : longint;
+ Len : longint;
+ i : longint;
+ Done : boolean;
+ L, R, M : integer;
+begin
+ {if the line number we want is the current line, reposition at the
+ current line offset, return the current line number and exit}
+ if (aLineNum = FLineCurrent) then begin
+ Seek(FLineCurOfs, soFromBeginning);
+ Result := FLineCurrent;
+ Exit;
+ end;
+ {if the line number requested is less than or equal to zero, just
+ position at line zero (ie, the start of the stream)}
+ if (aLineNum <= 0) then begin
+ Seek(0, soFromBeginning);
+ FLineCurrent := 0;
+ FLineCurOfs := 0;
+ Result := 0;
+ Exit;
+ end;
+ {if the line number requested is greater than or equal to the line
+ count, position at the end of the stream (note that if we don't
+ know the number of lines in the stream yet, FLineCount is set to
+ -1)}
+ if (FLineCount >= 0) and (aLineNum > FLineCount) then begin
+ Seek(0, soFromEnd);
+ FLineCurrent := FLineCount;
+ FLineCurOfs := FSize;
+ Result := FLineCount;
+ Exit;
+ end;
+ {if the line number requested is greater than the top item in the
+ line index, we shall have to build up the index until we get to the
+ line we require, or just beyond}
+ if (aLineNum > longint(FLineIndex[FLineInxTop])) then begin
+ {position at the last known line offset}
+ CurLine := longint(FLineIndex[FLineInxTop]);
+ CurOfs := longint(FLineIndex[FLineInxTop+1]);
+ Seek(CurOfs, soFromBeginning);
+ Done := false;
+ {continue reading lines in chunks of FLineInxStep and add an index
+ entry for each chunk}
+ while not Done do begin
+ for i := 0 to pred(FLineInxStep) do begin
+ atsGetLine(CurPos, EndPos, Len);
+ inc(CurLine);
+ CurOfs := EndPos;
+ if (EndPos = FSize) then begin
+ Done := true;
+ Break;
+ end;
+ end;
+ if Done then
+ FLineCount := CurLine
+ else begin
+ inc(FLineInxTop, 2);
+ if (FLineInxTop = (LineIndexCount * 2)) then begin
+ {we've exhausted the space in the index: rescale}
+ FLineInxTop := FLineInxTop div 2;
+ for i := 0 to pred(FLineInxTop) do begin
+ if Odd(i) then
+ FLineIndex.Exchange((i*2)-1, i)
+ else
+ FLineIndex.Exchange(i*2, i);
+ end;
+ FLineInxStep := FLineInxStep * 2;
+ end;
+ FLineIndex[FLineInxTop] := pointer(CurLine);
+ FLineIndex[FLineInxTop+1] := pointer(CurOfs);
+ if (aLineNum <= CurLine) then
+ Done := true;
+ end;
+ end;
+ end;
+ {we can now work out where the nearest item in the index is to the
+ line we require}
+ L := 0;
+ R := FLineInxTop;
+ while (L <= R) do begin
+ M := (L + R) div 2;
+ if Odd(M) then
+ dec(M);
+ if (aLineNum < longint(FLineIndex[M])) then
+ R := M - 2
+ else if (aLineNum > longint(FLineIndex[M])) then
+ L := M + 2
+ else begin
+ FLineCurrent := longint(FLineIndex[M]);
+ FLineCurOfs := longint(FLineIndex[M+1]);
+ Seek(FLineCurOfs, soFromBeginning);
+ Result := FLineCurrent;
+ Exit;
+ end;
+ end;
+ {the item at L-2 will have the nearest smaller line number than the
+ one we want; start here and read through the stream forwards}
+ CurLine := longint(FLineIndex[L-2]);
+ Seek(longint(FLineIndex[L-1]), soFromBeginning);
+ while true do begin
+ atsGetLine(CurPos, EndPos, Len);
+ inc(CurLine);
+ if (CurLine = FLineCount) or (CurLine = aLineNum) then begin
+ FLineCurrent := CurLine;
+ FLineCurOfs := EndPos;
+ Seek(EndPos, soFromBeginning);
+ Result := CurLine;
+ Exit;
+ end;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.WriteLine(const aSt : AnsiString);
+var
+ Len : Integer;
+begin
+ Len := Length(aSt);
+ if Len > 0 then
+ WriteLineArray(PAnsiChar(aSt), Len)
+ else
+ WriteLineArray('', 0);
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.WriteLineArray(aCharArray : PAnsiChar;
+ aLen : TStMemSize);
+var
+ C : AnsiChar;
+begin
+ if (aCharArray = nil) then
+ aLen := 0;
+ if (LineTerminator = ltNone) then begin
+ if (aLen >= FixedLineLength) then
+ Write(aCharArray[0], FixedLineLength)
+ else begin
+ FillChar(FFixedLine[aLen], FixedLineLength-aLen, ' ');
+ if (aLen > 0) then
+ Move(aCharArray[0], FFixedLine[0], aLen);
+ Write(FFixedLine[0], FixedLineLength);
+ end;
+ end
+ else begin
+ if (aLen > 0) then
+ Write(aCharArray[0], aLen);
+ case LineTerminator of
+ ltNone : {this'll never get hit};
+ ltCR : Write(LineTerm[ltCR], 1);
+ ltLF : Write(LineTerm[ltLF], 1);
+ ltCRLF : Write(LineTerm[ltCRLF], 2);
+ ltOther: begin
+ C := LineTermChar;
+ Write(C, 1);
+ end;
+ else
+ RaiseStError(EStBufStreamError, stscBadTerminator);
+ end;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+procedure TStAnsiTextStream.WriteLineZ(aSt : PAnsiChar);
+var
+ LenSt : TStMemSize;
+begin
+ if (aSt = nil) then
+ LenSt := 0
+ else
+ LenSt := StrLen(aSt);
+ WriteLineArray(aSt, LenSt);
+end;
+
+{$IFNDEF FPC}
+{-----------------------------------------------------------------------------}
+{ TStMemoryMappedFile }
+{-----------------------------------------------------------------------------}
+
+constructor TStMemoryMappedFile.Create(const FileName : string; {!!.02}
+ MaxSize : Cardinal;
+ ReadOnly : Boolean;
+ SharedData : Boolean);
+var
+ RO1,
+ RO2,
+ RO3,
+ RO4,
+ FHi : DWORD;
+ SetSize: Boolean;
+begin
+ inherited Create;
+
+ FMutex := CreateMutex(nil, False, nil);
+ FSharedData := SharedData;
+ if (FSharedData) then
+ FHeaderSize := SizeOf(Word) + SizeOf(Cardinal)
+ else
+ FHeaderSize := 0;
+
+ FReadOnly := ReadOnly;
+ if (SharedData) then
+ FReadOnly := False;
+ if (FReadOnly) then begin
+ RO1 := GENERIC_READ;
+ RO2 := FILE_ATTRIBUTE_READONLY;
+ RO3 := PAGE_READONLY;
+ RO4 := FILE_MAP_READ;
+ FMaxHi := 0;
+ FMaxLo := 0;
+ end else begin
+ RO1 := GENERIC_READ or GENERIC_WRITE;
+ RO2 := FILE_ATTRIBUTE_NORMAL;
+ RO3 := PAGE_READWRITE;
+ RO4 := FILE_MAP_WRITE;
+ FMaxHi := 0;
+ FMaxLo := MaxSize;
+ end;
+
+ if (not SharedData) then begin
+ FHandle := CreateFile(PChar(FileName),
+ RO1,
+ FILE_SHARE_READ or FILE_SHARE_WRITE,
+ nil,
+ OPEN_ALWAYS,
+ RO2,
+ 0);
+
+ if (FHandle = INVALID_HANDLE_VALUE) then
+ RaiseStError(EStMMFileError, stscCreateFileFailed);
+
+ {reset FMaxLo if file is read/write and less < FileSize}
+ {the result is that the file size cannot be changed but the contents can}
+ {still be modified}
+ FDataSize := GetFileSize(FHandle, @FHi);
+ if (FDataSize <> $FFFFFFFF) then begin
+ if (not ReadOnly) and (FDataSize > FMaxLo) then
+ FMaxLo := FDataSize;
+ end else begin
+ CloseHandle(FHandle);
+ RaiseStError(EStMMFileError, stscGetSizeFailed);
+ end;
+ end else
+ FDataSize := 0;
+
+ if (not SharedData) then begin
+ FMapObj := CreateFileMapping(FHandle, nil, RO3, FMaxHi, FMaxLo, nil);
+ SetSize := False;
+ end else begin
+ if (FMaxLo > (High(Cardinal) - FHeaderSize)) then
+ FMaxLo := High(Cardinal) - FHeaderSize
+ else
+ FMaxLo := FMaxLo + FHeaderSize;
+ FMapObj := CreateFileMapping(THandle($FFFFFFFF), nil, RO3,
+ FMaxHi, FMaxLo, 'STMMFILE1');
+ SetSize := (GetLastError = ERROR_ALREADY_EXISTS);
+ end;
+
+ if (FMapObj = INVALID_HANDLE_VALUE) then
+ RaiseStError(EStMMFileError, stscFileMappingFailed);
+
+ FBuffer := MapViewOfFile(FMapObj, RO4, 0, 0, FMaxLo);
+ if (not Assigned(FBuffer)) then
+ RaiseStError(EStMMFileError, stscCreateViewFailed);
+
+ if (SharedData) then begin
+ if (SetSize) then
+ Move(PByteArray(FBuffer)[SizeOf(Word)-1], FDataSize, SizeOf(Cardinal))
+ else begin
+ Move(FHeaderSize, PByteArray(FBuffer)[0], SizeOf(Word));
+ FDataSize := 0;
+ Move(FDataSize, PByteArray(FBuffer)[SizeOf(Word)-1], SizeOf(Cardinal));
+ end;
+ end;
+ {set position to beginning}
+ FPos := FHeaderSize;
+end;
+
+{-----------------------------------------------------------------------------}
+
+destructor TStMemoryMappedFile.Destroy;
+begin
+{Close the View and Mapping object}
+ UnmapViewOfFile(FBuffer);
+ FBuffer := nil;
+ CloseHandle(FMapObj);
+
+ if (not SharedData) then begin
+{set the file pointer to the end of the actual data}
+ SetFilePointer(FHandle, FDataSize, nil, FILE_BEGIN);
+{set the EOF marker to the end of actual data}
+ SetEndOfFile(FHandle);
+ CloseHandle(FHandle);
+ end;
+
+ {now the Mutex can be cleared}
+ CloseHandle(FMutex);
+ FMutex := 0;
+
+ inherited Destroy;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStMemoryMappedFile.GetDataSize : Cardinal;
+begin
+ Move(PByteArray(FBuffer)[SizeOf(Word)-1], FDataSize, SizeOf(Cardinal));
+ Result := FDataSize;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStMemoryMappedFile.Read(var Buffer; Count : Longint) : Longint;
+var
+// ByteArray : TByteArray absolute Buffer; {!!.02}
+ ByteArray : PByte; {!!.02}
+begin
+ ByteArray := @Buffer; {!!.02}
+ {check to make sure that the read does not go beyond the actual data}
+ if (((FPos-FHeaderSize) + DWORD(Count)) > FDataSize) then
+ Count := FDataSize - FPos + FHeaderSize;
+
+ if (SharedData) then begin
+ WaitForSingleObject(FMutex, INFINITE);
+ try
+// Move(PByteArray(FBuffer)[FPos], ByteArray[0], Count); {!!.02}
+ Move(PByteArray(FBuffer)[FPos], ByteArray^, Count); {!!.02}
+ Inc(FPos, Count);
+ Result := Count;
+ finally
+ ReleaseMutex(FMutex);
+ end;
+ end else begin
+// Move(PByteArray(FBuffer)[FPos], ByteArray[0], Count); {!!.02}
+ Move(PByteArray(FBuffer)[FPos], ByteArray^, Count); {!!.02}
+ Inc(FPos, Count);
+ Result := Count;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStMemoryMappedFile.Write(const Buffer; Count : Longint) : Longint;
+var
+// ByteArray : TByteArray absolute Buffer; {!!.02}
+ ByteArray : PByte; {!!.02}
+begin
+ ByteArray := @Buffer; {!!.02}
+ if (ReadOnly) then begin
+ Result := 0;
+ Exit;
+ end;
+
+ {check that the write does not go beyond the maximum file size}
+ if ((FPos + DWORD(Count)) > pred(FMaxLo)) then
+ Count := pred(FMaxLo - FPos);
+
+ if (SharedData) then begin
+ WaitForSingleObject(FMutex, INFINITE);
+ try
+// Move(ByteArray[0], PByteArray(FBuffer)[FPos], Count); {!!.02}
+ Move(ByteArray^, PByteArray(FBuffer)[FPos], Count); {!!.02}
+ Inc(FPos, Count);
+ {if the write went beyond the previous end of data, update FDataSize}
+ if ((FPos-FHeaderSize) > FDataSize) then
+ FDataSize := FPos-FHeaderSize;
+ Move(FDataSize, PByteArray(FBuffer)[SizeOf(Word)-1], SizeOf(Cardinal));
+ Result := Count;
+ finally
+ ReleaseMutex(FMutex);
+ end;
+ end else begin
+// Move(ByteArray[0], PByteArray(FBuffer)[FPos], Count); {!!.02}
+ Move(ByteArray^, PByteArray(FBuffer)[FPos], Count); {!!.02}
+ Inc(FPos, Count);
+ {if the write went beyond the previous end of data, update FDataSize}
+ if ((FPos-FHeaderSize) > FDataSize) then
+ FDataSize := FPos-FHeaderSize;
+ Move(FDataSize, PByteArray(FBuffer)[SizeOf(Word)-1], SizeOf(Cardinal));
+ Result := Count;
+ end;
+end;
+
+{-----------------------------------------------------------------------------}
+
+function TStMemoryMappedFile.Seek(Offset : Longint; Origin : Word) : Longint;
+begin
+ if (SharedData) then begin
+ WaitForSingleObject(FMutex, INFINITE);
+ try
+ case Origin of
+ {$WARNINGS OFF}
+ soFromBeginning : FPos := Offset + FHeaderSize;
+ soFromCurrent : FPos := FPos + Offset + FHeaderSize;
+ {the seek should be based on actual data, not the mapped size since}
+ {the "data" between FDataSize and the mapped size is undefined}
+ soFromEnd : FPos := FDataSize + Offset + FHeaderSize;
+ {$WARNINGS ON}
+ else
+ RaiseStError(EStMMFileError, stscBadOrigin);
+ end;
+
+ {force the new position to be valid}
+ if ((FPos-FHeaderSize) > FDataSize) then
+ FPos := FDataSize + FHeaderSize;
+ Result := FPos;
+ finally
+ ReleaseMutex(FMutex);
+ end;
+ end else begin
+ {$WARNINGS OFF}
+ case Origin of
+ soFromBeginning : FPos := Offset + FHeaderSize;
+ soFromCurrent : FPos := FPos + Offset + FHeaderSize;
+ {the seek should be based on actual data, not the mapped size since}
+ {the "data" between FDataSize and the mapped size is undefined}
+ soFromEnd : FPos := FDataSize + Offset + FHeaderSize;
+ else
+ RaiseStError(EStMMFileError, stscBadOrigin);
+ end;
+ {$WARNINGS ON}
+
+ {force the new position to be valid}
+ if ((FPos-FHeaderSize) > FDataSize) then
+ FPos := FDataSize + FHeaderSize;
+ Result := FPos;
+ end;
+end;
+{$ENDIF}
+{-----------------------------------------------------------------------------}
+
+end.
+
diff --git a/components/systools/source/run/ststrs.pas b/components/systools/source/run/ststrs.pas
new file mode 100644
index 000000000..d63fe1d5e
--- /dev/null
+++ b/components/systools/source/run/ststrs.pas
@@ -0,0 +1,3408 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower SysTools
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{*********************************************************}
+{* SysTools: StStrS.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Short string routines *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+//{$I StDefine.inc}
+
+unit StStrS;
+
+interface
+
+uses
+ {$IFDEF FPC}
+ LCLIntf, LCLType, StrUtils,
+ {$ELSE}
+ Windows,
+ {$ENDIF}
+ Classes,
+ SysUtils,
+ StConst,
+ StBase;
+
+ {-------- Numeric conversion -----------}
+
+function HexBS(B : Byte) : ShortString;
+ {-Return the hex string for a byte.}
+
+function HexWS(W : Word) : ShortString;
+ {-Return the hex string for a word.}
+
+function HexLS(L : LongInt) : ShortString;
+ {-Return the hex string for a long integer.}
+
+function HexPtrS(P : Pointer) : ShortString;
+ {-Return the hex string for a pointer.}
+
+function BinaryBS(B : Byte) : ShortString;
+ {-Return a binary string for a byte.}
+
+function BinaryWS(W : Word) : ShortString;
+ {-Return the binary string for a word.}
+
+function BinaryLS(L : LongInt) : ShortString;
+ {-Return the binary string for a long integer.}
+
+function OctalBS(B : Byte) : ShortString;
+ {-Return an octal string for a byte.}
+
+function OctalWS(W : Word) : ShortString;
+ {-Return an octal string for a word.}
+
+function OctalLS(L : LongInt) : ShortString;
+ {-Return an octal string for a long integer.}
+
+function Str2Int16S(const S : ShortString; var I : SmallInt) : Boolean;
+ {-Convert a string to an SmallInt.}
+
+function Str2WordS(const S : ShortString; var I : Word) : Boolean;
+ {-Convert a string to a word.}
+
+function Str2LongS(const S : ShortString; var I : LongInt) : Boolean;
+ {-Convert a string to a long integer.}
+
+{$IFDEF VER93}
+function Str2RealS(const S : ShortString; var R : Double) : Boolean;
+{$ELSE}
+ {-Convert a string to a real.}
+function Str2RealS(const S : ShortString; var R : Real) : Boolean;
+{$ENDIF}
+
+function Str2ExtS(const S : ShortString; var R : Extended) : Boolean;
+ {-Convert a string to an extended.}
+
+function Long2StrS(L : LongInt) : ShortString;
+ {-Convert an integer type to a string.}
+
+function Real2StrS(R : Double; Width : Byte; Places : ShortInt) : ShortString;
+ {-Convert a real to a string.}
+
+function Ext2StrS(R : Extended; Width : Byte; Places : ShortInt) : ShortString;
+ {-Convert an extended to a string.}
+
+function ValPrepS(const S : ShortString) : ShortString;
+ {-Prepares a string for calling Val.}
+
+
+ {-------- General purpose string manipulation --------}
+
+function CharStrS(C : AnsiChar; Len : Cardinal) : ShortString;
+ {-Return a string filled with the specified character.}
+
+function PadChS(const S : ShortString; C : AnsiChar; Len : Cardinal) : ShortString;
+ {-Pad a string on the right with a specified character.}
+
+function PadS(const S : ShortString; Len : Cardinal) : ShortString;
+ {-Pad a string on the right with spaces.}
+
+function LeftPadChS(const S : ShortString; C : AnsiChar; Len : Cardinal) : ShortString;
+ {-Pad a string on the left with a specified character.}
+
+function LeftPadS(const S : ShortString; Len : Cardinal) : ShortString;
+ {-Pad a string on the left with spaces.}
+
+function TrimLeadS(const S : ShortString) : ShortString;
+ {-Return a string with leading white space removed.}
+
+function TrimTrailS(const S : ShortString) : ShortString;
+ {-Return a string with trailing white space removed.}
+
+function TrimS(const S : ShortString) : ShortString;
+ {-Return a string with leading and trailing white space removed.}
+
+function TrimSpacesS(const S : ShortString) : ShortString;
+ {-Return a string with leading and trailing spaces removed.}
+
+function CenterChS(const S : ShortString; C : AnsiChar; Len : Cardinal) : ShortString;
+ {-Pad a string on the left and right with a specified character.}
+
+function CenterS(const S : ShortString; Len : Cardinal) : ShortString;
+ {-Pad a string on the left and right with spaces.}
+
+{$IFNDEF FPC}
+function EntabS(const S : ShortString; TabSize : Byte) : ShortString;
+ {-Convert blanks in a string to tabs.}
+
+function DetabS(const S : ShortString; TabSize : Byte) : ShortString;
+ {-Expand tabs in a string to blanks.}
+{$ENDIF}
+
+function ScrambleS(const S, Key : ShortString) : ShortString;
+ {-Encrypt / Decrypt string with enhanced XOR encryption.}
+
+function SubstituteS(const S, FromStr, ToStr : ShortString) : ShortString;
+ {-Map the characters found in FromStr to the corresponding ones in ToStr.}
+
+function FilterS(const S, Filters : ShortString) : ShortString;
+ {-Remove characters from a string. The characters to remove are specified in
+ ChSet.}
+
+ {--------------- Word / Char manipulation -------------------------}
+
+function CharExistsS(const S : ShortString; C : AnsiChar) : Boolean; overload;
+function CharExistsS(const S : String; C : Char) : Boolean; overload;
+ {-Determines whether a given character exists in a string. }
+
+function CharCountS(const S : ShortString; C : AnsiChar) : Byte;
+ {-Count the number of a given character in a string. }
+
+function WordCountS(const S, WordDelims : ShortString) : Cardinal;
+ {-Given an array of word delimiters, return the number of words in a string.}
+
+function WordPositionS(N : Cardinal; const S, WordDelims : ShortString;
+ var Pos : Cardinal) : Boolean;
+ {-Given an array of word delimiters, set Pos to the start position of the
+ N'th word in a string. Result indicates success/failure.}
+
+function ExtractWordS(N : Cardinal; const S, WordDelims : ShortString) : ShortString;
+ {-Given an array of word delimiters, return the N'th word in a string.}
+
+function AsciiCountS(const S, WordDelims : ShortString; Quote : AnsiChar) : Cardinal;
+ {-Return the number of words in a string.}
+
+function AsciiPositionS(N : Cardinal; const S, WordDelims : ShortString;
+ Quote : AnsiChar; var Pos : Cardinal) : Boolean;
+ {-Return the position of the N'th word in a string.}
+
+function ExtractAsciiS(N : Cardinal; const S, WordDelims : ShortString;
+ Quote : AnsiChar) : ShortString;
+ {-Given an array of word delimiters, return the N'th word in a string. Any
+ text within Quote characters is counted as one word.}
+
+procedure WordWrapS(const InSt : ShortString; var OutSt, Overlap : ShortString;
+ Margin : Cardinal; PadToMargin : Boolean);
+ {-Wrap a text string at a specified margin.}
+
+ {--------------- String comparison and searching -----------------}
+function CompStringS(const S1, S2 : ShortString) : Integer;
+ {-Compare two strings.}
+
+function CompUCStringS(const S1, S2 : ShortString) : Integer;
+ {-Compare two strings. This compare is not case sensitive.}
+
+function SoundexS(const S : ShortString) : ShortString;
+ {-Return 4 character soundex of an input string.}
+
+function MakeLetterSetS(const S : ShortString) : Longint;
+ {-Return a bit-mapped long storing the individual letters contained in S.}
+
+procedure BMMakeTableS(const MatchString : ShortString; var BT : BTable);
+ {-Build a Boyer-Moore link table}
+
+function BMSearchS(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : ShortString ; var Pos : Cardinal) : Boolean;
+ {-Use the Boyer-Moore search method to search a buffer for a string.}
+
+function BMSearchUCS(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : ShortString ; var Pos : Cardinal) : Boolean;
+ {-Use the Boyer-Moore search method to search a buffer for a string. This
+ search is not case sensitive.}
+
+ {--------------- DOS pathname parsing -----------------}
+
+function DefaultExtensionS(const Name, Ext : ShortString) : ShortString;
+ {-Return a file name with a default extension attached.}
+
+function ForceExtensionS(const Name, Ext : ShortString) : ShortString;
+ {-Force the specified extension onto the file name.}
+
+function JustFilenameS(const PathName : ShortString) : ShortString;
+ {-Return just the filename and extension of a pathname.}
+
+function JustNameS(const PathName : ShortString) : ShortString;
+ {-Return just the filename (no extension, path, or drive) of a pathname.}
+
+function JustExtensionS(const Name : ShortString) : ShortString;
+ {-Return just the extension of a pathname.}
+
+function JustPathnameS(const PathName : ShortString) : ShortString;
+ {-Return just the drive and directory portion of a pathname.}
+
+function AddBackSlashS(const DirName : ShortString) : ShortString;
+ {-Add a default backslash to a directory name.}
+
+function CleanPathNameS(const PathName : ShortString) : ShortString;
+ {-Return a pathname cleaned up as DOS does it.}
+
+function HasExtensionS(const Name : ShortString; var DotPos : Cardinal) : Boolean;
+ {-Determine if a pathname contains an extension and, if so, return the
+ position of the dot in front of the extension.}
+
+ {------------------ Formatting routines --------------------}
+
+function CommaizeS(L : LongInt) : ShortString;
+ {-Convert a long integer to a string with commas.}
+
+function CommaizeChS(L : Longint; Ch : AnsiChar) : ShortString;
+ {-Convert a long integer to a string with Ch in comma positions.}
+
+function FloatFormS(const Mask : ShortString ; R : TstFloat ; const LtCurr,
+ RtCurr : ShortString ; Sep, DecPt : AnsiChar) : ShortString;
+ {-Return a formatted string with digits from R merged into mask.}
+
+function LongIntFormS(const Mask : ShortString ; L : LongInt ; const LtCurr,
+ RtCurr : ShortString ; Sep : AnsiChar) : ShortString;
+ {-Return a formatted string with digits from L merged into mask.}
+
+function StrChPosS(const P : string; C : Char; var Pos : Cardinal) : Boolean; overload;
+function StrChPosS(const P : ShortString; C : AnsiChar; var Pos : Cardinal) : Boolean; overload;
+
+ {-Return the position of a specified character within a string.}
+
+function StrStPosS(const P, S : ShortString; var Pos : Cardinal) : Boolean;
+ {-Return the position of a specified substring within a string.}
+
+function StrStCopyS(const S : ShortString; Pos, Count : Cardinal) : ShortString;
+ {-Copy characters at a specified position in a string.}
+
+function StrChInsertS(const S : ShortString; C : AnsiChar; Pos : Cardinal) : ShortString;
+ {-Insert a character into a string at a specified position.}
+
+function StrStInsertS(const S1, S2 : ShortString; Pos : Cardinal) : ShortString;
+ {-Insert a string into another string at a specified position.}
+
+function StrChDeleteS(const S : ShortString; Pos : Cardinal) : ShortString;
+ {-Delete the character at a specified position in a string.}
+
+function StrStDeleteS(const S : ShortString; Pos, Count : Cardinal) : ShortString;
+ {-Delete characters at a specified position in a string.}
+
+
+{-------------------------- New Functions -----------------------------------}
+
+function ContainsOnlyS(const S, Chars : ShortString;
+ var BadPos : Cardinal) : Boolean;
+
+function ContainsOtherThanS(const S, Chars : ShortString;
+ var BadPos : Cardinal) : Boolean;
+
+function CopyLeftS(const S : ShortString; Len : Cardinal) : ShortString;
+ {-Return the left Len characters of a string}
+
+function CopyMidS(const S : ShortString; First, Len : Cardinal) : ShortString;
+ {-Return the mid part of a string}
+
+function CopyRightS(const S : ShortString; First : Cardinal) : ShortString;
+ {-Return the right Len characters of a string}
+
+function CopyRightAbsS(const S : ShortString; NumChars : Cardinal) : ShortString;
+ {-Return NumChar characters starting from end}
+
+function CopyFromNthWordS(const S, WordDelims : ShortString;
+ const AWord : ShortString; N : Cardinal; {!!.02}
+ var SubString : ShortString) : Boolean;
+
+function DeleteFromNthWordS(const S, WordDelims : ShortString;
+ AWord : ShortString; N : Cardinal;
+ var SubString : ShortString) : Boolean;
+
+function CopyFromToWordS(const S, WordDelims, Word1, Word2 : ShortString;
+ N1, N2 : Cardinal;
+ var SubString : ShortString) : Boolean;
+
+function DeleteFromToWordS(const S, WordDelims, Word1, Word2 : ShortString;
+ N1, N2 : Cardinal;
+ var SubString : ShortString) : Boolean;
+
+function CopyWithinS(const S, Delimiter : ShortString;
+ Strip : Boolean) : ShortString;
+
+function DeleteWithinS(const S, Delimiter : ShortString) : ShortString;
+
+function ExtractTokensS(const S, Delims : ShortString;
+ QuoteChar : AnsiChar;
+ AllowNulls : Boolean;
+ Tokens : TStrings) : Cardinal;
+
+function IsChAlphaS(C : Char) : Boolean;
+ {-Returns true if Ch is an alpha}
+
+function IsChNumericS(C : AnsiChar; const Numbers : ShortString) : Boolean;
+ {-Returns true if Ch in numeric set}
+
+function IsChAlphaNumericS(C : Char; const Numbers : ShortString) : Boolean;
+ {-Returns true if Ch is an alpha or numeric}
+
+function IsStrAlphaS(const S : string) : Boolean;
+ {-Returns true if all characters in string are an alpha}
+
+function IsStrNumericS(const S, Numbers : ShortString) : Boolean;
+ {-Returns true if all characters in string are in numeric set}
+
+function IsStrAlphaNumericS(const S, Numbers : String) : Boolean;
+ {-Returns true if all characters in string are alpha or numeric}
+
+function LastWordS(const S, WordDelims, AWord : ShortString;
+ var Position : Cardinal) : Boolean;
+ {-returns the position in a string of the last instance of a given word}
+
+function LastWordAbsS(const S, WordDelims : ShortString;
+ var Position : Cardinal) : Boolean;
+ {-returns the position in a string of the last word}
+
+function LastStringS(const S, AString : ShortString;
+ var Position : Cardinal) : Boolean;
+ {-returns the position in a string of the last instance of a given string}
+
+function LeftTrimCharsS(const S, Chars : ShortString) : ShortString;
+ {-strips given characters from the beginning of a string}
+
+function KeepCharsS(const S, Chars : ShortString) : ShortString;
+ {-returns a string containing only those characters in a given set}
+
+function RepeatStringS(const RepeatString : ShortString;
+ var Repetitions : Cardinal;
+ MaxLen : Cardinal) : ShortString;
+ {-creates a string of up to Repetition instances of a string}
+
+function ReplaceStringS(const S, OldString, NewString : ShortString;
+ N : Cardinal;
+ var Replacements : Cardinal) : ShortString;
+ {-replaces a substring with up to Replacements instances of a string}
+
+function ReplaceStringAllS(const S, OldString, NewString : ShortString;
+ var Replacements : Cardinal) : ShortString;
+ {-replaces all instances of a substring with one or more instances of a string}
+
+function ReplaceWordS(const S, WordDelims, OldWord, NewWord : ShortString;
+ N : Cardinal;
+ var Replacements : Cardinal) : ShortString;
+ {-replaces a given word with one or more instances of a string}
+
+function ReplaceWordAllS(const S, WordDelims, OldWord, NewWord : ShortString;
+ var Replacements : Cardinal) : ShortString;
+ {-replaces all instances of a word with one or more instances of a string}
+
+function RightTrimCharsS(const S, Chars : ShortString) : ShortString;
+ {-removes those characters at the end of a string contained in a set of characters}
+
+function StrWithinS(const S, SearchStr : ShortString;
+ Start : Cardinal;
+ var Position : Cardinal) : boolean;
+ {-finds the position of a substring within a string starting at a given point}
+
+function TrimCharsS(const S, Chars : ShortString) : ShortString;
+ {-removes trailing and leading characters defined by a string from a string}
+
+function WordPosS(const S, WordDelims, AWord : ShortString;
+ N : Cardinal; var Position : Cardinal) : Boolean;
+ {-returns the Nth instance of a word within a string}
+
+
+implementation
+
+
+ {-------- Numeric conversion -----------}
+
+function HexBS(B : Byte) : ShortString;
+ {-Return the hex string for a byte.}
+begin
+ Result[0] := #2;
+ Result[1] := StHexDigits[B shr 4];
+ Result[2] := StHexDigits[B and $F];
+end;
+
+function HexWS(W : Word) : ShortString;
+ {-Return the hex string for a word.}
+begin
+ Result[0] := #4;
+ Result[1] := StHexDigits[hi(W) shr 4];
+ Result[2] := StHexDigits[hi(W) and $F];
+ Result[3] := StHexDigits[lo(W) shr 4];
+ Result[4] := StHexDigits[lo(W) and $F];
+end;
+
+function HexLS(L : LongInt) : ShortString;
+ {-Return the hex string for a long integer.}
+begin
+ Result := HexWS(HiWord(DWORD(L))) + HexWS(LoWord(DWORD(L))); {!!.02}
+end;
+
+function HexPtrS(P : Pointer) : ShortString;
+ {-Return the hex string for a pointer.}
+begin
+ Result := HexLS(LongInt(P)); {!!.02}
+end;
+
+function BinaryBS(B : Byte) : ShortString;
+ {-Return a binary string for a byte.}
+var
+ I, N : Cardinal;
+begin
+ N := 1;
+ Result[0] := #8;
+ for I := 7 downto 0 do begin
+ Result[N] := StHexDigits[Ord(B and (1 shl I) <> 0)]; {0 or 1}
+ Inc(N);
+ end;
+end;
+
+function BinaryWS(W : Word) : ShortString;
+ {-Return the binary string for a word.}
+var
+ I, N : Cardinal;
+begin
+ N := 1;
+ Result[0] := #16;
+ for I := 15 downto 0 do begin
+ Result[N] := StHexDigits[Ord(W and (1 shl I) <> 0)]; {0 or 1}
+ Inc(N);
+ end;
+end;
+
+function BinaryLS(L : LongInt) : ShortString;
+ {-Return the binary string for a long integer.}
+var
+ I : Longint;
+ N : Byte;
+begin
+ N := 1;
+ Result[0] := #32;
+ for I := 31 downto 0 do begin
+ Result[N] := StHexDigits[Ord(L and LongInt(1 shl I) <> 0)]; {0 or 1}
+ Inc(N);
+ end;
+end;
+
+function OctalBS(B : Byte) : ShortString;
+ {-Return an octal string for a byte.}
+var
+ I : Cardinal;
+begin
+ Result[0] := #3;
+ for I := 0 to 2 do begin
+ Result[3-I] := StHexDigits[B and 7];
+ B := B shr 3;
+ end;
+end;
+
+function OctalWS(W : Word) : ShortString;
+ {-Return an octal string for a word.}
+var
+ I : Cardinal;
+begin
+ Result[0] := #6;
+ for I := 0 to 5 do begin
+ Result[6-I] := StHexDigits[W and 7];
+ W := W shr 3;
+ end;
+end;
+
+function OctalLS(L : LongInt) : ShortString;
+ {-Return an octal string for a long integer.}
+var
+ I : Cardinal;
+begin
+ Result[0] := #12;
+ for I := 0 to 11 do begin
+ Result[12-I] := StHexDigits[L and 7];
+ L := L shr 3;
+ end;
+end;
+
+function Str2Int16S(const S : ShortString; var I : SmallInt) : Boolean;
+ {-Convert a string to an SmallInt.}
+
+var
+ ec : Integer;
+begin
+ ValSmallint(S, I, ec);
+ if (ec = 0) then
+ Result := true
+ else begin
+ Result := false;
+ if (ec < 0) then
+ I := succ(length(S))
+ else
+ I := ec;
+ end;
+end;
+
+function Str2WordS(const S : ShortString; var I : Word) : Boolean;
+ {-Convert a string to a word.}
+
+var
+ ec : Integer;
+begin
+ ValWord(S, I, ec);
+ if (ec = 0) then
+ Result := true
+ else begin
+ Result := false;
+ if (ec < 0) then
+ I := succ(length(S))
+ else
+ I := ec;
+ end;
+end;
+
+function Str2LongS(const S : ShortString; var I : LongInt) : Boolean;
+ {-Convert a string to a long integer.}
+
+var
+ ec : Integer;
+begin
+ ValLongint(S, I, ec);
+ if (ec = 0) then
+ Result := true
+ else begin
+ Result := false;
+ if (ec < 0) then
+ I := succ(length(S))
+ else
+ I := ec;
+ end;
+end;
+
+{$IFDEF VER93}
+function Str2RealS(const S : ShortString; var R : Double) : Boolean;
+{$ELSE}
+ {-Convert a string to a real.}
+function Str2RealS(const S : ShortString; var R : Real) : Boolean;
+{$ENDIF}
+ {-Convert a string to a real.}
+var
+ Code : Integer;
+ St : ShortString;
+ SLen : Byte absolute St;
+begin
+ St := S;
+ {trim trailing blanks}
+ while St[SLen] = ' ' do
+ Dec(SLen);
+ Val(ValPrepS(St), R, Code);
+ if Code <> 0 then begin
+ R := Code;
+ Result := False;
+ end else
+ Result := True;
+end;
+
+function Str2ExtS(const S : ShortString; var R : Extended) : Boolean;
+ {-Convert a string to an extended.}
+var
+ Code : Integer;
+ P : ShortString;
+ PLen : Byte absolute P;
+begin
+ P := S;
+ {trim trailing blanks}
+ while P[PLen] = ' ' do
+ Dec(PLen);
+ Val(ValPrepS(P), R, Code);
+ if Code <> 0 then begin
+ R := Code;
+ Result := False;
+ end else
+ Result := True;
+end;
+
+function Long2StrS(L : LongInt) : ShortString;
+ {-Convert an integer type to a string.}
+begin
+ Str(L, Result);
+end;
+
+function Real2StrS(R : Double; Width : Byte; Places : ShortInt) : ShortString;
+ {-Convert a real to a string.}
+begin
+ Str(R:Width:Places, Result);
+end;
+
+function Ext2StrS(R : Extended; Width : Byte; Places : ShortInt) : ShortString;
+ {-Convert an extended to a string.}
+begin
+ Str(R:Width:Places, Result);
+end;
+
+function ValPrepS(const S : ShortString) : ShortString;
+ {-Prepares a string for calling Val.}
+var
+ P : Cardinal;
+begin
+ Result := TrimSpacesS(S);
+ if Result <> '' then begin
+ if StrChPosS(Result, {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator, P) then begin
+ Result[P] := '.';
+ if P = Byte(Result[0]) then
+ Result[0] := AnsiChar(Pred(P));
+ end;
+ end else begin
+ Result := '0';
+ end;
+end;
+
+ {-------- General purpose string manipulation --------}
+
+function CharStrS(C : AnsiChar; Len : Cardinal) : ShortString;
+ {-Return a string filled with the specified character.}
+begin
+ if Len = 0 then
+ Result[0] := #0
+ else begin
+ Result[0] := AnsiChar(Len);
+ FillChar(Result[1], Len, C);
+ end;
+end;
+
+function PadChS(const S : ShortString; C : AnsiChar; Len : Cardinal) : ShortString;
+ {-Pad a string on the right with a specified character.}
+var
+ SLen : Byte absolute S;
+begin
+ if Length(S) >= Len then
+ Result := S
+ else begin
+ if Len > 255 then Len := 255;
+ Result[0] := AnsiChar(Len);
+ Move(S[1], Result[1], SLen);
+ if SLen < 255 then
+ FillChar(Result[Succ(SLen)], Len-SLen, C);
+ end;
+end;
+
+function PadS(const S : ShortString; Len : Cardinal) : ShortString;
+ {-Pad a string on the right with spaces.}
+begin
+ Result := PadChS(S, ' ', Len);
+end;
+
+function LeftPadChS(const S : ShortString; C : AnsiChar; Len : Cardinal) : ShortString;
+ {-Pad a string on the left with a specified character.}
+begin
+ if Length(S) >= Len then
+ Result := S
+ else if Length(S) < 255 then begin
+ if Len > 255 then Len := 255;
+ Result[0] := AnsiChar(Len);
+ Move(S[1], Result[Succ(Word(Len))-Length(S)], Length(S));
+ FillChar(Result[1], Len-Length(S), C);
+ end;
+end;
+
+function LeftPadS(const S : ShortString; Len : Cardinal) : ShortString;
+ {-Pad a string on the left with spaces.}
+begin
+ Result := LeftPadChS(S, ' ', Len);
+end;
+
+function TrimLeadS(const S : ShortString) : ShortString;
+ {-Return a string with leading white space removed}
+var
+ I : Cardinal;
+begin
+{!!.03 - added }
+ if S = '' then begin
+ Result := '';
+ Exit;
+ end;
+{!!.03 - added end }
+ I := 1;
+ while (I <= Length(S)) and (S[I] <= ' ') do
+ Inc(I);
+ Move(S[I], Result[1], Length(S)-I+1);
+ Result[0] := AnsiChar(Length(S)-I+1);
+end;
+
+function TrimTrailS(const S : ShortString) : ShortString;
+ {-Return a string with trailing white space removed.}
+begin
+ Result := S;
+ while (Length(Result) > 0) and (Result[Length(Result)] <= ' ') do
+ Dec(Result[0]);
+end;
+
+function TrimS(const S : ShortString) : ShortString;
+ {-Return a string with leading and trailing white space removed.}
+var
+ I : Cardinal;
+ SLen : Byte absolute Result;
+begin
+ Result := S;
+ while (SLen > 0) and (Result[SLen] <= ' ') do
+ Dec(SLen);
+
+ I := 1;
+ while (I <= SLen) and (Result[I] <= ' ') do
+ Inc(I);
+ Dec(I);
+ if I > 0 then
+ Delete(Result, 1, I);
+end;
+
+function TrimSpacesS(const S : ShortString) : ShortString;
+ {-Return a string with leading and trailing spaces removed.}
+var
+ I : Word;
+begin
+ Result := S;
+ while (Length(Result) > 0) and (Result[Length(Result)] = ' ') do
+ Dec(Result[0]);
+ I := 1;
+ while (I <= Length(Result)) and (S[I] = ' ') do
+ Inc(I);
+ Dec(I);
+ if I > 0 then
+ Delete(Result, 1, I);
+end;
+
+function CenterChS(const S : ShortString; C : AnsiChar; Len : Cardinal) : ShortString;
+ {-Pad a string on the left and right with a specified character.}
+begin
+ if Length(S) >= Len then
+ Result := S
+ else if Length(S) < 255 then begin
+ if Len > 255 then Len := 255;
+ Result[0] := AnsiChar(Len);
+ FillChar(Result[1], Len, C);
+ Move(S[1], Result[Succ((Len-Length(S)) shr 1)], Length(S));
+ end;
+end;
+
+function CenterS(const S : ShortString; Len : Cardinal) : ShortString;
+ {-Pad a string on the left and right with spaces.}
+begin
+ Result := CenterChS(S, ' ', Len);
+end;
+
+{$IFNDEF FPC}
+function EntabS(const S : ShortString; TabSize : Byte) : ShortString;
+ {-Convert blanks in a string to tabs.}
+register;
+asm
+ push ebx { Save registers }
+ push edi
+ push esi
+
+ mov esi, eax { ESI => input string }
+ mov edi, ecx { EDI => output string }
+ xor ebx, ebx { Initial SpaceCount = 0 }
+ xor ecx, ecx { Default input length = 0 }
+ and edx, 0FFh { Default output length = 0 in DH, TabSize in DL }
+
+ mov cl, [esi] { Get input length }
+ inc esi
+ or edx, edx { TabSize = 0? }
+ jnz @@DefLength
+ mov ecx, edx { Return zero length string if TabSize = 0 }
+
+@@DefLength:
+ mov [edi], cl { Store default output length }
+ inc edi
+ or ecx, ecx
+ jz @@Done { Done if empty input string }
+ inc ch { Current input position=1 }
+
+@@Next:
+ or ebx, ebx { Compare SpaceCount to 0 }
+ jz @@NoTab { If SpaceCount=0 then no tab insert here }
+ xor eax, eax
+ mov al, ch { Ipos to AL }
+ div dl { Ipos DIV TabSize }
+ cmp ah, 1 { Ipos MOD TabSize = 1 ? }
+ jnz @@NoTab { If not, no tab insert here }
+ sub edi, ebx { Remove unused characters from output string }
+ sub dh, bl { Reduce Olen by SpaceCount }
+ inc dh { Add one to output length }
+ xor ebx, ebx { Reset SpaceCount }
+ mov byte ptr [edi], 09h { Store a tab }
+ inc edi
+
+@@NoTab:
+ mov al, [esi] { Get next input character }
+ inc esi
+ cmp cl, ch { End of string? }
+ jz @@Store { Yes, store character anyway }
+ inc bl { Increment SpaceCount }
+ cmp al, 32 { Is character a space? }
+ jz @@Store { Yes, store it for now }
+ xor ebx, ebx { Reset SpaceCount }
+ cmp al, 39 { Is it a quote? }
+ jz @@Quotes { Yep, enter quote loop }
+ cmp al, 34 { Is it a doublequote? }
+ jnz @@Store { Nope, store it }
+
+@@Quotes:
+ mov ah, al { Save quote start }
+
+@@NextQ:
+ mov [edi], al { Store quoted character }
+ inc edi
+ inc dh { Increment output length }
+ mov al, [esi] { Get next character }
+ inc esi
+ inc ch { Increment Ipos }
+ cmp ch, cl { At end of line? }
+ jae @@Store { If so, exit quote loop }
+ cmp al, ah { Matching end quote? }
+ jnz @@NextQ { Nope, stay in quote loop }
+ cmp al, 39 { Single quote? }
+ jz @@Store { Exit quote loop }
+ cmp byte ptr [esi-2],'\'{ Previous character an escape? }
+ jz @@NextQ { Stay in if so }
+
+@@Store:
+ mov [edi], al { Store last character }
+ inc edi
+ inc dh { Increment output length }
+ inc ch { Increment input position }
+ jz @@StoreLen { Exit if past 255 }
+ cmp ch, cl { Compare Ipos to Ilen }
+ jbe @@Next { Repeat while characters left }
+
+@@StoreLen:
+ xor eax, eax
+ mov al, dh
+ sub edi, eax
+ dec edi
+ mov [edi], dh { Store final length }
+
+@@Done:
+ pop esi
+ pop edi
+ pop ebx
+end;
+
+function DetabS(const S : ShortString; TabSize : Byte) : ShortString;
+ {-Expand tabs in a string to blanks.}
+register;
+asm
+ push ebx
+ push edi
+ push esi
+
+ mov edi, ecx { EDI => output string }
+ mov esi, eax { ESI => input string }
+ xor ecx, ecx { Default input length = 0 }
+ and edx, 0FFh { Default output length = 0 in DH, DL is Tabsize }
+ xor eax, eax
+ mov cl, [esi] { Get input length }
+ inc esi
+ or edx, edx { TabSize = 0? }
+ jnz @@DefLength
+ mov ecx, edx { Return zero length string if TabSize = 0 }
+
+@@DefLength:
+ mov [edi], cl { Store default output length }
+ inc edi
+ or ecx, ecx
+ jz @@Done { Done if empty input string }
+ mov ah, 09h { Store tab in AH }
+ mov bl, 255 { Maximum length of output }
+
+@@Next:
+ mov al, [esi] { Next input character }
+ inc esi
+ cmp al, ah { Is it a tab? }
+ jz @@Tab { Yes, compute next tab stop }
+ mov [edi], al { No, store to output }
+ inc edi
+ inc dh { Increment output length }
+ cmp dh, bl { 255 characters max }
+ jz @@StoreLen
+ dec cl
+ jnz @@Next { Next character while Olen <= 255 }
+ jmp @@StoreLen { Loop termination }
+
+@@Tab:
+ mov bh, cl { Save input counter }
+ mov al, dh { Current output length in AL }
+ and eax, 0FFh { Clear top byte }
+ div dl { OLen DIV TabSize in AL }
+ inc al { Round up to next tab position }
+ mul dl { Next tab position in AX }
+ or ah, ah { AX > 255? }
+ jnz @@StoreLen { Can't store it }
+ sub al, dh { Count of blanks to insert }
+ add dh, al { New output length in DH }
+ mov cl, al { Loop counter for blanks }
+ mov ax, 0920h { Tab in AH, Blank in AL }
+ rep stosb { Store blanks }
+ mov cl, bh { Restore input position }
+ dec cl
+ jnz @@Next { Back for next input }
+
+@@StoreLen:
+ xor eax, eax
+ mov al, dh
+ sub edi, eax
+ dec edi
+ mov [edi], dh { Store final length }
+
+@@Done:
+ pop esi
+ pop edi
+ pop ebx
+end;
+{$ENDIF}
+
+function ScrambleS(const S, Key : ShortString) : ShortString;
+ {-Encrypt / Decrypt string with enhanced XOR encryption.}
+var
+ J, LKey, LStr : Byte;
+ I : Cardinal;
+begin
+ Result := S;
+ LKey := Length(Key);
+ LStr := Length(S);
+ if LKey = 0 then Exit;
+ if LStr = 0 then Exit;
+ I := 1;
+ J := LKey;
+ while I <= LStr do begin
+ if J = 0 then
+ J := LKey;
+ if (S[I] <> Key[J]) then
+ Result[I] := AnsiChar(Byte(S[I]) xor Byte(Key[J]));
+ inc(I);
+ dec(J);
+ end;
+end;
+
+function SubstituteS(const S, FromStr, ToStr : ShortString) : ShortString;
+ {-Map the characters found in FromStr to the corresponding ones in ToStr.}
+var
+ P : Cardinal;
+ I : Byte;
+begin
+ Result := S;
+ if Length(FromStr) = Length(ToStr) then
+ for I := 1 to Length(Result) do begin
+ if StrChPosS(FromStr, S[I], P) then
+ Result[I] := ToStr[P];
+ end;
+end;
+
+function FilterS(const S, Filters : ShortString) : ShortString;
+ {-Remove characters from a string. The characters to remove are specified in
+ ChSet.}
+var
+ I : Cardinal;
+ Len : Cardinal;
+begin
+ Len := 0;
+ for I := 1 to Length(S) do
+ if not CharExistsS(Filters, S[I]) then begin
+ Inc(Len);
+ Result[Len] := S[I];
+ end;
+ Result[0] := AnsiChar(Len);
+end;
+
+ {--------------- Word / Char manipulation -------------------------}
+
+function CharExistsS(const S : String; C : Char) : Boolean; overload;
+var
+ I: Integer;
+begin
+ Result := False;
+ for I := 1 to Length(S) do
+ begin
+ if S[I] = C then
+ begin
+ Result := True;
+ Break;
+ end;
+ end;
+end;
+
+function CharExistsS(const S : ShortString; C : AnsiChar) : Boolean; overload;
+ {-Determine whether a given character exists in a string. }
+register;
+asm
+ xor ecx, ecx
+ mov ch, [eax]
+ inc eax
+ or ch, ch
+ jz @@Done
+ jmp @@5
+
+@@Loop:
+ cmp dl, [eax+3]
+ jne @@1
+ inc cl
+ jmp @@Done
+
+@@1:
+ cmp dl, [eax+2]
+ jne @@2
+ inc cl
+ jmp @@Done
+
+@@2:
+ cmp dl, [eax+1]
+ jne @@3
+ inc cl
+ jmp @@Done
+
+@@3:
+ cmp dl, [eax+0]
+ jne @@4
+ inc cl
+ jmp @@Done
+
+@@4:
+ add eax, 4
+ sub ch, 4
+ jna @@Done
+
+@@5:
+ cmp ch, 4
+ jae @@Loop
+
+ cmp ch, 3
+ je @@1
+
+ cmp ch, 2
+ je @@2
+
+ cmp ch, 1
+ je @@3
+
+@@Done:
+ xor eax, eax
+ mov al, cl
+end;
+
+function CharCountS(const S : ShortString; C : AnsiChar) : Byte;
+ {-Count the number of a given character in a string. }
+register;
+asm
+ xor ecx, ecx
+ mov ch, [eax]
+ inc eax
+ or ch, ch
+ jz @@Done
+ jmp @@5
+
+@@Loop:
+ cmp dl, [eax+3]
+ jne @@1
+ inc cl
+
+@@1:
+ cmp dl, [eax+2]
+ jne @@2
+ inc cl
+
+@@2:
+ cmp dl, [eax+1]
+ jne @@3
+ inc cl
+
+@@3:
+ cmp dl, [eax+0]
+ jne @@4
+ inc cl
+
+@@4:
+ add eax, 4
+ sub ch, 4
+ jna @@Done
+
+@@5:
+ cmp ch, 4
+ jae @@Loop
+
+ cmp ch, 3
+ je @@1
+
+ cmp ch, 2
+ je @@2
+
+ cmp ch, 1
+ je @@3
+
+@@Done:
+ mov al, cl
+end;
+
+function WordCountS(const S, WordDelims : ShortString) : Cardinal;
+ {-Given an array of word delimiters, return the number of words in a string.}
+var
+ I : Integer;
+ SLen : Byte;
+begin
+ Result := 0;
+ I := 1;
+ SLen := Length(S);
+
+ while I <= SLen do begin
+ {skip over delimiters}
+ while (I <= SLen) and CharExistsS(WordDelims, S[I]) do
+ Inc(I);
+
+ {if we're not beyond end of S, we're at the start of a word}
+ if I <= SLen then
+ Inc(Result);
+
+ {find the end of the current word}
+ while (I <= SLen) and not CharExistsS(WordDelims, S[I]) do
+ Inc(I);
+ end;
+end;
+
+function WordPositionS(N : Cardinal; const S, WordDelims : ShortString;
+ var Pos : Cardinal) : Boolean;
+ {-Given an array of word delimiters, set Pos to the start position of the
+ N'th word in a string. Result indicates success/failure.}
+var
+ I : Cardinal;
+ Count : Byte;
+ SLen : Byte absolute S;
+begin
+ Count := 0;
+ I := 1;
+ Result := False;
+
+ while (I <= SLen) and (Count <> N) do begin
+ {skip over delimiters}
+ while (I <= SLen) and CharExistsS(WordDelims, S[I]) do
+ Inc(I);
+
+ {if we're not beyond end of S, we're at the start of a word}
+ if I <= SLen then
+ Inc(Count);
+
+ {if not finished, find the end of the current word}
+ if Count <> N then
+ while (I <= SLen) and not CharExistsS(WordDelims, S[I]) do
+ Inc(I)
+ else begin
+ Pos := I;
+ Result := True;
+ end;
+ end;
+end;
+
+function ExtractWordS(N : Cardinal; const S, WordDelims : ShortString) : ShortString;
+ {-Given an array of word delimiters, return the N'th word in a string.}
+var
+ I : Cardinal;
+ Len : Byte;
+ SLen : Byte absolute S;
+begin
+ Len := 0;
+ if WordPositionS(N, S, WordDelims, I) then
+ {find the end of the current word}
+ while (I <= SLen) and not CharExistsS(WordDelims, S[I]) do begin
+ {add the I'th character to result}
+ Inc(Len);
+ Result[Len] := S[I];
+ Inc(I);
+ end;
+ Result[0] := AnsiChar(Len);
+end;
+
+function AsciiCountS(const S, WordDelims : ShortString; Quote : AnsiChar) : Cardinal;
+ {-Return the number of words in a string.}
+var
+ I : Cardinal;
+ InQuote : Boolean;
+ SLen : Byte absolute S;
+begin
+ Result := 0;
+ I := 1;
+ InQuote := False;
+ while I <= SLen do begin
+ {skip over delimiters}
+ while (I <= SLen) and (S[i] <> Quote) and CharExistsS(WordDelims, S[I]) do
+ Inc(I);
+ {if we're not beyond end of S, we're at the start of a word}
+ if I <= SLen then
+ Inc(Result);
+ {find the end of the current word}
+ while (I <= SLen) and (InQuote or not CharExistsS(WordDelims, S[I])) do begin
+ if S[I] = Quote then
+ InQuote := not InQuote;
+ Inc(I);
+ end;
+ end;
+end;
+
+function AsciiPositionS(N : Cardinal; const S, WordDelims : ShortString;
+ Quote : AnsiChar; var Pos : Cardinal) : Boolean;
+ {-Return the position of the N'th word in a string.}
+var
+ I : Cardinal;
+ Count : Byte;
+ InQuote : Boolean;
+ SLen : Byte absolute S;
+begin
+ Count := 0;
+ InQuote := False;
+ Result := False;
+ I := 1;
+ while (I <= SLen) and (Count <> N) do begin
+ {skip over delimiters}
+ while (I <= SLen) and (S[I] <> Quote) and CharExistsS(WordDelims, S[I]) do
+ Inc(I);
+ {if we're not beyond end of S, we're at the start of a word}
+ if I <= SLen then
+ Inc(Count);
+ {if not finished, find the end of the current word}
+ if Count <> N then
+ while (I <= SLen) and (InQuote or not CharExistsS(WordDelims, S[I])) do begin
+ if S[I] = Quote then
+ InQuote := not InQuote;
+ Inc(I);
+ end
+ else begin
+ Pos := I;
+ Result := True;
+ end;
+ end;
+end;
+
+function ExtractAsciiS(N : Cardinal; const S, WordDelims : ShortString;
+ Quote : AnsiChar) : ShortString;
+ {-Given an array of word delimiters, return the N'th word in a string. Any
+ text within Quote characters is counted as one word.}
+var
+ I : Cardinal;
+ Len : Byte;
+ SLen : Byte absolute S;
+ InQuote : Boolean;
+begin
+ Len := 0;
+ InQuote := False;
+ if AsciiPositionS(N, S, WordDelims, Quote, I) then
+ {find the end of the current word}
+ while (I <= SLen) and ((InQuote) or not CharExistsS(WordDelims, S[I])) do begin
+ {add the I'th character to result}
+ Inc(Len);
+ if S[I] = Quote then
+ InQuote := not(InQuote);
+ Result [Len] := S[I];
+ Inc(I);
+ end;
+ Result [0] := AnsiChar(Len);
+end;
+
+procedure WordWrapS(const InSt : ShortString; var OutSt, Overlap : ShortString;
+ Margin : Cardinal; PadToMargin : Boolean);
+ {-Wrap a text string at a specified margin.}
+var
+ EOS, BOS : Cardinal;
+ InStLen : Byte;
+ OutStLen : Byte absolute OutSt;
+ OvrLen : Byte absolute Overlap;
+begin
+ InStLen := Length(InSt);
+
+{!!.02 - Added }
+ { handle empty string on input }
+ if InStLen = 0 then begin
+ OutSt := '';
+ Overlap := '';
+ Exit;
+ end;
+{!!.02 - End Added }
+
+ {find the end of the output string}
+ if InStLen > Margin then begin
+ {find the end of the word at the margin, if any}
+ EOS := Margin;
+ while (EOS <= InStLen) and (InSt[EOS] <> ' ') do
+ Inc(EOS);
+ if EOS > InStLen then
+ EOS := InStLen;
+
+ {trim trailing blanks}
+ while (InSt[EOS] = ' ') and (EOS > 0) do
+ Dec(EOS);
+
+ if EOS > Margin then begin
+ {look for the space before the current word}
+ while (EOS > 0) and (InSt[EOS] <> ' ') do
+ Dec(EOS);
+
+ {if EOS = 0 then we can't wrap it}
+ if EOS = 0 then
+ EOS := Margin
+ else
+ {trim trailing blanks}
+ while (InSt[EOS] = ' ') and (EOS > 0) do
+ Dec(EOS);
+ end;
+ end else
+ EOS := InStLen;
+
+ {copy the unwrapped portion of the line}
+ OutStLen := EOS;
+ Move(InSt[1], OutSt[1], OutStLen);
+
+ {find the start of the next word in the line}
+ BOS := EOS+1;
+ while (BOS <= InStLen) and (InSt[BOS] = ' ') do
+ Inc(BOS);
+
+ if BOS > InStLen then
+ OvrLen := 0
+ else begin
+ {copy from the start of the next word to the end of the line}
+ OvrLen := Succ(InStLen-BOS);
+ Move(InSt[BOS], Overlap[1], OvrLen);
+ end;
+
+ {pad the end of the output string if requested}
+ if PadToMargin and (OutStLen < Margin) then begin
+ FillChar(OutSt[OutStLen+1], Margin-OutStLen, ' ');
+ OutStLen := Margin;
+ end;
+end;
+
+ {--------------- String comparison and searching -----------------}
+function CompStringS(const S1, S2 : ShortString) : Integer;
+ {-Compare two strings.}
+register;
+asm
+ push edi
+ mov edi, edx { EDI points to S2 }
+ push esi
+ mov esi, eax { ESI points to S1 }
+
+ xor ecx, ecx
+
+ mov dl, [edi] { DL = Length(S2) }
+ inc edi { EDI points to S2[1] }
+ mov cl, [esi]
+ inc esi { CL = Length(S1) - ESI points to S1[1] }
+
+ or eax, -1 { EAX holds temporary result }
+
+ cmp cl, dl { Compare lengths }
+ je @@EqLen { Lengths equal? }
+ jb @@Comp { Jump if S1 shorter than S1 }
+
+ inc eax { S1 longer than S2 }
+ mov cl, dl { Length(S2) in CL }
+
+@@EqLen:
+ inc eax { Equal or greater }
+
+@@Comp:
+ or ecx, ecx
+ jz @@Done { Done if either is empty }
+
+ repe cmpsb { Compare until no match or ECX = 0 }
+ je @@Done { If Equal, result ready based on length }
+
+ mov eax, 1
+ ja @@Done { S1 Greater? Return 1 }
+ or eax, -1 { Else S1 Less, Return -1 }
+
+@@Done:
+ pop esi
+ pop edi
+end;
+
+function CompUCStringS(const S1, S2 : ShortString) : Integer;
+ {-Compare two strings. This compare is not case sensitive.}
+register;
+asm
+ push ebx
+ push edi { Save registers }
+ push esi
+
+ mov edi, edx { EDI points to S2 }
+ mov esi, eax { ESI points to S1 }
+
+ xor eax, eax { EAX holds chars from S1 }
+ xor ecx, ecx { ECX holds count of chars to compare }
+ xor edx, edx { DH holds temp result, DL chars from S2 }
+ or ebx, -1
+
+ mov al, [edi] { AH = Length(S2) }
+ inc edi { EDI points to S2[1] }
+ mov cl, [esi] { CL = Length(S1) - SI points to S1[1] }
+ inc esi
+
+ cmp cl, al { Compare lengths }
+ je @@EqLen { Lengths equal? }
+ jb @@Comp { Jump if S1 shorter than S1 }
+
+ inc ebx { S1 longer than S2 }
+ mov cl, al { Shorter length in CL }
+
+@@EqLen:
+ inc ebx { Equal or greater }
+
+@@Comp:
+ or ecx, ecx
+ jz @@Done { Done if lesser string is empty }
+
+@@Start:
+ mov al, [esi] { S1[?] into AL }
+ inc esi
+
+ push ecx { Save registers }
+ push edx
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper
+ pop edx { Restore registers }
+ pop ecx
+
+ mov dl, [edi] { S2[?] into DL }
+ inc edi { Point EDI to next char in S2 }
+ mov dh, al
+ mov al, dl
+ mov dl, dh
+
+ push ecx { Save registers }
+ push edx
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper
+ pop edx { Restore registers }
+ pop ecx
+
+ cmp dl, al { Compare until no match }
+ jnz @@Output
+ dec ecx
+ jnz @@Start
+
+ je @@Done { If Equal, result ready based on length }
+
+@@Output:
+ mov ebx, 1
+ ja @@Done { S1 Greater? Return 1 }
+ or ebx, -1 { Else S1 Less, Return -1 }
+
+@@Done:
+ mov eax, ebx { Result into AX }
+ pop esi { Restore Registers }
+ pop edi
+ pop ebx
+end;
+
+function SoundexS(const S : ShortString) : ShortString; assembler;
+ {-Return 4 character soundex of an input string}
+register;
+const
+ SoundexTable : array[0..255] of Char =
+ (#0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0,
+ { A B C D E F G H I J K L M }
+ #0, '1', '2', '3', #0, '1', '2', #0, #0, '2', '2', '4', '5',
+ { N O P Q R S T U V W X Y X }
+ '5', #0, '1', '2', '6', '2', '3', #0, '1', #0, '2', #0, '2',
+ #0, #0, #0, #0, #0, #0,
+ { a b c d e f g h i j k l m }
+ #0, '1', '2', '3', #0, '1', '2', #0, #0, '2', '2', '4', '5',
+ { n o p q r s t u v w x y x }
+ '5', #0, '1', '2', '6', '2', '3', #0, '1', #0, '2', #0, '2',
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0, #0, #0, #0, #0, #0, #0, #0,
+ #0, #0, #0);
+asm
+ push edi
+ mov edi, edx { EDI => output string }
+ push ebx
+ push esi
+
+ mov esi, eax { ESI => input string }
+ mov byte ptr [edi], 4 { Prepare output string to be #4'0000' }
+ mov dword ptr [edi+1], '0000'
+ inc edi
+
+ mov cl, byte ptr [esi]
+ inc esi
+ or cl, cl { Exit if null string }
+ jz @@Done
+
+ xor eax, eax
+ mov al, [esi] { Get first character of input string }
+ inc esi
+
+ push ecx { Save ECX across call to CharUpper }
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper { Uppercase AL }
+ pop ecx { Restore saved register }
+
+ mov [edi], al { Store first output character }
+ inc edi
+
+ dec cl { One input character used }
+ jz @@Done { Was input string one char long? }
+
+ mov ch, 03h { Output max 3 chars beyond first }
+ mov edx, offset SoundexTable { EDX => Soundex table }
+ xor eax, eax { Prepare for address calc }
+ xor bl, bl { BL will be used to store 'previous char' }
+
+@@Next:
+ mov al, [esi] { Get next char in AL }
+ inc esi
+ mov al, [edx+eax] { Get soundex code into AL }
+ or al, al { Is AL zero? }
+ jz @@NoStore { If yes, skip this char }
+ cmp bl, al { Is it the same as the previous stored char? }
+ je @@NoStore { If yes, skip this char }
+ mov [edi], al { Store char to Dest }
+ inc edi
+ dec ch { Decrement output counter }
+ jz @@Done { If zero, we're done }
+ mov bl, al { New previous character }
+
+@@NoStore:
+ dec cl { Decrement input counter }
+ jnz @@Next
+
+@@Done:
+ pop esi
+ pop ebx
+ pop edi
+end;
+
+function MakeLetterSetS(const S : ShortString) : Longint;
+ {-Return a bit-mapped long storing the individual letters contained in S.}
+register;
+asm
+ push ebx { Save registers }
+ push esi
+
+ mov esi, eax { ESI => string }
+ xor ecx, ecx { Zero ECX }
+ xor edx, edx { Zero EDX }
+ xor eax, eax { Zero EAX }
+ add cl, [esi] { CX = Length(S) }
+ jz @@Exit { Done if ECX is 0 }
+ inc esi
+
+@@Next:
+ mov al, [esi] { EAX has next char in S }
+ inc esi
+
+ push ecx { Save registers }
+ push edx
+ push eax { Push Char onto stack for CharUpper }
+ call CharUpper
+ pop edx { Restore registers }
+ pop ecx
+
+ sub eax, 'A' { Convert to bit number }
+ cmp eax, 'Z'-'A' { Was char in range 'A'..'Z'? }
+ ja @@Skip { Skip it if not }
+
+ mov ebx, eax { Exchange EAX and ECX }
+ mov eax, ecx
+ mov ecx, ebx
+ ror edx, cl
+ or edx, 01h { Set appropriate bit }
+ rol edx, cl
+ mov ebx, eax { Exchange EAX and ECX }
+ mov eax, ecx
+ mov ecx, ebx
+
+@@Skip:
+ dec ecx
+ jnz @@Next { Get next character }
+
+@@Exit:
+ mov eax, edx { Move EDX to result }
+ pop esi { Restore registers }
+ pop ebx
+end;
+
+procedure BMMakeTableS(const MatchString : ShortString; var BT : BTable);
+ {-Build a Boyer-Moore link table}
+register;
+asm
+ push edi { Save registers because they will be changed }
+ push esi
+ mov esi, eax { Move EAX to ESI }
+ push ebx
+
+ xor eax, eax { Zero EAX }
+ xor ecx, ecx { Zero ECX }
+ mov cl, [esi] { ECX has length of MatchString }
+ inc esi
+
+ mov ch, cl { Duplicate CL in CH }
+ mov eax, ecx { Fill each byte in EAX with length }
+ shl eax, 16
+ or eax, ecx
+ mov edi, edx { Point to the table }
+ mov ecx, 64 { Fill table bytes with length }
+ rep stosd
+ cmp al, 1 { If length <= 1, we're done }
+ jbe @@MTDone
+ xor ebx, ebx { Zero EBX }
+ mov cl, al { Restore CL to length of string }
+ dec ecx
+
+@@MTNext:
+ mov al, [esi] { Load table with positions of letters }
+ mov bl, al { that exist in the search string }
+ inc esi
+ mov [edx+ebx], cl
+ dec cl
+ jnz @@MTNext
+
+@@MTDone:
+ pop ebx { Restore registers }
+ pop esi
+ pop edi
+end;
+
+function BMSearchS(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : ShortString ; var Pos : Cardinal) : Boolean; assembler;
+ {-Use the Boyer-Moore search method to search a buffer for a string.}
+register;
+var
+ BufPtr : Pointer;
+asm
+ push edi { Save registers since we will be changing }
+ push esi
+ push ebx
+
+ mov BufPtr, eax { Copy Buffer to local variable and EDI }
+ mov edi, eax
+ mov ebx, ecx { Copy BT ptr to EBX }
+ mov ecx, edx { Length of buffer to ECX }
+ mov esi, MatchString { Set ESI to beginning of MatchString }
+ xor eax, eax { Zero EAX }
+
+ mov dl, [esi] { Length of MatchString in EDX }
+ inc esi
+ and edx, 0FFh
+
+ cmp dl, 1 { Check to see if we have a trivial case }
+ ja @@BMSInit { If Length(MatchString) > 1 do BM search }
+ jb @@BMSNotFound { If Length(MatchString) = 0 we're done }
+
+ mov al,[esi] { If Length(MatchString) = 1 do a REPNE SCASB }
+ mov ebx, edi
+ repne scasb
+ jne @@BMSNotFound { No match during REP SCASB }
+ mov esi, Pos { Set position in Pos }
+ {dec edi} { Found, calculate position }
+ sub edi, ebx
+ mov eax, 1 { Set result to True }
+ mov [esi], edi
+ jmp @@BMSDone { We're done }
+
+@@BMSInit:
+ dec edx { Set up for BM Search }
+ add esi, edx { Set ESI to end of MatchString }
+ add ecx, edi { Set ECX to end of buffer }
+ add edi, edx { Set EDI to first check point }
+ std { Backward string ops }
+ mov dh, [esi] { Set DH to character we'll be looking for }
+ dec esi { Dec ESI in prep for BMSFound loop }
+ jmp @@BMSComp { Jump to first comparison }
+
+@@BMSNext:
+ mov al, [ebx+eax] { Look up skip distance from table }
+ add edi, eax { Skip EDI ahead to next check point }
+
+@@BMSComp:
+ cmp edi, ecx { Have we reached end of buffer? }
+ jae @@BMSNotFound { If so, we're done }
+ mov al, [edi] { Move character from buffer into AL for comparison }
+ cmp dh, al { Compare }
+ jne @@BMSNext { If not equal, go to next checkpoint }
+
+ push ecx { Save ECX }
+ dec edi
+ xor ecx, ecx { Zero ECX }
+ mov cl, dl { Move Length(MatchString) to ECX }
+ repe cmpsb { Compare MatchString to buffer }
+ je @@BMSFound { If equal, string is found }
+
+ mov al, dl { Move Length(MatchString) to AL }
+ sub al, cl { Calculate offset that string didn't match }
+ add esi, eax { Move ESI back to end of MatchString }
+ add edi, eax { Move EDI to pre-string compare location }
+ inc edi
+ mov al, dh { Move character back to AL }
+ pop ecx { Restore ECX }
+ jmp @@BMSNext { Do another compare }
+
+@@BMSFound: { EDI points to start of match }
+ mov edx, BufPtr { Move pointer to buffer into EDX }
+ mov esi, Pos
+ sub edi, edx { Calculate position of match }
+ mov eax, edi
+ inc eax
+ inc eax { Pos is one based }
+ mov [esi], eax { Set Pos to position of match }
+ mov eax, 1 { Set result to True }
+ pop ecx { Restore ESP }
+ jmp @@BMSDone
+
+@@BMSNotFound:
+ xor eax, eax { Set result to False }
+
+@@BMSDone:
+ cld { Restore direction flag }
+ pop ebx { Restore registers }
+ pop esi
+ pop edi
+end;
+
+function BMSearchUCS(var Buffer; BufLength : Cardinal; var BT : BTable;
+ const MatchString : ShortString ; var Pos : Cardinal) : Boolean; assembler;
+ {-Use the Boyer-Moore search method to search a buffer for a string. This
+ search is not case sensitive.}
+register;
+var
+ BufPtr : Pointer;
+asm
+ push edi { Save registers since we will be changing }
+ push esi
+ push ebx
+
+ mov BufPtr, eax { Copy Buffer to local variable and ESI }
+ mov edi, eax
+ mov ebx, ecx { Copy BT ptr to EBX }
+ mov ecx, edx { Length of buffer to ECX }
+ mov esi, MatchString { Set ESI to beginning of MatchString }
+ xor eax, eax { Zero EAX }
+
+ mov dl, byte ptr [esi] { Length of MatchString in EDX }
+ and edx, 0FFh { Clean up EDX }
+ inc esi { Set ESI to first character }
+
+ or dl, dl { Check to see if we have a trivial case }
+ jz @@BMSNotFound { If Length(MatchString) = 0 we're done }
+
+@@BMSInit:
+ dec edx { Set up for BM Search }
+ add esi, edx { Set ESI to end of MatchString }
+ add ecx, edi { Set ECX to end of buffer }
+ add edi, edx { Set EDI to first check point }
+ std { Backward string ops }
+ mov dh, [esi] { Set DH to character we'll be looking for }
+ dec esi { Dec ESI in prep for BMSFound loop }
+ jmp @@BMSComp { Jump to first comparison }
+
+@@BMSNext:
+ mov al, [ebx+eax] { Look up skip distance from table }
+ add edi, eax { Skip EDI ahead to next check point }
+
+@@BMSComp:
+ cmp edi, ecx { Have we reached end of buffer? }
+ jae @@BMSNotFound { If so, we're done }
+
+ push ebx { Save registers }
+ push ecx
+ push edx
+ mov al, [edi] { Move character from buffer into AL for comparison }
+ push eax { Push Char onto stack for CharUpper }
+ cld
+ call CharUpper
+ std
+ pop edx { Restore registers }
+ pop ecx
+ pop ebx
+
+ cmp dh, al { Compare }
+ jne @@BMSNext { If not equal, go to next checkpoint }
+
+ push ecx { Save ECX }
+ dec edi
+ xor ecx, ecx { Zero ECX }
+ mov cl, dl { Move Length(MatchString) to ECX }
+ jecxz @@BMSFound { If ECX is zero, string is found }
+
+@@StringComp:
+ xor eax, eax
+ mov al, [edi] { Get char from buffer }
+ dec edi { Dec buffer index }
+
+ push ebx { Save registers }
+ push ecx
+ push edx
+ push eax { Push Char onto stack for CharUpper }
+ cld
+ call CharUpper
+ std
+ pop edx { Restore registers }
+ pop ecx
+ pop ebx
+
+ mov ah, al { Move buffer char to AH }
+ mov al, [esi] { Get MatchString char }
+ dec esi
+ cmp ah, al { Compare }
+ loope @@StringComp { OK? Get next character }
+ je @@BMSFound { Matched! }
+
+ xor ah, ah { Zero AH }
+ mov al, dl { Move Length(MatchString) to AL }
+ sub al, cl { Calculate offset that string didn't match }
+ add esi, eax { Move ESI back to end of MatchString }
+ add edi, eax { Move EDI to pre-string compare location }
+ inc edi
+ mov al, dh { Move character back to AL }
+ pop ecx { Restore ECX }
+ jmp @@BMSNext { Do another compare }
+
+@@BMSFound: { EDI points to start of match }
+ mov edx, BufPtr { Move pointer to buffer into EDX }
+ mov esi, Pos
+ sub edi, edx { Calculate position of match }
+ mov eax, edi
+ inc eax
+ inc eax { Pos is one based }
+ mov [esi], eax { Set Pos to position of match }
+ mov eax, 1 { Set result to True }
+ pop ecx { Restore ESP }
+ jmp @@BMSDone
+
+@@BMSNotFound:
+ xor eax, eax { Set result to False }
+
+@@BMSDone:
+ cld { Restore direction flag }
+ pop ebx { Restore registers }
+ pop esi
+ pop edi
+end;
+
+ {--------------- DOS pathname parsing -----------------}
+
+function DefaultExtensionS(const Name, Ext : ShortString) : ShortString;
+ {-Return a file name with a default extension attached.}
+var
+ DotPos : Cardinal;
+begin
+ if HasExtensionS(Name, DotPos) then
+ Result := Name
+ else if Name = '' then
+ Result := ''
+ else
+ Result := Name + '.' + Ext;
+end;
+
+function ForceExtensionS(const Name, Ext : ShortString) : ShortString;
+ {-Force the specified extension onto the file name.}
+var
+ DotPos : Cardinal;
+begin
+ if HasExtensionS(Name, DotPos) then
+ Result := Copy(Name, 1, DotPos) + Ext
+ else if Name = '' then
+ Result := ''
+ else
+ Result := Name + '.' + Ext;
+end;
+
+function JustFilenameS(const PathName : ShortString) : ShortString;
+ {-Return just the filename and extension of a pathname.}
+var
+ I : Longint;
+begin
+ Result := '';
+ if PathName = '' then
+ Exit;
+ I := Succ(Length(PathName));
+ repeat
+ Dec(I);
+ until (I = 0) or (PathName[I] in DosDelimSet); {!!.01}
+ Result := Copy(PathName, Succ(I), StMaxFileLen);
+end;
+
+function JustNameS(const PathName : ShortString) : ShortString;
+ {-Return just the filename (no extension, path, or drive) of a pathname.}
+var
+ DotPos : Cardinal;
+begin
+ Result := JustFileNameS(PathName);
+ if HasExtensionS(Result, DotPos) then
+ Result := Copy(Result, 1, DotPos-1);
+end;
+
+function JustExtensionS(const Name : ShortString) : ShortString;
+ {-Return just the extension of a pathname.}
+var
+ DotPos : Cardinal;
+begin
+ if HasExtensionS(Name, DotPos) then
+ Result := Copy(Name, Succ(DotPos), StMaxFileLen)
+ else
+ Result := '';
+end;
+
+function JustPathnameS(const PathName : ShortString) : ShortString;
+ {-Return just the drive and directory portion of a pathname.}
+var
+ I : Longint;
+begin
+ I := Succ(Length(PathName));
+ repeat
+ Dec(I);
+ until (I = 0) or (PathName[I] in DosDelimSet); {!!.01}
+
+ if I = 0 then
+ {Had no drive or directory name}
+ Result [0] := #0
+ else if I = 1 then
+ {Either the root directory of default drive or invalid pathname}
+ Result := PathName[1]
+ else if (PathName[I] = '\') then begin
+ if PathName[Pred(I)] = ':' then
+ {Root directory of a drive, leave trailing backslash}
+ Result := Copy(PathName, 1, I)
+ else
+ {Subdirectory, remove the trailing backslash}
+ Result := Copy(PathName, 1, Pred(I));
+ end else
+ {Either the default directory of a drive or invalid pathname}
+ Result := Copy(PathName, 1, I);
+end;
+
+function AddBackSlashS(const DirName : ShortString) : ShortString;
+ {-Add a default backslash to a directory name}
+begin
+ Result := DirName;
+ if (Length(Result) = 0) then
+ Exit;
+ if ((Length(Result) = 2) and (Result[2] = ':')) or
+ ((Length(Result) > 2) and (Result[Length(Result)] <> '\')) then
+ Result := Result + '\';
+end;
+
+function CleanFileNameS(const FileName : ShortString) : ShortString;
+ {-Return filename with at most 8 chars of name and 3 of extension}
+var
+ DotPos : Cardinal;
+ NameLen : Cardinal;
+begin
+ if HasExtensionS(FileName, DotPos) then begin
+ {Take the first 8 chars of name and first 3 chars of extension}
+ NameLen := Pred(DotPos);
+ if NameLen > 8 then
+ NameLen := 8;
+ Result := Copy(FileName, 1, NameLen)+Copy(FileName, DotPos, 4);
+ end else
+ {Take the first 8 chars of name}
+ Result := Copy(FileName, 1, 8);
+end;
+
+function CleanPathNameS(const PathName : ShortString) : ShortString;
+ {-Return a pathname cleaned up as DOS does it.}
+var
+ I : Longint;
+ S : ShortString;
+begin
+ Result[0] := #0;
+ S := PathName;
+
+ I := Succ(Length(S));
+ repeat
+ dec(I);
+ if I > 2 then
+ if (S[I] = '\') and (S[I-1] = '\') then
+ if (S[I-2] <> ':') then
+ Delete(S, I, 1);
+ until I <= 0;
+
+ I := Succ(Length(S));
+ repeat
+ {Get the next directory or drive portion of pathname}
+ repeat
+ Dec(I);
+ until (I = 0) or (S[I] in DosDelimSet); {!!.02}
+
+ {Clean it up and prepend it to output string}
+ Result := CleanFileNameS(Copy(S, Succ(I), StMaxFileLen)) + Result;
+ if I > 0 then begin
+ Result := S[I] + Result;
+ Delete(S, I, 255);
+ end;
+ until I <= 0;
+
+end;
+
+function HasExtensionS(const Name : ShortString; var DotPos : Cardinal) : Boolean;
+ {-Determine if a pathname contains an extension and, if so, return the
+ position of the dot in front of the extension.}
+var
+ I : Cardinal;
+begin
+ DotPos := 0;
+ for I := Length(Name) downto 1 do
+ if (Name[I] = '.') and (DotPos = 0) then
+ DotPos := I;
+ Result := (DotPos > 0)
+ {and (Pos('\', Copy(Name, Succ(DotPos), MaxFileLen)) = 0);}
+ and not CharExistsS(Copy(Name, Succ(DotPos), StMaxFileLen), '\');
+end;
+
+ {------------------ Formatting routines --------------------}
+
+
+function CommaizeChS(L : Longint; Ch : AnsiChar) : ShortString;
+ {-Convert a long integer to a string with Ch in comma positions}
+var
+ NumCommas, I, Len : Cardinal;
+ Neg : Boolean;
+begin
+ if L < 0 then begin
+ Neg := True;
+ L := Abs(L);
+ end else
+ Neg := False;
+ Result := Long2StrS(L);
+ Len := Length(Result);
+ NumCommas := (Len - 1) div 3;
+ for I := 1 to NumCommas do
+ System.Insert(Ch, Result, Len-(I * 3)+1);
+ if Neg then
+ System.Insert('-', Result, 1);
+end;
+
+function CommaizeS(L : LongInt) : ShortString;
+ {-Convert a long integer to a string with commas}
+begin
+ Result := CommaizeChS(L, ',');
+end;
+
+function FormPrimS(const Mask : ShortString; R : TstFloat; const LtCurr,
+ RtCurr : ShortString; Sep, DecPt : AnsiChar;
+ AssumeDP : Boolean) : ShortString;
+ {-Returns a formatted string with digits from R merged into the Mask}
+const
+ Blank = 0;
+ Asterisk = 1;
+ Zero = 2;
+const
+{$IFOPT N+}
+ MaxPlaces = 18;
+{$ELSE}
+ MaxPlaces = 11;
+{$ENDIF}
+ FormChars : string[8] = '#@*$-+,.';
+ PlusArray : array[Boolean] of AnsiChar = ('+', '-');
+ MinusArray : array[Boolean] of AnsiChar = (' ', '-');
+ FillArray : array[Blank..Zero] of AnsiChar = (' ', '*', '0');
+var
+ S : ShortString; {temporary string}
+ Filler : Integer; {char for unused digit slots: ' ', '*', '0'}
+ WontFit, {true if number won't fit in the mask}
+ AddMinus, {true if minus sign needs to be added}
+ Dollar, {true if floating dollar sign is desired}
+ Negative : Boolean; {true if B is negative}
+ StartF, {starting point of the numeric field}
+ EndF : Word; {end of numeric field}
+ RtChars, {# of chars to add to right}
+ LtChars, {# of chars to add to left}
+ DotPos, {position of '.' in Mask}
+ Digits, {total # of digits}
+ Places, {# of digits after the '.'}
+ Blanks, {# of blanks returned by Str}
+ FirstDigit, {pos. of first digit returned by Str}
+ Extras, {# of extra digits needed for special cases}
+ DigitPtr : Byte; {pointer into temporary string of digits}
+ I : Word;
+label
+ EndFound,
+ RedoCase,
+ Done;
+begin
+ {assume decimal point at end?}
+ Result := Mask;
+ if (not AssumeDP) and (not CharExistsS(Result, '.')) then
+ AssumeDP := true;
+ if AssumeDP and (Result <> '') and (Length(Result) < 255) then begin
+ Inc(Result[0]);
+ Result[Length(Result)] := '.';
+ end;
+
+ RtChars := 0;
+ LtChars := 0;
+
+ {check for empty string}
+ if Length(Result) = 0 then
+ goto Done;
+
+ {initialize variables}
+ Filler := Blank;
+ DotPos := 0;
+ Places := 0;
+ Digits := 0;
+ Dollar := False;
+ AddMinus := True;
+ StartF := 1;
+
+ {store the sign of the real and make it positive}
+ Negative := (R < 0);
+ R := Abs(R);
+
+ {strip and count c's}
+ for I := Length(Result) downto 1 do begin
+ if Result[I] = 'C' then begin
+ Inc(RtChars);
+ System.Delete(Result, I, 1);
+ end else if Result[I] = 'c' then begin
+ Inc(LtChars);
+ System.Delete(Result, I, 1);
+ end;
+ end;
+
+ {find the starting point for the field}
+ while (StartF <= Length(Result)) and
+ not CharExistsS(FormChars, Result[StartF]) do
+ Inc(StartF);
+ if StartF > Length(Result) then
+ goto Done;
+
+ {find the end point for the field}
+ EndF := StartF;
+ for I := StartF to Length(Result) do begin
+ EndF := I;
+ case Result[I] of
+ '*' : Filler := Asterisk;
+ '@' : Filler := Zero;
+ '$' : Dollar := True;
+ '-',
+ '+' : AddMinus := False;
+ '#' : {ignore} ;
+ ',',
+ '.' : DotPos := I;
+ else
+ goto EndFound;
+ end;
+ {Inc(EndF);}
+ end;
+
+ {if we get here at all, the last char was part of the field}
+ Inc(EndF);
+
+EndFound:
+ {if we jumped to here instead, it wasn't}
+ Dec(EndF);
+
+ {disallow Dollar if Filler is Zero}
+ if Filler = Zero then
+ Dollar := False;
+
+ {we need an extra slot if Dollar is True}
+ Extras := Ord(Dollar);
+
+ {get total # of digits and # after the decimal point}
+ for I := StartF to EndF do
+ case Result[I] of
+ '#', '@',
+ '*', '$' :
+ begin
+ Inc(Digits);
+ if (I > DotPos) and (DotPos <> 0) then
+ Inc(Places);
+ end;
+ end;
+
+ {need one more 'digit' if Places > 0}
+ Inc(Digits, Ord(Places > 0));
+
+ {also need an extra blank if (1) Negative is true, and (2) Filler is Blank,
+ and (3) AddMinus is true}
+ if Negative and AddMinus and (Filler = Blank) then
+ Inc(Extras)
+ else
+ AddMinus := False;
+
+ {translate the real to a string}
+ Str(R:Digits:Places, S);
+
+ {add zeros that Str may have left out}
+ if Places > MaxPlaces then begin
+ FillChar(S[Length(S)+1], Places-MaxPlaces, '0');
+ inc(S[0], Places-MaxPlaces);
+ while (Length(S) > Digits) and (S[1] = ' ') do
+ System.Delete(S, 1, 1);
+ end;
+
+ {count number of initial blanks}
+ Blanks := 1;
+ while S[Blanks] = ' ' do
+ Inc(Blanks);
+ FirstDigit := Blanks;
+ Dec(Blanks);
+
+ {the number won't fit if (a) S is longer than Digits or (b) the number of
+ initial blanks is less than Extras}
+ WontFit := (Length(S) > Digits) or (Blanks < Extras);
+
+ {if it won't fit, fill decimal slots with '*'}
+ if WontFit then begin
+ for I := StartF to EndF do
+ case Result[I] of
+ '#', '@', '*', '$' : Result[I] := '*';
+ '+' : Result[I] := PlusArray[Negative];
+ '-' : Result[I] := MinusArray[Negative];
+ end;
+ goto Done;
+ end;
+
+ {fill initial blanks in S with Filler; insert floating dollar sign}
+ if Blanks > 0 then begin
+ FillChar(S[1], Blanks, FillArray[Filler]);
+
+ {put floating dollar sign in last blank slot if necessary}
+ if Dollar then begin
+ S[Blanks] := LtCurr[1];
+ Dec(Blanks);
+ end;
+
+ {insert a minus sign if necessary}
+ if AddMinus then
+ S[Blanks] := '-';
+ end;
+
+ {put in the digits / signs}
+ DigitPtr := Length(S);
+ for I := EndF downto StartF do begin
+RedoCase:
+ case Result[I] of
+ '#', '@', '*', '$' :
+ if DigitPtr <> 0 then begin
+ Result[I] := S[DigitPtr];
+ Dec(DigitPtr);
+ if (DigitPtr <> 0) and (S[DigitPtr] = '.') then {!!.01}
+ Dec(DigitPtr);
+ end
+ else
+ Result[I] := FillArray[Filler];
+ ',' :
+ begin
+ Result[I] := Sep;
+ if (I < DotPos) and (DigitPtr < FirstDigit) then begin
+ Result[I] := '#';
+ goto RedoCase;
+ end;
+ end;
+ '.' :
+ begin
+ Result[I] := DecPt;
+ if (I < DotPos) and (DigitPtr < FirstDigit) then begin
+ Result[I] := '#';
+ goto RedoCase;
+ end;
+ end;
+ '+' : Result[I] := PlusArray[Negative];
+ '-' : Result[I] := MinusArray[Negative];
+ end;
+ end;
+
+Done:
+ if AssumeDP then
+ Dec(Result[0]);
+ if RtChars > 0 then begin
+ S := RtCurr;
+ if Byte(S[0]) > RtChars then
+ S[0] := AnsiChar(RtChars)
+ else
+ S := LeftPadS(S, RtChars);
+ Result := Result + S;
+ end;
+ if LtChars > 0 then begin
+ S := LtCurr;
+ if Byte(S[0]) > LtChars then
+ S[0] := AnsiChar(LtChars)
+ else
+ S := PadS(S, LtChars);
+ Result := S + Result;
+ end;
+end;
+
+function FloatFormS(const Mask : ShortString ; R : TstFloat ; const LtCurr,
+ RtCurr : ShortString ; Sep, DecPt : AnsiChar) : ShortString;
+ {-Return a formatted string with digits from R merged into mask.}
+begin
+ Result := FormPrimS(Mask, R, LtCurr, RtCurr, Sep, DecPt, False);
+end;
+
+function LongIntFormS(const Mask : ShortString ; L : LongInt ; const LtCurr,
+ RtCurr : ShortString ; Sep : AnsiChar) : ShortString;
+ {-Return a formatted string with digits from L merged into mask.}
+begin
+ Result := FormPrimS(Mask, L, LtCurr, RtCurr, Sep, '.', True);
+end;
+
+function StrChPosS(const P : String; C : Char; var Pos : Cardinal) : Boolean;
+var
+ I: Integer;
+{-Return the position of a specified character within a string.}
+begin
+ Result := False;
+ for I := 1 to Length(P) do
+ begin
+ if P[I] = C then
+ begin
+ Result := True;
+ Pos := I;
+ Break;
+ end;
+ end;
+end;
+
+function StrChPosS(const P : ShortString; C : AnsiChar; var Pos : Cardinal) : Boolean;
+ {-Return the position of a specified character within a string.}
+asm
+ push ebx { Save registers }
+ push edi
+
+ xor edi, edi { Zero counter }
+ xor ebx, ebx
+ add bl, [eax] { Get input length }
+ jz @@NotFound
+ inc eax
+
+@@Loop:
+ inc edi { Increment counter }
+ cmp [eax], dl { Did we find it? }
+ jz @@Found
+ inc eax { Increment pointer }
+
+ cmp edi, ebx { End of string? }
+ jnz @@Loop { If not, loop }
+
+@@NotFound:
+ xor eax, eax { Not found, zero EAX for False }
+ mov [ecx], eax
+ jmp @@Done
+
+@@Found:
+ mov [ecx], edi { Set Pos }
+ mov eax, 1 { Set EAX to True }
+
+@@Done:
+ pop edi { Restore registers }
+ pop ebx
+end;
+
+function StrStPosS(const P, S : ShortString; var Pos : Cardinal) : Boolean;
+ {-Return the position of a specified substring within a string.}
+begin
+ Pos := System.Pos(S, P);
+ Result := Pos <> 0;
+end;
+
+function StrStCopyS(const S : ShortString; Pos, Count : Cardinal) : ShortString;
+ {-Copy characters at a specified position in a string.}
+begin
+ Result := System.Copy(S, Pos, Count);
+end;
+
+function StrChInsertS(const S : ShortString; C : AnsiChar; Pos : Cardinal) : ShortString;
+ {-Insert a character into a string at a specified position.}
+var
+ Temp : string[2];
+begin
+ Temp[0] := #1;
+ Temp[1] := C;
+ Result := S;
+ System.Insert(Temp, Result, Pos);
+end;
+
+function StrStInsertS(const S1, S2 : ShortString; Pos : Cardinal) : ShortString;
+ {-Insert a string into another string at a specified position.}
+begin
+ Result := S1;
+ System.Insert(S2, Result, Pos);
+end;
+
+function StrChDeleteS(const S : ShortString; Pos : Cardinal) : ShortString;
+ {-Delete the character at a specified position in a string.}
+begin
+ Result := S;
+ System.Delete(Result, Pos, 1);
+end;
+
+function StrStDeleteS(const S : ShortString; Pos, Count : Cardinal) : ShortString;
+ {-Delete characters at a specified position in a string.}
+begin
+ Result := S;
+ System.Delete(Result, Pos, Count);
+end;
+
+{----------------------------- NEW FUNCTIONS (3.00) -------------------------}
+
+function CopyLeftS(const S : ShortString; Len : Cardinal) : ShortString;
+ {-Return the left Len characters of a string}
+begin
+ if (Len < 1) or (S = '') then
+ Result := ''
+ else
+ Result := Copy(S, 1, Len);
+end;
+
+
+
+function CopyMidS(const S : ShortString; First, Len : Cardinal) : ShortString;
+ {-Return the mid part of a string}
+begin
+ if (First > Length(S)) or (Len < 1) or (S = '') then
+ Result := ''
+ else
+ Result := Copy(S, First, Len);
+end;
+
+
+
+function CopyRightS(const S : ShortString; First : Cardinal) : ShortString;
+ {-Return the right Len characters of a string}
+begin
+ if (First > Length(S)) or (First < 1) or (S = '') then
+ Result := ''
+ else
+ Result := Copy(S, First, Length(S));
+end;
+
+function CopyRightAbsS(const S : ShortString; NumChars : Cardinal) : ShortString;
+ {-Return NumChar characters starting from end}
+begin
+ if (Length(S) > NumChars) then
+ Result := Copy(S, (Length(S) - NumChars)+1, NumChars)
+ else
+ Result := S;
+end;
+
+
+function CopyFromNthWordS(const S, WordDelims : ShortString;
+ const AWord : ShortString; N : Cardinal; {!!.02}
+ var SubString : ShortString) : Boolean;
+var
+ P : Cardinal;
+begin
+ if (WordPosS(S, WordDelims, AWord, N, P)) then begin
+ SubString := Copy(S, P, Length(S));
+ Result := True;
+ end else begin
+ SubString := '';
+ Result := False;
+ end;
+end;
+
+
+
+function DeleteFromNthWordS(const S, WordDelims : ShortString;
+ AWord : ShortString; N : Cardinal;
+ var SubString : ShortString) : Boolean;
+var
+ P : Cardinal;
+begin
+ if (WordPosS(S, WordDelims, AWord, N, P)) then begin
+ Result := True;
+ SubString := Copy(S, 1, P-1);
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+end;
+
+
+
+function CopyFromToWordS(const S, WordDelims, Word1, Word2 : ShortString;
+ N1, N2 : Cardinal;
+ var SubString : ShortString) : Boolean;
+var
+ P1,
+ P2 : Cardinal;
+begin
+ if (WordPosS(S, WordDelims, Word1, N1, P1)) then begin
+ if (WordPosS(S, WordDelims, Word2, N2, P2)) then begin
+ Dec(P2);
+ if (P2 > P1) then begin
+ Result := True;
+ SubString := Copy(S, P1, P2-P1);
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+end;
+
+
+
+function DeleteFromToWordS(const S, WordDelims, Word1, Word2 : ShortString;
+ N1, N2 : Cardinal;
+ var SubString : ShortString) : Boolean;
+var
+ P1,
+ P2 : Cardinal;
+begin
+ SubString := S;
+ if (WordPosS(S, WordDelims, Word1, N1, P1)) then begin
+ if (WordPosS(S, WordDelims, Word2, N2, P2)) then begin
+ Dec(P2);
+ if (P2 > P1) then begin
+ Result := True;
+ System.Delete(SubString, P1, P2-P1+1);
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+ end else begin
+ Result := False;
+ SubString := '';
+ end;
+end;
+
+
+
+function CopyWithinS(const S, Delimiter : ShortString;
+ Strip : Boolean) : ShortString;
+var
+ P1,
+ P2 : Cardinal;
+ TmpStr : ShortString;
+begin
+ if (S = '') or (Delimiter = '') or (Pos(Delimiter, S) = 0) then
+ Result := ''
+ else begin
+ if (StrStPosS(S, Delimiter, P1)) then begin
+ TmpStr := Copy(S, P1 + Length(Delimiter), Length(S));
+ if StrStPosS(TmpStr, Delimiter, P2) then begin
+ Result := Copy(TmpStr, 1, P2-1);
+ if (not Strip) then
+ Result := Delimiter + Result + Delimiter;
+ end else begin
+ Result := TmpStr;
+ if (not Strip) then
+ Result := Delimiter + Result;
+ end;
+ end;
+ end;
+end;
+
+
+
+function DeleteWithinS(const S, Delimiter : ShortString) : ShortString;
+var
+ P1,
+ P2 : Cardinal;
+ TmpStr : ShortString;
+begin
+ if (S = '') or (Delimiter = '') or (Pos(Delimiter, S) = 0) then
+ Result := ''
+ else begin
+ if (StrStPosS(S, Delimiter, P1)) then begin
+ TmpStr := Copy(S, P1 + Length(Delimiter), Length(S));
+ if (Pos(Delimiter, TmpStr) = 0) then
+ Result := Copy(S, 1, P1-1)
+ else begin
+ if (StrStPosS(TmpStr, Delimiter, P2)) then begin
+ Result := S;
+ P2 := P2 + (2*Length(Delimiter));
+ System.Delete(Result, P1, P2);
+ end;
+ end;
+ end;
+ end;
+end;
+
+
+
+function ReplaceWordS(const S, WordDelims, OldWord, NewWord : ShortString;
+ N : Cardinal;
+ var Replacements : Cardinal) : ShortString;
+var
+ I,
+ C,
+ P1 : Cardinal;
+begin
+ if (S = '') or (WordDelims = '') or (OldWord = '') or
+ (Pos(OldWord, S) = 0) then begin
+ Result := S;
+ Replacements := 0;
+ end else begin
+ if (WordPosS(S, WordDelims, OldWord, N, P1)) then begin
+ Result := S;
+ System.Delete(Result, P1, Length(OldWord));
+ C := 0;
+ for I := 1 to Replacements do begin
+ if ((Length(NewWord) + Length(Result)) <= 255) then begin
+ Inc(C);
+ System.Insert(NewWord, Result, P1);
+ Inc(P1, Length(NewWord) + 1);
+ end else begin
+ Replacements := C;
+ Exit;
+ end;
+ end;
+ end else begin
+ Result := S;
+ Replacements := 0;
+ end;
+ end;
+end;
+
+
+function ReplaceWordAllS(const S, WordDelims, OldWord, NewWord : ShortString;
+ var Replacements : Cardinal) : ShortString;
+var
+ I,
+ C,
+ P1 : Cardinal;
+begin
+ if (S = '') or (WordDelims = '') or (OldWord = '') or
+ (Pos(OldWord, S) = 0) then begin
+ Result := S;
+ Replacements := 0;
+ end else begin
+ Result := S;
+ C := 0;
+ while (WordPosS(Result, WordDelims, OldWord, 1, P1)) do begin
+ System.Delete(Result, P1, Length(OldWord));
+ for I := 1 to Replacements do begin
+ if ((Length(NewWord) + Length(Result)) <= 255) then begin
+ Inc(C);
+ System.Insert(NewWord, Result, P1);
+ end else begin
+ Replacements := C;
+ Exit;
+ end;
+ end;
+ end;
+ Replacements := C;
+ end;
+end;
+
+
+function ReplaceStringS(const S, OldString, NewString : ShortString;
+ N : Cardinal;
+ var Replacements : Cardinal) : ShortString;
+var
+ I,
+ C,
+ P1 : Cardinal;
+ TmpStr : ShortString;
+begin
+ if (S = '') or (OldString = '') or (Pos(OldString, S) = 0) then begin
+ Result := S;
+ Replacements := 0;
+ Exit;
+ end;
+ TmpStr := S;
+
+ I := 1;
+ P1 := Pos(OldString, TmpStr);
+ C := P1;
+ while (I < N) and (C < Length(TmpStr)) do begin
+ Inc(I);
+ System.Delete(TmpStr, 1, P1 + Length(OldString));
+ Inc(C, P1 + Length(OldString));
+ end;
+ Result := S;
+ System.Delete(Result, C, Length(OldString));
+
+ C := 0;
+ for I := 1 to Replacements do begin
+ if ((Length(NewString) + Length(Result)) <= 255) then begin
+ Inc(C);
+ System.Insert(NewString, Result, P1);
+ Inc(P1, Length(NewString) + 1);
+ end else begin
+ Replacements := C;
+ Exit;
+ end;
+ end;
+end;
+
+
+function ReplaceStringAllS(const S, OldString, NewString : ShortString;
+ var Replacements : Cardinal) : ShortString;
+var
+ I,
+ C,
+ P1 : Cardinal;
+ Tmp: String;
+begin
+ Result := S;
+ if (S = '') or (OldString = '') or (Pos(OldString, S) = 0) then
+ Replacements := 0
+ else begin
+ Tmp := S;
+ P1 := Pos(OldString, S);
+ if (P1 > 0) then begin
+ Result := Copy(Tmp, 1, P1-1);
+ C := 0;
+ while (P1 > 0) do begin
+ for I := 1 to Replacements do begin
+ Inc(C);
+ Result := Result + NewString;
+ end;
+ Tmp := Copy(Tmp, P1+Length(OldString), MaxInt);
+ P1 := Pos(OldString, Tmp);
+ if (P1 > 0) then begin
+ Result := Result + Copy(Tmp, 1, P1-1);
+ {Tmp := Copy(Tmp, P1, MaxInt)};
+ end else
+ Result := Result + Tmp;
+ end;
+ Replacements := C;
+ end else begin
+ Result := S;
+ Replacements := 0;
+ end;
+ end;
+end;
+
+function LastWordS(const S, WordDelims, AWord : ShortString;
+ var Position : Cardinal) : Boolean;
+var
+ TmpStr : ShortString;
+ I : Cardinal;
+begin
+ if (S = '') or (WordDelims = '') or
+ (AWord = '') or (Pos(AWord, S) = 0) then begin
+ Result := False;
+ Position := 0;
+ Exit;
+ end;
+
+ TmpStr := S;
+ I := Length(TmpStr);
+ while (Pos(TmpStr[I], WordDelims) > 0) do begin
+ System.Delete(TmpStr, I, 1);
+ I := Length(TmpStr);
+ end;
+
+ Position := Length(TmpStr);
+ repeat
+ while (Pos(TmpStr[Position], WordDelims) = 0) and (Position > 1) do
+ Dec(Position);
+ if (Copy(TmpStr, Position + 1, Length(AWord)) = AWord) then begin
+ Inc(Position);
+ Result := True;
+ Exit;
+ end;
+ System.Delete(TmpStr, Position, Length(TmpStr));
+ Position := Length(TmpStr);
+ until (Length(TmpStr) = 0);
+ Result := False;
+ Position := 0;
+end;
+
+
+
+function LastWordAbsS(const S, WordDelims : ShortString;
+ var Position : Cardinal) : Boolean;
+begin
+ if (S = '') or (WordDelims = '') then begin
+ Result := False;
+ Position := 0;
+ Exit;
+ end;
+
+{find first non-delimiter character, if any. If not a "one-word wonder"}
+ Position := Length(S);
+ while (Position > 0) and (Pos(S[Position], WordDelims) > 0) do
+ Dec(Position);
+
+ if (Position = 0) then begin
+ Result := True;
+ Position := 1;
+ Exit;
+ end;
+
+{find next delimiter character}
+ while (Position > 0) and (Pos(S[Position], WordDelims) = 0) do
+ Dec(Position);
+ Inc(Position);
+ Result := True;
+end;
+
+
+
+function LastStringS(const S, AString : ShortString;
+ var Position : Cardinal) : Boolean;
+var
+ TmpStr : ShortString;
+ I, C : Cardinal;
+begin
+ if (S = '') or (AString = '') or (Pos(AString, S) = 0) then begin
+ Result := False;
+ Position := 0;
+ Exit;
+ end;
+
+ TmpStr := S;
+ C := 0;
+ I := Pos(AString, TmpStr);
+ while (I > 0) do begin
+ Inc(C, I + Length(AString));
+ System.Delete(TmpStr, 1, I + Length(AString));
+ I := Pos(AString, TmpStr);
+ end;
+{Go back the length of AString since the while loop deletes the last instance}
+ Dec(C, Length(AString));
+ Position := C;
+ Result := True;
+end;
+
+
+
+function KeepCharsS(const S, Chars : ShortString) : ShortString;
+var
+ FromInx : Cardinal;
+ ToInx : Cardinal;
+begin
+ {if either the input string or the list of acceptable chars is empty
+ the destination string will also be empty}
+ if (S = '') or (Chars = '') then begin
+ Result := '';
+ Exit;
+ end;
+
+ {set the maximum length of the result string (it could be less than
+ this, of course}
+ Result[0] := AnsiChar(length(S));
+
+ {start off the to index}
+ ToInx := 0;
+
+ {in a loop, copy over the chars that match the list}
+ for FromInx := 1 to length(S) do
+ if CharExistsS(Chars, S[FromInx]) then begin
+ inc(ToInx);
+ Result[ToInx] := S[FromInx];
+ end;
+
+ {make sure that the length of the result string is correct}
+ Result[0] := AnsiChar(ToInx);
+end;
+
+
+
+function RepeatStringS(const RepeatString : ShortString;
+ var Repetitions : Cardinal;
+ MaxLen : Cardinal) : ShortString;
+var
+ i : Cardinal;
+ Len : Cardinal;
+ ActualReps : Cardinal;
+begin
+ Result := '';
+ if (MaxLen <> 0) and
+ (Repetitions <> 0) and
+ (RepeatString <> '') then begin
+ if (MaxLen > 255) then
+ MaxLen := 255;
+ Len := length(RepeatString);
+ ActualReps := MaxLen div Len;
+ if (ActualReps > Repetitions) then
+ ActualReps := Repetitions
+ else
+ Repetitions := ActualReps;
+ if (ActualReps > 0) then begin
+ Result[0] := AnsiChar(ActualReps * Len);
+ for i := 0 to pred(ActualReps) do
+ Move(RepeatString[1], Result[i * Len + 1], Len);
+ end;
+ end;
+end;
+
+
+
+function TrimCharsS(const S, Chars : ShortString) : ShortString;
+begin
+ Result := RightTrimCharsS(S, Chars);
+ Result := LeftTrimCharsS(Result, Chars);
+end;
+
+
+
+function RightTrimCharsS(const S, Chars : ShortString) : ShortString;
+var
+ CutOff : integer;
+begin
+ CutOff := length(S);
+ while (CutOff > 0) do begin
+ if not CharExistsS(Chars, S[CutOff]) then
+ Break;
+ dec(CutOff);
+ end;
+ if (CutOff = 0) then
+ Result := ''
+ else
+ Result := Copy(S, 1, CutOff);
+end;
+
+
+
+function LeftTrimCharsS(const S, Chars : ShortString) : ShortString;
+var
+ CutOff : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ CutOff := 1;
+ while (CutOff <= LenS) do begin
+ if not CharExistsS(Chars, S[CutOff]) then
+ Break;
+ inc(CutOff);
+ end;
+ if (CutOff > LenS) then
+ Result := ''
+ else
+ Result := Copy(S, CutOff, LenS - CutOff + 1);
+end;
+
+
+
+function ExtractTokensS(const S, Delims : ShortString;
+ QuoteChar : AnsiChar;
+ AllowNulls : Boolean;
+ Tokens : TStrings) : Cardinal;
+var
+ State : (ScanStart,
+ ScanQuotedToken,
+ ScanQuotedTokenEnd,
+ ScanNormalToken,
+ ScanNormalTokenWithQuote);
+ CurChar : AnsiChar;
+ TokenStart : integer;
+ Inx : integer;
+begin
+ {Notes: this routine implements the following state machine
+ start ----> ScanStart
+ ScanStart-----quote----->ScanQuotedToken
+ ScanStart-----delim----->ScanStart (1)
+ ScanStart-----other----->ScanNormalToken
+ ScanQuotedToken-----quote----->ScanQuotedTokenEnd
+ ScanQuotedToken-----other----->ScanQuotedToken
+ ScanQuotedTokenEnd-----quote----->ScanNormalTokenWithQuote
+ ScanQuotedTokenEnd-----delim----->ScanStart (2)
+ ScanQuotedTokenEnd-----other----->ScanNormalToken
+ ScanNormalToken-----quote----->ScanNormalTokenWithQuote
+ ScanNormalToken-----delim----->ScanStart (3)
+ ScanNormalToken-----other----->ScanNormalToken
+ ScanNormalTokenWithQuote-----quote----->ScanNormalTokenWithQuote
+ ScanNormalTokenWithQuote-----other----->ScanNormalToken
+
+ (1) output a null token if allowed
+ (2) output a token, stripping quotes (if the dequoted token is
+ empty, output a null token if allowed)
+ (3) output a token; no quote stripping
+
+ If the quote character is #0, it's taken to mean that the routine
+ should not check for quoted substrings.}
+
+ {clear the tokens string list, set the return value to zero}
+ Tokens.Clear;
+ Result := 0;
+
+ {if the input string is empty or the delimiter list is empty or
+ the quote character is found in the delimiter list, return zero
+ tokens found}
+ if (S = '') or
+ (Delims = '') or
+ CharExistsS(Delims, QuoteChar) then
+ Exit;
+
+ {start off in the normal scanning state}
+ State := ScanStart;
+
+ {the first token starts at position 1}
+ TokenStart := 1;
+
+ {read through the entire string}
+ for Inx := 1 to length(S) do begin
+
+ {get the current character}
+ CurChar := S[Inx];
+
+ {process the character according to the current state}
+ case State of
+ ScanStart :
+ begin
+ {if the current char is the quote character, switch states}
+ if (QuoteChar <> #0) and (CurChar = QuoteChar) then
+ State := ScanQuotedToken
+
+ {if the current char is a delimiter, output a null token}
+ else if CharExistsS(Delims, CurChar) then begin
+
+ {if allowed to, output a null token}
+ if AllowNulls then begin
+ Tokens.Add('');
+ inc(Result);
+ end;
+
+ {set the start of the next token to be one character after
+ this delimiter}
+ TokenStart := succ(Inx);
+ end
+
+ {otherwise, the current char is starting a normal token, so
+ switch states}
+ else
+ State := ScanNormalToken
+ end;
+
+ ScanQuotedToken :
+ begin
+ {if the current char is the quote character, switch states}
+ if (CurChar = QuoteChar) then
+ State := ScanQuotedTokenEnd
+ end;
+
+ ScanQuotedTokenEnd :
+ begin
+ {if the current char is the quote character, we have a token
+ consisting of two (or more) quoted substrings, so switch
+ states}
+ if (CurChar = QuoteChar) then
+ State := ScanNormalTokenWithQuote
+
+ {if the current char is a delimiter, output the token
+ without the quotes}
+ else if CharExistsS(Delims, CurChar) then begin
+
+ {if the token is empty without the quotes, output a null
+ token only if allowed to}
+ if ((Inx - TokenStart) = 2) then begin
+ if AllowNulls then begin
+ Tokens.Add('');
+ inc(Result);
+ end
+ end
+
+ {else output the token without the quotes}
+ else begin
+ Tokens.Add(Copy(S, succ(TokenStart), Inx - TokenStart - 2));
+ inc(Result);
+ end;
+
+ {set the start of the next token to be one character after
+ this delimiter}
+ TokenStart := succ(Inx);
+
+ {switch states back to the start state}
+ State := ScanStart;
+ end
+
+ {otherwise it's a (complex) normal token, so switch states}
+ else
+ State := ScanNormalToken
+ end;
+
+ ScanNormalToken :
+ begin
+ {if the current char is the quote character, we have a
+ complex token with at least one quoted substring, so switch
+ states}
+ if (QuoteChar <> #0) and (CurChar = QuoteChar) then
+ State := ScanNormalTokenWithQuote
+
+ {if the current char is a delimiter, output the token}
+ else if CharExistsS(Delims, CurChar) then begin
+ Tokens.Add(Copy(S, TokenStart, Inx - TokenStart));
+ inc(Result);
+
+ {set the start of the next token to be one character after
+ this delimiter}
+ TokenStart := succ(Inx);
+
+ {switch states back to the start state}
+ State := ScanStart;
+ end;
+ end;
+
+ ScanNormalTokenWithQuote :
+ begin
+ {if the current char is the quote character, switch states
+ back to scanning a normal token}
+ if (CurChar = QuoteChar) then
+ State := ScanNormalToken;
+ end;
+
+ end;
+ end;
+
+ {we need to process the (possible) final token: first assume that
+ the current character index is just beyond the end of the string}
+ Inx := succ(length(S));
+
+ {if we are in the scanning quoted token state, we've read an opening
+ quote, but no closing one; increment the token start value}
+ if (State = ScanQuotedToken) then
+ inc(TokenStart)
+
+ {if we've finished scanning a quoted token, we've read both quotes;
+ increment the token start value, and decrement the current index}
+ else if (State = ScanQuotedTokenEnd) then begin
+ inc(TokenStart);
+ dec(Inx);
+ end;
+
+ {if the final token is not empty, output the token}
+ if (TokenStart < Inx) then begin
+ Tokens.Add(Copy(S, TokenStart, Inx - TokenStart));
+ inc(Result);
+ end
+ {otherwise the final token is empty, so output a null token if
+ allowed to}
+ else if AllowNulls then begin
+ Tokens.Add('');
+ inc(Result);
+ end;
+end;
+
+
+
+function ContainsOnlyS(const S, Chars : ShortString;
+ var BadPos : Cardinal) : Boolean;
+var
+ I : Cardinal;
+begin
+ if (S = '') then begin
+ Result := False;
+ BadPos := 0;
+ end else begin
+ for I := 1 to Length(S) do begin
+ if (not CharExistsS(Chars, S[I])) then begin
+ BadPos := I;
+ Result := False;
+ Exit;
+ end;
+ end;
+ Result := True;
+ BadPos := 0;
+ end;
+end;
+
+
+
+function ContainsOtherThanS(const S, Chars : ShortString;
+ var BadPos : Cardinal) : Boolean;
+var
+ I : Cardinal;
+begin
+ if (S = '') then begin
+ Result := False;
+ BadPos := 0;
+ end else begin
+ for I := 1 to Length(S) do begin
+ if (CharExistsS(Chars, S[I])) then begin
+ BadPos := I;
+ Result := True;
+ Exit;
+ end;
+ end;
+ Result := False;
+ BadPos := 0;
+ end;
+end;
+
+
+
+function IsChAlphaS(C : Char) : Boolean;
+ {-Returns true if Ch is an alpha}
+begin
+ {$IFDEF FPC}
+ Result := C in ['a'..'z', 'A'..'Z'];
+ {$ELSE}
+ Result := Windows.IsCharAlpha(C);
+ {$ENDIF}
+end;
+
+
+
+function IsChNumericS(C : AnsiChar; const Numbers : ShortString) : Boolean;
+ {-Returns true if Ch in numeric set}
+begin
+ Result := CharExistsS(Numbers, C);
+end;
+
+
+function IsChAlphaNumericS(C : Char; const Numbers : ShortString) : Boolean;
+ {-Returns true if Ch is an alpha or numeric}
+begin
+ {$IFDEF FPC}
+ Result := IsChAlphaS(C) or CharExistsS(Numbers, C);
+ {$ELSE}
+ Result := Windows.IsCharAlpha(C) or CharExistsS(Numbers, C);
+ {$ENDIF}
+end;
+
+
+
+function IsStrAlphaS(const S : string) : Boolean;
+ {-Returns true if all characters in string are an alpha}
+var
+ I : Cardinal;
+begin
+ Result := false;
+ if (length(S) > 0) then begin
+ for I := 1 to Length(S) do
+ {$IFDEF FPC}
+ if not IsChAlphaS(S[I]) then
+ Exit;
+ {$ELSE}
+ if not Windows.IsCharAlpha(S[I]) then
+ Exit;
+ {$ENDIF}
+ Result := true;
+ end;
+end;
+
+
+
+function IsStrNumericS(const S, Numbers : ShortString) : Boolean;
+ {-Returns true if all characters in string are in numeric set}
+var
+ i : Cardinal;
+begin
+ Result := false;
+ if (length(S) > 0) then begin
+ for i := 1 to Length(S) do
+ if not CharExistsS(Numbers, S[i]) then
+ Exit;
+ Result := true;
+ end;
+end;
+
+
+function IsStrAlphaNumericS(const S, Numbers : String) : Boolean;
+ {-Returns true if all characters in string are alpha or numeric}
+var
+ i : Cardinal;
+begin
+ Result := false;
+ if (length(S) > 0) then begin
+ for I := 1 to Length(S) do
+ {$IFDEF FPC}
+ if not IsChAlphaNumericS(S[i], Numbers) then
+ Exit;
+ {$ELSE}
+ if (not Windows.IsCharAlpha(S[i])) and
+ (not CharExistsS(Numbers, S[i])) then
+ Exit;
+ {$ENDIF}
+ Result := true;
+ end;
+end;
+
+function StrWithinS(const S, SearchStr : ShortString;
+ Start : Cardinal;
+ var Position : Cardinal) : boolean;
+var
+ TmpStr : ShortString;
+begin
+ TmpStr := S;
+ if (Start > 1) then
+ System.Delete(TmpStr, 1, Start-1);
+ Position := pos(SearchStr, TmpStr);
+ if (Position > 0) then begin
+ Position := Position + Start - 1;
+ Result := True;
+ end else
+ Result := False;
+end;
+
+
+function WordPosS(const S, WordDelims, AWord : ShortString;
+ N : Cardinal; var Position : Cardinal) : Boolean;
+ {-returns the Nth instance of a given word within a string}
+var
+ TmpStr : ShortString;
+ Len,
+ I,
+ P1,
+ P2 : Cardinal;
+begin
+ if (S = '') or (AWord = '') or (Pos(AWord, S) = 0) or (N < 1) then begin
+ Result := False;
+ Position := 0;
+ Exit;
+ end;
+
+ Result := False;
+ Position := 0;
+
+ TmpStr := S;
+ I := 0;
+ Len := Length(AWord);
+ P1 := Pos(AWord, TmpStr);
+
+ while (P1 > 0) and (Length(TmpStr) > 0) do begin
+ P2 := P1 + pred(Len);
+ if (P1 = 1) then begin
+ if (Pos(TmpStr[P2+1], WordDelims) > 0) then begin
+ Inc(I);
+ end else
+ System.Delete(TmpStr, 1, P2);
+ end else if (Pos(TmpStr[P1-1], WordDelims) > 0) and
+ ((Pos(TmpStr[P2+1], WordDelims) > 0) or
+ (P2+1 = Length(TmpStr))) then begin
+ Inc(I);
+ end else if ((P1 + pred(Len)) = Length(TmpStr)) then begin
+ if (P1 > 1) and (Pos(TmpStr[P1-1], WordDelims) > 0) then
+ Inc(I);
+ end;
+
+ if (I = N) then begin
+ Result := True;
+ Position := Position + P1;
+ Exit;
+ end;
+ System.Delete(TmpStr, 1, P2);
+ Position := Position + P2;
+ P1 := Pos(AWord, TmpStr);
+ end;
+end;
+
+
+end.
diff --git a/components/systools/source/run/sttohtml.pas b/components/systools/source/run/sttohtml.pas
new file mode 100644
index 000000000..6ff9415a5
--- /dev/null
+++ b/components/systools/source/run/sttohtml.pas
@@ -0,0 +1,963 @@
+// Upgraded to Delphi 2009: Sebastian Zierer
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower SysTools
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{*********************************************************}
+{* SysTools: StToHTML.pas 4.04 *}
+{*********************************************************}
+{* SysTools: HTML Text Formatter *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+//{$I StDefine.inc}
+
+unit StToHTML;
+
+interface
+
+uses
+ {$IFNDEF FPC}
+ Windows, Messages,
+ {$ENDIF}
+ SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ StStrms, StBase;
+
+type
+ TStOnProgressEvent = procedure(Sender : TObject; Percent : Word) of object;
+
+ TStStreamToHTML = class(TObject)
+ protected {private}
+ { Private declarations }
+ FCaseSensitive : Boolean;
+ FCommentMarkers : TStringList;
+ FEmbeddedHTML : TStringList;
+ FInFileSize : Cardinal;
+ FInFixedLineLen : integer;
+ FInLineTermChar : Char;
+ FInLineTerminator: TStLineTerminator;
+ FInputStream : TStream;
+ FInSize : Cardinal;
+ FInTextStream : TStAnsiTextStream;
+ FIsCaseSensitive : Boolean;
+ FKeywords : TStringList;
+ FOnProgress : TStOnProgressEvent;
+ FOutputStream : TStream;
+ FOutTextStream : TStAnsiTextStream;
+ FPageFooter : TStringList;
+ FPageHeader : TStringList;
+ FStringMarkers : TStringList;
+ FWordDelims : String;
+ protected
+ { Protected declarations }
+
+ {internal methods}
+ function ParseBuffer : Boolean;
+
+ procedure SetCommentMarkers(Value : TStringList);
+ procedure SetEmbeddedHTML(Value : TStringList);
+ procedure SetKeywords(Value : TStringList);
+ procedure SetPageFooter(Value : TStringList);
+ procedure SetPageHeader(Value : TStringList);
+ procedure SetStringMarkers(Value : TStringList);
+
+ public
+ { Public declarations }
+
+ property CaseSensitive : Boolean
+ read FCaseSensitive
+ write FCaseSensitive;
+
+ property CommentMarkers : TStringList
+ read FCommentMarkers
+ write SetCommentMarkers;
+
+ property EmbeddedHTML : TStringList
+ read FEmbeddedHTML
+ write SetEmbeddedHTML;
+
+ property InFixedLineLength : integer
+ read FInFixedLineLen
+ write FInFixedLineLen;
+
+ property InLineTermChar : Char
+ read FInLineTermChar
+ write FInLineTermChar;
+
+ property InLineTerminator : TStLineTerminator
+ read FInLineTerminator
+ write FInLineTerminator;
+
+ property InputStream : TStream
+ read FInputStream
+ write FInputStream;
+
+ property Keywords : TStringList
+ read FKeywords
+ write SetKeywords;
+
+ property OnProgress : TStOnProgressEvent
+ read FOnProgress
+ write FOnProgress;
+
+ property OutputStream : TStream
+ read FOutputStream
+ write FOutputStream;
+
+ property PageFooter : TStringList
+ read FPageFooter
+ write SetPageFooter;
+
+ property PageHeader : TStringList
+ read FPageHeader
+ write SetPageHeader;
+
+ property StringMarkers : TStringList
+ read FStringMarkers
+ write SetStringMarkers;
+
+ property WordDelimiters : String
+ read FWordDelims
+ write FWordDelims;
+
+
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure GenerateHTML;
+ end;
+
+
+ TStFileToHTML = class(TStComponent)
+ protected {private}
+ { Private declarations }
+
+ FCaseSensitive : Boolean;
+ FCommentMarkers : TStringList;
+ FEmbeddedHTML : TStringList;
+ FInFile : TFileStream;
+ FInFileName : String;
+ FInLineLength : integer;
+ FInLineTermChar : Char;
+ FInLineTerminator : TStLineTerminator;
+ FKeywords : TStringList;
+ FOnProgress : TStOnProgressEvent;
+ FOutFile : TFileStream;
+ FOutFileName : String;
+ FPageFooter : TStringList;
+ FPageHeader : TStringList;
+ FStream : TStStreamToHTML;
+ FStringMarkers : TStringList;
+ FWordDelims : String;
+
+ protected
+
+ procedure SetCommentMarkers(Value : TStringList);
+ procedure SetEmbeddedHTML(Value : TStringList);
+ procedure SetKeywords(Value : TStringList);
+ procedure SetPageFooter(Value : TStringList);
+ procedure SetPageHeader(Value : TStringList);
+ procedure SetStringMarkers(Value : TStringList);
+
+ public
+ constructor Create(AOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure Execute;
+
+ published
+ property CaseSensitive : Boolean
+ read FCaseSensitive
+ write FCaseSensitive default False;
+
+ property CommentMarkers : TStringList
+ read FCommentMarkers
+ write SetCommentMarkers;
+
+ property EmbeddedHTML : TStringList
+ read FEmbeddedHTML
+ write SetEmbeddedHTML;
+
+ property InFileName : String
+ read FInFileName
+ write FInFileName;
+
+ property InFixedLineLength : integer
+ read FInLineLength
+ write FInLineLength default 80;
+
+ property InLineTermChar : Char
+ read FInLineTermChar
+ write FInLineTermChar default #10;
+
+ property InLineTerminator : TStLineTerminator
+ read FInLineTerminator
+ write FInLineTerminator default ltCRLF;
+
+ property Keywords : TStringList
+ read FKeywords
+ write SetKeywords;
+
+ property OnProgress : TStOnProgressEvent
+ read FOnProgress
+ write FOnProgress;
+
+ property OutFileName : String
+ read FOutFileName
+ write FOutFileName;
+
+ property PageFooter : TStringList
+ read FPageFooter
+ write SetPageFooter;
+
+ property PageHeader : TStringList
+ read FPageHeader
+ write SetPageHeader;
+
+ property StringMarkers : TStringList
+ read FStringMarkers
+ write SetStringMarkers;
+
+ property WordDelimiters : String
+ read FWordDelims
+ write FWordDelims;
+ end;
+
+
+implementation
+
+uses
+ StConst,
+ StDict;
+
+
+(*****************************************************************************)
+(* TStStreamToHTML Implementation *)
+(*****************************************************************************)
+
+constructor TStStreamToHTML.Create;
+begin
+ inherited Create;
+
+ FCommentMarkers := TStringList.Create;
+ FEmbeddedHTML := TStringList.Create;
+ FKeywords := TStringList.Create;
+ FPageFooter := TStringList.Create;
+ FPageHeader := TStringList.Create;
+ FStringMarkers := TStringList.Create;
+
+ FInputStream := nil;
+ FOutputStream := nil;
+
+ FInFileSize := 0;
+ FWordDelims := ',; .()';
+
+ FInLineTerminator := ltCRLF; {normal Windows text file terminator}
+ FInLineTermChar := #10;
+ FInFixedLineLen := 80;
+
+ with FEmbeddedHTML do begin
+ Add('"="');
+ Add('&=&');
+ Add('<=<');
+ Add('>=>');
+ Add('¡=¡');
+ Add('¢=¢');
+ Add('£=£');
+ Add('©=©');
+ Add('®=®');
+ Add('±=±');
+ Add('¼=¼');
+ Add('½=½');
+ Add('¾=¾');
+ Add('÷=÷');
+ end;
+end;
+
+
+destructor TStStreamToHTML.Destroy;
+begin
+ FCommentMarkers.Free;
+ FCommentMarkers := nil;
+
+ FEmbeddedHTML.Free;
+ FEmbeddedHTML := nil;
+
+ FKeywords.Free;
+ FKeywords := nil;
+
+ FPageFooter.Free;
+ FPageFooter := nil;
+
+ FPageHeader.Free;
+ FPageHeader := nil;
+
+ FStringMarkers.Free;
+ FStringMarkers := nil;
+
+ FInTextStream.Free;
+ FInTextStream := nil;
+
+ FOutTextStream.Free;
+ FOutTextStream := nil;
+
+ inherited Destroy;
+end;
+
+
+procedure TStStreamToHTML.GenerateHTML;
+begin
+ if not ((Assigned(FInputStream) and (Assigned(FOutputStream)))) then
+ RaiseStError(EStToHTMLError, stscBadStream)
+ else
+ ParseBuffer;
+end;
+
+
+procedure DisposeString(Data : Pointer); far;
+begin
+ Dispose(PString(Data));
+end;
+
+
+function TStStreamToHTML.ParseBuffer : Boolean;
+var
+ I, J,
+ P1,
+ P2,
+ BRead,
+ PC : Longint;
+ CloseStr,
+ SStr,
+ EStr,
+ S,
+ VS,
+ AStr,
+ TmpStr : String;
+ P : Pointer;
+ PS : PString;
+ CommentDict : TStDictionary;
+ HTMLDict : TStDictionary;
+ KeywordsDict : TStDictionary;
+ StringDict : TStDictionary;
+ CommentPend : Boolean;
+
+ function ConvertEmbeddedHTML(const Str2 : String) : String;
+ var
+ L,
+ J : Longint;
+ PH : Pointer;
+ begin
+ Result := '';
+ {avoid memory reallocations}
+ SetLength(Result, 1024);
+ J := 1;
+ for L := 1 to Length(Str2) do begin
+ if (not HTMLDict.Exists(Str2[L], PH)) then begin
+ Result[J] := Str2[L];
+ Inc(J);
+ end else begin
+ Move(String(PH^)[1], Result[J], Length(String(PH^)) * SizeOf(Char));
+ Inc(J, Length(String(PH^)));
+ end;
+ end;
+ Dec(J);
+ SetLength(Result, J);
+ end;
+
+ procedure CheckSubString(const Str1 : String);
+ var
+ S2 : String;
+ begin
+ if (KeywordsDict.Exists(Str1, P)) then begin
+ VS := String(P^);
+ S2 := Copy(VS, 1, pos(';', VS)-1)
+ + ConvertEmbeddedHTML(Str1)
+ + Copy(VS, pos(';', VS)+1, Length(VS));
+ if (P1 >= Length(Str1)) and (P1 <= Length(TmpStr)) then
+ S2 := S2 + ConvertEmbeddedHTML(TmpStr[P1]);
+ end else begin
+ S2 := ConvertEmbeddedHTML(Str1);
+ if (P1 >= Length(Str1)) and (P1 <= Length(TmpStr)) then
+ S2 := S2 + ConvertEmbeddedHTML(TmpStr[P1]);
+ end;
+ S := S + S2;
+ end;
+
+begin
+ if (Length(FWordDelims) = 0) then
+ RaiseStError(EStToHTMLError, stscWordDelimiters);
+
+ {create Dictionaries for lookups}
+ CommentDict := TStDictionary.Create(FCommentMarkers.Count+1);
+ KeywordsDict := TStDictionary.Create(FKeywords.Count+1);
+ HTMLDict := TStDictionary.Create(FEmbeddedHTML.Count+1);
+ StringDict := TStDictionary.Create(FStringMarkers.Count+1);
+
+ CommentDict.DisposeData := DisposeString;
+ KeywordsDict.DisposeData := DisposeString;
+ HTMLDict.DisposeData := DisposeString;
+ StringDict.DisposeData := DisposeString;
+
+ FInTextStream := TStAnsiTextStream.Create(FInputStream);
+ FInTextStream.LineTermChar := AnsiChar(FInLineTermChar);
+ FInTextStream.LineTerminator := FInLineTerminator;
+ FInTextStream.FixedLineLength := FInFixedLineLen;
+ FInFileSize := FInTextStream.Size;
+
+ FOutTextStream := TStAnsiTextStream.Create(FOutputStream);
+ FOutTextStream.LineTermChar := #10;
+ FOutTextStream.LineTerminator := ltCRLF;
+ FOutTextStream.FixedLineLength := 80;
+
+ FInLineTerminator := ltCRLF; {normal Windows text file terminator}
+ FInLineTermChar := #10;
+ FInFixedLineLen := 80;
+
+ try
+ if (FCaseSensitive) then begin
+ CommentDict.Hash := AnsiHashStr;
+ CommentDict.Equal := AnsiCompareStr;
+ HTMLDict.Hash := AnsiHashStr;
+ HTMLDict.Equal := AnsiCompareStr;
+ KeywordsDict.Hash := AnsiHashStr;
+ KeywordsDict.Equal:= AnsiCompareStr;
+ StringDict.Hash := AnsiHashStr;
+ StringDict.Equal := AnsiCompareStr;
+ end else begin
+ CommentDict.Hash := AnsiHashText;
+ CommentDict.Equal := AnsiCompareText;
+ HTMLDict.Hash := AnsiHashText;
+ HTMLDict.Equal := AnsiCompareText;
+ KeywordsDict.Hash := AnsiHashText;
+ KeywordsDict.Equal:= AnsiCompareText;
+ StringDict.Hash := AnsiHashText;
+ StringDict.Equal := AnsiCompareText;
+ end;
+
+ {Add items from string lists to dictionaries}
+ for I := 0 to pred(FKeywords.Count) do begin
+ if (Length(FKeywords[I]) = 0) then
+ continue;
+ if (pos('=', FKeywords[I]) > 0) then begin
+ New(PS);
+ S := FKeywords.Names[I];
+ PS^ := FKeywords.Values[S];
+ if (not KeywordsDict.Exists(S, P)) then
+ KeywordsDict.Add(S, PS)
+ else
+ Dispose(PS);
+ end else
+ RaiseStError(EStToHTMLError, stscInvalidSLEntry);
+ end;
+
+ for I := 0 to pred(FStringMarkers.Count) do begin
+ if (Length(FStringMarkers[I]) = 0) then
+ continue;
+ if (pos('=', FStringMarkers[I]) > 0) then begin
+ New(PS);
+ S := FStringMarkers.Names[I];
+ PS^ := FStringMarkers.Values[S];
+ if (not StringDict.Exists(S, P)) then
+ StringDict.Add(S, PS)
+ else
+ Dispose(PS);
+ end else
+ RaiseStError(EStToHTMLError, stscInvalidSLEntry);
+ end;
+
+ for I := 0 to pred(FCommentMarkers.Count) do begin
+ if (Length(FCommentMarkers[I]) = 0) then
+ continue;
+ if (pos('=', FCommentMarkers[I]) > 0) then begin
+ New(PS);
+ S := FCommentMarkers.Names[I];
+ if (Length(S) = 1) then
+ PS^ := FCommentMarkers.Values[S]
+ else begin
+ PS^ := ':1' + S[2] + ';' + FCommentMarkers.Values[S];
+ S := S[1];
+ end;
+ if (not CommentDict.Exists(S, P)) then
+ CommentDict.Add(S, PS)
+ else begin
+ AStr := String(P^);
+ AStr := AStr + PS^;
+ String(P^) := AStr;
+ CommentDict.Update(S, P);
+ Dispose(PS);
+ end;
+ end else
+ RaiseStError(EStToHTMLError, stscInvalidSLEntry);
+ end;
+
+ for I := 0 to pred(FEmbeddedHTML.Count) do begin
+ if (pos('=', FEmbeddedHTML[I]) > 0) then begin
+ New(PS);
+ S := FEmbeddedHTML.Names[I];
+ PS^ := FEmbeddedHTML.Values[S];
+ if (not HTMLDict.Exists(S, P)) then
+ HTMLDict.Add(S, PS)
+ else
+ Dispose(PS);
+ end else
+ RaiseStError(EStToHTMLError, stscInvalidSLEntry);
+ end;
+
+ BRead := 0;
+ if (FPageHeader.Count > 0) then begin
+ for I := 0 to pred(FPageHeader.Count) do
+ FOutTextStream.WriteLine(FPageHeader[I]);
+ end;
+ FOutTextStream.WriteLine('');
+ CommentPend := False;
+ AStr := '';
+ SStr := '';
+ EStr := '';
+
+ {make sure buffer is at the start}
+ FInTextStream.Position := 0;
+ while not FInTextStream.AtEndOfStream do begin
+ TmpStr := FInTextStream.ReadLine;
+ Inc(BRead, Length(TmpStr) + Length(FInTextStream.LineTermChar));
+ if (FInFileSize > 0) then begin
+ PC := Round((BRead / FInFileSize * 100));
+ if (Assigned(FOnProgress)) then
+ FOnProgress(Self, PC);
+ end;
+
+ if (TmpStr = '') then begin
+ if (CommentPend) then
+ FOutTextStream.WriteLine(EStr)
+ else
+ FOutTextStream.WriteLine(' ');
+ continue;
+ end;
+
+ if (CommentPend) then
+ S := SStr
+ else
+ S := '';
+
+ P1 := 1;
+ repeat
+ if (not CommentPend) and (CommentDict.Exists(TmpStr[P1], P)) then begin
+ VS := String(P^);
+ if (Copy(VS, 1 , 2) = ':1') then begin
+ while (Copy(VS, 1 , 2) = ':1') do begin
+ System.Delete(VS, 1, 2);
+ if (TmpStr[P1+1] = VS[1]) then begin
+ System.Delete(VS, 1, 2);
+ CloseStr := Copy(VS, 1, pos(';', VS)-1);
+ System.Delete(VS, 1, pos(';', VS));
+ SStr := Copy(VS, 1, pos(';', VS)-1);
+ System.Delete(VS, 1, pos(';', VS));
+ J := pos(':1', VS);
+ if (J = 0) then
+ EStr := Copy(VS, pos(';', VS)+1, Length(VS))
+ else begin
+ EStr := Copy(VS, 1, J-1);
+ System.Delete(VS, 1, J+2);
+ end;
+
+ if (CloseStr = '') then begin
+ S := S + SStr;
+ AStr := Copy(TmpStr, P1, Length(TmpStr));
+ CheckSubString(AStr);
+ S := S + EStr;
+ CloseStr := '';
+ SStr := '';
+ EStr := '';
+ TmpStr := '';
+ continue;
+ end else begin
+ I := pos(CloseStr, TmpStr);
+ if (I = 0) then begin
+ CommentPend := True;
+ S := SStr + S;
+ end else begin
+ S := S + SStr;
+ AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
+ CheckSubstring(AStr);
+ S := S + EStr;
+ System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
+ end;
+ end;
+ end else begin
+ J := pos(':1', VS);
+ if (J > 0) then
+ System.Delete(VS, 1, J-1);
+ end;
+ end;
+ end else begin
+ {is it really the beginning of a comment?}
+ CloseStr := Copy(VS, 1, pos(';', VS)-1);
+ System.Delete(VS, 1, pos(';', VS));
+ SStr := Copy(VS, 1, pos(';', VS)-1);
+ EStr := Copy(VS, pos(';', VS)+1, Length(VS));
+ I := pos(CloseStr, TmpStr);
+ if (I > 0) and (I > P1) then begin
+ {ending marker found}
+ CommentPend := False;
+ S := S + SStr;
+ AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
+ CheckSubstring(AStr);
+ S := S + EStr;
+ System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
+ P1 := 1;
+ CloseStr := '';
+ SStr := '';
+ EStr := '';
+ if (TmpStr = '') then
+ continue;
+ end else begin {1}
+ CommentPend := True;
+ S := S + SStr;
+ if (Length(TmpStr) > 1) then begin
+ AStr := Copy(TmpStr, P1, Length(TmpStr));
+ CheckSubstring(AStr);
+ end else
+ S := S + TmpStr;
+ S := S + EStr;
+ TmpStr := '';
+ continue;
+ end;
+ end;
+ end;
+
+ if (CommentPend) then begin
+ I := pos(CloseStr, TmpStr);
+ if (I < 1) then begin
+ AStr := Copy(TmpStr, P1, Length(TmpStr));
+ CheckSubstring(AStr);
+ S := S + EStr;
+ TmpStr := '';
+ continue;
+ end else begin {2}
+ CommentPend := False;
+ if (Length(TmpStr) > 1) then begin
+ AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
+ CheckSubstring(AStr);
+ end else
+ S := S + TmpStr;
+ S := S + EStr;
+ System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
+ CloseStr := '';
+ SStr := '';
+ EStr := '';
+ if (TmpStr = '') then
+ continue
+ else
+ P1 := 1;
+ end;
+ end else begin
+ CloseStr := '';
+ SStr := '';
+ EStr := '';
+ end;
+
+ if (TmpStr = '') then
+ continue;
+
+ P := nil;
+ while (P1 <= Length(TmpStr)) and (pos(TmpStr[P1], FWordDelims) = 0) and
+ (not StringDict.Exists(TmpStr[P1], P)) do
+ Inc(P1);
+ if (Assigned(P)) then begin
+ P2 := P1+1;
+ VS := String(P^);
+ CloseStr := Copy(VS, 1, pos(';', VS)-1);
+ System.Delete(VS, 1, pos(';', VS));
+ SStr := Copy(VS, 1, pos(';', VS)-1);
+ System.Delete(VS, 1, pos(';', VS));
+ EStr := Copy(VS, pos(';', VS)+1, Length(VS));
+
+ while (TmpStr[P2] <> CloseStr) and (P2 <= Length(TmpStr)) do
+ Inc(P2);
+ S := S + SStr;
+ AStr := Copy(TmpStr, P1, P2-P1+1);
+ CheckSubString(AStr);
+ S := S + EStr;
+
+ System.Delete(TmpStr, P1, P2);
+ if (TmpStr = '') then
+ continue
+ else
+ P1 := 1;
+ P := nil;
+ end else if (P1 <= Length(TmpStr)) and (pos(TmpStr[P1], FWordDelims) > 0) then begin
+ if (P1 = 1) then begin
+ S := S + ConvertEmbeddedHTML(TmpStr[1]);
+ System.Delete(TmpStr, 1, 1);
+ P1 := 1;
+ end else begin
+ AStr := Copy(TmpStr, 1, P1-1);
+ if (Length(AStr) > 0) then
+ CheckSubstring(AStr);
+ System.Delete(TmpStr, 1, P1);
+ P1 := 1;
+ end;
+ end else begin
+ AStr := TmpStr;
+ CheckSubString(AStr);
+ TmpStr := '';
+ end;
+ until (Length(TmpStr) = 0);
+ FOutTextStream.WriteLine(S);
+ end;
+ if (Assigned(FOnProgress)) then
+ FOnProgress(Self, 0);
+
+ Result := True;
+ FOutTextStream.WriteLine('');
+ if (FPageFooter.Count > 0) then begin
+ for I := 0 to pred(FPageFooter.Count) do
+ FOutTextStream.WriteLine(FPageFooter[I]);
+ end;
+ finally
+ CommentDict.Free;
+ HTMLDict.Free;
+ KeywordsDict.Free;
+ StringDict.Free;
+
+ FInTextStream.Free;
+ FInTextStream := nil;
+
+ FOutTextStream.Free;
+ FOutTextStream := nil;
+ end;
+end;
+
+
+procedure TStStreamToHTML.SetCommentMarkers(Value : TStringList);
+begin
+ FCommentMarkers.Assign(Value);
+end;
+
+
+procedure TStStreamToHTML.SetEmbeddedHTML(Value : TStringList);
+begin
+ FEmbeddedHTML.Assign(Value);
+end;
+
+
+procedure TStStreamToHTML.SetKeywords(Value : TStringList);
+begin
+ FKeywords.Assign(Value);
+end;
+
+
+procedure TStStreamToHTML.SetPageFooter(Value : TStringList);
+begin
+ FPageFooter.Assign(Value);
+end;
+
+
+procedure TStStreamToHTML.SetPageHeader(Value : TStringList);
+begin
+ FPageHeader.Assign(Value);
+end;
+
+
+procedure TStStreamToHTML.SetStringMarkers(Value : TStringList);
+begin
+ FStringMarkers.Assign(Value);
+end;
+
+
+
+(*****************************************************************************)
+(* TStFileToHTML Implementation *)
+(*****************************************************************************)
+
+
+constructor TStFileToHTML.Create(AOwner : TComponent);
+begin
+ inherited Create(AOwner);
+
+ FCommentMarkers := TStringList.Create;
+ FEmbeddedHTML := TStringList.Create;
+ FKeywords := TStringList.Create;
+ FPageFooter := TStringList.Create;
+ FPageHeader := TStringList.Create;
+ FStringMarkers := TStringList.Create;
+
+ FWordDelims := ',; .()';
+
+ FInLineTerminator := ltCRLF;
+ FInLineTermChar := #10;
+ FInLineLength := 80;
+
+ with FEmbeddedHTML do begin
+ Add('"="');
+ Add('&=&');
+ Add('<=<');
+ Add('>=>');
+ Add('¡=¡');
+ Add('¢=¢');
+ Add('£=£');
+ Add('©=©');
+ Add('®=®');
+ Add('±=±');
+ Add('¼=¼');
+ Add('½=½');
+ Add('¾=¾');
+ Add('÷=÷');
+ end;
+end;
+
+
+destructor TStFileToHTML.Destroy;
+begin
+ FCommentMarkers.Free;
+ FCommentMarkers := nil;
+
+ FEmbeddedHTML.Free;
+ FEmbeddedHTML := nil;
+
+ FKeywords.Free;
+ FKeywords := nil;
+
+ FPageFooter.Free;
+ FPageFooter := nil;
+
+ FPageHeader.Free;
+ FPageHeader := nil;
+
+ FStringMarkers.Free;
+ FStringMarkers := nil;
+
+ FInFile.Free;
+ FInFile := nil;
+
+ FOutFile.Free;
+ FOutFile := nil;
+
+ FStream.Free;
+ FStream := nil;
+
+ inherited Destroy;
+end;
+
+
+procedure TStFileToHTML.Execute;
+begin
+ FStream := TStStreamToHTML.Create;
+ try
+ if (FInFileName = '') then
+ RaiseStError(EStToHTMLError, stscNoInputFile)
+ else if (FOutFileName = '') then
+ RaiseStError(EStToHTMLError, stscNoOutputFile)
+ else begin
+ if (Assigned(FInFile)) then
+ FInFile.Free;
+ try
+ FInFile := TFileStream.Create(FInFileName, fmOpenRead or fmShareDenyWrite);
+ except
+ RaiseStError(EStToHTMLError, stscInFileError);
+ Exit;
+ end;
+
+ if (Assigned(FOutFile)) then
+ FOutFile.Free;
+ try
+ FOutFile := TFileStream.Create(FOutFileName, fmCreate);
+ except
+ RaiseStError(EStToHTMLError, stscOutFileError);
+ Exit;
+ end;
+
+ try
+ FStream.InputStream := FInFile;
+ FStream.OutputStream := FOutFile;
+ FStream.CaseSensitive := CaseSensitive;
+ FStream.CommentMarkers := CommentMarkers;
+ FStream.EmbeddedHTML := EmbeddedHTML;
+ FStream.InFixedLineLength := InFixedLineLength;
+ FStream.InLineTermChar := InLineTermChar;
+ FStream.InLineTerminator := InLineTerminator;
+ FStream.Keywords := Keywords;
+ FStream.OnProgress := OnProgress;
+ FStream.PageFooter := PageFooter;
+ FStream.PageHeader := PageHeader;
+ FStream.StringMarkers := StringMarkers;
+ FStream.WordDelimiters := WordDelimiters;
+
+ FStream.GenerateHTML;
+ finally
+ FInFile.Free;
+ FInFile := nil;
+ FOutFile.Free;
+ FOutFile := nil;
+ end;
+ end;
+ finally
+ FStream.Free;
+ FStream := nil;
+ end;
+end;
+
+
+procedure TStFileToHTML.SetCommentMarkers(Value : TStringList);
+begin
+ FCommentMarkers.Assign(Value);
+end;
+
+
+procedure TStFileToHTML.SetEmbeddedHTML(Value : TStringList);
+begin
+ FEmbeddedHTML.Assign(Value);
+end;
+
+
+
+procedure TStFileToHTML.SetKeywords(Value : TStringList);
+begin
+ FKeywords.Assign(Value);
+end;
+
+
+procedure TStFileToHTML.SetPageFooter(Value : TStringList);
+begin
+ FPageFooter.Assign(Value);
+end;
+
+
+procedure TStFileToHTML.SetPageHeader(Value : TStringList);
+begin
+ FPageHeader.Assign(Value);
+end;
+
+
+procedure TStFileToHTML.SetStringMarkers(Value : TStringList);
+begin
+ FStringMarkers.Assign(Value);
+end;
+
+
+end.
diff --git a/components/systools/source/run/stutils.pas b/components/systools/source/run/stutils.pas
new file mode 100644
index 000000000..68dc11fc0
--- /dev/null
+++ b/components/systools/source/run/stutils.pas
@@ -0,0 +1,439 @@
+// Upgraded to Delphi 2009: Sebastian Zierer
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower SysTools
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{*********************************************************}
+{* SysTools: StUtils.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Assorted utility routines *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+// {$I StDefine.inc}
+
+unit StUtils;
+
+interface
+
+uses
+ {$IFNDEF FPC}
+ Windows,
+ {$ENDIF}
+ SysUtils, Classes,
+
+ StConst, StBase, StDate,
+ StStrL; { long string routines }
+
+function SignL(L : LongInt) : Integer;
+ {-return sign of LongInt value}
+function SignF(F : Extended) : Integer;
+ {-return sign of floating point value}
+
+function MinWord(A, B : Word) : Word;
+ {-Return the smaller of A and B}
+function MidWord(W1, W2, W3 : Word) : Word;
+ {-return the middle of three Word values}
+function MaxWord(A, B : Word) : Word;
+ {-Return the greater of A and B}
+
+function MinLong(A, B : LongInt) : LongInt;
+ {-Return the smaller of A and B}
+function MidLong(L1, L2, L3 : LongInt) : LongInt;
+ {-return the middle of three LongInt values}
+function MaxLong(A, B : LongInt) : LongInt;
+ {-Return the greater of A and B}
+
+function MinFloat(F1, F2 : Extended) : Extended;
+ {-return the lesser of two floating point values}
+function MidFloat(F1, F2, F3 : Extended) : Extended;
+ {-return the middle of three floating point values}
+function MaxFloat(F1, F2 : Extended) : Extended;
+ {-return the greater of two floating point values}
+
+{-Assorted utility routines. }
+
+function MakeInteger16(H, L : Byte): SmallInt;
+ {-Construct an integer from two bytes}
+
+function MakeWord(H, L : Byte) : Word;
+ {-Construct a word from two bytes}
+
+function SwapNibble(B : Byte) : Byte;
+ {-Swap the high and low nibbles of a byte}
+
+function SwapWord(L : LongInt) : LongInt;
+ {-Swap the low- and high-order words of a long integer}
+
+procedure SetFlag(var Flags : Word; FlagMask : Word);
+ {-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
+
+procedure ClearFlag(var Flags : Word; FlagMask : Word);
+ {-Clear bit(s) in the parameter Flags. The bits to clear are specified in Flagmask}
+
+function FlagIsSet(Flags, FlagMask : Word) : Boolean;
+ {-Return True if the bit specified by FlagMask is set in Flags}
+
+procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
+ {-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
+
+procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
+ {-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}
+
+function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
+ {-Return True if the bit specified by FlagMask is set in the Flags parameter}
+
+procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
+ {-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
+
+
+procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
+ {-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}
+
+
+function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
+ {-Return True if the bit specified by FlagMask is set in Flags}
+
+procedure ExchangeBytes(var I, J : Byte);
+ {-Exchange the values in two bytes}
+
+procedure ExchangeWords(var I, J : Word);
+ {-Exchange the values in two words}
+
+procedure ExchangeLongInts(var I, J : LongInt);
+ {-Exchange the values in two long integers}
+
+procedure ExchangeStructs(var I, J; Size : Cardinal);
+ {-Exchange the values in two structures}
+
+
+procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
+ {-Fill memory with a word-sized filler}
+
+procedure FillStruct(var Dest; Count : Cardinal; var Filler; FillerSize : Cardinal);
+ {-Fill memory with a variable sized filler}
+
+function AddWordToPtr(P : Pointer; W : Word) : Pointer;
+ {-Add a word to a pointer.}
+
+implementation
+
+const
+ ecOutOfMemory = 8;
+
+function MakeInteger16(H, L : Byte): SmallInt;
+begin
+ Word(Result) := (H shl 8) or L; {!!.02}
+end;
+
+function SwapNibble(B : Byte) : Byte;
+begin
+ Result := (B shr 4) or (B shl 4);
+end;
+
+function SwapWord(L : LongInt) : LongInt; register;
+asm
+ ror eax,16;
+end;
+
+procedure SetFlag(var Flags : Word; FlagMask : Word);
+begin
+ Flags := Flags or FlagMask;
+end;
+
+procedure ClearFlag(var Flags : Word; FlagMask : Word);
+begin
+ Flags := Flags and (not FlagMask);
+end;
+
+
+function FlagIsSet(Flags, FlagMask : Word) : Boolean;
+begin
+ Result := (FlagMask AND Flags <> 0);
+end;
+
+procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
+begin
+ Flags := Flags or FlagMask;
+end;
+
+procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
+begin
+ Flags := Flags and (not FlagMask);
+end;
+
+function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
+begin
+ Result := (FlagMask AND Flags <> 0);
+end;
+
+procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
+begin
+ Flags := Flags or FlagMask;
+end;
+
+procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
+begin
+ Flags := Flags and (not FlagMask);
+end;
+
+function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
+begin
+ Result := FlagMask = (Flags and FlagMask);
+end;
+
+procedure ExchangeBytes(var I, J : Byte);
+register;
+asm
+ mov cl, [eax]
+ mov ch, [edx]
+ mov [edx], cl
+ mov [eax], ch
+end;
+
+procedure ExchangeWords(var I, J : Word);
+register;
+asm
+ mov cx, [eax]
+ push ecx
+ mov cx, [edx]
+ mov [eax], cx
+ pop ecx
+ mov [edx], cx
+end;
+
+procedure ExchangeLongInts(var I, J : LongInt);
+register;
+asm
+ mov ecx, [eax]
+ push ecx
+ mov ecx, [edx]
+ mov [eax], ecx
+ pop ecx
+ mov [edx], ecx
+end;
+
+procedure ExchangeStructs(var I, J; Size : Cardinal);
+register;
+asm
+ push edi
+ push ebx
+ push ecx
+ shr ecx, 2
+ jz @@LessThanFour
+
+@@AgainDWords:
+ mov ebx, [eax]
+ mov edi, [edx]
+ mov [edx], ebx
+ mov [eax], edi
+ add eax, 4
+ add edx, 4
+ dec ecx
+ jnz @@AgainDWords
+
+@@LessThanFour:
+ pop ecx
+ and ecx, $3
+ jz @@Done
+ mov bl, [eax]
+ mov bh, [edx]
+ mov [edx], bl
+ mov [eax], bh
+ inc eax
+ inc edx
+ dec ecx
+ jz @@Done
+
+ mov bl, [eax]
+ mov bh, [edx]
+ mov [edx], bl
+ mov [eax], bh
+ inc eax
+ inc edx
+ dec ecx
+ jz @@Done
+
+ mov bl, [eax]
+ mov bh, [edx]
+ mov [edx], bl
+ mov [eax], bh
+
+@@Done:
+ pop ebx
+ pop edi
+end;
+
+procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
+asm
+ push edi
+ mov edi,Dest
+ mov ax,Filler
+ mov ecx,Count
+ cld
+ rep stosw
+ pop edi
+end;
+
+procedure FillStruct(var Dest; Count : Cardinal; var Filler;
+ FillerSize : Cardinal);
+register;
+asm
+ or edx, edx
+ jz @@Exit
+
+ push edi
+ push esi
+ push ebx
+ mov edi, eax
+ mov ebx, ecx
+
+@@NextStruct:
+ mov esi, ebx
+ mov ecx, FillerSize
+ shr ecx, 1
+ rep movsw
+ adc ecx, ecx
+ rep movsb
+ dec edx
+ jnz @@NextStruct
+
+ pop ebx
+ pop esi
+ pop edi
+
+@@Exit:
+end;
+
+function AddWordToPtr(P : Pointer; W : Word) : Pointer;
+begin
+ Result := Pointer(LongInt(P)+W);
+end;
+
+function MakeWord(H, L : Byte) : Word;
+begin
+ Result := (Word(H) shl 8) or L;
+end;
+
+function MinWord(A, B : Word) : Word;
+begin
+ if A < B then
+ Result := A
+ else
+ Result := B;
+end;
+
+function MaxWord(A, B : Word) : Word;
+begin
+ if A > B then
+ Result := A
+ else
+ Result := B;
+end;
+
+function MinLong(A, B : LongInt) : LongInt;
+begin
+ if A < B then
+ Result := A
+ else
+ Result := B;
+end;
+
+function MaxLong(A, B : LongInt) : LongInt;
+begin
+ if A > B then
+ Result := A
+ else
+ Result := B;
+end;
+
+function SignL(L : LongInt) : Integer;
+ {-return sign of LongInt value}
+begin
+ if L < 0 then
+ Result := -1
+ else if L = 0 then
+ Result := 0
+ else
+ Result := 1;
+end;
+
+function SignF(F : Extended) : Integer;
+ {-return sign of floating point value}
+begin
+ if F < 0 then
+ Result := -1
+ else if F = 0 then
+ Result := 0
+ else
+ Result := 1;
+end;
+
+function MidWord(W1, W2, W3 : Word) : Word;
+ {return the middle of three Word values}
+begin
+ Result := StUtils.MinWord(StUtils.MinWord(StUtils.MaxWord(W1, W2),
+ StUtils.MaxWord(W2, W3)), StUtils.MaxWord(W1, W3));
+end;
+
+function MidLong(L1, L2, L3 : LongInt) : LongInt;
+ {return the middle of three LongInt values}
+begin
+ Result := StUtils.MinLong(StUtils.MinLong(StUtils.MaxLong(L1, L2),
+ StUtils.MaxLong(L2, L3)), StUtils.MaxLong(L1, L3));
+end;
+
+function MidFloat(F1, F2, F3 : Extended) : Extended;
+ {return the middle of three floating point values}
+begin
+ Result := MinFloat(MinFloat(MaxFloat(F1, F2), MaxFloat(F2, F3)), MaxFloat(F1, F3));
+end;
+
+function MinFloat(F1, F2 : Extended) : Extended;
+ {-return the lesser of two floating point values}
+begin
+ if F1 <= F2 then
+ Result := F1
+ else
+ Result := F2;
+end;
+
+function MaxFloat(F1, F2 : Extended) : Extended;
+ {-return the greater of two floating point values}
+begin
+ if F1 > F2 then
+ Result := F1
+ else
+ Result := F2;
+end;
+
+
+end.
+
+
+