You've already forked lazarus-ccr
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
gridprinter
industrialstuff
iosdesigner
iphonelazext
jujiboutils
jvcllaz
kcontrols
lazautoupdate
lazbarcodes
lazmapviewer
lclextensions
longtimer
manualdock
mbColorLib
mplayer
multithreadprocs
nicechart
nicegrid
nicesidebar
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
3558 lines
97 KiB
ObjectPascal
3558 lines
97 KiB
ObjectPascal
![]() |
// 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.
|