Net-IMAP-Simple-1.2204/0000750000175000017500000000000012253054776014223 5ustar jetterojetteroNet-IMAP-Simple-1.2204/Simple.pm0000644000175000017500000010630312253054653016014 0ustar jetterojetteropackage 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.2204"; 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} = $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 parenthsis match..." ); 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; Net-IMAP-Simple-1.2204/Changes0000644000175000017500000005155212253054531015520 0ustar jetterojettero1.2204: Sat Dec 14 2013 - disable error checking on expunge. It's not clear to me that this ever produces an error (which would be with the delete or select commands, not expunge). 1.2203: Mon Oct 07 2013 - https://rt.cpan.org/Public/Bug/Display.html?id=89296 I think I fixed a design problem (no argument sanitization) thinking it fixed the bug, but there may have never been a bug. - nope, was a format problem. Holborn supplied his own patches. 1.2202: Wed Oct 02 2013 - really minor pod fix https://rt.cpan.org/Public/Bug/Display.html?id=89195 1.2201: Mon Aug 05 2013 - stupid bug in the new ssl defaults code, fixed by ChinaXing(陈云星) — how do I miss this stuff? 1.2200: Wed Apr 07 2013 - SSL evolved on me. They actually expect me to check certs? Madness. I came up with some reasonable defaults and some settings and things. The final solution to the defaults puzzle was an amalgam of various ideas from Tom Heady (https://github.com/tomheady). - I deleted the Net::IMAP::Server from inc/ and there is no longer a Net::IMAP::Server environment to test in. It was driving me crazy how buggy that was in some places, and I had no ability to reproduce those environments, so I removed it. If you want to test against a real dovecot or uwash server, super! check the t/test_runner.pm file for the settings. They are intentionally unobvious -- please don't run automated tests unless you're willing to help debug. The automated results don't help anybody without further information on the failures. Normally, cpan testers is the best thing in the world ... IMAP sucks. 1.2034_2: Fri Nov 16 2012 - finally, some testers rand _1 ... didn't tell me anything; but they ran it. I'm just going to remove the offending module load. I'm never going to figure out why it fails on so many machines (but never ever mine). 1.2034_1: Thu Oct 25 2012 - I still have no idea why t/07 fails on basically everyone's machine except mine, but I did find that croaks and dies are totally lost because of the way I run the tests. 1.2034: Wed Oct 10 2012 - https://rt.cpan.org/Ticket/Display.html?id=80088 1.2033: Mon Jul 23 2012 - https://rt.cpan.org/Public/Bug/Display.html?id=78539 1.2032: Thu Apr 05 2012 - my school switched to SSLv3 only and they just kinda time out on autonegotiation... So I added a way to specify the ssl version. 1.2031: Fri Mar 02 2012 - these tests don't work under this new EV multithreaded system. Disabled all tests unless people promise to test single threaded. I'd rather have nobody test it than have all the tests fail every time. I'll fix the tests later. 1.2030: Mon Feb 06 2012 - fixed bug in get that was fetching more message than there actually was to get (spuriously appending FLAGS \Seen and the like) - made sure the tests run in order (re: EV testers). What I did is really truly awful. If there is a good way to force the tests to run in order, please tell it to me. My solution is just horrible (see top of t/test_server.pm) 1.2029: Mon Jan 30 2012 - spelling fix from the debian people 1.2028: Wed Jan 25 2012 - separator method from glaess@glaessixs 1.2027: Wed Dec 28 2011 - ... 1.20271: Wed Dec 28 2011 - heh, spurious number of tests 1.2027: Fri Dec 23 2011 - deal with this: https://rt.cpan.org/Ticket/Display.html?id=73431 1.2026: Mon Oct 10 2011 - Bug in UID search, contribs by Jorge 1.2025: Fri Sep 02 2011 - removed unused build rules that fail to compile in dmake 1.2024: Tue Aug 02 2011 - Jason Woodard submitted a patch to remove the post-sort from range2list. I don't recall why the sort was there to begin with, so the patch seems reasonable to me. All tests passed, released. 1.2023: Wed May 25 2011 - patch for minor (but annoying) options bug. Thanks Mr. Griffiths! 1.2022: Fri Mar 04 2011 - horrid little typo in socket builder 1.2021: Fri Mar 04 2011 - removed the die() after do("") loading the test server http://goo.gl/FUQPn 1.2020: Mon Feb 07 2011 - Andrzej Adam Filip requested a CLOSE method for ::PipeSocket 1.2019: Wed Dec 01 2010 - _process_flags() was a little too aggressive about what's a valid flag and what isn't. Really, it needs to be up to the server. https://rt.cpan.org/Ticket/Display.html?id=63282 - many doc bugs fixed thanks to HM 2k 1.2018: Thu Oct 28 2010 - minor bug with the sloppy CRLF code Thanks go to: http://github.com/marado 1.2016: Sun Sep 05 2010 - fixed ipv4 address stuff 1.2016: Wed Sep 01 2010 - added readline callbacks; which I think I may leave undocumented for now. 1.2016: Mon Aug 30 2010 - found something to fix in https://rt.cpan.org/Ticket/Display.html?id=60537 1.2015: Sun Aug 29 2010 - got the pipesocket working - made sure it ps works in the context of nisim 1.2014: Sun Aug 15 2010 - added uidsearch() -- just like search() 1.2013: Mon Aug 09 2010 - created the PipeSocket object - skeled the connect support 1.2013: Sat Aug 07 2010 - added seq() - added list2range - added contrib/uidfetch - fixed a BODY bug in the fetch grammar 1.2012: Sun Aug 01 2010 - added uidcopy() 1.2011_00: Sat Jul 31 2010 - .{32766} appears to be a limit for that type of matching. I also found a SIGSEGV in (??{ _noexist }) that may or may not be known. Result? A billion times better interface for the {#}\r\nstrings . 1.2010_99: Sun Jul 25 2010 - added a logout method that's just like quit, but doesn't expunge and doesn't have a hardquit option. 1.2010_99: Sat Jul 24 2010 - I really like the way body_summary works and I love writing grammars, so I wrote a generalized fetch() routine. It could probably be used by body_summary() in the future. 1.2010: Mon Jul 19 2010 - If the client is not yet setting on a mailbox and a search is issued, the client now selects the default mbox first. - RFC3501 wants RFC 2822 dates for date-based searches, %d-%m-%Y is therefore wrong, it should be %d-%b-%Y (huh). - provide uidnext, uidvalidity, and uid - also (incidental to the above) make status() take field arguments - fixed a "bug" where not passing coderefs to _process_cmd will probably cause various crashes. 1.2010: Sun Jul 18 2010 - I was having some issues getting the debugs to work inside Coro threads. Rather than debugging it properly I just added more debug options - changed the behavior of ->top($id) so that )\r\n isn't left on the end of the last line of headers as they come back. *** let me know if this broke something for you *** 1.2001: Wed Jul 14 2010 - Ugh. I have seen it before and I already found this problem. It's still that DateTime bug: https://rt.cpan.org/Public/Bug/Display.html?id=58459 1.2000_1: Wed Jul 14 2010 - ugh, I'm *STILL* getting that bug (is it?) where sometimes machines can't copy messages (line 25) after there's definitely (line 22) 10 messages in the mailbox. WHY WHY WHY WHY? Naturally, the logdump is truncated at the point where I really need it. http://www.cpantesters.org/cpan/report/590a9a6e-8e97-11df-b0b7-6c9e78e28bc1 Changed the t/22 test to dump the last 200 lines instead of the first few hundred. 1.2000: Tue Jul 06 2010 - Jason and I (due to a disagreement about what should be returned by body_summary()) begun using objects instead. This way the return value can be interrogated easily to see what it is and what it has. 1.2000: Sat Jul 03 2010 - woodward sent in some rfc3501 fetch-body support and docs. The extension requires Parse::RecDescent for correct parsing, so body_summary() was forked off to an extensions module. 1.1916: Mon Jun 07 2010 - woodward sent in an RFC-5256 patch to make SEARCH more correct 1.1915: Sat Jun 05 2010 - import the latest Net-IMAP-Server to the inc/ dir (1.27) - report various bugs - fix various bugs in inc/ dir 1.1913: Wed May 26 2010 1.1914: Wed May 26 2010 - pulled in changes from alexmv 1.1912: Fri Apr 23 2010 - Doug confirmed that it worked. I'm going to go ahead and release this as a new version. 1.1912_1: Thu Apr 22 2010 - Hrm, per Doug Reed at Service Optimi, I noticed that _last returns self->{last} regardless of whether it's ever been set. Seems like we can DWIM and call self->select if it's never been called yet and make ->list (et al) function. We'll see what he thinks of this fix. 1.1911: Sun Mar 14 2010 - Fixed [introduced] bugs illuminated in #55552 (RT), thanks to Aaron Wilson for a positively excellent bug report! 1.1910_2: Wed Feb 17 2010 - http://www.nntp.perl.org/group/perl.cpan.testers/2010/02/msg6764802.html - I still can't figure out what's causing this... NO IDEA - I made the test ridiculously verbose if two conditions are met: 1) automated testing; 2) the copy tests fail in some way. 1.1910_1: Sun Jan 17 2010 - http://www.nntp.perl.org/group/perl.cpan.testers/2010/01/msg6625605.html It seems the t/22_* tests are failing, but I can't seem to build a perl for which the tests fail. :( No idea. I added another prereq to the makefile and added another line (perhaps informative?) to the t/22_copy* test. 1.1910: Tue Oct 27 2009 - documented search() and added a bunch of kid functions that issue searches on your behalf. Added tests for search(). 1.1908: Thu Sep 24 2009 - top() does a surprisingly terrible job at groking header lines. If you have something like this: message-id: date: wednesday, blarg blarg xx:xx:xx (pdt) The results are somewhat random concerning, lines vs header-rows. My goal is to make sure each element of the arrayref returned is a header line, not just a line of text. 1.1908: Sun Sep 20 2009 - added a really weak search command. I think we can do a little better... 1.1907: Sun Jul 26 2009 - PREAUTH fix and tests - a nifty little contrib/ dovecot pipe server thingy - fixed serious issues with the greeting timeout 1.1905: Mon Jul 20 2009 - I apparently need Class::Accessor installed for tests. Pulling over all deps of the now included net-imap-server 1.1904: Fri Jul 17 2009 - bestpractical's patch makes more sense than mine does 1.1903: Fri Jul 17 2009 - actually use the inc/ copy of net-imap-server 1.1902: Fri Jul 17 2009 - I decided to include a static copy of net-imap-server so I know precisely what version is there for tests. Suggested net-imap-server build tests using net-imap-simple this way. 1.1902: Thu Jul 16 2009 - There's apparently 5.10 problems with the tests (probably not with the module). The tests are kinda hinky anyway. 1.1900: Fri Jul 10 2009 - I really thought I released this already. Lawl. 1.1900: Fri Jun 26 16:03:16 EDT 2009 - prolly going to release this, it seems to test fine all over the place. 1.1899_07: Sun Jun 21 07:16:36 EDT 2009 - I decided to do get() my way, without ruining everything, by blessing the arrayref and overloading '""'. - I tought the t/35 test to prove that _process_command fails just as Jonathan Kamens says. - applied JIK's patch. 1.1899_07: Sat Jun 20 22:12:00 EDT 2009 - I want to change the way get() works. I don't think I should, but I'd like to return the actual message in scalar context and the lines in list context. Returning the lines as an arrayref makes no sense to me. 1.1899_07: Sat Jun 20 15:26:13 EDT 2009 - while trying to get some delete and copy tests I ended up working on expunge_mailbox() a little - found another bug in Net::IMAP::Server::Mailbox... It's clearly just a demo, but since I'm using it for my tests, it's worth fixing. - my delete tests do show that ranges like 3:5 really do work, which makes me think RT#40203 may turn out to be spurious. I'll let the tests prove it out before I close it though. - I refactored the _reselect() stuff away, it was poorly thought out. There's a _clear_cache() instead. Yeah, 40203 appears to be bogus because the client doesn't really parse the sequence-set numbers. I have confirmed for sure that you can $imap->delete("3:5,7,10") and it'll work just like you called delete 5 times. - Copies seem to work fine too. I'm going to close the ticket. - Documented the sequence set stuff so RT#40203 doesn't come up again. 1.1899_06: Fri Jun 19 08:54:07 EDT 2009 - added a status() sub for the STATUS command - added a status() test, with some unseen() flag tests - added a select() and current_mailbox() test -- failed to unescape the working mailbox for current_mailbox() - reported a status command bug (in Mailbox) to Net::IMAP::Server - moved a bunch of contrib and t7lib modules around to keep pause from indexing them. - worked on the docs for seen and unseen - created a method for error-checking when using msg_flags(), seen() and unseen() -- which I think solves ticket 33189. Basically, if Cyrus-imap is returning different values for FETCH (FLAGS) than for STATUS, what can I really do to fix it? However, the log provided by Mr Spiegl seems to suggest he was counting errors as unseen messages... so this may just fix it. 1.1899_05: Wed Jun 17 06:25:39 EDT 2009 - documented see, unsee, add_flags, and sub_flags - used the IMAP RFC to show that gmail is wrong, Net::IMAP::Server is right. google apps for domains apparently selects an unseen message willy nilly (or which ever is last) for the OK [UNSEEN #] message. It should be the *first* unseen message. Their IMAP is notoriously un-IMAP though. I shouldn't be so surprised. - added undelete to go with the other flaggy functions - added more flag tests 1.1899_05: Tue Jun 16 06:42:16 EDT 2009 - I started working on ticket 45953, - created sub_flags() and add_flags() - taught delete() to use add_flags() -- adds \Deleted - providing see() and unsee() for ticket 45953 - I started building tests for the flag manipulation stuff and put reselect stuff ... noticed a possible bug in Net::IMAP::Server 1.1899_05: Sun Jun 14 07:14:54 EDT 2009 - fixed t/test_server.pm (use IO::Socket::INET, not Net::TCP) 1.1899_04: Sat Jun 13 18:33:46 EDT 2009 - added deleted() from JIK 's patch. 1.1899_03: Sat Jun 13 17:05:55 EDT 2009 - added a connection class so we might reject connections after the 4th, or whatever, and possibly solve ticket 30229 - banged my head on the IO::Socket::SSL wall for a while - buu (#perl freenode) set me straight on something enabling me to close 30229. 1.1899_02: Sat Jun 13 07:39:29 EDT 2009 - moved some tests around and fixed the manifests - added support, docs and test for EXAMINE 1.1899_01: Fri Jun 12 22:06:36 EDT 2009 - man Coro is disaggreable in the shutdown epoch, it took a fork, a setsid and another fork to disssociate the test from the Coro ... um... messing with exit(). - decided as I clear tickets from RT, I'll write tests. As I write tests, I'll release dev releases, the *goal* will be 1.1900 -- all RT cleared. 1.1900: Thu Jun 11 07:17:13 EDT 2009 - fixed a bug I created in select - moved the tests around a little, getting ready for a whole suite 1.1900: Wed Jun 10 22:01:53 EDT 2009 - It took me forever to figure out why the append command wouldn't work. Bug submitted to Net::IMAP::Server - added my login function to contrib - I think I fixed the oldest bug on RT 1.1810: Sun Jun 7 10:52:30 EDT 2009 - made $imap->select return "0E0" when 0 messages are found after an otherwise successful select. 1.1810: Sat Jun 6 22:13:34 EDT 2009 - Started working on the tests. Net::IMAP::Simple doesn't seem to be able to handle the results of a select command as returned by Net::IMAP::Server. This may indicate other problems with protocol compliance. I can't say definitley for sure that it's ::Simple, but that's the most likely suspect. - Made the module pull in IO::Socket::SSL without needing to involve another module that probably shouldn't be a whole separate distribution anyway. Considering deprecating the Net::IMAP::Simple::SSL for that reason, and because that whole distribution is only 2 useful lines anyway. 1.1800: Thu Jun 4 21:44:59 EDT 2009 - jettero started pulling in his changes. 1.17 2006-10-11 - Beta/Developer release -> production 1.16_1 2006-10-02 - Beta Release - Added debugging - Upgraded imap.pl example script - Updated documentation - Added a few patches here and there 1.16 2006-06-13 - Multiple bugs identified by nate@cs.wisc.edu. Patch provided by Nate. Nate also provided new release tests - thanks man. 1.15 2005-11-21 - Added mailboxes_subscribed() function introduced by John Cappiello. This function provides a method for retreiving a list of mailboxes which the user has subscribed to. This differs from the mailboxes() function in that with the mailboxes() function all mailboxes are returned, regardless ass to whether or not the user has subscribed to them. 1.14 2005-10-01 - Fixed error in sample code within the POD documentation identified by Matthew S. Hallacy 1.13 2005-09-28 - Versioning schema changed to use CVS versioning rather than hard coded versioning. This is to address issues some people are having with bug tracking and package management tools. 0.105 2005-09-28 - Fixed syntax problem in the bindaddr option. Thanks Dagobert Michelsen for pointing this out. 0.104 2005-08-06 - Fixed major bug discovered in get() and getfh() which caused message lines to be dropped if they started with an "*" 0.103 2005-07-10 - Fixed error in select() identified by Guido Kerkewitz and Jonathan B. Glatt - Added folder_subscribe() and folder_unsubscribe() functions provided by Guido Kerkewitz. 0.102 2005-06-25 - Fixed protocol error identified within the expunge_mailbox() function. (Thanks alot to William Faulk for pointing this out) - Fixed bugs in the sample imap.pl script provided. - Added flags() and recent() routines - Added current_box() function - Added use_select_cache and select_cache_ttl options. These options will allow you to enable internal caching for select() operations. 0.101 2005-01-06 - Fixed bug which resulted in inconsistant results from login() 0.100 2005-14-05 - Fixed dates in Changes file - Fixed IMAP protocol error identified by John A. Murphy - Changed behavior of login() to only return true or false. This change means that to get the current number of messages in a users INBOX folder you will need to preform a simple $imap->select("INBOX") after successfully logging in. - Added messages() function - Added the frame work within select() to provide more detailed information about the current IMAP framework 0.99 2005-28-04 - Added multi-line header patch for bug discovered in top(), thanks Sergey Mudrik for pointing this out. 0.98 2005-27-04 - Minor document changes - Fixed implimentation bug with the new option set 0.97 2005-26-04 - Added patch submitted by LTHEGLER to address the multiple line output problem. 0.96 2005-26-04 - Took over module development (Colin Faber) - Fixed synopsis to provide a functional example (Colin Faber) - Added error handling (Colin Faber) - Added IPv6 support (Colin Faber) - Added port, timeout, use_v6, retry, retry_delay and bindaddr options to the object creation method. 0.95 2004-06-09 - Accept port configuration (Matt Bradford). - Documentation overhaul (Casey West). - Huge internal code overhaul (Casey West). - Implemented expunge_mailbox() (Florin Andrei). 0.94 Thu May 20 15:24:21 EDT 2004 - Taken by Casey West. - Quoted the password argument to login() when sending to IMAP LOGIN command. - Added arguments for searching in paths and for mailboxes in the mailboxes() command. - Distribution clean up. 0.93 Thu Dec 16 16:15:00 1999 - LIST ... {\d}\r\nmailbox parsing in mailboxes() - better escaping of \" e \\ (Netscape server doesn't put the \\ in the mailbox name. Why?) 0.92 Tue Dec 13 15:07:00 1999 - seen method - \r\n as EOL. Thanks to Edward Chao! - \" escaping. Thanks to Edward Chao! 0.91 Tue Nov 9 11:41:00 1999 - getfh method - fixed bugs in the documentation(!!!) 0.90 Wed Nov 3 15:29:13 1999 - original version; created by h2xs 1.18 Net-IMAP-Simple-1.2204/META.yml0000640000175000017500000000115712253054776015501 0ustar jetterojettero--- abstract: unknown author: - 'Paul Miller ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.84, CPAN::Meta::Converter version 2.132661' keywords: - imap - simple license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Net-IMAP-Simple no_index: directory: - t - inc requires: IO::Select: 0 IO::Socket: 0 Parse::RecDescent: 0 perl: 5.008 resources: repository: http://github.com/jettero/net--imap--simple version: 1.2204 Net-IMAP-Simple-1.2204/README0000644000175000017500000000111512224536034015074 0ustar jetterojetteroNAME Net::IMAP::Simple - Perl extension for simple IMAP account handling. SYNOPSIS use strict; use warings; use Net::IMAP::Simple; my $server = Net::IMAP::Simple->new( 'someserver' ); $server->login( 'someuser', 'somepassword' ); for ( 1 .. $server->select( 'somefolder' ) ) { print $email->header('Subject'), "\n"; } $server->quit(); COPYRIGHT All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. BUGS https://rt.cpan.org/Dist/Display.html?Queue=Net-IMAP-Simple Net-IMAP-Simple-1.2204/MANIFEST0000644000175000017500000000176012253054777015366 0ustar jetterojettero.perlcriticrc Changes contrib/33189_attach.pl contrib/connectalot.pl contrib/hand_test01.pl contrib/imap.pl contrib/preauth-pipe-server.pl contrib/search-test.pl contrib/SimpleX.pm contrib/SimpleX.pod contrib/status.pl inc/rebuild_iff_necessary.pm inc/slurp_fetchmail.pm lib/Net/IMAP/Simple/PipeSocket.pm Makefile.PL MANIFEST README Simple.pm Simple.pod t/01_load.t t/07_select_and_examine.t t/08_selectalot.t t/10_list.t t/11_mailboxes.t t/15_flags.t t/16_exotic_flags.t t/17_status_and_select.t t/19_readline_callback.t t/22_copy_multiple.t t/22_uidcopy_multiple.t t/23_delete_multiple.t t/35_imap_results_in_message_body.t t/42_preauth_with_command.t t/45_search.t t/50_body_summary.t t/55_uid_stuff.t t/60_fetch_with_grammar.t t/70_list2range.t t/75_back_and_forth.t t/80_top.t t/critic.t t/pod.t t/pod_coverage.t t/test_runner.pm TODO META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Net-IMAP-Simple-1.2204/Simple.pod0000644000175000017500000007513512224536034016166 0ustar jetterojettero=encoding utf-8 =head1 NAME Net::IMAP::Simple - Perl extension for simple IMAP account handling. =head1 SYNOPSIS use strict; use warnings; use Net::IMAP::Simple; use Email::Simple; # Create the object my $imap = Net::IMAP::Simple->new('imap.example.com') || die "Unable to connect to IMAP: $Net::IMAP::Simple::errstr\n"; # Log on if(!$imap->login('user','pass')){ print STDERR "Login failed: " . $imap->errstr . "\n"; exit(64); } # Print the subject's of all the messages in the INBOX my $nm = $imap->select('INBOX'); for(my $i = 1; $i <= $nm; $i++){ if($imap->seen($i)){ print "*"; } else { print " "; } my $es = Email::Simple->new(join '', @{ $imap->top($i) } ); printf("[%03d] %s\n", $i, $es->header('Subject')); } $imap->quit; =head1 DESCRIPTION This module is a simple way to access IMAP accounts. =head1 OBJECT CREATION METHOD my $imap = Net::IMAP::Simple->new( $server [ :port ]); # OR my $imap = Net::IMAP::Simple->new( $server [, option_name => option_value ] ); =head2 new This class method constructs a new L object. It takes one required parameter which is the server to connect to, and additional optional parameters. The server parameter may specify just the server, or both the server and port number. To specify an alternate port, separate it from the server with a colon (C<:>), C. On success an object is returned. On failure, nothing is returned and an error message is set to C<$Net::IMAP::Simple>. See L below for a special hostname invocation that doesn't use Sockets (internally). Options are provided as a hash to C: =over 4 =item port => int Assign the port number (default: 143) =item timeout => int (default: 90) Connection timeout in seconds. =item retry => int (default: 1) Attempt to retry the connection attmpt (x) times before giving up =item retry_delay => int (default: 5) Wait (x) seconds before retrying a connection attempt =item use_v6 => BOOL If set to true, attempt to use IPv6 sockets rather than IPv4 sockets. This option requires the L module =item use_ssl => BOOL If set to true, attempt to use L sockets rather than vanilla sockets. Note that no attempt is made to check the certificate validity by default. This is terrible personal security but matches the previous behavior of this module. Please consider using C below. This option requires the L module =item ssl_version => version This should be one or more of the following (space separated): SSLv3 SSLv2 TLSv1. If you specify, for example, "SSLv3 SSLv2" then L will attempt auto negotiation. At the time of this writing, the default string was v3/v2 auto negotiation -- it may have changed by the time you read this. Warning: setting this will also set C. =item find_ssl_defaults => [] Looks in some standard places for CA certificate libraries and if found sets reasonable defaults along the lines of the following. ssl_options => [ SSL_ca_path => "/etc/ssl/certs/", SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER() ] Warning: setting this will also set C. =item ssl_options => [] You may provide your own L options if you desire to do so. It is completely overridden by C above. =item bindaddr => str Assign a local address to bind =item use_select_cache => BOOL Enable C caching internally =item select_cache_ttl => int The number of seconds to allow a select cache result live before running C<$imap->select()> again. =item debug => BOOL | \*HANDLE | warn | file:name Enable debugging output. If C<\*HANDLE> is a valid file handle, debugging will be written to it. If it is the string C<"warn"> then the debugging will be written using the L command. If it is a string of the form C then the named file will be opened for append and the debugs written to it. Otherwise debugging will be written to C =item readline_callback => CODE You may choose to pass a callback function for the purpose of pre-processing lines before they are handed to the rest of the L internals. This can be handy for animating a spinner or modifying the IMAP behavior. =back =head1 PREAUTH Rather than passing a port number and issuing a login, in some situations it may be convenient to authenticate with (for example) ssh and simply invoke (for example) dovecot by hand. If the server name starts with C, then L will issue the command rather than building sockets. This is a typical setup: my $cmd = "ssh -C mailhost dovecot --exec-mail imap"; my $imap = Net::IMAP::Simple->new("cmd:$cmd"); # $imap->login(); ... don't need this my $number_of_messages = $imap->select("INBOX"); =head1 METHODS =over 4 =item starttls $imap->starttls; If you start an IMAP session and wish to upgrade to SSL later, you can use this function to start TLS. This function will try to C L and L at runtime. =item login my $inbox_msgs = $imap->login($user, $passwd); This method takes two required parameters, a username and password. This pair is authenticated against the server. If authentication is successful TRUE (1) will be returned Nothing is returned on failure and the C error handler is set with the error message. =item status my $num_messages = $imap->status($folder); my ($unseen, $recent, $num_messages) = $imap->status($folder); Issue a C command. The C command counts messages without altering the state of the named (optionally) mailbox. It returns either the number of messages, or the number of unseen messages, recent, and the total number of messages. C<$folder> is an optional argument. C will use the current mailbox or C if the C<$folder> argument is not provided. This method does not use caching. This method can also query custom status values. The first argument to the function (if any) is assumed to be the folder name, so the folder argument is required when trying to query custom status values. my ($f1, $f2) = $imap->status($folder, qw(f1 f2)); my $f2 = $imap->status($folder, qw(f1 f2)); =item uidnext my $uidnext = $imap->uidnext($folder); Return the C value for a mailbox. The C<$folder> argument is optional. This is really just an alias for my $uidnext = $imap->status($folder, qw(uidnext)); with the mild difference that it can compute the folder argument for you =item uidvalidity my $uidvalidity = $imap->uidnext($folder); Return the C value for a mailbox. The C<$folder> argument is optional. This is also an alias for the status call like C above. =item uid my $uid = $imap->uid($msgno); my @uid = $imap->uid($msg_range); # eg 4:14 or 15,4,14 Return the C value(s) for a message. These unique IDs "I" stay the same during the session and "I" stay the same between sessions. Whether they stay the same depends on the C value; see: above and RFC3501. Warning, although you might thing C<@uid> should contain the Cs for 15, then 4, then 14 in the example above; most IMAP servers seem to return the UIDs in increasing order. Normally the sequence numbers are in increasing order also, so it all maches up. my ($uid4, $uid14, $uid15) = $imap->uid("15,4,14"); # warning This function is actually an alias for C<< $imap->uidsearch($msg_range) >>. =item seq my $seq = $imap->seq($uids); my @seq = $imap->seq($uids); # eg 58888:58900 Rather like C above, but maps uids to sequence numbers. =item select my $num_messages = $imap->select($folder); Selects a folder named in the single required parameter. The number of messages in that folder is returned on success. On failure, nothing is returned and the C error handler is set with the error message. =item examine This is very nearly a synonym for C. The only real difference is that the EXAMINE command is sent to the server instead of SELECT. L is otherwise unaware of the read-only-ness of the mailbox. =item close $imap->close; Un-selects the current mailbox, leaving no mailbox selected. =item messages print "Messages in Junk Mail -- " . $imap->messages("INBOX.Junk Mail") . "\n"; This method is an alias for C<$imap->select> =item flags print "Available server flags: " . join(", ", $imap->flags) . "\n"; This method accepts an optional folder name and returns the current available server flags as a list, for the selected folder. If no folder name is provided the last folder C<< $imap->select >>'ed will be used. This method uses caching. =item separator Returns the folder separator (technically "hierarchy separator", rfc3501§6.3.8) for the server. =item recent print "Recent messages value: " . $imap->recent . "\n"; This method accepts an optional folder name and returns the 'RECENT' value provided durning a SELECT result set. If no folder name is provided the last folder C<< $imap->select >>'ed will be used. This method uses caching. See also: L =item unseen print "Unseen messages value: " . $imap->unseen . "\n"; This method accepts an optional folder name and returns the 'UNSEEN' value provided during a SELECT command result. If no folder name is provided the last folder C<< $imap->select >>'ed will be used. If a folder name I provided, this will issue a SELECT first. This method uses caching. If the server does not provide UNSEEN during SELECT -- surprisingly common -- this method will fall back and use STATUS to determine the unseen count. B: This is not the opposite of L below. The UNSEEN value varies from server to server, but according to the IMAP specification, it should be the I, in the case the flag is provided. (If the flag is not provided, users would have to use the SEARCH command to find it.) See also: L =item current_box print "Current Mail Box folder: " . $imap->current_box . "\n"; This method returns the current working mail box folder name. =item top my $header = $imap->top( $message_number ); print for @{$header}; This method accepts a message number as its required parameter. That message will be retrieved from the currently selected folder. On success this method returns a list reference containing the lines of the header. Nothing is returned on failure and the C error handler is set with the error message. =item seen defined( my $seen = $imap->seen( $message_number ) ) or warn "problem testing for \Seen: " . $imap->errstr; print "msg #$message_number has been \Seen!" if $seen; A message number is the only required parameter for this method. The message's C<\Seen> flag will be examined and if the message has been seen a true value is returned. A defined false value is returned if the message does not have the C<\Seen> flag set. The undefined value is returned when an error has occurred while checking the flag status. B: This is not the opposite of L above. This issues a C command and checks to see if the given message has been C<\Seen> before. =item deleted defined( my $deleted = $imap->deleted( $message_number ) ) or warn "problem testing for \Deleted: " . $imap->errstr; print "msg #$message_number has been \Deleted!" if $deleted; A message number is the only required parameter for this method. The message's C<\Deleted> flag will be examined and if the message has been deleted a true value is returned. A defined false value is returned if the message does not have the C<\Deleted> flag set. The undefined value is returned when an error has occurred while checking the flag status. =item list my $message_size = $imap->list($message_number); my $mailbox_sizes = $imap->list; This method returns size information for a message, as indicated in the single optional parameter, or all messages in a mailbox. When querying a single message a scalar value is returned. When listing the entire mailbox a hash is returned. On failure, nothing is returned and the C error handler is set with the error message. =item get my $message = $imap->get( $message_number ) or die $imap->errstr; my @message_lines = $map->get( $message_number ) or die $imap->errstr; my $part = $imap->get( $message_number, '1.1' ) or die $imap->errstr; my @part_lines = $imap->get( $message_number, '1.1' ) or die $imap->errstr; This method fetches a message and returns its lines as an array or, the actual message. On failure, either an empty list is returned and the C error handler is set with the error message. Optionally, a part can be specified in order to fetch a specific portion of a message. This is the raw, encoded body of the message part. The part number is a set of zero or more part specifiers delimited by periods. Every message has at least one part. Specifying a part of '1' returns the raw, encoded body. This is only useful if you know the header information such as encoding. Historically, C returned the array of lines as a reference to the array instead of returning the message or the array itself. Please note that it still does this, although it may be deprecated in the future. The scalar result returned is actually a blessed arrayref with the stringify member overloaded. If you're intending to use the resulting message as a string more than once, it I make sense to force the stringification first. my $message = $imap->get(1); $message = "$message"; # force stringification It is not normally necessary to do this. =item put $imap->put( $mailbox_name, $message, @flags ) or warn $imap->errstr; Save a message to the server under the folder named C<$mailbox_name>. You may optionally specify flags for the mail (e.g. C<\Seen>, C<\Answered>), but they must start with a slash. If C<$message> is an arrayref, the lines will be printed correctly. =item msg_flags my @flags = $imap->msg_flags( $message_number ); my $flags = $imap->msg_flags( $message_number ); # aught to come out roughly the same print "Flags on message #$message_number: @flags\n"; print "Flags on message #$message_number: $flags\n"; Detecting errors with this member functions is usually desirable. In the scalar context, detecting an error is synonymous with testing for defined. if( defined( my $flags = $imap->msg_flags($num) ) ) { # it has $flags! } else { warn "problem listing flags for message #$num: " . $imap->errstr; } In list context, you must call L() to test for success. my @flags = $imap->msg_flags($num); warn "problem listing flags for msg #$num: " . $imap->errstr if $imap->waserr; =item getfh my $file = $imap->getfh( $message_number ); print <$file>; On success this method returns a file handle pointing to the message identified by the required parameter. On failure, nothing is returned and the C error handler is set with the error message. =item quit $imap->quit; OR $imap->quit(BOOL); This method logs out of the IMAP server, expunges the selected mailbox, and closes the connection. No error message will ever be returned from this method. Optionally if BOOL is TRUE (1) then a hard quit is performed which closes the socket connection. This hard quit will still issue both EXPUNGE and LOGOUT commands however the response is ignored and the socket is closed after issuing the commands. =item logout $imap->logout; This method is just like the quit method except that it does not have a hard quit option and it does not expunge the mailbox before it hangs up and closes the socket. =item last my $message_number = $imap->last; This method returns the message number of the last message in the selected mailbox, since the last time the mailbox was selected. On failure, nothing is returned and the C error handler is set with the error message. =item delete print "Gone!" if $imap->delete( $message_number ); This method sets the C<\Deleted> flag on the given message (or messages). On success it returns true, false on failure and the C error handler is set with the error message. If the flag was already there, no error is produced. I takes either a message number or L as the only argument. Note that messages aren't actually deleted until they are expunged (see L). =item undelete print "Resurrected!" if $imap->undelete( $message_number ); This method removes the C<\Deleted> flag on the given message. On success it returns true, false on failure and the C error handler is set with the error message. If the flag wasn't there, no error is produced. =item see print "You've seen message #$msgno" if $imap->see( $messageno ); This method sets the C<\Seen> flag on the given message. On success it returns true, false on failure and the C error handler is set with the error message. If the flag was already there, no error is produced. =item unsee print "You've not seen message #$msgno" if $imap->unsee( $messageno ); This method removes the C<\Seen> flag on the given message. On success it returns true, false on failure and the C error handler is set with the error message. If the flag wasn't there, no error is produced. =item add_flags L and L above really just call this function for those flags. $imap->add_flags( $msgno, qw(\Seen \Deleted) ) or die $imap->errstr; =item sub_flags L above really just calls this function for that flag. $imap->sub_flags( $msgno, '\Seen' ) or die $imap->errstr; =item mailboxes my @boxes = $imap->mailboxes; my @folders = $imap->mailboxes("Mail/%"); my @lists = $imap->mailboxes("lists/perl/*", "/Mail/"); This method returns a list of mailboxes. When called with no arguments it recurses from the IMAP root to get all mailboxes. The first optional argument is a mailbox path and the second is the path reference. RFC 3501 section 6.3.8 has more information. On failure nothing is returned and the C error handler is set with the error message. =item mailboxes_subscribed my @boxes = $imap->mailboxes_subscribed; my @folders = $imap->mailboxes_subscribed("Mail/%"); my @lists = $imap->mailboxes_subscribed("lists/perl/*", "/Mail/"); This method returns a list of mailboxes subscribed to. When called with no arguments it recurses from the IMAP root to get all mailboxes. The first optional argument is a mailbox path and the second is the path reference. RFC 3501 has more information. On failure nothing is returned and the C error handler is set with the error message. =item create_mailbox print "Created" if $imap->create_mailbox( "/Mail/lists/perl/advocacy" ); This method creates the mailbox named in the required argument. Returns true on success, false on failure and the C error handler is set with the error message. =item expunge_mailbox my @expunged = $imap->expunge_mailbox( "/Mail/lists/perl/advocacy" ); die $imap->errstr if $imap->waserr; my $expunged = $imap->expunge_mailbox( "/Mail/lists/perl/advocacy" ) or die $imap->errstr; This method removes all mail marked as deleted in the mailbox named in the required argument. Returns either the number of messages that were expunged, or the indexes of those messages -- which has a questionable usefulness since it tends to return numbers that don't relate to the message numbers marked with the C<\Deleted> flags. If 0 messages were expunged without error, the function will return C<0E0> so it will still test true, but also evaluate to 0. In list context, you must call L() to test for success. =item delete_mailbox print "Deleted" if $imap->delete_mailbox( "/Mail/lists/perl/advocacy" ); This method deletes the mailbox named in the required argument. Returns true on success, false on failure and the C error handler is set with the error message. =item rename_mailbox print "Renamed" if $imap->rename_mailbox( $old => $new ); This method renames the mailbox in the first required argument to the mailbox named in the second required argument. Returns true on success, false on failure and the C error handler is set with the error message. =item folder_subscribe print "Subscribed" if $imap->folder_subscribe( "/Mail/lists/perl/advocacy" ); This method subscribes to the folder. Returns true on success, false on failure and the C error handler is set with the error message. =item folder_unsubscribe print "Unsubscribed" if $imap->folder_unsubscribe( "/Mail/lists/perl/advocacy" ); This method un-subscribes to the folder. Returns true on success, false on failure and the C error handler is set with the error message. =item copy print "copied" if $imap->copy( $message_number, $mailbox ); This method copies the message number (or L) in the currently selected mailbox to the folder specified in the second argument. Both arguments are required. On success this method returns true. Returns false on failure and the C error handler is set with the error message. =item uidcopy print "copied" if $imap->uidcopy( $message_uid, $mailbox ); This method is identical to C above, except that it uses UID numbers instead of sequence numbers. =item noop $imap->noop; Performs a null operation. This may be needed to get updates on a mailbox, or ensure that the server does not close the connection as idle. RFC 3501 states that servers' idle timeouts must not be less than 30 minutes. =item errstr print "Login ERROR: " . $imap->errstr . "\n" if !$imap->login($user, $pass); Return the last error string captured for the last operation which failed. =item waserr my @flags = $imap->msg_flags(14); die $imap->errstr if $imap->waserr; Because C can optionally return a list, it's not really possible to detect failure in list context. Therefore, you must call C if you wish to detect errors. Few of the L methods use C. The ones that do will mention it. =item list2range Sometimes you have a long list of sequence numbers which are consecutive and really want to be an IMAP-style range. my @list = (5..9, 13..38, 55,56,57); my $short = $imap->list2range(@list); # $short how says: 5:9,13:38,55:57 =item range2list Pretty much the opposite of C. my @list = $imap->range2list("1,3,5:9"); # @list is (1,3,5,6,7,8,9); =back =head1 SEARCHING =over 4 =item search This function returns an array of message numbers (in list context) or the number of matched messages (in scalar context). It takes a single argument: the search. IMAP searching can be a little confusing and this function makes no attempt to parse your searches. If you wish to do searches by hand, please see RFC 3501. IMAP sorting (see RFC 5256) is supported via an optional second argument. The RFC requires the charset be specified, which can be provided via the optional third argument (defaults to UTF-8). Here are a few examples: my @ids = $imap->search("UNSEEN"); my @ids = $imap->search('SUBJECT "blarg is \"blarg\""'); my @ids = $imap->search('FROM "joe@aol.com"'); my @ids = $imap->search("DELETED"); # example from RFC 3501, search terms are ANDed together my @ids = $imap->search('FLAGGED SINCE 1-Feb-1994 NOT FROM "Smith"'); # example from RFC 3501, search terms are ORed together my @ids = $imap->search('OR BODY "blard" SUBJECT "blarg"'); # flagged and ( since x or !from y ): my @ids = $imap->search('FLAGGED OR SINCE x NOT FROM "y"'); # no typo above, see the RFC # example from RFC 5256, sorted by subject and reverse date my @ids = $imap->search('BODY "zaphod"', 'SUBJECT REVERSE DATE'); Since this module is meant to be simple, L has a few search helpers. If you need fancy booleans and things, you'll have to learn search. If you need a quick search for unseen messages, see below. These all return an array of messages or count of messages exactly as the search function does. Some of them take arguments, some do not. They do try to grok your arguments slightly, the mechanics of this (if any) will be mentioned below. =over 4 =item search_seen Returns numbers of messages that have the \Seen flag. =item search_recent Returns numbers of messages that have the \Recent flag. =item search_answered Returns numbers of messages that have the \Answered flag. =item search_deleted Returns numbers of messages that have the \Deleted flag. =item search_flagged Returns numbers of messages that have the \Flagged flag. =item search_draft Returns numbers of messages that have the \Draft flag. =item search_unseen Returns numbers of messages that do not have the \Seen flag. =item search_old Returns numbers of messages that do not have the \Recent flag. =item search_unanswered Returns numbers of messages that do not have the \Answered flag. =item search_undeleted Returns numbers of messages that do not have the \Deleted flag. =item search_unflagged Returns numbers of messages that do not have the \Flagged flag. =item search_smaller This function takes a single argument we'll call C<< >> and returns numbers of messages that are smaller than C<< >> octets. This function will try to force your argument to be a number before passing it to the IMAP server. =item search_larger This function takes a single argument we'll call C<< >> and returns numbers of messages that are larger than C<< >> octets. This function will try to force your argument to be a number before passing it to the IMAP server. =item search_from This function takes a single argument we'll call C<< >> and returns numbers of messages that have C<< >> in the from header. This function will attempt to force your string into the RFC3501 quoted-string format. =item search_to This function takes a single argument we'll call C<< >> and returns numbers of messages that have C<< >> in the to header. This function will attempt to force your string into the RFC3501 quoted-string format. =item search_cc This function takes a single argument we'll call C<< >> and returns numbers of messages that have C<< >> in the cc header. This function will attempt to force your string into the RFC3501 quoted-string format. =item search_bcc This function takes a single argument we'll call C<< >> and returns numbers of messages that have C<< >> in the bcc header. This function will attempt to force your string into the RFC3501 quoted-string format. =item search_subject This function takes a single argument we'll call C<< >> and returns numbers of messages that have C<< >> in the subject header. This function will attempt to force your string into the RFC3501 quoted-string format. =item search_body This function takes a single argument we'll call C<< >> and returns numbers of messages that have C<< >> in the message body. This function will attempt to force your string into the RFC3501 quoted-string format. =item search_before This function takes a single argument we'll call C<< >> and returns numbers of messages that were received before C<< >>. If you have L installed (optional), this function will attempt to force the date into the format C<%d-%b-%Y> (date-monthName-year) as RFC3501 requires. If you do not have that module, no attempt will be made to coerce your date into the correct format. =item search_since This function takes a single argument we'll call C<< >> and returns numbers of messages that were received after C<< >>. If you have L installed (optional), this function will attempt to force the date into the format C<%d-%m-%Y> (date-month-year) as RFC3501 requires. If you do not have that module, no attempt will be made to coerce your date into the correct format. =item search_sent_before This function takes a single argument we'll call C<< >> and returns numbers of messages that have a header date before C<< >>. If you have L installed (optional), this function will attempt to force the date into the format C<%d-%m-%Y> (date-month-year) as RFC3501 requires. If you do not have that module, no attempt will be made to coerce your date into the correct format. =item search_sent_since This function takes a single argument we'll call C<< >> and returns numbers of messages that have a header date after C<< >>. If you have L installed (optional), this function will attempt to force the date into the format C<%d-%m-%Y> (date-month-year) as RFC3501 requires. If you do not have that module, no attempt will be made to coerce your date into the correct format. =back =item uidsearch This function works exactly like C but it returns UIDs instead of sequence numbers. The convenient shortcuts above are not provided for it. =back =head1 OTHER NOTES =over 4 =item sequence set Message numbers are never checked before being passed to the IMAP server (this is a "simple" module after all), so in most places where a message number is required, you can instead use so-called I. Examples: $imap->copy( "3,4,9:22", "ANOTHERBOX" ) or die $imap->errstr; $imap->delete( "3,4,9:22", "ANOTHERBOX" ) or die $imap->errstr; =back =head1 AUTHOR =over 4 =item Creator Joao Fonseca C<< >> =item Maintainer 2004 Casey West C<< >> =item Maintainer 2005 Colin Faber C<< >> =item Maintainer 2009 Paul Miller C<< >> =back =head1 COPYRIGHT Copyright (c) 2009-2010 Paul Miller Copyright (c) 2005 Colin Faber Copyright (c) 2004 Casey West Copyright (c) 1999 Joao Fonseca All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 LICENSE This module is free software. You can redistribute it and/or modify it under the terms of the Artistic License 2.0. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. [This software may have had previous licenses, of which the current maintainer is completely unaware. If this is so, it is possible the above license is incorrect or invalid.] =head1 BUGS There are probably bugs. But don't worry, the current maintainer takes them very seriously and will usually triage (at least) within a single day. L =head1 SEE ALSO L, L, L, L Net-IMAP-Simple-1.2204/Makefile.PL0000644000175000017500000000267512224536034016202 0ustar jetterojetterouse ExtUtils::MakeMaker; use ExtUtils::Command qw(cp); my $build_simplex = prompt("Do you wish to include some simple protocol extensions (pulls in Parse::RecDescent)? ", $ENV{OVERRIDE_DEFAULT_SX} ? $ENV{OVERRIDE_DEFAULT_SX} : "y"); if( $build_simplex =~ m/[Yy]/ ) { local @ARGV = qw(contrib/SimpleX.pod contrib/SimpleX.pm .); cp(); open my $out, ">test_simplex" or die "unable to setup body-summary tests: $!"; chmod 0444, qw(SimpleX.pod SimpleX.pm); # prevent myself from editing them without realizing it =cut SimpleX.%: contrib/SimpleX.% $(RM) $@; $(CP) $< $@ && $(CHMOD) 0444 $@ inc/slurp_fetchmailx.pm: inc/slurp_fetchmail.pm sed -e s/slurp_fetchmail/slurp_fetchmailx/ -e s/Net::IMAP::Simple/Net::IMAP::SimpleX/ $< > $@ =cut } else { unlink qw(SimpleX.pod SimpleX.pm test_simplex); } WriteMakefile( 'NAME' => 'Net::IMAP::Simple', 'VERSION_FROM' => 'Simple.pm', AUTHOR => 'Paul Miller ', PREREQ_PM => { 'IO::Socket' => 0, 'IO::Select' => 0, ( $build_simplex ? ('Parse::RecDescent'=>0) : () ), }, ($ExtUtils::MakeMaker::VERSION ge '6.48'? (MIN_PERL_VERSION => 5.008, META_MERGE => { keywords => [qw(imap simple)], resources=> { repository => 'http://github.com/jettero/net--imap--simple', }, }, LICENSE => 'Perl Artistic', ) : ()), ); Net-IMAP-Simple-1.2204/META.json0000640000175000017500000000215412253054776015647 0ustar jetterojettero{ "abstract" : "unknown", "author" : [ "Paul Miller " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.84, CPAN::Meta::Converter version 2.132661", "keywords" : [ "imap", "simple" ], "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-IMAP-Simple", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "IO::Select" : "0", "IO::Socket" : "0", "Parse::RecDescent" : "0", "perl" : "5.008" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "http://github.com/jettero/net--imap--simple" } }, "version" : "1.2204" } Net-IMAP-Simple-1.2204/t/0000750000175000017500000000000012253054776014466 5ustar jetterojetteroNet-IMAP-Simple-1.2204/t/16_exotic_flags.t0000644000175000017500000000101412124717727017630 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 3; our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; $imap->put( testing => "Subject: test message" ); $imap->add_flags(1 => qw(blarg fluurg carmel) ); my @flags = $imap->msg_flags(1); ok( (grep {m/blarg/} @flags), 1 ); ok( (grep {m/fluurg/} @flags), 1 ); ok( (grep {m/carmel/} @flags), 1 ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/pod_coverage.t0000644000175000017500000000105011724212373017300 0ustar jetterojetteroBEGIN { unless( $ENV{I_PROMISE_TO_TEST_SINGLE_THREADED} ) { print "1..1\nok 1\n"; exit 0; } } use strict; use Test::More; if (not $ENV{TEST_AUTHOR}) { plan( skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to true to run.'); } eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD" if $@; my %params = ( 'Net::IMAP::Simple::PipeSocket' => {trustme=>['.']}, ); my @modules = all_modules(); plan tests => scalar @modules; for my $m (@modules) { pod_coverage_ok( $m, $params{$m} ); } Net-IMAP-Simple-1.2204/t/35_imap_results_in_message_body.t0000644000175000017500000000125412224554144023077 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 1; my $special_message = <<"HERE"; From: me To: you Subject: supz! 1 OK FETCH COMPLETED\r 2 OK FETCH COMPLETED\r 3 OK FETCH COMPLETED\r 4 OK FETCH COMPLETED\r 5 OK FETCH COMPLETED\r Hi, this is a message, do you like it? HERE our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; $imap->put( testing => $special_message ); my $return = $imap->get(1); $special_message =~ s/\x0d?\x0a/\x07/g; $return =~ s/\x0d?\x0a/\x07/g; ok( $return, $special_message ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/17_status_and_select.t0000644000175000017500000000145212124721726020666 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 6; our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; if( $nm ) { $imap->delete("1:$nm"); $imap->expunge_mailbox; } ok( $imap->select("testing")+0, 0 ); $imap->put( testing => "Subject: test-$_\n\ntest-$_", '\Seen' ) for 1 .. 10; my ($unseen, $recent, $total) = $imap->status; ok( "unseen $unseen", "unseen 0" ); ok( "total $total", "total 10" ); $imap->unsee($_) for 5,7; ok( "funseen " . $imap->unseen, 'funseen 2' ); ($unseen, $recent, $total) = $imap->status; ok( "unseen $unseen", "unseen 2" ); ok( "total $total", "total 10" ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/70_list2range.t0000644000175000017500000000070111724212330017216 0ustar jetterojetteroBEGIN { unless( $ENV{I_PROMISE_TO_TEST_SINGLE_THREADED} ) { print "1..1\nok 1\n"; exit 0; } } use strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => 2; my @a = sort { rand()<=>rand() } (1 .. 50, 90 .. 99, 1000 .. 1010, 3..10); ok( Net::IMAP::Simple->list2range(@a), my $result = "1:50,90:99,1000:1010" ); my %h; my @b = sort { $a<=>$b } grep {!$h{$_}++} @a; my @c = Net::IMAP::Simple->range2list($result); ok( "@c", "@b" ); Net-IMAP-Simple-1.2204/t/55_uid_stuff.t0000644000175000017500000000156112124721766017161 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 7; our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; my @uidnext = ($imap->uidnext); $imap->put( testing => "Subject: test1" ); push @uidnext, $imap->uidnext; $imap->put( testing => "Subject: test2" ); my @seq = $imap->search_since("1-Jan-1971"); my @uid = $imap->uid(do{local $"=","; "@seq"}); my @aud = $imap->uid(); for( 0 .. $#uid ) { ok($uid[$_], $aud[$_]); ok($uid[$_], $uidnext[$_]); } ok( $imap->uidnext, $uid[-1]+1 ); # this is (perhaps) Net-IMAP-Server specific ... perhaps ok( $imap->uidvalidity ); # how could we test this? my @ssuid = $imap->uidsearch("since 1-Jan-1971"); ok( "@ssuid", "@uid" ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/75_back_and_forth.t0000644000175000017500000000253212124720543020106 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => (our $tests = 10 + 3); our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; $imap->create_mailbox('test'); ok( $imap->select("testing")+0, 0 ); $imap->put( testing => "Subject: test-$_\n\ntest-$_" . "\n" . (" xxxxxx " x 2_000), '\Seen' ) for 1 .. $tests; ok( $imap->select("testing")+0, $tests ); for my $i ( 1 .. ($tests-3) ) { my $errors = 0; my $msg = $imap->get($i) or do { $errors ++; warn " " . $imap->errstr }; $imap->put( test => $msg ) or do { $errors ++; warn " " . $imap->errstr }; $imap->delete( $i ) or do { $errors ++; warn " " . $imap->errstr }; ok($errors, 0); } # hey, look at that... dovecot produces this error on its own # [...blib/lib/Net/IMAP/Simple.pm line 1181 in sub _send_cmd] 56 FETCH 913 RFC822\r\n # [...blib/lib/Net/IMAP/Simple.pm line 725 in sub _process_cmd] 56 BAD Error in IMAP command FETCH: Invalid messageset\r\n # [...blib/lib/Net/IMAP/Simple.pm line 1201 in sub _cmd_ok] 56 BAD Error in IMAP command FETCH: Invalid messageset\r\n $imap->get($tests + 9_00); # finishing move ok( $imap->errstr, qr(Invalid messageset|message not found)i ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/critic.t0000644000175000017500000000063511724212373016130 0ustar jetterojetteroBEGIN { unless( $ENV{I_PROMISE_TO_TEST_SINGLE_THREADED} ) { print "1..1\nok 1\n"; exit 0; } } use strict; use Test::More; use File::Spec; if (not $ENV{TEST_AUTHOR}) { plan( skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to true to run.'); } eval { require Test::Perl::Critic; }; if ($@) { plan( skip_all => 'Test::Perl::Critic required for test.'); } Test::Perl::Critic->import(); all_critic_ok(); Net-IMAP-Simple-1.2204/t/10_list.t0000644000175000017500000000144612124615144016125 0ustar jetterojetteroBEGIN { unless( $ENV{I_PROMISE_TO_TEST_SINGLE_THREADED} ) { print "1..1\nok 1\n"; exit 0; } } use strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 5; our $imap; sub run_tests { $imap->create_mailbox("blarg"); my $n = $imap->select("blarg"); $imap->delete("1:$n"); $imap->expunge_mailbox; $imap->select("blarg"); my $h = $imap->list(); ok( ref $h, "HASH" ); ok( int(keys %$h), 0 ); $imap->put( blarg => "Subject: test!\n\ntest!" ); $imap->select('blarg'); $h = $imap->list(); ok( ref $h, "HASH" ); ok( int(keys %$h), 1 ); my ($v) = values %$h; ok( $v == 21 || $v == 25 ); # dovecot puts another \r\n on the end (or something like that) and is 25 instead of the expected 21 bytes } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/19_readline_callback.t0000644000175000017500000000117012124715750020560 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 2; my $append_ok = 0; my $get_ok = 0; sub callback_test { my ($line) = @_; # e.g.: 5 OK [APPENDUID 1283347568 1002] APPEND COMPLETED $append_ok ++ if $line =~ m/\d+\s+OK.+?APPEND COMPLETED/i; $get_ok ++ if $line =~ m/test-\d+!/; } our $CALLBACK_TEST = \&callback_test; our $imap; sub run_tests { my $nm = $imap->select("testing"); $imap->put( testing => "Subject: test!\n\ntest-$_!" ) for 1 .. 5; $imap->get( $_ ) for 1 .. 5; ok( $append_ok, 5 ); ok( $get_ok, 5 ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/07_select_and_examine.t0000644000175000017500000000276312124722521020770 0ustar jetterojetterouse strict; no warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 16; our $imap; my $nm; sub run_tests { my $nm = $imap->select("testing") or die "imap error: " . $imap->errstr; $nm = $imap->select("testing"); $imap->put( testing => "Subject: test!\n\ntest!" ) or die "problem putting message: " . $imap->errstr; my @c = ( [ scalar $imap->select("fake"), $imap->current_box, $imap->unseen, $imap->last, $imap->recent ], [ scalar $imap->select("testing"), $imap->current_box, $imap->unseen, $imap->last, $imap->recent ], [ scalar $imap->select("fake"), $imap->current_box, $imap->unseen, $imap->last, $imap->recent ], [ scalar $imap->select("testing"), $imap->current_box, $imap->unseen, $imap->last, $imap->recent ], ); ok( $c[$_][1], "testing" ) for 0 .. $#c; ok( $c[0][0], undef ); ok( $c[1][0], $nm+1 ); ok( $c[2][0], undef ); ok( $c[3][0], $nm+1 ); ok( "@{ $c[$_] }[2,3,4]", "1 1 0" ) for 0 .. $#c; ## Test EXMAINE ok( $imap->examine('testing') ); # ok( not $imap->put( testing => "Subject: test!\n\ntest!" ) ); # ok( $imap->errstr, qr/read.*only/ ); # this worked in Net::IMAP::Server -- dovecot apparently lets you append after examine... heh ok( $nm = $imap->select('testing') ); ok( $imap->put( testing => "Subject: test!\n\ntest!" ), 1 ) or die " error putting test message: " . $imap->errstr . "\n"; ok( $imap->select('testing'), 2 ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/22_copy_multiple.t0000644000175000017500000000120012124715237020032 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 5; our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; ok( $imap->select("testing")+0, 0 ); $imap->put( testing => "Subject: test-$_\n\ntest-$_", '\Seen' ) for 1 .. 10; ok( $imap->select("testing")+0, 10 ); $imap->create_mailbox("testing2"); my @res; ok( $res[0] = $imap->copy( "3:5,9", 'testing2' ) ); ok( $res[1] = $imap->copy( "1,7", 'testing2' ) ); ok( $res[2] = $imap->select("testing2"), 6 ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/50_body_summary.t0000644000175000017500000000271712124721707017675 0ustar jetterojetterouse strict; use warnings; use Test; BEGIN { if( not -f "test_simplex" ) { plan tests => 1; print "# skipping all tests, not installing SimpleX\n"; skip(1,1,1); exit 0; } } use Net::IMAP::SimpleX; plan tests => our $tests = 4 + (3+4); our $imap; our $USE_SIMPLEX = 1; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; $imap->put( testing => "Subject: test" ); my $bs = $imap->body_summary(1); ok( not $bs->has_parts() ); ok( not $bs->type() ); ok( not $bs->parts() ); ok( $bs->body()->content_type(), "text/plain" ); $imap->put( testing => <HTML Content

--0-1563833763-1277912078=:86501-- TEST2 $bs = $imap->body_summary(2); ok( $bs->has_parts() ); ok( $bs->type(), "alternative" ); ok( scalar (my @parts = $bs->parts()), 2 ); ok( $parts[0]->content_type(), "text/plain" ); ok( $parts[1]->content_type(), "text/html" ); ok( $parts[0]->charset(), "fake-charset-1" ); ok( $parts[1]->charset(), "fake-charset-2" ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/15_flags.t0000644000175000017500000000414212124715700016246 0ustar jetterojetterouse strict; use Test; use Net::IMAP::Simple; plan tests => our $tests = ((my $puts = 5)+1)*4 -2 # the put lines + 8 # some arbitrary flag tests on message 4 + 8 # some msg_flags return values + 8 # grab flags for some nonexistnat messages, and for some existant ones ; our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; ok( 0+$imap->last, 0 ); ok( 0+$imap->unseen, 0 ); for(1 .. $puts) { ok( $imap->put( testing => "Subject: test-$_\n\ntest-$_" ) ); ok( 0+$imap->last, $_ ); ok( 0+$imap->unseen, $_ ); $imap->see($_); ok( 0+$imap->unseen, 0 ); } $imap->unsee(4); $imap->delete(4); ok( not $imap->seen(4) ); ok( $imap->deleted(4) ); $imap->see(4); $imap->undelete(4); ok( $imap->seen(4) ); ok( not $imap->deleted(4) ); $imap->add_flags( 5, qw(\Seen \Deleted) ); ok( $imap->seen(5) ); ok( $imap->deleted(5) ); $imap->sub_flags( 5, qw(\Seen \Deleted) ); ok( not $imap->seen(5) ); ok( not $imap->deleted(5) ); $imap->sub_flags( 4, qw(\Seen \Deleted \Answered) ); $imap->add_flags( 5, qw(\Seen \Deleted \Answered) ); my $w; my @flags4 = $imap->msg_flags(4); ok( not ($w=$imap->waserr) ); warn $imap->errstr if $w; my $flags4 = $imap->msg_flags(4); ok( not ($w=$imap->waserr) ); warn $imap->errstr if $w; my @flags5 = $imap->msg_flags(5); ok( not ($w=$imap->waserr) ); warn $imap->errstr if $w; my $flags5 = $imap->msg_flags(5); ok( not ($w=$imap->waserr) ); warn $imap->errstr if $w; ok( 0+@flags4, 0 ); # ok( 0+@flags5, 3 ); # \Seen \Answered \Deleted ok( defined $flags4 ); ok( defined $flags5 ); () = $imap->msg_flags(252); ok( $imap->waserr ); ok( not defined $imap->msg_flags(252) ); ok( not defined $imap->seen(252) ); ok( not defined $imap->deleted(252) ); ok( defined $imap->seen(4) ); ok( defined $imap->seen(5) ); ok( defined $imap->deleted(4) ); ok( defined $imap->deleted(5) ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/pod.t0000644000175000017500000000055111724212362015430 0ustar jetterojetteroBEGIN { unless( $ENV{I_PROMISE_TO_TEST_SINGLE_THREADED} ) { print "1..1\nok 1\n"; exit 0; } } use strict; use Test::More; if (not $ENV{TEST_AUTHOR}) { plan( skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to true to run.'); } eval "use Test::Pod 1.00"; ## no critic plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Net-IMAP-Simple-1.2204/t/22_uidcopy_multiple.t0000644000175000017500000000127312124715337020547 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 5; our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; ok( $imap->select("testing")+0, 0 ); $imap->put( testing => "Subject: test-$_\n\ntest-$_", '\Seen' ) for 1 .. 10; ok( $imap->select("testing")+0, 10 ); $imap->create_mailbox("testing2"); my @_uid359 = $imap->uid("3:5,9"); my @_uid17 = $imap->uid("1,7"); ok($imap->uidcopy( join(",",@_uid359), 'testing2' ) ); ok($imap->uidcopy( join(",",@_uid17), 'testing2' ) ); ok($imap->select("testing2"), 6 ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/60_fetch_with_grammar.t0000644000175000017500000003120112225265241021002 0ustar jetterojetterouse strict; use warnings; use Test; BEGIN { if( not -f "test_simplex" ) { plan tests => 1; print "# skipping all tests, not installing SimpleX\n"; skip(1,1,1); exit 0; } } use Net::IMAP::SimpleX; plan tests => our $tests = ( 1 # the sample test + 1 # keys=5 + 2 # UIDs + 2 # HEADER FIELDS + 2 # UID HEADER FIELDS ); my $sample = q/* 1 FETCH (FLAGS (\Recent) INTERNALDATE "23-Jul-2010 22:21:37 -0400" RFC822.SIZE 402/ . q/ ENVELOPE (NIL "something" NIL NIL NIL NIL NIL NIL NIL NIL) BODYSTRUCTURE (("text" "plain" ("charset" "fake-charset-1")/ . qq/ NIL NIL "7BIT" 15 2)("text" "html" ("charset" "fake-charset-2") NIL NIL "7BIT" 21 2) "alternative"))\x0d\x0a/; our $imap; our $USE_SIMPLEX = 1; sub run_tests { my $parser = $imap->{parser}{fetch}; my $bool = $parser->fetch_item($sample) ? 1:0; ok( $bool ) or warn " couldn't parse: $sample"; my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; $imap->put(testing=>$_) for get_messages(); my %parts = eval { %{ $imap->fetch(1=>'FULL')->{1} } }; ok( int( keys %parts ), 5 ) or warn do {my @a = keys %parts; "parts(@a)"}; my $res = $imap->fetch('1:*', "UID BODY[HEADER.FIELDS (DATE FROM SUBJECT)]"); my $uid1 = $res->{1}{UID}; my $uid2 = $res->{2}{UID}; ok( $uid1 > 0 and $uid2 > 0 ); ok( $uid1 != $uid2 ); ok( $res->{1}{'BODY[HEADER.FIELDS (DATE FROM SUBJECT)]'} =~ m/1:09.*Paul Miller.*test message/s ); ok( $res->{2}{'BODY[HEADER.FIELDS (DATE FROM SUBJECT)]'} =~ m/4:12.*Paul Miller.*test2/s ); $res = $imap->uidfetch("$uid1,$uid2", "UID BODY[HEADER.FIELDS (DATE FROM SUBJECT)]"); ok( $res->{1}{'BODY[HEADER.FIELDS (DATE FROM SUBJECT)]'} =~ m/1:09.*Paul Miller.*test message/s ); ok( $res->{2}{'BODY[HEADER.FIELDS (DATE FROM SUBJECT)]'} =~ m/4:12.*Paul Miller.*test2/s ); } do "t/test_runner.pm"; sub get_messages { my @messages = (< Received: from voltar.org (x-x-x-x.lightspeed.klmzmi.sbcglobal.net [0.0.0.0]) by mx.google.com with ESMTPS id n20sm1380887ibe.17.2010.07.24.07.01.10 (version=TLSv1/SSLv3 cipher=RC4-MD5); Sat, 24 Jul 2010 07:01:11 -0700 (PDT) Sender: Paul Miller Date: Sat, 24 Jul 2010 10:01:09 -0400 From: Paul Miller To: Paul Miller Subject: test message Message-ID: <20100724140108.GA19962\@corky> MIME-Version: 1.0 Content-Type: text/plain; charset=us-ascii Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Status: RO Content-Length: 158 Lines: 7 this is the test part -- If riding in an airplane is flying, then riding in a boat is swimming. 116 jumps, 48.6 minutes of freefall, 92.9 freefall miles. TEST1 From jettero\@cpan.org Sat Jul 24 10:04:15 2010 Return-Path: Received: from cpan.org (x-x-x-x.lightspeed.klmzmi.sbcglobal.net [0.0.0.0]) by mx.google.com with ESMTPS id e8sm1384214ibb.14.2010.07.24.07.04.14 (version=TLSv1/SSLv3 cipher=RC4-MD5); Sat, 24 Jul 2010 07:04:14 -0700 (PDT) Sender: Paul Miller Date: Sat, 24 Jul 2010 10:04:12 -0400 From: Paul Miller To: Paul Miller Subject: test2 Message-ID: <20100724140412.GA20361\@corky> MIME-Version: 1.0 Content-Type: text/plain; charset=us-ascii Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 test2 -- If riding in an airplane is flying, then riding in a boat is swimming. 116 jumps, 48.6 minutes of freefall, 92.9 freefall miles. TEST2 } Net-IMAP-Simple-1.2204/t/80_top.t0000644000175000017500000000132012224536413015754 0ustar jetterojetteroBEGIN { unless( $ENV{I_PROMISE_TO_TEST_SINGLE_THREADED} ) { print "1..1\nok 1\n"; exit 0; } } use strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 3; our $imap; sub run_tests { $imap->create_mailbox("blarg"); my $n = $imap->select("blarg"); $imap->delete("1:$n"); $imap->expunge_mailbox; $imap->select("blarg"); $imap->put( blarg => "Subject: test$_\n\ntest$_" ) for 1..2; my @r = $imap->top; my @a = "@r" =~ m/(test\d+)/g; ok( "@a", "test1 test2" ); @r = $imap->top(1); @a = "@r" =~ m/(test\d+)/g; ok( "@a", "test1" ); @r = $imap->top(2); @a = "@r" =~ m/(test\d+)/g; ok( "@a", "test2" ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/45_search.t0000644000175000017500000000114712124720234016422 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = (my $puts = 5)*1 +1 # startup +2 # subject searches ; our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; ok( 0+$imap->search_unseen, 0 ); for my $pnum (1 .. $puts) { $imap->put( testing => "Subject: test-$pnum\n\ntest-$pnum" ); ok( 0+$imap->search_unseen, $pnum ); } ok( 0+$imap->search_subject("test-"), $puts ); ok( 0+$imap->search_subject("test-3"), 1 ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/01_load.t0000644000175000017500000000015512076004052016061 0ustar jetterojettero use strict; use warnings; use Test; plan tests => 1; ok(eval "use Net::IMAP::Simple; 1") or warn " $@"; Net-IMAP-Simple-1.2204/t/08_selectalot.t0000644000175000017500000000101312124717624017314 0ustar jetterojetterouse strict; use Test; use Net::IMAP::Simple; plan tests => our $tests = 3; our $imap; sub run_tests { $imap->select("testing") or warn " \e[1;33m" . $imap->errstr . "\e[m\n"; ok( $imap->current_box, "testing" ); $imap->select("reallynowaythissuckerexistsIhope"); ok( $imap->current_box, "testing" ); $imap->create_mailbox("anotherthingy"); $imap->select("anotherthingy") or warn " \e[1;33m" . $imap->errstr . "\e[m\n"; ok( $imap->current_box, "anotherthingy" ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/test_runner.pm0000644000175000017500000000634212125022435017367 0ustar jetterojetteroour $tests; our $imap; use strict; use IO::Socket::INET; use Time::HiRes qw(time); use Fcntl qw(:flock); no warnings; # # There used to be a little stand alone server than ran in this test suite. It # was totally unreliable and I tired of trying to maintain it. You must now # test against your own server if you wish to test. I highly recommend # skipping the tests. If you choose to report errors, please also explain why # they failed. # # For example, the last failures from CPAN Testers seemed to be segmentation # faults in SSL that I couldn't reproduce at my house or at work. Not really a # perl problem and not really something I can fix. # # On the other hand, it could be a simple network or process management error. # How can I tell from here? TAP wasn't really set up to deal with process # management the way I was doing it. I gave up. # # If you want to test, set these environment variables and run the tests. # These settings are intentionally un-obvious. If you want to run automated # tests please help debug the failures. Automated test results against unknown # environments help absolutely nobody at all. Your IMAP server will differ # from mine, so some of the tests will fail and I won't have any ability to # figure out why without your /tmp/ logs and/or some help. With most modules # cpan testers is the best thing in the entire world. With IMAP, not so much. # # ** THIS WILL DESTROY ANY FOLDERS YOU HAVE NAMED # ** TESTING, TESTING2 OR TESTING3 # # export NIS_TEST_HOST=someserver.org # export NIS_TEST_USER=someguyname # export NIS_TEST_PASS=blarg # # ** THIS WILL DESTROY ANY FOLDERS YOU HAVE NAMED # ** TESTING, TESTING2 OR TESTING3 # # HOST will get connections on 143 and 993, specifying a port is not possible # at this time. # # unless( exists $ENV{NIS_TEST_HOST} and exists $ENV{NIS_TEST_USER} and exists $ENV{NIS_TEST_PASS} and Net::IMAP::Simple->new($ENV{NIS_TEST_HOST}) ) { ok($_) for 1 .. $tests; # just skip everything my $line = "[not actually running any tests -- see t/test_runner.pm]"; my $len = length $line; $len ++; print STDERR "\e7\e[5000C\e[${len}D$line\e8"; exit 0; } open INFC, ">/tmp/client-run-" . time . ".log"; # we don't care very much if the above command fails our $CALLBACK_TEST; my @c = $CALLBACK_TEST ? (readline_callback => $CALLBACK_TEST) :(); our $USE_SIMPLEX; my $class = $USE_SIMPLEX ? "Net::IMAP::SimpleX" : "Net::IMAP::Simple"; $imap = $class->new($ENV{NIS_TEST_HOST}, debug=>\*INFC, @c, use_ssl=>1) or die "\nconnect failed: $Net::IMAP::Simple::errstr\n"; $imap->login(@ENV{qw(NIS_TEST_USER NIS_TEST_PASS)}); if( __PACKAGE__->can('run_tests') ) { for my $mb (qw(testing testing1 testing2 testing3)) { $imap->create_mailbox($mb); my $nm = $imap->select($mb); if( $nm > 0 ) { $imap->delete("1:$nm"); $imap->expunge_mailbox; } } eval { run_tests(); 1} or warn "\nfail: $@\n"; for my $mb (qw(testing testing1 testing2 testing3)) { my $nm = $imap->select($mb); if( $nm > 0 ) { $imap->delete("1:$nm"); $imap->expunge_mailbox; } $imap->delete_mailbox($mb); } } else { warn "weird, no tests"; } Net-IMAP-Simple-1.2204/t/42_preauth_with_command.t0000644000175000017500000000223612224554160021357 0ustar jetterojetterouse strict; no warnings; # NOTE: To use this test, you have to enter a PREAUTH server command into your # ~/.ppsc_test file and make sure you have File::Slurp installed. # # Example command: # # echo ssh -C blarghost exec dovecot --exec-mail imap > ~/.ppsc_test # use Test; use Net::IMAP::Simple; plan tests => our $tests = 1; sub fixeol($) { $_[0] =~ s/[\x0d\x0a]+/\n/g } my $time = localtime; my $msg = <<"HERE"; From: me To: you Subject: NiSim Test - $time $time NiSim Test HERE #open INFC, ">>", "informal-imap-client-dump.log" or die $!; my $cmd; if( my $t = "$ENV{HOME}/.ppsc_test" ) { eval q + use File::Slurp qw(slurp); $cmd = slurp("$ENV{HOME}/.ppsc_test"); chomp $cmd; +; } unless( $cmd ) { skip(1,1,1); exit 0; } my $imap = Net::IMAP::Simple->new("cmd:$cmd", #debug=>\*INFC ) or die "\nconnect failed: $Net::IMAP::Simple::errstr\n"; $imap->create_mailbox('testing'); my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; $imap->put( testing => $msg ); my $gmsg = $imap->get( $nm + 1 ); $imap->delete_mailbox('testing'); fixeol($msg); fixeol($gmsg); ok( $gmsg, $msg ); Net-IMAP-Simple-1.2204/t/23_delete_multiple.t0000644000175000017500000000104712253054006020325 0ustar jetterojetterouse strict; use warnings; use Test; use Net::IMAP::Simple; plan tests => our $tests = 4; our $imap; sub run_tests { my $nm = $imap->select('testing') or die " failure selecting testing: " . $imap->errstr . "\n"; ok( $imap->select("testing")+0, 0 ); $imap->put( testing => "Subject: test-$_\n\ntest-$_", '\Seen' ) for 1 .. 10; $imap->delete( "3:4,6" ) or warn $imap->errstr; my @e = $imap->expunge_mailbox; ok( not $imap->waserr ); ok( "@e", "6 4 3" ); ok( $imap->last, 7 ); } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/t/11_mailboxes.t0000644000175000017500000000055512124720270017133 0ustar jetterojetterouse strict; use Test; use Net::IMAP::Simple; plan tests => our $tests = 2; our $imap; sub run_tests { $imap->create_mailbox("anotherthingy"); my @e = $imap->mailboxes; my @E = qw(testing anotherthingy); for my $__e (@E) { ok(1) if grep { $_ eq $__e } @e; # would use ~~ but would rule out 5.8 boxes } } do "t/test_runner.pm"; Net-IMAP-Simple-1.2204/.perlcriticrc0000644000175000017500000000034011462543612016704 0ustar jetterojetteroseverity = 4 verbose = 8 exclude = ValuesAndExpressions::ProhibitConstantPragma Subroutines::RequireArgUnpacking Modules::RequireFilenameMatchesPackage Modules::ProhibitMultiplePackages TestingAndDebugging::ProhibitNoStrict Net-IMAP-Simple-1.2204/TODO0000644000175000017500000000032411462543612014710 0ustar jetterojettero- there should be tests for the new search() - there should be tests for the newly repaird top() - search() should get fancier, dunno how - search() should be documented ... er... when it's ... desgined properly Net-IMAP-Simple-1.2204/contrib/0000750000175000017500000000000012253054776015663 5ustar jetterojetteroNet-IMAP-Simple-1.2204/contrib/SimpleX.pod0000644000175000017500000001305011711501636017742 0ustar jetterojettero=head1 NAME Net::IMAP::SimpleX - Addons for Net::IMAP::Simple =head1 SYNOPSIS use strict; use warnings; use Net::IMAP::SimpleX; L uses L as a base so the object creation is the same as it is for the ancestor: my $imap = Net::IMAP::SimpleX->new('imap.example.com') || die "Unable to connect to IMAP: $Net::IMAP::Simple::errstr\n"; $imap->select("INBOX"); L is a collection of handy methods that are not simple, require L, or are experimental. =head1 DESCRIPTION This module adds some useful, yet not so simple, extensions on top of L. =head1 METHODS =over 4 =item new For details on the invocation, read L. =item body_summary Typical invocations will take this overall shape. # get an object representation of the message body my $summary = $imap->body_summary($message_number); # multipart message if ($summary->has_parts) { for my $subpart ($summary->parts) { if ($subpart->has_parts) { ... } # examine the message part my @attr = map { $subpart->$_ } qw/content_type encoding encoded_size/; # fetch the raw message part my $subpart_body = $imap->get($message_number, $subpart->part_number); } } else { my $body = $summary->body; my @attr = map { $body->$_ } qw/content_type encoding encoded_size/ } This method returns a simple object that contains a representation of the body of a message. The object is built by a L parser using the output of an IMAP I command. The parser uses the formal syntax as defined by RFC3501 L. my $body = $summary->body; my @attr = map { $body->$_ } qw/ content_description encoded_size charset content_type part_number format id encoding /; For multipart messages, the object contains sub-objects for each message part, accessible via the parts() method and inspected via the has_parts() method. The type method describes the type of multipart (such as mixed or alternative). The parts method returns a list of sub parts, which themselves may have subparts, and so on. An example of a multipart, alternative message with a text body and an html version of the body would looke something like: if ($summary->has_parts) { if ($summary->type eq 'alternative') { my ($html) = grep { $_->content_type eq 'text/html' } $summary->parts; } } A really complex, multipart message could look something like this: if ($summary->has_parts && $summary->type eq 'mixed') { for my $part ($summary->parts) { if ($part->has_parts && $part->type eq 'mixed') { ... } ... } } =item fetch The fetch command returns the various parts of messages that users request. It is fairly complicated (following RFC3501 using a grammar/parser), but there are some basic patterns that it follows. my $res =$imap->fetch('30:32' => 'UID BODY.PEEK[HEADER.FIELDS (DATE)] FLAGS') # $res = { # 30 => { # "BODY[HEADER.FIELDS (DATE)]" => "Date: Sun, 18 Jul 2010 20:54:48 -0400\r\n\r\n", # "FLAGS" => ["\\Flagged", "\\Seen"], # "UID" => 58890, # }, # 31 => { # "BODY[HEADER.FIELDS (DATE)]" => "Date: Wed, 21 Jul 2010 09:09:04 -0400\r\n\r\n", # "FLAGS" => ["\\Seen"], # "UID" => 58891, # }, # 32 => { # "BODY[HEADER.FIELDS (DATE)]" => "Date: Sat, 24 Jul 2010 05:12:06 -0700\r\n\r\n", # "FLAGS" => ["\\Seen"], # "UID" => 58892, # }, # } So-called "parenthized" lists will be returned as an array (see C) but nearly everything else will come back as strings. This includes parenthized queries. Take C), for example. The result would come back as the RFC822 header lines (as the above C has done). For more information about the different types of queries, see RFC3501. There's a surprising number of things that can be queried. =item uidfetch This is roughly the same thing as the C method above, but the query runs on UIDs instead of sequence numbers. The keys of the C<$res> are still the sequence numbers though. my $res =$imap->fetch('58890' => 'UID BODY.PEEK[HEADER.FIELDS (DATE)] FLAGS') # $res = { # 30 => { # "BODY[HEADER.FIELDS (DATE)]" => "Date: Sun, 18 Jul 2010 20:54:48 -0400\r\n\r\n", # "FLAGS" => ["\\Flagged", "\\Seen"], # "UID" => 58890, # }, # ... =back =head1 AUTHOR =over 4 =item INITIAL AUTHOR Jason Woodward C<< >> =item ADDITIONAL CONTRIBUTIONS Paul Miller C<< >> [I] =back =head1 COPYRIGHT Copyright (c) 2010 Jason Woodward All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 LICENSE This module is free software. You can redistribute it and/or modify it under the terms of the Artistic License 2.0. This program is distributed in the hope that it will be useful, but without any warranty; without even the implied warranty of merchantability or fitness for a particular purpose. =head1 BUGS L =head1 SEE ALSO L, L, L Net-IMAP-Simple-1.2204/contrib/hand_test01.pl0000755000175000017500000000071211462543612020333 0ustar jetterojettero#!/usr/bin/perl use strict; use warnings; use lib 'inc', "blib/lib", "blib/arch"; use rebuild_iff_necessary; use slurp_fetchmail; use Data::Dump qw(dump); my $imap = slurp_fetchmail->login(use_ssl=>1); my @c; for my $box (map {split m/\s+/} (@ARGV ? @ARGV : ("INBOX"))) { push @c, { selectres => dump($imap->select($box)), box => $imap->current_box, first_unseen=>$imap->unseen, recent=>$imap->recent, }; } warn dump(@c) . "\n"; Net-IMAP-Simple-1.2204/contrib/preauth-pipe-server.pl0000755000175000017500000000226311462543612022133 0ustar jetterojettero#!/usr/bin/perl use strict; use Net::Server; use base 'Net::Server::PreFork'; use IPC::Open3; use IO::Select; my $port = shift; my @cmd = @ARGV; die "port cmd cmd cmd cmd cmd cmd cmd" unless $port and @cmd; sub process_request { my $this = shift; my ($wtr, $rdr, $err); my $pid = open3($wtr, $rdr, $err, @cmd); $rdr->blocking(0); STDIN->blocking(0); my $select = IO::Select->new($rdr, \*STDIN); TOP: while(1) { if( my @handles = $select->can_read(1) ) { for(@handles) { my $at_least_one = 0; while( my $line = $_->getline ) { if( $_ == $rdr ) { print STDOUT $line; $this->log(1, "[IMAP] $line"); } else { print $wtr $line; $this->log(1, "[CLNT] $line"); } $at_least_one ++; } last TOP unless $at_least_one; } } } $this->log(1, "[KILL] $pid must die"); kill -1, $pid; kill -2, $pid; waitpid $pid, 0; return; } main->run(port=>$port, log_file=>"ppsc.log"); Net-IMAP-Simple-1.2204/contrib/connectalot.pl0000755000175000017500000000170611462543612020536 0ustar jetterojettero#!/usr/bin/perl use strict; use warnings; use IO::Socket::INET; use IO::Socket::SSL; my $ppid = $$; END { print "[$$] ", $$==$ppid ? "ppid ":"", "exit\n" }; print "[$$] ppid started\n"; $SIG{__WARN__} = sub { print "[$$] $_[0]" }; $SIG{__DIE__} = sub { print "[$$] $_[0]"; exit 0 }; my $class = $ENV{ca_use_ssl} ? "IO::Socket::SSL" : "IO::Socket::INET"; my $port = $ENV{ca_use_ssl} ? 19794 : 19795; my @pids; for( 1 .. 5 ) { if( my $pid = fork ) { push @pids, $pid; } else { print "[$$] start\n"; my $sock = $class->new(PeerAddr=>"localhost:$port", Timeout=>2) or die "couldn't bind: $@"; while( my $line = $sock->getline ) { print "[$$] $line"; } my $eof = ($sock->eof() ? "EOF" : "..."); my $ced = ($sock->connected() ? "CONNECTED" : "..."); my $time = time; print "[$$] time: $time; eof: $eof; ced: $ced\n"; exit 0; } } waitpid( $_, 0 ) for @pids; Net-IMAP-Simple-1.2204/contrib/SimpleX.pm0000644000175000017500000001655112130310104017565 0ustar jetterojetteropackage Net::IMAP::SimpleX::NIL; use strict; use warnings; use overload fallback=>1, '""' => sub { "" }; sub new { return bless {}, "Net::IMAP::SimpleX::NIL" } package Net::IMAP::SimpleX::Body; use strict; use warnings; no warnings 'once'; ## no critic our $uidm; BEGIN { our @fields = qw/content_description encoded_size charset content_type format part_number id name encoding/; for my $attr (@fields) { no strict; *{"Net::IMAP::SimpleX::Body::$attr"} = sub { shift->{$attr}; }; } } sub hasparts { return 0; } *has_parts = \&hasparts; sub parts { return } sub type { return } sub body { return shift; } package Net::IMAP::SimpleX::BodySummary; use strict; use warnings; no warnings 'once'; ## no critic sub new { my ($class, $data) = @_; my $self; Net::IMAP::SimpleX::_id_parts($data); if ($data->{parts}) { $self = $data; } else { $self = { body => $data }; } return bless $self, $class; } sub hasparts { return shift->{parts} ? 1 : 0; } *has_parts = \&hasparts; sub parts { my $self = shift; return wantarray ? @{$self->{parts}} : $self->{parts}; } sub type { return shift->{type} || undef; } sub body { return shift->{body}; } package Net::IMAP::SimpleX; use strict; use warnings; use Carp; use Parse::RecDescent; use base 'Net::IMAP::Simple'; our $VERSION = "1.1000"; # directly from http://tools.ietf.org/html/rfc3501#section-9 # try and flatten, format as best we can our $body_grammar = q { body: body_type_mpart | body_type_1part { $return = bless $item[1], 'Net::IMAP::SimpleX::Body'; } body_type_mpart: '('body(s) subtype')' { $return = bless { parts => $item[2], type => $item{subtype} }, 'Net::IMAP::SimpleX::BodySummary'; } body_type_1part: body_type_basic | body_type_text { $return = bless $item[1], 'Net::IMAP::SimpleX::BodySummary'; } body_type_basic: '('media_type body_fields')' { $return = { content_type => $item{media_type}, %{$item{body_fields}} }; } body_type_text: '('media_type body_fields number')' { $return = { content_type => $item{media_type}, %{$item{body_fields}}, }} body_fields: body_field_param body_field_id body_field_desc body_field_enc body_field_octets { $return = { id => $item{body_field_id}, content_description => $item{body_field_desc}, encoding => $item{body_field_enc}, encoded_size => $item{body_field_octets}, $item{body_field_param} ? %{$item{body_field_param}} : () }; } body_field_id: nil | word body_field_desc: nil | word body_field_enc: word body_field_octets: number body_field_param: body_field_param_simple | body_field_param_ext | nil body_field_param_ext: '('word word word word')' { $return = { $item[2] => $item[3], $item[4] => $item[5] }; } body_field_param_simple: '('word word')' { $return = { $item[2] => $item[3] }; } body_field_param: nil media_type: type subtype { $return = "$item{type}/$item{subtype}"; } type: word subtype: word nil: 'NIL' {$return = '';} number: /\d+/ key: word value: word word: /[^\s\)\(]+/ { $item[1] =~ s/\"//g; $return = $item[1];} }; our $fetch_grammar = q& fetch: fetch_item(s) {$return={ map {(@$_)} reverse @{$item[1]} }} fetch_item: cmd_start 'FETCH' '(' value_pair(s?) ')' {$return=[$item[1], {map {(@$_)} @{$item[4]}}]} cmd_start: '*' /\d+/ {$return=$item[2]} value_pair: tag value {$return=[$item[1], $item[2]]} tag: /BODY\b(?:\.PEEK)?(?:\[[^\]]*\])?(?:<[\d\.]*>)?/i | atom value: atom | string | parenthized_list atom: /[^"()\s{}[\]]+/ { # strictly speaking, the NIL atom should be undef, but P::RD isn't going to allow that. # returning a null character instead $return=($item[1] eq "NIL" ? Net::IMAP::SimpleX::NIL->new : $item[1]) } string: '"' /[^\x0d\x0a"]*/ '"' {$return=$item[2]} | '{' /\d+/ "}\x0d\x0a" { $return = length($text) >= $item[2] ? substr($text,0,$item[2],"") # if the production is accepted, we alter the input stream : undef; } parenthized_list: '(' value(s?) ')' {$return=$item[2]} &; sub new { my $class = shift; if (my $self = $class->SUPER::new(@_)) { $self->{parser}{body_summary} = Parse::RecDescent->new($body_grammar); $self->{parser}{fetch} = Parse::RecDescent->new($fetch_grammar); return $self; } } sub _id_parts { my $data = shift; my $pre = shift; $pre = $pre ? "$pre." : ''; my $id = 1; if (my $parts = $data->{parts}) { for my $sub (@$parts){ _id_parts($sub,"$pre$id") if $sub->{parts}; $sub->{part_number} = "$pre$id"; $id++; } } else { $data->{part_number} = $id; } return; } sub body_summary { my ($self, $number) = @_; my $bodysummary; return $self->_process_cmd( cmd => [ 'FETCH' => qq[$number BODY] ], final => sub { return $bodysummary; }, process => sub { if ($_[0] =~ m/\(BODY\s+(.*?)\)\s*$/i) { my $body_parts = $self->{parser}{body_summary}->body($1); $bodysummary = Net::IMAP::SimpleX::BodySummary->new($body_parts); } }, ); } sub uidfetch { my $self = shift; local $uidm = 1; # auto-pop this after the fetch return $self->fetch(@_); } sub fetch { my $self = shift; my $msg = shift; $msg =~ s/[^\*\d:,-]//g; croak "which message?" unless $msg; my $spec = "@_" || 'FULL'; $self->_be_on_a_box; # cut and pasted from ::Server $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE ENVELOPE/] if uc $spec eq "ALL"; $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE/] if uc $spec eq "FAST"; $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY/] if uc $spec eq "FULL"; $spec = [ $spec ] unless ref $spec; my $stxt = join(" ", map {s/[^()[\]\s<>\da-zA-Z.-]//g; uc($_)} @$spec); ## no critic: really? don't modify $_? pfft $self->_debug( caller, __LINE__, parsed_fetch=> "$msg ($stxt)" ) if $self->{debug}; my $entire_response = ""; return $self->_process_cmd( cmd => [ ($uidm ? "UID FETCH" : "FETCH")=> qq[$msg ($stxt)] ], final => sub { #open my $fh, ">", "entire_response.dat"; #print $fh $entire_response; if( my $res = $self->{parser}{fetch}->fetch($entire_response) ) { $self->_debug( caller, __LINE__, parsed_fetch=> "PARSED") if $self->{debug}; return wantarray ? %$res : $res; } $self->_debug( caller, __LINE__, parsed_fetch=> "PARSE FAIL") if $self->{debug}; return; }, process => sub { $entire_response .= $_[0]; return 1; }, ); } 1; Net-IMAP-Simple-1.2204/contrib/status.pl0000755000175000017500000000036011462543612017543 0ustar jetterojettero#!/usr/bin/perl use strict; use warnings; use lib 'inc', "blib/lib", "blib/arch"; use rebuild_iff_necessary; use slurp_fetchmail; use Data::Dump qw(dump); my $imap = slurp_fetchmail->login(use_ssl=>1); warn dump( $imap->status(shift) ); Net-IMAP-Simple-1.2204/contrib/search-test.pl0000755000175000017500000000326211462543612020446 0ustar jetterojettero#!/usr/bin/perl use strict; use Net::IMAP::Simple; my $goog = login(); $goog->select("jet"); my @id1 = $goog->search(q(SUBJECT "rt.cpan.org #55177")); print "id1: @id1\n"; my @id2 = $goog->search(q(HEADER Message-ID "")); print "id2: @id2\n"; $goog->put( jet => qq(from: jettero\@cpan.org\r\nMessage-ID: test-77\r\nsubject: test-77\r\n\r\ntest-77\r\n) ); $goog->put( jet => qq(from: jettero\@cpan.org\r\nMessage-ID: \r\nsubject: \r\n\r\n\r\n) ); $goog->put( jet => qq(from: jettero\@cpan.org\r\nMessage-ID: \r\nsubject: \r\n\r\n\r\n) ); my @id3 = $goog->search(q(HEADER Message-ID "test-77")); print "id3: @id3\n"; my @id4 = $goog->search(q(HEADER Message-ID "")); print "id4: @id4\n"; my @id5 = $goog->search(q(HEADER Message-ID "")); print "id5: @id5\n"; my @id6 = $goog->search(q(SUBJECT "test-77")); print "id6: @id6\n"; # login {{{ sub login { my $arg = ""; $arg = ".$_[0]" if $_[0]; my $fetchmailrc; { open my $in, "$ENV{HOME}/.fetchmailrc$arg" or die $!; local $/ = undef; $fetchmailrc = <$in>; close $in; } my $server = $1 if $fetchmailrc =~ m/server\s+(.+)/m; my $user = $1 if $fetchmailrc =~ m/user\s+(.+)/m; my $pass = $1 if $fetchmailrc =~ m/pass\s+(.+)/m; print "$server "; my $debug = 1; my $imap = Net::IMAP::Simple->new($server, debug=>$debug, use_ssl=>1) or die "connect failed: $Net::IMAP::Simple::errstr"; $imap->login($user=>$pass) or die "login failed: " . $imap->errstr; print "[in] "; return $imap; } # }}} Net-IMAP-Simple-1.2204/contrib/33189_attach.pl0000755000175000017500000000211211462543612020230 0ustar jetterojettero#!/usr/bin/perl # Warning: the returned message numbers are not always correct! use strict; use warnings; use Email::Simple; use lib 'inc', "blib/lib", "blib/arch"; use rebuild_iff_necessary; use slurp_fetchmail; use Net::IMAP::Simple; my $show_subjects = $ENV{SHOW_SUBJECTS}; my $imap = slurp_fetchmail->login(use_ssl=>1); my $folder = shift || 'INBOX'; my ( $newmsg, $unseenmsg, $oldmsg, $flags ); my $nm = $imap->select($folder); print "folder $folder: $nm total"; $newmsg = $imap->recent; $flags = $imap->flags; $unseenmsg = 0; for ( my $i = 1 ; $i <= $nm ; $i++ ) { $unseenmsg++ if not $imap->seen($i); } $oldmsg = $unseenmsg - $newmsg; print ", $newmsg new, $unseenmsg unseen, $oldmsg old\n"; # Print the subjects of all the messages in the INBOX if ($show_subjects) { for ( my $i = 1 ; $i <= $nm ; $i++ ) { if ( $imap->seen($i) ) { print " "; } else { print "N "; } my $es = Email::Simple->new( join '', @{ $imap->top($i) } ); printf( "[%03d] %s\n", $i, $es->header('Subject') ); } } $imap->quit; Net-IMAP-Simple-1.2204/contrib/imap.pl0000755000175000017500000000576611462543612017165 0ustar jetterojettero#!/usr/bin/perl require 'lib/Net/IMAP/Simple.pm'; print "Square brackets: [] indicate optional arguments\n\n"; print "IMAP Server[:port] [localhost]: "; while(<>){ chomp; $_ ||= 'localhost'; $imap = Net::IMAP::Simple->new($_, port => 143, timeout => 90) || die "$Net::IMAP::Simple::errstr\n"; if($imap){ print "Connected.\n"; last; } else { print "Connection to $_ failed: $Net::IMAP::Simple::errstr\n"; print "IMAP Server[:port]: "; } } print "User: "; while(<>){ chomp; $user = $_; if(!$user){ print "Blank user not allowed\n"; print "User: "; } else { last; } } print "Password: "; system("stty -echo"); while(<>){ chomp; if(!$imap->login($user, $_)){ print "Login failed: " . $imap->errstr . "\n"; } else { my $msgs = $imap->select("INBOX"); print "Messages in INBOX: $msgs\n"; last; } } system("stty echo"); print "\n"; my $ptc = qq{ Please enter a command: help - This help screen list - List all folders / mail boxes accessable by this account folders - List all folders within select box - Select a mail box select folder - Select a folder within , format: Some.Folder.I.Own which looks like: Some/Folder/I/Own exit - Disconnect and close }; print $ptc . "[root] "; my %o; while(<>){ chomp; my (@folders, %boxes); my @folders = $imap->mailboxes; for(@folders){ $boxes{ (split(/\./))[0] } = 1; } my @io = split(/\s+/, $_); if($io[0] eq 'select'){ if($io[1] eq 'box'){ if(!$boxes{ $io[2] }){ print $ptc . "Invalid mail box: $io\n\n"; } else { print "\n-- Mail box successfully selected --\n $io[2]\n\n"; $o{box} = $io[2]; } } elsif($io[1] eq 'folder'){ my $c = $imap->select($io[2]); if(!defined $c){ print $ptc . "Select error: " . $imap->errstr . "\n\n"; } else { print "-- Folder information: $io[2] --\n"; print " Messages: " . $c . "\n"; print " Recent: " . $imap->recent . "\n"; print " Flags: " . $imap->flags . "\n"; print "Flag List: " . join(" ", $imap->flags) . "\n\n"; # $o{folder} = $io[2]; } } else { print $ptc . "Invalid select option\n\n"; } } elsif($io[0] eq 'list'){ print "-- Avaliable mail folders/boxes --\n"; for(keys %boxes){ print "Mail box: $_\n"; } print "\n"; } elsif($io[0] eq 'folders' && $o{box}){ print "-- Listing folders in: $o{box} --\n"; my $x = $o{box}; $x =~ s/(\W)/\\$1/g; for(@folders){ if(/^$x/){ my $msgs = $imap->select($_); if(!defined $msgs){ print "Failed to read: $o{box} -> $_: " . $imap->errstr . "\n"; } else { printf("$o{box} -> $_ " . (" " x (30 - length($_))) . "[%06d]\n", $msgs); } } } print "\n"; } elsif($io[0] eq 'exit' || $io[0] eq 'quit'){ print "Good bye!\n\n"; $imap->quit; exit; } elsif($io[0] eq 'help'){ print $ptc; } else { print $ptc . "Invalid command: $io[0]\n\n"; } print "[" . ($o{box} ? $o{box} : 'root') . ($o{folder} ? " -> $o{folder}" : '') . "] "; } Net-IMAP-Simple-1.2204/inc/0000750000175000017500000000000012253054776014774 5ustar jetterojetteroNet-IMAP-Simple-1.2204/inc/slurp_fetchmail.pm0000644000175000017500000000174211462543612020515 0ustar jetterojettero package slurp_fetchmail; use strict; use warnings; use Carp; use File::Slurp qw(slurp); use Net::IMAP::Simple; use File::Basename; sub login { my $class = shift; my $fetchmailrc = slurp("$ENV{HOME}/.fetchmailrc"); my ($server) = $fetchmailrc =~ m/server\s+(.+)/m; my ($user) = $fetchmailrc =~ m/user\s+(.+)/m; my ($pass) = $fetchmailrc =~ m/pass\s+(.+)/m; croak "server, user and pass must be in the $ENV{HOME}/.fetchmailrc for this to work" unless $server and $user and $pass; if( exists $ENV{DEBUG} ) { if( $ENV{DEBUG} eq "1" ) { $ENV{DEBUG} = basename($0); $ENV{DEBUG} .= ".log"; } } my $imap = Net::IMAP::Simple->new($server, ($ENV{DEBUG} ? (debug=>do { open my $x, ">>", $ENV{DEBUG} or die $!; $x}) : ()), @_) or croak "connect failed: $Net::IMAP::Simple::errstr"; $imap->login($user=>$pass) or croak "login failed: " . $imap->errstr; return $imap; } "True"; Net-IMAP-Simple-1.2204/inc/rebuild_iff_necessary.pm0000644000175000017500000000032711462543612021660 0ustar jetterojettero package rebuild_iff_necessary; BEGIN { use IPC::System::Simple qw(systemx); systemx($^X, "Makefile.PL") if not -f "Makefile" or ((stat "Makefile")[9] > (stat "Makefile.PL")[9]); systemx("make"); } 1; Net-IMAP-Simple-1.2204/lib/0000750000175000017500000000000012253054776014771 5ustar jetterojetteroNet-IMAP-Simple-1.2204/lib/Net/0000750000175000017500000000000012253054776015517 5ustar jetterojetteroNet-IMAP-Simple-1.2204/lib/Net/IMAP/0000750000175000017500000000000012253054776016245 5ustar jetterojetteroNet-IMAP-Simple-1.2204/lib/Net/IMAP/Simple/0000750000175000017500000000000012253054776017476 5ustar jetterojetteroNet-IMAP-Simple-1.2204/lib/Net/IMAP/Simple/PipeSocket.pm0000644000175000017500000000536611523771637022122 0ustar jetterojetteropackage Net::IMAP::Simple::PipeSocket; use strict; use warnings; use Carp; use IPC::Open3; use IO::Select; use Symbol 'gensym'; use base 'Tie::Handle'; sub new { my $class = shift; my %args = @_; croak "command (e.g. 'ssh hostname dovecot') argument required" unless $args{cmd}; open my $fake, "+>", undef or die "initernal error dealing with blarg: $!"; ## no critic my($wtr, $rdr, $err); $err = gensym; my $pid = eval { open3($wtr, $rdr, $err, $args{cmd}) } or croak $@; my $sel = IO::Select->new($err); # my $orig = select $wtr; $|=1; # select $rdr; $|=1; # select $orig; my $this = tie *{$fake}, $class, (%args, pid=>$pid, wtr=>$wtr, rdr=>$rdr, err=>$err, sel=>$sel, ) or croak $!; return $fake; } sub UNTIE { return $_[0]->_waitpid } sub DESTROY { return $_[0]->_waitpid } sub FILENO { my $this = shift; my $rdr = $this->{rdr}; # do we mean rdr or wtr? meh? return fileno($rdr); # probably need this for select() on the read handle } sub TIEHANDLE { my $class = shift; my $this = bless {@_}, $class; return $this; } sub _chkerr { my $this = shift; my $sel = $this->{sel}; while( my @rdy = $sel->can_read(0) ) { for my $fh (@rdy) { if( eof($fh) ) { $sel->remove($fh); next; } my $line = <$fh>; warn "PIPE ERR: $line"; } } return } sub PRINT { my $this = shift; my $wtr = $this->{wtr}; $this->_chkerr; return print $wtr @_; } sub READLINE { my $this = shift; my $rdr = $this->{rdr}; $this->_chkerr; my $line = <$rdr>; return $line; } sub _waitpid { my $this = shift; if( my $pid = delete $this->{pid} ) { for my $key (qw(wtr rdr err)) { close delete $this->{$key} if exists $this->{$key}; } kill 1, $pid; # doesn't really matter if this works... we hung up all the # filehandles, so ... it's probably dead anyway. waitpid( $pid, 0 ); my $child_exit_status = $? >> 8; return $child_exit_status; } return; } sub CLOSE { my $this = shift; my $rdr = $this->{rdr}; my $wtr = $this->{wtr}; close $rdr or warn "PIPE ERR (close-r): $!"; close $wtr or warn "PIPE ERR (close-w): $!"; return; } 1; __END__ =head1 NAME Net::IMAP::Simple::PipeSocket - a little wrapper around IPC-Open3 that feels like a socket =head1 SYNOPSIS This module is really just a wrapper around IPC-Open3 that can be dropped in place of a socket handle. The L code assumes the socket is always a socket and is never a pipe and re-writing it all would be horrible. This abstraction is used only for that purpose.