mimedec.pas

互联网套件

    FPartFileName            := '';
    FHeaderFlag              := TRUE;  { We begin by a header }
    FLineNum                 := 0;
    FPartHeaderBeginSignaled := FALSE;
    FNext                    := ProcessPartHeaderLine;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.ProcessPartLine;	{ ##ERIC }
var
    Len : Integer;
    t   : Integer;
    s   : String;		{ ##ERIC }
begin
    { Check if end of part (boundary line found) }
    if (FCurrentData <> nil) and (FCurrentData^ <> #0) then begin
    	s := LowerCase(StrPas(FCurrentData));
        if (s = FBoundary) or
           (s = (FBoundary + '--')) then begin
            PreparePart;
            exit;
        end
        else begin
            for t := 0 to FEmbeddedBoundary.Count - 1 do begin
                if (s = FEmbeddedBoundary[t]) or
                   (s = (FEmbeddedBoundary[t] + '--')) then begin
                    { we now have to wait for the next part }
          	    PreparePart;
                    exit;
                end
            end;
        end;
    end;

    if not FPartOpened then begin
        FPartOpened := TRUE;
        TriggerPartBegin;
    end;

    if FPartEncoding = 'base64' then
        ProcessLineBase64
    else if FPartEncoding = 'quoted-printable' then
        ProcessLineQuotedPrintable
    else if FPartEncoding = 'x-uuencode' then	{ ##ERIC }
        ProcessLineUUDecode										{ ##ERIC }
    else begin
        if FCurrentData = nil then
            Len := 0
        else
            Len := StrLen(FCurrentData);
        ProcessDecodedLine(FCurrentData, Len);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.ProcessPartHeaderLine;
var
    p       : PChar;
    Delim   : Char;
    Token   : String;
    KeyWord : String;
    Value   : String;
    Value1  : String;
begin
    if (FCurrentData = nil) or (FCurrentData^ = #0) then begin
        { End of part header }
        if not FPartHeaderBeginSignaled then begin
            Inc(FPartNumber);
            TriggerPartHeaderBegin;
        end;
        TriggerPartHeaderEnd;
        FHeaderFlag := FALSE;  { Remember we are no more in a header }
        FLineNum    := 0;
        FNext       := ProcessPartLine;
        Exit;
    end;

    Inc(FLineNum);
    if FLineNum = 1 then begin
        Inc(FPartNumber);
        FPartHeaderBeginSignaled := TRUE;
        TriggerPartHeaderBegin;
{       FEmbeddedBoundary.clear; }
    end;

    { A header line can't begin with a space nor tab char. If we got that }
    { then we consider the header as begin finished and process line      }
    if FHeaderFlag and (FCurrentData[0] in [' ', #9]) then begin
        TriggerPartHeaderEnd;
        FHeaderFlag := FALSE;
        FLineNum    := 0;
        FNext       := ProcessPartLine;
        ProcessPartLine;
        Exit;
    end;

    p := GetToken(FCurrentData, KeyWord, Delim);
    if KeyWord = 'content-type' then begin
        p := GetToken(p, FPartContentType, Delim);
        while Delim = ';' do begin
            p := GetToken(p, Token, Delim);
            if Delim = '=' then begin
                p := GetToken(p, Value, Delim);
                if Token = 'name' then
                    FPartName := Value
                else if Token = 'charset' then
                    FPartCharset := Value
                else if Token = 'boundary' then begin                { ##ERIC }
                    { we have an embedded boundary }		     { ##ERIC }
                    Value := Value + #0;  { NUL terminate string for Delphi 1 }
                    GetQuoted(@Value[1], Value1);		     { ##ERIC }
                    FEmbeddedBoundary.Add('--' + LowerCase(Value1)); { ##ERIC }
                end;																				{ ##ERIC }
            end;
        end;
    end
    else if KeyWord = 'content-transfer-encoding' then begin
        GetToken(p, FPartEncoding, Delim);
    end
    else if KeyWord = 'content-disposition' then begin
        p := GetToken(p, FPartDisposition, Delim);
        while Delim = ';' do begin
            p := GetToken(p, Token, Delim);
            if Delim = '=' then begin
                p := GetQuoted(p, Value);
                if Token = 'filename' then
                    FPartFileName := Value;
            end;
        end;
    end;

    TriggerPartHeaderLine;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.ProcessHeaderLine;
var
    p     : PChar;
    pVal  : PChar;
    Delim : Char;
    Token : String;
    Value : String;
begin
    if (FCurrentData = nil) or (FCurrentData^ = #0) then begin
        FHeaderFlag := FALSE;  { We are no more in a header }
        TriggerHeaderEnd;
        FLineNum    := 0;
        if FBoundary = '' then begin
            FNext := ProcessMessageLine;
        end
        else begin
            TriggerPartBegin;
            FNext := ProcessWaitBoundary;
        end;
        Exit;
    end;

    Inc(FLineNum);
    if FLineNum = 1 then
        TriggerHeaderBegin;

    p    := GetToken(FCurrentData, Token, Delim);
    pVal := StpBlk(p);
    if Delim = ':' then begin
        p := GetToken(p, Value, Delim);

        if Token = 'content-type' then begin
            FContentType := Value;
            if Pos('multipart/', FContentType) = 1 then begin	{ ##ERIC }
                p := GetToken(p, Token, Delim);
                if Token = 'boundary' then begin
                    GetQuoted(p, FBoundary);
                    FBoundary := lowercase('--' + FBoundary);	{ ##ERIC }
                end;
            end;
        end
        else if Token = 'mime-version' then
            FMimeVersion := StrPas(pVal)
        else if Token = 'from' then
            FFrom := StrPas(pVal)
        else if Token = 'to' then
            FDest := StrPas(pVal)
        else if Token = 'subject' then
            FSubject := StrPas(pVal)
        else if Token = 'return-path' then begin
            FReturnPath := StrPas(pVal);
            if (Length(FReturnPath) >= 2) and
               (FReturnPath[1] = '<') and
               (FReturnPath[Length(FReturnPath)] = '>') then
                FReturnPath := Copy(FReturnPath, 2, Length(FReturnPath) - 2);
        end
        else if Token = 'date' then
            FDate := StrPas(pVal)
        else if Token = 'content-transfer-encoding' then
            GetToken(pVal, FEncoding, Delim);
    end;

    TriggerHeaderLine;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.MessageEnd;
begin
    if (FBoundary = '') or FPartOpened then
        TriggerPartEnd;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.MessageBegin;
begin
    FFrom             := '';
    FDest             := '';
    FSubject          := '';
    FContentType      := '';
    FMimeVersion      := '';
    FPartContentType  := '';
    FPartEncoding     := '';
    FApplicationType  := '';
    FPartName         := '';
    FPartFileName     := '';
    FPartDisposition  := '';
    FPartCharset      := '';
    FApplicationType  := '';
    FPartNumber       := 0;
    FLineNum          := 0;
    FBoundary         := '';
    FCurrentData      := nil;
    FHeaderFlag       := TRUE;
    FPartOpened       := FALSE;
    FNext             := ProcessHeaderLine;
    FEmbeddedBoundary.Clear; { ##ERIC }
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.DecodeFile(FileName : String);
var
    aStream  : TStream;
begin
    aStream  := TFileStream.Create(FileName, fmOpenRead);
    try
        DecodeStream(aStream);
    finally
        aStream.Destroy;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMimeDecode.DecodeStream(aStream : TStream);
begin
    FBufferSize := 2048;      { Start with a reasonable FBuffer }
    GetMem(FBuffer, FBufferSize);
    try
        cUUFilename       := '';                    { ##ERIC }
        FEmbeddedBoundary := TStringList.Create;    { ##ERIC }
        try
            InternalDecodeStream(aStream);
        finally
            FEmbeddedBoundary.Free;		    { ##ERIC }
        end;
    finally
        FreeMem(FBuffer, FBufferSize);
        FBuffer     := nil;
        FBufferSize := 0;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This routine use an intelligent buffer management, trying to move data    }
{ the less possible times. The buffer is enlarged as necessary to contains  }
{ the largest line we encounter.                                            }
procedure TMimeDecode.InternalDecodeStream(aStream : TStream);
var
    RdCnt   : LongInt;
    nUsed   : Integer;
    nStart  : Integer;
    nLast   : Integer;
    nSearch : Integer;
    I, J    : Integer;
begin
    nUsed  := 0;
    nStart := 0;
    MessageBegin;
    while TRUE do begin
        nSearch := nStart + nUsed;
        RdCnt   := aStream.Read(FBuffer[nSearch],
                                FBufferSize - nUsed - nStart -
                                2);  { for next char and #0 }
        if RdCnt <= 0 then begin
            break;
        end;

        nUsed  := nUsed + RdCnt;
        nLast  := nStart + nUsed;

        { Nul terminate the FBuffer }
        FBuffer[nLast] := #0;

        { Search for terminating line feed }
        while TRUE do begin
            I := nSearch;
            while (I < nLast) and (FBuffer[I] <> #10) do
                Inc(I);
            if I >= nLast then begin
                { We did'nt find any LF in the FBuffer, need to read more ! }
                if nStart > (3 * (FBufferSize div 4)) then begin
                    { Reuse start of FBuffer because 3/4 buffer is unused   }
                    Move(FBuffer[nStart], FBuffer[0], nUsed + 1);
                    nStart := 0;
                end
                else begin
                    { Makes FBuffer larger }
                    {$IFDEF VER80}
                    FBuffer := ReallocMem(FBuffer, FBufferSize, FBufferSize + 32);
                    {$ELSE}
                    ReallocMem(FBuffer, FBufferSize + 32);
                    {$ENDIF}
                    FBufferSize := FBufferSize + 32;
                end;
                break;
            end;

            { We found a line feed, process FBuffer up to this point }
            { Remove any preceding CR                               }
            if (I > nStart) and (FBuffer[I - 1] = #13) then
                j := I - 1
            else
                J := I;

            { We found a LF, if we are processing a header, we must     }
            { have the next character to see if the line is continuated }
            if FHeaderFlag then begin
                if I >= (nLast - 1) then begin
                    { We don't have the next character in our FBuffer, }
                    { we need to read more data                       }
                    { Read a single byte at the end of the FBuffer     }
                    { We have room because we preserved it previously }
                    RdCnt := aStream.Read(FBuffer[I + 1], 1);
                    if RdCnt > 0 then begin
                        { We have read the next char }
                        Inc(nLast);
                        Inc(nUsed);
                        FBuffer[I + 2] := #0;
                    end;
                end;

                if I < nLast then begin
                    if (not (FBuffer[nStart] in [#10, #13])) and  { 27/08/98 }
                       (FBuffer[I + 1] in [' ', #9]) then begin
                        { We have a continuation line, replace CR/LF by spaces }
                        FBuffer[I]     := ' ';
                        FBuffer[J]     := ' ';
                        FBuffer[I + 1] := ' ';
                        nSearch   := I;
                        { and search new end of line }
                        continue;
                    end;
                end;
            end;

            FBuffer[J] := #0;
            FCurrentData := FBuffer + nStart;

            FNext;
            FBuffer[J] := #10;
            nStart := I + 1;
            nUsed  := nLast - nStart;
            nSearch := nStart;
        end;
    end;
    { Process the last line }
    if nUsed > 0 then begin
        FCurrentData := FBuffer + nStart;
        FNext;
    end;

    MessageEnd;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.