view release on metacpan or  search on metacpan

SMTP.pm  view on Meta::CPAN

    "250" => "OK: %s",
    "251" => "User not local; will forward to <forward-path>",
    "354" => "%s",
    "421" => "%s Service not available, closing connection",
    "450" => "Requested mail action not taken: mailbox unavailable",
    "451" => "Requested action aborted: error in processing",
    "452" => "Requested action not taken: insufficient system storage",
    "500" => "Syntax error, command unrecognized",
    "501" => "Syntax error in parameter or arguments: %s",
    "502" => "Command not implemented %s",
    "503" => "Bad sequence of commands",
    "504" => "Command parameter not implemented",
    "550" => "Requested action not taken: %s",
    "551" => "User not local; please try %s",
    "552" => "Requested mail action aborted: exceeded storage allocation",
    "553" => "Requested action not taken: mailbox name not allowed",
    "554" => "Transaction failed: %s"
};

# legal SMTP state transitions -- each state is followed by an arrayref
# to its legal predecessors. To determine if a new state is legal, check
# to see if it's predecessor is in the array in NFA. 

$NetServer::SMTP::NFA = {
    "HELO" => [ "undef" ],
    "EHELO" => [ "undef" ],
    "MAIL" => [ qw(HELO RSET NOOP DATA) ],
    "RCPT" => [ qw(MAIL NOOP RCPT RSET) ],
    "MAIL" => [ qw(HELO NOOP DATA RSET) ],
    "DATA" => [ qw(RCPT NOOP) ],
    "TURN" => [ @$NetServer::SMTP::States ],
    "NOOP" => [ @$NetServer::SMTP::States ],
    "QUIT" => [ @$NetServer::SMTP::States ],
    "HELP" => [ @$NetServer::SMTP::States ],
    "DUMP" => [ @$NetServer::SMTP::States ],
    "RSET" => [ @$NetServer::SMTP::States ],
};
    
sub new {
    # create a new NetServer::SMTP
    my ($class) = shift; 
    my ($self) = bless {}, $class;
    if (@_) {
        $self = $self->initialise(@_);
    }
    if (! defined($self->{silent})) {
        $self->respond(220, "leafmail $NetServer::SMTP::VERSION is ready");
    }
    return $self;
}

sub initialise {

=pod

=item initialise()

Called by B<new()> to initialise the new object.  Initialisation keys 
may be specified as a hash, supplied as a parameter to the new
object, or as a filename or file handle containing a frozen 
B<NetServer::SMTP> object which is users to overlay the object. 

Recognized keys are:

=over 4

=item myhost

My host name (FQDN) 

=item allowed

array of aliases for hosts users allowed to send mail

=item silent

If silent, dont say hello when creating a new server (we have other
reasons for creating NetServer::SMTP objects, once in a while :)

=item relay

Relay hostname (FQDN) 

=item ERROR

If this flag goes non-zero, Something Bad has happened and the session
should either terminate or refuse to proceed further

=item spooldir

Directory where spooled transactions are waiting

=back

=cut

    my ($self) = shift ;
    my (@junk);
    if (scalar(@_) == 1) {
        # it's a filehandle or filename -- open it and load the contents
        my ($file);
        my ($fn) = shift;
        if (ref($fn) !~ /file/i) {
            $file = new IO::File($fn, "r") or croak "Could not open $fn\n";
        }
        my ($frozen) = join( "", $file->getlines() );
        $file->close();
        ($self, @junk) = thaw($frozen);
        $self->{spooledfile} = $fn;
        return $self;
    } elsif (scalar(@_) % 2 == 0)  {
        # it's an initialisation hash -- overlay it on $self
        %$self = (@_);
        return $self;
    } else {
        croak "Don't know how to initialise from [", join("][", @_), "]\n";
    }
}

sub respond ($$;@) {
    # issue a response code and the corresponding message
    # NOTE: SMTP response messages are printf() format strings and 
    # positional substitution may occur if additional respond() parameters
    # are available
    my ($self) = shift; 
    my ($resp) = shift;
    my (@args) = @_;
    print STDOUT "$resp ", sprintf($NetServer::SMTP::Err->{$resp}, @args), 
        "\r\n";
}

sub EHLO {
    my $self = shift;
    $self->respond(550, "I don't talk ESMTP");
    return;
}

sub HELP {
    my $self = shift;
    my $resp = "<<%%"
NetServer::SMTP $NetServer::SMTP::VERSION

Known Commands: 

HELO MAIL RCPT DATA RSET NOOP QUIT HELP DUMP TURN

%%
    $self->respond("214", $resp);
    return;
}

sub HELO {
    # say hello -- start a session
    my ($self) = shift;
    my ($next) = join(" ", @_);
    $next =~ s/\r\n//;;
    my ($f, $snd) = "";
    if ($next =~ /^from:/i) {
        $next =~ /(from:*)\s+(.*)/i;
        ($f, $snd) = ($1, $2);
        $snd =~ s/[><]//g;
    } else {
        $snd = $next;
    }
    if (grep(/$snd/i, @{ $self->{allowed} }) != 0) {
        $self->{host} = $snd;
        my ($s) = $self->serv();
	my ($peer) = $s->peer();
        if ($self->{host} ne $peer->[0]) {
            $self->respond(554, " lie to me at your peril!" );
            $self->{ERROR} = 1;
            return;