1
0
Files
applications
bindings
components
Comba_Animation
aboutcomponent
acs
beepfp
callite
captcha
chelper
chemtext
cmdline
cmdlinecfg
colorpalette
cryptini
csvdocument
epiktimer
everettrandom
examplecomponent
exctrls
extrasyn
fpexif
fpsound
fpspreadsheet
fractions
freetypepascal
geckoport
gradcontrols
grid_semaphor
industrialstuff
iosdesigner
iphonelazext
jujiboutils
jvcllaz
kcontrols
lazautoupdate
lazbarcodes
lazmapviewer
lclextensions
longtimer
manualdock
mbColorLib
mplayer
multithreadprocs
nvidia-widgets
onguard
orpheus
playsoundpackage
poweredby
powerpdf
rgbgraphics
richmemo
richview
rtfview
rx
scrolltext
smnetgradient
spktoolbar
splashabout
svn
systools
examples
images
source
db
general
design
run
st2dbarc.pas
stastro.pas
stastrop.pas
stbarc.pas
stbarpn.pas
stbase.pas
stbcd.pas
stbits.pas
stccy.dat
stccycnv.dat
stcoll.pas
stconst.pas
stcrc.pas
stdate.pas
stdatest.pas
stdecmth.pas
stdict.pas
stdque.pas
steclpse.pas
stexpr.pas
stexpr.txt
stfin.pas
sthash.pas
stinistm.pas
stjup.pas
stjupsat.pas
stlarr.pas
stlist.pas
stmars.pas
stmath.pas
stmerc.pas
stmerge.pas
stmoney.pas
stneptun.pas
stnvbits.pas
stnvcoll.pas
stnvcont.pas
stnvdict.pas
stnvdq.pas
stnvlary.pas
stnvlist.pas
stnvlmat.pas
stnvscol.pas
stnvtree.pas
stpluto.pas
stpqueue.pas
stptrns.pas
strandom.pas
stregex.pas
stsaturn.pas
ststat.pas
ststrl.pas
ststrms.pas
ststrs.pas
sttext.pas
sttohtml.pas
sttree.pas
sttxtdat.pas
sturanus.pas
stutils.pas
stvarr.pas
stvenus.pas
include
windows_only
laz_systools.lpk
laz_systools.pas
laz_systools_all.lpg
laz_systools_design.lpk
laz_systools_design.pas
laz_systoolsdb.lpk
laz_systoolsdb.pas
laz_systoolsdb_design.lpk
laz_systoolsdb_design.pas
laz_systoolswin.lpk
laz_systoolswin.pas
laz_systoolswin_design.lpk
laz_systoolswin_design.pas
readme-orig.txt
readme.txt
readme404pre.txt
tdi
thtmlport
tparadoxdataset
tvplanit
xdev_toolkit
zlibar
zmsql
examples
image_sources
lclbindings
wst
lazarus-ccr/components/systools/source/general/run/ststrs.pas

3409 lines
95 KiB
ObjectPascal
Raw Normal View History

(* ***** 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.