File Coverage

lib/Qmail/Deliverable.pm

Criterion	Covered	Total	%
statement	145	186	77.9
branch	89	118	75.4
condition	2	5	40.0
subroutine	16	20	80.0
pod	5	7	71.4
total	257	336	76.4

package Qmail::Deliverable;

use strict;
use 5.006;
use Carp qw(carp);
use base 'Exporter';
use Qmail::Deliverable::Status qw(:status);

our $VERSION   = '1.12';
our @EXPORT_OK = (
    qw(reread_config qmail_local dot_qmail deliverable qmail_user),
    @Qmail::Deliverable::Status::STATUS,
);
our %EXPORT_TAGS = (
    all    => \@EXPORT_OK,
    status => \@Qmail::Deliverable::Status::STATUS,
);
our $VPOPMAIL_EXT = 0;
our $qmail_dir    = '/var/qmail';

# rfc2822's "atext"
my $atext = "[A-Za-z0-9!#\$%&\'*+\/=?^_\`{|}~-]";
my $valid = qr/^(?!.*\@.*\@)($atext+(?:[\@.]$atext+)*)\.?\z/;

# disallow control characters and non-ascii
my $ascii = qr/^([\x20-\x7e]*)\z/;

# parse shell line
my $shell_sq    = qr/'[^']+'/;                                      # no escaping in single quotes!
my $shell_dq    = qr/(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))/; # from Regexp::Common
my $shell_bare  = qr/[^"'\\\s]+/;                                   # no sq, dq, backslash, or space
my $shell_token = qr/(\\.|$shell_sq|$shell_dq|$shell_bare)+/;

sub _readpipe {
    my ( $command, @args ) = @_;
    local %ENV = ();
    open my $fh, '-|', $command, @args or die "open: @_: $!";
    my @data = readline $fh;
    close $fh;    # Without explicit close, $? is unreliable later
    return wantarray ? @data : join( "", @data );
}

sub _slurp {
    my ($fn) = @_;
    open my $fh, '<', $fn or return;
    return wantarray ? readline $fh : join( "", readline $fh );
}

sub _first (&@) {
    my $sub = shift;
    $sub->($_) and return $_ for @_;
    return;
}

sub _findinpath {
    my ($command) = @_;

    # Attempt to retain some level of security against PATH attacks
    my @path = grep defined, map /($ascii)/,    # untaint
        grep m{^/[^<>|]+$}, split /:/, $ENV{PATH};
    return _first { -x $_ } map "$_/$command", @path;
}

# Resolve only once to further reduce risk of PATH attacks
my $valias_exec = _findinpath 'valias';
my $vuser_exec  = _findinpath 'vuserinfo';

my %locals;
my %virtualdomains;
my %users_exact;
my %users_wild;

sub reread_config {
    %locals         = ();
    %virtualdomains = ();
    %users_exact    = ();
    %users_wild     = ();
    my $locals_fn =
        -e "$qmail_dir/control/locals"
        ? "$qmail_dir/control/locals"
        : "$qmail_dir/control/me";
    for ( _slurp $locals_fn ) {
        chomp;
        ($_) = lc =~ /$ascii/ or do { warn "Invalid character"; next; };
        $locals{$_} = 1;
    }
    for ( _slurp "$qmail_dir/control/virtualdomains" ) {
        chomp;
        ($_) = lc =~ /$ascii/ or do { warn "Invalid character"; next; };
        my ( $domain, $prepend ) = split /:/, $_, 2;
        $virtualdomains{$domain} = $prepend;
    }
    for ( _slurp "$qmail_dir/users/assign" ) {
        chomp;
        ($_) = /$ascii/ or do { warn "Invalid character"; next; };
        if (/^#/) {    # comment
            next;
        }
        elsif (s/^=([^:]+)://) {
            $users_exact{ lc $1 } = $_;
        }
        elsif (s/^\+([^:]+)://) {
            $users_wild{ lc $1 } = $_;
        }
        elsif (/^\.$/) {
            last;
        }
        else {
            warn "Invalid line in users/assign: '$_'\n";
        }
    }
}

sub _qmail_getpw {
    my ($local) = @_;
    local $/ = "\0";
    my @a = _readpipe "/var/qmail/bin/qmail-getpw", $local;
    chomp @a;
    for (@a) {
        ($_) = /$ascii/ or do { warn "Invalid character"; return ""; }
    }
    return @a;
}

sub _prepend {
    my ($domain) = @_;

    return $virtualdomains{$domain} if exists $virtualdomains{$domain};

    my @parts = split /\./, $domain;
    for ( reverse 1 .. @parts ) {
        my $wildcard = join "", map ".$_", @parts[ -$_ .. -1 ];
        return $virtualdomains{$wildcard} if exists $virtualdomains{$wildcard};
    }

    return $virtualdomains{''} if exists $virtualdomains{''};
    return undef;
}

sub _potential_exts {
    my ($ext) = @_;
    my @exts;

    # Exact match has highest precedence
    push @exts, $ext;    # user, or user-ext

    # Then user-default
    my @parts = split /(-)/, $ext;
    for ( reverse 1 .. $#parts ) {
        next unless $parts[$_] eq '-';
        push @exts, join( "", @parts[ 0 .. $_ ] ) . "default";
    }

    return @exts;
}

sub qmail_user {
    my ($in)    = @_;
    my ($local) = lc($in) =~ /$valid/
        or do { carp "Invalid address: $in"; return; };

    if ( exists $users_exact{$local} ) {
        return split /:/, $users_exact{$local}, 7;    # colon terminated
    }
    else {
        for ( reverse 1 .. length $local ) {
            my $try = substr $local, 0, $_;
            if ( exists $users_wild{$try} ) {
                my @assign = split /:/, $users_wild{$try}, 7;
                $assign[5] .= substr( $local, $_ );
                return @assign;
            }
        }
    }

    if ( $qmail_dir eq "t/fixtures" ) {
        return $local;
    }
    return _qmail_getpw $local;
}

sub qmail_local {
    my ($in)      = @_;
    my ($address) = lc($in) =~ /$valid/
        or do { carp "Invalid address: $in"; return; };

    return $address if $address !~ /\@/;
    my ( $local, $domain ) = split /\@/, $address;

    return $local if exists $locals{$domain};

    my $prepend = _prepend $domain;
    return "$prepend-$local" if defined $prepend;

    return undef;
}

sub dot_qmail {
    my ( $user, $uid, $gid, $homedir, $dash, $ext ) = @_;
    if ( @_ == 1 ) {
        my ($in)      = @_;
        my ($address) = lc($in) =~ /$valid/
            or do { carp "Invalid address: $in"; return; };

        my $local = qmail_local $address;
        return undef if not defined $local;

        ( $user, $uid, $gid, $homedir, $dash, $ext ) = qmail_user $local;
    }

    $ext =~ s/\./:/g;

    my $dashext = $dash . $ext;

    if ( not length $dashext ) {
        return "$homedir/.qmail" if -e "$homedir/.qmail";
        return "";    # defaultdelivery
    }

    for ( _potential_exts($ext), 'default' ) {
        return "$homedir/.qmail-$_" if -e "$homedir/.qmail-$_";
    }

    return undef;
}

sub valias {
    my ($address) = @_;
    if ( not $valias_exec ) {
        warn "Cannot check valias; valias executable not found";
        return 0;
    }
    my ( $local, $domain ) = split /\@/, $address;
    for ( _potential_exts($local) ) {
        eval { _readpipe( $valias_exec, "$_\@$domain" ) };
        return 1 if $? == 0;
    }
    return 0;
}

sub vuser {
    my ($address) = @_;
    if ( not $vuser_exec ) {
        warn "Cannot check vuser; vuser executable not found";
        return 0;
    }
    eval { _readpipe $vuser_exec, $address } or return 0;
    return 1 if $? == 0;
    return 0;
}

sub deliverable {
    my ($in)      = @_;
    my ($address) = lc($in) =~ /$valid/
        or do { carp "Invalid address: $in"; return; };

    my $local = qmail_local $address;
    return QD_NOT_LOCAL if not defined $local;

    my ( $user, $uid, $gid, $homedir, $dash, $ext ) = qmail_user $local;

    return QD_UNKNOWN_PERM_DENIED     if not -r $homedir or not -x _;
    return QD_TEMPFAIL_GROUP_WRITABLE if ( stat _ )[2] & 0020;
    return QD_TEMPFAIL_GROUP_WRITABLE if ( stat _ )[2] & 0002;
    return QD_TEMPFAIL_STICKY         if -k _;

    my $dot_qmail = dot_qmail $user, $uid, $gid, $homedir, $dash, $ext;

    return QD_NOT_DELIVERABLE if not defined $dot_qmail;
    return QD_DELIVERABLE     if not length $dot_qmail;    # defaultdelivery

    return QD_NOT_DELIVERABLE     if not -e $dot_qmail;
    return QD_UNKNOWN_PERM_DENIED if not -r $dot_qmail;
    return QD_DELIVERABLE         if not -s _;             # empty => defaultdelivery

    my @dot_qmail = _slurp $dot_qmail;

    if ( $dot_qmail[0] =~ /^\|\s*\S*vdelivermail/ ) {
        if ( $address !~ /\@/ ) {
            carp "vpopmail support not available if no domain given";
            return QD_VPOPMAIL_NO_DOMAIN;
        }
        my $origlocal = ( split /\@/, $address )[0];

        # Update domain with user field in assign file, just like vpopmail
        # does. This way we support alias domains. See vpopmail.c,
        # vget_assign().
        $address = $origlocal . '@' . $user;

        if ( $dot_qmail[0] =~ /bounce-no-mailbox/ ) {
            return QD_VPOPMAIL_DIR    if -d "$homedir/$origlocal";
            return QD_VPOPMAIL_VALIAS if valias $address;
            return QD_VPOPMAIL_VUSER  if vuser $address;
            if ($VPOPMAIL_EXT) {
                my ( $local, $domain ) = split /@/, $address;
                my @chunks = split /\-/, $local;    # vpopmail qmail-ext option
                for ( 0 .. $#chunks ) {
                    return QD_VPOPMAIL_QMAIL_EXT
                        if vuser $chunks[$_] . '@' . $domain;
                }
            }
            return QD_NOT_DELIVERABLE;
        }
        return QD_VPOPMAIL_CATCHALL;
    }
    if ( $dot_qmail[0] =~ /^\|bouncesaying\s+(.*)/ ) {
        my @args = $1 =~ /$shell_token/g;
        return QD_UNKNOWN_BOUNCESAYING if @args > 1;
        return QD_NOT_DELIVERABLE;
    }

    return QD_EZMLM        if grep /ezmlm/, @dot_qmail;
    return QD_UNKNOWN_PIPE if grep /^\|/,   @dot_qmail;

    return QD_DELIVERABLE;
}

reread_config;

# use Memoize;
# use Memoize::Expire;
# tie my %deliverable_cache, 'Memoize::Expire', LIFETIME => 60;
# memoize 'deliverable';

1;

__END__