r44657 - in /branches/upstream/libmail-imapclient-perl/current: Changes MANIFEST META.yml lib/Mail/IMAPClient.pm lib/Mail/IMAPClient.pod lib/Mail/IMAPClient/BodyStructure.pm t/fetch_hash.t
carnil-guest at users.alioth.debian.org
carnil-guest at users.alioth.debian.org
Wed Sep 23 04:15:25 UTC 2009
Author: carnil-guest
Date: Wed Sep 23 04:14:32 2009
New Revision: 44657
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=44657
Log:
[svn-upgrade] Integrating new upstream version, libmail-imapclient-perl (3.21)
Added:
branches/upstream/libmail-imapclient-perl/current/t/fetch_hash.t
Modified:
branches/upstream/libmail-imapclient-perl/current/Changes
branches/upstream/libmail-imapclient-perl/current/MANIFEST
branches/upstream/libmail-imapclient-perl/current/META.yml
branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pm
branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pod
branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient/BodyStructure.pm
Modified: branches/upstream/libmail-imapclient-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmail-imapclient-perl/current/Changes?rev=44657&op=diff
==============================================================================
--- branches/upstream/libmail-imapclient-perl/current/Changes (original)
+++ branches/upstream/libmail-imapclient-perl/current/Changes Wed Sep 23 04:14:32 2009
@@ -4,6 +4,18 @@
Changes from 2.99_01 to 3.16 made by Mark Overmeer
Changes from 0.09 to 2.99_01 made by David Kernen
- Potential compatibility issues from 3.17+ highlighted with '*'
+
+version 3.21: Tue Sep 22 19:45:13 EDT 2009
+ - rt.cpan.org#49691: rewrite of fetch_hash to resolve several issues
+ [Robert Norris]
+ includes new tests via t/fetch_hash.t
+ - rt.cpan.org#48980: (enhancement) add support for XLIST extension
+ [Robert Norris]
+ - rt.cpan.org#49024: NIL personal name returned by *_addresses methods
+ [Dmitry Bigunyak]
+ - rt.cpan.org#49401: IMAPClient expunge fails (unless folder arg used)
+ [Gary Baluha]
+ - update/clarify close and expunge documentation a little
version 3.20: Fri Aug 21 17:40:40 EDT 2009
- added file/tests in t/simple.t
Modified: branches/upstream/libmail-imapclient-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmail-imapclient-perl/current/MANIFEST?rev=44657&op=diff
==============================================================================
--- branches/upstream/libmail-imapclient-perl/current/MANIFEST (original)
+++ branches/upstream/libmail-imapclient-perl/current/MANIFEST Wed Sep 23 04:14:32 2009
@@ -32,6 +32,7 @@
sample.perldb
t/basic.t
t/bodystructure.t
+t/fetch_hash.t
t/messageset.t
t/pod.t
t/simple.t
Modified: branches/upstream/libmail-imapclient-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmail-imapclient-perl/current/META.yml?rev=44657&op=diff
==============================================================================
--- branches/upstream/libmail-imapclient-perl/current/META.yml (original)
+++ branches/upstream/libmail-imapclient-perl/current/META.yml Wed Sep 23 04:14:32 2009
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Mail-IMAPClient
-version: 3.20
+version: 3.21
version_from: lib/Mail/IMAPClient.pm
installdirs: site
requires:
Modified: branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pm?rev=44657&op=diff
==============================================================================
--- branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pm (original)
+++ branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pm Wed Sep 23 04:14:32 2009
@@ -5,7 +5,7 @@
use warnings;
package Mail::IMAPClient;
-our $VERSION = '3.20';
+our $VERSION = '3.21';
use Mail::IMAPClient::MessageSet;
@@ -140,8 +140,8 @@
sub Rfc822_date {
my $class = shift;
- my $date = $class =~ /^\d+$/ ? $class : shift; # method or function?
- my @date = gmtime($date);
+ my $date = $class =~ /^\d+$/ ? $class : shift; # method or function?
+ my @date = gmtime($date);
#Date: Fri, 09 Jul 1999 13:10:55 -0000
sprintf(
@@ -159,6 +159,7 @@
sub Rfc2060_date {
$_[0] =~ /^\d+$/ ? Rfc3501_date(@_) : shift->Rfc3501_date(@_);
}
+
sub Rfc3501_date {
my $class = shift;
my $stamp = $class =~ /^\d+$/ ? $class : shift;
@@ -171,6 +172,7 @@
sub Rfc2060_datetime($;$) {
$_[0] =~ /^\d+$/ ? Rfc3501_datetime(@_) : shift->Rfc3501_datetime(@_);
}
+
sub Rfc3501_datetime($;$) {
my $class = shift;
my $stamp = $class =~ /^\d+$/ ? $class : shift;
@@ -477,6 +479,12 @@
sub list { shift->_list_or_lsub( "LIST", @_ ) }
sub lsub { shift->_list_or_lsub( "LSUB", @_ ) }
+sub xlist {
+ my ($self) = @_;
+ return undef unless $self->has_capability("XLIST");
+ shift->_list_or_lsub( "XLIST", @_ );
+}
+
sub _folders_or_subscribed {
my ( $self, $method, $what ) = @_;
my @folders;
@@ -529,6 +537,25 @@
my @folders = $self->_folders_or_subscribed( "list", $what );
$self->{Folders} = \@folders unless $what;
return wantarray ? @folders : \@folders;
+}
+
+sub xlist_folders {
+ my ($self) = @_;
+ my $xlist = $self->xlist;
+ return undef unless defined $xlist;
+
+ my %xlist;
+ my $xlist_re = qr/\A\\(Inbox|AllMail|Trash|Drafts|Sent|Spam|Starred)\Z/;
+
+ for my $resp (@$xlist) {
+ my $rec = $self->_list_or_lsub_response_parse($resp);
+ next unless defined $rec->{name};
+ for my $attr ( @{ $rec->{attrs} } ) {
+ $xlist{$1} = $rec->{name} if ( $attr =~ $xlist_re );
+ }
+ }
+
+ return wantarray ? %xlist : \%xlist;
}
sub subscribed {
@@ -1337,7 +1364,7 @@
if ($code) {
$code = uc($code) unless ( $good and $code eq $good );
- # on a successful LOGOUT $code is OK not BYE
+ # on successful LOGOUT $code is OK (not BYE!) see RFC 3501 sect 7.1.5
if ( $code eq 'BYE' ) {
$self->State(Unconnected);
$self->LastError($byemsg) if $byemsg;
@@ -1771,7 +1798,7 @@
$self;
}
-# LIST or LSUB Response
+# LIST/XLIST/LSUB Response
# Contents: name attributes, hierarchy delimiter, name
# Example: * LIST (\Noselect) "/" ~/Mail/foo
# NOTE: in _list_response_preprocess we append literal data so we need
@@ -1784,10 +1811,10 @@
$resp =~ s/\015?\012$//;
if (
- $resp =~ / ^\* \s+ (?:LIST|LSUB) \s+ # * LIST or LSUB
- \( ([^\)]*) \) \s+ # (attrs)
- (?: \" ([^"]*) \" | NIL ) \s # "delimiter" or NIL
- (?:\s*\" (.*) \" | (.*) ) # "name" or name
+ $resp =~ / ^\* \s+ (?:LIST|XLIST|LSUB) \s+ # * LIST|XLIST|LSUB
+ \( ([^\)]*) \) \s+ # (attrs)
+ (?: \" ([^"]*) \" | NIL ) \s # "delimiter" or NIL
+ (?:\s*\" (.*) \" | (.*) ) # "name" or name
/ix
)
{
@@ -2015,55 +2042,84 @@
s/([\( ])FAST([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE$2/i;
s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i;
}
+ my %words = map { uc($_) => 1 } @words;
my $output = $self->fetch( $msgs, "($what)" ) or return undef;
- for ( my $x = 0 ; $x <= $#$output ; $x++ ) {
- my $entry = {};
- my $l = $output->[$x];
+ while ( my $l = shift @$output ) {
+ next if $l !~ m/^\*\s(\d+)\sFETCH\s\(/g;
+ my ( $mid, $entry ) = ( $1, {} );
+ my ( $key, $value );
+ ATTR:
+ while ( $l !~ m/\G\s*\)\s*$/gc ) {
+ if ( $l =~ m/\G\s*([\w\d\.]+(?:\[[^\]]*\])?)\s*/gc ) {
+ $key = uc($1);
+ }
+ elsif ( !defined $key ) {
+
+ # some kind of malformed response
+ $self->LastError("Invalid item name in FETCH response: $l");
+ return undef;
+ }
+
+ if ( $l =~ m/\G\s*$/gc ) {
+ $value = shift @$output;
+ $entry->{$key} = $value;
+ $l = shift @$output;
+ next ATTR;
+ }
+ elsif ( $l =~ m/\G(?:"([^"]+)"|([^()\s]+))\s*/gc ) {
+ $value = defined $1 ? $1 : $2;
+ $entry->{$key} = $value;
+ next ATTR;
+ }
+ elsif ( $l =~ m/\G\(/gc ) {
+ my $depth = 1;
+ $value = "";
+ while ( $l =~ m/\G(\(|\)|[^()]+)/gc ) {
+ my $stuff = $1;
+ if ( $stuff eq "(" ) {
+ $depth++;
+ $value .= "(";
+ }
+ elsif ( $stuff eq ")" ) {
+ $depth--;
+ if ( $depth == 0 ) {
+ $entry->{$key} = $value;
+ next ATTR;
+ }
+ $value .= ")";
+ }
+ else {
+ $value .= $stuff;
+ }
+ }
+ m/\G\s*/gc;
+ }
+ else {
+ $self->LastError("Invalid item value in FETCH response: $l");
+ return undef;
+ }
+ }
if ( $self->Uid ) {
- my $uid = $l =~ /\bUID\s+(\d+)/i ? $1 : undef;
- $uid or next;
-
- if ( $uids->{$uid} ) { $entry = $uids->{$uid} }
- else { $uids->{$uid} ||= $entry }
+ $uids->{ $entry->{UID} } = $entry;
}
else {
- my $mid = $l =~ /^\* (\d+) FETCH/i ? $1 : undef;
- $mid or next;
-
- if ( $uids->{$mid} ) { $entry = $uids->{$mid} }
- else { $uids->{$mid} ||= $entry }
- }
-
- foreach my $w (@words) {
- if ( $l =~ /\Q$w\E\s*$/i ) {
- $entry->{$w} = $output->[ $x + 1 ];
- $entry->{$w} =~ s/(?:$CR?$LF)+$//og;
- chomp $entry->{$w};
- }
- elsif (
- $l =~ /\( # open paren followed by ...
- (?:.*\s)? # ...optional stuff and a space
- \Q$w\E\s # escaped fetch field<sp>
- (?:" # then: a dbl-quote
- (\\.| # then bslashed anychar(s) or ...
- [^"]+) # ... nonquote char(s)
- "| # then closing quote; or ...
- \( # ...an open paren
- ([^\)]*) # ... non-close-paren char(s)
- \)| # then closing paren; or ...
- (\S+)) # unquoted string
- (?:\s.*)? # possibly followed by space-stuff
- \) # close paren
- /xi
- )
- {
- $entry->{$w} = defined $1 ? $1 : defined $2 ? $2 : $3;
- }
- }
- }
+ $uids->{$mid} = $entry;
+ }
+
+ for my $word ( keys %$entry ) {
+ next if exists $words{$word};
+
+ if ( my ($stuff) = $word =~ m/^BODY(\[.*)$/ ) {
+ next if exists $words{ "BODY.PEEK" . $stuff };
+ }
+
+ delete $entry->{$word};
+ }
+ }
+
return wantarray ? %$uids : $uids;
}
@@ -2111,16 +2167,20 @@
sub expunge {
my ( $self, $folder ) = @_;
- my $old = $self->Folder || '';
- if ( defined $folder && $folder eq $old ) {
+ return undef unless ( defined $folder or defined $self->Folder );
+
+ my $old = defined $self->Folder ? $self->Folder : '';
+
+ if ( !defined($folder) || $folder eq $old ) {
$self->_imap_command('EXPUNGE')
or return undef;
}
else {
$self->select($folder) or return undef;
my $succ = $self->_imap_command('EXPUNGE');
- $self->select($old) or return undef; # BUG? this should be fatal?
- $succ or return undef;
+
+ # if $old eq '' IMAP4 select should close $folder without EXPUNGE
+ return undef unless ( $self->select($old) and $succ );
}
return wantarray ? $self->History : $self->Results;
@@ -2128,6 +2188,8 @@
sub uidexpunge {
my ( $self, $msgspec ) = ( shift, shift );
+
+ return undef unless $self->has_capability("UIDPLUS");
my $msg =
UNIVERSAL::isa( $msgspec, 'Mail::IMAPClient::MessageSet' )
Modified: branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pod
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pod?rev=44657&op=diff
==============================================================================
--- branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pod (original)
+++ branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient.pod Wed Sep 23 04:14:32 2009
@@ -754,16 +754,14 @@
$imap->close or die "Could not close: $@\n";
-The B<close> method is implemented via the default method and is used
-to close the currently selected folder via the CLOSE IMAP client
-command. According to RFC3501, the CLOSE command performs an implicit
-EXPUNGE, which means that any messages that you've flagged as
-I<\Deleted> (say, with the L</delete_message> method) will now be
-deleted. If you haven't deleted any messages then B<close> can be
-thought of as an "unselect".
-
-Note again that this closes the currently selected folder, not the
-IMAP session.
+The B<close> method is used to close the currently selected folder via
+the CLOSE IMAP client command. According to RFC3501, the CLOSE
+command performs an implicit EXPUNGE, which means that any messages
+that are flagged as I<\Deleted> (i.e. with the L</delete_message>
+method) will now be deleted. If you haven't deleted any messages then
+B<close> can be thought of as an "unselect".
+
+Note: this closes the currently selected folder, not the IMAP session.
See also L</delete_message>, L</expunge>, and RFC3501.
@@ -1063,19 +1061,14 @@
The B<expunge> method accepts one optional argument, a folder name.
It expunges the folder specified as the argument, or the currently
-selected folder if no argument is supplied.
+selected folder (if any) when no argument is supplied.
Although RFC3501 does not permit optional arguments (like a folder
-name) to the EXPUNGE client command, the L</expunge> method does,
-which is especially interesting given that the L</expunge> method
-doesn't technically exist. In case you're curious, expunging a folder
-deletes the messages that you thought were already deleted via
-L</delete_message> but really weren't, which means you have to use a
-method that doesn't exist to delete messages that you thought didn't
-exist. (Seriously, I'm not making any of this stuff up.)
-
-Or you could use the L</close> method, which deselects as well as
-expunges and which likewise doesn't technically exist.
+name) to the EXPUNGE client command, the L</expunge> method does.
+Note: expunging a folder deletes the messages that have the \Deleted
+flag set (i.e. messages flagged via L</delete_message>).
+
+See also the L</close> method, which "deselects" as well as expunges.
=head2 fetch
@@ -1168,27 +1161,12 @@
}
};
-You can specify I<BODY[HEADER.FIELDS ($fieldlist)> as an argument, but
-you should keep the following in mind if you do:
-
-B<1.> You can only specify one argument of this type per call. If you
-need multiple fields, then you'll have to call B<fetch_hashref>
-multiple times, each time specifying a different FETCH attribute but
-the same.
-
-B<2.> Fetch operations that return RFC822 message headers return the
-whole header line, including the field name and the colon. For
-example, if you do a C<$imap-E<gt>fetch_hash("BODY[HEADER.FIELDS
-(Subject)]")>, you will get back subject lines that start with
-"Subject: ".
-
-By itself this method may be useful for, say, speeding up programs
-that want the size of every message in a folder. It issues one
-command and receives one (possibly long!) response from the server.
-However, it's true power lies in the as-yet-unwritten methods that
-will rely on this method to deliver even more powerful result hashes
-(and which may even remove the restrictions mentioned in B<1> and
-B<2>, above). Look for more new function in later releases.
+By itself this method may be useful for, say, speeding up programs that
+want the size of every message in a folder. It issues one command and
+receives one (possibly long!) response from the server. However, it's
+true power lies in the as-yet-unwritten methods that will rely on this
+method to deliver even more powerful result hashes. Look for more new
+function in later releases.
This method is new with version 2.2.3 and is thus still experimental.
If you decide to try this method and run into problems, please see the
@@ -1268,6 +1246,76 @@
Notice that if you just want to list a folder's subfolders (and not
the folder itself), then you need to include the hierarchy separator
character (as returned by the L</separator> method).
+
+=head2 xlist_folders
+
+Example:
+
+ my $xlist = $imap->xlist_folders
+ or die "Could not get xlist folders.\n";
+
+IMAP servers implementing the XLIST extension (such as Gmail)
+designate particular folders to be used for particular functions.
+This is useful in the case where you want to know which folder should
+be used for Trash when the actual folder name can't be predicted
+(e.g. in the case of Gmail, the folder names change depending on the
+user's locale settings).
+
+The B<xlist_folders> method returns a hash listing any "xlist" folder
+names, with the values listing the actual folders that should be used
+for those names. For example, using this method with a Gmail user
+using the English (US) locale might give this output from
+L<Data::Dumper>:
+
+ $VAR1 = {
+ 'Inbox' => 'Inbox',
+ 'AllMail' => '[Gmail]/All Mail',
+ 'Trash' => '[Gmail]/Trash',
+ 'Drafts' => '[Gmail]/Drafts',
+ 'Sent' => '[Gmail]/Sent Mail',
+ 'Spam' => '[Gmail]/Spam',
+ 'Starred' => '[Gmail]/Starred'
+ };
+
+The same list for a user using the French locale might look like this:
+
+ $VAR1 = {
+ 'Inbox' => 'Bo&AO4-te de r&AOk-ception',
+ 'AllMail' => '[Gmail]/Tous les messages',
+ 'Trash' => '[Gmail]/Corbeille',
+ 'Drafts' => '[Gmail]/Brouillons',
+ 'Sent' => '[Gmail]/Messages envoy&AOk-s',
+ 'Spam' => '[Gmail]/Spam',
+ 'Starred' => '[Gmail]/Suivis'
+ };
+
+Mail::IMAPClient recognizes the following "xlist" folder names:
+
+=over 4
+
+=item Inbox
+
+=item AllMail
+
+=item Trash
+
+=item Drafts
+
+=item Sent
+
+=item Spam
+
+=item Starred
+
+=back
+
+These are currently the only ones supported by Gmail. The XLIST
+extension is not documented, and there are no other known
+implementations other than Gmail, so this list is based on what Gmail
+provides.
+
+If the server does not support the XLIST extension, this method
+returns undef.
=head2 has_capability
@@ -2523,6 +2571,9 @@
B<uidexpunge> returns undef on failure.
+If the server does not support the UIDPLUS extension, this method
+returns undef.
+
=head2 uidnext
Example:
Modified: branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient/BodyStructure.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient/BodyStructure.pm?rev=44657&op=diff
==============================================================================
--- branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient/BodyStructure.pm (original)
+++ branches/upstream/libmail-imapclient-perl/current/lib/Mail/IMAPClient/BodyStructure.pm Wed Sep 23 04:14:32 2009
@@ -157,7 +157,7 @@
foreach ( @{$self->{$name}} )
{ my $pn = $_->personalname;
my $name = $pn && $pn ne 'NIL' ? "$pn " : '';
- push @list, $pn. '<'.$_->mailboxname .'@'. $_->hostname.'>';
+ push @list, $name . '<' . $_->mailboxname . '@' . $_->hostname . '>';
}
wantarray ? @list
Added: branches/upstream/libmail-imapclient-perl/current/t/fetch_hash.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmail-imapclient-perl/current/t/fetch_hash.t?rev=44657&op=file
==============================================================================
--- branches/upstream/libmail-imapclient-perl/current/t/fetch_hash.t (added)
+++ branches/upstream/libmail-imapclient-perl/current/t/fetch_hash.t Wed Sep 23 04:14:32 2009
@@ -1,0 +1,233 @@
+#!/usr/bin/perl
+#
+#
+# tests for fetch_hash()
+#
+# fetch_hash() calls fetch() internally. rather than refactor
+# fetch_hash() just for testing, we instead subclass M::IC and use the
+# overidden fetch() to feed it test data.
+
+use strict;
+use warnings;
+use Test::More tests => 18;
+
+BEGIN { use_ok('Mail::IMAPClient') or exit; }
+
+my @tests = (
+ [
+ "unquoted value",
+ [ q{* 1 FETCH (UNQUOTED foobar)}, ],
+ [ [1], qw(UNQUOTED) ],
+ { "1" => { "UNQUOTED" => q{foobar}, } },
+ ],
+ [
+ "quoted value",
+ [ q{* 1 FETCH (QUOTED "foo bar baz")}, ],
+ [ [1], qw(QUOTED) ],
+ { "1" => { "QUOTED" => q{foo bar baz}, }, },
+ ],
+ [
+ "parenthesized value",
+ [ q{* 1 FETCH (PARENS (foo bar))}, ],
+ [ [1], qw(PARENS) ],
+ { "1" => { "PARENS" => q{foo bar}, }, },
+ ],
+ [
+ "parenthesized value with quotes",
+ [ q{* 1 FETCH (PARENS (foo "bar" baz))}, ],
+ [ [1], qw(PARENS) ],
+ { "1" => { "PARENS" => q{foo "bar" baz}, }, },
+ ],
+ [
+ "parenthesized value with parens at start",
+ [ q{* 1 FETCH (PARENS ((foo) bar baz))}, ],
+ [ [1], qw(PARENS) ],
+ { "1" => { "PARENS" => q{(foo) bar baz}, }, },
+ ],
+ [
+ "parenthesized value with parens in middle",
+ [ q{* 1 FETCH (PARENS (foo (bar) baz))}, ],
+ [ [1], qw(PARENS) ],
+ { "1" => { "PARENS" => q{foo (bar) baz}, }, },
+ ],
+ [
+ "parenthesized value with parens at end",
+ [ q{* 1 FETCH (PARENS (foo bar (baz)))}, ],
+ [ [1], qw(PARENS) ],
+ { "1" => { "PARENS" => q{foo bar (baz)}, }, },
+ ],
+ [
+ "complex parens",
+ [ q{* 1 FETCH (PARENS ((((foo) "bar") baz (quux))))}, ],
+ [ [1], qw(PARENS) ],
+ { "1" => { "PARENS" => q{(((foo) "bar") baz (quux))}, }, },
+ ],
+ [
+ "basic literal value",
+ [ q{* 1 FETCH (LITERAL}, q{foo}, q{)}, ],
+ [ [1], qw(LITERAL) ],
+ { "1" => { "LITERAL" => q{foo}, }, },
+ ],
+ [
+ "multiline literal value",
+ [ q{* 1 FETCH (LITERAL}, q{foo\r\nbar\r\nbaz\r\n}, q{)}, ],
+ [ [1], qw(LITERAL) ],
+ { "1" => { "LITERAL" => q{foo\r\nbar\r\nbaz\r\n}, }, },
+ ],
+ [
+ "multiple attributes",
+ [ q{* 1 FETCH (FOO foo BAR bar BAZ baz)}, ],
+ [ [1], qw(FOO BAR BAZ) ],
+ {
+ "1" => {
+ "FOO" => q{foo},
+ "BAR" => q{bar},
+ "BAZ" => q{baz},
+ },
+ },
+ ],
+ [
+ "dotted attribute",
+ [ q{* 1 FETCH (FOO.BAR foobar)}, ],
+ [ [1], qw(FOO.BAR) ],
+ { "1" => { "FOO.BAR" => q{foobar}, }, },
+ ],
+ [
+ "complex attribute",
+ [ q{* 1 FETCH (FOO.BAR[BAZ (QUUX)] quuz)}, ],
+ [ [1], q{FOO.BAR[BAZ (QUUX)]} ],
+ { "1" => { q{FOO.BAR[BAZ (QUUX)]} => q{quuz}, }, },
+ ],
+ [
+ "BODY.PEEK[] requests match BODY[] responses",
+ [ q{* 1 FETCH (BODY[] foo)} ],
+ [ [1], qw(BODY.PEEK[]) ],
+ { "1" => { "BODY[]" => q{foo}, }, },
+ ],
+ [
+ "BODY.PEEK[] requests match BODY.PEEK[] responses also",
+ [ q{* 1 FETCH (BODY.PEEK[] foo)} ],
+ [ [1], qw(BODY.PEEK[]) ],
+ { "1" => { "BODY.PEEK[]" => q{foo}, }, },
+ ],
+ [
+ "real life example",
+ [
+'* 1 FETCH (UID 541 FLAGS (\\Seen) INTERNALDATE "15-Sep-2009 20:05:45 +1000" RFC822.SIZE 771 BODY[HEADER.FIELDS (TO FROM DATE SUBJECT)]',
+ 'Date: Tue, 15 Sep 2009 20:05:45 +1000
+To: rob at pyro
+From: rob at pyro
+Subject: test Tue, 15 Sep 2009 20:05:45 +1000
+
+',
+ ' BODY[]',
+ 'Return-Path: <rob at pyro>
+X-Spam-Checker-Version: SpamAssassin 3.2.5 (2008-06-10) on pyro.home
+X-Spam-Level:
+X-Spam-Status: No, score=-0.5 required=5.0 tests=ALL_TRUSTED,BAYES_00,
+ FH_FROMEML_NOTLD,TO_MALFORMED autolearn=no version=3.2.5
+X-Original-To: rob at pyro
+Delivered-To: rob at pyro
+Received: from pyro (pyro [127.0.0.1])
+ by pyro.home (Postfix) with ESMTP id A5C8115A066
+ for <rob at pyro>; Tue, 15 Sep 2009 20:05:45 +1000 (EST)
+Date: Tue, 15 Sep 2009 20:05:45 +1000
+To: rob at pyro
+From: rob at pyro
+Subject: test Tue, 15 Sep 2009 20:05:45 +1000
+X-Mailer: swaks v20061116.0 jetmore.org/john/code/#swaks
+Message-Id: <20090915100545.A5C8115A066 at pyro.home>
+X-Bogosity: Spam, tests=bogofilter, spamicity=0.999693, version=1.2.1
+Lines: 1
+
+This is a test mailing
+',
+ ')
+',
+ ],
+ [
+ [1],
+ q{BODY.PEEK[HEADER.FIELDS (To From Date Subject)]},
+ qw(FLAGS INTERNALDATE RFC822.SIZE BODY[])
+ ],
+ {
+ "1" => {
+ 'BODY[]' => 'Return-Path: <rob at pyro>
+X-Spam-Checker-Version: SpamAssassin 3.2.5 (2008-06-10) on pyro.home
+X-Spam-Level:
+X-Spam-Status: No, score=-0.5 required=5.0 tests=ALL_TRUSTED,BAYES_00,
+ FH_FROMEML_NOTLD,TO_MALFORMED autolearn=no version=3.2.5
+X-Original-To: rob at pyro
+Delivered-To: rob at pyro
+Received: from pyro (pyro [127.0.0.1])
+ by pyro.home (Postfix) with ESMTP id A5C8115A066
+ for <rob at pyro>; Tue, 15 Sep 2009 20:05:45 +1000 (EST)
+Date: Tue, 15 Sep 2009 20:05:45 +1000
+To: rob at pyro
+From: rob at pyro
+Subject: test Tue, 15 Sep 2009 20:05:45 +1000
+X-Mailer: swaks v20061116.0 jetmore.org/john/code/#swaks
+Message-Id: <20090915100545.A5C8115A066 at pyro.home>
+X-Bogosity: Spam, tests=bogofilter, spamicity=0.999693, version=1.2.1
+Lines: 1
+
+This is a test mailing
+',
+ 'INTERNALDATE' => '15-Sep-2009 20:05:45 +1000',
+ 'FLAGS' => '\\Seen',
+ 'BODY[HEADER.FIELDS (TO FROM DATE SUBJECT)]' =>
+ 'Date: Tue, 15 Sep 2009 20:05:45 +1000
+To: rob at pyro
+From: rob at pyro
+Subject: test Tue, 15 Sep 2009 20:05:45 +1000
+
+',
+ 'RFC822.SIZE' => '771'
+ },
+ },
+ ],
+);
+
+my @uid_tests = (
+ [
+ "uid enabled",
+ [ q{* 1 FETCH (UID 123 UNQUOTED foobar)}, ],
+ [ [123], qw(UNQUOTED) ],
+ { "123" => { "UNQUOTED" => q{foobar}, } },
+ ],
+);
+
+package Test::Mail::IMAPClient;
+
+use vars qw(@ISA);
+ at ISA = qw(Mail::IMAPClient);
+
+sub new {
+ my ( $class, %args ) = @_;
+ my %me = %args;
+ return bless \%me, $class;
+}
+
+sub fetch {
+ my ( $self, @args ) = @_;
+ return $self->{_next_fetch_response} || [];
+}
+
+package main;
+
+sub run_tests {
+ my ( $imap, $tests ) = @_;
+
+ for my $test (@$tests) {
+ my ( $comment, $fetch, $request, $response ) = @$test;
+ $imap->{_next_fetch_response} = $fetch;
+ my $r = $imap->fetch_hash(@$request);
+ is_deeply( $r, $response, $comment );
+ }
+}
+
+my $imap = Test::Mail::IMAPClient->new( Uid => 0 );
+run_tests( $imap, \@tests );
+
+$imap->Uid(1);
+run_tests( $imap, \@uid_tests );
More information about the Pkg-perl-cvs-commits
mailing list