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;

*)

{$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;


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;
begin
  u4 := WideStringToUCS4String(GetUTF16Char(Index));
  if length(u4) > 0 then Result := u4[0] else Result := 0;
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;

end.