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;