r44659 - in /trunk/libmail-imapclient-perl: Changes MANIFEST META.yml debian/changelog 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 05:25:22 UTC 2009


Author: carnil-guest
Date: Wed Sep 23 05:25:06 2009
New Revision: 44659

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=44659
Log:
* New upstream release
  - Bugfixes including update and clarification of the close and expunge
    documentation (Closes: #547713)

Added:
    trunk/libmail-imapclient-perl/t/fetch_hash.t
      - copied unchanged from r44658, branches/upstream/libmail-imapclient-perl/current/t/fetch_hash.t
Modified:
    trunk/libmail-imapclient-perl/Changes
    trunk/libmail-imapclient-perl/MANIFEST
    trunk/libmail-imapclient-perl/META.yml
    trunk/libmail-imapclient-perl/debian/changelog
    trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pm
    trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pod
    trunk/libmail-imapclient-perl/lib/Mail/IMAPClient/BodyStructure.pm

Modified: trunk/libmail-imapclient-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libmail-imapclient-perl/Changes?rev=44659&op=diff
==============================================================================
--- trunk/libmail-imapclient-perl/Changes (original)
+++ trunk/libmail-imapclient-perl/Changes Wed Sep 23 05:25:06 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: trunk/libmail-imapclient-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libmail-imapclient-perl/MANIFEST?rev=44659&op=diff
==============================================================================
--- trunk/libmail-imapclient-perl/MANIFEST (original)
+++ trunk/libmail-imapclient-perl/MANIFEST Wed Sep 23 05:25:06 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: trunk/libmail-imapclient-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libmail-imapclient-perl/META.yml?rev=44659&op=diff
==============================================================================
--- trunk/libmail-imapclient-perl/META.yml (original)
+++ trunk/libmail-imapclient-perl/META.yml Wed Sep 23 05:25:06 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: trunk/libmail-imapclient-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libmail-imapclient-perl/debian/changelog?rev=44659&op=diff
==============================================================================
--- trunk/libmail-imapclient-perl/debian/changelog (original)
+++ trunk/libmail-imapclient-perl/debian/changelog Wed Sep 23 05:25:06 2009
@@ -1,8 +1,14 @@
-libmail-imapclient-perl (3.20-3) UNRELEASED; urgency=low
-
+libmail-imapclient-perl (3.21-1) UNRELEASED; urgency=low
+
+  [ Ryan Niebur ]
   * Update jawnsy's email address
 
- -- Ryan Niebur <ryanryan52 at gmail.com>  Tue, 01 Sep 2009 21:19:08 -0700
+  [ Salvatore Bonaccorso ]
+  * New upstream release
+    - Bugfixes including update and clarification of the close and expunge
+      documentation (Closes: #547713)
+
+ -- Salvatore Bonaccorso <salvatore.bonaccorso at gmail.com>  Wed, 23 Sep 2009 05:23:00 +0000
 
 libmail-imapclient-perl (3.20-2) unstable; urgency=low
 

Modified: trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pm?rev=44659&op=diff
==============================================================================
--- trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pm (original)
+++ trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pm Wed Sep 23 05:25:06 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: trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pod
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pod?rev=44659&op=diff
==============================================================================
--- trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pod (original)
+++ trunk/libmail-imapclient-perl/lib/Mail/IMAPClient.pod Wed Sep 23 05:25:06 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: trunk/libmail-imapclient-perl/lib/Mail/IMAPClient/BodyStructure.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libmail-imapclient-perl/lib/Mail/IMAPClient/BodyStructure.pm?rev=44659&op=diff
==============================================================================
--- trunk/libmail-imapclient-perl/lib/Mail/IMAPClient/BodyStructure.pm (original)
+++ trunk/libmail-imapclient-perl/lib/Mail/IMAPClient/BodyStructure.pm Wed Sep 23 05:25:06 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




More information about the Pkg-perl-cvs-commits mailing list