File Coverage

blib/lib/Mail/Box/IMAP4/SSL.pm

Criterion	Covered	Total	%
statement	47	53	88.6
branch	8	12	66.6
condition	6	10	60.0
subroutine	10	10	100.0
pod	1	2	50.0
total	72	87	82.7

use 5.006;
use strict;
use warnings;

package Mail::Box::IMAP4::SSL;
# ABSTRACT: handle IMAP4 folders with SSL
our $VERSION = '0.03'; # VERSION

use superclass 'Mail::Box::IMAP4' => 2.079;
use IO::Socket::SSL 1.12;
use Mail::Reporter 2.079 qw();
use Mail::Transport::IMAP4 2.079 qw();
use Mail::IMAPClient 3.02;

my $imaps_port = 993; # standard port for IMAP over SSL

#--------------------------------------------------------------------------#
# init
#--------------------------------------------------------------------------#

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

    # until we're connected, mark as closed in case we exit early
    # (otherwise, Mail::Box::DESTROY will try to close/unlock, which dies)
    $self->{MB_is_closed}++;

    # if no port is provided, use the default
    $args->{server_port} ||= $imaps_port;

    # Mail::Box::IMAP4 wants a folder or it throws warnings
    $args->{folder} ||= '/';

    # Use messages classes from our superclass type
    $args->{message_type} ||= 'Mail::Box::IMAP4::Message';

    # giving us a transport argument is an error since our only purpose
    # is to create the right kind of transport object
    if ( $args->{transporter} ) {
        Mail::Reporter->log(
            ERROR => "The 'transporter' option is not valid for " . __PACKAGE__ );
        return;
    }

    # some arguments are required to connect to a server
    for my $req (qw/ server_name username password/) {
        if ( not defined $args->{$req} ) {
            Mail::Reporter->log( ERROR => "The '$req' option is required for " . __PACKAGE__ );
            return;
        }
    }

    # trying to create the transport object

    my $verify_mode =
      $ENV{MAIL_BOX_IMAP4_SSL_NOVERIFY} ? SSL_VERIFY_NONE() : SSL_VERIFY_PEER();

    my $ssl_socket = IO::Socket::SSL->new(
        Proto           => 'tcp',
        PeerAddr        => $args->{server_name},
        PeerPort        => $args->{server_port},
        SSL_verify_mode => $verify_mode,
    );

    unless ($ssl_socket) {
        Mail::Reporter->log( ERROR => "Couldn't connect to '$args->{server_name}': "
              . IO::Socket::SSL::errstr() );
        return;
    }

    my $imap = Mail::IMAPClient->new(
        User     => $args->{username},
        Password => $args->{password},
        Socket   => $ssl_socket,
        Uid      => 1,                # Mail::Transport::IMAP4 does this
        Peek     => 1,                # Mail::Transport::IMAP4 does this
    );
    my $imap_err = $@;

    unless ( $imap && $imap->IsAuthenticated ) {
        Mail::Reporter->log( ERROR => "Login rejected for user '$args->{username}'"
              . " on server '$args->{server_name}': $imap_err" );
        return;
    }

    $args->{transporter} = Mail::Transport::IMAP4->new( imap_client => $imap, );

    unless ( $args->{transporter} ) {
        Mail::Reporter->log(
            ERROR => "Error creating Mail::Transport::IMAP4 from the SSL connection." );
        return;
    }

    # now that we have a valid transporter, mark ourselves open
    # and let the superclass initialize
    delete $self->{MB_is_closed};
    $self->SUPER::init($args);

}

sub type { 'imaps' }

1;

__END__