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.2206";
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;
$Net::IMAP::Simple::errstr = "connection failed $@";
return;
}
return unless $sock;
my $select = $self->{sel} = IO::Select->new($sock);
$self->_debug( caller, __LINE__, 'new', "waiting for socket ready" ) if $self->{debug};
my $greeting_ok = 0;
if( $select->can_read($self->{timeout}) ) {
$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";
return $self->status($mbox => 'uidvalidity');
}
sub uidsearch {
my $self = shift;
local $uidm = 1;
return $self->search(@_);
}
sub uid {
my $self = shift;
$self->_be_on_a_box; # does a select if we're not on a mailbox
return $self->uidsearch( shift || "1:*" );
}
sub seq {
my $self = shift;
my $msgno = shift || "1:*";
$self->_be_on_a_box; # does a select if we're not on a mailbox
return $self->search("uid $msgno");
}
sub status {
my $self = shift;
my $mbox = shift || $self->current_box || "INBOX";
my @fields = @_ ? @_ : qw(unseen recent messages);
# Example: C: A042 STATUS blurdybloop (UIDNEXT MESSAGES)
# S: * STATUS blurdybloop (MESSAGES 231 UIDNEXT 44292)
# S: A042 OK STATUS completed
@fields = map{uc$_} @fields;
my %fields;
return $self->_process_cmd(
cmd => [ STATUS => _escape($mbox) . " (@fields)" ],
final => sub { (@fields{@fields}) },
process => sub {
if( my ($status) = $_[0] =~ m/\* STATUS.+?$mbox.+?\((.+?)\)/i ) {
for( @fields ) {
$fields{$_} = _unescape($1)
if $status =~ m/$_\s+(\S+|"[^"]+"|'[^']+')/i
# NOTE: this regex isn't perfect, but should almost always work
# for status values returned by a well meaning IMAP server
}
}
},
);
}
sub select { ## no critic -- too late to choose a different name now...
my ( $self, $mbox, $examine_mode ) = @_;
$examine_mode = $examine_mode ? 1:0;
$self->{examine_mode} = 0 unless exists $self->{examine_mode};
$mbox = $self->current_box unless $mbox;
if( $examine_mode == $self->{examine_mode} ) {
if ( $self->{use_select_cache} && ( time - $self->{BOXES}{$mbox}{proc_time} ) <= $self->{select_cache_ttl} ) {
return $self->{BOXES}{$mbox}{messages};
}
}
$self->{BOXES}{$mbox}{proc_time} = time;
my $cmd = $examine_mode ? 'EXAMINE' : 'SELECT';
return $self->_process_cmd(
cmd => [ $cmd => _escape($mbox) ],
final => sub {
my $nm = $self->{last} = $self->{BOXES}{$mbox}{messages};
$self->{working_box} = $mbox;
$self->{examine_mode} = $examine_mode;
$nm ? $nm : "0E0";
},
process => sub {
if ( $_[0] =~ /^\*\s+(\d+)\s+EXISTS/i ) {
$self->{BOXES}{$mbox}{messages} = $1;
} elsif ( $_[0] =~ /^\*\s+FLAGS\s+\((.*?)\)/i ) {
$self->{BOXES}{$mbox}{flags} = [ split( /\s+/, $1 ) ];
} elsif ( $_[0] =~ /^\*\s+(\d+)\s+RECENT/i ) {
$self->{BOXES}{$mbox}{recent} = $1;
} elsif ( $_[0] =~ /^\*\s+OK\s+\[(.*?)\s+(.*?)\]/i ) {
my ( $flag, $value ) = ( $1, $2 );
if ( $value =~ /\((.*?)\)/ ) {
# NOTE: the sflags really aren't used anywhere, should they be?
$self->{BOXES}{$mbox}{sflags}{$flag} = [ split( /\s+/, $1 ) ];
} else {
$self->{BOXES}{$mbox}{oflags}{$flag} = $value;
}
}
},
);
}
sub examine {
my $self = shift;
return $self->select($_[0], 1);
}
sub messages {
my ( $self, $folder ) = @_;
return $self->select($folder);
}
sub flags {
my ( $self, $folder ) = @_;
$self->select($folder);
return @{ $self->{BOXES}{ $self->current_box }{flags} || [] };
}
sub recent {
my ( $self, $folder ) = @_;
$self->select($folder);
return $self->{BOXES}{ $self->current_box }{recent};
}
sub unseen {
my ( $self, $folder ) = @_;
my $oflags = $self->{BOXES}{ $self->current_box }{oflags};
if( exists $oflags->{UNSEEN} ) {
$self->select($folder);
return $self->{BOXES}{ $self->current_box }{oflags}{UNSEEN};
}
my ($unseen) = $self->status;
return $unseen;
}
sub current_box {
my ($self) = @_;
return ( $self->{working_box} ? $self->{working_box} : 'INBOX' );
}
sub close { ## no critic -- we already have tons of methods with built in names
my $self = shift;
$self->{working_box} = undef;
return $self->_process_cmd(
cmd => [ "CLOSE" ],
);
}
sub noop {
my $self = shift;
return $self->_process_cmd(
cmd => [ "NOOP" ],
);
}
sub top {
my ( $self, $number ) = @_;
my $messages = $number || '1:' . $self->_last;
my @lines;
## rfc2822 ## 2.2. Header Fields
## rfc2822 ## Header fields are lines composed of a field name, followed by a colon
## rfc2822 ## (":"), followed by a field body, and terminated by CRLF. A field
## rfc2822 ## name MUST be composed of printable US-ASCII characters (i.e.,
## rfc2822 ## characters that have values between 33 and 126, inclusive), except
## rfc2822 ## colon. A field body may be composed of any US-ASCII characters,
## rfc2822 ## except for CR and LF. However, a field body may contain CRLF when
## rfc2822 ## used in header "folding" and "unfolding" as described in section
## rfc2822 ## 2.2.3. All field bodies MUST conform to the syntax described in
## rfc2822 ## sections 3 and 4 of this standard.
return $self->_process_cmd(
cmd => [ FETCH => qq[$messages RFC822.HEADER] ],
final => sub {
$lines[-1] =~ s/\)\x0d\x0a\z// # sometimes we get this and I don't think we should
# I really hoping I'm not breaking someting by doing this.
if @lines;
return wantarray ? @lines : \@lines
},
process => sub {
return if $_[0] =~ m/\*\s+\d+\s+FETCH/i; # should this really be case insensitive?
if( not @lines or $_[0] =~ m/^[!-9;-~]+:/ ) {
push @lines, $_[0];
} else {
$lines[-1] .= $_[0];
}
},
);
}
sub seen {
my ( $self, $number ) = @_;
my @flags = $self->msg_flags($number);
return if $self->waserr;
return 1 if grep {$_ eq '\Seen'} @flags;
return 0;
}
sub deleted {
my ( $self, $number ) = @_;
my @flags = $self->msg_flags($number);
return if $self->waserr;
return 1 if grep {$_ eq '\Deleted'} @flags;
return 0;
}
sub range2list {
my $self_or_class = shift;
my %h;
my @items = grep {!$h{$_}++} map { m/(\d+):(\d+)/ ? ($1 .. $2) : ($_) } split(m/[,\s]+/, shift);
return @items;
}
sub list2range {
my $self_or_class = shift;
my %h;
my @a = sort { $a<=>$b } grep {!$h{$_}++} grep {m/^\d+/} grep {defined $_} @_;
my @b;
while(@a) {
my $e = 0;
$e++ while $e+1 < @a and $a[$e]+1 == $a[$e+1];
push @b, ($e>0 ? [$a[0], $a[$e]] : [$a[0]]);
splice @a, 0, $e+1;
}
return join(",", map {join(":", @$_)} @b);
}
sub list {
my ( $self, $number ) = @_;
# NOTE: this entire function is horrible:
# 1. it should be called message_size() or something similar
# 2. what if $number is a range? none of this works right
my $messages = $number || '1:' . $self->_last;
my %list;
return {} if $messages eq "1:0";
return $self->_process_cmd(
cmd => [ FETCH => qq[$messages RFC822.SIZE] ],
final => sub { $number ? $list{$number} : \%list },
process => sub {
if ( $_[0] =~ /^\*\s+(\d+).*RFC822.SIZE\s+(\d+)/i ) {
$list{$1} = $2;
}
},
);
}
sub search {
my ($self, $search, $sort, $charset) = @_;
$search ||= "ALL";
$charset ||= 'UTF-8';
my $cmd = $uidm ? 'UID SEARCH' : 'SEARCH';
$self->_be_on_a_box; # does a select if we're not on a mailbox
# add rfc5256 sort, requires charset :(
if ($sort) {
$sort = uc $sort;
$cmd = ($uidm ? "UID ": "") . "SORT ($sort) \"$charset\"";
}
my @seq;
return $self->_process_cmd(
cmd => [ $cmd => $search ],
final => sub { wantarray ? @seq : int @seq },
process => sub { if ( my ($msgs) = $_[0] =~ /^\*\s+(?:SEARCH|SORT)\s+(.*)/i ) {
@seq = $self->range2list($msgs);
}},
);
}
sub search_seen { my $self = shift; return $self->search("SEEN"); }
sub search_recent { my $self = shift; return $self->search("RECENT"); }
sub search_answered { my $self = shift; return $self->search("ANSWERED"); }
sub search_deleted { my $self = shift; return $self->search("DELETED"); }
sub search_flagged { my $self = shift; return $self->search("FLAGGED"); }
sub search_draft { my $self = shift; return $self->search("FLAGGED"); }
sub search_unseen { my $self = shift; return $self->search("UNSEEN"); }
sub search_old { my $self = shift; return $self->search("OLD"); }
sub search_unanswered { my $self = shift; return $self->search("UNANSWERED"); }
sub search_undeleted { my $self = shift; return $self->search("UNDELETED"); }
sub search_unflagged { my $self = shift; return $self->search("UNFLAGGED"); }
sub search_smaller { my $self = shift; my $octets = int shift; return $self->search("SMALLER $octets"); }
sub search_larger { my $self = shift; my $octets = int shift; return $self->search("LARGER $octets"); }
sub _process_date {
my $d = shift;
if( eval 'use Date::Manip (); 1' ) { ## no critic
if( my $pd = Date::Manip::ParseDate($d) ) {
# NOTE: RFC 3501 wants this poorly-internationalized date format
# for SEARCH. Not my fault.
return Date::Manip::UnixDate($pd, '%d-%b-%Y');
}
} else {
# TODO: complain if the date isn't %d-%m-%Y
# I'm not sure there's anything to be gained by doing so ... They'll
# just get an imap error they can choose to handle.
}
return $d;
}
sub _process_qstring {
my $t = shift;
$t =~ s/\\/\\\\/g;
$t =~ s/"/\\"/g;
return "\"$t\"";
}
sub search_before { my $self = shift; my $d = _process_date(shift); return $self->search("BEFORE $d"); }
sub search_since { my $self = shift; my $d = _process_date(shift); return $self->search("SINCE $d"); }
sub search_sent_before { my $self = shift; my $d = _process_date(shift); return $self->search("SENTBEFORE $d"); }
sub search_sent_since { my $self = shift; my $d = _process_date(shift); return $self->search("SENTSINCE $d"); }
sub search_from { my $self = shift; my $t = _process_qstring(shift); return $self->search("FROM $t"); }
sub search_to { my $self = shift; my $t = _process_qstring(shift); return $self->search("TO $t"); }
sub search_cc { my $self = shift; my $t = _process_qstring(shift); return $self->search("CC $t"); }
sub search_bcc { my $self = shift; my $t = _process_qstring(shift); return $self->search("BCC $t"); }
sub search_subject { my $self = shift; my $t = _process_qstring(shift); return $self->search("SUBJECT $t"); }
sub search_body { my $self = shift; my $t = _process_qstring(shift); return $self->search("BODY $t"); }
sub get {
my ( $self, $number, $part ) = @_;
my $arg = $part ? "BODY[$part]" : 'RFC822';
my @lines;
my $fetching;
return $self->_process_cmd(
cmd => [ FETCH => qq[$number $arg] ],
final => sub {
if( $fetching ) {
if( $fetching > 0 ) {
# XXX: this is just about the least efficient way in the
# world to do this; I should appologize, but really,
# nothing in this module is done particularly well. I
# doubt anyone will notice this.
local $"="";
my $message = "@lines";
@lines = split m/(?<=\x0d\x0a)/, substr($message, 0, $fetching)
if( length $message > $fetching );
}
return wantarray ? @lines : Net::IMAP::Simple::_message->new(\@lines)
}
if( defined $fetching and $fetching == 0 ) {
return "\n"; # XXX: Your 0 byte message is incorrectly returned as a newline. Meh.
}
# NOTE: There is not supposed to be an error if you ask for a
# message that's not there, but this is a rather confusing
# notion … so we generate an error here.
$self->{_errstr} = "message not found";
return;
},
process => sub {
if ( $_[0] =~ /^\*\s+\d+\s+FETCH\s+\(.+?\{(\d+)\}/ ) {
$fetching = $1;
} elsif( $_[0] =~ /^\*\s+\d+\s+FETCH\s+\(.+?\"(.*)\"\s*\)/ ) {
# XXX: this is not tested because Net::IMAP::Server doesn't do
# this type of string result (that I know of) for this it might
# work, ... frog knows. Not likely to come up very often, if
# ever; although you do sometimes see the occasional 0byte
# message. Valid really.
$fetching = -1;
@lines = ($1);
} elsif( $fetching ) {
push @lines, join( ' ', @_ );
}
},
);
}
sub _process_flags {
my $self = shift;
my @ret = map { split m/\s+/, $_ } grep { $_ } @_;
return @ret;
}
sub put {
my ( $self, $mailbox_name, $msg, @flags ) = @_;
croak "usage: \$imap->put(mailbox, message, \@flags)" unless defined $msg and defined $mailbox_name;
my $size = length $msg;
if ( ref $msg eq "ARRAY" ) {
$size = 0;
$size += length $_ for @$msg;
}
@flags = $self->_process_flags(@flags);
return $self->_process_cmd(
cmd => [ APPEND => _escape($mailbox_name) ." (@flags) {$size}" ],
final => sub { $self->_clear_cache; 1 },
process => sub {
if( $_[0] =~ m/^\+\s+/ ) { # + continue (or go ahead, or whatever)
if ($size) {
my $sock = $self->_sock;
if ( ref $msg eq "ARRAY" ) {
print $sock $_ for @$msg;
} else {
print $sock $msg;
}
$size = undef;
print $sock "\r\n";
}
}
},
);
}
sub msg_flags {
my ( $self, $number ) = @_;
my @flags;
$self->{_waserr} = 1; # assume something went wrong.
$self->{_errstr} = "flags not found during fetch";
# _send_cmd] 15 FETCH 12 (FLAGS)\r\n
# _process_cmd] * 12 FETCH (FLAGS (\Seen))\r\n
# _cmd_ok] * 12 FETCH (FLAGS (\Seen))\r\n
# _seterrstr] warning unknown return string (id=15): * 12 FETCH (FLAGS (\Seen))\r\n
# _process_cmd] 15 OK Success\r\n
return $self->_process_cmd(
cmd => [ FETCH => qq[$number (FLAGS)] ],
final => sub {
return if $self->{_waserr};
wantarray ? @flags : "@flags";
},
process => sub {
if( $_[0] =~ m/\* $number FETCH \(FLAGS \(([^()]*?)\)\)/i ) {
@flags = $self->_process_flags($1);
delete $self->{_waserr};
}
},
);
}
sub getfh {
my ( $self, $number ) = @_;
my $file = IO::File->new_tmpfile;
my $buffer;
return $self->_process_cmd(
cmd => [ FETCH => qq[$number RFC822] ],
final => sub { seek $file, 0, 0; $file },
process => sub {
if ( $_[0] !~ /^\* \d+ FETCH/ ) {
defined($buffer) and print $file $buffer;
$buffer = $_[0];
}
},
);
}
sub logout {
my $self = shift;
return $self->_process_cmd( cmd => ['LOGOUT'], final => sub { $self->_sock->close; 1 }, process => sub { } );
}
sub quit {
my ( $self, $hq ) = @_;
$self->_send_cmd('EXPUNGE'); # XXX: $self->expunge_mailbox?
if ( !$hq ) {
# XXX: $self->logout?
$self->_process_cmd( cmd => ['LOGOUT'], final => sub { 1 }, process => sub { } );
} else {
# XXX: do people use the $hq?
$self->_send_cmd('LOGOUT');
}
$self->_sock->close;
return 1;
}
sub _be_on_a_box {
my $self = shift;
return if $self->{working_box};
$self->select; # sit on something
return;
}
sub last { ## no critic -- too late to choose a different name now...
my $self = shift;
my $last = $self->_last;
if( not defined $last ) {
$self->select or return;
$last = $self->_last;
}
return $last;
}
sub add_flags {
my ( $self, $number, @flags ) = @_;
@flags = $self->_process_flags(@flags);
return unless @flags;
return $self->_process_cmd(
cmd => [ STORE => qq[$number +FLAGS (@flags)] ],
final => sub { $self->_clear_cache },
process => sub { },
);
}
sub sub_flags {
my ( $self, $number, @flags ) = @_;
@flags = $self->_process_flags(@flags);
return unless @flags;
return $self->_process_cmd(
cmd => [ STORE => qq[$number -FLAGS (@flags)] ],
final => sub { $self->_clear_cache },
process => sub { },
);
}
sub delete { ## no critic -- too late to choose a different name now...
my ( $self, $number ) = @_;
return $self->add_flags( $number, '\Deleted' );
}
sub undelete {
my ( $self, $number ) = @_;
return $self->sub_flags( $number, '\Deleted' );
}
sub see {
my ( $self, $number ) = @_;
return $self->add_flags( $number, '\Seen' );
}
sub unsee {
my ( $self, $number ) = @_;
return $self->sub_flags( $number, '\Seen' );
}
sub _process_list {
my ( $self, $line ) = @_;
$self->_debug( caller, __LINE__, '_process_list', $line ) if $self->{debug};
my @list;
if ( $line =~ /^\*\s+(LIST|LSUB).*\s+\{\d+\}\s*$/i ) {
chomp( my $res = $self->_sock->getline );
$res =~ s/\r//;
push @list, _escape($res);
$self->_debug( caller, __LINE__, '_process_list', $res ) if $self->{debug};
} elsif ( $line =~ /^\*\s+(LIST|LSUB).*\s+(\".*?\")\s*$/i || $line =~ /^\*\s+(LIST|LSUB).*\s+(\S+)\s*$/i ) {
push @list, $2;
}
return @list;
}
sub mailboxes {
my ( $self, $box, $ref ) = @_;
$ref ||= '""';
my @list;
if ( !defined $box ) {
# recurse, should probably follow
# RFC 2683: 3.2.1.1. Listing Mailboxes
return $self->_process_cmd(
cmd => [ LIST => qq[$ref *] ],
final => sub { map { _unescape($_) } @list },
process => sub { push @list, $self->_process_list( $_[0] ); },
);
}
return $self->_process_cmd(
cmd => [ LIST => qq[$ref $box] ],
final => sub { map { _unescape($_) } @list },
process => sub { push @list, $self->_process_list( $_[0] ) },
);
}
sub mailboxes_subscribed {
my ( $self, $box, $ref ) = @_;
$ref ||= '""';
my @list;
if ( !defined $box ) {
# recurse, should probably follow
# RFC 2683: 3.2.2. Subscriptions
return $self->_process_cmd(
cmd => [ LSUB => qq[$ref *] ],
final => sub { map { _unescape($_) } @list },
process => sub { push @list, $self->_process_list( $_[0] ) },
);
}
return $self->_process_cmd(
cmd => [ LSUB => qq[$ref $box] ],
final => sub { map { _unescape($_) } @list },
process => sub { push @list, $self->_process_list( $_[0] ) },
);
}
sub create_mailbox {
my ( $self, $box ) = @_;
return $self->_process_cmd(
cmd => [ CREATE => _escape($box) ],
final => sub { 1 },
process => sub { },
);
}
sub expunge_mailbox {
my ( $self, $box ) = @_;
return if !$self->select($box);
# C: A202 EXPUNGE
# S: * 3 EXPUNGE
# S: * 3 EXPUNGE
# S: * 5 EXPUNGE
# S: * 8 EXPUNGE
# S: A202 OK EXPUNGE completed
my @expunged;
return $self->_process_cmd(
cmd => ['EXPUNGE'],
final => sub {
$self->_clear_cache;
return @expunged if wantarray; # don't return 0E0 if want array and we're empty
return "0E0" unless @expunged;
return @expunged;
},
process => sub {
if( $_[0] =~ m/^\s*\*\s+(\d+)\s+EXPUNGE[\r\n]*$/i ) {
push @expunged, $1;
}
},
);
}
sub delete_mailbox {
my ( $self, $box ) = @_;
return $self->_process_cmd(
cmd => [ DELETE => _escape($box) ],
final => sub { 1 },
process => sub { },
);
}
sub rename_mailbox {
my ( $self, $old_box, $new_box ) = @_;
my $o = _escape($old_box);
my $n = _escape($new_box);
return $self->_process_cmd(
cmd => [ RENAME => qq[$o $n] ],
final => sub { 1 },
process => sub { },
);
}
sub folder_subscribe {
my ( $self, $box ) = @_;
$self->select($box);
return $self->_process_cmd(
cmd => [ SUBSCRIBE => _escape($box) ],
final => sub { 1 },
process => sub { },
);
}
sub folder_unsubscribe {
my ( $self, $box ) = @_;
$self->select($box);
return $self->_process_cmd(
cmd => [ UNSUBSCRIBE => _escape($box) ],
final => sub { 1 },
process => sub { },
);
}
sub copy {
my ( $self, $number, $box ) = @_;
my $b = _escape($box);
return $self->_process_cmd(
cmd => [ COPY => qq[$number $b] ],
final => sub { 1 },
process => sub { },
);
}
sub uidcopy {
my ( $self, $number, $box ) = @_;
my $b = _escape($box);
return $self->_process_cmd(
cmd => [ 'UID COPY' => qq[$number $b] ],
final => sub { 1 },
process => sub { },
);
}
sub waserr {
return $_[0]->{_waserr};
}
sub errstr {
return $_[0]->{_errstr};
}
sub _nextid { return ++$_[0]->{count} }
sub _escape {
my $val = shift;
$val =~ s/\\/\\\\/g;
$val =~ s/\"/\\\"/g;
$val = "\"$val\"";
return $val;
}
sub _unescape {
my $val = shift;
$val =~ s/^"//g;
$val =~ s/"$//g;
$val =~ s/\\\"/\"/g;
$val =~ s/\\\\/\\/g;
return $val;
}
sub _send_cmd {
my ( $self, $name, $value ) = @_;
my $sock = $self->_sock;
my $id = $self->_nextid;
my $cmd = "$id $name" . ( $value ? " $value" : "" ) . "\r\n";
$self->_debug( caller, __LINE__, '_send_cmd', $cmd ) if $self->{debug};
{ local $\; print $sock $cmd; }
return ( $sock => $id );
}
sub _cmd_ok {
my ( $self, $res ) = @_;
my $id = $self->_count;
$self->_debug( caller, __LINE__, '_cmd_ok', $res ) if $self->{debug};
if ( $res =~ /^$id\s+OK/i ) {
return 1;
} elsif ( $res =~ /^$id\s+(?:NO|BAD)(?:\s+(.+))?/i ) {
$self->_seterrstr( $1 || 'unknown error' );
return 0;
} elsif ( $res =~ m/^\*\s+/ ) {
} else {
$self->_seterrstr("warning unknown return string (id=$id): $res");
}
return;
}
sub _read_multiline {
my ( $self, $sock, $list, $count ) = @_;
my @lines;
my $read_so_far = 0;
while ( $read_so_far < $count ) {
if( defined( my $line = $sock->getline ) ) {
$read_so_far += length( $line );
push @lines, $line;
} else {
$self->_seterrstr( "error reading $count bytes from socket" );
last;
}
}
if( $list and $lines[-1] !~ m/\)[\x0d\x0a\s]*$/ ) {
$self->_debug( caller, __LINE__, '_read_multiline', "Looking for ending parenthesis match..." ) if $self->{debug};
my $unmatched = 1;
while( $unmatched ) {
if( defined( my $line = $sock->getline ) ) {
push @lines, $line;
$unmatched = 0 if $line =~ m/\)[\x0d\x0a\s]*$/;
} else {
$self->_seterrstr( "error reading $count bytes from socket" );
last;
}
}
}
if ( $self->{debug} ) {
my $count=0;
for ( my $i = 0 ; $i < @lines ; $i++ ) {
$count += length($lines[$i]);
$self->_debug( caller, __LINE__, '_read_multiline', "[$i] ($count) $lines[$i]" );
}
}
return @lines;
}
sub _process_cmd {
my ( $self, %args ) = @_;
my ( $sock, $id ) = $self->_send_cmd( @{ $args{cmd} } );
$args{process} = sub {} unless ref($args{process}) eq "CODE";
$args{final} = sub {} unless ref($args{final}) eq "CODE";
my $cb = $self->{readline_callback};
my $res;
while ( $res = $sock->getline ) {
$cb->($res) if $cb;
$self->_debug( caller, __LINE__, '_process_cmd', $res ) if $self->{debug};
if ( $res =~ /^\*.*\{(\d+)\}[\r\n]*$/ ) {
my $count = $1;
my $list;
$list = 1 if($res =~ /\(/);
$args{process}->($res);
foreach( $self->_read_multiline( $sock, $list, $count ) ) {
$cb->($_) if $cb;
$args{process}->($_)
}
} else {
my $ok = $self->_cmd_ok($res);
if ( defined($ok) && $ok == 1 ) {
return $args{final}->($res);
} elsif ( defined($ok) && !$ok ) {
return;
} else {
$args{process}->($res);
}
}
}
return;
}
sub _seterrstr {
my ( $self, $err ) = @_;
$self->{_errstr} = $err;
$self->_debug( caller, __LINE__, '_seterrstr', $err ) if $self->{debug};
return;
}
sub debug {
my $this = shift;
if( @_ ) {
$this->{debug} = shift;
}
return $this->{debug};
}
sub _debug {
my ( $self, $package, $filename, $line, $dline, $routine, $str ) = @_;
$str =~ s/\n/\\n/g;
$str =~ s/\r/\\r/g;
$str =~ s/\cM/^M/g;
my $shortness = 30;
my $elipsissn = $shortness-3;
my $flen = length $filename;
my $short_fname = ($flen > $shortness ? "..." . substr($filename, $flen - $elipsissn) : $filename);
$line = "[$short_fname line $line in sub $routine] $str\n";
if( exists $self->{debug} and defined $self->{debug} ) {
if ( ref( $self->{debug} ) eq 'GLOB' ) {
print { $self->{debug} } $line;
} elsif( $self->{debug} eq "warn" ) {
warn $line;
} elsif( $self->{debug} =~ m/^file:(.+)/ ) {
open my $out, ">>", $1 or warn "[log io fail: $@] $line";
print $out $line;
CORE::close($out);
} else {
print STDOUT $line;
}
}
return;
}
1;