File Coverage

blib/lib/Net/IMAP/Client.pm

Criterion	Covered	Total	%
statement	36	644	5.5
branch	0	298	0.0
condition	0	74	0.0
subroutine	12	71	16.9
pod	33	33	100.0
total	81	1120	7.2

package Net::IMAP::Client;

use vars qw[$VERSION];
$VERSION = '0.9507';

use strict;
use warnings;

use List::Util qw( min max first );
use List::MoreUtils qw( each_array );
use IO::Socket::INET ();
use IO::Socket::SSL ();
use Socket qw( SO_KEEPALIVE );

use Net::IMAP::Client::MsgSummary ();

our $READ_BUFFER = 4096;
my %UID_COMMANDS = map { $_ => 1 } qw( COPY FETCH STORE SEARCH SORT THREAD );
my %DEFAULT_ARGS = (
    uid_mode => 1,
    timeout  => 90,
    server   => '127.0.0.1',
    port     => undef,
    user     => undef,
    pass     => undef,
    ssl      => 0,
    ssl_verify_peer => 1,
    tls      => 0,
    socket   => undef,
    _cmd_id  => 0,
    ssl_options => {},
);

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

    my $self = { map {
        $_ => exists $args{$_} ? $args{$_} : $DEFAULT_ARGS{$_}
    } keys %DEFAULT_ARGS };

    die "Cannot enable both ssl and tls" if ($self->{tls} and $self->{ssl});

    bless $self, $class;

    $self->{notifications} = [];
    eval {
        $self->_get_socket;     # set up the socket
    };

    return $@ ? undef : $self;
}

sub DESTROY {
    my ($self) = @_;
	local $@;
    eval {
        $self->quit
          if $self->{socket}->opened;
    };
}

sub uid_mode {
    my ($self, $val) = @_;
    if (defined($val)) {
        return $self->{uid_mode} = $val;
    } else {
        return $self->{uid_mode};
    }
}

### imap utilities ###

sub login {
    my ($self, $user, $pass) = @_;
    $user ||= $self->{user};
    $pass ||= $self->{pass};
    $self->{user} = $user;
    $self->{pass} = $pass;
    _string_quote($user);
    _string_quote($pass);
    my ($ok) = $self->_tell_imap(LOGIN => "$user $pass");
    return $ok;
}

sub logout {
    my ($self) = @_;
    $self->_send_cmd('LOGOUT');
    $self->_get_socket->close;
    return 1;
}

*quit = \&logout;

sub capability {
    my ($self, $requirement) = @_;
    my $capability = $self->{capability};
    unless ($capability) {
        my ($ok, $lines) = $self->_tell_imap('CAPABILITY');
        if ($ok) {
            my $line = $lines->[0][0];
            if ($line =~ /^\*\s+CAPABILITY\s+(.*?)\s*$/) {
                $capability = $self->{capability} = [ split(/\s+/, $1) ];
            }
        }
    }
    if ($requirement && $capability) {
        return first { $_ =~ $requirement } @$capability;
    }
    return $capability;
}

sub status {
    my $self = shift;
    my $a;
    my $wants_one = undef;
    if (ref($_[0]) eq 'ARRAY') {
        my @tmp = @{$_[0]};
        $a = \@tmp;
    } else {
        $a = [ shift ];
        $wants_one = 1;
    }
    foreach (@$a) {
        _string_quote($_);
        $_ = "STATUS $_ (MESSAGES RECENT UNSEEN UIDNEXT UIDVALIDITY)";
    }
    my $results = $self->_tell_imap2(@$a);

    # remove "NO CLIENT BUG DETECTED" lines as they serve no
    # purpose beyond the religious zeal of IMAP implementors
    for my $row (@$results) {
        if (@{$row->[1]} > 1) {
            $row->[1] = [ grep { $_->[0] !~ /NO CLIENT BUG DETECTED: STATUS on selected mailbox:/ } @{$row->[1]} ];
        }
    }

    my %ret;
    my $name;
    foreach my $i (@$results) {
        if ($i->[0]) {          # was successful?
            my $tokens = _parse_tokens($i->[1]->[0]);
            $name = $tokens->[2];
            $tokens = $tokens->[3];
            my %tmp = @$tokens;
            $tmp{name} = $name;
            $ret{$name} = \%tmp;
        }
    }
    return $wants_one
        ? (defined $name and $ret{$name})  # avoid data on undef key
        : \%ret;
}

sub select {
	my ($self, $folder) = @_;
	$self->_select_or_examine($folder, 'SELECT');
}
sub examine {
	my ($self, $folder) = @_;
	$self->_select_or_examine($folder, 'EXAMINE');
}

sub _select_or_examine {
    my ($self, $folder, $operation) = @_;
    my $quoted = $folder;
    _string_quote($quoted);
    my ($ok, $lines) = $self->_tell_imap($operation => $quoted);
    if ($ok) {
        $self->{selected_folder} = $folder;
        my %info = ();
        foreach my $tmp (@$lines) {
            my $line = $tmp->[0];
            if ($line =~ /^\*\s+(\d+)\s+EXISTS/i) {
                $info{messages} = $1 + 0;
            } elsif ($line =~ /^\*\s+FLAGS\s+\((.*?)\)/i) {
                $info{flags} = [ split(/\s+/, $1) ];
            } elsif ($line =~ /^\*\s+(\d+)\s+RECENT/i) {
                $info{recent} = $1 + 0;
            } elsif ($line =~ /^\*\s+OK\s+\[(.*?)\s+(.*?)\]/i) {
                my ($flag, $value) = ($1, $2);
                if ($value =~ /\((.*?)\)/) {
                    $info{sflags}->{$flag} = [split(/\s+/, $1)];
                } else {
                    $info{sflags}->{$flag} = $value;
                }
            }
        }
        $self->{FOLDERS} ||= {};
        $self->{FOLDERS}{$folder} = \%info;
    }
    return $ok;
}

sub separator {
    my ($self) = @_;
    my $sep = $self->{separator};
    if (!$sep) {
        my ($ok, $lines) = $self->_tell_imap(LIST => '"" ""');
        if ($ok) {
            my $tokens = _parse_tokens($lines->[0]);
            $sep = $self->{separator} = $tokens->[3];
        } else {
            $sep = undef;
        }
    }
    return $sep;
}

sub folders {
    my ($self) = @_;
    my ($ok, $lines) = $self->_tell_imap(LIST => '"" "*"');
    if ($ok) {
        my @ret = map { _parse_tokens($_)->[4] } @$lines;
        return wantarray ? @ret : \@ret;
    }
    return undef;
}

sub _mk_namespace {
    my ($ns) = @_;
    if ($ns) {
        foreach my $i (@$ns) {
            $i = {
                prefix => $i->[0],
                sep    => $i->[1],
            };
        }
    }
    return $ns;
}

sub namespace {
    my ($self) = @_;
    my ($ok, $lines) = $self->_tell_imap('NAMESPACE');
    if ($ok) {
        my $ret = _parse_tokens($lines->[0]);
        splice(@$ret, 0, 2);
        return {
            personal => _mk_namespace($ret->[0]),
            other    => _mk_namespace($ret->[1]),
            shared   => _mk_namespace($ret->[2]),
        };
    }
}

sub folders_more {
    my ($self) = @_;
    my ($ok, $lines) = $self->_tell_imap(LIST => '"" "*"');
    if ($ok) {
        my %ret = map {
            my $tokens = _parse_tokens($_);
            my $flags = $tokens->[2];
            my $sep   = $tokens->[3];
            my $name  = $tokens->[4];
            ( $name, { flags => $flags, sep => $sep } );
        } @$lines;
        return \%ret;
    }
    return undef;
}

sub noop {
    my ($self) = @_;
    my ($ok) = $self->_tell_imap('NOOP', undef, 1);
    return $ok;
}

sub seq_to_uid {
    my ($self, @seq_ids) = @_;
    my $ids = join(',', @seq_ids);

    my $save_uid_mode = $self->uid_mode;
    $self->uid_mode(0);
    my ($ok, $lines) = $self->_tell_imap(FETCH => "$ids UID", 1);
    $self->uid_mode($save_uid_mode);

    if ($ok) {
        my %ret = map {
            $_->[0] =~ /^\*\s+(\d+)\s+FETCH\s*\(\s*UID\s+(\d+)/
              && ( $1, $2 );
        } @$lines;
        return \%ret;
    }
    return undef;
}

{ my %no_args = map{ $_, 1} qw(
	ALL
	ANSWERED
	DELETED
	DRAFT
	FLAGGED
	NEW
	OLD
	RECENT
	SEEN
	UNANSWERED
	UNDELETED
	UNDRAFT
	UNFLAGGED
	UNSEEN
	);
sub search {
    my ($self, $criteria, $sort, $charset) = @_;

    $charset ||= 'UTF-8';

    my $cmd = $sort ? 'SORT' : 'SEARCH';
    if ($sort) {
        if (ref($sort) eq 'ARRAY') {
            $sort = uc '(' . join(' ', @$sort) . ')';
        } elsif ($sort !~ /^\(/) {
            $sort = uc "($sort)";
        }
        $sort =~ s/\s*$/ /;
        $sort =~ s/\^/REVERSE /g;
    } else {
        $charset = "CHARSET $charset";
        $sort = '';
    }

    if (ref($criteria) eq 'HASH') {
        my @a;
        while (my ($key, $val) = each %$criteria) {
            $key = uc $key;
            push @a, $key;
            next if $no_args{$key};
            # don't quote range
            my $quoted = $val;
            _string_quote($quoted) unless $key eq 'UID';
            push @a, $quoted;
        }
        $criteria = '(' . join(' ', @a) . ')';
    }

    my ($ok, $lines) = $self->_tell_imap($cmd => "$sort$charset $criteria", 1);
    if ($ok) {
        # it makes no sense to employ the full token parser here
        # read past progress messages lacking initial '*'
		foreach my $line (@{$lines->[0]}) {
			if ($line =~ s/^\*\s+(?:SEARCH|SORT)\s+//ig) {
				$line =~ s/\s*$//g;
				return [ map { $_ + 0 } split(/\s+/, $line) ];
			}
		}
    }

    return undef;
}
}

sub get_rfc822_body {
    my ($self, $msg) = @_;
    my $wants_many = undef;
    if (ref($msg) eq 'ARRAY') {
        $msg = join(',', @$msg);
        $wants_many = 1;
    }
    my ($ok, $lines) = $self->_tell_imap(FETCH => "$msg RFC822", 1);
    if ($ok) {
        my @ret = map { $_->[1] } @$lines;
        return $wants_many ? \@ret : $ret[0];
    }
    return undef;
}

sub get_part_body {
    my ($self, $msg, $part) = @_;
    $part = "BODY[$part]";
    my ($ok, $lines) = $self->_tell_imap(FETCH => "$msg $part", 1);
    if ($ok) {
        # it can contain FLAGS notification, i.e. \Seen flag becomes set
        my $tokens = _parse_tokens($lines->[0], 1);
        my %hash = @{$tokens->[3]};
        if ($hash{FLAGS}) {
            $self->_handle_notification($tokens);
        }
        return $hash{$part};
    }
    return undef;
}

sub get_parts_bodies {
    my ($self, $msg, $parts) = @_;
    my $tmp = join(' ', map { "BODY[$_]" } @$parts);
    my ($ok, $lines) = $self->_tell_imap(FETCH => "$msg ($tmp)", 1);
    if ($ok) {
        # it can contain FLAGS notification, i.e. \Seen flag becomes set
        my $tokens = _parse_tokens($lines->[0], 1);
        my %hash = @{$tokens->[3]};
        if ($hash{FLAGS}) {
            $self->_handle_notification($tokens);
        }
        my %ret = map {( $_, $hash{"BODY[$_]"} )} @$parts;
        return \%ret;
    }
    return undef;
}

sub get_summaries {
    my ($self, $msg, $headers) = @_;
    if (!$msg) {
        $msg = '1:*';
    } elsif (ref $msg eq 'ARRAY') {
        $msg = join(',', @$msg);
    }
    if ($headers) {
        $headers = " BODY.PEEK[HEADER.FIELDS ($headers)]";
    } else {
        $headers = '';
    }
    my ($ok, $lp) = $self->_tell_imap(FETCH => qq[$msg (UID FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODYSTRUCTURE$headers)], 1);
    if ($ok) {
        my @ret;
        foreach (@$lp) {
            my $summary;
            my $tokens = _parse_tokens($_); ## in form: [ '*', ID, 'FETCH', [ tokens ]]
            if ($tokens->[2] eq 'FETCH') {
                my %hash = @{$tokens->[3]};
                if ($hash{ENVELOPE}) {
                    # full fetch
                    $summary = Net::IMAP::Client::MsgSummary->new(\%hash, undef, !!$headers);
                    $summary->{seq_id} = $tokens->[1];
                } else {
                    # 'FETCH' (probably FLAGS) notification!
                    $self->_handle_notification($tokens);
                }
            } else {
                # notification!
                $self->_handle_notification($tokens);
            }
            push @ret, $summary
              if $summary;
        }
        return \@ret;
    } else {
        return undef;
    }
}

sub fetch {
    my ($self, $msg, $keys) = @_;
    my $wants_many = undef;
    if (ref $msg eq 'ARRAY') {
        $msg = join(',', @$msg);
        $wants_many = 1;
    }
    if (ref $keys eq 'ARRAY') {
        $keys = join(' ', @$keys);
    }
    my ($ok, $lp) = $self->_tell_imap(FETCH => qq[$msg ($keys)], 1);
    if ($ok) {
        my @ret;
        foreach (@$lp) {
            my $tokens = _parse_tokens($_)->[3];
            push @ret, { @$tokens };
        }
        return $wants_many || @ret > 1 ? \@ret : $ret[0];
    }
}

sub create_folder {
    my ($self, $folder) = @_;
    my $quoted = $folder;
    _string_quote($quoted);
    my ($ok) = $self->_tell_imap(CREATE => $quoted);
    return $ok;
}

# recursively removes any subfolders!
sub delete_folder {
    my ($self, $folder) = @_;
    my $quoted = $folder . $self->separator . '*';
    _string_quote($quoted);
    my ($ok, $lines) = $self->_tell_imap(LIST => qq{"" $quoted});
    if ($ok) {
        my @subfolders;
        foreach my $line (@$lines) {
            my $tokens = _parse_tokens($line);
            push @subfolders, $tokens->[4];
        }
        @subfolders = sort { length($b) - length($a) } @subfolders;
        foreach (@subfolders) {
            _string_quote($_);
            ($ok) = $self->_tell_imap(DELETE => $_);
        }
        $quoted = $folder;
        _string_quote($quoted);
        ($ok) = $self->_tell_imap(DELETE => $quoted);
    }
    return $ok;
}

sub append {
    my ($self, $folder, $rfc822, $flags, $date) = @_;
    die 'message body passed to append() must be a SCALAR reference'
        unless ref $rfc822 eq 'SCALAR';
    my $quoted = $folder;
    _string_quote($quoted);
    my $args = [ "$quoted " ];
    if ($flags) {
        # my @tmp = @$flags;
        # $quoted = join(' ', map { _string_quote($_) } @tmp);
        # push @$args, "($quoted) ";
        push @$args, '(' . join(' ', @$flags) . ') ';
    }
    if ($date) {
        my $tmp = $date;
        _string_quote($tmp);
        push @$args, "$tmp ";
    }
    push @$args, $rfc822;
    my ($ok) = $self->_tell_imap(APPEND => $args, 1);
    return $ok;
}

sub copy {
    my ($self, $msg, $folder) = @_;
    my $quoted = $folder;
    _string_quote($quoted);
    if (ref $msg eq 'ARRAY') {
        $msg = join(',', @$msg);
    }
    my ($ok) = $self->_tell_imap(COPY => "$msg $quoted", 1);
    return $ok;
}

sub get_flags {
    my ($self, $msg) = @_;
    my $wants_many = undef;
    if (ref($msg) eq 'ARRAY') {
        $msg = join(',', @$msg);
        $wants_many = 1;
    }
    my ($ok, $lines) = $self->_tell_imap(FETCH => "$msg (UID FLAGS)", 1);
    if ($ok) {
        my %ret = map {
            my $tokens = _parse_tokens($_)->[3];
            my %hash = @$tokens;
            $hash{UID} => $hash{FLAGS};
        } @$lines;
        return $wants_many ? \%ret : $ret{$msg};
    }
    return undef;
}

sub get_threads {
    my ($self, $algo, $msg) = @_;
    $algo ||= "REFERENCES";
    my ($ok, $lines) = $self->_tell_imap(THREAD => "$algo UTF-8 ALL");
    if ($ok) {
        my $result = $lines->[0][0];
        $result =~ s/^\*\s+THREAD\s+//;
        my $parsed = _parse_tokens([ $result ]);
        if ($msg) {
            (my $left = $result) =~ s/\b$msg\b.*$//;
            my $thr = 0;
            my $par = 0;
            for (my $i = 0; $i < length($left); ++$i) {
                my $c = substr($left, $i, 1);
                if ($c eq '(') {
                    $par++;
                } elsif ($c eq ')') {
                    $par--;
                    if ($par == 0) {
                        $thr++;
                    }
                }
            }
            $parsed = $parsed->[$thr];
        }
        return $parsed;
    }
    return $ok;
}

sub _store_helper {
    my ($self, $msg, $flags, $cmd) = @_;
    if (ref $msg eq 'ARRAY') {
        $msg = join(',', @$msg);
    }
    unless (ref $flags) {
        $flags = [ $flags ];
    }
    $flags = '(' . join(' ', @$flags) . ')';
    $self->_tell_imap(STORE => "$msg $cmd $flags", 1);
}

sub store {
    my ($self, $msg, $flags) = @_;
    $self->_store_helper($msg, $flags, 'FLAGS');
}

sub add_flags {
    my ($self, $msg, $flags) = @_;
    $self->_store_helper($msg, $flags, '+FLAGS');
}

sub del_flags {
    my ($self, $msg, $flags) = @_;
    $self->_store_helper($msg, $flags, '-FLAGS');
}

sub delete_message {
    my ($self, $msg) = @_;
    $self->add_flags($msg, '\\Deleted');
}

sub expunge {
    my ($self) = @_;
    my ($ok, $lines) = $self->_tell_imap('EXPUNGE' => undef, 1);
    if ($ok && $lines && @$lines) {
        my $ret = $lines->[0][0];
        if ($ret =~ /^\*\s+(\d+)\s+EXPUNGE/) {
            return $1 + 0;
        }
    }
    return $ok ? -1 : undef;
}

sub last_error {
    my ($self) = @_;
	defined $self->{_error} or return;
    $self->{_error} =~ s/\s+$//s; # remove trailing carriage return
    return $self->{_error};
}

sub notifications {
    my ($self) = @_;
    my $tmp = $self->{notifications};
    $self->{notifications} = [];
    return wantarray ? @$tmp : $tmp;
}

##### internal stuff #####

sub _get_port {
    my ($self) = @_;
    return $self->{port} || ($self->{ssl} ? 993 : 143);
}

sub _get_timeout {
    my ($self) = @_;
    return $self->{timeout} || 90;
}

sub _get_server {
    my ($self) = @_;
    return $self->{server};
}

sub _get_ssl_config {
    my ($self) = @_;
    if (!$self->{ssl_verify_peer}
         || !$self->{ssl_ca_path}
         && !$self->{ssl_ca_file}
         && $^O ne 'linux') {
        return SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE;
    }

    my %ssl_config = ( SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER );

    if ($^O eq 'linux' && !$self->{ssl_ca_path} && !$self->{ssl_ca_file}) {
        $ssl_config{SSL_ca_path} =
			-d '/etc/ssl/certs/' ? '/etc/ssl/certs/' : '/etc/pki/tls/certs/';

		-d $ssl_config{SSL_ca_path}
			or die "$ssl_config{SSL_ca_path}: SSL certification directory not found";
    }
    $ssl_config{SSL_ca_path} = $self->{ssl_ca_path} if $self->{ssl_ca_path};
    $ssl_config{SSL_ca_file} = $self->{ssl_ca_file} if $self->{ssl_ca_file};

    return %ssl_config;
}
sub _get_socket {
    my ($self) = @_;

    my $socket = $self->{socket};
    return $socket if (defined($socket) and ($socket->isa('IO::Socket::SSL')or $socket->isa('IO::Socket::INET')));

    $self->{socket} = ($self->{ssl} ? 'IO::Socket::SSL' : 'IO::Socket::INET')->new(
			( ( %{$self->{ssl_options}} ) x !!$self->{ssl} ),
                PeerAddr => $self->_get_server,
                PeerPort => $self->_get_port,
                Timeout  => $self->_get_timeout,
                Proto    => 'tcp',
                Blocking => 1,
                $self->_get_ssl_config,
            ) or die "failed connect or ssl handshake: $!,$IO::Socket::SSL::SSL_ERROR";
    $self->{socket}->sockopt(SO_KEEPALIVE, 1);

    $self->{greeting} = $self->_socket_getline; # get the initial greeting

    $self->_starttls if ($self->{tls});         # upgrade to TLS if needed

    return $self->{socket};
}

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

    # ask for the capabilities directly at this level, make sure we can do STARTTLS
    my $can_do_starttls = 0;
    my ($ok, $lines) = $self->_tell_imap('CAPABILITY');
    if ($ok) {
        my $line = $lines->[0][0];
        $can_do_starttls ||= 1 if ($line =~ /^\*\s+CAPABILITY.*\s+STARTTLS/);
    } else {
        die "IMAP server failed CAPABILITY query"
    }
    die "IMAP server does not have STARTTLS capability" unless ($can_do_starttls);

    # request STARTTLS
    ($ok, $lines) = $self->_tell_imap('STARTTLS');
    if ($ok) {
        my @sni_args;
        push(@sni_args, SSL_hostname => $self->_get_server) if (IO::Socket::SSL->can_client_sni());
        IO::Socket::SSL->start_SSL(
            $self->{socket},
            $self->_get_ssl_config,
            @sni_args,
        ) or die $IO::Socket::SSL::SSL_ERROR;
    } else {
        die "IMAP server failed STARTTLS command"
    }

    return $self->{socket};
}

sub _get_next_id {
    return ++$_[0]->{_cmd_id};
}

sub _socket_getline {
    local $/ = "\r\n";
    return $_[0]->_get_socket->getline;
}

sub _socket_write {
    my $self = shift;
    # open LOG, '>>:raw', '/tmp/net-imap-client.log';
    # print LOG @_;
    # close LOG;
    $self->_get_socket->write(@_);
}

sub _send_cmd {
    my ($self, $cmd, $args) = @_;

    local $\;
    use bytes;
    my $id   = $self->_get_next_id;
    if ($self->uid_mode && exists($UID_COMMANDS{$cmd})) {
        $cmd = "UID $cmd";
    }
    my @literals = ();
    if (ref $args eq 'ARRAY') {
        # may contain literals
        foreach (@$args) {
            if (ref $_ eq 'SCALAR') {
                push @literals, $_;
                $_ = '{' . length($$_) . "}\r\n";
            }
        }
        $args = join('', @$args);
    }
    my $socket = $self->_get_socket;
    if (@literals == 0) {
        $cmd = "NIC$id $cmd" . ($args ? " $args" : '') . "\r\n";
        $self->_socket_write($cmd);
    } else {
        $cmd = "NIC$id $cmd ";
        $self->_socket_write($cmd);
        my @split = split(/\r\n/, $args);

        my $ea = each_array(@split, @literals);
        while (my ($tmp, $lit) = $ea->()) {
            $self->_socket_write($tmp . "\r\n");
            my $line = $self->_socket_getline;
            # print STDERR "$line - $tmp\n";
            if ($line =~ /^\+/) {
                $self->_socket_write($$lit);
            } else {
                $self->{_error} = "Expected continuation, got: $line";
                # XXX: it's really bad if we get here, what to do?
                return undef;
            }
        }
        $self->_socket_write("\r\n"); # end of command!
    }
    $socket->flush;
    return "NIC$id";
}

sub _read_literal {
    my ($self, $count) = @_;

    my $buf;
    my @lines = ();
    my $sock = $self->_get_socket;
    # print STDERR "\033[1;31m ::: Reading $count bytes ::: \033[0m \n";
    while ($count > 0) {
        my $read = $sock->read($buf, min($count, $READ_BUFFER));
        # print STDERR "GOT $read / $buf";
        $count -= $read;
        last if !$read;
        push @lines, $buf;
    }

    $buf = join('', @lines);
    return \$buf;
}

sub _cmd_ok {
    my ($self, $res, $id) = @_;
    $id ||= $self->{_cmd_id};

    if ($res =~ /^NIC$id\s+OK/i) {
        return 1;
    } elsif ($res =~ /^NIC$id\s+(?:NO|BAD)(?:\s+(.+))?/i) {
        my $error = $1 || 'unknown error';
        $self->{_error} = $error;
        return 0;
    }
    return undef;
}

sub _cmd_ok2 {
    my ($self, $res) = @_;

    if ($res =~ /^(NIC\d+)\s+OK/i) {
        my $id = $1;
        return ($id, 1);
    } elsif ($res =~ /^(NIC\d+)\s+(?:NO|BAD)(?:\s+(.+))?/i) {
        my $id = $1;
        my $error = $2 || 'unknown error';
        $self->{_error} = $error;
        return ($id, 0, $error);
    }
    return ();
}

sub _reconnect_if_needed {
    my ($self, $force) = @_;
    if ($force || !$self->_get_socket->connected) {
        $self->{socket} = undef;
        $self->{greeting} = $self->_socket_getline;
        if ($self->login) {
            if ($self->{selected_folder}) {
                $self->select($self->{selected_folder});
            }
            return 1;
        }
        return undef;
    }
    return 0;
}

sub _tell_imap {
    my ($self, $cmd, $args, $do_notf) = @_;

    $cmd = uc $cmd;

    my ($lineparts, $ok, $res);

  RETRY1: {
        $self->_send_cmd($cmd, $args);
        redo RETRY1 if $self->_reconnect_if_needed;
    }

    $lineparts = [];      # holds results in boxes
    my $accumulator = []; # box for collecting results
    while ($res = $self->_socket_getline) {
        # print STDERR ">>>>$res<<<<<\n";

        if ($res =~ /^\*/) {

            # store previous box and start a new one

            push @$lineparts, $accumulator if @$accumulator;
            $accumulator = [];
        }
        if ($res =~ /(.*)\{(\d+)\}\r\n/) {
            my ($line, $len) = ($1, $2 + 0);
            push @$accumulator,
              $line,
                $self->_read_literal($len);
        } else {
            $ok = $self->_cmd_ok($res);
            if (defined($ok)) {
                last;
            } else {
                push @$accumulator, $res;
            }
        }
    }
    # store last box
    push @$lineparts, $accumulator if @$accumulator;

    unless (defined $res) {
        goto RETRY1 if $self->_reconnect_if_needed(1);
    }

    if ($do_notf) {
        no warnings 'uninitialized';
        for (my $i = scalar(@$lineparts); --$i >= 0;) {
            my $line = $lineparts->[$i];

            # 1. notifications don't contain literals
            last if scalar(@$line) != 1;

            my $text = $line->[0];

            # 2. FETCH notifications only contain FLAGS.  We make a
            #    promise never to FETCH flags alone intentionally.

            # 3. Other notifications will have a first token different
            #    from the running command

            if ( $text =~ /^\*\s+\d+\s+FETCH\s*\(\s*FLAGS\s*\([^\)]*?\)\)/
                   || $text !~ /^\*\s+(?:\d+\s+)?$cmd/ ) {
                my $tokens = _parse_tokens($line);
                if ($self->_handle_notification($tokens, 1)) {
                    splice @$lineparts, $i, 1;
                }
                next;
            }

            last;
        }
    }

    return wantarray ? ($ok, $lineparts) : $ok ? $lineparts : undef;
}

# Variant of the above method that sends multiple commands.  After
# sending all commands to the server, it waits until all results are
# returned and puts them in an array, in the order the commands were
# sent.
sub _tell_imap2 {
    my ($self, @cmd) = @_;

    my %results;
    my @ids;

  RETRY2: {
        @ids = ();
        foreach (@cmd) {
            push @ids, $self->_send_cmd($_);
            redo RETRY2 if $self->_reconnect_if_needed;
        }
    }

    %results = ();
    for (0..$#cmd) {
        my $lineparts = [];
        my $accumulator = [];
        my $res;
        while ($res = $self->_socket_getline) {
            # print STDERR "2: $res";
            if ($res =~ /^\*/) {
                push @$lineparts, $accumulator if @$accumulator;
                $accumulator = [];
            }
            if ($res =~ /(.*)\{(\d+)\}\r\n/) {
                my ($line, $len) = ($1, $2);
                push @$accumulator,
                  $line,
                    $self->_read_literal($len);
            } else {
                my ($cmdid, $ok, $error) = $self->_cmd_ok2($res);
                if (defined($ok)) {
                    $results{$cmdid} = [ $ok, $lineparts, $error ];
                    last;
                } else {
                    push @$accumulator, $res;
                }
            }
        }
        push @$lineparts, $accumulator if @$accumulator;
        unless (defined $res) {
            goto RETRY2 if $self->_reconnect_if_needed(1);
        }
    }

    my @ret = @results{@ids};
    return \@ret;
}

sub _string_quote {
    $_[0] =~ s/\\/\\\\/g;
    $_[0] =~ s/\"/\\\"/g;
    $_[0] = "\"$_[0]\"";
}

sub _string_unquote {
    if ($_[0] =~ s/^"//g) {
        $_[0] =~ s/"$//g;
        $_[0] =~ s/\\\"/\"/g;
        $_[0] =~ s/\\\\/\\/g;
    }
}

##### parse imap response #####
#
# This is probably the simplest/dumbest way to parse the IMAP output.
# Nevertheless it seems to be very stable and fast.
#
# $input is an array ref containing IMAP output.  Normally it will
# contain only one entry -- a line of text -- but when IMAP sends
# literal data, we read it separately (see _read_literal) and store it
# as a scalar reference, therefore it can be like this:
#
#    [ '* 11 FETCH (RFC822.TEXT ', \$DATA, ')' ]
#
# so that's why the routine looks a bit more complicated.
#
# It returns an array of tokens.  Literal strings are dereferenced so
# for the above text, the output will be:
#
#    [ '*', '11', 'FETCH', [ 'RFC822.TEXT', $DATA ] ]
#
# note that lists are represented as arrays.
#
sub _parse_tokens {
    my ($input, $no_deref) = @_;

    my @tokens = ();
    my @stack = (\@tokens);

    while (my $text = shift @$input) {
        if (ref $text) {
            push @{$stack[-1]}, ($no_deref ? $text : $$text);
            next;
        }
        while (1) {
            $text =~ m/\G\s+/gc;
            if ($text =~ m/\G[([]/gc) {
                my $sub = [];
                push @{$stack[-1]}, $sub;
                push @stack, $sub;
            } elsif ($text =~ m/\G(BODY\[[a-zA-Z0-9._() -]*\])/gc) {
                push @{$stack[-1]}, $1; # let's consider this an atom too
            } elsif ($text =~ m/\G[])]/gc) {
                pop @stack;
            } elsif ($text =~ m/\G\"((?:\\.|[^\"\\])*)\"/gc) {
                my $str = $1;
                # unescape
                $str =~ s/\\\"/\"/g;
                $str =~ s/\\\\/\\/g;
                push @{$stack[-1]}, $str; # found string
            } elsif ($text =~ m/\G(\d+)/gc) {
                push @{$stack[-1]}, $1 + 0; # found numeric
            } elsif ($text =~ m/\G([a-zA-Z0-9_\$\\.+\/*&-]+)/gc) {
                my $atom = $1;
                if (lc $atom eq 'nil') {
                    $atom = undef;
                }
                push @{$stack[-1]}, $atom; # found atom
            } else {
                last;
            }
        }
    }

    return \@tokens;
}

sub _handle_notification {
    my ($self, $tokens, $reverse) = @_;

    no warnings 'uninitialized';
    my $not;

    my $sf = $self->{selected_folder};
    if ($sf) { # otherwise we shouldn't get any notifications, but whatever
        $sf = $self->{FOLDERS}{$sf};
        if ($tokens->[2] eq 'FETCH') {
            my %data = @{$tokens->[3]};
            if (my $flags = $data{FLAGS}) {
                $not = { seq   => $tokens->[1] + 0,
                         flags => $flags };
                if (first { $_ eq '\\Deleted' } @$flags) {
                    --$sf->{messages};
                    $not->{deleted} = 1;
                }
                if ($data{UID}) {
                    $not->{uid} = $data{UID};
                }
            }

        } elsif ($tokens->[2] eq 'EXISTS') {
            $sf->{messages} = $tokens->[1] + 0;
            $not = { messages => $tokens->[1] + 0 };

        } elsif ($tokens->[2] eq 'EXPUNGE') {
            --$sf->{messages};
            $not = { seq => $tokens->[1] + 0, destroyed => 1 };

        } elsif ($tokens->[2] eq 'RECENT') {
            $sf->{recent} = $tokens->[1] + 0;
            $not = { recent => $tokens->[1] + 0 };

        } elsif ($tokens->[1] eq 'FLAGS') {
            $sf->{flags} = $tokens->[2];
            $not = { flags => $tokens->[2] };

        } elsif ($tokens->[1] eq 'OK') {
            $sf->{sflags}{$tokens->[2][0]} = $tokens->[2][1];
        }
    }

    if (defined $not) {
        $not->{folder} = $self->{selected_folder};
        if ($reverse) {
            unshift @{$self->{notifications}}, $not;
        } else {
            push @{$self->{notifications}}, $not;
        }
        return 1;
    }

    return 0;
}

1;

__END__