Delphi知识中心
www.delphi.ee
提供Delphi技术知识
与Delphi程序员共同进步


在线服务QQ:99923144 随时恭候您的光临
首页 基础知识 WIN系统 组件使用 组件开发 数据库 ACTIVEX 多媒体技术 网络技术 关于
文章类别:基础知识    你尚未登陆,会员功能无法使用,请从 网站首页 登陆。
  最快的字符串函数库 FastStringsFuncs  
 
最快的字符串函数库 FastStringsFuncs

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.
 

在线服务QQ:99923144 Delphi程序员QQ群(139442)
Delphi知识中心 www.delphi.ee 最专业的Delphi技术资料网站