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 $date = $class =~ /^\d+$/ ? $class : shift;    # method or function?
-    my @date = gmtime $date;
+    my $class = shift;
+    my $date  = $class =~ /^\d+$/ ? $class : shift;    # method or function?
+    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
-    my $stamp = $class =~ /^\d+$/ ? $class : shift;    # method or function
-    my @date  = gmtime $stamp;
+    $_[0] =~ /^\d+$/ ? Rfc3501_date(@_) : shift->Rfc3501_date(@_);
+}
 
+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
-    $zone ||= '+0000';
-    my @date = gmtime $stamp;
+    $_[0] =~ /^\d+$/ ? Rfc3501_datetime(@_) : shift->Rfc3501_datetime(@_);
+}
 
+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
-                 \( ([^\)]*) \)          \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
       )
     {
@@ -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++ ) {
-        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 }
+            $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;
+        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;
 }
 
@@ -2099,16 +2167,20 @@ sub close {
 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;
@@ -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
-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".
+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 again that this closes the currently selected folder, not the
-IMAP session.
+Note: this closes the currently selected folder, not the 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,
-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.)
+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>).
 
-Or you could use the L</close> method, which deselects as well as
-expunges and which likewise doesn't technically exist.
+See also the L</close> method, which "deselects" as well as expunges.
 
 =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
-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
@@ -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
-    host1 and host2.
+    by your imap servers. Use --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 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 $ ',
-		  '$Date: 2010/01/16 03:34:37 $ ',
+		  '$Revision: 1.303 $ ',
+		  '$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";
-		eval("\$flags_f =~ $regexflag");
+		$debug and print "eval \$h1_flags =~ $regexflag\n";
+		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 $isdel  = $flags =~ /\B\\Deleted\b/ ? 1 : 0;
+				my $h2_flags  = $h2_hash{$m_id}{'F'} || "";
+				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;
-			$flags_f = flags_regex($flags_f) if @regexflag;
+			$h1_flags =~ s@\\Recent\s?@@gi;
+			$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 $flags_t = $h2_hash{$m_id}{'F'} || "";
+		my $h1_flags = $h1_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;
-		$flags_f = flags_regex($flags_f) if @regexflag;
-		$flags_f = flags_filter($flags_f, $permanentflags2) if ($permanentflags2);
-		# compare flags - add missing flags
-		my @ff = split(' ', $flags_f );
-		my %ft = map { $_ => 1 } split(' ', $flags_t );
-		my @flags_a = map { exists $ft{$_} ? () : $_ } @ff;
+		$h1_flags =~ s@\\Recent\s?@@gi;
+		$h1_flags = flags_regex($h1_flags) if @regexflag;
+		$h1_flags = flags_filter($h1_flags, $permanentflags2) if ($permanentflags2);
+		
+		
+		# compare flags - set flags if there a diffrence
+		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
-		if (!$dry and @flags_a and !$imap2->store($h2_msg, "+FLAGS.SILENT (@flags_a)") ) {
-			warn "Could not add flags '@flags_a' flagf '$flags_f'",
-			  " flagt '$flags_t' on msg #$h2_msg in $h2_fold: ",
+		# This sets flags so flags can be removed with this
+		# When you remove a \Seen flag on host1 you want to it
+		# to be removed on host2. Just add flags is not what 
+		# 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",
-			      "flags to  : @flags_t\n";
+			print "host1 flags: $h1_flags\n",
+			      "host2 flags: @h2_flags\n";
 
 			print "Looking dates\n"; 
-			#my $d_f = $imap1->internaldate($h1_msg);
-			#my $d_t = $imap2->internaldate($h2_msg);
-			my $d_f = $h1_hash{$m_id}{'D'};
-			my $d_t = $h2_hash{$m_id}{'D'};
+			#my $h1_idate = $imap1->internaldate($h1_msg);
+			#my $h2_idate = $imap2->internaldate($h2_msg);
+			my $h1_idate = $h1_hash{$m_id}{'D'};
+			my $h2_idate = $h2_hash{$m_id}{'D'};
 			print 
-			  "idate from: $d_f\n",
-			    "idate to  : $d_t\n";
+			  "host1 internal date: $h1_idate\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) 
-		if 	defined ($IO::Socket::INET::VERSION) 
-		and 	$IO::Socket::INET::VERSION eq '1.25' 
-		and 	!$self->Port;
+	$debug and print "Entering myconnect\n";
 	%$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 \
-                --allow3xx
+                --debug
+                
                 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 \
-            --allow3xx
+                --justconnect
 }
 
+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