smtpprot.pas

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

    { can't use the AUTH command.                                         }
    if (not FESmtpSupported)
      then begin
        FLastResponse := '500 ESMTP not supported.';
        SetErrorMessage;
        TriggerRequestDone(500);
        Exit;
      end;

    FFctPrv := smtpFctAuth;
    case FAuthType of
      smtpAuthNone :
        begin
          { shouldn't happen }
          FLastResponse := '500 No Authorization Type Selected.';
          SetErrorMessage;
          TriggerRequestDone(500);
          Exit;
        end;
      smtpAuthPlain :
        begin
           AuthPlain := FUsername;
           AuthPlain := AuthPlain + #0;
           if (FFromName <> '') {FromName should be set before calling Auth}
             then
               AuthPlain := AuthPlain + FFromname
             else
               AuthPlain := AuthPlain + FUsername;
           AuthPlain := AuthPlain + #0;
           AuthPlain := AuthPlain + FPassword;
           AuthPlain := Base64Encode(AuthPlain);
           ExecAsync(smtpAuth, 'AUTH PLAIN ' + AuthPlain, [235], nil);
        end;
      smtpAuthLogin :
        begin
          ExecAsync(smtpAuth, 'AUTH LOGIN', [334], AuthNextLogin);
        end;
      smtpAuthCramMD5 :
        begin
          ExecAsync(smtpAuth, 'AUTH CRAM-MD5', [334], AuthNextCramMD5);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.AuthNextLogin;
begin
    { If there was an error, tell the user and exit.                      }
    if (FRequestResult <> 0)
      then begin
        TriggerRequestDone(FRequestResult);
        Exit;
      end;

    FState := smtpInternalReady;
    ExecAsync(smtpAuth, Base64Encode(FUsername), [334], AuthNextLoginNext);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.AuthNextLoginNext;
begin
    { If there was an error, tell the user and exit.                      }
    if (FRequestResult <> 0)
      then begin
        TriggerRequestDone(FRequestResult);
        Exit;
      end;

    FState := smtpInternalReady;
    ExecAsync(smtpAuth, Base64Encode(FPassword), [235], nil);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.AuthNextCramMD5;
var
  Challenge  : String;
  Response   : String;
  HexDigits  : String;
  MD5Digest  : TMD5Digest;
  MD5Context : TMD5Context;
  Count      : Integer;
  IPAD       : Array[0..63] of Byte;
  OPAD       : Array[0..63] of Byte;
begin
    { If there was an error, tell the user and exit.                      }
    if (FRequestResult <> 0)
      then begin
        TriggerRequestDone(FRequestResult);
        Exit;
      end;

    { Server should be returning something like                           }
    {   334 PDEyMzc5MTU3NTAtNjMwNTcxMzRAZm9vLmJhci5jb20+                  }
    { If it does not, then exit.                                          }
    if (Length(FLastResponse) < 5)
      then begin
        FLastResponse := '500 Malformed MD5 Challege: ' + FLastResponse;
        SetErrorMessage;
        TriggerRequestDone(500);
        Exit;
      end;

    Challenge := Copy(FLastResponse, 5, Length(FLastResponse) - 4);

    Challenge := Base64Decode(Challenge);

    {See RFC2104 }
    for Count := 0 to 63 do
      begin
        if ((Count+1) <= Length(FPassword))
          then begin
            IPAD[Count] := Byte(FPassword[Count+1]) xor $36;
            OPAD[Count] := Byte(FPassword[Count+1]) xor $5C;
          end
          else begin
            IPAD[Count] := 0 xor $36;
            OPAD[Count] := 0 xor $5C;
          end;
      end;

    MD5Init(MD5Context);
    MD5Update(MD5Context, IPAD, 64);
    MD5UpdateBuffer(MD5Context, @Challenge[1], Length(Challenge));
    MD5Final(MD5Digest, MD5Context);

    MD5Init(MD5Context);
    MD5Update(MD5Context, OPAD, 64);
    MD5Update(MD5Context, MD5Digest, 16);
    MD5Final(MD5Digest, MD5Context);

    HexDigits := '0123456789abcdef';
    Response := FUsername;
    Response := Response + ' ';
    for Count := 0 to 15 do
      begin
        Response := Response + HexDigits[((Byte(MD5Digest[Count]) and $F0) shr 4)+1];
        Response := Response + HexDigits[(Byte(MD5Digest[Count]) and $0F)+1];
      end;

    FState := smtpInternalReady;
    ExecAsync(smtpAuth, Base64Encode(Response), [235], nil);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.Vrfy;
begin
    FFctPrv := smtpFctVrfy;
    ExecAsync(smtpVrfy, 'VRFY ' + FHdrTo, [250], nil);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.MailFrom;
begin
    FFctPrv := smtpFctMailFrom;
    if (Pos('<', FFromName) <> 0) and (Pos('>', FFromName) <> 0) then
        ExecAsync(smtpMailFrom, 'MAIL FROM:' + Trim(FFromName), [250], nil)
    else
        ExecAsync(smtpMailFrom,
                  'MAIL FROM:<' + Trim(FFromName) + '>', [250], nil)
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.Rset;
begin
    FFctPrv := smtpFctRset;
    ExecAsync(smtpRset, 'RSET', [250], nil);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.RcptTo;
begin
    if FRcptName.Count <= 0 then
        raise SmtpException.Create('RcptName list is empty');

    FItemCount := -1;
    RcptToNext;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.RcptToNext;
var
    WhenDone : TSmtpNextProc;
begin
    Inc(FItemCount);
    if FItemCount >= (FRcptName.Count - 1) then
        WhenDone := nil
    else
        WhenDone := RcptToDone;
    FFctPrv    := smtpFctRcptTo;
    if (Pos('<', FRcptName.Strings[FItemCount]) <> 0) and
       (Pos('>', FRcptName.Strings[FItemCount]) <> 0) then
        ExecAsync(smtpRcptTo,
                  'RCPT TO:' + Trim(FRcptName.Strings[FItemCount]),
                  [250, 251], WhenDone)
    else
        ExecAsync(smtpRcptTo,
                  'RCPT TO:<' + Trim(FRcptName.Strings[FItemCount])+ '>',
                  [250, 251], WhenDone);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.RcptToDone;
begin
    FState := smtpInternalReady;
    RcptToNext;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.SetContentType(newValue : TSmtpContentType);
begin
    if FContentType = newValue then
        Exit;
    FContentType := newValue;
    if FContentType = smtpPlainText then
        FContentTypeStr := 'text/plain'
    else
        FContentTypeStr := 'text/html';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.Data;
begin
    FLineNum   := 0;
    FMoreLines := TRUE;
    FItemCount := -1;
    if not Assigned(FHdrLines) then
        FHdrLines := TStringList.Create
    else
        FHdrLines.Clear;
    if not FOwnHeaders then begin
        { Angus V2.21 - the body must contain all the headers }
        if Length(Trim(FHdrReplyTo)) > 0 then
            FHdrLines.Add('Reply-To: '    + FHdrReplyTo);
        if Length(Trim(FHdrReturnPath)) > 0 then
            FHdrLines.Add('Return-Path: '    + FHdrReturnPath);
        if Length(FHdrFrom) > 0 then
            FHdrLines.Add('From: '    + FHdrFrom);
        if Length(FHdrTo) > 0 then
            FHdrLines.Add('To: '      + FHdrTo);
        if Length(FHdrCc) > 0 then
            FHdrLines.Add('Cc: '      + FHdrCc);
        FHdrLines.Add('Subject: ' + FHdrSubject);
        if Length(Trim(FHdrSender)) > 0 then
            FHdrLines.Add('Sender: ' + FHdrSender)
        else if Length(Trim(FHdrFrom)) > 0 then
            FHdrLines.Add('Sender: ' + FHdrFrom);
        FHdrLines.Add('Mime-Version: 1.0');
        FHdrLines.Add('Content-Type: ' + FContentTypeStr + '; charset="' + FCharSet + '"');
        FHdrLines.Add('Date: ' + Rfc822DateTime(Now));
        FHdrLines.Add('X-Mailer: ICS SMTP Component V' +
                      IntToStr(SmtpCliVersion div 100) + '.' +
                      IntToStr(SmtpCliVersion mod 100));
        TriggerProcessHeader(FHdrLines);
        { An empty line mark the header's end }
        FHdrLines.Add('');
    end
    else
        FItemCount := 0;
    FFctPrv := smtpFctData;
    ExecAsync(smtpData, 'DATA', [354], DataNext);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCustomSmtpClient.DataNext;
var
    MsgLine  : array [0..1023] of char;
begin
    { If we have been disconnected, then do nothing.                      }
    { RequestDone event handler is called from socket SessionClose event. }
    if not FConnected then begin
        FWSocket.OnDataSent := nil;
        Exit;
    end;

    Inc(FItemCount);
    if FItemCount < FHdrLines.Count then begin
        { There are still header lines to send }
        StrPCopy(@MsgLine, FHdrLines.Strings[FItemCount]);
        TriggerHeaderLine(@MsgLine, SizeOf(MsgLine));
        TriggerDisplay('> ' + StrPas(MsgLine));
        FWSocket.OnDataSent := WSocketDataSent;
        FWSocket.PutDataInSendBuffer(@MsgLine, strlen(MsgLine));
        FWSocket.SendStr(#13+#10);
    end
    else begin
        { Now we need to send data lines }
        if FMoreLines then begin
            try
                Inc(FLineNum);
                TriggerGetData(FLineNum, @MsgLine, High(MsgLine), FMoreLines);
            except
                FMoreLines := FALSE;
            end;
        end;

        if FMoreLines then begin
            if MsgLine[0] = '.' then
                Move(MsgLine[0], MsgLine[1], StrLen(MsgLine) + 1);
            TriggerDisplay('> ' + StrPas(MsgLine));
            FWSocket.OnDataSent := WSocketDataSent;
            FWSocket.PutDataInSendBuffer(@MsgLine, StrLen(MsgLine));
            FWSocket.SendStr(#13 + #10);
        end
        else begin
            { Send the last message line }
            FWSocket.OnDataSent := nil;
            ExecAsync(smtpData, '.', [250], nil);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TCusto