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

Previous  Top  Next

    
 

 

 

FastStrings.pas

 

Code:

//==================================================

//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, '&nbsp;', ' ', 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.

 

 

 

 

©Drkb::00160