view release on metacpan or  search on metacpan

lib/Net/IMAP/Simple.pm  view on Meta::CPAN

package Net::IMAP::Simple;

use strict;
use warnings;

use Carp;
use IO::File;
use IO::Socket;
use IO::Select;
use Net::IMAP::Simple::PipeSocket;

our $VERSION = "1.2212";

BEGIN {
    # I'd really rather the pause/cpan indexers miss this "package"
    eval ## no critic
    q( package Net::IMAP::Simple::_message;
       use overload fallback=>1, '""' => sub { local $"=""; "@{$_[0]}" };
       sub new { bless $_[1] })
}

our $uidm;

sub new {
    my ( $class, $server, %opts ) = @_;

    ## warn "use of Net::IMAP::Simple::SSL is depricated, pass use_ssl to new() instead\n"
    ##     if $class =~ m/::SSL/;

    my $self = bless { count => -1 } => $class;

    $self->{use_v6}  = ( $opts{use_v6}  ? 1 : 0 );
    $self->{use_ssl} = ( $opts{use_ssl} ? 1 : 0 );

    unless( $opts{shutup_about_v6ssl} ) {
        carp "use_ssl with IPv6 is not yet supported"
            if $opts{use_v6} and $opts{use_ssl};
    }

    if( $opts{ssl_version} ) {
        $self->{ssl_version} = $opts{ssl_version};
        $opts{use_ssl} = 1;
    }

    $opts{use_ssl} = 1 if $opts{find_ssl_defaults};

    if( $opts{use_ssl} ) {
        eval {
            require IO::Socket::SSL;
            import IO::Socket::SSL;
            "true";

        } or croak "IO::Socket::SSL must be installed in order to use_ssl";

         $self->{ssl_options}       = [ eval {@{ $opts{ssl_options} }} ];
         carp "ignoring ssl_options: $@" if $opts{ssl_options} and not @{ $self->{ssl_options} };

        unless( @{ $self->{ssl_options} } ) {
            if( $opts{find_ssl_defaults} ) {
                my $nothing = 1;

                for(qw(
                            /etc/ssl/certs/ca-certificates.crt
                            /etc/pki/tls/certs/ca-bundle.crt
                            /etc/ssl/ca-bundle.pem
                            /etc/ssl/certs/
                    )) {

                    if( -f $_ ) {
                        @{ $self->{ssl_options} } = (SSL_ca_file=>$_, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER());
                        $nothing = 0;
                        last;

                    } elsif( -d $_ ) {
                        @{ $self->{ssl_options} } = (SSL_ca_path=>$_, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER());
                        $nothing = 0;
                        last;
                    }
                }

                if( $nothing ) {
                    carp "couldn't find rational defaults for ssl verify.  Choosing to not verify.";
                    @{ $self->{ssl_options} } = (SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE());
                }

            } else {
                @{ $self->{ssl_options} } = (SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE());
            }
        }
    }

    if ( $opts{use_v6} ) {
        eval {
            require IO::Socket::INET6;
            import  IO::Socket::INET6;
            "true";

        } or croak "IO::Socket::INET6 must be installed in order to use_v6";
    }

    if( $server =~ m/cmd:(.+)/ ) {
        $self->{cmd} = $1;

    } else {
        if( ($self->{server}, $self->{port}) = $server =~ m/^(\d{1,3}(?:\.\d{1,3}){3})(?::(\d+))?\z/ ) {

        } elsif( ($self->{server}, $self->{port}) = $server =~ m/^\[([a-fA-F0-9:]+)\]:(\d+)\z/ ) {

        } elsif( ($self->{server}, $self->{port}) = $server =~ m/^([a-fA-F0-9:]+)\z/ ) {

        } elsif( ($self->{server}, $self->{port}) = $server =~ m/^([^:]+):(\d+)\z/ ) {

        } else {
            $self->{server} = $server;
            $self->{port}   = $opts{port};
        }

        $self->{port} = $self->_port unless defined $self->{port};
    }

    $self->{timeout}           = ( $opts{timeout} ? $opts{timeout} : $self->_timeout );
    $self->{retry}             = ( defined($opts{retry}) ? $opts{retry} : $self->_retry );
    $self->{retry_delay}       = ( defined($opts{retry_delay}) ? $opts{retry_delay} : $self->_retry_delay );
    $self->{bindaddr}          = $opts{bindaddr};
    $self->{use_select_cache}  = $opts{use_select_cache};
    $self->{select_cache_ttl}  = $opts{select_cache_ttl};
    $self->{debug}             = $opts{debug};
    $self->{readline_callback} = $opts{readline_callback};

    my $sock;
    my $c;
    for ( my $i = 0 ; $i <= $self->{retry} ; $i++ ) {
        if ( $sock = $self->{sock} = $self->_connect ) {
            $c = 1;
            last;

        } elsif ( $i < $self->{retry} ) {
            sleep $self->{retry_delay};

            # Critic NOTE: I'm not sure why this was done, but it was removed
            # beucase the critic said it was bad and sleep makes more sense.
            # select( undef, undef, undef, $self->{retry_delay} );
        }
    }

    if ( !$c ) {
        $@ =~ s/IO::Socket::INET6?: //g;

lib/Net/IMAP/Simple.pm  view on Meta::CPAN

        $self->_debug( caller, __LINE__, 'new', "looking for greeting" ) if $self->{debug};
        if( my $line = $sock->getline ) {
            # Cool, we got a line, check to see if it's a
            # greeting.

            $self->_debug( caller, __LINE__, 'new', "got a greeting: $line" ) if $self->{debug};
            $greeting_ok = 1 if $line =~ m/^\*\s+(?:OK|PREAUTH)/i;

            # Also, check to see if we failed before we sent any
            # commands.
            return if $line =~ /^\*\s+(?:NO|BAD)(?:\s+(.+))?/i;

        } else {
            $self->_debug( caller, __LINE__, 'new', "server hung up during connect" ) if $self->{debug};

            # The server hung up on us, otherwise we'd get a line
            # after can_read.
            return;
        }

    } else {
        $self->_debug( caller, __LINE__, 'new', "no greeting found before timeout" ) if $self->{debug};
    }

    return unless $greeting_ok;
    return $self;
}

sub _connect {
    my ($self) = @_;
    my $sock;

    if( $self->{cmd} ) {
        $self->_debug( caller, __LINE__, '_connect', "popping open a pipesocket for command: $self->{cmd}" ) if $self->{debug};
        $sock = Net::IMAP::Simple::PipeSocket->new(cmd=>$self->{cmd});

    } else {
        $self->_debug( caller, __LINE__, '_connect', "connecting to $self->{server}:$self->{port}" ) if $self->{debug};
        $sock = $self->_sock_from->new(
            PeerAddr => $self->{server},
            PeerPort => $self->{port},
            Timeout  => $self->{timeout},
            Proto    => 'tcp',
            ( $self->{bindaddr}    ? ( LocalAddr => $self->{bindaddr} )      : () ),
            ( $_[0]->{ssl_version} ? ( SSL_version => $self->{ssl_version} ) : () ),
            ( $_[0]->{use_ssl}     ? (@{ $self->{ssl_options} })             : () ),
        );
    }

    $self->_debug( caller, __LINE__, '_connect', "connected, returning socket" ) if $self->{debug};
    return $sock;
}

sub _port        { return $_[0]->{use_ssl} ? 993 : 143 }
sub _sock        { return $_[0]->{sock} }
sub _count       { return $_[0]->{count} }
sub _last        { $_[0]->select unless exists $_[0]->{last}; return $_[0]->{last}||0 }
sub _timeout     { return 90 }
sub _retry       { return 1 }
sub _retry_delay { return 5 }
sub _sock_from   { return $_[0]->{use_v6} ? 'IO::Socket::INET6' : $_[0]->{use_ssl} ? 'IO::Socket::SSL' : 'IO::Socket::INET' }

sub starttls {
    my ($self) = @_;

    require IO::Socket::SSL; import IO::Socket::SSL;
    require Net::SSLeay;     import Net::SSLeay;

    # $self->{debug} = 1;
    # warn "Processing STARTTLS command";

    return $self->_process_cmd(
        cmd   => ['STARTTLS'],
        final => sub {
            Net::SSLeay::load_error_strings();
            Net::SSLeay::SSLeay_add_ssl_algorithms();
            Net::SSLeay::randomize();

            my $startres = IO::Socket::SSL->start_SSL(
                $self->{sock},
                SSL_version        => $self->{ssl_version} || "SSLv3 TLSv1",
                SSL_startHandshake => 0,
            );

            unless ( $startres ) {
                croak "Couldn't start TLS: " . IO::Socket::SSL::errstr() . "\n";
            }

            $self->_debug( caller, __LINE__, 'starttls', "TLS initialization done" ) if $self->{debug};
            1;
        },

        # process => sub { push @lines, $_[0] if $_[0] =~ /^(?: \s+\S+ | [^:]+: )/x },
    );
}

sub login {
    my ( $self, $user, $pass ) = @_;

    $pass = _escape($pass);

    return $self->_process_cmd(
        cmd     => [ LOGIN => qq[$user $pass] ],
        final   => sub { 1 },
        process => sub { },
    );
}

sub separator {
    my ( $self, ) = @_;
    my $sep;

        return $self->_process_cmd (
        cmd     => [ LIST => qq["" ""]  ],
        final => sub { $sep },
        process => sub { (undef,undef,undef,$sep,undef) = split /\s/smx , $_[0];
                        $sep =~ s/["]//g;  },
    );
}

sub _clear_cache {
    my $self = shift;
    my $cb = $self->current_box;

    push @_, $cb if $cb and not @_;
    return unless @_;

    for my $box (@_) {
        delete $self->{BOXES}{$box};
    }

    delete $self->{last};

    return 1;
}

sub uidnext {
    my $self = shift;
    my $mbox = shift || $self->current_box || "INBOX";

    return $self->status($mbox => 'uidnext');
}

sub uidvalidity {
    my $self = shift;
    my $mbox = shift || $self->current_box || "INBOX";