unit ExUtils;

interface

uses
  Classes, EncdDecd, WinZLib;

{ Extract }
function Extract(const Data: WideString): WideString; { unzip }

{ Package }
function Package(const Data: WideString): WideString; { zip }

{ Extract64 }
function Extract64(const Data: WideString): WideString; { unzip base64 }

{ Package64 }
function Package64(const Data: WideString): WideString; { zip base64 }

{ WideStringToUTF8 }
function WideStringToUTF8(S: WideString): AnsiString;

{ UTF8ToWideString }
function UTF8ToWideString(S: AnsiString): WideString;

implementation

{ Extract }
function Extract(const Data: WideString): WideString;
var
  S: TStringStream;
  P: Pointer;
  Bytes: Integer;
  AnsiData: string;
begin
  Result := '';
  if Length(Data) > 0 then
  begin
    AnsiData := Data;
    P := nil;
    DecompressBuf(PChar(AnsiData), Length(AnsiData), 0, P, Bytes); { unzip }
    if Assigned(P) and (Bytes > 0) then
    begin
      S := TStringStream.Create('');
      try
        S.WriteBuffer(P^, Bytes);
        Result := S.DataString;
      finally
        S.Free;
      end;
      FreeMem(P);
    end;
  end;
end;

{ Package }
function Package(const Data: WideString): WideString;
var
  S: TStringStream;
  P: Pointer;
  Bytes: Integer;
  AnsiData: string;
begin
  Result := '';
  if Length(Data) > 0 then
  begin
    try
      P := nil;
      AnsiData := Data;
      CompressBuf(PChar(AnsiData), Length(AnsiData), P, Bytes); { zip }
      if Assigned(P) and (Bytes > 0) then
      begin
        S := TStringStream.Create('');
        try
          S.WriteBuffer(P^, Bytes);
          Result := S.DataString;
        finally
          S.Free;
        end;
      end;
    finally
      FreeMem(P);
    end;
  end;
end;

{ Extract64 }
function Extract64(const Data: WideString): WideString;
var
  S: TStringStream;
  P: Pointer;
  Bytes: Integer;
  AnsiData: string;
begin
  Result := '';
  if Length(Data) > 0 then
  begin
    AnsiData := DecodeString(Data);
    P := nil;
    DecompressBuf(PChar(AnsiData), Length(AnsiData), 0, P, Bytes); { unzip }
    if Assigned(P) and (Bytes > 0) then
    begin
      S := TStringStream.Create('');
      try
        S.WriteBuffer(P^, Bytes);
        Result := S.DataString;
      finally
        S.Free;
      end;
      FreeMem(P);
    end;
  end;
end;

{ Package64 }
function Package64(const Data: WideString): WideString;
var
  S: TStringStream;
  P: Pointer;
  Bytes: Integer;
  AnsiData: string;
begin
  Result := '';
  if Length(Data) > 0 then
  begin
    try
      P := nil;
      AnsiData := Data;
      CompressBuf(PChar(AnsiData), Length(AnsiData), P, Bytes); { zip }
      if Assigned(P) and (Bytes > 0) then
      begin
        S := TStringStream.Create('');
        try
          S.WriteBuffer(P^, Bytes);
          Result := S.DataString;
        finally
          S.Free;
        end;
        Result := EncodeString(Result);
      end;
    finally
      FreeMem(P);
    end;
  end;
end;

//----------------- Conversion routines ---------------------------------------
type
  // Unicode transformation formats (UTF) data types
  UTF7 = Char;
  UTF8 = Char;
  UTF16 = WideChar;
  UTF32 = Cardinal;

  // UTF conversion schemes (UCS) data types
  PUCS4 = ^UCS4;
  UCS4 = Cardinal;
  PUCS2 = PWideChar;
  UCS2 = WideChar;

const
  ReplacementCharacter: UCS4 = $0000FFFD;
  MaximumUCS2: UCS4 = $0000FFFF;
  MaximumUTF16: UCS4 = $0010FFFF;
  MaximumUCS4: UCS4 = $7FFFFFFF;

  SurrogateHighStart: UCS4 = $D800;
  SurrogateHighEnd: UCS4 = $DBFF;
  SurrogateLowStart: UCS4 = $DC00;
  SurrogateLowEnd: UCS4 = $DFFF;

const
  halfShift: Integer = 10;

  halfBase: UCS4 = $0010000;
  halfMask: UCS4 = $3FF;

  offsetsFromUTF8: array[0..5] of UCS4 = ($00000000, $00003080, $000E2080, $03C82080, $FA082080, $82082080);

  bytesFromUTF8: array[0..255] of Byte = (
	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
	2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5);

  firstByteMark: array[0..6] of Byte = ($00, $00, $C0, $E0, $F0, $F8, $FC);

{ WideStringToUTF8 }
function WideStringToUTF8(S: WideString): AnsiString;

var
  ch: UCS4;
  L, J, T,
  bytesToWrite: Word;
  byteMask: UCS4;
  byteMark: UCS4;

begin
  if Length(S) = 0 then
  begin
    Result := '';
    Exit;
  end;

  SetLength(Result, Length(S) * 6); // assume worst case
  T := 1;
  for J := 1 to Length(S) do
  begin
    byteMask := $BF;
    byteMark := $80;

    ch := UCS4(S[J]);

    if ch < $80 then
      bytesToWrite := 1
    else
    if ch < $800 then
      bytesToWrite := 2
    else
    if ch < $10000 then
      bytesToWrite := 3
    else
    if ch < $200000 then
      bytesToWrite := 4
    else
    if ch < $4000000 then
      bytesToWrite := 5
    else
    if ch <= MaximumUCS4 then
      bytesToWrite := 6
    else
    begin
      bytesToWrite := 2;
      ch := ReplacementCharacter;
    end;

    for L := bytesToWrite downto 2 do
    begin
      Result[T + L - 1] := Char((ch or byteMark) and byteMask);
      ch := ch shr 6;
    end;
    Result[T] := Char(ch or firstByteMark[bytesToWrite]);
    Inc(T, bytesToWrite);
  end;
  SetLength(Result, T - 1); // assume worst case
end;

{ UTF8ToWideString }
function UTF8ToWideString(S: AnsiString): WideString;

var
  L, J, T: Cardinal;
  ch: UCS4;
  extraBytesToWrite: Word;

begin
  if Length(S) = 0 then
  begin
    Result := '';
    Exit;
  end;

  SetLength(Result, Length(S)); // create enough room

  L := 1;
  T := 1;
  while L <= Cardinal(Length(S)) do
  begin
    ch := 0;
    extraBytesToWrite := bytesFromUTF8[Ord(S[L])];

    for J := extraBytesToWrite downto 1 do
    begin
      ch := ch + Ord(S[L]);
      Inc(L);
      ch := ch shl 6;
    end;
    ch := ch + Ord(S[L]);
    Inc(L);
    ch := ch - offsetsFromUTF8[extraBytesToWrite];

    if ch <= MaximumUCS2 then
    begin
      Result[T] := WideChar(ch);
      Inc(T);
    end
    else
    if ch > MaximumUCS4 then
    begin
      Result[T] := WideChar(ReplacementCharacter);
      Inc(T);
    end
    else
    begin
      ch := ch - halfBase;
      Result[T] := WideChar((ch shr halfShift) + SurrogateHighStart);
      Inc(T);
      Result[T] := WideChar((ch and halfMask) + SurrogateLowStart);
      Inc(T);
    end;
  end;
  SetLength(Result, T - 1); // now fix up length
end;

end.