File Coverage

blib/lib/Test/MTA/Exim4.pm

Criterion	Covered	Total	%
statement	243	271	89.6
branch	74	134	55.2
condition	29	86	33.7
subroutine	26	29	89.6
pod	17	17	100.0
total	389	537	72.4

package Test::MTA::Exim4;

use warnings;
use strict;
use 5.006;
use base qw(Class::Accessor::Fast);
use IPC::Cmd qw[can_run run];
use Test::Builder;

our $VERSION = '0.05'; # VERSION
our $AUTHORITY = 'cpan:NIGELM'; # AUTHORITY

__PACKAGE__->mk_accessors(qw[ debug]);
__PACKAGE__->mk_ro_accessors(qw[exim_path config_file test timeout]);

# ABSTRACT: Test Anything interface for testing Exim4 configurations


# ------------------------------------------------------------------------


sub new {
    my ( $proto, $fields ) = @_;
    my ($class) = ref $proto || $proto;

    # copy fields into self (without checking) and bless
    my $self = defined($fields) ? { %{$fields} } : {};
    bless( $self, $class );

    # set some defaults if not already in place
    $self->{exim_path}
        ||= $ENV{DEFAULT_EXIM_PATH}
        || can_run('exim4')
        || can_run('exim')
        || '/usr/sbin/exim';
    $self->{config_file} ||= $ENV{DEFAULT_EXIM_CONFIG_FILE};
    $self->{test}        ||= Test::Builder->new;
    $self->{timeout}     ||= 5;

    # check that underlying IPC::Cmd has sufficient capabilities
    IPC::Cmd->can_capture_buffer
        || $self->_croak('IPC::Cmd cannot capture buffers on this system - testing will fail');

    # check that exim is there and runnable
    can_run( $self->{exim_path} )
        || $self->_croak('No runnable exim binary found');

    # reset internal state
    $self->reset;

    return $self;
}

# ------------------------------------------------------------------------


sub reset {
    my $self = shift;

    $self->{_state} = { config => {} };

    return $self;
}

# ------------------------------------------------------------------------


sub config_ok {
    my $self = shift;
    my $msg  = shift;

    $self->_run_exim_bv;

    # pad the msg if not specified
    $msg ||= sprintf( 'config %s is valid',
        ( $self->{_state}{exim_config_file} || $self->{config_file} || '(unknown)' ) );

    $self->test->ok( $self->{_state}{config}{ok}, $msg ) || $self->_diag;
}

# ------------------------------------------------------------------------


sub exim_version {
    my $self = shift;

    $self->_run_exim_bv;

    return $self->{_state}{exim_version};
}

# ------------------------------------------------------------------------


sub exim_build {
    my $self = shift;

    $self->_run_exim_bv;

    return $self->{_state}{exim_build};
}

# ------------------------------------------------------------------------


sub has_option {
    my $self   = shift;
    my $option = shift;
    my $msg    = shift;

    $self->_run_exim_bv;
    $self->_croak('Invalid exim config') unless ( $self->{_state}{config}{ok} );
    $self->_run_exim_bp;

    # pad the msg if not specified
    $msg ||= sprintf( 'Checking for existence of %s option', $option );

    $self->test->ok( exists $self->{_state}{option}{$option}, $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub has_not_option {
    my $self   = shift;
    my $option = shift;
    my $msg    = shift;

    $self->_run_exim_bv;
    $self->_croak('Invalid exim config') unless ( $self->{_state}{config}{ok} );
    $self->_run_exim_bp;

    # pad the msg if not specified
    $msg ||= sprintf( 'Checking for lack of existence of %s option', $option );

    $self->test->ok( !exists $self->{_state}{option}{$option}, $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub option_is {
    my $self   = shift;
    my $option = shift;
    my $value  = shift;
    my $msg    = shift;

    $self->_run_exim_bv;
    $self->_croak('Invalid exim config') unless ( $self->{_state}{config}{ok} );
    $self->_run_exim_bp;

    # pad the msg if not specified
    $msg ||= sprintf( 'Checking for %s option', $option );

    $self->test->is_eq( $self->{_state}{option}{$option}, $value, $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub option_is_true {
    my $self   = shift;
    my $option = shift;
    my $msg    = shift;

    $self->_run_exim_bv;
    $self->_croak('Invalid exim config') unless ( $self->{_state}{config}{ok} );
    $self->_run_exim_bp;

    # pad the msg if not specified
    $msg ||= sprintf( 'Checking for %s option', $option );

    my $value = $option =~ s/^no_// ? undef : 1;
    $self->test->is_eq( $self->{_state}{option}{$option}, $value, $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub option_is_false {
    my $self   = shift;
    my $option = shift;
    my $msg    = shift;

    $self->_run_exim_bv;
    $self->_croak('Invalid exim config') unless ( $self->{_state}{config}{ok} );
    $self->_run_exim_bp;

    # pad the msg if not specified
    $msg ||= sprintf( 'Checking for %s option', $option );

    my $value = $option =~ s/^no_// ? 1 : undef;
    $self->test->is_eq( $self->{_state}{option}{$option}, $value, $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub expansion_is {
    my $self   = shift;
    my $string = shift;
    my $expect = shift;
    my $msg    = shift;

    $self->_run_exim_bv;
    $self->_croak('Invalid exim config') unless ( $self->{_state}{config}{ok} );

    # pad the msg if not specified
    $msg ||= sprintf( "Checking expansion of '%s'", $string );

    my $got = $self->_run_exim_be($string);
    chomp $got;
    $self->test->is_eq( $got, $expect, $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub has_capability {
    my $self = shift;
    my $type = shift;
    my $what = shift;
    my $msg  = shift;

    $self->_run_exim_bv;
    $self->_croak('Invalid exim config')                  unless ( $self->{_state}{config}{ok} );
    $self->_croak('Capability requires a type')           unless ($type);
    $self->_croak('Capability requires a thing to check') unless ($what);

    # pad the msg if not specified
    $msg ||= sprintf( 'Checking for %s/%s capability', $type, $what );

    $self->test->ok( ( $self->{_state}{config}{$type} && $self->{_state}{config}{$type}{$what} ), $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub has_not_capability {
    my $self = shift;
    my $type = shift;
    my $what = shift;
    my $msg  = shift;

    $self->_run_exim_bv;
    $self->_croak('Invalid exim config')                  unless ( $self->{_state}{config}{ok} );
    $self->_croak('Capability requires a type')           unless ($type);
    $self->_croak('Capability requires a thing to check') unless ($what);

    # pad the msg if not specified
    $msg ||= sprintf( 'Checking for lack of %s/%s capability', $type, $what );

    $self->test->ok( ( $self->{_state}{config}{$type} && !$self->{_state}{config}{$type}{$what} ), $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub routes_ok {
    my $self = shift;
    my $addr = shift;
    my $msg  = shift;

    $self->_croak('Requires an address') unless ($addr);

    # run the check
    my $res = $self->_run_exim_bt($addr);

    # pad the msg if not specified
    $msg ||= sprintf( 'Can route to %s', $addr );

    # OK if there are no undeliverables and there are deliverables
    $self->test->ok( ( $res->{deliverable} && !$res->{undeliverable} ), $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub routes_as_ok {
    my $self   = shift;
    my $addr   = shift;
    my $target = shift;
    my $msg    = shift;

    $self->_croak('Requires an address')           unless ($addr);
    $self->_croak('Requires a target description') unless ($target);

    # if target is a hash, wrap it in an array
    $target = [$target] if ( ref($target) eq 'HASH' );
    $self->_croak('target should be an arrayref')
        unless ( ref($target) eq 'ARRAY' );

    # run the check
    my $res = $self->_run_exim_bt($addr);

    # pad the msg if not specified
    $msg ||= sprintf( 'Can route to %s', $addr );

    # check we get the right number of things back
    my $count_ok =
        ( scalar( keys %{ $res->{addresses} } ) == scalar( @{$target} ) );
    my $count         = scalar( @{$target} );
    my $addr_count_ok = 0;
    my $addresses     = { %{ $res->{addresses} } };    #copy address info

    # only do these tests if the count matches the rules
    if ($count_ok) {
        foreach my $targetspec ( @{$target} ) {
            $self->_croak('target spec should be hashref')
                unless ( ref($targetspec) eq 'HASH' );
            foreach my $addr ( keys %{$addresses} ) {
                my $thisone = 1;
                foreach my $key ( keys %{$targetspec} ) {
                    unless ( exists( $addresses->{$addr}{$key} )
                        && ( $addresses->{$addr}{$key} eq $targetspec->{$key} ) ) {
                        $thisone = 0;
                        last;
                    }
                }
                if ($thisone) {
                    $addr_count_ok++;
                    last;
                }
            }
        }
    }

    # return test status
    $self->test->ok( ( $count_ok && ( $addr_count_ok == $count ) ), $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub discards_ok {
    my $self = shift;
    my $addr = shift;
    my $msg  = shift;

    $self->_croak('Requires an address') unless ($addr);

    # run the check
    my $res = $self->_run_exim_bt($addr);

    # pad the msg if not specified
    $msg ||= sprintf( 'Discard for %s', $addr );

    # OK if there is a total of one address and it was discarded
    $self->test->ok( ( ( $res->{total} == 1 ) && ( values %{ $res->{addresses} } )[0]->{discarded} ), $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


sub undeliverable_ok {
    my $self = shift;
    my $addr = shift;
    my $msg  = shift;

    $self->_croak('Requires an address') unless ($addr);

    # run the check
    my $res = $self->_run_exim_bt($addr);

    # pad the msg if not specified
    $msg ||= sprintf( 'Undeliverable to %s', $addr );

    # OK if there are no deliverables and there are undeliverables
    $self->test->ok( ( $res->{undeliverable} && !$res->{deliverable} ), $msg )
        || $self->_diag;
}

# ------------------------------------------------------------------------


# ------------------------------------------------------------------------


sub _run_exim_command {
    my $self = shift;
    my @args = @_;

    # we always put the config file as the first argument if we have one
    unshift @args, ( '-C' . $self->{config_file} )
        if ( $self->{config_file} );

    # run command
    my ( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) = run(
        command => [ $self->{exim_path}, @args ],
        verbose => $self->{debug},

        ## TODO timeout appears to have a nasty interaction which
        ##      causes the tests to fail, plus hang after the run
        #timeout => $self->{timeout}
    );

    # as documented in IPC::Cmd, the buffer returns are an arrayref
    # unexpectedly, that array has a single element with a slurped string
    # so we reprocess into a one line per element form
    $full_buf   = [ map { ( split( /\r?\n/, $_ ) ) } @{ $full_buf   || [] } ];
    $stdout_buf = [ map { ( split( /\r?\n/, $_ ) ) } @{ $stdout_buf || [] } ];
    $stderr_buf = [ map { ( split( /\r?\n/, $_ ) ) } @{ $stderr_buf || [] } ];

    $self->{_state}{last_error}  = $error_code;
    $self->{_state}{last_output} = $full_buf;

    return ( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf );
}

# ------------------------------------------------------------------------


sub _run_exim_bv {
    my $self = shift;

    # we only want to run this once per session
    return if ( $self->{_state}{checked}++ );

    # run command
    my ( $success, undef, undef, $stdout_buf, undef ) = $self->_run_exim_command('-bV');

    # parse things out if command worked
    if ($success) {
        $self->{_state}{config}{ok} = 1;
        foreach ( @{$stdout_buf} ) {
            chomp;
            if (/^Exim\s+version\s+([0-9\.]+)\s+#(\d+)/) {
                $self->{_state}{exim_version} = $1;
                $self->{_state}{exim_build}   = $2;
            }
            elsif (
                m{ ^
                    (   support \s+ for |       # pick one of these
                        lookups         |       # in $1
                        authenticators  |
                        routers         |
                        transports
                    )
                    (?: \s+ \( [a-z\s-]+ \) )?  # optional load type for 4.74+ - discarded
                                                # eg (built-in)
                    : \s*                       # followed by a colon
                    (.*)                        # and the rest of the line in $2
                    $
                 }ix
                ) {
                my $type = lc($1);
                my $res  = lc($2);
                $type =~ tr/a-z/_/cs;
                $type =~ s/s$//;    # strip trailing s
                $res =~ tr|a-z0-9_ /||cd;
                $self->{_state}{config}{$type}{$_} = 1 foreach ( split( /[\s\/]/, $res ) );
            }
            elsif (/Configuration file is (.*)/) {
                $self->{_state}{exim_config_file} = $1;
            }
        }

        # we do sanity checks here - currently croak on these, which might
        # be too drastic!
        $self->_croak('No exim version number found')
            unless ( $self->{_state}{exim_version} );
    }
    else {
        $self->{_state}{config}{ok} = 0;
    }
}

# ------------------------------------------------------------------------


sub _run_exim_bp {
    my $self = shift;

    # we only want to run this once per session
    return if ( exists $self->{_state}{option} );

    # initialize the option hash, because if we don't get anything parseable
    # back the first time it probably won't succeed subsequently
    $self->{_state}{option} = {};

    # run command
    my ( $success, undef, undef, $stdout_buf, undef ) = $self->_run_exim_command('-bP');

    # parse things out if command worked
    if ($success) {
        foreach ( @{$stdout_buf} ) {
            chomp;
            if (/^(no_)?(\w+)(?: = (.*))?$/) {
                my ( $negate, $option, $value ) = ( $1, $2, $3 );
                $self->{_state}{option}{$option} =
                    $negate ? undef : defined $value ? $value : 1;
            }
        }
    }
}

# ------------------------------------------------------------------------


sub _run_exim_be {
    my $self   = shift;
    my $string = shift;

    # run command
    my ( $success, undef, undef, $stdout_buf, undef ) = $self->_run_exim_command( '-be', $string );

    # parse things out if command worked

    return $success && join( "\n", @$stdout_buf, '' );
}

# ------------------------------------------------------------------------


sub _run_exim_bt {
    my $self    = shift;
    my $address = shift;
    my $sender  = shift;

    # check for sanity... make sure we have a valid binary + config
    $self->_run_exim_bv unless ( $self->{_state}{config}{ok} );
    $self->_croak('No exim version number found')
        unless ( $self->{_state}{config}{ok} );

    my @options = ('-bt');
    push( @options, '-f', $sender ) if ( defined($sender) );
    push( @options, '--', $address );

    # run command - use a -- divider to prevent funkiness in the address
    my ( $success, undef, undef, $stdout_buf, undef ) = $self->_run_exim_command(@options);

    # as exim uses the exit value to signify how well things worked, and
    # IPC::Cmd obscures this somewhat, we are just going to ignore it!
    # and parse the output to see what happened...
    my @lines  = @{$stdout_buf};
    my $result = {
        all_ok        => $success,
        deliverable   => 0,
        undeliverable => 0,
        total         => 0,
        addresses     => {}
    };
    while ( scalar(@lines) ) {
        my $line = shift @lines;
        next if ( $line =~ /^\s*$/ );

        # this line should be one of:-
        #    is undeliverable
        #    is discarded
        #    ->  + more info on next lines
        #    + more info on next lines
        if ( $line =~ /^(.*) is undeliverable(.*)$/ ) {
            $result->{undeliverable}++;
            $result->{total}++;
            $result->{addresses}{$1} = { ok => 0, reason => $2, address => $1 };
            next;
        }
        $result->{deliverable}++;
        $result->{total}++;
        my $res = { ok => 1, discarded => 0, data => [] };
        if ( $line =~ /^(.*) -\> (.*)$/ ) {
            $res->{address}          = $1;
            $res->{target}           = $2;
            $result->{addresses}{$1} = $res;
        }
        elsif ( $line =~ /^(.*) is discarded$/ ) {
            $res->{address}          = $1;
            $res->{discarded}        = 1;
            $result->{addresses}{$1} = $res;
        }
        else {
            $res->{address} = $line;
            $result->{addresses}{$line} = $res;
        }

        # mop up subsequent lines
        while ( scalar(@lines) && ( $lines[0] =~ /^\s/ ) ) {
            $line = shift @lines;
            if ( $line =~ /^\s+\<-- (.*)/ ) {
                $res->{original} ||= [];
                push( @{ $res->{original} }, $1 );
            }
            elsif ( $line =~ /^\s+transport = (.*)/ ) {
                $res->{transport} = $1;
            }
            elsif ( $line =~ /^\s+router = (.*), transport = (.*)/ ) {
                $res->{router}    = $1;
                $res->{transport} = $2;
            }
            else {
                push( @{ $res->{data} }, $line );
            }
        }
    }

    return $result;
}

# ------------------------------------------------------------------------


sub _diag {
    my $self = shift;

    $self->test->diag(
        sprintf(
            "Error: %s\nOutput: %s\n",
            $self->{_state}{last_error},
            join(
                ' ',
                @{  ( ref( $self->{_state}{last_output} ) eq 'ARRAY' )
                    ? $self->{_state}{last_output}
                    : [ $self->{_state}{last_output} ]
                }
            )
        )
    );
}

# ------------------------------------------------------------------------


1;    # End of Test::MTA::Exim4

__END__