Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Быстрые операции с очень большими строками

01.01.2007

FastStrings.pas

//==================================================
//All code herein is copyrighted by
//Peter Morris
//-----
//Do not alter / remove this copyright notice
//Email me at : support@droopyeyes.com
//
//The homepage for this library is http://www.droopyeyes.com
//
// CURRENT VERSION V3.2
//
//(Check out www.HowToDoThings.com for Delphi articles !)
//(Check out www.stuckindoors.com if you need a free events page on your site !)
//==================================================
 
 
unit
FastStrings;
 
interface
 
uses
   
{$IFNDEF LINUX}
     
Windows,
   
{$ENDIF}
   
SysUtils;
 
//This TYPE declaration will become apparent later
type
 
TBMJumpTable = array[0..255] of Integer;
 
TFastPosProc = function (const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
 
TFastPosIndexProc = function (const aSourceString, aFindString: string; const aSourceLen, aFindLen, StartPos: Integer; var JumpTable: TBMJumpTable): Integer;
 
TFastTagReplaceProc = procedure (var Tag: string; const UserData: Integer);
 
 
//Boyer-Moore routines
procedure
MakeBMTable(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);
procedure
MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);
function BMPos(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
function BMPosNoCase(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
 
function FastAnsiReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;
procedure
FastCharMove(const Source; var Dest; Count : Integer);
function FastCharPos(const aSource : string; const C: Char; StartPos : Integer): Integer;
function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer): Integer;
function FastPos(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosBack(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
function FastReplace(const aSourceString : string; const aFindString, aReplaceString : string;
 
CaseSensitive : Boolean = False) : string;
function FastTagReplace(const SourceString, TagStart, TagEnd: string;
 
FastTagReplaceProc: TFastTagReplaceProc; const UserData: Integer): string;
function SmartPos(const SearchStr,SourceStr : string;
                 
const CaseSensitive : Boolean = TRUE;
                 
const StartPos : Integer = 1;
                 
const ForwardSearch : Boolean = TRUE) : Integer;
 
implementation
 
const
  cDeltaSize
= 1.5;
 
var
 
GUpcaseTable : array[0..255] of char;
 
GUpcaseLUT: Pointer;
 
//MakeBMJumpTable takes a FindString and makes a JumpTable
procedure
MakeBMTable(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);
begin
 
if BufferLen = 0 then raise Exception.Create('BufferLen is 0');
 
asm
        push    EDI
        push    ESI
        mov     EDI
, JumpTable
        mov     EAX
, BufferLen
        mov     ECX
, $100
        REPNE   STOSD
        mov     ECX
, BufferLen
        mov     EDI
, JumpTable
        mov     ESI
, Buffer
        dec     ECX
        xor     EAX
, EAX
@@loop
:
        mov     AL
, [ESI]
        lea     ESI
, ESI + 1
        mov    
[EDI + EAX * 4], ECX
        dec     ECX
        jg      @@loop
 
        pop     ESI
        pop     EDI
 
end;
end;
 
procedure
MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);
begin
 
if BufferLen = 0 then raise Exception.Create('BufferLen is 0');
 
asm
        push    EDI
        push    ESI
 
        mov     EDI
, JumpTable
        mov     EAX
, BufferLen
        mov     ECX
, $100
        REPNE   STOSD
 
        mov     EDX
, GUpcaseLUT
        mov     ECX
, BufferLen
        mov     EDI
, JumpTable
        mov     ESI
, Buffer
        dec     ECX
        xor     EAX
, EAX
@@loop
:
        mov     AL
, [ESI]
        lea     ESI
, ESI + 1
        mov     AL
, [EDX + EAX]
        mov    
[EDI + EAX * 4], ECX
        dec     ECX
        jg      @@loop
        pop     ESI
        pop     EDI
 
end;
end;
 
function BMPos(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
var
 
LastPos: Pointer;
begin
 
LastPos := Pointer(Integer(aSource) + aSourceLen - 1);
 
asm
        push    ESI
        push    EDI
        push    EBX
 
        mov     EAX
, aFindLen
        mov     ESI
, aSource
        lea     ESI
, ESI + EAX - 1
        std
        mov     EBX
, JumpTable
 
@@comparetext
:
        cmp     ESI
, LastPos
        jg      @@NotFound
        mov     EAX
, aFindLen
        mov     EDI
, aFind
        mov     ECX
, EAX
        push    ESI
//Remember where we are
        lea     EDI
, EDI + EAX - 1
        xor     EAX
, EAX
@@CompareNext
:
        mov     al
, [ESI]
        cmp     al
, [EDI]
        jne     @@LookAhead
        lea     ESI
, ESI - 1
        lea     EDI
, EDI - 1
        dec     ECX
        jz      @@Found
        jmp     @@CompareNext
 
@@LookAhead
:
       
//Look up the char in our Jump Table
        pop     ESI
        mov     al
, [ESI]
        mov     EAX
, [EBX + EAX * 4]
        lea     ESI
, ESI + EAX
        jmp     @@CompareText
 
@@NotFound
:
        mov    
Result, 0
        jmp     @@TheEnd
@@Found
:
        pop     EDI
//We are just popping, we don't need the value
        inc     ESI
        mov    
Result, ESI
@@TheEnd
:
        cld
        pop     EBX
        pop     EDI
        pop     ESI
 
end;
end;
 
function BMPosNoCase(const aSource, aFind: Pointer; const aSourceLen, aFindLen: Integer; var JumpTable: TBMJumpTable): Pointer;
var
 
LastPos: Pointer;
begin
 
LastPos := Pointer(Integer(aSource) + aSourceLen - 1);
 
asm
        push    ESI
        push    EDI
        push    EBX
 
        mov     EAX
, aFindLen
        mov     ESI
, aSource
        lea     ESI
, ESI + EAX - 1
        std
        mov     EDX
, GUpcaseLUT
 
@@comparetext
:
        cmp     ESI
, LastPos
        jg      @@NotFound
        mov     EAX
, aFindLen
        mov     EDI
, aFind
        push    ESI
//Remember where we are
        mov     ECX
, EAX
        lea     EDI
, EDI + EAX - 1
        xor     EAX
, EAX
@@CompareNext
:
        mov     al
, [ESI]
        mov     bl
, [EDX + EAX]
        mov     al
, [EDI]
        cmp     bl
, [EDX + EAX]
        jne     @@LookAhead
        lea     ESI
, ESI - 1
        lea     EDI
, EDI - 1
        dec     ECX
        jz      @@Found
        jmp     @@CompareNext
 
@@LookAhead
:
       
//Look up the char in our Jump Table
        pop     ESI
        mov     EBX
, JumpTable
        mov     al
, [ESI]
        mov     al
, [EDX + EAX]
        mov     EAX
, [EBX + EAX * 4]
        lea     ESI
, ESI + EAX
        jmp     @@CompareText
 
@@NotFound
:
        mov    
Result, 0
        jmp     @@TheEnd
@@Found
:
        pop     EDI
//We are just popping, we don't need the value
        inc     ESI
        mov    
Result, ESI
@@TheEnd
:
        cld
        pop     EBX
        pop     EDI
        pop     ESI
 
end;
end;
 
 
//NOTE : FastCharPos and FastCharPosNoCase do not require you to pass the length
//       of the string, this was only done in FastPos and FastPosNoCase because
//       they are used by FastReplace many times over, thus saving a LENGTH()
//       operation each time.  I can't see you using these two routines for the
//       same purposes so I didn't do that this time !
function FastCharPos(const aSource : string; const C: Char; StartPos : Integer) : Integer;
var
  L                          
: Integer;
begin
 
//If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
 
Assert(StartPos > 0);
 
 
Result := 0;
  L
:= Length(aSource);
 
if L = 0 then exit;
 
if StartPos > L then exit;
 
Dec(StartPos);
 
asm
      PUSH EDI                
//Preserve this register
 
      mov  EDI
, aSource        //Point EDI at aSource
      add  EDI
, StartPos
      mov  ECX
, L              //Make a note of how many chars to search through
     
sub  ECX, StartPos
      mov  AL
,  C              //and which char we want
   
@Loop:
      cmp  
Al, [EDI]           //compare it against the SourceString
      jz  
@Found
      inc  EDI
      dec  ECX
      jnz  
@Loop
      jmp  
@NotFound
   
@Found:
     
sub  EDI, aSource        //EDI has been incremented, so EDI-OrigAdress = Char pos !
      inc  EDI
      mov  
Result,   EDI
   
@NotFound:
 
      POP  EDI
 
end;
end;
 
function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer) : Integer;
var
  L                          
: Integer;
begin
 
Result := 0;
  L
:= Length(aSource);
 
if L = 0 then exit;
 
if StartPos > L then exit;
 
Dec(StartPos);
 
if StartPos < 0 then StartPos := 0;
 
 
asm
      PUSH EDI                
//Preserve this register
      PUSH EBX
      mov  EDX
, GUpcaseLUT
 
      mov  EDI
, aSource        //Point EDI at aSource
      add  EDI
, StartPos
      mov  ECX
, L              //Make a note of how many chars to search through
     
sub  ECX, StartPos
 
      xor  EBX
, EBX
      mov  BL
,  C
      mov  AL
, [EDX+EBX]
   
@Loop:
      mov  BL
, [EDI]
      inc  EDI
      cmp  
Al, [EDX+EBX]
      jz  
@Found
      dec  ECX
      jnz  
@Loop
      jmp  
@NotFound
   
@Found:
     
sub  EDI, aSource        //EDI has been incremented, so EDI-OrigAdress = Char pos !
      mov  
Result,   EDI
   
@NotFound:
 
      POP  EBX
      POP  EDI
 
end;
end;
 
//The first thing to note here is that I am passing the SourceLength and FindLength
//As neither Source or Find will alter at any point during FastReplace there is
//no need to call the LENGTH subroutine each time !
function FastPos(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
 
JumpTable: TBMJumpTable;
begin
 
//If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
 
Assert(StartPos > 0);
 
if aFindLen < 1 then begin
   
Result := 0;
   
exit;
 
end;
 
if aFindLen > aSourceLen then begin
   
Result := 0;
   
exit;
 
end;
 
 
MakeBMTable(PChar(aFindString), aFindLen, JumpTable);
 
Result := Integer(BMPos(PChar(aSourceString) + (StartPos - 1), PChar(aFindString),aSourceLen - (StartPos-1), aFindLen, JumpTable));
 
if Result > 0 then
   
Result := Result - Integer(@aSourceString[1]) +1;
end;
 
function FastPosNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
 
JumpTable: TBMJumpTable;
begin
 
//If this assert failed, it is because you passed 0 for StartPos, lowest value is 1 !!
 
Assert(StartPos > 0);
 
if aFindLen < 1 then begin
   
Result := 0;
   
exit;
 
end;
 
if aFindLen > aSourceLen then begin
   
Result := 0;
   
exit;
 
end;
 
 
MakeBMTableNoCase(PChar(AFindString), aFindLen, JumpTable);
 
Result := Integer(BMPosNoCase(PChar(aSourceString) + (StartPos - 1), PChar(aFindString),aSourceLen - (StartPos-1), aFindLen, JumpTable));
 
if Result > 0 then
   
Result := Result - Integer(@aSourceString[1]) +1;
end;
 
function FastPosBack(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
 
SourceLen : Integer;
begin
 
if aFindLen < 1 then begin
   
Result := 0;
   
exit;
 
end;
 
if aFindLen > aSourceLen then begin
   
Result := 0;
   
exit;
 
end;
 
 
if (StartPos = 0) or  (StartPos + aFindLen > aSourceLen) then
   
SourceLen := aSourceLen - (aFindLen-1)
 
else
   
SourceLen := StartPos;
 
 
asm
          push ESI
          push EDI
          push EBX
 
          mov EDI
, aSourceString
          add EDI
, SourceLen
         
Dec EDI
 
          mov ESI
, aFindString
          mov ECX
, SourceLen
         
Mov  Al, [ESI]
 
   
@ScaSB:
          cmp  
Al, [EDI]
          jne  
@NextChar
 
   
@CompareStrings:
          mov  EBX
, aFindLen
          dec  EBX
          jz  
@FullMatch
 
   
@CompareNext:
          mov  
Ah, [ESI+EBX]
          cmp  
Ah, [EDI+EBX]
         
Jnz  @NextChar
 
   
@Matches:
         
Dec  EBX
         
Jnz  @CompareNext
 
   
@FullMatch:
          mov  EAX
, EDI
         
sub  EAX, aSourceString
          inc  EAX
          mov  
Result, EAX
          jmp  
@TheEnd
   
@NextChar:
          dec  EDI
          dec  ECX
          jnz  
@ScaSB
 
          mov  
Result,0
 
   
@TheEnd:
          pop  EBX
          pop  EDI
          pop  ESI
 
end;
end;
 
 
function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;
var
 
SourceLen : Integer;
begin
 
if aFindLen < 1 then begin
   
Result := 0;
   
exit;
 
end;
 
if aFindLen > aSourceLen then begin
   
Result := 0;
   
exit;
 
end;
 
 
if (StartPos = 0) or  (StartPos + aFindLen > aSourceLen) then
   
SourceLen := aSourceLen - (aFindLen-1)
 
else
   
SourceLen := StartPos;
 
 
asm
          push ESI
          push EDI
          push EBX
 
          mov  EDI
, aSourceString
          add  EDI
, SourceLen
         
Dec  EDI
 
          mov  ESI
, aFindString
          mov  ECX
, SourceLen
 
          mov  EDX
, GUpcaseLUT
          xor  EBX
, EBX
 
          mov  
Bl, [ESI]
          mov  
Al, [EDX+EBX]
 
   
@ScaSB:
          mov  
Bl, [EDI]
          cmp  
Al, [EDX+EBX]
          jne  
@NextChar
 
   
@CompareStrings:
          PUSH ECX
          mov  ECX
, aFindLen
          dec  ECX
          jz  
@FullMatch
 
   
@CompareNext:
          mov  
Bl, [ESI+ECX]
          mov  
Ah, [EDX+EBX]
          mov  
Bl, [EDI+ECX]
          cmp  
Ah, [EDX+EBX]
         
Jz   @Matches
 
   
//Go back to findind the first char
          POP  ECX
         
Jmp  @NextChar
 
   
@Matches:
         
Dec  ECX
         
Jnz  @CompareNext
 
   
@FullMatch:
          POP  ECX
 
          mov  EAX
, EDI
         
sub  EAX, aSourceString
          inc  EAX
          mov  
Result, EAX
          jmp  
@TheEnd
   
@NextChar:
          dec  EDI
          dec  ECX
          jnz  
@ScaSB
 
          mov  
Result,0
 
   
@TheEnd:
          pop  EBX
          pop  EDI
          pop  ESI
 
end;
end;
 
//My move is not as fast as MOVE when source and destination are both
//DWord aligned, but certainly faster when they are not.
//As we are moving characters in a string, it is not very likely at all that
//both source and destination are DWord aligned, so moving bytes avoids the
//cycle penality of reading/writing DWords across physical boundaries
procedure
FastCharMove(const Source; var Dest; Count : Integer);
asm
//Note:  When this function is called, delphi passes the parameters as follows
//ECX = Count
//EAX = Const Source
//EDX = Var Dest
 
       
//If no bytes to copy, just quit altogether, no point pushing registers
        cmp   ECX
,0
       
Je    @JustQuit
 
       
//Preserve the critical delphi registers
        push  ESI
        push  EDI
 
       
//move Source into ESI  (generally the SOURCE register)
       
//move Dest into EDI (generally the DEST register for string commands)
       
//This may not actually be neccessary, as I am not using MOVsb etc
       
//I may be able just to use EAX and EDX, there may be a penalty for
       
//not using ESI, EDI but I doubt it, this is another thing worth trying !
        mov   ESI
, EAX
        mov   EDI
, EDX
 
       
//The following loop is the same as repNZ MovSB, but oddly quicker !
   
@Loop:
       
//Get the source byte
       
Mov   AL, [ESI]
       
//Point to next byte
       
Inc   ESI
       
//Put it into the Dest
        mov  
[EDI], AL
       
//Point dest to next position
       
Inc   EDI
       
//Dec ECX to note how many we have left to copy
       
Dec   ECX
       
//If ECX <> 0 then loop
       
Jnz   @Loop
 
       
//Another optimization note.
       
//Many people like to do this
 
       
//Mov AL, [ESI]
       
//Mov [EDI], Al
       
//Inc ESI
       
//Inc ESI
 
       
//There is a hidden problem here, I wont go into too much detail, but
       
//the pentium can continue processing instructions while it is still
       
//working out the result of INC ESI or INC EDI
       
//(almost like a multithreaded CPU)
       
//if, however, you go to use them while they are still being calculated
       
//the processor will stop until they are calculated (a penalty)
       
//Therefore I alter ESI and EDI as far in advance as possible of using them
 
       
//Pop the critical Delphi registers that we have altered
        pop   EDI
        pop   ESI
   
@JustQuit:
end;
 
function FastAnsiReplace(const S, OldPattern, NewPattern: string;
 
Flags: TReplaceFlags): string;
var
 
BufferSize, BytesWritten: Integer;
 
SourceString, FindString: string;
 
ResultPChar: PChar;
 
FindPChar, ReplacePChar: PChar;
 
SPChar, SourceStringPChar, PrevSourceStringPChar: PChar;
 
FinalSourceMarker: PChar;
 
SourceLength, FindLength, ReplaceLength, CopySize: Integer;
 
FinalSourcePosition: Integer;
begin
 
//Set up string lengths
 
BytesWritten := 0;
 
SourceLength := Length(S);
 
FindLength := Length(OldPattern);
 
ReplaceLength := Length(NewPattern);
 
//Quick exit
 
if (SourceLength = 0) or (FindLength = 0) or
   
(FindLength > SourceLength) then
 
begin
   
Result := S;
   
Exit;
 
end;
 
 
//Set up the source string and find string
 
if rfIgnoreCase in Flags then
 
begin
   
SourceString := AnsiUpperCase(S);
   
FindString := AnsiUpperCase(OldPattern);
 
end else
 
begin
   
SourceString := S;
   
FindString := OldPattern;
 
end;
 
 
//Set up the result buffer size and pointers
 
try
   
if ReplaceLength <= FindLength then
     
//Result cannot be larger, only same size or smaller
     
BufferSize := SourceLength
   
else
     
//Assume a source string made entired of the sub string
     
BufferSize := (SourceLength * ReplaceLength) div
   
FindLength;
 
   
//10 times is okay for starters. We don't want to
   
//go allocating much more than we need.
   
if BufferSize > (SourceLength * 10) then
     
BufferSize := SourceLength * 10;
 
except
   
//Oops, integer overflow! Better start with a string
   
//of the same size as the source.
   
BufferSize := SourceLength;
 
end;
 
SetLength(Result, BufferSize);
 
ResultPChar := @Result[1];
 
 
//Set up the pointers to S and SourceString
 
SPChar := @S[1];
 
SourceStringPChar := @SourceString[1];
 
PrevSourceStringPChar := SourceStringPChar;
 
FinalSourceMarker := @SourceString[SourceLength - (FindLength - 1)];
 
 
//Set up the pointer to FindString
 
FindPChar := @FindString[1];
 
 
//Set the pointer to ReplaceString
 
if ReplaceLength > 0 then
   
ReplacePChar := @NewPattern[1]
 
else
   
ReplacePChar := nil;
 
 
//Replace routine
  repeat
   
//Find the sub string
   
SourceStringPChar := AnsiStrPos(PrevSourceStringPChar,
   
FindPChar);
   
if SourceStringPChar = nil then Break;
   
//How many characters do we need to copy before
   
//the string occurs
   
CopySize := SourceStringPChar - PrevSourceStringPChar;
 
   
//Check we have enough space in our Result buffer
   
if CopySize + ReplaceLength > BufferSize - BytesWritten then
   
begin
     
BufferSize := Trunc((BytesWritten + CopySize + ReplaceLength) * cDeltaSize);
     
SetLength(Result, BufferSize);
     
ResultPChar := @Result[BytesWritten + 1];
   
end;
 
   
//Copy the preceeding characters to our result buffer
   
Move(SPChar^, ResultPChar^, CopySize);
   
Inc(BytesWritten, CopySize);
   
//Advance the copy position of S
   
Inc(SPChar, CopySize + FindLength);
   
//Advance the Result pointer
   
Inc(ResultPChar, CopySize);
   
//Copy the replace string into the Result buffer
   
if Assigned(ReplacePChar) then
   
begin
     
Move(ReplacePChar^, ResultPChar^, ReplaceLength);
     
Inc(ResultPChar, ReplaceLength);
     
Inc(BytesWritten, ReplaceLength);
   
end;
 
   
//Fake delete the start of the source string
   
PrevSourceStringPChar := SourceStringPChar + FindLength;
 
until (PrevSourceStringPChar > FinalSourceMarker) or
   
not (rfReplaceAll in Flags);
 
 
FinalSourcePosition := Integer(SPChar - @S[1]);
 
CopySize := SourceLength - FinalSourcePosition;
 
SetLength(Result, BytesWritten + CopySize);
 
if CopySize > 0 then
   
Move(SPChar^, Result[BytesWritten + 1], CopySize);
end;
 
function FastReplace(const aSourceString : string; const aFindString, aReplaceString : string;
   
CaseSensitive : Boolean = False) : string;
var
 
PResult                     : PChar;
 
PReplace                    : PChar;
 
PSource                     : PChar;
 
PFind                       : PChar;
 
PPosition                   : PChar;
 
CurrentPos,
 
BytesUsed,
  lResult
,
  lReplace
,
  lSource
,
  lFind                      
: Integer;
 
Find                        : TFastPosProc;
 
CopySize                    : Integer;
 
JumpTable                   : TBMJumpTable;
begin
 
LSource := Length(aSourceString);
 
if LSource = 0 then begin
   
Result := aSourceString;
   
exit;
 
end;
 
PSource := @aSourceString[1];
 
 
LFind := Length(aFindString);
 
if LFind = 0 then exit;
 
PFind := @aFindString[1];
 
 
LReplace := Length(aReplaceString);
 
 
//Here we may get an Integer Overflow, or OutOfMemory, if so, we use a Delta
 
try
   
if LReplace <= LFind then
     
SetLength(Result,lSource)
   
else
     
SetLength(Result, (LSource *LReplace) div  LFind);
 
except
   
SetLength(Result,0);
 
end;
 
 
LResult := Length(Result);
 
if LResult = 0 then begin
   
LResult := Trunc((LSource + LReplace) * cDeltaSize);
   
SetLength(Result, LResult);
 
end;
 
 
 
PResult := @Result[1];
 
 
 
if CaseSensitive then
 
begin
   
MakeBMTable(PChar(AFindString), lFind, JumpTable);
   
Find := BMPos;
 
end else
 
begin
   
MakeBMTableNoCase(PChar(AFindString), lFind, JumpTable);
   
Find := BMPosNoCase;
 
end;
 
 
 
BytesUsed := 0;
 
if LReplace > 0 then begin
   
PReplace := @aReplaceString[1];
    repeat
     
PPosition := Find(PSource,PFind,lSource, lFind, JumpTable);
     
if PPosition = nil then break;
 
     
CopySize := PPosition - PSource;
     
Inc(BytesUsed, CopySize + LReplace);
 
     
if BytesUsed >= LResult then begin
       
//We have run out of space
       
CurrentPos := Integer(PResult) - Integer(@Result[1]) +1;
       
LResult := Trunc(LResult * cDeltaSize);
       
SetLength(Result,LResult);
       
PResult := @Result[CurrentPos];
     
end;
 
     
FastCharMove(PSource^,PResult^,CopySize);
     
Dec(lSource,CopySize + LFind);
     
Inc(PSource,CopySize + LFind);
     
Inc(PResult,CopySize);
 
     
FastCharMove(PReplace^,PResult^,LReplace);
     
Inc(PResult,LReplace);
 
   
until lSource < lFind;
 
end else begin
    repeat
     
PPosition := Find(PSource,PFind,lSource, lFind, JumpTable);
     
if PPosition = nil then break;
 
     
CopySize := PPosition - PSource;
     
FastCharMove(PSource^,PResult^,CopySize);
     
Dec(lSource,CopySize + LFind);
     
Inc(PSource,CopySize + LFind);
     
Inc(PResult,CopySize);
     
Inc(BytesUsed, CopySize);
   
until lSource < lFind;
 
end;
 
 
SetLength(Result, (PResult+LSource) - @Result[1]);
 
if LSource > 0 then
   
FastCharMove(PSource^, Result[BytesUsed + 1], LSource);
end;
 
function FastTagReplace(const SourceString, TagStart, TagEnd: string;
 
FastTagReplaceProc: TFastTagReplaceProc; const UserData: Integer): string;
var
 
TagStartPChar: PChar;
 
TagEndPChar: PChar;
 
SourceStringPChar: PChar;
 
TagStartFindPos: PChar;
 
TagEndFindPos: PChar;
 
TagStartLength: Integer;
 
TagEndLength: Integer;
 
DestPChar: PChar;
 
FinalSourceMarkerStart: PChar;
 
FinalSourceMarkerEnd: PChar;
 
BytesWritten: Integer;
 
BufferSize: Integer;
 
CopySize: Integer;
 
ReplaceString: string;
 
  procedure
AddBuffer(const Buffer: Pointer; Size: Integer);
 
begin
   
if BytesWritten + Size > BufferSize then
   
begin
     
BufferSize := Trunc(BufferSize * cDeltaSize);
     
if BufferSize <= (BytesWritten + Size) then
       
BufferSize := Trunc((BytesWritten + Size) * cDeltaSize);
     
SetLength(Result, BufferSize);
     
DestPChar := @Result[BytesWritten + 1];
   
end;
   
Inc(BytesWritten, Size);
   
FastCharMove(Buffer^, DestPChar^, Size);
   
DestPChar := DestPChar + Size;
 
end;
 
begin
 
Assert(Assigned(@FastTagReplaceProc));
 
TagStartPChar := PChar(TagStart);
 
TagEndPChar := PChar(TagEnd);
 
if (SourceString = '') or (TagStart = '') or (TagEnd = '') then
 
begin
   
Result := SourceString;
   
Exit;
 
end;
 
 
SourceStringPChar := PChar(SourceString);
 
TagStartLength := Length(TagStart);
 
TagEndLength := Length(TagEnd);
 
FinalSourceMarkerEnd := SourceStringPChar + Length(SourceString) - TagEndLength;
 
FinalSourceMarkerStart := FinalSourceMarkerEnd - TagStartLength;
 
 
BytesWritten := 0;
 
BufferSize := Length(SourceString);
 
SetLength(Result, BufferSize);
 
DestPChar := @Result[1];
 
  repeat
   
TagStartFindPos := AnsiStrPos(SourceStringPChar, TagStartPChar);
   
if (TagStartFindPos = nil) or (TagStartFindPos > FinalSourceMarkerStart) then Break;
   
TagEndFindPos := AnsiStrPos(TagStartFindPos + TagStartLength, TagEndPChar);
   
if (TagEndFindPos = nil) or (TagEndFindPos > FinalSourceMarkerEnd) then Break;
   
CopySize := TagStartFindPos - SourceStringPChar;
   
AddBuffer(SourceStringPChar, CopySize);
   
CopySize := TagEndFindPos - (TagStartFindPos + TagStartLength);
   
SetLength(ReplaceString, CopySize);
   
if CopySize > 0 then
     
Move((TagStartFindPos + TagStartLength)^, ReplaceString[1], CopySize);
   
FastTagReplaceProc(ReplaceString, UserData);
   
if Length(ReplaceString) > 0 then
     
AddBuffer(@ReplaceString[1], Length(ReplaceString));
   
SourceStringPChar := TagEndFindPos + TagEndLength;
 
until SourceStringPChar > FinalSourceMarkerStart;
 
CopySize := PChar(@SourceString[Length(SourceString)]) - (SourceStringPChar - 1);
 
if CopySize > 0 then
   
AddBuffer(SourceStringPChar, CopySize);
 
SetLength(Result, BytesWritten);
end;
 
function SmartPos(const SearchStr,SourceStr : string;
                 
const CaseSensitive : Boolean = TRUE;
                 
const StartPos : Integer = 1;
                 
const ForwardSearch : Boolean = TRUE) : Integer;
begin
 
// NOTE:  When using StartPos, the returned value is absolute!
 
if (CaseSensitive) then
   
if (ForwardSearch) then
     
Result:=
       
FastPos(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
   
else
     
Result:=
       
FastPosBack(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
 
else
   
if (ForwardSearch) then
     
Result:=
       
FastPosNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
   
else
     
Result:=
       
FastPosBackNoCase(SourceStr,SearchStr,Length(SourceStr),Length(SearchStr),StartPos)
end;
 
var
  I
: Integer;
initialization
 
{$IFNDEF LINUX}
   
for I:=0 to 255 do GUpcaseTable[I] := Chr(I);
   
CharUpperBuff(@GUpcaseTable[0], 256);
 
{$ELSE}
   
for I:=0 to 255 do GUpcaseTable[I] := UpCase(Chr(I));
 
{$ENDIF}
 
GUpcaseLUT := @GUpcaseTable[0];
end.
 
FastStringFuncs.pas
 
 
//==================================================
//All code herein is copyrighted by
//Peter Morris
//-----
//Do not alter / remove this copyright notice
//Email me at : support@droopyeyes.com
//
//The homepage for this library is http://www.droopyeyes.com
//
//(Check out www.HowToDoThings.com for Delphi articles !)
//(Check out www.stuckindoors.com if you need a free events page on your site !)
 
unit
FastStringFuncs;
 
interface
 
uses
 
{$IFDEF LINUX}
   
QGraphics,
 
{$ELSE}
   
Graphics,
 
{$ENDIF}
 
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,'&amp;','&', False);
 
Result := FastReplace(Result,'&lt;','<', False);
 
Result := FastReplace(Result,'&gt;','>', False);
 
Result := FastReplace(Result,'&quot;','"', 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.