unit utf8helper;

(* DEMO

procedure TForm1.Button1Click(Sender: TObject);
var uni:TUTF8Helper;
i, posi:Integer;
begin
 uni:=TUTF8Helper.Create('Die Vision von Lazarus ist: "Write once, compile '+
 'everywhere." Das bedeutet im Idealfall, eine Applikation, die Unicode '+
 'eingeschaltet hat, hat nur einen Source-Code, der für alle Plattformen gültig ist, '+
 'ohne irgendwelche konditionalen Definitionen.');
 posi:=uni.UPos('gültig');
 uni.UDelete(posi,6);
 uni.UInsert('richtig',posi);
 Caption:=uni.UCopy(16,7);

 for i:=1 to uni.count do if uni[i]='o' then uni[i]:='Ö';

 Memo1.text:=uni.UTF8Str;
 uni.free;
end;

*)

(*

US:=TUTF8Scanner.Create(S);
US.FindChars:='äö';
Repeat
 case US.FindIndex(US.Next) of
  {ä} 0: begin US.Replace('A'); end;
  {ö} 1: begin US.Replace('O'); end;
 end;
until US.Done;
Memo1.text:=US.UTF8String;


*)

{$MODE objfpc}{$H+}

interface

uses
  Classes, SysUtils, LCLPRoc;

type

  { TUnicodeClass }

  TUTF8Helper = class
  private
    fString: UTF8String;
    fBytePosA, fBytePosB: Integer;
    fCharIndex: Integer;
    function GetUCS2Char(Index: Integer): WideChar;
    function GetUCS4Char(Index: Integer): UCS4Char; virtual;
    function GetUTF16Char(Index: Integer): WideString;
    procedure PutUCS2Char(Index: Integer; const AValue: WideChar);
    procedure PutUCS4Char(Index: Integer; const AChar: UCS4Char); virtual;
    function GetUTF8Char(Index: Integer): UTF8String; virtual;
    procedure PutUTF16Char(Index: Integer; const AValue: WideString);
    procedure PutUTF8Char(Index: Integer; const AChar: UTF8String); virtual;
    function GetUTF8String: UTF8String; overload;
    function GetUTF16String: WideString; overload;
    function GetUCS4String: UCS4String; overload;

  public
    constructor Create; overload;
    constructor Create(AString: UTF8String); overload;
    constructor Create(AString: WideString); overload;
    constructor Create(AString: UCS4String); overload;
    destructor Destroy; override;
    function Count: Integer;
    procedure ResetIndex;
    procedure SetString(AString: UTF8String); overload;
    procedure SetString(AString: WideString); overload;
    procedure SetString(AString: UCS4String); overload;
    procedure LowerCase;
    procedure UpperCase;
    function UPos(const SearchForText: UTF8String): integer;
    function UCopy(StartCharIndex, CharCount: integer): UTF8String;
    procedure UDelete(StartCharIndex, CharCount: integer);
    procedure UInsert(const source: UTF8String; StartCharIndex: integer);
    property UnicodeChars[Index: Integer]: UCS4Char read GetUCS4Char write PutUCS4Char;
    property Utf8Chars[Index: Integer]: UTF8String read GetUTF8Char write PutUTF8Char; default;
    property Utf16Chars[Index: Integer]: WideString read GetUTF16Char write PutUTF16Char;
    property Ucs2Chars[Index: Integer]: WideChar read GetUCS2Char write PutUCS2Char;
    property UTF8Str: UTF8String read GetUTF8String write SetString;
    property UTF16Str: WideString read GetUTF16String write SetString;
    property UCS4Str: UCS4String read GetUCS4String write SetString;
  end;


  { TUTF8Scanner }

  TUTF8Scanner = class
  private
    fBytePos: integer;
    fCharPos: integer;
    fLastLength: integer;
    fLen: integer;
    fPString: PChar;
    fAnsiString: AnsiString;
    fDone: Boolean;
    fFindList: TList;
    fModePChar:Boolean;
    function GetString: AnsiString;
    function GetStringPos: integer;
    procedure SetFindChars(Chars: UTF8String);
    procedure SetString(const AValue: AnsiString);
  public
    constructor Create(AString: UTF8String); overload;
    constructor Create(APChar:PChar); overload;
    destructor Destroy; override;
    function Next: UCS4Char;
    function FindIndex(AChar: UCS4Char): Integer;
    procedure Replace(AChar: UTF8String);
    function IsFindChar(AChar: UCS4Char): Boolean;
    function CurrentCharAsUTF8: UTF8String;
    function CharToUnicode(AChar: UTF8String): UCS4Char;
    function GenerateCaseStatement(WithBeginEnd: Boolean = false; InstanceName: string = 'US'): string;
    procedure Reset;
    property Done: Boolean read fDone;
    property FindChars: UTF8String write SetFindChars;
    property BytePos: integer read fBytePos;
    property CharPos: integer read fCharPos;
    property LastLength: integer read fLastLength;
    property StringPos: integer read GetStringPos;
    property UTF8String: AnsiString read GetString write SetString;
  end;


implementation


{ TUTF8Helper }

function TUTF8Helper.GetUTF16Char(Index: Integer): WideString;
begin
  Result := UTF8ToUTF16(GetUTF8Char(Index));
end;

procedure TUTF8Helper.PutUTF16Char(Index: Integer; const AValue: WideString);
begin
  PutUTF8Char(Index, UTF16ToUTF8(AValue));
end;

function TUTF8Helper.GetUCS2Char(Index: Integer): WideChar;
var temp: WideString;
begin
  temp := (UTF8Decode(GetUTF8Char(Index)));
  if Length(temp) > 0 then Result := temp[1] else raise Exception.Create('character ' + inttostr(Index) + ' not convertible')
end;

procedure TUTF8Helper.PutUCS2Char(Index: Integer; const AValue: WideChar);
begin
  PutUTF8Char(Index, UTF8Encode(AValue));
end;

function TUTF8Helper.GetUCS4Char(Index: Integer): UCS4Char;
//var u4: UCS4String;
var dummy: integer;
begin
  {u4 := WideStringToUCS4String(GetUTF16Char(Index));
  if length(u4) > 0 then Result := u4[0] else Result := 0;}
  Result := UTF8CharacterToUnicode(Pchar(GetUTF8Char(Index)), dummy);
end;

procedure TUTF8Helper.PutUCS4Char(Index: Integer; const AChar: UCS4Char);
var AString: UCS4String;
begin
  SetLength(AString, 2);
  AString[0] := AChar;
  PutUTF16Char(Index, UCS4StringToWideString(AString));
end;

procedure TUTF8Helper.ResetIndex;
begin
  fCharIndex := -1;
  fBytePosB := -1;
  fBytePosA := -1;
end;

constructor TUTF8Helper.Create;
begin
  ResetIndex;
end;

constructor TUTF8Helper.Create(AString: UTF8String);
begin
  ResetIndex;
  SetString(AString);
end;

constructor TUTF8Helper.Create(AString: WideString);
begin
  ResetIndex;
  SetString(AString);
end;

constructor TUTF8Helper.Create(AString: UCS4String);
begin
  ResetIndex;
  SetString(AString);
end;

destructor TUTF8Helper.Destroy;
begin
  inherited Destroy;
end;

procedure TUTF8Helper.SetString(AString: UTF8String);
begin
  fString := AString;
  ResetIndex;
end;

procedure TUTF8Helper.SetString(AString: WideString);
begin
  SetString(UTF16ToUTF8(AString));
end;

procedure TUTF8Helper.SetString(AString: UCS4String);
begin
  SetString(UCS4StringToWideString(AString));
end;

procedure TUTF8Helper.LowerCase;
begin
  fString := UTF8LowerCase(fString);
  ResetIndex;
end;

procedure TUTF8Helper.UpperCase;
begin
  fString := UTF8UpperCase(fString);
  ResetIndex;
end;

function TUTF8Helper.UPos(const SearchForText: UTF8String): integer;
begin
  Result := UTF8Pos(SearchForText, fString);
end;

function TUTF8Helper.UCopy(StartCharIndex, CharCount: integer
  ): UTF8String;
begin
  Result := UTF8Copy(fString, StartCharIndex, CharCount);
end;

procedure TUTF8Helper.UDelete(StartCharIndex, CharCount: integer);
begin
  UTF8Delete(fString, StartCharIndex, CharCount);
  ResetIndex;
end;

procedure TUTF8Helper.UInsert(const source: UTF8String;
  StartCharIndex: integer);
begin
  UTF8Insert(source, fString, StartCharIndex);
  ResetIndex;
end;

function TUTF8Helper.GetUTF8String: UTF8String;
begin
  Result := fString;
end;

function TUTF8Helper.GetUTF16String: WideString;
begin
  Result := UTF8ToUTF16(GetUTF8String);
end;

function TUTF8Helper.GetUCS4String: UCS4String;
begin
  Result := WideStringToUCS4String(GetUTF16String);
end;

function TUTF8Helper.Count: Integer;
begin
  Result := UTF8Length(Pchar(fString), Length(fString));
  ResetIndex;
end;

function TUTF8Helper.GetUTF8Char(Index: Integer): UTF8String;
var Pc, Pc2, Pc3: Pchar;
  alen, counter: integer;
begin
  Result := '';
  if fString = '' then exit;

  Pc3 := @fString[1];
  Pc := Pc3;
  counter := 1;
  if (fCharIndex > -1) then
    if (Index > fCharIndex) then
    begin
      counter := fCharIndex + 1;
      Inc(Pc, fBytePosB);
    end else
      if (Index = fCharIndex) then
      begin
        counter := fCharIndex;
        Inc(Pc, fBytePosA);
      end;

  if Pc[0] = #0 then exit;
  repeat
    Pc2 := Pc;
    alen := UTF8CharacterLength(Pc);
    inc(Pc, alen);
    inc(counter);
  until (Counter > Index) or (Pc[0] = #0);

  fBytePosA := Pc2 - Pc3;
  fBytePosB := Pc - Pc3;
  fCharIndex := Index;

  Result := Copy(fString, Pc2 - Pc3 + 1, alen);

end;

procedure TUTF8Helper.PutUTF8Char(Index: Integer; const AChar: UTF8String);
var Pc, Pc2, Pc3: Pchar;
  alen, counter, pos: integer;
begin

  if fString = '' then exit;

  Pc3 := @fString[1];
  Pc := Pc3;
  counter := 1;
  if (fCharIndex > -1) then
    if (Index > fCharIndex) then
    begin
      counter := fCharIndex + 1;
      Inc(Pc, fBytePosB);
    end else
      if (Index = fCharIndex) then
      begin
        counter := fCharIndex;
        Inc(Pc, fBytePosA);
      end;

  if Pc[0] = #0 then exit;
  repeat
    Pc2 := Pc;
    alen := UTF8CharacterLength(Pc);
    inc(Pc, alen);
    inc(counter);
  until (Counter > Index) or (Pc[0] = #0);

  fBytePosA := Pc2 - Pc3;
  fBytePosB := Pc - Pc3;
  fCharIndex := Index;

  Pos := fBytePosA + 1;

  if (Length(AChar) = 1) and (alen = 1) then
  begin
    fString[Pos] := AChar[1];
  end else
    if (Length(AChar) = 2) and (alen = 2) then
    begin
      fString[Pos] := AChar[1];
      fString[Pos + 1] := AChar[2];
    end else
      if (Length(AChar) = 1) and (alen = 2) then
      begin
        Delete(fString, Pos, 1);
        fString[Pos] := AChar[1];
        ResetIndex;
      end else
        if (Length(AChar) = 2) and (alen = 1) then
        begin
          fString[Pos] := AChar[1];
          Insert(AChar[2], fString, Pos + 1);
          ResetIndex;
        end else
        begin
          Delete(fString, Pos, alen);
          Insert(AChar, fString, Pos);
          ResetIndex;
        end;

end;

{ TUTF8Scanner }

function TUTF8Scanner.GetStringPos: integer;
begin
  Result := fBytePos - fLastLength + 1;
end;

function TUTF8Scanner.GetString: AnsiString;
begin
  if fModePChar then
  Result:=fPString else
  Result:=fAnsiString;
end;

constructor TUTF8Scanner.Create(AString: UTF8String);
begin
  fFindList := TList.Create;
  SetString(AString);
end;

constructor TUTF8Scanner.Create(APChar: PChar);
begin
  fFindList := TList.Create;
  fModePChar:=True;
  fPString := APChar;
  fLen := strlen(APChar);
  Reset;
end;

destructor TUTF8Scanner.Destroy;
begin
  fFindList.free;
  inherited Destroy;
end;

function TUTF8Scanner.Next: UCS4Char;
var Len: integer;
begin
  if fBytePos < fLen then
  begin
    Result := UTF8CharacterToUnicode(fPString + fBytePos, Len);
    fLastLength := Len;
    inc(fBytePos, Len);
    inc(fCharPos);
    if fBytePos >= fLen then fDone := true;
  end else fDone := true;
end;

procedure TUTF8Scanner.SetFindChars(Chars: UTF8String);
var Scn: TUTF8Scanner;
begin
  Scn := TUTF8Scanner.Create(Chars);
  fFindList.Clear;
  if Length(Chars) > 0 then
    repeat
      fFindList.Add(Pointer(Scn.Next));
    until Scn.Done;
  Scn.free;
end;

procedure TUTF8Scanner.SetString(const AValue: AnsiString);
begin
  fModePchar:=False;
  fAnsiString := AValue;
  fPString := @fAnsiString[1];
  fLen := Length(AValue);
  Reset;
end;

function TUTF8Scanner.IsFindChar(AChar: UCS4Char): Boolean;
begin
  Result := fFindList.IndexOf(Pointer(AChar)) > -1;
end;

function TUTF8Scanner.FindIndex(AChar: UCS4Char): Integer;
begin
  Result := fFindList.IndexOf(Pointer(AChar));
end;


procedure TUTF8Scanner.Replace(AChar: UTF8String);
var i, diff: integer;
begin
  if fModePChar then raise Exception.Create('Replace not possible in Pchar mode');
  if Length(AChar) = fLastLength then
  begin
    for i := 0 to fLastLength - 1 do (fPString + fBytePos - fLastLength + i)^ := Achar[i + 1];
  end else
  begin
    System.Delete(fAnsiString, StringPos, fLastLength);
    System.Insert(AChar, fAnsiString, StringPos);
    fPString := @fAnsiString[1];

    diff := Length(AChar) - fLastLength;
    Inc(fBytePos, diff);
    Inc(fLen, diff);
    fLastLength := Length(AChar);
  end;
end;

function TUTF8Scanner.CurrentCharAsUTF8: UTF8String;
begin
//  Result := Copy(fAnsiString, GetStringPos, LastLength);
  SetLength(Result,LastLength);
  Strlcopy(@Result[1],fPString+fBytePos-LastLength,LastLength);
end;

function TUTF8Scanner.CharToUnicode(AChar: UTF8String): UCS4Char;
var Dummy: integer;
begin
  Result := UTF8CharacterToUnicode(@AChar[1], Dummy);
end;

function TUTF8Scanner.GenerateCaseStatement(WithBeginEnd: Boolean; InstanceName: string): string;
var i: integer;
begin
  Result := 'case ' + InstanceName + '.FindIndex(' + InstanceName + '.Next) of' + LineEnding;
  for i := 0 to fFindList.Count - 1 do
    if WithBeginEnd then
    begin
      Result := Result + '  {' + UnicodeToUTF8(UCS4Char(fFindList[i])) + '} ' + inttostr(i) + ': begin <code here> end;' + LineEnding;
    end else
      Result := Result + '  {' + UnicodeToUTF8(UCS4Char(fFindList[i])) + '} ' + inttostr(i) + ': <code here> ;' + LineEnding;
  Result := Result + 'end;';
end;

procedure TUTF8Scanner.Reset;
begin
  fBytePos := 0;
  fLastLength := 0;
  fCharPos := 0;
  fDone := False;
end;

end.