Справочные материалы, общие вопросы

Unix-строки (чтение и запись Unix-файлов)

2013-08-19T21:11:19+07:00

Code:

unit StreamFile;

interface

uses SysUtils;

procedure AssignStreamFile(var F: Text; Filename: string);

implementation

const

BufferSize = 128;

type

TStreamBuffer = array[1..High(Integer)] of Char;

TStreamBufferPointer = ^TStreamBuffer;

TStreamFileRecord = record

case Integer of

(

Filehandle: Integer;

Buffer: TStreamBufferPointer;

BufferOffset: Integer;

ReadCount: Integer;

);

(

Dummy: array[1..32] of Char

)

end;

function StreamFileOpen(var F: TTextRec): Integer;

var

Status: Integer;

begin

with TStreamFileRecord(F.UserData) do

begin

GetMem(Buffer, BufferSize);

case F.Mode of

fmInput:

FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone);

fmOutput:

FileHandle := FileCreate(StrPas(F.Name));

fmInOut:

begin

FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone or

fmOpenWrite or fmOpenRead);

if FileHandle <> -1then

status := FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }

F.Mode := fmOutput;

end;

BufferOffset := 0;

ReadCount := 0;

F.BufEnd := 0; { В этом месте подразумеваем что мы достигли конца файла (eof). }

if FileHandle = -1then

Result := -1

else

Result := 0;

end;

function StreamFileInOut(var F: TTextRec): Integer;

procedureRead(var Data: TStreamFileRecord);

procedure CopyData;

begin

while (F.BufEnd < Sizeof(F.Buffer) - 2)

and (Data.BufferOffset <= Data.ReadCount)

and (Data.Buffer[Data.BufferOffset] <> #10) do

begin

F.Buffer[F.BufEnd] := Data.Buffer^[Data.BufferOffset];

Inc(Data.BufferOffset);

Inc(F.BufEnd);

end;

if Data.Buffer[Data.BufferOffset] = #10then

begin

F.Buffer[F.BufEnd] := #13;

Inc(F.BufEnd);

F.Buffer[F.BufEnd] := #10;

Inc(F.BufEnd);

Inc(Data.BufferOffset);

end;

begin

F.BufEnd := 0;

F.BufPos := 0;

F.Buffer := '';

repeat

begin

if (Data.ReadCount = 0) or (Data.BufferOffset > Data.ReadCount) then

begin

Data.BufferOffset := 1;

Data.ReadCount := FileRead(Data.FileHandle, Data.Buffer^, BufferSize);

end;

CopyData;

enduntil (Data.ReadCount = 0)

or (F.BufEnd >= Sizeof(F.Buffer) - 2);

Result := 0;

end;

procedureWrite(var Data: TStreamFileRecord);

var

Status: Integer;

Destination: Integer;

II: Integer;

begin

with TStreamFileRecord(F.UserData) do

begin

Destination := 0;

for II := 0to F.BufPos - 1do

begin

if F.Buffer[II] <> #13then

begin

Inc(Destination);

Buffer^[Destination] := F.Buffer[II];

end;

Status := FileWrite(FileHandle, Buffer^, Destination);

F.BufPos := 0;

Result := 0;

end;

begin

case F.Mode of

fmInput:

Read(TStreamFileRecord(F.UserData));

fmOutput:

Write(TStreamFileRecord(F.UserData));

end;

function StreamFileFlush(var F: TTextRec): Integer;

begin

Result := 0;

end;

function StreamFileClose(var F: TTextRec): Integer;

begin

with TStreamFileRecord(F.UserData) do

begin

FreeMem(Buffer);

FileClose(FileHandle);

end;

Result := 0;

end;

procedure AssignStreamFile(var F: Text; Filename: string);

begin

with TTextRec(F) do

begin

Mode := fmClosed;

BufPtr := @Buffer;

BufSize := Sizeof(Buffer);

OpenFunc := @StreamFileOpen;

InOutFunc := @StreamFileInOut;

FlushFunc := @StreamFileFlush;

CloseFunc := @StreamFileClose;

StrPLCopy(Name, FileName, Sizeof(Name) - 1);

end;

end.

Взято из Советов по Delphi от Валентина Озерова

Сборник Kuliba

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

2013-08-19T21:12:13+07:00

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 https://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 = 0thenraise 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;

procedure MakeBMTableNoCase(Buffer: PChar; BufferLen: Integer; var JumpTable: TBMJumpTable);

begin

if BufferLen = 0thenraise 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;

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;

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;

//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 = 0then 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;

function FastCharPosNoCase(const aSource : string; C: Char; StartPos : Integer) : Integer;

var

L : Integer;

begin

Result := 0;

L := Length(aSource);

if L = 0then exit;

if StartPos > L then exit;

Dec(StartPos);

if StartPos < 0then 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;

//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 < 1thenbegin

Result := 0;

exit;

end;

if aFindLen > aSourceLen thenbegin

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 > 0then

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 < 1thenbegin

Result := 0;

exit;

end;

if aFindLen > aSourceLen thenbegin

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 > 0then

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 < 1thenbegin

Result := 0;

exit;

end;

if aFindLen > aSourceLen thenbegin

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;

function FastPosBackNoCase(const aSourceString, aFindString : string; const aSourceLen, aFindLen, StartPos : Integer) : Integer;

var

SourceLen : Integer;

begin

if aFindLen < 1thenbegin

Result := 0;

exit;

end;

if aFindLen > aSourceLen thenbegin

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;

//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

//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);

endelse

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 > 0then

ReplacePChar := @NewPattern[1]

else

ReplacePChar := nil;

//Replace routine

repeat

//Find the sub string

SourceStringPChar := AnsiStrPos(PrevSourceStringPChar,

FindPChar);

if SourceStringPChar = nilthen 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 > 0then

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 = 0thenbegin

Result := aSourceString;

exit;

end;

PSource := @aSourceString[1];

LFind := Length(aFindString);

if LFind = 0then 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 = 0thenbegin

LResult := Trunc((LSource + LReplace) * cDeltaSize);

SetLength(Result, LResult);

end;

PResult := @Result[1];

if CaseSensitive then

begin

MakeBMTable(PChar(AFindString), lFind, JumpTable);

Find := BMPos;

endelse

begin

MakeBMTableNoCase(PChar(AFindString), lFind, JumpTable);

Find := BMPosNoCase;

end;

BytesUsed := 0;

if LReplace > 0thenbegin

PReplace := @aReplaceString[1];

repeat

PPosition := Find(PSource,PFind,lSource, lFind, JumpTable);

if PPosition = nilthen break;

CopySize := PPosition - PSource;

Inc(BytesUsed, CopySize + LReplace);

if BytesUsed >= LResult thenbegin

//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;

endelsebegin

repeat

PPosition := Find(PSource,PFind,lSource, lFind, JumpTable);

if PPosition = nilthen 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 > 0then

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 > 0then

Move((TagStartFindPos + TagStartLength)^, ReplaceString[1], CopySize);

FastTagReplaceProc(ReplaceString, UserData);

if Length(ReplaceString) > 0then

AddBuffer(@ReplaceString[1], Length(ReplaceString));

SourceStringPChar := TagEndFindPos + TagEndLength;

until SourceStringPChar > FinalSourceMarkerStart;

CopySize := PChar(@SourceString[Length(SourceString)]) - (SourceStringPChar - 1);

if CopySize > 0then

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:=0to255do GUpcaseTable[I] := Chr(I);

CharUpperBuff(@GUpcaseTable[0], 256);

{$ELSE}

for I:=0to255do 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 https://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)) div3) * 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;

//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) div4) * 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 := 1to Length(S) do

begin

Result[I] := char(byte(S[I]) xor (Key shr8));

Key := (byte(Result[I]) + Key) * cKey1 + cKey2;

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=0then 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 := 1to Length(S) do

begin

Result[I] := char(byte(S[I]) xor (Key shr8));

Key := (byte(S[I]) + Key) * cKey1 + cKey2;

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 >0dobegin

Value := FastCharPosNoCase(cHexChars, aHex[Position], 1)-1;

if Value = -1then

raise Exception.Create('Invalid hex character ' + aHex[Position]);

Result := Result + (Value * Multiplier);

Multiplier := Multiplier * 16;

Dec(Position);

end;

//Get the left X amount of chars

function LeftStr(const aSourceString : string; Size : Integer) : string;

begin

if Size > Length(aSourceString) then

Result := aSourceString

elsebegin

SetLength(Result, Size);

Move(aSourceString[1],Result[1],Size);

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 = 0then

Result := (Value = Pattern)

else

begin

Result := (Copy(Value,1,Star1-1) = Copy(Pattern,1,Star1-1));

if Result then

begin

if Star1 > 1then Value := Copy(Value,Star1,Length(Value));

Pattern := Copy(Pattern,Star1+1,Length(Pattern));

NextPattern := Pattern;

Star2 := FastCharPos(NextPattern, '*',1);

if Star2 > 0then NextPattern := Copy(NextPattern,1,Star2-1);

//pos(NextPattern,Value);

NextPos := FastPos(Value, NextPattern, Length(Value), Length(NextPattern), 1);

if (NextPos = 0) andnot (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;

//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 = 0then 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 > 0thenbegin

BeforePos := FastPosBackNoCase(Source,BeforeText,AfterPos-1,lBeforeText,AfterPos - (lBeforeText-1));

if (BeforePos > 0) thenbegin

Result := Copy(Source,BeforePos + lBeforeText, AfterPos - (BeforePos + lBeforeText));

Break;

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) > 0then

Filename := Copy(Filename,1,Length(Filename)-Length(Ext));

repeat

Result := Path + RandomStr(32) + Ext;

untilnot FileExists(Result);

end;

//Makes a string of aLength filled with random characters

function RandomStr(aLength : Longint) : string;

var

X : Longint;

begin

if aLength <= 0then exit;

SetLength(Result, aLength);

for X:=1to aLength do

Result[X] := Chr(Random(26) + 65);

end;

function ReverseStr(const aSourceString: string): string;

var

L : Integer;

D : Pointer;

begin

L := Length(aSourceString);

SetLength(Result,L);

if L = 0then 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;

//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

elsebegin

SetLength(Result, Size);

FastCharMove(aSourceString[Length(aSourceString)-(Size-1)],Result[1],Size);

end;

//Converts a typical HTML RRGGBB color to a TColor

function RGBToColor(aRGB : string) : TColor;

begin

if Length(aRGB) < 6thenraise EConvertError.Create('Not a valid RGB value');

if aRGB[1] = '#'then aRGB := Copy(aRGB,2,Length(aRGB));

if Length(aRGB) <> 6thenraise EConvertError.Create('Not a valid RGB value');

Result := HexToInt(aRGB);

asm

mov EAX, Result

BSwap EAX

shr EAX, 8

mov Result, EAX

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 = nilthen Result := TStringList.Create;

Result.Clear;

S := '';

for X:=1to Length(aValue) dobegin

if aValue[X] <> aDelimiter then

S:=S + aValue[X]

elsebegin

Result.Add(S);

S := '';

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 = 0then exit;

LFind := Length(aFindString);

if LFind = 0then exit;

if CaseSensitive then

begin

Next := BMPos;

MakeBMTable(PChar(aFindString), Length(aFindString), JumpTable);

endelse

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 <> nilthen

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 := 1to 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 = 936then Break; {26 * 6 * 6}

Multiple := Multiple * 6;

LastChar := SoundexGroup;

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) = 0then Exit;

ResChar := @Result[1];

SrcChar := @S[1];

for X:=1to Length(S) do

begin

case SrcChar^ of

'<':

begin

Inc(TagCnt);

if WantHTML and (TagCnt = 1) then

begin

ResChar^ := '<';

Inc(ResChar);

end;

'>':

begin

Dec(TagCnt);

if WantHTML and (TagCnt = 0) then

begin

ResChar^ := '>';

Inc(ResChar);

end;

else

case WantHTML of

False:

if TagCnt <= 0then

begin

ResChar^ := SrcChar^;

Inc(ResChar);

TagCnt := 0;

end;

True:

if TagCnt >= 1then

begin

ResChar^ := SrcChar^;

Inc(ResChar);

endelse

if TagCnt < 0then TagCnt := 0;

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) thenbegin

Path := ExtractFilepath(aFilename);

Ext := ExtractFileExt(aFilename);

Filename := ExtractFilename(aFilename);

if Length(Ext) > 0then

Filename := Copy(Filename,1,Length(Filename)-Length(Ext));

Index := 2;

repeat

Result := Path + Filename + IntToStr(Index) + Ext;

Inc(Index);

untilnot FileExists(Result);

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) dobegin

if aValue[X] <> '%'then

Result := Result + aValue[X]

elsebegin

Result := Result + Chr( HexToInt( Copy(aValue,X+1,2) ) );

Inc(X,2);

end;

Inc(X);

end;

//Returns the whole word at a position

function WordAt(Text : string; Position : Integer) : string;

var

X : Integer;

begin

Result := '';

L := Length(Text);

if (Position > L) or (Position < 1) then Exit;

for X:=Position to L dobegin

if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then

Result := Result + Text[X]

else

Break;

end;

for X:=Position-1downto1dobegin

if Upcase(Text[X]) in ['A'..'Z','0'..'9'] then

Result := Text[X] + Result

else

Break;

end;

end.

Добавление функций проверки орфографии

2013-08-19T21:15:35+07:00

Предположим, что в вашу задачу, как разработчика программного обеспечения, входит создание некоторого специализированного текстового процессора. Не вдаваясь в рассуждения о необходимости создания еще одного приложения подобного рода, мы просто рассмотрим один прием, который придаст вашей разработке весьма ощутимое преимущество по сравнению с аналогами. К примеру, вам необходимо создать некий HTML-редактор. Как и в случае с любым другим приложением такого типа, ваша программа должна будет обладать функциями орфографической проверки текста. Естественно, можно потратить много времени на создание своего собственного шедевра в данной области, но почему бы нам не воспользоваться уже готовыми решениями? В рамках данной статьи я бы хотел поговорить о технологии использования в ваших приложениях механизмов проверки орфографии, входящих в состав всем известного приложения - Microsoft Word с использованием автоматизации (OLE Automation).

OLE Automation

Идея, заложенная в автоматизацию, включает разработку приложений, функциональность которых может быть доступна и другим программам, а также создание приложений, которые "знают", как использовать функциональность, предоставляемую вам другими программными продуктами. Если говорить техническим языком, приложение, которое предоставляет некоторую повторно используемую функциональность, называется сервером автоматизации (automation server) (также часто называемым сервером COM). Приложение же, использующее функциональность, предоставляемую сервером автоматизации, называется клиентом автоматизации (automation client), также часто называемым контроллером автоматизации. Важно подчеркнуть, что сервер автоматизации может не быть "чистым" сервером автоматизации, так же как и клиент автоматизации может не быть "чистым" клиентом автоматизации. В действительности сервер автоматизации может использовать сервисы другого приложения, которое также является сервером автоматизации. Клиент автоматизации, предоставляющий свои сервисы другому клиенту, также может являться как клиентом, так и сервером автоматизации. Глубинные механизмы (сетевые и транспортные протоколы), с помощью которых клиент автоматизации взаимодействует с сервером, уже являются частью собственно COM.

Сервер автоматизации - это просто двоичный исполняемый модуль, который может состоять из нескольких объектов автоматизации. Объект автоматизации (также называемый объектом COM, хотя технически объект автоматизации является объектом COM особого сорта) - это отдельный, самодостаточный объект, спроектированный для выполнения специфической задачи или функции. В общем, все объекты автоматизации, собранные в одном сервере, предназначены для осуществления каких-то функциональных возможностей. Например, Microsoft Excel является сервером автоматизации, состоящим из нескольких меньших серверов автоматизации (Workbook - книга, Chart - диаграмма, Worksheet - лист, Range - диапазон и т.д.), каждый из которых определяет часть функций, предоставляемых пользователю Microsoft Excel. Идея заключается в том, что сервер автоматизации "позволяет" своим клиентам получать доступ и использовать свои объекты так же легко и просто, как будто это его внутренние объекты.

Для решения задачи, поставленной перед нами в начале данной статьи, мы можем воспользоваться теми возможностями, которые предоставляет нам сервер автоматизации Microsoft Word. C помощью приложения, разработанного в Borland Delphi (программа будет выступать в качестве клиента автоматизации), мы сможем динамически создать новый документ и поместить в него некоторый текст (который и будем проверять). После этого нам останется лишь с помощью MS Word осуществить эту проверку. Если приложение Word будет минимизировано, то пользователи могут и не почувствовать, что выполнение части функций нашего приложения берет на себя другая программа. Обращаю внимание, что для полноценного использования OLE-автоматизации вам надо будет знать как можно больше о возможностях и интерфейсах того приложения, функциональностью которого вы решили воспользоваться. Кроме того, для корректного выполнения всех функций разрабатываемого приложения необходимо, чтобы на компьютере пользователя было установлено соответствующее приложение. В нашем случае - Microsoft Word.

Основные принципы работы

Существует три основных метода использования OLE-автоматизации в Borland Delphi в зависимости от того, какую версию этой среды разработки вы используете.

Delphi 5. Закладка Servers на палитре компонентов.

Если вы являетесь счастливым обладателем этой версии Delphi, то для работы с Microsoft Word можно воспользоваться компонентами, расположенными на закладке Ser-vers (рис. 1). Такие компоненты, как TWord-Application и TWordDocument, предоставляют все необходимые для работы интерфейсы.

Delphi 3, 4. Раннее связывание.

Используя термины автоматизации, для обеспечения в Delphi доступа к методам и свойствам, предоставляемым MS Word, необходимо установить соответствующую библиотеку типов. Библиотека типов предоставляет информацию обо всех свойствах и методах, которые разработчик может использовать при работе с сервером автоматизации. Для использования библиотеки типов Microsoft Word в Delphi (3 или 4 версии) необходимо произвести следующие несложные действия:

выбрать пункт меню Project|Import Type Library;

в открывшемся диалоге найти файл msword8.olb (для Microsoft Office'2000 этот файл будет иметь название msword9.olb), расположенный в подкаталоге "Office" того каталога, в который был установлен Microsoft Office.

После этого будет создан файл с именем word_TLB.pas, в котором в синтаксисе object pascal будут описаны константы, типы, свойства и методы для доступа к серверу автоматизации Microsoft Word. Файл word_TLB.pas должен быть включен в список uses всех модулей, в которых вы планируете использовать функции Microsoft Word. Такая технология работы с серверами автоматизации называется ранним связыванием. Одним из преимуществ раннего связывания является осуществление контроля вызовов и передаваемых параметров на этапе компиляции.

Delphi 2. Позднее связывание.

Для доступа к объектам MS Word без применения библиотеки типов можно использовать так называемое позднее связывание. В данном случае доступ к Word осуществляется так же, как к переменной типа Variant, следствием чего является необходимость знания вами всех предоставляемых сервером автоматизации интерфейсов. Позднего связывания следует по возможности избегать, поскольку при этом отсутствует возможность контроля корректности вызовов процедур и функций со стороны компилятора, и если вы неправильно написали имя того или иного метода, то узнаете об этом, только, когда программа "вывалится" по ошибке в процессе выполнения.

Начнем!

Итак, вернемся к теме статьи. Для демонстрации принципов работы с MS Word я буду использовать механизмы, предоставляемые пятой версией Delphi (т.е. компоненты TWordApplication, TWordDocument). Ниже я приведу код, обеспечивающий соединение и работу с MS Word в случае использования библиотеки типов и позднего связывания и больше не буду касаться этой темы.

Для доступа к объектам Word при работе в Delphi 3, 4 (запуск приложения и создание нового документа) используйте следующий код:

Code:

uses

Word_TLB;

...

var

WordApp: _Application;

WordDoc: _Document;

VarFalse: OleVariant;

begin

WordApp := CoApplication.Create;

WordDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);

{

код для проверки орфографии, описываемы далее в данной статье

}

VarFalse:=False;

WordApp.Quit(VarFalse, EmptyParam, EmptyParam);

end;

Обращаю внимание, что в методах MS Word множество параметров описаны как необязательные (optional). При использовании интерфейсов (библиотек типов), Delphi не позволит вам опускать те или иные параметры, даже если в контексте разрабатываемого вами кода они не нужны. В четвертой версии Delphi в модуле system.pas описана переменная EmptyParam, которую можно использовать в качестве "заглушки" для неиспользуемых переменных в вызываемом методе.

Для автоматизации MS Word с использованием переменной Variant (позднее связывание) используйте следующий код:

Code:

uses

ComObj;

...

var

WordApp, WordDoc: Variant;

begin

WordApp := CreateOleObject('Word.Application');

WordDoc := WordApp.Documents.Add;

{

код для проверки орфографии, описываемы далее в данной статье

}

WordApp.Quit(False)

end;

При использовании позднего связывания компилятор Delphi позволяет вам опускать те или иные параметры при вызове методов сервера автоматизации.

Как уже упоминалось, Delphi 5 упрощает программисту использование функциональности MS Word в своих приложениях путем предоставления его методов и свойств в виде компонентов. Так как множество параметров, определенных в методах Word'а, описаны как необязательные, то в Delphi данные процедуры и функции переопределены и представляют собой набор из нескольких методов с различным количеством параметров. Таким образом, разработчику предоставляется возможность при вызове метода не указывать последние n параметров, необходимость в которых отсутствует.

Шаг за шагом

Для создания своего редактора с возможностью проверки орфографии в минимальном варианте нам понадобится две формы: одна будет использоваться для редактирования текста, а вторая - для отображения диалога правки найденных ошибок. Однако предлагаю начать с самого начала.

Если у вас не запущен Delphi - запустите его. Создайте новый проект (если он не был создан при открытии приложения). По умолчанию проект будет содержать одну форму. Данная форма будет главной в нашем проекте. Поместите на форму один компонент типа TMemo и две кнопки (TButton). Заполните свойство Lines компонента Memo1 каким-нибудь текстом (содержащим ошибки). Заголовок одной кнопки определите как "Орфография", а второй - "Тезаурус". Затем перейдите на закладку Servers палитры компонентов и поместите на форму по одному компоненту типа TWordApplication и TWordDocument (рис. 2). Установите значения свойства Name первого компонента в Word-App, а второго - WordDoc.

TWordApplication, TWordDocument

При автоматизации MS Word для управления приложением, отображения его рабочего окна, получения доступа к атрибутам и объектной модели MS Word мы используем объект Application. Для того чтобы указать приложению, запускать ли новую копию процесса Word или использовать уже запущенный, применяется свойство Applicati-on.ConnectKind. В нашем случае мы устанавливаем данное свойство в значение ckRunningInstance. Другие возможные значения этого свойства вы сможете узнать, воспользовавшись справочной системой Delphi.

Когда мы открываем в MS Word существующий файл или создаем новый, мы тем самым создаем объект Document. Типичной задачей при использовании автоматизации Word является работа с некоторой областью документа: добавление текста, выделение некоторой области, проверка орфографии и т.д. Объект, определяющий некоторую область в документе, называется Range.

Естественно, в рамках статьи я не смогу подробно рассказать обо всех нюансах работы с компонентами, расположенными на закладке Servers палитры компонентов (кстати, с любой другой закладкой ситуация состоит ничуть не лучше). Для более детального их изучения предлагаю воспользоваться справочной системой Borland Delphi. В нашем же сегодняшнем разговоре я буду упоминать только те свойства и методы, которые будут необходимы.

Как это все будет работать

Алгоритм работы нашего приложения будет достаточно прост. Каждое слово, входящее в состав проверяемого нами текста, будет передаваться в MS Word для проверки. Сервер автоматизации Word содержит метод SpellingErrors, который позволяет вам осуществлять проверку текста, входящего в состав некоторой области Range. Мы же будем каждый раз определять эту область таким образом, чтобы она содержала только переданное нами в Word слово. Метод SpellingErrors в качестве результата своей работы возвращает коллекцию слов, написание которых признано ошибочным. Если эта коллекция пуста, то мы переходим к рассмотрению следующего слова. Иначе - переходим к процедуре замены неправильно напечатанного слова. Путем вызова метода GetSpellingSuggestions можно получить список слов, предлагаемых в качестве замены. Эти слова помещаются в коллекцию SpellingSuggestions. Данную коллекцию мы помещаем в качестве списка (компонент типа TListBox), расположенного во второй форме нашего проекта. Думаю, самое время немного поговорить о ней.

Для того чтобы добавить новую форму в проект, следует выбрать пункт меню File|New Form. Назовем эту форму frSpellCheck. На форму поместим три кнопки типа TBitBtn, два элемента редактирования (TEdit) и один список (TListBox). На форму также следует поместить три метки (см. рис. 3). Компонент edNID (editNotInDictionary) служит для отображения заменяемого слова. edReplaceWith содержит выделенный в данный момент вариант для замены, а список lbSuggestions - список предлагаемых вариантов (заполняемый на основании данных, содержащихся в коллекции SpellingSuggestions). Три кнопки выполняют именно те функции, которым соответствуют их заголовки - не больше и не меньше. Каждой из кнопок соответствует свое значение, возвращаемое функцией frSpellCheck.ModalResult. В зависимости от этого значения в основной обрабатывающей процедуре осуществляется то или иное действие - игнорирование, замена или отмена дальнейшей проверки. Форма frSpellCheck содержит одно общедоступное свойство:

sReplacedWord :String

Оно служит для передачи в основную форму слова для замены в случае нажатия пользователем кнопки "Заменить".

Пишем код!

Ниже приводится код основной процедуры приложения.

Code:

procedure TForm1.btnSpellCheckClick(Sender: TObject);

var

colSpellErrors : ProofreadingErrors;

colSuggestions : SpellingSuggestions;

i : Integer;

StopLoop : Boolean;

itxtLen, itxtStart : Integer;

varFalse : OleVariant;

begin

WordApp.Connect;

WordDoc.ConnectTo(WordApp.Docum-ents.Add(EmptyParam, EmptyParam));

StopLoop:=False;

itxtStart:=0;

Memo.SelStart:=0;

itxtlen:=0;

whilenot StopLoop do

begin

itxtStart := itxtLen + itxtStart;

itxtLen := Pos(' ', Copy(Memo.Text,itxtStart+1,MaxInt));

if itxtLen = 0then

StopLoop := True;

Memo.SelStart := itxtStart;

Memo.SelLength := -1 + itxtLen;

if Memo.SelText = ''then

Continue;

Caption:=Memo.SelText;

WordDoc.Range.Delete(EmptyParam,Emp-tyParam);

WordDoc.Range.Set_Text(Memo.SelText);

colSpellErrors := WordDoc.SpellingErrors;

if colSpellErrors.Count <> 0then

begin

colSuggestions := WordApp.GetSpellingSuggestions

(colSpellErrors.Item(1).Get_Text);

with frSpellCheck do

begin

edNID.text := colSpellErrors.Item(1).Get_Text;

lbSuggestions.Items.Clear;

for i:= 1to colSuggestions.Count do

lbSuggestions.Items.Add(VarToStr-(colSuggestions.Item(i)));

lbSuggestions.ItemIndex := 0;

lbSuggestionsClick(Sender);

ShowModal;

case frSpellCheck.ModalResult of

mrAbort: Break;

mrIgnore: Continue;

mrOK:

if sReplacedWord <> ''then

begin

Memo.SelText := sReplacedWord;

itxtLen := Length(sReplacedWord);

end;

WordDoc.Disconnect;

varFalse:=False;

WordApp.Quit(varFalse);

Memo.SelStart := 0;

Memo.SelLength := 0;

end;

Обработчики событий нажатий на кнопки формы frSpellCheck и список слов, предлагаемых для замены:

Code:

procedure TfrSpellCheck.lbSuggestionsClick(Sen-der: TObject);

begin

if lbSuggestions.ItemIndex <> -1then

edReplaceWith.Text := lbSuggestions.Items[lbSuggestio-ns.ItemIndex]

else

edReplaceWith.Text := '';

end;

procedure TfrSpellCheck.btnChangeClick(Sender: TObject);

begin

sReplacedWord := edReplaceWith.Text;

end;

procedure TfrSpellCheck.btnIgnoreClick(Sender: TObject);

begin

sReplacedWord := '';

end;

Тезаурус

Теперь рассмотрим вопрос добавления в нашу программу функций тезауруса. Делается это достаточно просто:

Code:

procedure TForm1.btnThesaurusClick(Sender: TObject);

var

varFalse : OleVariant;

begin

if Memo.SelText <> ''then

begin

WordApp.Connect;

WordDoc.ConnectTo(WordApp.Documen-ts.Add(EmptyParam, EmptyParam));

WordDoc.Range.Delete(EmptyParam,Empty-Param);

WordDoc.Range.Set_Text(Memo.SelText);

WordDoc.Range.CheckSynonyms;

Memo.SelText := WordDoc.Range.Get_Text;

WordDoc.Disconnect;

varFalse:=False;

WordApp.Quit(varFalse);

end;

Тестирование

В тексте, помещенном в компонент Memo, мною было сознательно сделано несколько ошибок, которые вы сможете увидеть, приглядевшись к изображению, представленному на рисунке 1. В частности, вместо слова "своих" я написал "свиох", вместо "путем" - "пуетм", а вместо "виде" - "виед". Как же повела себя программа? На следующих рисунках (рисунки 4-6) можно видеть, что проверка текста действительно работает.

Надеюсь, вы понимаете, что в рамках одной статьи невозможно описать все те возможности, которые открываются перед разработчиком программного обеспечения в случае использования серверов автоматизации. И речь идет не только о Microsoft Word, но и о других приложениях (к примеру, широко распространено применение MS Excel в качестве базы для построения отчетов). Все разнообразие данного направления программирования можно познать, на мой взгляд, только через собственный опыт. Так что удачного вам кода!

https://delphiworld.narod

DelphiWorld 6.0

Как хранятся строки?

2013-08-19T21:10:25+07:00

Тип String:

по смещению -4 храниться длина строки

по смещению -8 храниться счётчик ссылок на строку (когда он обнуляется строка уничтожается)

Сама строка располагается в памяти как есть - каждая буква занимает 1 байт.

При копировании строки:

s1:=s2 - реального копирования не происходит, увеличивается только счётчик ссылок, но если после этого изменить одну из строк:

s1:=s1+'a';

то произойдёт физическое копирование содержимого строк, и теперь s1 и s2 будут показывать на разные адреса памяти.

PChar - длина строки определяется от начала до #0 байта, по сути это чистой воды pointer, так что все действия по отслеживанию распределения памяти лежат на программисте - сами заботьтесь о том чтобы хватило места для распределения памяти и освобождении после использования. Тоже одна буква = 1 байт Для хранения unicode (т.е. 2х байтовых символов) используйте соответствующие символы с приставкой Wide...

Автор:Vit

Примечание Fantasist'a:

Это верно только если s1 - локальная переменная, или s1 и s2 - обе не локальные. Если s1 не локальная(глобальная или член класса), а s2 - локальная происходит копирование.

Взято с Vingrad.ruhttps://forum.vingrad

Небольшой модуль для работы со строками

2013-08-19T21:12:59+07:00

Code:

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Небольшой модуль для работы со строками

function CompMask(S, Mask: string):string; //выбор строки по маске

// удаление из строки count символов начиная с posit

function deleteStr(s:string;posit,count:integer):string;

//Удаление из строки s сначала first и с конца last символов

function deleteFaskaStr(s:string; first,last:integer):string;

Запись в стринлист strg всех вхождений по маске mask из строки source

procedure getStrings(var strg: TStringList; mask,source: string);

Зависимости: classes,sysutils

Автор: SuMaga, sumaga@mail.ru, ICQ:721602488, Махачкала

Дата: 24 января 2003 г.

***************************************************** }

unit StrMask;

interface

uses classes, sysutils;

function CompMask(S, Mask: string): string;

function deleteStr(s: string; posit, count: integer): string;

function deleteFaskaStr(s: string; first, last: integer): string;

procedure getStrings(var strg: TStringList; mask, source: string);

implementation

type

TmaskObj = class

constructor open;

public

Maschr: tstringlist;

Masposish: TStringList;

destructor close;

end;

procedure getStrings(var strg: TStringList; mask, source: string);

var

s, s2: string;

begin

s2 := source;

s := CompMask(s2, mask);

while s <> ''do

begin

strg.Add(s);

s2 := StringReplace(s2, s, '', []);

s := CompMask(s2, mask);

if pos(s, s2) = 0then

break;

end;

function eraseMask(inpstr: TStrings): TStrings;

var

i: integer;

e: boolean;

begin

e := false;

for i := 0to inpstr.Count - 1do

if (i <> inpstr.Count - 1) and (i < inpstr.Count - 1) then

if ((inpstr[i] = '`') and (inpstr[i + 1] = '|')) or

((inpstr[i] = '|') and (inpstr[i + 1] = '`')) or

((inpstr[i] = '`') and (inpstr[i + 1] = '`')) then

begin

e := true;

end;

if (e = false) or (i <= inpstr.Count - 1) then

begin

Result := inpstr;

exit;

end;

for i := 0to inpstr.Count - 1do

if (i <> inpstr.Count - 1) and (i < inpstr.Count - 1) then

if ((inpstr[i] = '`') and (inpstr[i + 1] = '|')) or

((inpstr[i] = '`') and (inpstr[i + 1] = '`')) or

((inpstr[i] = '|') and (inpstr[i + 1] = '`')) then

begin

inpstr.Delete(i + 1);

inpstr[i] := '`';

end;

Result := eraseMask(inpstr);

end;

{

`<---- Эквивалентна----->*

|<---- Эквивалентна----->?

}

function SplitMask(mask: string; MaskList: TStringList): TStringList;

var

i, j, k: integer;

s1: string;

mch: TmaskObj;

begin

mch := TmaskObj.open;

for i := 1to length(Mask) do

begin

if Mask[i] = '`'then

begin

mch.Maschr.Add('`');

mch.Masposish.Add(inttostr(i))

end;

if Mask[i] = '|'then

begin

mch.Maschr.Add('|');

mch.Masposish.Add(inttostr(i))

end;

k := 0;

for i := 0to mch.Maschr.Count - 1do

begin

j := strtoint(mch.Masposish.Strings[i]) - k;

if j - 1 <> 0then

s1 := copy(Mask, 1, j - 1)

else

s1 := '';

delete(Mask, 1, j);

k := length(s1) + 1 + k;

if (s1 <> mch.Maschr.Strings[i]) and (length(s1) <> 0) then

MaskList.Add(s1);

MaskList.Add(mch.Maschr.Strings[i]);

end;

if Mask <> ''then

MaskList.Add(Mask);

mch.close;

Result := TStringList(eraseMask(MaskList));

end;

function deleteStr(s: string; posit, count: integer): string;

begin

Delete(s, posit, count);

Result := s;

end;

function deleteFaskaStr(s: string; first, last: integer): string;

begin

result := deleteStr(s, 1, first);

result := deleteStr(Result, length(Result) - last + 1, length(Result) -

(length(Result) - last));

end;

function CompMask(S, Mask: string): string;

var

i, j, k, y: integer;

s1, s2, s3, s4, s5: string;

MaskList: TStringList;

PrPos: integer;

var

fm: boolean;

label

1, 2, 3;

begin

if length(s) = 0then

exit;

if length(Mask) = 0then

exit;

if length(s) < length(Mask) then

exit;

//if Assigned(MaskList) then

begin

MaskList := TStringList.Create;

MaskList := SplitMask(Mask, MaskList);

end;

PrPos := 0;

s4 := s;

fm := false;

s3 := '';

i := 0;

result := '';

if MaskList.Count - 1 = 0then

begin

if (MaskList[0] = '`') then

begin

s3 := s;

fm := true;

end;

if (MaskList[0] = '|') then

begin

s3 := s[1];

fm := true;

result := s3;

exit;

end;

if (MaskList[0] <> '`') and (MaskList[0] <> '|') then

begin

if pos(MaskList[0], s) = 0then

exit;

s3 := copy(s, pos(MaskList[0], s), length(MaskList[0]));

fm := true;

end;

i := MaskList.Count + 1;

end;

//Начало цикла

while i <= MaskList.Count - 1do

begin

if (MaskList[i] = '`') and (PrPos = 0) and (i + 1 <= MaskList.Count - 1)

then

begin

if pos(MaskList[i + 1], s) = 0then

goto2;

j := pos(MaskList[i + 1], s) + length(MaskList[i + 1]) - 1;

s3 := copy(s, 1, j);

delete(s, 1, j);

fm := true;

PrPos := j;

i := i + 1;

goto1;

end;

if (MaskList[i] = '|') and (PrPos = 0) and (i + 1 <= MaskList.Count - 1)

then

begin

k := i;

y := 0;

if i + 1 <= MaskList.Count - 1then

while (MaskList[k] = '|') do

begin

k := k + 1;

y := y + 1;

if k >= MaskList.Count - 1then

break;

end;

if pos(MaskList[k], s) = 0then

goto2;

j := pos(MaskList[k], s);

s3 := copy(s, j - y, length(MaskList[k]) + y);

delete(s, 1, j + length(MaskList[k]) - 1);

fm := true;

PrPos := j - 1;

i := k;

goto1;

end;

if (PrPos = 0) and (MaskList[i] <> '|') and (MaskList[i] <> '`') then

begin

if pos(MaskList[i], s) = 0then

break;

j := pos(MaskList[i], s);

s3 := copy(s, j, length(MaskList[i]));

delete(s, 1, j + length(MaskList[i]) - 1);

fm := true;

PrPos := length(MaskList[i]);

goto1;

end;

fm := false;

if (PrPos <> 0) and (i < MaskList.Count - 1) then

begin

if (MaskList[i] = '`') then

begin

if pos(MaskList[i + 1], s) = 0then

goto2;

j := pos(MaskList[i + 1], s);

s3 := s3 + copy(s, 1, j + length(MaskList[i + 1]) - 1);

fm := true;

delete(s, 1, j + length(MaskList[i + 1]) - 1);

PrPos := j + length(MaskList[i + 1]);

i := i + 1;

goto1;

end;

if (MaskList[i] = '|') then

begin

if i + 1 <= MaskList.Count - 1then

if MaskList[i + 1] <> '|'then

begin

if pos(MaskList[i + 1], s) > 2then

begin

//break;

goto2;

end;

s3 := s3 + copy(s, 1, length(MaskList[i + 1]) + 1);

delete(s, 1, length(MaskList[i + 1]) + 1);

fm := true;

i := i + 1;

goto1;

end;

s3 := s3 + copy(s, 1, 1);

delete(s, 1, 1);

fm := true;

PrPos := 1;

end;

if (MaskList[i] <> '`') and (MaskList[i] <> '|') then

begin

if pos(MaskList[i], s) = 0then

goto2;

j := pos(MaskList[i], s);

s3 := s3 + copy(s, j, length(MaskList[i]));

delete(s, 1, j + length(MaskList[i]) - 1);

fm := true;

PrPos := length(MaskList[i]);

fm := true

end;

if (PrPos <> 0) and (i = MaskList.Count - 1) then

begin

if (MaskList[i] = '`') then

begin

s3 := s3 + s;

s := '';

fm := true;

PrPos := j;

end;

if (MaskList[i] = '|') then

begin

s3 := s3 + copy(s, 1, 1);

delete(s, 1, 1);

fm := true;

PrPos := 1;

end;

if (MaskList[i] <> '`') and (MaskList[i] <> '|') then

begin

if pos(MaskList[i], s) <> 0then

j := pos(MaskList[i], s) + length(MaskList[i]) - 1

else

goto2;

s3 := s3 + copy(s, 1, j);

delete(s, 1, j);

fm := true;

PrPos := j + length(s3);

end;

1: inc(i);

end;

s5 := s3;

if s3 <> ''then

for i := 0to MaskList.Count - 1do

if (MaskList[i] <> '`') and (MaskList[i] <> '|') then

begin

if pos(MaskList[i], s3) = 0then

goto2;

s3 := StringReplace(s3, MaskList[i], '', []);

end;

s3 := s5;

MaskList.Free;

if fm then

begin

result := s3;

end

{

{result:='';

else

if length(s)>=length(Mask) then

result:=CompMask(s,Mask)

else Result:='';}

end;

destructor TmaskObj.close;

begin

Maschr.free;

Masposish.free;

end;

constructor TmaskObj.open;

begin

Maschr := TStringList.Create;

Masposish := TStringList.Create;

end;

end.

Пример использования:

s := 'asd r';

s := CompMask(s, 'd |');

//в результате s='d r';

Расширенные строковые функции

2013-08-19T21:14:28+07:00

LTrim() - Удаляем все пробелы в левой части строки

RTrim() - Удаляем все пробелы в правой части строки

Trim() - Удаляем все пробелы по краям строки

RightStr() - Возвращаем правую часть стоки заданной длины

LeftStr() - Возвращаем левую часть стоки заданной длины

MidStr() - Возвращаем центральную часть строки

squish() - возвращает строку со всеми белыми пробелами и с удаленными повторяющимися апострофами.

before() - возвращает часть стоки, находящейся перед первой найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает Search.

after() - возвращает часть строки, находящейся после первой найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает NULL.

RPos() - возвращает первый символ последней найденной подстроки Find в строке Search. Если Find не найдена, функция возвращает 0. Подобна реверсированной Pos().

inside() - возвращает подстроку, вложенную между парой подстрок Front ... Back.

leftside() - возвращает левую часть "отстатка" inside() или Search.

rightside() - возвращает правую часть "остатка" inside() или Null.

trim() - возвращает строку со всеми удаленными по краям белыми пробелами.

Code:

unit TrimStr;

{$B-}

{

Файл: TrimStr

Автор: Bob Swart [100434,2072]

Описание: программы для удаления конечных/начальных пробелов

и левых/правых частей строк (аналог Basic-функций).

Версия: 2.0

LTrim() - Удаляем все пробелы в левой части строки

RTrim() - Удаляем все пробелы в правой части строки

Trim() - Удаляем все пробелы по краям строки

RightStr() - Возвращаем правую часть стоки заданной длины

LeftStr() - Возвращаем левую часть стоки заданной длины

MidStr() - Возвращаем центральную часть строки

}

interface

const

Space = #$20;

function LTrim(const Str: string): string;

function RTrim(Str: string): string;

function Trim(Str: string): string;

function RightStr(const Str: string; Size: Word): string;

function LeftStr(const Str: string; Size: Word): string;

function MidStr(const Str: string; Size: Word): string;

implementation

function LTrim(const Str: string): string;

var

len: Byte absolute Str;

i: Integer;

begin

i := 1;

while (i <= len) and (Str[i] = Space) do

Inc(i);

LTrim := Copy(Str, i, len)

end{LTrim};

function RTrim(Str: string): string;

var

len: Byte absolute Str;

begin

while (Str[len] = Space) do

Dec(len);

RTrim := Str

end{RTrim};

function Trim(Str: string): string;

begin

Trim := LTrim(RTrim(Str))

end{Trim};

function RightStr(const Str: string; Size: Word): string;

var

len: Byte absolute Str;

begin

if Size > len then

Size := len;

RightStr := Copy(Str, len - Size + 1, Size)

end{RightStr};

function LeftStr(const Str: string; Size: Word): string;

begin

LeftStr := Copy(Str, 1, Size)

end{LeftStr};

function MidStr(const Str: string; Size: Word): string;

var

len: Byte absolute Str;

begin

if Size > len then

Size := len;

MidStr := Copy(Str, ((len - Size) div2) + 1, Size)

end{MidStr};

end.

// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

const

BlackSpace = [#33..#126];

{

squish() возвращает строку со всеми белыми пробелами и с удаленными

повторяющимися апострофами.

}

function squish(const Search: string): string;

var

Index: byte;

InString: boolean;

begin

InString := False;

Result := '';

forIndex := 1to Length(Search) do

begin

if InString or (Search[Index] in BlackSpace) then

AppendStr(Result, Search[Index]);

InString := ((Search[Index] = '''') and (Search[Index - 1] <> '\'))

xor InString;

end;

{

before() возвращает часть стоки, находящейся перед

первой найденной подстроки Find в строке Search. Если

Find не найдена, функция возвращает Search.

}

function before(const Search, Find: string): string;

var

index: byte;

begin

index := Pos(Find, Search);

ifindex = 0then

Result := Search

else

Result := Copy(Search, 1, index - 1);

end;

{

after() возвращает часть строки, находящейся после

первой найденной подстроки Find в строке Search. Если

Find не найдена, функция возвращает NULL.

}

function after(const Search, Find: string): string;

var

index: byte;

begin

index := Pos(Find, Search);

ifindex = 0then

Result := ''

else

Result := Copy(Search, index + Length(Find), 255);

end;

{

RPos() возвращает первый символ последней найденной

подстроки Find в строке Search. Если Find не найдена,

функция возвращает 0. Подобна реверсированной Pos().

}

function RPos(const Find, Search: string): byte;

var

FindPtr, SearchPtr, TempPtr: PChar;

begin

FindPtr := StrAlloc(Length(Find) + 1);

SearchPtr := StrAlloc(Length(Search) + 1);

StrPCopy(FindPtr, Find);

StrPCopy(SearchPtr, Search);

Result := 0;

repeat

TempPtr := StrRScan(SearchPtr, FindPtr^);

if TempPtr <> nilthen

if (StrLComp(TempPtr, FindPtr, Length(Find)) = 0) then

begin

Result := TempPtr - SearchPtr + 1;

TempPtr := nil;

end

else

TempPtr := #0;

until TempPtr = nil;

end;

{

inside() возвращает подстроку, вложенную между парой

подстрок Front ... Back.

}

function inside(const Search, Front, Back: string): string;

var

Index, Len: byte;

begin

Index := RPos(Front, before(Search, Back));

Len := Pos(Back, Search);

if (Index > 0) and (Len > 0) then

Result := Copy(Search, Index + 1, Len - (Index + 1))

else

Result := '';

end;

{

leftside() возвращает левую часть "отстатка" inside() или Search.

}

function leftside(const Search, Front, Back: string): string;

begin

Result := before(Search, Front + inside(Search, Front, Back) + Back);

end;

{

rightside() возвращает правую часть "остатка" inside() или Null.

}

function rightside(const Search, Front, Back: string): string;

begin

Result := after(Search, Front + inside(Search, Front, Back) + Back);

end;

{

trim() возвращает строку со всеми удаленными по краям белыми пробелами.

}

function trim(const Search: string): string;

var

Index: byte;

begin

Index := 1;

while (Index <= Length(Search)) andnot (Search[Index] in BlackSpace) do

Index := Index + 1;

Result := Copy(Search, Index, 255);

Index := Length(Result);

while (Index > 0) andnot (Result[Index] in BlackSpace) do

Index := Index - 1;

Result := Copy(Result, 1, Index);

end;

https://delphiworld.narod

DelphiWorld 6.0

Справочник по функциям работы с PChar

2013-08-19T21:09:28+07:00

function StrLIComp(Strl, Str2: PChar; MaxLen: Cardinal) : Integer; Работает как StrLComp, но без учета регистра символов.

function StrScantStr: PChar; Chr: Char) : PChar; Отыскивает первое вхождение символа Chr в строку Str и возвращает указатель на него или nil в случае отстутствия.

function StrRScanfStr: PChar; Chr: Char) : PChar; Работает как StrScan, но отыскивается последнее вхождение Chr.

function StrPos(Strl, Str2: PChar) : PChar; Отыскивает первое вхождение строки Str2 в строку Strl и возвращает указатель на нее или nil в случае отстутствия.

function StrUpperfStr: PChar) : PChar; Преобразует строку к верхнему регистру.

function StrLower(Str: PChar): PChar; Преобразует строку к нижнему регистру.

function StrPaslStr: PChar): String; Преобразует строку Str в строку типа string.

function StrAlloc(Size: Cardinal): PChar; Размещает в куче памяти новую строку размером Size и возвращает указатель на нее.

function StrBufSize(Str: PChar): Cardinal; Возвращает размер блока памяти, выделенного для строки при помощи функции StrAlloc.

function StrNewfStr: PChar): PChar ; Размещает в куче памяти копню строки Str и возвращает указатель на нее.

procedure StrDispose(Str: PChar); Уничтожает строку, размещенную при помощи StrAlloc или StrNew.

function StrLenfStr: PChar): Возвращает число символов в строке Str (без учета завершающего нулевого).

function StrEndfStr: PChar): PChar; Возвращает указатель на завершающий нулевой символ строки Str.

function StrMove(Dest, Source: PChar; Count: Cardinal): PChar; Копирует из строки Source в строку Dest ровно Count символов, причем строки могут перекрываться.

function StrCopy(Dest, Source: PChar): PChar; Копирует Source в Dest и возвращает указатель на Dest.

function StrECopy(Dest, Source: PChar): PChar; Копирует Source в Dest и возвращает указатель на завершающий символ Dest.

function StrLCopy(Dest, Source: PChar; MaxLen: Cardinal): PChar; Работает как StrCopy, но копирует не более MaxLen символов.

function StrPCopy(Dest: PChar; const Source: String): PChar; Копирует строку Source (типа string) в Dest и возвращает указатель на Dest.

function StrPLCopy(Dest: PChar; const Source: string; MaxLen: Cardinal): PChar; Работает как StrPCopy, но копирует не более MaxLen символов.

function StrCat(Dest, Source: PChar): PChar; Дописывает Source к концу Dest и возвращает указатель на Dest.

function StrLCatfDest, Source: PChar; MaxLen: Cardinal) : PChar; Работает как StrCat, но копирует не более MaxLen-StrLen(Dest) символов.

function StrCoirip(Strl, Str2: PChar): Integer; Сравнивает две строки (посимвольно). Возвращает значение: <0 — при Strl <Str2, 0 — при Strl =Str2, >0 — при Strl >Str2.

function StrIComp(Strl, Str2: PChar): Integer; Работает как StrComp, но без учета регистра символов.

function StrLComp(Strl, Str2: PChar; MaxLen: Cardinal): Integer; Работает как StrComp, но сравнение происходит на протяжении не более чем MaxLen символов.

Справочник по функциям работы со строками

2013-08-19T20:52:41+07:00

function NewStrtconst(S: String): PString; Создает копию строки S и возвращает указатель на нее.

procedure DisposeStr(P: PString) ; Уничтожает строку, на которую указывает Р.

procedure AssignStr(var P: PString; const S: strings) Уничтожает строку, на которую указывает Р и затем присваивает ему адрес созданной копии строки S.

procedure AppendStrfvar Dest: string; const S: string); Добавляет строку S в конец строки Dest.

function Uppercase(const S: string): string; Преобразует символы 'a'..'z' в строке S к верхнему регистру.

function LowerCase(const S: string): string; Преобразует символы 'A'..'Z' в строке S к нижнему регистру.

function CompareStr(const SI, S2: string): Integer; Сравнивает две строки S1 и S2 с учетом регистра символов. Возвращаемое значение равно 0 в случае равенства строк или разности кодов пары первых несовпадающих символов.

function CompareText(const SI, S2: string): Integer; Сравнивает две строки без учета регистра символов.

function AnsiUpperCase(const S: string): string; Преобразует символы в строке к верхнему регистру с учетом языкового драйвера.

function AnsiLowerCase(const S: string) : string; Преобразует символы в строке к нижнему регистру с учетом языкового драйвера.

function AnsiCompareStr(const SI, S2: string): Integer; Сравнивает две строки с использованием языкового драйвера и с учетом регистра символов.

function AnsiCompareText(const SI, S2 : string) : Integer; Сравнивает две строки с использованием языкового драйвера и без учета регистра символов.

function IsValidldent(const Ident: string): Boolean; Возвращает True, если строка Ident может служить идентификатором в программе на Object Pascal (т. е. содержит только буквы и цифры, причем первый символ — буква).

function IntToStr(Value: Longint): string; Преобразует целое число в строку.

function IntToHex(Value: Longint; Digits: Integer): s t r ing ; Преобразует целое число в строку с его шестнадцатиричным представлением.

function StrToInt(const S: string): Longint; Преобразует строку в целое число. При ошибке возникает исключительная ситуация EConvertError.

function StrToIntDef(const S: string; Default; Longint): Longint ; Работает как StrToInt, но при ошибке возвращает значение Default.

function LoadStr(Ident: Word) : string; Загружает строку с индексом Ident из ресурсов приложения.

function FmtLoadStr(Ident: Word; const Args: array of const): string; Загружает строку с индексом Ident из ресурсов приложения с форматированием (см. описание функции Format).