synachar.pas

很不错的东东

function UCS4toUTF8(const Value: string): string;
function UTF7toUCS2(const Value: string): string;
function UCS2toUTF7(const Value: string): string;
function CharsetConversion(Value: string; CharFrom: TMimeChar;
  CharTo: TMimeChar): string;
function CharsetConversionEx(Value: string; CharFrom: TMimeChar;
  CharTo: TMimeChar; const TransformTable: array of Word): string;
function GetCurCP: TMimeChar;
function GetCPFromID(Value: string): TMimeChar;
function GetIDFromCP(Value: TMimeChar): string;
function NeedCharsetConversion(const Value: string): Boolean;
function IdealCharsetCoding(const Value: string; CharFrom: TMimeChar;
  CharTo: TMimeSetChar): TMimeChar;

implementation

uses
{$IFDEF LINUX}
  Libc,
{$ELSE}
  Windows,
{$ENDIF}
  SysUtils,
  SynaUtil, SynaCode;

const
  NotFoundChar = '_';

var
  SetTwo: set of TMimeChar = [UCS_2, UTF_7];
  SetFour: set of TMimeChar = [UCS_4, UTF_8];

{==============================================================================}
function ReplaceUnicode(Value: Word; const TransformTable: array of Word): Word;
var
  n: integer;
begin
  if High(TransformTable) <> 0 then
    for n := 0 to High(TransformTable) do
      if not odd(n) then
        if TransformTable[n] = Value then
          begin
            Value := TransformTable[n+1];
            break;
          end;
  Result := Value;
end;

{==============================================================================}
procedure CopyArray(const SourceTable: array of Word;
  var TargetTable: array of Word);
var
  n: Integer;
begin
  for n := 0 to 127 do
    TargetTable[n] := SourceTable[n];
end;

{==============================================================================}
procedure GetArray(CharSet: TMimeChar; var Result: array of Word);
begin
  case CharSet of
    ISO_8859_1:
      CopyArray(CharISO_8859_1, Result);
    ISO_8859_2:
      CopyArray(CharISO_8859_2, Result);
    ISO_8859_3:
      CopyArray(CharISO_8859_3, Result);
    ISO_8859_4:
      CopyArray(CharISO_8859_4, Result);
    ISO_8859_5:
      CopyArray(CharISO_8859_5, Result);
    ISO_8859_6:
      CopyArray(CharISO_8859_6, Result);
    ISO_8859_7:
      CopyArray(CharISO_8859_7, Result);
    ISO_8859_8:
      CopyArray(CharISO_8859_8, Result);
    ISO_8859_9:
      CopyArray(CharISO_8859_9, Result);
    ISO_8859_10:
      CopyArray(CharISO_8859_10, Result);
    ISO_8859_13:
      CopyArray(CharISO_8859_13, Result);
    ISO_8859_14:
      CopyArray(CharISO_8859_14, Result);
    ISO_8859_15:
      CopyArray(CharISO_8859_15, Result);
    CP1250:
      CopyArray(CharCP_1250, Result);
    CP1251:
      CopyArray(CharCP_1251, Result);
    CP1252:
      CopyArray(CharCP_1252, Result);
    CP1253:
      CopyArray(CharCP_1253, Result);
    CP1254:
      CopyArray(CharCP_1254, Result);
    CP1255:
      CopyArray(CharCP_1255, Result);
    CP1256:
      CopyArray(CharCP_1256, Result);
    CP1257:
      CopyArray(CharCP_1257, Result);
    CP1258:
      CopyArray(CharCP_1258, Result);
    KOI8_R:
      CopyArray(CharKOI8_R, Result);
    CP895:
      CopyArray(CharCP_895, Result);
    CP852:
      CopyArray(CharCP_852, Result);
  end;
end;

{==============================================================================}
procedure ReadMulti(const Value: string; var Index: Integer; mb: Byte;
  var b1, b2, b3, b4: Byte);
var
  b: array[0..3] of Byte;
  n: Integer;
  s: string;
begin
  b[0] := 0;
  b[1] := 0;
  b[2] := 0;
  b[3] := 0;
  if (Length(Value) + 1) < Index + mb then
    Exit;
  s := '';
  for n := 1 to mb do
  begin
    s := Value[Index] + s;
    Inc(Index);
  end;
  for n := 1 to mb do
    b[n - 1] := Ord(s[n]);
  b1 := b[0];
  b2 := b[1];
  b3 := b[2];
  b4 := b[3];
end;

{==============================================================================}
function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte): string;
var
  b: array[0..3] of Byte;
  n: Integer;
begin
  Result := '';
  b[0] := b1;
  b[1] := b2;
  b[2] := b3;
  b[3] := b4;
  for n := 1 to mb do
    Result := Char(b[n - 1]) + Result;
end;

{==============================================================================}
function UTF8toUCS4(const Value: string): string;
var
  n, x, ul, m: Integer;
  s: string;
  w1, w2: Word;
begin
  Result := '';
  n := 1;
  while Length(Value) >= n do
  begin
    x := Ord(Value[n]);
    Inc(n);
    if x < 128 then
      Result := Result + WriteMulti(x, 0, 0, 0, 4)
    else
    begin
      m := 0;
      if (x and $E0) = $C0 then
        m := $1F;
      if (x and $F0) = $E0 then
        m := $0F;
      if (x and $F8) = $F0 then
        m := $07;
      if (x and $FC) = $F8 then
        m := $03;
      if (x and $FE) = $FC then
        m := $01;
      ul := x and m;
      s := IntToBin(ul, 0);
      while Length(Value) >= n do
      begin
        x := Ord(Value[n]);
        Inc(n);
        if (x and $C0) = $80 then
          s := s + IntToBin(x and $3F, 6)
        else
        begin
          Dec(n);
          Break;
        end;
      end;
      ul := BinToInt(s);
      w1 := ul div 65536;
      w2 := ul mod 65536;
      Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4);
    end;
  end;
end;

{==============================================================================}
function UCS4toUTF8(const Value: string): string;
var
  s, l, k: string;
  b1, b2, b3, b4: Byte;
  n, m, x, y: Integer;
  b: Byte;
begin
  Result := '';
  n := 1;
  while Length(Value) >= n do
  begin
    ReadMulti(Value, n, 4, b1, b2, b3, b4);
    if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then
      Result := Result + Char(b1)
    else
    begin
      x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536;
      l := IntToBin(x, 0);
      y := Length(l) div 6;
      s := '';
      for m := 1 to y do
      begin
        k := Copy(l, Length(l) - 5, 6);
        l := Copy(l, 1, Length(l) - 6);
        b := BinToInt(k) or $80;
        s := Char(b) + s;
      end;
      b := BinToInt(l);
      case y of
        5:
          b := b or $FC;
        4:
          b := b or $F8;
        3:
          b := b or $F0;
        2:
          b := b or $E0;
        1:
          b := b or $C0;
      end;
      s := Char(b) + s;
      Result := Result + s;
    end;
  end;
end;

{==============================================================================}
function UTF7toUCS2(const Value: string): string;
var
  n: Integer;
  c: Char;
  s: string;
begin
  Result := '';
  n := 1;
  while Length(Value) >= n do
  begin
    c := Value[n];
    Inc(n);
    if c <> '+' then
      Result := Result + WriteMulti(Ord(c), 0, 0, 0, 2)
    else
    begin
      s := '';
      while Length(Value) >= n do
      begin
        c := Value[n];
        Inc(n);
        if c = '-' then
          Break;
        if (c = '=') or (Pos(c, TableBase64) < 1) then
        begin
          Dec(n);
          Break;
        end;
        s := s + c;
      end;
      if s = '' then
        s := '+'
      else
        s := DecodeBase64(s);
      Result := Result + s;
    end;
  end;
end;

{==============================================================================}
function UCS2toUTF7(const Value: string): string;
var
  s: string;
  b1, b2, b3, b4: Byte;
  n, m: Integer;
begin
  Result := '';
  n := 1;
  while Length(Value) >= n do
  begin
    ReadMulti(Value, n, 2, b1, b2, b3, b4);
    if (b2 = 0) and (b1 < 128) then
      if Char(b1) = '+' then
        Result := Result + '+-'
      else
        Result := Result + Char(b1)
    else
    begin
      s := Char(b2) + Char(b1);
      while Length(Value) >= n do
      begin
        ReadMulti(Value, n, 2, b1, b2, b3, b4);
        if (b2 = 0) and (b1 < 128) then
        begin
          Dec(n, 2);
          Break;
        end;
        s := s + Char(b2) + Char(b1);
      end;
      s := EncodeBase64(s);
      m := Pos('=', s);
      if m > 0 then
        s := Copy(s, 1, m - 1);
      Result := Result + '+' + s + '-';
    end;