idcoderheader.pas

Indy控件的使用源代码

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  10093: IdCoderHeader.pas 
{
{   Rev 1.0    2002.11.12 10:32:34 PM  czhower
}
unit IdCoderHeader;

//TODO: Optimize and restructure code
//TODO: Redo this unit to fit with the new coders and use the exisiting MIME stuff

{
2001-Nov-18 Peter Mee
 - Fixed multiple QP decoding in single header.
11-10-2001 - J. Peter Mugaas
  - tiny fix for 8bit header encoding suggested by Andrew P.Rybin}
interface

uses
  IdEMailAddress;

type
  TTransfer = (bit7, bit8, iso2022jp);
  CSET = set of Char;

// Procs
  function EncodeAddressItem(EmailAddr:TIdEmailAddressItem; const HeaderEncoding: Char;
    TransferHeader: TTransfer; MimeCharSet: string): string;
  function EncodeHeader(const Header: string; specials : CSET; const HeaderEncoding: Char;
   TransferHeader: TTransfer; MimeCharSet: string): string;
  function Encode2022JP(const S: string): string;
  function EncodeAddress(EmailAddr:TIdEMailAddressList; const HeaderEncoding: Char;
    TransferHeader: TTransfer; MimeCharSet: string): string;
  function DecodeHeader(Header: string):string;
  function Decode2022JP(const S: string): string;
  Procedure DecodeAddress(EMailAddr : TIdEmailAddressItem);
  Procedure DecodeAddresses(AEMails : String; EMailAddr : TIdEmailAddressList);
  procedure InitializeISO(var TransferHeader: TTransfer; var HeaderEncoding: char;
    var CharSet: string);

implementation

uses
  IdGlobal,
  SysUtils;

const
  csSPECIALS: CSET = ['(', ')', '[', ']', '<', '>', ':', ';', '.', ',', '@', '\', '"'];  {Do not Localize}

  kana_tbl : array[#$A1..#$DF] of Word = (
    $2123,$2156,$2157,$2122,$2126,$2572,$2521,$2523,$2525,$2527,
    $2529,$2563,$2565,$2567,$2543,$213C,$2522,$2524,$2526,$2528,
    $252A,$252B,$252D,$252F,$2531,$2533,$2535,$2537,$2539,$253B,
    $253D,$253F,$2541,$2544,$2546,$2548,$254A,$254B,$254C,$254D,
    $254E,$254F,$2552,$2555,$2558,$255B,$255E,$255F,$2560,$2561,
    $2562,$2564,$2566,$2568,$2569,$256A,$256B,$256C,$256D,$256F,
    $2573,$212B,$212C);

  vkana_tbl : array[#$A1..#$DF] of Word = (
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$2574,$0000,
    $0000,$252C,$252E,$2530,$2532,$2534,$2536,$2538,$253A,$253C,
    $253E,$2540,$2542,$2545,$2547,$2549,$0000,$0000,$0000,$0000,
    $0000,$2550,$2553,$2556,$2559,$255C,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000);

  sj1_tbl : array[#128..#255] of Byte = (
    $00,$21,$23,$25,$27,$29,$2B,$2D,$2F,$31,$33,$35,$37,$39,$3B,$3D,
    $3F,$41,$43,$45,$47,$49,$4B,$4D,$4F,$51,$53,$55,$57,$59,$5B,$5D,
    $00,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,
    $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,
    $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,
    $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,
    $5F,$61,$63,$65,$67,$69,$6B,$6D,$6F,$71,$73,$75,$77,$79,$7B,$7D,
    $02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$00,$00,$00);

  sj2_tbl : array[Char] of Word = (
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,$0000,
    $0000,$0000,$0000,$0000,$0021,$0022,$0023,$0024,$0025,$0026,
    $0027,$0028,$0029,$002A,$002B,$002C,$002D,$002E,$002F,$0030,
    $0031,$0032,$0033,$0034,$0035,$0036,$0037,$0038,$0039,$003A,
    $003B,$003C,$003D,$003E,$003F,$0040,$0041,$0042,$0043,$0044,
    $0045,$0046,$0047,$0048,$0049,$004A,$004B,$004C,$004D,$004E,
    $004F,$0050,$0051,$0052,$0053,$0054,$0055,$0056,$0057,$0058,
    $0059,$005A,$005B,$005C,$005D,$005E,$005F,$0000,$0060,$0061,
    $0062,$0063,$0064,$0065,$0066,$0067,$0068,$0069,$006A,$006B,
    $006C,$006D,$006E,$006F,$0070,$0071,$0072,$0073,$0074,$0075,
    $0076,$0077,$0078,$0079,$007A,$007B,$007C,$007D,$007E,$0121,
    $0122,$0123,$0124,$0125,$0126,$0127,$0128,$0129,$012A,$012B,
    $012C,$012D,$012E,$012F,$0130,$0131,$0132,$0133,$0134,$0135,
    $0136,$0137,$0138,$0139,$013A,$013B,$013C,$013D,$013E,$013F,
    $0140,$0141,$0142,$0143,$0144,$0145,$0146,$0147,$0148,$0149,
    $014A,$014B,$014C,$014D,$014E,$014F,$0150,$0151,$0152,$0153,
    $0154,$0155,$0156,$0157,$0158,$0159,$015A,$015B,$015C,$015D,
    $015E,$015F,$0160,$0161,$0162,$0163,$0164,$0165,$0166,$0167,
    $0168,$0169,$016A,$016B,$016C,$016D,$016E,$016F,$0170,$0171,
    $0172,$0173,$0174,$0175,$0176,$0177,$0178,$0179,$017A,$017B,
    $017C,$017D,$017E,$0000,$0000,$0000);

  base64_tbl: array [0..63] of Char = (
    'A','B','C','D','E','F','G','H',     {Do not Localize}
    'I','J','K','L','M','N','O','P',      {Do not Localize}
    'Q','R','S','T','U','V','W','X',      {Do not Localize}
    'Y','Z','a','b','c','d','e','f',      {Do not Localize}
    'g','h','i','j','k','l','m','n',      {Do not Localize}
    'o','p','q','r','s','t','u','v',       {Do not Localize}
    'w','x','y','z','0','1','2','3',       {Do not Localize}
    '4','5','6','7','8','9','+','/');      {Do not Localize}

function EncodeAddressItem(EmailAddr:TIdEmailAddressItem; const HeaderEncoding: Char;
  TransferHeader: TTransfer; MimeCharSet: string): string;
var
  S : string;
  I : Integer;
  NeedEncode : Boolean;
begin
  if EmailAddr.Name <> '' then  {Do not Localize}
  begin
    NeedEncode := False;
    for I := 1 to Length(EmailAddr.Name) do
    begin
      if (EmailAddr.Name[I] < #32) or (EmailAddr.Name[I] >= #127) then
      begin
        NeedEncode := True;
        Break;
      end;
    end;
    if NeedEncode then
      S := EncodeHeader(EmailAddr.Name, csSPECIALS, HeaderEncoding, TransferHeader, MimeCharSet)
    else
    begin                { quoted string }
      S := '"';           {Do not Localize}
      for I := 1 to Length(EmailAddr.Name) do
      begin              { quote special characters }
        if (EmailAddr.Name[I] = '\') or (EmailAddr.Name[I] = '"') then S := S + '\';    {Do not Localize}
        S := S + EmailAddr.Name[I];
      end;
      S := S + '"';   {Do not Localize}
    end;
    Result := Format('%s <%s>', [S, EmailAddr.Address])    {Do not Localize}
  end
  else Result := Format('%s', [EmailAddr.Address]);     {Do not Localize}
end;

function B64(AChar: Char): Byte;
//TODO: Make this use the more efficient MIME Coder
var
  i: Integer;
begin
  for i := Low(base64_tbl) to High(base64_tbl) do begin
    if AChar = base64_tbl[i] then begin
      Result := i;
      exit;
    end;
  end;
  Result := 0;
end;

function DecodeHeader(Header: string):string;
  // I needed a Pos function that accepts a startposition
  // PosRev from IdGlobal didn't work here. If you find this useful,    {Do not Localize}
  // you can move this function to IdGlobal.pas

  function PosStartAt(const SubStr,s : string; StartPos : Cardinal = 0; IgnoreCase : boolean = false) : integer;
  begin
    if StartPos=0 then
    begin
      if IgnoreCase
      then Result := System.Pos(AnsiUpperCase(SubStr),AnsiUpperCase(s))
      else Result := System.Pos(SubStr,s)
    end else
    begin
      if IgnoreCase
      then Result := System.Pos(AnsiUpperCase(SubStr),AnsiUpperCase(System.Copy(s,StartPos,Length(s))))
      else Result := System.Pos(SubStr,System.Copy(s,StartPos,Length(s)));
      if Result>0 then Result := (Result+integer(StartPos))-1;
    end;
  end;

var
  i, l: Integer;
  HeaderEncoding,
  HeaderCharSet,
  s: string;
  a3: array [1..3] of byte;
  a4: array [1..4] of byte;
  encodingstartpos,encodingendpos:Integer;
  substring:string;
  EncodingFound : Boolean;
begin
  // Get the Charset part.
  encodingstartpos:=PosStartAt('=?ISO', UpperCase(Header),1);
  if encodingstartpos = 0 then
    encodingstartpos:=PosStartAt('=?WINDOWS', UpperCase(Header),1);

  while encodingstartpos > 0 do
  begin
    // Assume we will find the encoding
    EncodingFound := true;

    //we need 3 more question marks first and after that a '?='    {Do not Localize}
    //to find the end of the substring, we can't just search for '?=',    {Do not Localize}
    //example: '=?ISO-8859-1?Q?=E4?='    {Do not Localize}
    encodingendpos := PosStartAt('?', UpperCase(Header),encodingstartpos+5);  {Do not Localize}
    //TODO: Who the hell put gotos in here?
    //TODO: Remove these and whiplash that person
    if encodingendpos = 0 then
    begin
      EncodingFound := false;
    end;

    if EncodingFound then
    begin
      encodingendpos:=PosStartAt('?', UpperCase(Header),encodingendpos+1);  {Do not Localize}
      if encodingendpos=0 then
      begin
        EncodingFound := false;
      end;
    end;

    if EncodingFound then
    begin
      encodingendpos:=PosStartAt('?=', UpperCase(Header),encodingendpos+1);  {Do not Localize}
      if encodingendpos > 0 then
      begin
        substring:=Copy(Header,encodingstartpos,encodingendpos-encodingstartpos+2);
        //now decode the substring
        for i := 1 to 3 do
        begin
          l := Pos('?', substring);   {Do not Localize}
          substring := Copy(substring, l+1, Length(substring) - l + 1 );
          if i = 1 then
          begin
            HeaderCharSet := Copy(substring, 1, Pos('?', substring)-1)  {Do not Localize}
          end else if i = 2 then
          begin
            HeaderEncoding := copy(substring,1,1);
          end;
        end;

        //now Substring needs to end with '?=' otherwise give up!    {Do not Localize}
        if Copy(substring,Length(substring)-1,2)<>'?=' then    {Do not Localize}
        begin
          EncodingFound := false;
        end;

        // Get the HeaderEncoding
        if (AnsiSameText(HeaderEncoding, 'Q')) {Do not Localize}
        and (EncodingFound) then
        begin
          i := 1;
          s := '';        {Do not Localize}
          repeat // substring can be accessed by index here, because we know that it ends with '?='    {Do not Localize}
            if substring[i] = '_' then  {Do not Localize}
            begin
              s := s + ' ';    {Do not Localize}
            end else if (substring[i] = '=') and (Length(substring)>=i+2+2) then //make sure we can access i+2 and '?=' is still beyond    {Do not Localize}
            begin
              s := s + chr(StrToInt('$' + substring[i+1] + substring[i+2]));   {Do not Localize}
              inc(i,2);
            end else
            begin
              s := s + substring[i];
            end;
            inc(i);
          until (substring[i]='?') and (substring[i+1]='=')   {Do not Localize}
        end else if EncodingFound then
        begin
          while Length(substring) >= 4 do
          begin
            a4[1] := b64(substring[1]);
            a4[2] := b64(substring[2]);
            a4[3] := b64(substring[3]);
            a4[4] := b64(substring[4]);
            a3[1] := Byte((a4[1] shl 2) or (a4[2] shr 4));
            a3[2] := Byte((a4[2] shl 4) or (a4[3] shr 2));
            a3[3] := Byte((a4[3] shl 6) or (a4[4] shr 0));
            substring := Copy(substring, 5, Length(substring));
            s := s + CHR(a3[1]) + CHR(a3[2]) + CHR(a3[3]);
          end;
        end;

        if EncodingFound then
        begin
          if AnsiSameText(HeaderCharSet, 'ISO-2022-JP') then  {Do not Localize}
          begin
            substring := Decode2022JP(s)
          end else
          begin
            substring := s;
          end;

          //replace old substring in header with decoded one:
          header := Copy(header, 1, encodingstartpos - 1)
            + substring + Copy(header, encodingendpos + 2, Length(Header));
          substring := '';   {Do not Localize}
        end;

      end;
    end;

    encodingstartpos:=PosStartAt('=?ISO', UpperCase(Header),encodingstartpos+1);
    if encodingstartpos = 0 then
      encodingstartpos:=PosStartAt('=?WINDOWS', UpperCase(Header),encodingstartpos+1);
  end;
  //there might be #0's in header when this it b64 encoded, e.g with:    {Do not Localize}
  //decodeheader('"Fernando Corti=?ISO-8859-1?B?8Q==?=a" <[e-mail]>');    {Do not Localize}
  while Pos(#0,header)>0 do
  begin
    Delete(header,Pos(#0,header),1);
  end;
  Result:=Header;
end;

{
function DecodeHeader(Header: string):string;
var
  i, l: Integer;
  HeaderEncoding,
  HeaderCharSet,
  s: string;
  a3: array [1..3] of byte;
  a4: array [1..4] of byte;
begin
  // Get the Charset part.
  if Pos('=?ISO', UpperCase(Header)) > 0 then
  begin
    for i := 1 to 3 do begin
      l := Pos('?', Header);
      Header := Copy(Header, l+1, Length(Header) - l + 1 );
      if i = 1 then HeaderCharSet := Copy(Header, 1, Pos('?', Header)-1)
      else if i = 2 then HeaderEncoding := Header[1];
    end;
    // Get the HeaderEncoding
    if AnsiSameText(HeaderEncoding, 'Q') then begin
      i := 1;
      repeat
        if Header[i] = '_' then
          s := s + ' '
        else if Header[i] = '=' then begin
          s := s + chr(StrToInt('$' + Header[i+1] + Header[i+2]));
          inc(i,2);
        end else
          s := s + Header[i];
        inc(i);
      until (Header[i]='?') and (Header[i+1]='=')
    end
    else begin
      while Length(Header) >= 4 do begin
        a4[1] := b64(Header[1]);
        a4[2] := b64(Header[2]);
        a4[3] := b64(Header[3]);
        a4[4] := b64(Header[4]);
        a3[1] := (a4[1] shl 2) or (a4[2] shr 4);
        a3[2] := (a4[2] shl 4) or (a4[3] shr 2);
        a3[3] := (a4[3] shl 6) or (a4[4] shr 0);
        Header := Copy(Header, 5, Length(Header));
        s := s + CHR(a3[1]) + CHR(a3[2]) + CHR(a3[3]);
      end;
    end;