alsmtpclient.pas

Description: TALsmtpClient class implements the SMTP protocol (RFC-821)

      fContentType := self.fContentType;
      FCustomHeaders.Assign(FCustomHeaders);
    end;
  end
  else inherited AssignTo(Dest);
end;

{**********************************}
procedure TALSMTPClientHeader.Clear;
begin
  fSendTo := '';
  fSender := '';
  fMessageID := '';
  fbcc := '';
  fContentTransferEncoding := '';
  fComments := '';
  fMIMEVersion := '';
  fPriority := '';
  fReplyTo := '';
  fSubject := '';
  fFrom := '';
  fDate := '';
  fDispositionNotificationTo := '';
  fReferences := '';
  fcc := '';
  fContentType := '';
  FCustomHeaders.Clear;
end;

{*************************************}
constructor TALSMTPClientHeader.Create;
begin
  inherited create;
  FCustomHeaders:= TstringList.create;
  FCustomHeaders.Delimiter := ':';
  clear;
  fMessageID := 'AUTO';
  fMIMEVersion := '1.0';
  fDate := 'NOW';
  fContentType := 'text/plain';
end;

{*************************************}
destructor TALSMTPClientHeader.Destroy;
begin
  FCustomHeaders.free;
  inherited;
end;

{****************************************************}
function TALSMTPClientHeader.GetRawHeaderText: String;
Var i : integer;
    Str: String;
begin
  Result := '';
  If Trim(fFrom) <> '' then result := result + 'From: ' + trim(fFrom) + #13#10;
  If Trim(fSender) <> '' then result := result + 'Sender: ' + trim(fSender) + #13#10;
  If Trim(fSendTo) <> '' then result := result + 'To: ' + trim(fSendTo) + #13#10;
  If Trim(fcc) <> '' then result := result + 'cc: ' + trim(fcc) + #13#10;
  If Trim(fbcc) <> '' then result := result + 'bcc: ' + trim(fbcc) + #13#10;
  If Trim(fReplyTo) <> '' then result := result + 'Reply-To: ' + trim(fReplyTo) + #13#10;
  If Trim(fSubject) <> '' then result := result + 'Subject: ' + trim(fSubject) + #13#10;
  Str := fMessageID;
  If Trim(str) <> '' then begin
    If sametext(Str, 'AUTO') then Str := '<' + AlSMTPClientGenerateMessageID + '>';
    result := result + 'Message-ID: ' + trim(str) + #13#10;
  end;
  If Trim(fReferences) <> '' then result := result + 'References: ' + trim(fReferences) + #13#10;
  If Trim(fComments) <> '' then result := result + 'Comments: ' + trim(fComments) + #13#10;
  Str := fDate;
  If Trim(str) <> '' then begin
    If sametext(Str, 'NOW') then Str := ALDateTimeToRfc822Str(Now);
    result := result + 'Date: ' + trim(str) + #13#10;
  end;
  If Trim(fContentType) <> '' then result := result + 'Content-Type: ' + trim(fContentType) + #13#10;
  If Trim(fContentTransferEncoding) <> '' then result := result + 'Content-Transfer-Encoding: ' + trim(fContentTransferEncoding) + #13#10;
  If Trim(fMIMEVersion) <> '' then result := result + 'MIME-Version: ' + trim(fMIMEVersion) + #13#10;
  If Trim(fPriority) <> '' then result := result + 'Priority: ' + trim(fPriority) + #13#10;
  If Trim(fDispositionNotificationTo) <> '' then result := result + 'Disposition-Notification-To: ' + trim(fDispositionNotificationTo) + #13#10;
  For i := 0 to FCustomHeaders.count - 1 do
    if (trim(FCustomHeaders.names[i]) <> '') and (trim(FCustomHeaders.Values[FCustomHeaders.names[i]]) <> '') then
      result := result + FCustomHeaders.names[i] + ': ' + trim(FCustomHeaders.Values[FCustomHeaders.names[i]]) + #13#10;
end;

{***************************************************************************}
procedure TALSMTPClientHeader.SetRawHeaderText(const aRawHeaderText: string);
Var aRawHeaderLst: TstringList;

  {-------------------------------------}
  Function AlG001(aName: String): String;
  Var i, index: Integer;
      Str: String;
      bFound: boolean;
  Begin
    result := '';
    bFound:= false;
    for i:= 0 to aRawHeaderLst.Count - 1 do
    begin
      index := pos(aname, aRawHeaderLst[i]);
      if index = 1 then
      begin
        bFound := true;
        break;
      end;
    end;

    if not bFound then exit;
    result := copy(aRawHeaderLst[i], index + Length(aName) + 1, Length(aRawHeaderLst[i]));
    result := Trim(result);
    //aRawHeaderLst.Delete(i);

    //I := aRawHeaderLst.IndexOfName(aName);
    //If I >= 0 then Begin
    //  result := Trim(aRawHeaderLst.Values[aName]);
    //  aRawHeaderLst.Delete(i);
      While True do begin
        If i >= aRawHeaderLst.Count then break;
        str := aRawHeaderLst[i];
        If (str = '') or
           (not (str[1] in [' ',#9])) then break; //(1) an empty line or (2) a line that does not start with a space, a tab, or a field name followed by a colon
        Result := trim(result + ' ' + trim(str));
        aRawHeaderLst.Delete(i);
      end;
    //end
    //else result := '';
  end;

Var Str1, Str2: String;
    j: integer;
begin
  aRawHeaderLst := TstringList.create;
  try
    aRawHeaderLst.Delimiter := ':';
    aRawHeaderLst.Text := aRawHeaderText;

    fFrom:= Alg001('From');
    fSender:= Alg001('Sender');
    fSendTo:= Alg001('To');
    fcc:= Alg001('cc');
    fbcc:= Alg001('bcc');
    fReplyTo:= Alg001('Reply-To');
    fSubject:= Alg001('Subject');
    fMessageID:= Alg001('Message-ID');
    fReferences:= Alg001('References');
    fComments:= Alg001('Comments');
    fDate:= Alg001('Date');
    fContentType:= Alg001('Content-Type');
    fContentTransferEncoding:= Alg001('Content-Transfer-Encoding');
    fMIMEVersion:= Alg001('MIME-Version');
    fPriority:= Alg001('Priority');
    fDispositionNotificationTo:= Alg001('Disposition-Notification-To');

    FCustomHeaders.clear;
    J := 0;
    while j <= aRawHeaderLst.count - 1 do begin
      Str1 := trim(aRawHeaderLst.Names[j]);
      If (trim(str1) <> '') and (not (str1[1] in [' ',#9])) then begin
        Str1 := trim(Str1) + ': ' + trim(aRawHeaderLst.Values[aRawHeaderLst.Names[j]]);
        inc(j);
        While True do begin
          If j >= aRawHeaderLst.Count then break;
          str2 := aRawHeaderLst[j];
          If (str2 = '') or
             (not (str2[1] in [' ',#9])) then break; //(1) an empty line or (2) a line that does not start with a space, a tab, or a field name followed by a colon
          Str1 := trim(Str1 + ' ' + trim(str2));
          inc(j);
        end;
        FCustomHeaders.Add(Str1);
      end
      else inc(j);
    end;

  finally
    aRawHeaderLst.Free;
  end;
end;




///////////////////////////////////
////////// TAlSmtpClient //////////
///////////////////////////////////

{*******************************}
constructor TAlSmtpClient.Create;
begin
  FWSAData.wVersion := 0;
  Fconnected:= False;
  FSocketDescriptor:= INVALID_SOCKET;
  FAuthTypesSupported:= [];
  Ftimeout:= 60000;
  Randomize;
end;

{*******************************}
destructor TAlSmtpClient.Destroy;
begin
  If Fconnected then Disconnect;
  inherited;
end;

{*************************************************}
procedure TAlSmtpClient.CheckError(Error: Boolean);
var ErrCode: Integer;
    S: string;
begin
  ErrCode := WSAGetLastError;
  if Error and (ErrCode <> 0) then begin
    Case ErrCode Of
      WSAEINTR: S := 'Interrupted function call';
      WSAEACCES: S := 'Permission denied';
      WSAEFAULT: S := 'Bad address';
      WSAEINVAL: S := 'Invalid argument';
      WSAEMFILE: S := 'Too many open files';
      WSAEWOULDBLOCK: S := 'Resource temporarily unavailable';
      WSAEINPROGRESS: S := 'Operation now in progress';
      WSAEALREADY: S := 'Operation already in progress';
      WSAENOTSOCK: S := 'Socket operation on nonsocket';
      WSAEDESTADDRREQ: S := 'Destination address required';
      WSAEMSGSIZE: S := 'Message too long';
      WSAEPROTOTYPE: S := 'Protocol wrong type for socket';
      WSAENOPROTOOPT: S := 'Bad protocol option';
      WSAEPROTONOSUPPORT: S := 'Protocol not supported';
      WSAESOCKTNOSUPPORT: S := 'Socket type not supported';
      WSAEOPNOTSUPP: S := 'Operation not supported';
      WSAEPFNOSUPPORT: S := 'Protocol family not supported';
      WSAEAFNOSUPPORT: S := 'Address family not supported by protocol family';
      WSAEADDRINUSE: S := 'Address already in use';
      WSAEADDRNOTAVAIL: S := 'Cannot assign requested address';
      WSAENETDOWN: S := 'Network is down';
      WSAENETUNREACH: S := 'Network is unreachable';
      WSAENETRESET: S := 'Network dropped connection on reset';
      WSAECONNABORTED: S := 'Software caused connection abort';
      WSAECONNRESET: S := 'Connection reset by peer';
      WSAENOBUFS: S := 'No buffer space available';
      WSAEISCONN: S := 'Socket is already connected';
      WSAENOTCONN: S := 'Socket is not connected';
      WSAESHUTDOWN: S := 'Cannot send after socket shutdown';
      WSAETIMEDOUT: S := 'Connection timed out';
      WSAECONNREFUSED: S := 'Connection refused';
      WSAEHOSTDOWN: S := 'Host is down';
      WSAEHOSTUNREACH: S := 'No route to host';
      WSAEPROCLIM: S := 'Too many processes';
      WSASYSNOTREADY: S := 'Network subsystem is unavailable';
      WSAVERNOTSUPPORTED: S := 'Winsock.dll version out of range';
      WSANOTINITIALISED: S := 'Successful WSAStartup not yet performed';
      WSAEDISCON: S := 'Graceful shutdown in progress';
      WSAHOST_NOT_FOUND: S := 'Host not found';
      WSATRY_AGAIN: S := 'Nonauthoritative host not found';
      WSANO_RECOVERY: S := 'This is a nonrecoverable error';
      WSANO_DATA: S := 'Valid name, no data record of requested type';
      else Begin
        SetLength(S, 256);
        FormatMessage(
                      FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_FROM_HMODULE,
                      Pointer(GetModuleHandle('wsock32.dll')),
                      ErrCode,
                      0,
                      PChar(S),
                      Length(S),
                      nil
                     );
        SetLength(S, StrLen(PChar(S)));
        while (Length(S) > 0) and (S[Length(S)] in [#10, #13]) do SetLength(S, Length(S) - 1);
      end;
    end;
    raise Exception.CreateFmt('%s (Error code:%s)', [S, inttostr(ErrCode)]);      { Do not localize }
  end;
end;

{********************************************************************}
Function TAlSmtpClient.Connect(aHost: String; APort: integer): String;

  {---------------------------------------------}
  procedure CallServer(Server:string; Port:word);
  var SockAddr:Sockaddr_in;
      IP: String;
  begin
    FSocketDescriptor:=Socket(AF_INET,SOCK_STREAM,IPPROTO_IP);
    CheckError(FSocketDescriptor=INVALID_SOCKET);
    FillChar(SockAddr,SizeOf(SockAddr),0);
    SockAddr.sin_family:=AF_INET;
    SockAddr.sin_port:=swap(Port);
    SockAddr.sin_addr.S_addr:=inet_addr(Pchar(Server));
    If SockAddr.sin_addr.S_addr = INADDR_NONE then begin
      checkError(ALHostToIP(Server, IP));
      SockAddr.sin_addr.S_addr:=inet_addr(Pchar(IP));