view release on metacpan or  search on metacpan

lib/AnyEvent/SMTP/Server.pm  view on Meta::CPAN

        host => 'remote addr',
        port => 'remote port',
        helo => 'HELO/EHLO string',
    };

=back

=cut

sub import {
	my $me = shift;
	my $pkg = caller;
	
	@_ or return;
	for (@_) {
		if ( $_ eq 'smtp_server') {
			*{$pkg.'::'.$_} = \&$_;
		} else {
			croak "$_ is not exported by $me";
		}
	}
}

sub smtp_server {
	my ($host,$port,$cb) = @_;
	my $server = AnyEvent::SMTP::Server->new(
		host => $host,
		port => $port,
	);
	$server->reg_cb(
		mail => sub {
			$cb->($_[1]);
		},
	);
	$server->start;
	defined wantarray
		? AnyEvent::Util::guard { $server->stop; %$server = (); }
		: ()
}

sub new {
	my $pkg = shift;
	my $self = bless { @_ }, $pkg;
	$self->{hostname} = hostname() unless defined $self->{hostname};
	$self->set_exception_cb( sub {
		my ($e, $event, @args) = @_;
		my $ex = $@;
		if (exists $self->{event_failed}) {
			$self->{event_failed} = $ex;
			return;
		}
		#warn "exception: $self, $self->{current_con} (@args) [$@]";
		my $con = $self->{current_con};
		if (!$con) {
			local $::self = $self;
			local $::con;
			local $::event = $event;
			{
				package DB;
				my $i = 0;
				while (my @c = caller(++$i)) {
					warn "$i. [@DB::args]";
					next if @DB::args < 2;
					last if $DB::args[0] == $::self and $DB::args[1] eq $::event and UNIVERSAL::isa($DB::args[2], 'AnyEvent::SMTP::Conn');
				}
				$::con = $DB::args[2];
			}
			$con = $::con;
		}
		if ($con) {
			my $msg = "500 INTERNAL ERROR";
			if ($self->{devel}) {
				$ex =~ s{(?:\r?\n)+}{ }sg;
				$ex =~ s{\s+$}{}s;
				$msg .= ": ".$ex;
			}
			$con->reply($msg);
		}
		warn "exception during $event : $ex";
	} );
	$self->reg_cb(
		command => sub {
			my ($s,$con,$com) = @_;
			my ($cmd, @args);
			for ($com) {
				s/^\s+//;s/\s+$//;
				length or last;
				($cmd, @args) = split /\s+/;
				$cmd = uc $cmd;
			}
			if (exists $CMD{$cmd}) {
				$s->handle( $con, $cmd, @args );
			} else {
				warn "$cmd @args";
				$con->reply("500 Learn to type!");
			}
			#warn "Got command @_";
		},
		HELO => sub {
			my ($s,$con,@args) = @_;
			$con->{helo} = "@args";
			$con->new_m();
			$con->ok("I'm ready.");
		},
		EHLO => sub {
			my ($s,$con,@args) = @_;
			$con->{helo} = "@args";
			$con->new_m();
			$con->ok("Go on.");
		},
		RSET => sub {
			my ($s,$con,@args) = @_;
			$con->new_m();
			$con->ok;
		},
		MAIL => sub {
			my ($s,$con,@args) = @_;
			my $from = join ' ',@args;
			$from =~ s{^from:}{}i or return $con->reply('501 Usage: MAIL FROM:<mail addr>');
			$con->{helo} or return $con->reply("503 Error: send HELO/EHLO first");
			my @addrs;