view release on metacpan or  search on metacpan

lib/Net/IMAP/Simple.pm  view on Meta::CPAN

            return Date::Manip::UnixDate($pd, '%d-%b-%Y');
        }

    } else {
        # TODO: complain if the date isn't %d-%m-%Y

        # I'm not sure there's anything to be gained by doing so ...  They'll
        # just get an imap error they can choose to handle.
    }

    return $d;
}

sub _process_qstring {
    my $t = shift;
       $t =~ s/\\/\\\\/g;
       $t =~ s/"/\\"/g;

    return "\"$t\"";
}

sub search_before      { my $self = shift; my $d = _process_date(shift); return $self->search("BEFORE $d"); }
sub search_since       { my $self = shift; my $d = _process_date(shift); return $self->search("SINCE $d"); }
sub search_sent_before { my $self = shift; my $d = _process_date(shift); return $self->search("SENTBEFORE $d"); }
sub search_sent_since  { my $self = shift; my $d = _process_date(shift); return $self->search("SENTSINCE $d"); }

sub search_from    { my $self = shift; my $t = _process_qstring(shift); return $self->search("FROM $t"); }
sub search_to      { my $self = shift; my $t = _process_qstring(shift); return $self->search("TO $t"); }
sub search_cc      { my $self = shift; my $t = _process_qstring(shift); return $self->search("CC $t"); }
sub search_bcc     { my $self = shift; my $t = _process_qstring(shift); return $self->search("BCC $t"); }
sub search_subject { my $self = shift; my $t = _process_qstring(shift); return $self->search("SUBJECT $t"); }
sub search_body    { my $self = shift; my $t = _process_qstring(shift); return $self->search("BODY $t"); }

sub get {
    my ( $self, $number, $part ) = @_;
    my $arg = $part ? "BODY[$part]" : 'RFC822';

    return $self->fetch( $number, $arg );
}

sub fetch {
    my ( $self, $number, $part ) = @_;
    my $arg = $part || 'RFC822';

    my @lines;
    my $fetching;

    return $self->_process_cmd(
        cmd => [ FETCH => qq[$number $arg] ],
        final => sub {
            if( $fetching ) {
                if( $fetching > 0 ) {
                    # XXX: this is just about the least efficient way in the
                    # world to do this; I should appologize, but really,
                    # nothing in this module is done particularly well.  I
                    # doubt anyone will notice this.

                    local $"="";
                    my $message = "@lines";
                    @lines = split m/(?<=\x0d\x0a)/, substr($message, 0, $fetching)
                        if( length $message > $fetching );
                }
                return  wantarray ? @lines : Net::IMAP::Simple::_message->new(\@lines)
            }

            if( defined $fetching and $fetching == 0 ) {
                return "\n"; # XXX: Your 0 byte message is incorrectly returned as a newline.  Meh.
            }

            # NOTE: There is not supposed to be an error if you ask for a
            # message that's not there, but this is a rather confusing
            # notion … so we generate an error here.

            $self->{_errstr} = "message not found";
            return;
        },
        process => sub {
            if ( $_[0] =~ /^\*\s+\d+\s+FETCH\s+\(.+?\{(\d+)\}/ ) {
                $fetching = $1;

            } elsif( $_[0] =~ /^\*\s+\d+\s+FETCH\s+\(.+?\"(.*)\"\s*\)/ ) {
                # XXX: this is not tested because Net::IMAP::Server doesn't do
                # this type of string result (that I know of) for this it might
                # work, ... frog knows.  Not likely to come up very often, if
                # ever; although you do sometimes see the occasional 0byte
                # message.  Valid really.

                $fetching = -1;
                @lines = ($1);

            } elsif( $fetching ) {
                push @lines, join( ' ', @_ );
            }
        },
    );

}

sub _process_flags {
    my $self = shift;
    my @ret = map { split m/\s+/, $_ } grep { $_ } @_;

    return @ret;
}

sub put {
    my ( $self, $mailbox_name, $msg, @flags ) = @_;

    croak "usage: \$imap->put(mailbox, message, \@flags)" unless defined $msg and defined $mailbox_name;

    my $size = length $msg;
    if ( ref $msg eq "ARRAY" ) {
        $size = 0;
        $size += length $_ for @$msg;
    }

    @flags = $self->_process_flags(@flags);

    return $self->_process_cmd(
        cmd   => [ APPEND => _escape($mailbox_name) ." (@flags) {$size}" ],
        final => sub { $self->_clear_cache; 1 },
        process => sub {
            if( $_[0] =~ m/^\+\s+/ ) { # + continue (or go ahead, or whatever)
                if ($size) {
                    my $sock = $self->_sock;
                    if ( ref $msg eq "ARRAY" ) {
                        print $sock $_ for @$msg;

                    } else {
                        print $sock $msg;
                    }
                    $size = undef;
                    print $sock "\r\n";
                }
            }
        },

    );
}

# This supports supplying a date per IMAP RFC 3501
# APPEND Command - Section 6.3.11
# Implemented here as a new method so when calling the put above
# older code will not break
sub put_with_date {
    my ( $self, $mailbox_name, $msg, $date, @flags ) = @_;

    croak "usage: \$imap->put_with_date(mailbox, message, date, \@flags)" unless defined $msg and defined $mailbox_name;

    my $size = length $msg;
    if ( ref $msg eq "ARRAY" ) {
        $size = 0;
        $size += length $_ for @$msg;
    }

    @flags = $self->_process_flags(@flags);

    my $cmd_str = _escape($mailbox_name) . " (@flags)";
    $cmd_str .= " " . _escape($date) if $date ne "";
    $cmd_str .= " {$size}";