view release on metacpan or  search on metacpan

lib/Mail/IMAPClient.pm  view on Meta::CPAN

# _{name} methods are undocumented and meant to be private.

require 5.008_001;

use strict;
use warnings;

package Mail::IMAPClient;
our $VERSION = '3.43';

use Mail::IMAPClient::MessageSet;

use IO::Socket qw(:crlf SOL_SOCKET SO_KEEPALIVE);
use IO::Select ();
use Carp qw(carp);    #local $SIG{__WARN__} = \&Carp::cluck; #DEBUG

use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use Errno qw(EAGAIN EBADF ECONNRESET EPIPE);
use List::Util qw(first min max sum);
use MIME::Base64 qw(encode_base64 decode_base64);
use File::Spec ();

use constant APPEND_BUFFER_SIZE => 1024 * 1024;

use constant {
    Unconnected   => 0,
    Connected     => 1,    # connected; not logged in
    Authenticated => 2,    # logged in; no mailbox selected
    Selected      => 3,    # mailbox selected
};

use constant {
    INDEX => 0,    # Array index for output line number
    TYPE  => 1,    # Array index for line type (OUTPUT, INPUT, or LITERAL)
    DATA  => 2,    # Array index for output line data
};

my %SEARCH_KEYS = map { ( $_ => 1 ) } qw(
  ALL ANSWERED BCC BEFORE BODY CC DELETED DRAFT FLAGGED
  FROM HEADER KEYWORD LARGER NEW NOT OLD ON OR RECENT
  SEEN SENTBEFORE SENTON SENTSINCE SINCE SMALLER SUBJECT
  TEXT TO UID UNANSWERED UNDELETED UNDRAFT UNFLAGGED
  UNKEYWORD UNSEEN);

# modules require(d) during runtime when applicable
my %Load_Module = (
    "Compress-Zlib" => "Compress::Zlib",
    "INET"          => "IO::Socket::INET",
    "IP"            => "IO::Socket::IP",
    "SSL"           => "IO::Socket::SSL",
    "UNIX"          => "IO::Socket::UNIX",
    "BodyStructure" => "Mail::IMAPClient::BodyStructure",
    "Envelope"      => "Mail::IMAPClient::BodyStructure::Envelope",
    "Thread"        => "Mail::IMAPClient::Thread",
);

sub _load_module {
    my $self   = shift;
    my $modkey = shift;
    my $module = $Load_Module{$modkey} || $modkey;

    my $err = do {
        local ($@);
        eval "require $module";
        $@;
    };
    if ($err) {
        $self->LastError("Unable to load '$module': $err");
        return undef;
    }
    return $module;
}

sub _debug {
    my $self = shift;
    return unless $self->Debug;

    my $text = join '', @_;
    $text =~ s/$CRLF/\n  /og;
    $text =~ s/\s*$/\n/;

    #use POSIX (); $text = POSIX::strftime("%F %T ", localtime).$text; #DEBUG
    my $fh = $self->{Debug_fh} || \*STDERR;
    print $fh $text;
}

BEGIN {

    # set-up accessors
    foreach my $datum (
        qw(Authcallback Authmechanism Authuser Buffer Count Compress
        Debug Debug_fh Domain Folder Ignoresizeerrors Keepalive
        Maxappendstringlength Maxcommandlength Maxtemperrors
        Password Peek Port Prewritemethod Proxy Ranges Readmethod
        Readmoremethod Reconnectretry Server Showcredentials
        Socketargs Ssl Starttls Supportedflags Timeout Uid User)
      )
    {
        no strict 'refs';
        *$datum = sub {
            @_ > 1 ? ( $_[0]->{$datum} = $_[1] ) : $_[0]->{$datum};
        };
    }
}

sub LastError {
    my $self = shift;
    @_ or return $self->{LastError};
    my $err = shift;

lib/Mail/IMAPClient.pm  view on Meta::CPAN

            $self->_debug( "LITERAL: received literal in line "
                  . "$current_line of length $expected_size; attempting to "
                  . "retrieve from the "
                  . length($iBuffer)
                  . " bytes in: $iBuffer<END_OF_iBuffer>" );

            my $litstring;
            if ( length $iBuffer >= $expected_size ) {

                # already received all data
                $litstring = substr $iBuffer, 0, $expected_size, '';
            }
            else {    # literal data still to arrive
                $litstring = $iBuffer;
                $iBuffer   = '';

                my $litreadb = length($litstring);
                my $temperrs = 0;
                my $maxagain = $self->Maxtemperrors;
                undef $maxagain if $maxagain and lc($maxagain) eq 'unlimited';

                while ( $expected_size > $litreadb ) {
                    if ($timeout) {
                        my $rc = $self->_read_more( $socket, $timeout );
                        return undef unless ( $rc > 0 );
                    }
                    else {    # 25 ms before retry
                        CORE::select( undef, undef, undef, 0.025 );
                    }

                    # $litstring is emptied when $literal_cbtype is GLOB
                    my $ret =
                      $self->_sysread( $socket, \$litstring,
                        $expected_size - $litreadb,
                        length($litstring) );

                    if ($timeout) {
                        if ( defined $ret ) {
                            $temperrs = 0;
                        }
                        else {
                            $emsg = "error while reading data from server: $!";
                            if ( $! == ECONNRESET ) {
                                $self->State(Unconnected);
                            }
                            elsif ( $! == EAGAIN ) {
                                if ( defined $maxagain
                                    && $temperrs++ >= $maxagain )
                                {
                                    $emsg .= " ($temperrs)";
                                }
                                else {
                                    undef $emsg;
                                    next;    # try again
                                }
                            }
                        }
                    }

                    # EOF: note IO::Socket::SSL does not support eof()
                    if ( defined $ret and $ret == 0 ) {
                        $emsg = "socket closed while reading data from server";
                        $self->State(Unconnected);
                    }
                    elsif ( defined $ret and $ret > 0 ) {
                        $litreadb += $ret;

                        # conserve memory when using literal_callback GLOB
                        if ( $literal_cbtype eq "GLOB" ) {
                            print $literal_callback $litstring;
                            $litstring = "" unless ($emsg);
                        }
                    }

                    $self->_debug( "Received ret="
                          . ( defined($ret) ? $ret : "<undef>" )
                          . " $litreadb of $expected_size" );

                    # save errors and return
                    if ($emsg) {
                        $self->LastError($emsg);
                        $self->_record(
                            $transno,
                            [
                                $self->_next_index($transno), "ERROR",
                                "$transno * NO $emsg"
                            ]
                        );
                        $litstring = "" unless defined $litstring;
                        $self->_debug( "ERROR while processing LITERAL, "
                              . " buffer=\n"
                              . $litstring
                              . "<END>\n" );
                        return undef;
                    }
                }
            }

            if ( defined $litstring ) {
                if ( $literal_cbtype eq "GLOB" ) {
                    print $literal_callback $litstring;
                }
                elsif ( $literal_cbtype eq "CODE" ) {
                    $literal_callback->($litstring);
                }
            }

            push @$oBuffer, [ $index++, 'LITERAL', $litstring ]
              if ( $literal_cbtype ne "GLOB" );
        }
    }

    $self->_debug( "Read: " . join "", map { "\t" . $_->[DATA] } @$oBuffer )
      if ( $self->Debug );

    @$oBuffer ? $oBuffer : undef;
}

sub _sysread {
    my ( $self, $fh, $buf, $len, $off ) = @_;
    my $rm = $self->Readmethod;
    $rm ? $rm->(@_) : sysread( $fh, $$buf, $len, $off );
}

sub _read_more {
    my $self = shift;
    my $rm   = $self->Readmoremethod;
    $rm ? $rm->( $self, @_ ) : $self->__read_more(@_);
}

sub __read_more {
    my $self = shift;
    my $opt = ref( $_[0] ) eq "HASH" ? shift : {};
    my ( $socket, $timeout ) = @_;

    # IO::Socket::SSL buffers some data internally, so there might be some
    # data available from the previous sysread of which the file-handle
    # (used by select()) doesn't know of.
    return 1 if $socket->isa("IO::Socket::SSL") && $socket->pending;

    my $rvec = '';
    vec( $rvec, fileno($socket), 1 ) = 1;

    my $rc = CORE::select( $rvec, undef, $rvec, $timeout );

    # fast track success
    return $rc if $rc > 0;

    # by default set an error on timeout
    my $err_on_timeout =
      exists $opt->{error_on_timeout} ? $opt->{error_on_timeout} : 1;

    # $rc is 0 then we timed out
    return $rc if !$rc and !$err_on_timeout;

    # set the appropriate error and return
    my $transno = $self->Transaction;
    my $msg =
        ( $rc ? "error($rc)" : "timeout" )
      . " waiting ${timeout}s for data from server"
      . ( $! ? ": $!" : "" );
    $self->LastError($msg);
    $self->_record( $transno,
        [ $self->_next_index($transno), "ERROR", "$transno * NO $msg" ] );
    $self->_disconnect;    # BUG: can not handle timeouts gracefully
    return $rc;
}

sub _trans_index() {
    sort { $a <=> $b } keys %{ $_[0]->{History} };
}

# all default to last transaction
sub _transaction(;$) {
    @{ $_[0]->{History}{ $_[1] || $_[0]->Transaction } || [] };
}

sub _trans_data(;$) {
    map { $_->[DATA] } $_[0]->_transaction( $_[1] );
}

sub _escaped_trans_data(;$) {
    my ( $self, $trans ) = @_;
    my @a;
    my $prevwasliteral = 0;
    foreach my $line ( $self->_transaction($trans) ) {
        next unless defined $line;

        my $data = $line->[DATA];

        # literal is appended to previous data
        if ( $self->_is_literal($line) ) {
            $data = $self->Escape($data);
            $a[-1] .= qq("$data");
            $prevwasliteral = 1;
        }
        else {
            if ($prevwasliteral) {
                $a[-1] .= $data;