File Coverage

blib/lib/XMail/Ctrl.pm

Criterion	Covered	Total	%
statement	15	155	9.6
branch	0	102	0.0
condition	0	46	0.0
subroutine	5	21	23.8
pod	0	13	0.0
total	20	337	5.9

package XMail::Ctrl;

use strict;
use warnings;
use vars qw($VERSION $AUTOLOAD);
use Digest::MD5();
use IO::Socket;



# ABSTRACT: Crtl access to XMail server

$VERSION = 2.4;


# Perl interface to crtl for XMail
# Written by Aaron Johnson [e-mail]

# Once you create a new xmail connection don't
# let it sit around too long or it will time out!

sub new {

    my ( $class, %args ) = @_;

    my $self = bless {
        _helo         => {},
        _last_error   => {},
        _last_success => {},
        _command_ok   => 0,
        _io           => undef,
        _ctrlid       => $args{ctrlid} || "",
        _ctrlpass     => $args{ctrlpass} || "",
        _host         => $args{host} || "127.0.0.1",
        _port         => $args{port} || 6017,
        debug         => $args{debug} || 0,
    }, $class;

    # no point of connecting unless we got a password
    return $self unless $args{ctrlpass};

    # Skip connection with argument no_connect
    $self->connect unless $args{no_connect};
    return $self;
}

# connect
#    returns a 0/1 value indicating the result
#    errors are retrieved by last_error as such.
#
#      print $ctrl->last_error->{description}
#         unless $ctrl->connect;
#
#    errors could be one of:
#     * Failed connecting to server ([socket_info])
#     * Authentication failed

sub connect {
    my $self = shift;

    # return ok if a connection is already present
    $self->connected and return 1;

    my ( $host, $port ) = ( $self->{_host}, $self->{_port} );

    $self->{_io} =
      IO::Socket::INET->new( PeerAddr => $host, PeerPort => $port );

    $self->last_error("Connection failed [$host:$port] ($@)")
      and return 0
      unless defined $self->{_io};

    print STDOUT "\n" if $self->debug > 1;

    # get the helo string or return failure
    defined( my $buf = $self->_recv ) or return 0;

    # gather some useful stuff from the helo string

    # version 1.19 and above no longer return OS removed
    $buf =~ /^\+\d+ (<[\d\.@]+>)\D+([\d\.]+)/; # \(([^\)]+)\).+/;
    $self->{_helo} = { timestamp => $1,
                       version => $2,
		       # os => $3
		      };

    # create and send MD5 auth string
    $self->_send(
        $self->{_ctrlid} . "\t#"
          . Digest::MD5::md5_hex(
            $self->{_helo}{timestamp} . $self->{_ctrlpass}
          )
      )
      or return 0;    # shouldn't happen.

    # receive auth results
    $buf = $self->_recv;

    # auth not accepted ?
    unless ( defined $buf && $buf =~ /^\+/ ) {

        #  upon a xmail MD5 auth failure, xmail returns a
        # "-00171 Resource lock entry not found". don't think this status
        # fits very well and there actually is a ERR_MD5_AUTH_FAILED (-152)
        # defined in the xmail errorcode table. Reporting that instead
        # since that more accurately describes what just happened.

        $self->last_error( "00152",
            "MD5 authentication failed [$self->{_ctrlid}\@$host:$port]" );

        # the server will cut the connection here, so we'd better get rid of
        # the socket object accordingly
        undef $self->{_io};
        return 0;
    }

    $buf =~ /^.(\d+)\s?(.*)/ and $self->last_success( $1, $2 );
    return 1;
}

# helo,
# returns a 3-key hash (timestamp,version,os)
# Calling this method before a connection is made
# obviously will return an empty hash. Helo information
# will be unset when a call to quit is made.
sub helo {
    return (shift)->{_helo};
}

# connected,
# returns the connection state.
sub connected {
    my $self = shift;
    return ( defined $self->{_io} && $self->{_io}->connected ) ? 1 : 0;
}

# last_error,
# returns a two-key hash (code/description) exposing the last
# error encountered. method quit will undefine. on no errors
# an emtpy hash is returned. If running in debug mode, errors
# are additionally printed out to the console as they appear.
sub last_error {
    my ( $self, $code, $desc ) = @_;
    if ($code) {

        # if there the code is not a xmail code and
        # the desc has no value then we shift
        # the description to be the code and
        # assign our custom error code (-99999)
        if ( $code !~ /^\d+/ || !$desc ) {
            $desc = $code;
            $code = "99999";
        }
        $desc =~ s/\r?\n$//;
        print STDOUT "error:   code:$code  description:$desc\n"
          if $self->{debug};
        $self->{_last_error} = { code => $code, description => $desc };
    }
    return $self->{_last_error};

}

# last_success,
# returns a two-key hash (code/description) exposing the last
# successfull xcommand. method quit will undefine.
sub last_success {
    my ( $self, $code, $desc ) = @_;
    if ( defined($code) ) {
        return $self->{_last_success} = {} if $code eq '0';    #reset
        $desc =~ s/\r?\n$// if $desc;
        print STDOUT "ok   :   code:$code  description:$desc\n"
          if $self->{debug} > 2;
        $self->{_last_success} = { code => $code, description => $desc };
    }
    return $self->{_last_success};
}

# debug,
# sets debug mode (0-2)
sub debug {
    my ( $self, $set ) = @_;
    $self->{debug} = $set if defined $set;
    return $self->{debug};
}

# _send, wraps socket recv + does dbg output. returns 0 or 1
sub _send {
    my ( $self, $data ) = @_;
    $data .= "\r\n" unless $data =~ /\r?\n$/;

    # if the socket has been shutdown by the server, send returns
    # a defined value,(perlfunc says otherwise) but it will atleast
    # reset the connected state to false, so by additionally check
    # connection state after send, we can detect a dead peer and
    # perform a transparent reconnect and retransmit of the last command...
    unless(defined $self->{_io}->send($data) && $self->connected){

       # socket is down, reconnect and retransmit
       print STDOUT "info :   reconnecting [$self->{_host}:$self->{_port}]\n"
	   if $self->debug > 2;
	 # still failing ? then report a permanent error...
       $self->last_error("socket::send failed, no connection")
         && return 0
         unless $self->connect && defined $self->{_io}->send($data);
	}

    print STDOUT "debug:<< $data" if $self->debug > 1;
    return 1;
}

# _recv, wraps socket recv + does dbg output. returns indata or undef
sub _recv {
    my ( $self, $bufsz ) = @_;
    my $buf;
    return unless $self->connected;

    $self->last_error("socket::recv failed, no connection")
      && return
      unless $self->connected && defined $self->{_io}->recv( $buf, $bufsz || 128 );

    print STDOUT "debug:>> $buf" if $self->debug > 1;
    return $buf;
}

# xcommand, invoked by the autoloaded method
#
# *    on a getter command, x data is returned if the command
#     was successful. otherwise undef is returned.
#      my $data = $ctrl->userlist(...);
#      print $ctrl->last_error->{code} unless defined $data;
#
# *    on a setter command, undef/1 is returned indicating the result
#      print $ctrl->last_error->{description}
#        unless $ctrl->useradd(...) [ ==1 ]
#
#  An eventual error occuring during the transaction is
#  retrieved by the last_error method
#
sub xcommand {
    my ( $self, $args ) = @_;
    $self->command_ok(0);

    # $self->last_success(0);

    my @build_command = qw(
      domain
      alias
      account
      mlusername
      username
      password
      mailaddress
      perms
      usertype
      loc-domain
      loc-username
      extrn-domain
      extrn-username
      extrn-password
      authtype
      relative-file-path
      vars
      lev0
      lev1
      msgfile
    );

    my $command = delete $args->{command};
    foreach my $step (@build_command) {
        if ( ref $args->{$step} ne "HASH" ) {
            $command .= "\t$args->{$step}" if $args->{$step};
        }
        else {
            foreach my $varname ( keys %{ $args->{$step} } ) {
                $command .= "\t$varname\t$args->{$step}{$varname}";
            }
        }
        delete $args->{$step};
    }

    # no connection, try bring one up, return on failure
    $self->connect or return;

    # make debug output reader friendly
    print STDOUT "\n" if $self->debug > 1;

    # issue the command, return if send failure
    $self->_send($command) or return;

    local ($_);
    my $sck = $self->{_io};
    my ( $charge, $mode, $desc, $line, @data );
    while ( defined( $line = <$sck> ) ) {
        print STDOUT "debug:>> $line" if $self->debug > 1;
        if ( defined $mode ) {

            # weed out newlines
            $line =~ s/\r?\n$//;

            # end of input, break outta here
            last if $line =~ /^\.$/;

            # pile up input
            push ( @data, $line );
        }
        else {
            if ( $line =~ /^(.)(\d+)\s?(.*)/ ) {
                ( $charge, $mode, $desc ) = ( $1, $2, $3 );
            }

            # report '-' unless regexp matched
            $self->command_ok( $charge || '-' );

            if ( $charge eq '+' ) {
                $self->last_success( $mode, $desc );
                return 1 if $mode eq '00000';
                last if $mode ne '00100';

            }
            else {
                $self->last_error( $mode, $desc );
                return;
            }
        }
    }

    $self->last_error("Unknown recv error")
      and return
      if not defined $mode;    # cannot happen ?! :~/

    # got a +00101 code, xmail expects a list
    if ( $mode eq '00101' ) {
        @data =
          ( ref( $args->{output_to_file} ) eq 'ARRAY' )
          ? @{ $args->{output_to_file} }
          : split ( /\r?\n/, $args->{output_to_file} );

        for (@data) {

            # From Xmail docs section "Setting mailproc.tab file":
            # if line begins with a period... take care of that.
            $_ = ".$_" if /^\./;
            $self->_send($_) or last;    # end if error
        }
        $self->_send(".");
        $line = $self->_recv;

        # determine whether the list was accepted..
        $line =~ /^(.)(\d+)\s?(.*)/
          or $self->last_error( $line || "Unknown recv error" )
          and return;

        ( $charge, $mode, $desc ) = ( $1, $2, $3 );

        # set error and return unless good return status
        $self->last_error( $mode, $desc )
          and return
          unless $charge eq '+';

        # command_ok should be updated here aswell
        $self->command_ok($charge);

        # update last_success
        $self->last_success( $mode, $desc );
        return 1;
    }

    # got a +00100, a list as indata
    # return as-is unless told otherwise, the rare case I'd presume
    return ( join ( "\r\n", @data ) . "\r\n" ) if $self->raw_list;

    # ...otherwise, build up an array ref
    my $array_ref;
    my $count = 0;

    # attempting to save some memory on large lists
    while ( defined( $_ = shift @data ) ) {
        tr/"//d;
        $array_ref->[ $count++ ] = [ split /\t/ ];
    }
    return $array_ref;
}

sub error {
    my ($self) = @_;
    return $self->last_error->{code};
}

sub mode {
    my ($self) = @_;
    return $self->last_success->{code};
}

sub command_ok {
    my ( $self, $value ) = @_;
    return $self->{_command_ok} if ( !defined($value) );
    $self->{_command_ok} = ( $value eq '+' ) ? 1 : 0;
    return $self->{_command_ok};
}

sub raw_list {
    my ( $self, $value ) = @_;
    if ($value) {
        $self->{raw_list} = $value;
        return;
    }
    else {
        return $self->{raw_list};
    }

}

sub quit {
    my $self = shift;
    $self->{_helo}         = {};
    $self->{_last_error}   = {};
    $self->{_last_success} = {};
    if ( $self->connected ) {
        $self->_send("quit");
        $self->{_io}->close;
        undef $self->{_io};
    }
    return;
}

sub AUTOLOAD {
    my ( $self, $args ) = @_;

    $AUTOLOAD =~ /.*::(\w+)/;
    my $command = $1;
    if ( $command =~ /[A-Z]/ ) { exit }
    $args->{command} = $command;
    return $self->xcommand($args);

}

1;

__END__