Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Fetching contributors…
Cannot retrieve contributors at this time
247 lines (187 sloc) 6.39 KB
package Apache::Qpsmtpd;
use 5.006001;
use strict;
use warnings FATAL => 'all';
use Apache2::ServerUtil ();
use Apache2::Connection ();
use Apache2::Const -compile => qw(OK MODE_GETLINE);
use APR::Const -compile => qw(SO_NONBLOCK EOF SUCCESS);
use APR::Error ();
use APR::Brigade ();
use APR::Bucket ();
use APR::Socket ();
use Apache2::Filter ();
use ModPerl::Util ();
our $VERSION = '0.02';
sub handler {
my Apache2::Connection $c = shift;
$c->client_socket->opt_set(APR::Const::SO_NONBLOCK => 0);
die "\$ENV{QPSMTPD_CONFIG} must be given" unless $ENV{QPSMTPD_CONFIG};
my $qpsmtpd = Qpsmtpd::Apache->new();
ip => $c->remote_ip,
host => $c->remote_host,
info => undef,
conn => $c,
return Apache2::Const::OK;
package Qpsmtpd::Apache;
use Qpsmtpd::Constants;
use base qw(Qpsmtpd::SMTP);
my %cdir_memo;
sub config_dir {
my ($self, $config) = @_;
if (exists $cdir_memo{$config}) {
return $cdir_memo{$config};
my $cdir = $self->{conn}->base_server->dir_config("qpsmtpd.config_dir");
$cdir =~ /^(.*)$/; # detaint
my $configdir = $1 if -e "$1/$config";
$cdir_memo{$config} = $configdir;
} else {
$cdir_memo{$config} = $self->SUPER::config_dir(@_);
return $cdir_memo{$config};
sub start_connection {
my $self = shift;
my %opts = @_;
$self->{conn} = $opts{conn};
$self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000);
$self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
$self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]");
my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host;
my $remote_ip = $opts{ip};
$self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]");
remote_info => $remote_info,
remote_ip => $remote_ip,
remote_host => $remote_host,
local_ip => $opts{conn}->local_ip,
sub config {
my $self = shift;
my ($param, $type) = @_;
if (!$type) {
my $opt = $self->{conn}->base_server->dir_config("qpsmtpd.$param");
return $opt if defined($opt);
return $self->SUPER::config(@_);
sub run {
my $self = shift;
# should be somewhere in and not here...
my $rc = $self->start_conversation;
return if $rc != DONE;
# this should really be the loop and read_input should just
# get one line; I think
sub getline {
my $self = shift;
my $c = $self->{conn} || die "Cannot getline without a conn";
return if $c->aborted;
my $bb = $self->{bb_in};
while (1) {
my $rc = $c->input_filters->get_brigade($bb, Apache2::Const::MODE_GETLINE);
return if $rc == APR::Const::EOF;
die APR::Error::strerror($rc) unless $rc == APR::Const::SUCCESS;
next unless $bb->flatten(my $data);
return $data;
return '';
sub read_input {
my $self = shift;
my $c = $self->{conn};
while (defined(my $data = $self->getline)) {
$data =~ s/\r?\n$//s; # advanced chomp
$self->connection->notes('original_string', $data);
$self->log(LOGDEBUG, "dispatching $data");
defined $self->dispatch(split / +/, $data, 2)
or $self->respond(502, "command unrecognized: '$data'");
last if $self->{_quitting};
sub respond {
my ($self, $code, @messages) = @_;
my $c = $self->{conn};
while (my $msg = shift @messages) {
my $bb = $self->{bb_out};
my $line = $code . (@messages?"-":" ").$msg;
$self->log(LOGDEBUG, $line);
my $bucket = APR::Bucket->new(($c->bucket_alloc), "$line\r\n");
# $bucket->remove;
return 1;
sub disconnect {
my $self = shift;
$self->{_quitting} = 1;
=head1 NAME
Apache::Qpsmtpd - a mod_perl-2 connection handler for qpsmtpd
Listen smtp
AcceptFilter smtp none
## "smtp" and the AcceptFilter are required for Linux, FreeBSD
## with apache >= 2.1.5, for others it doesn't hurt. See also
## and
LoadModule perl_module modules/
use lib qw( /path/to/qpsmtpd/lib );
use Apache::Qpsmtpd;
$ENV{QPSMTPD_CONFIG} = "/path/to/qpsmtpd/config";
<VirtualHost _default_:25>
PerlModule Apache::Qpsmtpd
PerlProcessConnectionHandler Apache::Qpsmtpd
# can specify this in config/plugin_dirs if you wish:
PerlSetVar qpsmtpd.plugin_dirs /path/to/qpsmtpd/plugins
PerlSetVar qpsmtpd.loglevel 4
Using multiple instances of Qpsmtpd on the same server is also
possible by setting:
Then in the VirtualHost of each config define the configuration
PerlSetVar qpsmtpd.config_dir /path/to/qpsmtpd/config
Several different configurations can be running on the same
This module implements a mod_perl/apache 2.0 connection handler
that turns Apache into an SMTP server using Qpsmtpd.
It also allows you to set single-valued config options (such
as I<loglevel>, as seen above) using C<PerlSetVar> in F<httpd.conf>.
This module should be considered beta software as it is not yet
widely tested. However it is currently the fastest way to run
Qpsmtpd, so if performance is important to you then consider this
=head1 BUGS
Probably a few. Make sure you test your plugins carefully.
The Apache scoreboard (/server-status/) mostly works and shows
connections, but could do with some enhancements specific to SMTP.
=head1 AUTHOR
Matt Sergeant, <>
Some credit goes to <> for Apache::SMTP which gave
me the inspiration to do this. <> added the virtual
host support.
Jump to Line
Something went wrong with that request. Please try again.