unit FastStringFuncs;
interface
uses
Graphics, FastStrings, Sysutils, Classes;
const
cHexChars = '0123456789ABCDEF';
cSoundexTable: array[65..122] of Byte =
({A}0, {B}1, {C}2, {D}3, {E}0, {F}1, {G}2, {H}0, {I}0, {J}2, {K}2, {L}4, {M}5,
{N}5, {O}0, {P}1, {Q}2, {R}6, {S}2, {T}3, {U}0, {V}1, {W}0, {X}2, {Y}0, {Z}2,
0, 0, 0, 0, 0, 0,
{a}0, {b}1, {c}2, {d}3, {e}0, {f}1, {g}2, {h}0, {i}0, {j}2, {k}2, {l}4, {m}5,
{n}5, {o}0, {p}1, {q}2, {r}6, {s}2, {t}3, {u}0, {v}1, {w}0, {x}2, {y}0, {z}2);
function Base64Encode(const Source: AnsiString): AnsiString;
function Base64Decode(const Source: string): string;
function CopyStr(const aSourceString : string; aStart, aLength : Integer) : string;
function Decrypt(const S: string; Key: Word): string;
function Encrypt(const S: string; Key: Word): string;
function ExtractHTML(S : string) : string;
function ExtractNonHTML(S : string) : string;
function HexToInt(aHex : string) : int64;
function LeftStr(const aSourceString : string; Size : Integer) : string;
function StringMatches(Value, Pattern : string) : Boolean;
function MissingText(Pattern, Source : string; SearchText : string = '?') : string;
function RandomFileName(aFilename : string) : string;
function RandomStr(aLength : Longint) : string;
function ReverseStr(const aSourceString: string): string;
function RightStr(const aSourceString : string; Size : Integer) : string;
function RGBToColor(aRGB : string) : TColor;
function StringCount(const aSourceString, aFindString : string; Const CaseSensitive : Boolean = TRUE) : Integer;
function SoundEx(const aSourceString: string): Integer;
function UniqueFilename(aFilename : string) : string;
function URLToText(aValue : string) : string;
function WordAt(Text : string; Position : Integer) : string;
procedure Split(aValue : string; aDelimiter : Char; var Result : TStrings);
implementation
const
cKey1 = 52845;
cKey2 = 22719;
Base64_Table : shortstring = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
function StripHTMLorNonHTML(const S : string; WantHTML : Boolean) : string; forward;
//Encode to Base64
function Base64Encode(const Source: AnsiString): AnsiString;
var
NewLength: Integer;
begin
NewLength := ((2 + Length(Source)) div 3) * 4;
SetLength( Result, NewLength);
asm
Push ESI
Push EDI
Push EBX
Lea EBX, Base64_Table
Inc EBX // Move past String Size (ShortString)
Mov EDI, Result
Mov EDI, [EDI]
Mov ESI, Source
Mov EDX, [ESI-4] //Length of Input String
@WriteFirst2:
CMP EDX, 0
JLE @Done
MOV AL, [ESI]
SHR AL, 2
{$IFDEF VER140} // Changes to BASM in D6
XLATB
{$ELSE}
XLAT
{$ENDIF}
MOV [EDI], AL
INC EDI
MOV AL, [ESI + 1]
MOV AH, [ESI]
SHR AX, 4
AND AL, 63
{$IFDEF VER140} // Changes to BASM in D6
XLATB
{$ELSE}
XLAT
{$ENDIF}
MOV [EDI], AL
INC EDI
CMP EDX, 1
JNE @Write3
MOV AL, 61 // Add ==
MOV [EDI], AL
INC EDI
MOV [EDI], AL
INC EDI
JMP @Done
@Write3:
MOV AL, [ESI + 2]
MOV AH, [ESI + 1]
SHR AX, 6
AND AL, 63
{$IFDEF VER140} // Changes to BASM in D6
XLATB
{$ELSE}
XLAT
{$ENDIF}
MOV [EDI], AL
INC EDI
CMP EDX, 2
JNE @Write4
MOV AL, 61 // Add =
MOV [EDI], AL
INC EDI
JMP @Done
@Write4:
MOV AL, [ESI + 2]
AND AL, 63
{$IFDEF VER140} // Changes to BASM in D6
XLATB
{$ELSE}
XLAT
{$ENDIF}
MOV [EDI], AL
INC EDI
ADD ESI, 3
SUB EDX, 3
JMP @WriteFirst2
@done:
Pop EBX
Pop EDI
Pop ESI
end;
end;
//Decode Base64
function Base64Decode(const Source: string): string;
var
NewLength: Integer;
begin
{
NB: On invalid input this routine will simply skip the bad data, a
better solution would probably report the error
ESI -> Source String
EDI -> Result String
ECX -> length of Source (number of DWords)
EAX -> 32 Bits from Source
EDX -> 24 Bits Decoded
BL -> Current number of bytes decoded
}
SetLength( Result, (Length(Source) div 4) * 3);
NewLength := 0;
asm
Push ESI
Push EDI
Push EBX
Mov ESI, Source
Mov EDI, Result //Result address
Mov EDI, [EDI]
Or ESI,ESI // Nil Strings
Jz @Done
Mov ECX, [ESI-4]
Shr ECX,2 // DWord Count
JeCxZ @Error // Empty String
Cld
jmp @Read4
@Next:
Dec ECX
Jz @Done
@Read4:
lodsd
Xor BL, BL
Xor EDX, EDX
Call @DecodeTo6Bits
Shl EDX, 6
Shr EAX,8
Call @DecodeTo6Bits
Shl EDX, 6
Shr EAX,8
Call @DecodeTo6Bits
Shl EDX, 6
Shr EAX,8
Call @DecodeTo6Bits
// Write Word
Or BL, BL
JZ @Next // No Data
Dec BL
Or BL, BL
JZ @Next // Minimum of 2 decode values to translate to 1 byte
Mov EAX, EDX
Cmp BL, 2
JL @WriteByte
Rol EAX, 8
BSWAP EAX
StoSW
Add NewLength, 2
@WriteByte:
Cmp BL, 2
JE @Next
SHR EAX, 16
StoSB
Inc NewLength
jmp @Next
@Error:
jmp @Done
@DecodeTo6Bits:
@TestLower:
Cmp AL, 'a'
Jl @TestCaps
Cmp AL, 'z'
Jg @Skip
Sub AL, 71
Jmp @Finish
@TestCaps:
Cmp AL, 'A'
Jl @TestEqual
Cmp AL, 'Z'
Jg @Skip
Sub AL, 65
Jmp @Finish
@TestEqual:
Cmp AL, '='
Jne @TestNum
// Skip byte
ret
@TestNum:
Cmp AL, '9'
Jg @Skip
Cmp AL, '0'
JL @TestSlash
Add AL, 4
Jmp @Finish
@TestSlash:
Cmp AL, '/'
Jne @TestPlus
Mov AL, 63
Jmp @Finish
@TestPlus:
Cmp AL, '+'
Jne @Skip
Mov AL, 62
@Finish:
Or DL, AL
Inc BL
@Skip:
Ret
@Done:
Pop EBX
Pop EDI
Pop ESI
end;
SetLength( Result, NewLength); // Trim off the excess
end;
//Encrypt a string
function Encrypt(const S: string; Key: Word): string;
var
I: byte;
begin
SetLength(result,length(s));
for I := 1 to Length(S) do
begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(Result[I]) + Key) * cKey1 + cKey2;
end;
end;
//Return only the HTML of a string
function ExtractHTML(S : string) : string;
begin
Result := StripHTMLorNonHTML(S, True);
end;
function CopyStr(const aSourceString : string; aStart, aLength : Integer) : string;
var
L : Integer;
begin
L := Length(aSourceString);
if L=0 then Exit;
if (aStart < 1) or (aLength < 1) then Exit;
if aStart + (aLength-1) > L then aLength := L - (aStart-1);
if (aStart <1) then exit;
SetLength(Result,aLength);
FastCharMove(aSourceString[aStart], Result[1], aLength);
end;
//Take all HTML out of a string
function ExtractNonHTML(S : string) : string;
begin
Result := StripHTMLorNonHTML(S,False);
end;
//Decrypt a string encoded with Encrypt
function Decrypt(const S: string; Key: Word): string;
var
I: byte;
begin
SetLength(result,length(s));
for I := 1 to Length(S) do
begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(S[I]) + Key) * cKey1 + cKey2;
end;
end;
//Convert a text-HEX value (FF0088 for example) to an integer
function HexToInt(aHex : string) : int64;
var
Multiplier : Int64;
Position : Byte;
Value : Integer;
begin
Result := 0;
Multiplier := 1;
Position := Length(aHex);
while Position >0 do begin
Value := FastCharPosNoCase(cHexChars, aHex[Position], 1)-1;
if Value = -1 then
raise Exception.Create('Invalid hex character ' + aHex[Position]);
Result := Result + (Value * Multiplier);
Multiplier := Multiplier * 16;
Dec(Position);
end;
end;
//Get the left X amount of chars
function LeftStr(const aSourceString : string; Size : Integer) : string;
begin
if Size > Length(aSourceString) then
Result := aSourceString
else begin
SetLength(Result, Size);
Move(aSourceString[1],Result[1],Size);
end;
end;
//Do strings match with wildcards, eg
//StringMatches('The cat sat on the mat', 'The * sat * the *') = True
function StringMatches(Value, Pattern : string) : Boolean;
var
NextPos,
Star1,
Star2 : Integer;
NextPattern : string;
begin
Star1 := FastCharPos(Pattern,'*',1);
if Star1 = 0 then
Result := (Value = Pattern)
else
begin
Result := (Copy(Value,1,Star1-1) = Copy(Pattern,1,Star1-1));
if Result then
begin
if Star1 > 1 then Value := Copy(Value,Star1,Length(Value));
Pattern := Copy(Pattern,Star1+1,Length(Pattern));
NextPattern := Pattern;
Star2 := FastCharPos(NextPattern, '*',1);
if Star2 > 0 then NextPattern := Copy(NextPattern,1,Star2-1);
//pos(NextPattern,Value);
NextPos := FastPos(Value, NextPattern, Length(Value), Length(NextPattern), 1);
if (NextPos = 0) and not (NextPattern = '') then
Result := False
else
begin
Value := Copy(Value,NextPos,Length(Value));
if Pattern = '' then
Result := True
else
Result := Result and StringMatches(Value,Pattern);
end;
end;
end;
end;
//Missing text will tell you what text is missing, eg
//MissingText('the ? sat on the mat','the cat sat on the mat','?') = 'cat'
function MissingText(Pattern, Source : string; SearchText : string = '?') : string;
var
Position : Longint;
BeforeText,
AfterText : string;
BeforePos,
AfterPos : Integer;
lSearchText,
lBeforeText,
lAfterText,
lSource : Longint;
begin
Result := '';
Position := Pos(SearchText,Pattern);
if Position = 0 then exit;
lSearchText := Length(SearchText);
lSource := Length(Source);
BeforeText := Copy(Pattern,1,Position-1);
AfterText := Copy(Pattern,Position+lSearchText,lSource);
lBeforeText := Length(BeforeText);
lAfterText := Length(AfterText);
AfterPos := lBeforeText;
repeat
AfterPos := FastPosNoCase(Source,AfterText,lSource,lAfterText,AfterPos+lSearchText);
if AfterPos > 0 then begin
BeforePos := FastPosBackNoCase(Source,BeforeText,AfterPos-1,lBeforeText,AfterPos - (lBeforeText-1));
if (BeforePos > 0) then begin
Result := Copy(Source,BeforePos + lBeforeText, AfterPos - (BeforePos + lBeforeText));
Break;
end;
end;
until AfterPos = 0;
end;
//Generates a random filename but preserves the original path + extension
function RandomFilename(aFilename : string) : string;
var
Path,
Filename,
Ext : string;
begin
Result := aFilename;
Path := ExtractFilepath(aFilename);
Ext := ExtractFileExt(aFilename);
Filename := ExtractFilename(aFilename);
if Length(Ext) > 0 then
Filename := Copy(Filename,1,Length(Filename)-Length(Ext));
repeat
Result := Path + RandomStr(32) + Ext;
until not FileExists(Result);
end;
//Makes a string of aLength filled with random characters
function RandomStr(aLength : Longint) : string;
var
X : Longint;
begin
if aLength <= 0 then exit;
SetLength(Result, aLength);
for X:=1 to aLength do
Result[X] := Chr(Random(26) + 65);
end;
function ReverseStr(const aSourceString: string): string;
var
L : Integer;
S,
D : Pointer;
begin
L := Length(aSourceString);
SetLength(Result,L);
if L = 0 then exit;
S := @aSourceString[1];
D := @Result[L];
asm
push ESI
push EDI
mov ECX, L
mov ESI, S
mov EDI, D
@Loop:
mov Al, [ESI]
inc ESI
mov [EDI], Al
dec EDI
dec ECX
jnz @Loop
pop EDI
pop ESI
end;
end;
//Returns X amount of chars from the right of a string
function RightStr(const aSourceString : string; Size : Integer) : string;
begin
if Size > Length(aSourceString) then
Result := aSourceString
else begin
SetLength(Result, Size);
FastCharMove(aSourceString[Length(aSourceString)-(Size-1)],Result[1],Size);
end;
end;
//Converts a typical HTML RRGGBB color to a TColor
function RGBToColor(aRGB : string) : TColor;
begin
if Length(aRGB) < 6 then raise EConvertError.Create('Not a valid RGB value');
if aRGB[1] = '#' then aRGB := Copy(aRGB,2,Length(aRGB));
if Length(aRGB) <> 6 then raise EConvertError.Create('Not a valid RGB value');
Result := HexToInt(aRGB);
asm
mov EAX, Result
BSwap EAX
shr EAX, 8
mov Result, EAX
end;
end;
//Splits a delimited text line into TStrings (does not account for stuff in quotes but it should)
procedure Split(aValue : string; aDelimiter : Char; var Result : TStrings);
var
X : Integer;
S : string;
begin
if Result = nil then Result := TStringList.Create;
Result.Clear;
S := '';
for X:=1 to Length(aValue) do begin
if aValue[X] <> aDelimiter then
S:=S + aValue[X]
else begin
Result.Add(S);
S := '';
end;
end;
if S <> '' then Result.Add(S);
end;
//counts how many times a substring exists within a string
//StringCount('XXXXX','XX') would return 2
function StringCount(const aSourceString, aFindString : string; Const CaseSensitive : Boolean = TRUE) : Integer;
var
Find,
Source,
NextPos : PChar;
LSource,
LFind : Integer;
Next : TFastPosProc;
JumpTable : TBMJumpTable;
begin
Result := 0;
LSource := Length(aSourceString);
if LSource = 0 then exit;
LFind := Length(aFindString);
if LFind = 0 then exit;
if CaseSensitive then
begin
Next := BMPos;
MakeBMTable(PChar(aFindString), Length(aFindString), JumpTable);
end else
begin
Next := BMPosNoCase;
MakeBMTableNoCase(PChar(aFindString), Length(aFindString), JumpTable);
end;
Source := @aSourceString[1];
Find := @aFindString[1];
repeat
NextPos := Next(Source, Find, LSource, LFind, JumpTable);
if NextPos <> nil then
begin
Dec(LSource, (NextPos - Source) + LFind);
Inc(Result);
Source := NextPos + LFind;
end;
until NextPos = nil;
end;
function SoundEx(const aSourceString: string): Integer;
var
CurrentChar: PChar;
I, S, LastChar, SoundexGroup: Byte;
Multiple: Word;
begin
if aSourceString = '' then
Result := 0
else
begin
//Store first letter immediately
Result := Ord(Upcase(aSourceString[1]));
//Last character found = 0
LastChar := 0;
Multiple := 26;
//Point to first character
CurrentChar := @aSourceString[1];
for I := 1 to Length(aSourceString) do
begin
Inc(CurrentChar);
S := Ord(CurrentChar^);
if (S > 64) and (S < 123) then
begin
SoundexGroup := cSoundexTable[S];
if (SoundexGroup <> LastChar) and (SoundexGroup > 0) then
begin
Inc(Result, SoundexGroup * Multiple);
if Multiple = 936 then Break; {26 * 6 * 6}
Multiple := Multiple * 6;
LastChar := SoundexGroup;
end;
end;
end;
end;
end;
//Used by ExtractHTML and ExtractNonHTML
function StripHTMLorNonHTML(const S : string; WantHTML : Boolean) : string;
var
X: Integer;
TagCnt: Integer;
ResChar: PChar;
SrcChar: PChar;
begin
TagCnt := 0;
SetLength(Result, Length(S));
if Length(S) = 0 then Exit;
ResChar := @Result[1];
SrcChar := @S[1];
for X:=1 to Length(S) do
begin
case SrcChar^ of
'<':
begin
Inc(TagCnt);
if WantHTML and (TagCnt = 1) then
begin
ResChar^ := '<';
Inc(ResChar);
end;
end;
'>':
begin
Dec(TagCnt);
if WantHTML and (TagCnt = 0) then
begin
ResChar^ := '>';
Inc(ResChar);
end;
end;
else
case WantHTML of
False:
if TagCnt <= 0 then
begin
ResChar^ := SrcChar^;
Inc(ResChar);
TagCnt := 0;
end;
True:
if TagCnt >= 1 then
begin
ResChar^ := SrcChar^;
Inc(ResChar);
end else
if TagCnt < 0 then TagCnt := 0;
end;
end;
Inc(SrcChar);
end;
SetLength(Result, ResChar - PChar(@Result[1]));
Result := FastReplace(Result, ' ', ' ', False);
Result := FastReplace(Result,'&','&', False);
Result := FastReplace(Result,'<','<', False);
Result := FastReplace(Result,'>','>', False);
Result := FastReplace(Result,'"','"', False);
end;
//Generates a UniqueFilename, makes sure the file does not exist before returning a result
function UniqueFilename(aFilename : string) : string;
var
Path,
Filename,
Ext : string;
Index : Integer;
begin
Result := aFilename;
if FileExists(aFilename) then begin
Path := ExtractFilepath(aFilename);
Ext := ExtractFileExt(aFilename);
Filename := ExtractFilename(aFilename);
if Length(Ext) > 0 then
Filename := Copy(Filename,1,Length(Filename)-Length(Ext));
Index := 2;
repeat
Result := Path + Filename + IntToStr(Index) + Ext;
Inc(Index);
until not FileExists(Result);
end;
end;
//Decodes all that %3c stuff you get in a URL
function URLToText(aValue : string) : string;
var
X : Integer;
begin
Result := '';
X := 1;
while X <= Length(aValue) do begin
if aValue[X] <> '%' then
Result := Result + aValue[X]
else begin
Result := Result + Chr( HexToInt( Copy(aValue,X+1,2) ) );
Inc(X,2);
end;
Inc(X);
end;
end;
//Returns the whole word at a position
function WordAt(Text : string; Position : Integer) : string;
var
L,
X : Integer;
begin
Result := '';
L := Length(Text);
if (Position > L) or (Position < 1) then Exit;
for X:=Position to L do begin
if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then
Result := Result + Text[X]
else
Break;
end;
for X:=Position-1 downto 1 do begin
if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then
Result := Text[X] + Result
else
Break;
end;
end;
end.
