1.303

ChangeLog

@@ -1,17 +1,32 @@
 
 RCS file: RCS/imapsync,v
 Working file: imapsync
-head: 1.300
+head: 1.303
 branch:
 locks: strict
-	gilles: 1.300
+	gilles: 1.303
 access list:
 symbolic names:
 keyword substitution: kv
-total revisions: 300;	selected revisions: 300
+total revisions: 303;	selected revisions: 303
 description:
 ----------------------------
-revision 1.300	locked by: gilles;
+revision 1.303	locked by: gilles;
+date: 2010/01/20 04:12:52;  author: gilles;  state: Exp;  lines: +13 -12
+cosmetic changes.
+----------------------------
+revision 1.302
+date: 2010/01/20 03:34:59;  author: gilles;  state: Exp;  lines: +59 -51
+Flags are now exactly synced from host1 to host2.
+Previous releases just added flags, It was a wrong behavior
+since when a \Seen flag is removed on host1 a sync have to
+remove it on host2. imapsync is not imapadd.
+----------------------------
+revision 1.301
+date: 2010/01/18 06:24:16;  author: gilles;  state: Exp;  lines: +92 -23
+Added TLSv1 support.
+----------------------------
+revision 1.300
 date: 2010/01/16 03:34:37;  author: gilles;  state: Exp;  lines: +250 -250
 Changed name of variables. "from" replaced by imap1 "to" by imap2.
 f_* replaced by h1_*

Mail-IMAPClient-3.21/Changes

@@ -5,6 +5,27 @@ 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
+	- added methods Rfc3501_date/Rfc3501_datetime
+	  used by deprecated methods Rfc2060_date/Rfc2060_datetime
+	  rt.cpan.org#48510: Rfc3501_date/Rfc3501_datetime methods do
+	    not exist [sedmonds]
+	- login() hack to quote an empty password
+	  rt.cpan.org#48107: Cannot LOGIN with empty password [skunk]
+
 version 3.19: Fri Jun 19 14:59:15 EDT 2009
 	- *search() backwards compat: caller must quote single arg properly
 	  rt.cpan.org#47044: $imap->search does not return [ekuemmer]

Mail-IMAPClient-3.21/MANIFEST

@@ -32,8 +32,10 @@ prepare_dist
 sample.perldb
 t/basic.t
 t/bodystructure.t
+t/fetch_hash.t
 t/messageset.t
 t/pod.t
+t/simple.t
 t/thread.t
 test_template.txt
 META.yml                                 Module meta-data (added by MakeMaker)

Mail-IMAPClient-3.21/META.yml

@@ -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.19
+version:      3.21
 version_from: lib/Mail/IMAPClient.pm
 installdirs:  site
 requires:

Mail-IMAPClient-3.21/lib/Mail/IMAPClient.pm

@@ -5,7 +5,7 @@ use strict;
 use warnings;
 
 package Mail::IMAPClient;
-our $VERSION = '3.19';
+our $VERSION = '3.21';
 
 use Mail::IMAPClient::MessageSet;
 
@@ -139,10 +139,11 @@ my @dow = qw(Sun Mon Tue Wed Thu Fri Sat);
 my @mnt = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 
 sub Rfc822_date {
-    my $class = shift;    #Date: Fri, 09 Jul 1999 13:10:55 -0000#
+    my $class = shift;
-    my $date = $class =~ /^\d+$/ ? $class : shift;    # method or function?
+    my $date  = $class =~ /^\d+$/ ? $class : shift;    # method or function?
-    my @date = gmtime $date;
+    my @date  = gmtime($date);
 
+    #Date: Fri, 09 Jul 1999 13:10:55 -0000
     sprintf(
         "%s, %02d %s %04d %02d:%02d:%02d -%04d",
         $dow[ $date[6] ],
@@ -154,19 +155,31 @@ sub Rfc822_date {
 }
 
 # The following methods create valid dates for use in IMAP search strings
+# - provide Rfc2060* methods/functions for backwards compatibility
 sub Rfc2060_date {
-    my $class = shift;                                 # 11-Jan-2000
+    $_[0] =~ /^\d+$/ ? Rfc3501_date(@_) : shift->Rfc3501_date(@_);
-    my $stamp = $class =~ /^\d+$/ ? $class : shift;    # method or function
+}
-    my @date  = gmtime $stamp;
 
+sub Rfc3501_date {
+    my $class = shift;
+    my $stamp = $class =~ /^\d+$/ ? $class : shift;
+    my @date  = gmtime($stamp);
+
+    # 11-Jan-2000
     sprintf( "%02d-%s-%04d", $date[3], $mnt[ $date[4] ], $date[5] + 1900 );
 }
 
 sub Rfc2060_datetime($;$) {
-    my ( $class, $stamp, $zone ) = @_;    # 11-Jan-2000 04:04:04 +0000
+    $_[0] =~ /^\d+$/ ? Rfc3501_datetime(@_) : shift->Rfc3501_datetime(@_);
-    $zone ||= '+0000';
+}
-    my @date = gmtime $stamp;
 
+sub Rfc3501_datetime($;$) {
+    my $class = shift;
+    my $stamp = $class =~ /^\d+$/ ? $class : shift;
+    my $zone  = shift || '+0000';
+    my @date  = gmtime($stamp);
+
+    # 11-Jan-2000 04:04:04 +0000
     sprintf(
         "%02d-%s-%04d %02d:%02d:%02d %s",
         $date[3],
@@ -367,7 +380,8 @@ sub login {
 
     return undef unless ( defined($passwd) and defined($id) );
 
-    if ( $passwd =~ m/\W/ ) {    # need to quote
+    # BUG: should use Quote() with $passwd and $id
+    if ( $passwd eq "" or $passwd =~ m/\W/ ) {
         $passwd =~ s/(["\\])/\\$1/g;
         $passwd = qq("$passwd");
     }
@@ -465,6 +479,12 @@ sub _list_or_lsub {
 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;
@@ -519,6 +539,25 @@ sub folders {
     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 {
     my ( $self, $what ) = @_;
     my @folders = $self->_folders_or_subscribed( "lsub", $what );
@@ -1325,7 +1364,7 @@ sub _get_response {
     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;
@@ -1759,7 +1798,7 @@ sub _disconnect {
     $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
@@ -1772,10 +1811,10 @@ sub _list_or_lsub_response_parse {
 
     $resp =~ s/\015?\012$//;
     if (
-        $resp =~ / ^\* \s+ (?:LIST|LSUB) \s+   # * LIST or LSUB
+        $resp =~ / ^\* \s+ (?:LIST|XLIST|LSUB) \s+ # * LIST|XLIST|LSUB
-                 \( ([^\)]*) \)          \s+   # (attrs)
+                 \( ([^\)]*) \)                \s+ # (attrs)
-           (?:   \" ([^"]*)  \" | NIL  ) \s    # "delimiter" or NIL
+           (?:   \" ([^"]*)  \" | NIL  )       \s  # "delimiter" or NIL
-           (?:\s*\" (.*)     \" | (.*) )       # "name" or name
+           (?:\s*\" (.*)     \" | (.*) )           # "name" or name
          /ix
       )
     {
@@ -2003,55 +2042,84 @@ sub fetch_hash {
         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++ ) {
+    while ( my $l = shift @$output ) {
-        my $entry = {};
+        next if $l !~ m/^\*\s(\d+)\sFETCH\s\(/g;
-        my $l     = $output->[$x];
+        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;
+            $uids->{ $entry->{UID} } = $entry;
-            $uid or next;
-
-            if ( $uids->{$uid} ) { $entry = $uids->{$uid} }
-            else                 { $uids->{$uid} ||= $entry }
         }
         else {
-            my $mid = $l =~ /^\* (\d+) FETCH/i ? $1 : undef;
+            $uids->{$mid} = $entry;
-            $mid or next;
-
-            if ( $uids->{$mid} ) { $entry = $uids->{$mid} }
-            else                 { $uids->{$mid} ||= $entry }
         }
 
-        foreach my $w (@words) {
+        for my $word ( keys %$entry ) {
-            if ( $l =~ /\Q$w\E\s*$/i ) {
+            next if exists $words{$word};
-                $entry->{$w} = $output->[ $x + 1 ];
+
-                $entry->{$w} =~ s/(?:$CR?$LF)+$//og;
+            if ( my ($stuff) = $word =~ m/^BODY(\[.*)$/ ) {
-                chomp $entry->{$w};
+                next if exists $words{ "BODY.PEEK" . $stuff };
-            }
-            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;
             }
+
+            delete $entry->{$word};
         }
     }
+
     return wantarray ? %$uids : $uids;
 }
 
@@ -2099,16 +2167,20 @@ sub close {
 sub expunge {
     my ( $self, $folder ) = @_;
 
-    my $old = $self->Folder || '';
+    return undef unless ( defined $folder or defined $self->Folder );
-    if ( defined $folder && $folder eq $old ) {
+
+    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;
@@ -2117,6 +2189,8 @@ sub expunge {
 sub uidexpunge {
     my ( $self, $msgspec ) = ( shift, shift );
 
+    return undef unless $self->has_capability("UIDPLUS");
+
     my $msg =
       UNIVERSAL::isa( $msgspec, 'Mail::IMAPClient::MessageSet' )
       ? $msgspec

Mail-IMAPClient-3.21/lib/Mail/IMAPClient.pod

@@ -754,16 +754,14 @@ Example:
 
   $imap->close or die "Could not close: $@\n";
 
-The B<close> method is implemented via the default method and is used
+The B<close> method is used to close the currently selected folder via
-to close the currently selected folder via the CLOSE IMAP client
+the CLOSE IMAP client command.  According to RFC3501, the CLOSE
-command.  According to RFC3501, the CLOSE command performs an implicit
+command performs an implicit EXPUNGE, which means that any messages
-EXPUNGE, which means that any messages that you've flagged as
+that are flagged as I<\Deleted> (i.e. with the L</delete_message>
-I<\Deleted> (say, with the L</delete_message> method) will now be
+method) will now be deleted.  If you haven't deleted any messages then
-deleted.  If you haven't deleted any messages then B<close> can be
+B<close> can be thought of as an "unselect".
-thought of as an "unselect".
 
-Note again that this closes the currently selected folder, not the
+Note: this closes the currently selected folder, not the IMAP session.
-IMAP session.
 
 See also L</delete_message>, L</expunge>, and RFC3501.
 
@@ -1063,19 +1061,14 @@ Example:
 
 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,
+name) to the EXPUNGE client command, the L</expunge> method does.
-which is especially interesting given that the L</expunge> method
+Note: expunging a folder deletes the messages that have the \Deleted
-doesn't technically exist.  In case you're curious, expunging a folder
+flag set (i.e. messages flagged via L</delete_message>).
-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
+See also the L</close> method, which "deselects" as well as expunges.
-expunges and which likewise doesn't technically exist.
 
 =head2 fetch
 
@@ -1168,27 +1161,12 @@ This would result in L<Data::Dumper> output similar to the following:
               }
      };
 
-You can specify I<BODY[HEADER.FIELDS ($fieldlist)> as an argument, but
+By itself this method may be useful for, say, speeding up programs that
-you should keep the following in mind if you do:
+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
-B<1.> You can only specify one argument of this type per call.  If you
+true power lies in the as-yet-unwritten methods that will rely on this
-need multiple fields, then you'll have to call B<fetch_hashref>
+method to deliver even more powerful result hashes.  Look for more new
-multiple times, each time specifying a different FETCH attribute but
+function in later releases.
-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.
 
 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
@@ -1269,6 +1247,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
 
 Example:
@@ -2523,6 +2571,9 @@ lines returned from the UID EXPUNGE command.
 
 B<uidexpunge> returns undef on failure.
 
+If the server does not support the UIDPLUS extension, this method
+returns undef.
+
 =head2 uidnext
 
 Example:

Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure.pm

@@ -157,7 +157,7 @@ sub _addresses($$$)
     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

Mail-IMAPClient-3.21/t/fetch_hash.t

@@ -0,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@pyro
+From: rob@pyro
+Subject: test Tue, 15 Sep 2009 20:05:45 +1000
+
+',
+            ' BODY[]',
+            'Return-Path: <rob@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@pyro
+Delivered-To: rob@pyro
+Received: from pyro (pyro [127.0.0.1])
+        by pyro.home (Postfix) with ESMTP id A5C8115A066
+        for <rob@pyro>; Tue, 15 Sep 2009 20:05:45 +1000 (EST)
+Date: Tue, 15 Sep 2009 20:05:45 +1000
+To: rob@pyro
+From: rob@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@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@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@pyro
+Delivered-To: rob@pyro
+Received: from pyro (pyro [127.0.0.1])
+        by pyro.home (Postfix) with ESMTP id A5C8115A066
+        for <rob@pyro>; Tue, 15 Sep 2009 20:05:45 +1000 (EST)
+Date: Tue, 15 Sep 2009 20:05:45 +1000
+To: rob@pyro
+From: rob@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@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@pyro
+From: rob@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);
+@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 );

Mail-IMAPClient-3.21/t/simple.t

@@ -0,0 +1,36 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 13;
+
+BEGIN { use_ok('Mail::IMAPClient') or exit; }
+
+{
+    my $obj = Mail::IMAPClient->new();
+
+    my %t = ( 0 => "01-Jan-1970" );
+    foreach my $k ( sort keys %t ) {
+        my $v = $t{$k};
+        my $s = $v . ' 00:00:00 +0000';
+
+        is( Mail::IMAPClient::Rfc2060_date($k), $v, "Rfc2060_date($k)=$v" );
+        is( Mail::IMAPClient::Rfc3501_date($k), $v, "Rfc3501_date($k)=$v" );
+        is( Mail::IMAPClient::Rfc3501_datetime($k),
+            $s, "Rfc3501_datetime($k)=$s" );
+        is( Mail::IMAPClient::Rfc2060_datetime($k),
+            $s, "Rfc3501_datetime($k)=$s" );
+        is( $obj->Rfc3501_date($k),     $v, "->Rfc3501_date($k)=$v" );
+        is( $obj->Rfc2060_date($k),     $v, "->Rfc2060_date($k)=$v" );
+        is( $obj->Rfc3501_datetime($k), $s, "->Rfc3501_datetime($k)=$s" );
+        is( $obj->Rfc2060_datetime($k), $s, "->Rfc2060_datetime($k)=$s" );
+
+        foreach my $z (qw(+0000 -0500)) {
+            my $vz = $v . ' 00:00:00 ' . $z;
+            is( Mail::IMAPClient::Rfc2060_datetime( $k, $z ),
+                $vz, "Rfc2060_datetime($k)=$vz" );
+            is( Mail::IMAPClient::Rfc3501_datetime( $k, $z ),
+                $vz, "Rfc3501_datetime($k)=$vz" );
+        }
+    }
+}

Makefile

@@ -1,5 +1,5 @@
 
-# $Id: Makefile,v 1.26 2010/01/15 00:01:40 gilles Exp gilles $	
+# $Id: Makefile,v 1.27 2010/01/19 15:26:12 gilles Exp gilles $	
 
 TARGET=imapsync
 
@@ -12,20 +12,20 @@ usage:
 	@echo "make install # as root"
 	@echo "make testf   # run tests"
 	@echo "make testv   # run tests verbosely"
-	@echo "make test3xx # run tests with Mail-IMAPClient-3.xy"
+	@echo "make test3xx # run tests with (last) Mail-IMAPClient-3.xy"
 	@echo "make test229 # run tests with Mail-IMAPClient-2.2.9"
 	@echo "make all     "
 
 all: ChangeLog README VERSION
 
-.PHONY: test testp testf test3xx
+.PHONY: test tests testp testf test3xx
 
 .test: $(TARGET) tests.sh
 	/usr/bin/time sh tests.sh 1>/dev/null
 	touch .test
 
 .test_3xx: $(TARGET) tests.sh
-	CMD_PERL='perl -I./Mail-IMAPClient-3.19/lib' /usr/bin/time sh tests.sh 1>/dev/null
+	CMD_PERL='perl -I./Mail-IMAPClient-3.21/lib' /usr/bin/time sh tests.sh 1>/dev/null
 	touch .test_3xx
 
 test_quick : test_quick_229 test_quick_3xx
@@ -34,13 +34,14 @@ test_quick_229: $(TARGET) tests.sh
 	CMD_PERL='perl -I./Mail-IMAPClient-2.2.9' /usr/bin/time sh tests.sh locallocal 1>/dev/null
 
 test_quick_3xx: $(TARGET) tests.sh
-	CMD_PERL='perl -I./Mail-IMAPClient-3.19/lib' /usr/bin/time sh tests.sh locallocal 1>/dev/null
+	CMD_PERL='perl -I./Mail-IMAPClient-3.21/lib' /usr/bin/time sh tests.sh locallocal 1>/dev/null
 
 testv:
 	nice -40 sh -x tests.sh
 
 test: .test_229 .test_3xx
 
+tests: test
 
 test3xx: .test_3xx
 

README

@@ -3,7 +3,7 @@ NAME
     Synchronise mailboxes between two imap servers. Good at IMAP migration.
     More than 32 different IMAP server softwares supported with success.
 
-    $Revision: 1.300 $
+    $Revision: 1.303 $
 
 INSTALL
      imapsync works fine under any Unix OS with perl.
@@ -24,8 +24,8 @@ INSTALL
      Go into the directory imapsync-x.xx and read the INSTALL file.
      The INSTALL file is also at 
      http://www.linux-france.org/prj/imapsync/INSTALL (for windows users)
- 
+     
-     The freshmeat record is at http://freshmeat.net/projects/imapsync/
+ The freshmeat record is at http://freshmeat.net/projects/imapsync/
 
 SYNOPSIS
       imapsync [options]
@@ -42,6 +42,7 @@ SYNOPSIS
                [--host2 server2]  [--port2 <num>]
                [--user2 <string>] [--passfile2 <string>]
                [--ssl1] [--ssl2]
+               [--tls1] [--tls2]
                [--authmech1 <string>] [--authmech2 <string>] 
                [--noauthmd5]
                [--folder <string> --folder <string> ...]
@@ -73,7 +74,7 @@ SYNOPSIS
                [--split1] [--split2] 
                [--reconnectretry1 <int>] [--reconnectretry2 <int>]
                [--version] [--help]
-  
+
 DESCRIPTION
     The command imapsync is a tool allowing incremental and recursive imap
     transfer from one mailbox to another.
@@ -138,8 +139,8 @@ SECURITY
 
     imasync is not totally protected against sniffers on the network since
     passwords may be transferred in plain text if CRAM-MD5 is not supported
-    by your imap servers. Use --ssl1 and --ssl2 to enable encryption on
+    by your imap servers. Use --ssl1 (or --tls1) and --ssl2 (or --tls2) to
-    host1 and host2.
+    enable encryption on host1 and host2.
 
     You may authenticate as one user (typically an admin user), but be
     authorized as someone else, which means you don't need to know every
@@ -362,5 +363,5 @@ SIMILAR SOFTWARES
 
     Feedback (good or bad) will always be welcome.
 
-    $Id: imapsync,v 1.300 2010/01/16 03:34:37 gilles Exp gilles $
+    $Id: imapsync,v 1.303 2010/01/20 04:12:52 gilles Exp gilles $
 

TODO

@@ -1,5 +1,5 @@
 #!/bin/cat
-# $Id: TODO,v 1.70 2010/01/16 03:38:47 gilles Exp gilles $
+# $Id: TODO,v 1.72 2010/01/20 04:13:42 gilles Exp gilles $
 
 TODO file for imapsync
 ----------------------
@@ -9,6 +9,36 @@ http://groups.google.fr/group/comp.mail.imap
 
 Post on imapsync mailing-list when a new release comes.
 
+Start a wiki for imapsync.
+
+Add a best practice migration tips document.
+
+Add "output to reflect everything that imapsync was doing".
+Not everything but flag synchronization will be nice"
+
+Add and option to sync to & from files.
+
+Add an option to make imapsync automatically
+reconnect when the connection drops
+
+Add an --aclregextrans2 flag.
+"Today we discovered, that Cyrus and Dovecot use different characters for 
+their ACLs. Syncing ACLs vom Cyrus to Dovecot (at least 1.2) doesn't 
+work. Cyrus uses c and d, Dovecot uses k and x instead." 
+Peer Heinlein.
+
+Add --subscribeall option.
+Is it possible to have a option that subscribes all folders regardless of
+subscription on the source server? Perhaps --subscribeall?
+
+Add a --delete2folders option
+"When syncing mailboxes with imapsync, is there a way to delete folders in the
+target account? The --delete2 option only seems to delete individual
+messages, not folders."
+
+Add different levels of output to see clearly the
+problem by default.
+
 Add option --exclude_messages_with_flag
 
 Add more information about skipped messages.
@@ -20,11 +50,6 @@ mailboxes). May be the best is to take a part of the
 body. Have to code this.
 
 
-Add an option to store flags with "FLAGS.SILENT" instead of "+FLAGS.SILENT".
-No, be "FLAGS.SILENT" the default and "+FLAGS.SILENT" an option.
-
-
-Add TLS support with patches/imapsync-1.217_tls_support.patch
 
 Add Rick Romero patch with
 --quiet   No output at all
@@ -45,8 +70,6 @@ Add kerberos authentification
 
 Add NOOP commands to avoid timeouts.
 
-Start a wiki for imapsync.
-
 Add a --pidfile option.
 
 Write a clean_exit() replacing each die() or exit() call.
@@ -63,18 +86,6 @@ Fix this:
 >         # No NL Count on Windows my $length = ( -s $file ) + $bare_nl_count;
 >         my $length = ( -s $file );
 
-Add a --delete2folders option
-"When syncing mailboxes with imapsync, is there a way to delete folders in the
-target account? The --delete2 option only seems to delete individual
-messages, not folders."
-
-Add different levels of output to see clearly the
-problem by default.
-
-
-Add --subscribeall option.
-Is it possible to have a option that subscribes all folders regardless of
-subscription on the source server? Perhaps --subscribeall?
 
 Add stdin/stdout filter before transfer:
 "Now i asked me, how to modify your perl program to work with
@@ -97,9 +108,6 @@ vs 250s avec la version 1.217". Marc Jauvin
 
 Add LITERAL+ [RFC 2088] support to imapsync.
 
-Add an option to make imapsync automatically
-reconnect when the connection drops
-
 Add an entry to
 http://lsm.execpc.com/lsm/
 See template lsm.imapsync
@@ -109,13 +117,6 @@ is changing and have it replace the domain in all user names that are
 related to ACLs.
 See patches/imapsync-acls-users
 
-Add a best practice migration tips document.
-
-Add "output to reflect everything that imapsync was doing".
-Not everything but flag synchronization will be nice"
-
-Add and option to sync to & from files.
-
 Use examine() instead of select() in --dry mode.
 Add a method doing the switch automagicaly.
 
@@ -137,6 +138,14 @@ http://asg.web.cmu.edu/cyrus/download/imapd/altnamespace.html
 Explain expunge behavior.
 
 
+
+
+
+
+DONE. Be "FLAGS.SILENT" the normal behavior instead of "+FLAGS.SILENT".
+
+DONE. Add TLS support with patches/imapsync-1.217_tls_support.patch
+
 USELESS. Make --skipheader be multiple. Useless since we can
 use the or perl regex '^X-|^Date|^From'
 

VERSION

@@ -1 +1 @@
-1.300
+1.303

imapsync

@@ -9,7 +9,7 @@ tool. Synchronise mailboxes between two imap servers. Good
 at IMAP migration. More than 32 different IMAP server softwares
 supported with success.
 
-$Revision: 1.300 $
+$Revision: 1.303 $
 
 =head1 INSTALL
 
@@ -50,6 +50,7 @@ The option list:
            [--host2 server2]  [--port2 <num>]
            [--user2 <string>] [--passfile2 <string>]
            [--ssl1] [--ssl2]
+	   [--tls1] [--tls2]
            [--authmech1 <string>] [--authmech2 <string>] 
            [--noauthmd5]
            [--folder <string> --folder <string> ...]
@@ -162,7 +163,8 @@ the best solution.
 imasync is not totally protected against sniffers on the
 network since passwords may be transferred in plain text
 if CRAM-MD5 is not supported by your imap servers.  Use
---ssl1 and --ssl2 to enable encryption on host1 and host2.
+--ssl1 (or --tls1) and --ssl2 (or --tls2) to enable 
+encryption on host1 and host2.
 
 You may authenticate as one user (typically an admin user),
 but be authorized as someone else, which means you don't
@@ -418,7 +420,7 @@ Entries for imapsync:
 
 Feedback (good or bad) will always be welcome.
 
-$Id: imapsync,v 1.300 2010/01/16 03:34:37 gilles Exp gilles $
+$Id: imapsync,v 1.303 2010/01/20 04:12:52 gilles Exp gilles $
 
 =cut
 
@@ -475,6 +477,7 @@ my(
 	$timestart, $timeend, $timediff,
         $timesize, $timebefore,
         $ssl1, $ssl2,
+	$tls1, $tls2,
         $authuser1, $authuser2,
         $authmech1, $authmech2,
         $split1, $split2,
@@ -487,7 +490,7 @@ my(
 use vars qw ($opt_G); # missing code for this will be option.
 
 
-$rcs = '$Id: imapsync,v 1.300 2010/01/16 03:34:37 gilles Exp gilles $ ';
+$rcs = '$Id: imapsync,v 1.303 2010/01/20 04:12:52 gilles Exp gilles $ ';
 $rcs =~ m/,v (\d+\.\d+)/;
 $VERSION = ($1) ? $1: "UNKNOWN";
 
@@ -551,8 +554,8 @@ while (@argv_copy) {
 
 my $banner = join("", 
 		  '$RCSfile: imapsync,v $ ',
-		  '$Revision: 1.300 $ ',
+		  '$Revision: 1.303 $ ',
-		  '$Date: 2010/01/16 03:34:37 $ ',
+		  '$Date: 2010/01/20 04:12:52 $ ',
 		  "\n",localhost_info(),
 		  " and the module Mail::IMAPClient version used here is ",
 		  $VERSION_IMAPClient,"\n",
@@ -607,20 +610,20 @@ $split1 ||= 1000;
 $split2 ||= 1000;
 
 $host1 || missing_option("--host1") ;
-$port1 ||= defined $ssl1 ? 993 : 143;
+$port1 ||= (defined $ssl1 and !defined $tls1) ? 993 : 143;
 
 $host2 || missing_option("--host2") ;
-$port2 ||= defined $ssl2 ? 993 : 143;
+$port2 ||= (defined $ssl2 && !defined $tls2) ? 993 : 143;
-
 
 
 sub connect_imap {
-	my($host, $port, $debugimap, $ssl) = @_;
+	my($host, $port, $debugimap, $ssl, $tls) = @_;
 	my $imap = Mail::IMAPClient->new();
 	$imap->Server($host);
 	$imap->Port($port);
 	$imap->Debug($debugimap);
 	$imap->Ssl($ssl) if ($ssl);
+	$imap->Tls($tls) if ($tls);
 	#$imap->connect()
 	myconnect($imap)
 	  or die "Can not open imap connection on [$host]: $@\n";	
@@ -646,10 +649,10 @@ if ($justconnect) {
 	my $imap1 = ();
 	my $imap2 = ();
 	
-	$imap1 = connect_imap($host1, $port1, $debugimap, $ssl1);
+	$imap1 = connect_imap($host1, $port1, $debugimap, $ssl1, $tls1);
 	print "Host1 software: ", server_banner($imap1);
 	print "Host1 capability: ", join(" ", $imap1->capability()), "\n";
-	$imap2   = connect_imap($host2, $port2, $debugimap, $ssl2);
+	$imap2   = connect_imap($host2, $port2, $debugimap, $ssl2, $tls2);
 	print "Host2 software: ", server_banner($imap2);
 	print "Host2 capability: ", join(" ", $imap2->capability()), "\n";
 	$imap1->logout();
@@ -754,12 +757,12 @@ $timebefore = $timestart;
 
 $debugimap and print "Host1 connection\n";
 $imap1 = login_imap($host1, $port1, $user1, $password1, 
-		   $debugimap, $timeout, $fastio1, $ssl1, 
+		   $debugimap, $timeout, $fastio1, $ssl1, $tls1,
 		   $authmech1, $authuser1, $reconnectretry1);
 
 $debugimap and print "Host2 connection\n";
 $imap2 = login_imap($host2, $port2, $user2, $password2, 
-		 $debugimap, $timeout, $fastio2, $ssl2, 
+		 $debugimap, $timeout, $fastio2, $ssl2, $tls2,
 		 $authmech2, $authuser2, $reconnectretry2);
 
 #  history
@@ -771,12 +774,13 @@ $debug and print "Host2 Buffer I/O: ", $imap2->Buffer(), "\n";
 sub login_imap {
 	my($host, $port, $user, $password, 
 	   $debugimap, $timeout, $fastio, 
-	   $ssl, $authmech, $authuser, $reconnectretry) = @_;
+	   $ssl, $tls, $authmech, $authuser, $reconnectretry) = @_;
 	my ($imap);
 	
 	$imap = Mail::IMAPClient->new();
 	
 	$imap->Ssl($ssl) if ($ssl);
+	$imap->Tls($tls) if ($tls);
 	$imap->Clear(5);
 	$imap->Server($host);
 	$imap->Port($port);
@@ -1065,6 +1069,8 @@ sub tests_compare_lists {
 	ok(+1 == compare_lists(["b"], ["a"])   , 'compare_lists, ["b"] > ["a"]') ;
 	ok(-1 == compare_lists(["a"], ["aa"])  , 'compare_lists, ["a"] < ["aa"]') ;
 	ok(-1 == compare_lists(["a"], ["a", "a"]), 'compare_lists, ["a"] < ["a", "a"]') ;
+	ok( 0 == compare_lists([split(" ", "a b")], ["a", "b"]), 'compare_lists, split') ;
+	ok( 0 == compare_lists([sort split(" ", "b a")], ["a", "b"]), 'compare_lists, sort split') ;
 }
 
 
@@ -1303,13 +1309,13 @@ sub tests_flags_regex {
 }
 
 sub flags_regex {
-	my ($flags_f) = @_;
+	my ($h1_flags) = @_;
 	foreach my $regexflag (@regexflag) {
-		$debug and print "eval \$flags_f =~ $regexflag\n";
+		$debug and print "eval \$h1_flags =~ $regexflag\n";
-		eval("\$flags_f =~ $regexflag");
+		eval("\$h1_flags =~ $regexflag");
 		die("error: eval regexflag '$regexflag': $@\n") if $@;
 	}
-	return($flags_f);
+	return($h1_flags);
 }
 
 sub acls_sync {
@@ -1461,19 +1467,19 @@ FOLDER: foreach my $h1_fold (@h1_folders) {
 
 
 
-	$debug and print "LIST FROM: ", scalar(@h1_msgs), " messages [@h1_msgs]\n";
+	$debug and print "LIST Host1: ", scalar(@h1_msgs), " messages [@h1_msgs]\n";
 	# internal dates on "TO" are after the ones on "FROM"
 	# normally...
 	my @h2_msgs = select_msgs($imap2);
 	
-	$debug and print "LIST TO  : ", scalar(@h2_msgs), " messages [@h2_msgs]\n";
+	$debug and print "LIST Host2: ", scalar(@h2_msgs), " messages [@h2_msgs]\n";
 
 	my %h1_hash = ();
 	my %h2_hash = ();
 	
 	#print "++++ Using cache ++++\n";
 	
-	print "++++ Host1 [$h1_fold] Parse 1 ++++\n";
+	print "++++ Host1 [$h1_fold] parsing headers ++++\n";
 	last FOLDER if $imap1->IsUnconnected();
 	last FOLDER if $imap2->IsUnconnected();
 
@@ -1504,9 +1510,9 @@ FOLDER: foreach my $h1_fold (@h1_folders) {
 			$mess_skipped += 1;
 		}
 	}
-	$debug and print "Time headers: ", timenext(), " s\n";
+	$debug and print "Time parsing headers on host1: ", timenext(), " s\n";
 	
-	print "++++ Host2 [$h2_fold] Parse 1 ++++\n";
+	print "++++ Host2 [$h2_fold] parsing headers ++++\n";
 
 	my ($h2_heads, $h2_fir) = ({}, {});
 	$h2_heads =   $imap2->parse_headers([@h2_msgs], @useheader) if (@h2_msgs);
@@ -1527,10 +1533,10 @@ FOLDER: foreach my $h1_fold (@h1_folders) {
 			#$mess_skipped += 1;
 		}
 	}
-	$debug and print "Time headers: ", timenext(), " s\n";
+	$debug and print "Time parsing headers on host2: ", timenext(), " s\n";
 
 	print "++++ Verifying [$h1_fold] -> [$h2_fold] ++++\n";
-	# messages in "from" that are not good in "to"
+	# messages in host1 that are not good in host2
 	
 	my @h1_hash_keys_sorted_by_uid 
 	  = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys(%h1_hash);
@@ -1547,8 +1553,8 @@ FOLDER: foreach my $h1_fold (@h1_folders) {
 			#print "$m_id ";
 			unless (exists($h1_hash{$m_id})) {
 				my $h2_msg  = $h2_hash{$m_id}{'m'};
-				my $flags  = $h2_hash{$m_id}{'F'} || "";
+				my $h2_flags  = $h2_hash{$m_id}{'F'} || "";
-				my $isdel  = $flags =~ /\B\\Deleted\b/ ? 1 : 0;
+				my $isdel  = $h2_flags =~ /\B\\Deleted\b/ ? 1 : 0;
 				print "deleting message $m_id  $h2_msg\n"
 				  if ! $isdel;
 				push(@expunge,$h2_msg) if $uidexpunge2;
@@ -1597,7 +1603,7 @@ FOLDER: foreach my $h1_fold (@h1_folders) {
 				$mess_size_total_error += $h1_size;
 				next MESS;
 			}
-			#print "AAAmessage_string[$string]ZZZ\n";
+			
 			#my $message_file = "tmp_imapsync_$$";
 			#$imap1->select($h1_fold);
 			#unlink($message_file);
@@ -1670,27 +1676,27 @@ FOLDER: foreach my $h1_fold (@h1_folders) {
 				return($d);
 			}
 
-			my $flags_f = $h1_hash{$m_id}{'F'} || "";
+			my $h1_flags = $h1_hash{$m_id}{'F'} || "";
 			# RFC 2060: This flag can not be altered by any client
-			$flags_f =~ s@\\Recent\s?@@gi;
+			$h1_flags =~ s@\\Recent\s?@@gi;
-			$flags_f = flags_regex($flags_f) if @regexflag;
+			$h1_flags = flags_regex($h1_flags) if @regexflag;
 			
-			$flags_f = flags_filter($flags_f, $permanentflags2) if ($permanentflags2);
+			$h1_flags = flags_filter($h1_flags, $permanentflags2) if ($permanentflags2);
 			
 			my $new_id;
-			print "flags from: [$flags_f][$d]\n";
+			print "flags from: [$h1_flags][$d]\n";
 			last FOLDER if $imap1->IsUnconnected();
 			last FOLDER if   $imap2->IsUnconnected();
 			unless ($dry) {
 				
 				if ($OSNAME eq "MSWin32") {
-					$new_id = $imap2->append_string($h2_fold,$string, $flags_f, $d);
+					$new_id = $imap2->append_string($h2_fold,$string, $h1_flags, $d);
 				}
 				else {
 					# just back to append_string since append_file 3.05 does not work. 
-					#$new_id = $imap2->append_file($h2_fold, $message_file, "", $flags_f, $d);
+					#$new_id = $imap2->append_file($h2_fold, $message_file, "", $h1_flags, $d);
 					# append_string 3.05 does not work too some times with $d unset.
-					$new_id = $imap2->append_string($h2_fold,$string, $flags_f, $d);
+					$new_id = $imap2->append_string($h2_fold,$string, $h1_flags, $d);
 				}
 				unless($new_id){
 					no warnings 'uninitialized';
@@ -1737,46 +1743,52 @@ FOLDER: foreach my $h1_fold (@h1_folders) {
 		my $h2_msg  = $h2_hash{$m_id}{'m'};
 
 		# used cached flag values for efficiency
-		my $flags_f = $h1_hash{$m_id}{'F'} || "";
+		my $h1_flags = $h1_hash{$m_id}{'F'} || "";
-		my $flags_t = $h2_hash{$m_id}{'F'} || "";
+		my $h2_flags = $h2_hash{$m_id}{'F'} || "";
 
 		# RFC 2060: This flag can not be altered by any client
-		$flags_f =~ s@\\Recent\s?@@gi;
+		$h1_flags =~ s@\\Recent\s?@@gi;
-		$flags_f = flags_regex($flags_f) if @regexflag;
+		$h1_flags = flags_regex($h1_flags) if @regexflag;
-		$flags_f = flags_filter($flags_f, $permanentflags2) if ($permanentflags2);
+		$h1_flags = flags_filter($h1_flags, $permanentflags2) if ($permanentflags2);
-		# compare flags - add missing flags
+		
-		my @ff = split(' ', $flags_f );
+		
-		my %ft = map { $_ => 1 } split(' ', $flags_t );
+		# compare flags - set flags if there a diffrence
-		my @flags_a = map { exists $ft{$_} ? () : $_ } @ff;
+		my @h1_flags = sort split(' ', $h1_flags );
+		my @h2_flags = sort split(' ', $h2_flags );
+		my $diff = compare_lists(\@h1_flags, \@h2_flags);
 
-		$debug and print "Setting flags(@flags_a) ffrom($flags_f) fto($flags_t) on msg #$h2_msg in $h2_fold\n";
+		$diff and $debug and print "Replacing h2 flags($h2_flags) with h1 flags($h1_flags) on msg #$h2_msg in $h2_fold\n";
 
-		# This adds or changes flags but no flag are removed with this
+		# This sets flags so flags can be removed with this
-		if (!$dry and @flags_a and !$imap2->store($h2_msg, "+FLAGS.SILENT (@flags_a)") ) {
+		# When you remove a \Seen flag on host1 you want to it
-			warn "Could not add flags '@flags_a' flagf '$flags_f'",
+		# to be removed on host2. Just add flags is not what 
-			  " flagt '$flags_t' on msg #$h2_msg in $h2_fold: ",
+		# we need most of the time.
+		
+		if (!$dry and $diff and !$imap2->store($h2_msg, "FLAGS.SILENT (@h1_flags)") ) {
+			warn "Could not add flags @h1_flags",
+			  " on msg #$h2_msg in $h2_fold: ",
 			  $imap2->LastError, "\n";
 			#$error++;
 		}
 		last FOLDER if   $imap2->IsUnconnected();
 
 		$debug and do {
-			my @flags_t = @{ $imap2->flags($h2_msg) || [] };
+			my @h2_flags = @{ $imap2->flags($h2_msg) || [] };
 			last FOLDER if   $imap2->IsUnconnected();
 
-			print "flags from: $flags_f\n",
+			print "host1 flags: $h1_flags\n",
-			      "flags to  : @flags_t\n";
+			      "host2 flags: @h2_flags\n";
 
 			print "Looking dates\n"; 
-			#my $d_f = $imap1->internaldate($h1_msg);
+			#my $h1_idate = $imap1->internaldate($h1_msg);
-			#my $d_t = $imap2->internaldate($h2_msg);
+			#my $h2_idate = $imap2->internaldate($h2_msg);
-			my $d_f = $h1_hash{$m_id}{'D'};
+			my $h1_idate = $h1_hash{$m_id}{'D'};
-			my $d_t = $h2_hash{$m_id}{'D'};
+			my $h2_idate = $h2_hash{$m_id}{'D'};
 			print 
-			  "idate from: $d_f\n",
+			  "host1 internal date: $h1_idate\n",
-			    "idate to  : $d_t\n";
+			  "host2 internal date: $h2_idate\n";
 			
-			#unless ($d_f eq $d_t) {
+			#unless ($h1_idate eq $h2_idate) {
 			#	print "!!! Dates differ !!!\n";
 			#}
 		};
@@ -1784,7 +1796,7 @@ FOLDER: foreach my $h1_fold (@h1_folders) {
 			# Bad size
 			print 
 			"Message $m_id SZ_BAD  f:$h1_msg:$h1_size t:$h2_msg:$h2_size\n";
-			# delete in to and recopy ?
+			# delete in host2 and recopy ?
 			# NO recopy CODE HERE. to be written if needed.
 			$error++;
 			if ($opt_G){
@@ -1917,10 +1929,10 @@ sub stats {
 
 sub thank_author {
 
-	return(join("", "Happy with this free, open and gratis WTFPL software?\n",
+	return(join("", "Happy with this free, open and gratis DWTFPL software?\n",
 	  "Encourage the author (Gilles LAMIRAL) by giving him a book:\n",
 	  "http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/\n",
-          "or via paypal:\n",
+          "or just money via paypal:\n",
 	  "http://www.linux-france.org/prj/imapsync/paypal.html\n"));
 }
 
@@ -1993,6 +2005,8 @@ sub get_options {
 				   "fastio2!"     => \$fastio2,
 				   "ssl1!"        => \$ssl1,
 				   "ssl2!"        => \$ssl2,
+				   "tls1!"        => \$tls1,
+				   "tls2!"        => \$tls2,
 				   "authmech1=s" => \$authmech1,
 				   "authmech2=s" => \$authmech2,
 				   "authuser1=s" => \$authuser1,
@@ -2032,7 +2046,7 @@ sub get_options {
 
 sub load_modules {
 
-	require IO::Socket::SSL if ($ssl1 or $ssl2);
+	require IO::Socket::SSL if ($ssl1 or $ssl2 or $tls1 or $tls2);
 	require Date::Manip if ($syncinternaldates || $idatefromheader) ;
 
         require Term::ReadKey if (
@@ -2171,6 +2185,8 @@ Several options are mandatory.
 --authmech2   <string> : auth mechanism to use with host2. See --authmech1
 --ssl1                 : use an SSL connection on host1.
 --ssl2                 : use an SSL connection on host2.
+--tls1                 : use an TLS connection on host1.
+--tls2                 : use an TLS connection on host2.
 --folder      <string> : sync this folder.
 --folder      <string> : and this one, etc.
 --folderrec   <string> : sync this folder recursively.
@@ -2221,13 +2237,14 @@ Several options are mandatory.
                          source server only. newly transferred messages
                          are expunged if option --expunge is given.
                          no expunge is done on destination account but
-                         it will change in future releases.
+                         it may change in future releases.
 --expunge1             : expunge messages on source account.
 --expunge2             : expunge messages on target account.
 --uidexpunge2          : uidexpunge messages on the destination imap server
                          that are not on the source server, requires --delete2
 --syncinternaldates    : sets the internal dates on host2 same as host1.
-                         Turned on by default.
+                         Turned on by default. internal date is the date
+			 a message arrived on a host (mtime).
 --idatefromheader      : sets the internal dates on host2 same as the 
                          "Date:" headers. 
 --buffersize  <int>    : sets the size of a block of I/O.
@@ -2890,15 +2907,13 @@ no warnings 'once';
 sub myconnect {
 	my $self = shift;
 	
-	$self->Port(143) 
+	$debug and print "Entering myconnect\n";
-		if 	defined ($IO::Socket::INET::VERSION) 
-		and 	$IO::Socket::INET::VERSION eq '1.25' 
-		and 	!$self->Port;
 	%$self = (%$self, @_);
 
-        my $sock = ($self->Ssl ? IO::Socket::SSL->new : IO::Socket::INET->new);
+        my $sock = (($self->Ssl) ? IO::Socket::SSL->new : IO::Socket::INET->new);
         my $dp = ($self->Ssl ? 'imaps(993)' : 'imap(143)');
 
+	$debug and print "Calling configure\n";
 	my $ret = $sock->configure({
 		PeerAddr => $self->Server		,
                 PeerPort => $self->Port||$dp	       	,
@@ -2913,24 +2928,45 @@ sub myconnect {
 				unless defined wantarray;	
 		return undef;
 	}
-	$self->Socket($sock);
+	
+	if ($self->Tls) {
+	    $debug and print "Calling starttls\n";
+	    $sock->autoflush(1);
+	    my $banner = starttls($sock);
+	    $debug and print "End starttls: $banner\n";
+	    $self->State(Mail::IMAPClient::Connected);
+	}
+	
+	$debug and print "Calling Socket\n";
+	
+	if ($Mail::IMAPClient::VERSION =~ /^3/ and $self->Tls) {
+		$self->RawSocket($sock);
+	}else{
+		$self->Socket($sock);
+	}
+
+	
 	if ( $Mail::IMAPClient::VERSION =~ /^2/ ) {
+	    $debug and print "Calling myconnect_v2\n";
 	    return undef unless myconnect_v2($self);
+	    $debug and print "End myconnect_v2\n";
 	}
 	else {
 		$self->Ignoresizeerrors($allowsizemismatch);
 	}
 	if ($self->User and $self->Password) {
+		$debug and print "Calling login\n";
 		return $self->login ;
 	} 
 	else {
-		return $self;	
+		return $self;
 	}
 }
 
 	
 sub myconnect_v2 {
 	my $self = shift;
+	return $self if $self->Tls;
 	$self->State(Connected);
 	$self->Socket->autoflush(1);
 	my ($code, $output);
@@ -2955,6 +2991,40 @@ sub myconnect_v2 {
 }
 
 
+sub starttls {
+  my $socket   = shift;
+  
+  $debug and print "Entering starttls\n";
+  my $banner = $socket->getline();
+  unless ($banner =~ /^\* OK \[CAPABILITY.*STARTTLS.*\]/) {
+    die "No STARTTLS capability: $banner";
+  }
+  print $socket "STARTTLS\015\012";
+  my $txt = $socket->getline();
+  $debug and print "$txt";
+  unless($txt =~ /^STARTTLS OK/){
+    die "Invalid response for STARTTLS: $txt\n";
+  }
+  $debug and print "Calling start_SSL\n";
+  unless(IO::Socket::SSL->start_SSL($socket,
+      {
+      SSL_version    =>  "TLSV1",
+      SSL_startHandshake => 1,
+      SSL_verify_depth => 1,
+      }))
+  {
+    die "Couldn't start TLS: ".IO::Socket::SSL::errstr()."\n";
+  }
+  if (ref($socket) ne "IO::Socket::SSL") {
+    die "Socket has NOT been converted to SSL";
+  }else{
+     $debug and print "Socket successfuly converted to SSL\n";
+  }
+  $banner;
+}
+
+
+
 package Mail::IMAPClient;
 
 
@@ -2964,3 +3034,11 @@ sub Split {
 	if (@_) { $self->{SPLIT} = shift }
 	return $self->{SPLIT};
 }
+
+sub Tls {
+	my $self = shift;
+	
+	if (@_) { $self->{TLS} = shift }
+	return $self->{TLS};
+}
+

learn/imapclient_tls

@@ -0,0 +1,81 @@
+#!/usr/bin/perl -w
+
+use Mail::IMAPClient;
+use IO::Socket::SSL qw(debug1 debug2 debug3) ;
+
+$ARGV[3] or die "usage: $0 host user password folder\n";
+
+$host = $ARGV[0];
+$user = $ARGV[1];
+$password = $ARGV[2];
+$folder = $ARGV[3];
+
+my $imap = Mail::IMAPClient->new();
+
+
+my $socket  = IO::Socket::INET->new(
+             Proto    => 'tcp',
+             PeerAddr => $host,
+             PeerPort => 143,
+);
+
+$socket->autoflush(1);
+
+my $banner = $socket->getline();
+unless ($banner =~ /^\* OK \[CAPABILITY.*STARTTLS.*\]/) {
+  die "No STARTTLS capability: $banner";
+}
+
+
+print $socket "STARTTLS\015\012";
+my $txt = $socket->getline();
+unless($txt =~ /^STARTTLS OK/){
+  die "Invalid response for STARTTLS: $txt\n";
+}
+
+my $result = IO::Socket::SSL->start_SSL($socket,
+    {
+    SSL_startHandshake => 1, 
+    SSL_version    =>      "TLSv1",
+    SSL_verify_depth => 1,
+    }
+);
+
+print "start_SSL return $result\n";
+
+unless ($result){
+  
+  die "Couldn't start TLS: ".IO::Socket::SSL::errstr()."\n";
+}
+
+if (ref($socket) ne "IO::Socket::SSL") {
+  die "Socket has not been converted to SSL";
+}else{
+  print "Socket has been converted to SSL\n";
+}
+$imap->State(Mail::IMAPClient::Connected);
+
+
+$imap->Debug(1);
+print "Socket\n";
+$imap->RawSocket($socket);
+#$imap->Socket($socket);
+
+print $socket "a02 CAPABILITY\n";
+print "getline\n";
+$txt = $socket->getline();
+
+print "getline : $txt \n";
+
+
+#$imap->connect() or die;
+print "User\n";
+$imap->User($user);
+$imap->Password($password);
+print "login\n";
+
+$imap->login() or die;
+$imap->Uid(1);
+$imap->Peek(1);
+$imap->select($folder) or die;
+$imap->close();

tests.sh

@@ -1,6 +1,6 @@
 #!/bin/sh
 
-# $Id: tests.sh,v 1.96 2010/01/14 23:40:54 gilles Exp gilles $  
+# $Id: tests.sh,v 1.98 2010/01/20 04:13:59 gilles Exp gilles $  
 
 # Example:
 # CMD_PERL='perl -I./Mail-IMAPClient-3.14/lib' sh -x tests.sh
@@ -634,8 +634,8 @@ ll_flags()
                 --host2 $HOST2 --user2 titi \
                 --passfile2 ../../var/pass/secret.titi \
                 --folder INBOX.yop.yap \
-                --dry --debug \
+                --debug
-                --allow3xx
+                
                 echo 'rm /home/vmail/titi/.yop.yap/cur/*'
 }
 
@@ -647,7 +647,7 @@ ll_regex_flag()
                 --host2 $HOST2 --user2 titi \
                 --passfile2 ../../var/pass/secret.titi \
                 --folder INBOX.yop.yap \
-                --debug --regexflag 's/\\Answered/\\Flagged/g'
+                --debug --regexflag 's/\\Answered/\\Seen/g'
                 
                 echo 'rm -f /home/vmail/titi/.yop.yap/cur/*'
 }
@@ -680,18 +680,63 @@ ll_regex_flag3()
 }
 
 
+ll_tls_justconnect() {
+ $CMD_PERL ./imapsync \
+  --host1 l \
+  --host2 l \
+  --tls1 --tls2 \
+  --justconnect  --debug 
+}
+
+ll_tls_justlogin() {
+ $CMD_PERL ./imapsync \
+  --host1 $HOST1 --user1 tata \
+  --passfile1 ../../var/pass/secret.tata \
+  --host2 $HOST2 --user2 titi \
+  --passfile2 ../../var/pass/secret.titi \
+  --tls1 --tls2 \
+  --justlogin --debug 
+}
 
 
-ssl_justconnect() {
 
+ll_tls_devel() {
+   CMD_PERL='perl -I./Mail-IMAPClient-2.2.9' ll_justlogin ll_ssl_justlogin \
+&& CMD_PERL='perl -I./Mail-IMAPClient-3.19/lib' ll_justlogin ll_ssl_justlogin \
+&& CMD_PERL='perl -I./Mail-IMAPClient-2.2.9' ll_tls_justconnect  ll_tls_justlogin \
+&& CMD_PERL='perl -I./Mail-IMAPClient-3.19/lib' ll_tls_justconnect ll_tls_justlogin
+}
+
+ll_tls() {
+ $CMD_PERL ./imapsync \
+  --host1 $HOST1 --user1 tata \
+  --passfile1 ../../var/pass/secret.tata \
+  --host2 $HOST2 --user2 titi \
+  --passfile2 ../../var/pass/secret.titi \
+  --tls1 --tls2
+}
+
+
+
+ll_ssl_justconnect() {
                 $CMD_PERL ./imapsync \
 		--host1 $HOST1 \
                 --host2 $HOST2 \
                 --ssl1 --ssl2 \
-                --justconnect \
+                --justconnect
-            --allow3xx
 }
 
+ll_ssl_justlogin() {
+        $CMD_PERL ./imapsync \
+	 --host1 $HOST1 --user1 tata \
+         --passfile1 ../../var/pass/secret.tata \
+         --host2 $HOST2 --user2 titi \
+         --passfile2 ../../var/pass/secret.titi \
+         --ssl1 --ssl2 \
+         --justlogin
+}
+
+
 ll_ssl() {
         if can_send; then
                 #echo3 Here is plume
@@ -892,7 +937,7 @@ archiveopteryx_1() {
 		--allow3xx 
 }
 
-justlogin() {
+ll_justlogin() {
 # Look in the file ../../var/pass/secret.tptp to see 
 # strange \ character behavior
                 $CMD_PERL  ./imapsync \
@@ -903,7 +948,7 @@ justlogin() {
 		--allow3xx --justlogin --noauthmd5
 }
 
-justlogin_backslash_char() {
+ll_justlogin_backslash_char() {
 # Look in the file ../../var/pass/secret.tptp to see 
 # strange \ character behavior
                 $CMD_PERL  ./imapsync \
@@ -1169,7 +1214,6 @@ test $# -eq 0 && run_tests \
         ll_folder_rev \
         ll_subscribed \
         ll_subscribe \
-        ll_justconnect \
         ll_justfoldersizes \
         ll_authmd5 \
         ll_noauthmd5 \
@@ -1190,7 +1234,14 @@ test $# -eq 0 && run_tests \
         ll_regexmess_scwchu \
         ll_flags \
         ll_regex_flag \
+        ll_justconnect \
+        ll_justlogin \
         ll_ssl \
+        ll_ssl_justconnect \
+        ll_ssl_justlogin \
+        ll_tls_justconnect \
+        ll_tls_justlogin \
+        ll_tls \
         ll_authmech_PLAIN \
         ll_authmech_LOGIN \
         ll_authmech_CRAMMD5 \
@@ -1202,13 +1253,11 @@ test $# -eq 0 && run_tests \
 	gmail_gmail \
 	gmail_gmail2 \
 	archiveopteryx_1 \
-        ssl_justconnect \
 	allow3xx \
 	noallow3xx \
-        justlogin \
 	
 #       msw
-#	justlogin_backslash_char
+#	ll_justlogin_backslash_char
 
 
 # selective tests