Server IP : 85.214.239.14 / Your IP : 3.144.91.130 Web Server : Apache/2.4.62 (Debian) System : Linux h2886529.stratoserver.net 4.9.0 #1 SMP Tue Jan 9 19:45:01 MSK 2024 x86_64 User : www-data ( 33) PHP Version : 7.4.18 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals,pcntl_unshare, MySQL : OFF | cURL : OFF | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : OFF Directory : /proc/3/root/usr/share/perl5/Net/IMAP/ |
Upload File : |
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.2211"; 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'; return $self->fetch( $number, $arg ); } sub fetch { my ( $self, $number, $part ) = @_; my $arg = $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"; } } }, ); } # This supports supplying a date per IMAP RFC 3501 # APPEND Command - Section 6.3.11 # Implemented here as a new method so when calling the put above # older code will not break sub put_with_date { my ( $self, $mailbox_name, $msg, $date, @flags ) = @_; croak "usage: \$imap->put_with_date(mailbox, message, date, \@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); my $cmd_str = _escape($mailbox_name) . " (@flags)"; $cmd_str .= " " . _escape($date) if $date ne ""; $cmd_str .= " {$size}"; return $self->_process_cmd( cmd => [ APPEND => $cmd_str ], 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;