mimedec.pas

灰鸽子1.23源码,,,,,,,

                                                     write FOnPartEnd;
        property OnMessageEnd : TNotifyEvent         read  FOnMessageEnd
                                                     write FOnMessageEnd;
        property OnInlineDecodeBegin : TInlineDecodeBegin
                                                     read  FOnInlineDecodeBegin
                                                     write FOnInlineDecodeBegin;
        property OnInlineDecodeLine  : TInlineDecodeLine
                                                     read  FOnInlineDecodeLine
                                                     write FOnInlineDecodeLine;
        property OnInlineDecodeEnd   : TInlineDecodeEnd
                                                     read  FOnInlineDecodeEnd
                                                     write FOnInlineDecodeEnd;
    end;

procedure Register;

implementation

type
  TLookup = array [0..127] of Byte;

const
Base64In: TLookup = (
    255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    255, 255, 255, 255,  62, 255, 255, 255,  63,  52,  53,  54,  55,
     56,  57,  58,  59,  60,  61, 255, 255, 255,  64, 255, 255, 255,
      0,   1,   2,   3,   4,   5,   6,   7,   8,   9,  10,  11,  12,
     13,  14,  15,  16,  17,  18,  19,  20,  21,  22,  23,  24,  25,
    255, 255, 255, 255, 255, 255,  26,  27,  28,  29,  30,  31,  32,
     33,  34,  35,  36,  37,  38,  39,  40,  41,  42,  43,  44,  45,
     46,  47,  48,  49,  50,  51, 255, 255, 255, 255, 255
);


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure Register;
begin
    RegisterComponents('FPiette', [TMimeDecode]);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
function TrimRight(Str : String) : String;
var
    i : Integer;
begin
    i := Length(Str);
    while (i > 0) and (Str[i] in [' ', #9]) do
        i := i - 1;
    Result := Copy(Str, 1, i);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TrimLeft(Str : String) : String;
var
    i : Integer;
begin
    if Str[1] <> ' ' then
        Result := Str
    else begin
        i := 1;
        while (i <= Length(Str)) and (Str[i] = ' ') do
            i := i + 1;
        Result := Copy(Str, i, Length(Str) - i + 1);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function Trim(Str : String) : String;
begin
    Result := TrimLeft(TrimRight(Str));
end;
{$ENDIF}


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function HexConv(Ch : Char) : Integer;
begin
    if Ch in ['0'..'9'] then
        Result := Ord(Ch) - Ord('0')
    else
    	Result := (Ord(Ch) and 15) + 9;
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TMimeDecode.Create(AOwner : TComponent);
begin
    inherited Create(AOwner);
    FHeaderLines := TStringList.Create;
    FIsMultipart := FALSE;
    FEndOfMime   := FALSE;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TMimeDecode.Destroy;
begin
    if Assigned(FHeaderLines) then begin
        FHeaderLines.Destroy;
        FHeaderLines := nil;
    end;
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerHeaderBegin;
begin
    if Assigned(FOnHeaderBegin) then
        FOnHeaderBegin(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerHeaderLine;
begin
    if Assigned(FOnHeaderLine) then
        FOnHeaderLine(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerHeaderEnd;
begin
    if Assigned(FOnHeaderEnd) then
        FOnHeaderEnd(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerPartHeaderBegin;
begin
    if Assigned(FOnPartHeaderBegin) then
        FOnPartHeaderBegin(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerPartHeaderLine;
begin
    if Assigned(FOnPartHeaderLine) then
    	FOnPartHeaderLine(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerPartHeaderEnd;
begin
    if Assigned(FOnPartHeaderEnd) then
        FOnPartHeaderEnd(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerPartBegin;
begin
    if Assigned(FOnPartBegin) then
    	FOnPartBegin(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerPartLine(Data : PChar; DataLen : Integer);
begin
    if Assigned(FOnPartLine) then
        FOnPartLine(Self, Data, DataLen);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerPartEnd;
begin
    if Assigned(FOnPartEnd) then
        FOnPartEnd(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.TriggerMessageEnd;
begin
    if Assigned(FOnMessageEnd) then
        FOnMessageEnd(Self);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.ProcessDecodedLine(Line : PChar; Len : Integer);
begin
    if Len > 0 then begin
    	if (FPartContentType = '')  { Not sure it is always OK !              }
                                    { As such we can't have a MIME part which }
                                    { is uu-encoded.                          }
           and uuprocessline(line) then
            Exit;
    end;
    TriggerPartLine(Line, Len);

    { Write decoded characters to the destination stream }
    if Assigned(FDestStream) and (Len > 0) then
    	FDestStream.WriteBuffer(Line^, Len);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This works if charset="iso-8859-1" !                                        }
procedure TMimeDecode.ProcessLineQuotedPrintable;
var
    SourceIndex         : Integer;
    DecodedIndex        : Integer;
    Ch                  : Char;
    Code                : Integer;
    OldCh		: Char; {tap}
begin
    SourceIndex  := 0;
    DecodedIndex := 0;
    OldCh := #0;{tap}
{	if (FCurrentData <> nil) and (FCurrentData^ <> #0) then begin  --empty line means \r\n}
	if (FCurrentData <> nil) then begin
        while TRUE do begin
            Ch := FCurrentData[SourceIndex];
            if Ch = #0 then begin
                { Nov 25, 1999: Ken Petersen told me to insert CRLF }
                FCurrentData[DecodedIndex] := #13;
                Inc(DecodedIndex);
                FCurrentData[DecodedIndex] := #10;
                Inc(DecodedIndex);
                break;
            end;
            if Ch <> '=' then begin
                FCurrentData[DecodedIndex] := Ch;
                Inc(SourceIndex);
                Inc(DecodedIndex);
            end
            else begin
                Inc(SourceIndex);
                Ch := FCurrentData[SourceIndex];
                if Ch <> #0 then begin
                    Code := HexConv(Ch);
                    Inc(SourceIndex);
                    Ch := FCurrentData[SourceIndex];
                    if Ch <> #0 then begin
                        Code := (Code shl 4) + HexConv(Ch);
                        Inc(SourceIndex);
                    end;
                    FCurrentData[DecodedIndex] := Chr(Code);
                    Inc(DecodedIndex);
                end
                else begin {tap: "=\0" means line continuation}
                    break; {tap}
                end;
            end;
        end;
        {tap: if there is no quoted-string-mapping then the first char of the next msgline will be overwritten}
        OldCh := FCurrentData[DecodedIndex]; {tap}
        FCurrentData[DecodedIndex] := #0;
    end;

    ProcessDecodedLine(FCurrentData, DecodedIndex);
    if (OldCh <> #0) then {tap}
        FCurrentData[DecodedIndex] := OldCh; {tap}
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.ProcessLineBase64;
var
    ByteCount           : Integer;
    SourceIndex         : Integer;
    DataOut             : array[0..2] of Byte;
    DataIn0             : Byte;
    DataIn1             : Byte;
    DataIn2             : Byte;
    DataIn3             : Byte;
    DecodedIndex        : Integer;
begin
    DecodedIndex := 0;

    { Skip white spaces }
    SourceIndex := 0;
    while (FCurrentData[SourceIndex] <> #0) and
          (FCurrentData[SourceIndex] = ' ') do
        Inc(SourceIndex);

    { Decode until end of line. Replace coded chars by decoded ones }
    while (FCurrentData[SourceIndex] <> #0) and
          (FCurrentData[SourceIndex] <> ' ') do begin
        DataIn0 := Base64In[Byte(FCurrentData[SourceIndex + 0])];
        DataIn1 := Base64In[Byte(FCurrentData[SourceIndex + 1])];
        DataIn2 := Base64In[Byte(FCurrentData[SourceIndex + 2])];
        DataIn3 := Base64In[Byte(FCurrentData[SourceIndex + 3])];

        DataOut[0] := (DataIn0 and $3F) shl 2 + (DataIn1 and $30) shr 4;
        if DataIn2 <> $40 then begin
            DataOut[1] := (DataIn1 and $0F) shl 4 + (DataIn2 and $3C) shr 2;
            if DataIn3 <> $40 then begin
                DataOut[2] := (DataIn2 and $03) shl 6 + (DataIn3 and $3F);
                ByteCount := 3;
            end
            else
                ByteCount := 2;
        end
        else
            ByteCount := 1;

		{ Replace coded characters (4) by decoded characters (up to 3) }
        Move(DataOut, FCurrentData[DecodedIndex], ByteCount);
        DecodedIndex := DecodedIndex + ByteCount;

        SourceIndex := SourceIndex + 4;
    end;

    { Nul terminate decoded line }
    FCurrentData[DecodedIndex] := #0; { 16/02/99 }
    ProcessDecodedLine(FCurrentData, DecodedIndex);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function UUDec(Sym : Char): Byte;
begin
    if Sym = #0 then
        Result := 0
    else
        Result := (Ord(Sym) - Ord(' ')) and $3F;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure UUOutDec(buf: PChar; n: Integer; var out1 : String);
begin
    case n of
    0:   ;
    1:   out1 := out1 + Char((UUDec(buf[0]) SHL 2) + (UUDec(buf[1]) SHR 4));
    2:   out1 := out1 + Char((UUDec(buf[0]) SHL 2) + (UUDec(buf[1]) SHR 4)) +
                        Char((UUDec(buf[1]) SHL 4) + (UUDec(buf[2]) SHR 2));
    else out1 := out1 + Char((UUDec(buf[0]) SHL 2) + (UUDec(buf[1]) SHR 4)) +
                        Char((UUDec(buf[1]) SHL 4) + (UUDec(buf[2]) SHR 2)) +
                        Char((UUDec(buf[2]) SHL 6) + (UUDec(buf[3])));
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF NEVER}
procedure UUOutDec(buf: PChar; n: Integer; var out1 : String);
var
    c1, c2, c3: Char;
begin
    c1 := Chr((word(UUDec(buf[0])) SHL 2) or (word(UUDec(buf[1])) SHR 4));
    c2 := Chr((word(UUDec(buf[1])) SHL 4) or (word(UUDec(buf[2])) SHR 2));
    c3 := Chr((word(UUDec(buf[2])) SHL 6) or (word(UUDec(buf[3]))));
    if n >= 1 then
        out1 := out1 + c1;
    if n >= 2 then
        out1 := out1 + c2;
    if n >= 3 then
        out1 := out1 + c3;
end;
{$ENDIF}


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.ProcessLineUUDecode; { ##ERIC }
var
    count, Size : Integer;
    s           : String;
    out1        : String;
    bp          : PChar;
    pos1        : Integer;
begin
    if FCurrentData^ = #0 then
        exit;
    s := StrPas(FCurrentData);

    if LowerCase(copy(s, 1, 6)) = 'begin ' then begin
        out1:=lowercase(s);
        if (Pos('--', out1) > 0) and (Pos('cut here', out1) > 0) then
            Exit;
        pos1 := Pos(' ', s);