function UTF8StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;

type

TMatch=Record

Pos,Length: integer;

end;

var

Matches: array of TMatch;

OldPat,Srch: string; // Srch and Oldp can contain uppercase versions of S,OldPattern

PatLength,P,Count, Capacity, i: Integer;

p1,p2, MemPos, p3: pchar;

i1,i2, l, j: integer;

OldPatLengths: integer;

begin

if (Length(OldPattern)=0) or (Length(S)=0) then

exit(S);

if rfIgnoreCase in Flags then begin

Srch := UTF8LowerCase(S);

OldPat := UTF8LowerCase(OldPattern);

end else begin

Srch := S;

OldPat := OldPattern;

end;

{ Find matches }

Count := 0;

Capacity := 10;

SetLength(Matches, Capacity);

P:=PosEx(OldPat, Srch, 1);

if P=0 then exit(s);

if rfReplaceAll in Flags then { TODO : Consider using FindMatchesBoyerMooreCaseSensitive }

while p<>0 do begin

Matches[Count].pos := p;

Matches[Count].Length := Length(OldPat);

inc(Count);

if Count=Capacity then begin { Grow }

inc(Capacity, 10);

SetLength(Matches, Capacity);

end;

P:=PosEx(OldPat,Srch,P+1);

end

else begin

Matches[Count].pos := p;

Matches[Count].Length := Length(OldPat);

inc(Count);

end;

if rfIgnoreCase in Flags then begin { Correct match positions and lengths }

OldPatLengths := 0;

p1 := @Srch[1]; p2 := @S[1];

for i := 0 to Count-1 do begin

MemPos := @Srch[Matches[i].pos];

while p1<MemPos do begin

inc(p1, UTF8CharacterLengthFast(p1));

inc(p2, UTF8CharacterLengthFast(p2));

end;

Matches[i].pos := p2-@S[1]+1;

Matches[i].Length:=0;

{ Get length of old pattern in S }

{ Patterns do not necessarily have the same length with rfIgnoreCase }

{ We assume they have the same number of codepoints }

p3 := p2;

for j := 1 to Length(OldPat) do

begin

inc(p1, UTF8CharacterLengthFast(p1));

inc(p3, UTF8CharacterLengthFast(p3));

end;

Matches[i].Length := p3-p2;

Inc(OldPatLengths, Matches[i].Length);

p2 := p3;

end;

end

else

OldPatLengths := Length(OldPat)*Count;

PatLength := Length(OldPat);

if not (rfIgnoreCase in Flags) and (Length(NewPattern)=PatLength) then begin

//Result length will not change

Result:=S;

if (rfReplaceAll in Flags) then

for i := 0 to Count-1 do move(NewPattern[1], Result[Matches[i].pos], PatLength)

else

move(NewPattern[1], Result[Matches[0].pos], PatLength);

end else begin

SetLength(Result, Length(S) + Count*Length(NewPattern)-OldPatLengths);

if Length(Result)=0 then exit;

i1 := 1; i2 := 1;

for i := 0 to Count-1 do begin

l := Matches[i].pos-i1;

if l>0 then

move(S[i1], Result[i2], l); { Copy text before pattern }

inc(i2, l); { Move to the location of the pattern }

i1 := Matches[i].pos+Matches[i].Length; { Move over the old pattern }

if Length(NewPattern)>0 then

move(NewPattern[1], Result[i2], Length(NewPattern)); { Copy the new pattern }

inc(i2, Length(NewPattern));

end;

if (i1>0) and (i1<=Length(S)) then

move(S[i1], Result[i2], Length(S)-i1+1); { Copy leftover text }

end;

end;