"Fossies" - the Fresh Open Source Software Archive

Member "formmail_modules-3.14m1/lib/CGI/NMS/Mailer/SMTP.pm" (11 Aug 2004, 3930 Bytes) of package /linux/www/old/formmail_modules-3.14m1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "SMTP.pm" see the Fossies "Dox" file reference documentation.

    1 package CGI::NMS::Mailer::SMTP;
    2 use strict;
    3 
    4 use IO::Socket;
    5 use CGI::NMS::Mailer;
    6 use base qw(CGI::NMS::Mailer);
    7 
    8 =head1 NAME
    9 
   10 CGI::NMS::Mailer::SMTP - mail sender using SMTP
   11 
   12 =head1 SYNOPSYS
   13 
   14   my $mailer = CGI::NMS::Mailer::SMTP->new('mailhost.bigisp.net');
   15 
   16   $mailer->newmail($from, $to);
   17   $mailer->print($email_header_and_body);
   18   $mailer->endmail;
   19 
   20 =head1 DESCRIPTION
   21 
   22 This implementation of the mailer object defined in L<CGI::NMS::Mailer>
   23 uses an SMTP connection to a mail relay to send the email.
   24 
   25 =head1 CONSTRUCTORS
   26 
   27 =over
   28 
   29 =item new ( MAILHOST )
   30 
   31 MAILHOST must be the name or dotted decimal IP address of an SMTP
   32 server that will relay mail for the web server.
   33 
   34 =cut
   35 
   36 sub new {
   37   my ($pkg, $mailhost) = @_;
   38 
   39   $mailhost .= ':25' unless $mailhost =~ /:/;
   40   return bless { Mailhost => $mailhost }, $pkg;
   41 }
   42 
   43 =back
   44 
   45 =head1 METHODS
   46 
   47 See L<CGI::NMS::Mailer> for the user interface to these methods.
   48 
   49 =over
   50 
   51 =item newmail ( SCRIPTNAME, SENDER, @RECIPIENTS )
   52 
   53 Opens the SMTP connection and sends trace headers.
   54 
   55 =cut
   56 
   57 sub newmail {
   58   my ($self, $scriptname, $sender, @recipients) = @_;
   59 
   60   $self->{Sock} = IO::Socket::INET->new($self->{Mailhost});
   61   defined $self->{Sock} or die "connect to [$self->{Mailhost}]: $!";
   62 
   63   my $banner = $self->_smtp_response;
   64   $banner =~ /^2/ or die "bad SMTP banner [$banner] from [$self->{Mailhost}]";
   65 
   66   my $helohost = ($ENV{SERVER_NAME} =~ /^([\w\-\.]+)$/ ? $1 : '.');
   67   $self->_smtp_command("HELO $helohost");
   68   $self->_smtp_command("MAIL FROM:<$sender>");
   69   foreach my $r (@recipients) {
   70     $self->_smtp_command("RCPT TO:<$r>");
   71   }
   72   $self->_smtp_command("DATA", '3');
   73 
   74   $self->output_trace_headers($scriptname);
   75 }
   76 
   77 =item print ( @ARGS )
   78 
   79 Writes some email body to the SMTP socket.
   80 
   81 =cut
   82 
   83 sub print {
   84   my ($self, @args) = @_;
   85 
   86   my $text = join '', @args;
   87   $text =~ s#\n#\015\012#g;
   88   $text =~ s#^\.#..#mg;
   89 
   90   $self->{Sock}->print($text) or die "write to SMTP socket: $!";
   91 }
   92 
   93 =item endmail ()
   94 
   95 Finishes sending the mail and closes the SMTP connection.
   96 
   97 =cut
   98 
   99 sub endmail {
  100   my ($self) = @_;
  101 
  102   $self->_smtp_command(".");
  103   $self->_smtp_command("QUIT");
  104   delete $self->{Sock};
  105 }
  106 
  107 =back
  108 
  109 =head1 PRIVATE METHODS
  110 
  111 These methods should be called from within this module only.
  112 
  113 =over
  114 
  115 =item _smtp_getline ()
  116 
  117 Reads a line from the SMTP socket, and returns it as a string,
  118 including the terminating newline sequence.
  119 
  120 =cut
  121 
  122 sub _smtp_getline {
  123   my ($self) = @_;
  124 
  125   my $sock = $self->{Sock};
  126   my $line = <$sock>;
  127   defined $line or die "read from SMTP server: $!";
  128 
  129   return $line;
  130 }
  131 
  132 =item _smtp_response ()
  133 
  134 Reads a command response from the SMTP socket, and returns it as
  135 a single string.  A multiline responses is returned as a multiline
  136 string, and the terminating newline sequence is always included.
  137 
  138 =cut
  139 
  140 sub _smtp_response {
  141   my ($self) = @_;
  142 
  143   my $line = $self->_smtp_getline;
  144   my $resp = $line;
  145   while ($line =~ /^\d\d\d\-/) {
  146     $line = $self->_smtp_getline;
  147     $resp .= $line;
  148   }
  149   return $resp;
  150 }
  151 
  152 =item _smtp_command ( COMMAND [,EXPECT] )
  153 
  154 Sends the SMTP command COMMAND to the SMTP server, and reads a line
  155 in response.  Dies unless the first character of the response is
  156 the character EXPECT, which defaults to '2'.
  157 
  158 =cut
  159 
  160 sub _smtp_command {
  161   my ($self, $command, $expect) = @_;
  162   defined $expect or $expect = '2';
  163 
  164   $self->{Sock}->print("$command\015\012") or die
  165     "write [$command] to SMTP server: $!";
  166   
  167   my $resp = $self->_smtp_response;
  168   unless (substr($resp, 0, 1) eq $expect) {
  169     die "SMTP command [$command] gave response [$resp]";
  170   }
  171 }
  172 
  173 =back
  174 
  175 =head1 MAINTAINERS
  176 
  177 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
  178 
  179 To request support or report bugs, please email
  180 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
  181 
  182 =head1 COPYRIGHT
  183 
  184 Copyright 2003 London Perl Mongers, All rights reserved
  185 
  186 =head1 LICENSE
  187 
  188 This module is free software; you are free to redistribute it
  189 and/or modify it under the same terms as Perl itself.
  190 
  191 =cut
  192 
  193 1;
  194