From 95aab825e8f78ec9ecf159c5f3282fabde5a6893 Mon Sep 17 00:00:00 2001 From: Nick Bebout Date: Sat, 12 Mar 2011 02:44:51 +0000 Subject: [PATCH] 1.303 --- ChangeLog | 23 +- .../COPYRIGHT | 0 .../Changes | 21 ++ .../INSTALL | 0 .../MANIFEST | 2 + .../META.yml | 2 +- .../Makefile.PL | 0 .../README | 0 .../TODO | 0 .../examples/build_dist.pl | 0 .../examples/build_ldif.pl | 0 .../examples/cleanTest.pl | 0 .../examples/copy_folder.pl | 0 .../examples/cyrus_expire.pl | 0 .../examples/cyrus_expunge.pl | 0 .../examples/find_dup_msgs.pl | 0 .../examples/imap_to_mbox.pl | 0 .../examples/imtestExample.pl | 0 .../examples/migrate_mail2.pl | 0 .../examples/migrate_mbox.pl | 0 .../examples/populate_mailbox.pl | 0 .../examples/sharedFolder.pl | 0 .../lib/Mail/IMAPClient.pm | 190 +++++++++----- .../lib/Mail/IMAPClient.pod | 131 +++++++--- .../lib/Mail/IMAPClient/BodyStructure.pm | 2 +- .../IMAPClient/BodyStructure/Parse.grammar | 0 .../Mail/IMAPClient/BodyStructure/Parse.pm | 0 .../Mail/IMAPClient/BodyStructure/Parse.pod | 0 .../lib/Mail/IMAPClient/MessageSet.pm | 0 .../lib/Mail/IMAPClient/Thread.grammar | 0 .../lib/Mail/IMAPClient/Thread.pm | 0 .../lib/Mail/IMAPClient/Thread.pod | 0 .../prepare_dist | 0 .../sample.perldb | 0 .../t/basic.t | 0 .../t/bodystructure.t | 0 Mail-IMAPClient-3.21/t/fetch_hash.t | 233 ++++++++++++++++++ .../t/messageset.t | 0 .../t/pod.t | 0 Mail-IMAPClient-3.21/t/simple.t | 36 +++ .../t/thread.t | 0 .../test_template.txt | 0 Makefile | 11 +- README | 15 +- TODO | 69 +++--- VERSION | 2 +- imapsync | 226 +++++++++++------ learn/imapclient_tls | 81 ++++++ tests.sh | 75 +++++- 49 files changed, 885 insertions(+), 234 deletions(-) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/COPYRIGHT (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/Changes (99%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/INSTALL (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/MANIFEST (97%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/META.yml (97%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/Makefile.PL (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/README (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/TODO (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/build_dist.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/build_ldif.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/cleanTest.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/copy_folder.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/cyrus_expire.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/cyrus_expunge.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/find_dup_msgs.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/imap_to_mbox.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/imtestExample.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/migrate_mail2.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/migrate_mbox.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/populate_mailbox.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/examples/sharedFolder.pl (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient.pm (95%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient.pod (97%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient/BodyStructure.pm (99%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient/BodyStructure/Parse.grammar (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient/BodyStructure/Parse.pm (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient/BodyStructure/Parse.pod (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient/MessageSet.pm (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient/Thread.grammar (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient/Thread.pm (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/lib/Mail/IMAPClient/Thread.pod (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/prepare_dist (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/sample.perldb (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/t/basic.t (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/t/bodystructure.t (100%) create mode 100644 Mail-IMAPClient-3.21/t/fetch_hash.t rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/t/messageset.t (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/t/pod.t (100%) create mode 100644 Mail-IMAPClient-3.21/t/simple.t rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/t/thread.t (100%) rename {Mail-IMAPClient-3.19 => Mail-IMAPClient-3.21}/test_template.txt (100%) create mode 100755 learn/imapclient_tls diff --git a/ChangeLog b/ChangeLog index fdd8367..fbf4aaf 100644 --- a/ChangeLog +++ b/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_* diff --git a/Mail-IMAPClient-3.19/COPYRIGHT b/Mail-IMAPClient-3.21/COPYRIGHT similarity index 100% rename from Mail-IMAPClient-3.19/COPYRIGHT rename to Mail-IMAPClient-3.21/COPYRIGHT diff --git a/Mail-IMAPClient-3.19/Changes b/Mail-IMAPClient-3.21/Changes similarity index 99% rename from Mail-IMAPClient-3.19/Changes rename to Mail-IMAPClient-3.21/Changes index 3e4c5ac..fc8b7ab 100644 --- a/Mail-IMAPClient-3.19/Changes +++ b/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] diff --git a/Mail-IMAPClient-3.19/INSTALL b/Mail-IMAPClient-3.21/INSTALL similarity index 100% rename from Mail-IMAPClient-3.19/INSTALL rename to Mail-IMAPClient-3.21/INSTALL diff --git a/Mail-IMAPClient-3.19/MANIFEST b/Mail-IMAPClient-3.21/MANIFEST similarity index 97% rename from Mail-IMAPClient-3.19/MANIFEST rename to Mail-IMAPClient-3.21/MANIFEST index 224175c..f71af2b 100644 --- a/Mail-IMAPClient-3.19/MANIFEST +++ b/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) diff --git a/Mail-IMAPClient-3.19/META.yml b/Mail-IMAPClient-3.21/META.yml similarity index 97% rename from Mail-IMAPClient-3.19/META.yml rename to Mail-IMAPClient-3.21/META.yml index afc59e5..b26bb35 100644 --- a/Mail-IMAPClient-3.19/META.yml +++ b/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: diff --git a/Mail-IMAPClient-3.19/Makefile.PL b/Mail-IMAPClient-3.21/Makefile.PL similarity index 100% rename from Mail-IMAPClient-3.19/Makefile.PL rename to Mail-IMAPClient-3.21/Makefile.PL diff --git a/Mail-IMAPClient-3.19/README b/Mail-IMAPClient-3.21/README similarity index 100% rename from Mail-IMAPClient-3.19/README rename to Mail-IMAPClient-3.21/README diff --git a/Mail-IMAPClient-3.19/TODO b/Mail-IMAPClient-3.21/TODO similarity index 100% rename from Mail-IMAPClient-3.19/TODO rename to Mail-IMAPClient-3.21/TODO diff --git a/Mail-IMAPClient-3.19/examples/build_dist.pl b/Mail-IMAPClient-3.21/examples/build_dist.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/build_dist.pl rename to Mail-IMAPClient-3.21/examples/build_dist.pl diff --git a/Mail-IMAPClient-3.19/examples/build_ldif.pl b/Mail-IMAPClient-3.21/examples/build_ldif.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/build_ldif.pl rename to Mail-IMAPClient-3.21/examples/build_ldif.pl diff --git a/Mail-IMAPClient-3.19/examples/cleanTest.pl b/Mail-IMAPClient-3.21/examples/cleanTest.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/cleanTest.pl rename to Mail-IMAPClient-3.21/examples/cleanTest.pl diff --git a/Mail-IMAPClient-3.19/examples/copy_folder.pl b/Mail-IMAPClient-3.21/examples/copy_folder.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/copy_folder.pl rename to Mail-IMAPClient-3.21/examples/copy_folder.pl diff --git a/Mail-IMAPClient-3.19/examples/cyrus_expire.pl b/Mail-IMAPClient-3.21/examples/cyrus_expire.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/cyrus_expire.pl rename to Mail-IMAPClient-3.21/examples/cyrus_expire.pl diff --git a/Mail-IMAPClient-3.19/examples/cyrus_expunge.pl b/Mail-IMAPClient-3.21/examples/cyrus_expunge.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/cyrus_expunge.pl rename to Mail-IMAPClient-3.21/examples/cyrus_expunge.pl diff --git a/Mail-IMAPClient-3.19/examples/find_dup_msgs.pl b/Mail-IMAPClient-3.21/examples/find_dup_msgs.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/find_dup_msgs.pl rename to Mail-IMAPClient-3.21/examples/find_dup_msgs.pl diff --git a/Mail-IMAPClient-3.19/examples/imap_to_mbox.pl b/Mail-IMAPClient-3.21/examples/imap_to_mbox.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/imap_to_mbox.pl rename to Mail-IMAPClient-3.21/examples/imap_to_mbox.pl diff --git a/Mail-IMAPClient-3.19/examples/imtestExample.pl b/Mail-IMAPClient-3.21/examples/imtestExample.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/imtestExample.pl rename to Mail-IMAPClient-3.21/examples/imtestExample.pl diff --git a/Mail-IMAPClient-3.19/examples/migrate_mail2.pl b/Mail-IMAPClient-3.21/examples/migrate_mail2.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/migrate_mail2.pl rename to Mail-IMAPClient-3.21/examples/migrate_mail2.pl diff --git a/Mail-IMAPClient-3.19/examples/migrate_mbox.pl b/Mail-IMAPClient-3.21/examples/migrate_mbox.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/migrate_mbox.pl rename to Mail-IMAPClient-3.21/examples/migrate_mbox.pl diff --git a/Mail-IMAPClient-3.19/examples/populate_mailbox.pl b/Mail-IMAPClient-3.21/examples/populate_mailbox.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/populate_mailbox.pl rename to Mail-IMAPClient-3.21/examples/populate_mailbox.pl diff --git a/Mail-IMAPClient-3.19/examples/sharedFolder.pl b/Mail-IMAPClient-3.21/examples/sharedFolder.pl similarity index 100% rename from Mail-IMAPClient-3.19/examples/sharedFolder.pl rename to Mail-IMAPClient-3.21/examples/sharedFolder.pl diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient.pm b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient.pm similarity index 95% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient.pm rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient.pm index 0d0baa2..db85e5b 100644 --- a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient.pm +++ b/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 - (?:" # 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 diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient.pod b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient.pod similarity index 97% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient.pod rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient.pod index 1e44874..34aed3b 100644 --- a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient.pod +++ b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient.pod @@ -754,16 +754,14 @@ Example: $imap->close or die "Could not close: $@\n"; -The B 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 method) will now be -deleted. If you haven't deleted any messages then B can be -thought of as an "unselect". +The B 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 +method) will now be deleted. If you haven't deleted any messages then +B 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, L, and RFC3501. @@ -1063,19 +1061,14 @@ Example: The B 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 method does, -which is especially interesting given that the L method -doesn't technically exist. In case you're curious, expunging a folder -deletes the messages that you thought were already deleted via -L 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 method does. +Note: expunging a folder deletes the messages that have the \Deleted +flag set (i.e. messages flagged via L). -Or you could use the L method, which deselects as well as -expunges and which likewise doesn't technically exist. +See also the L method, which "deselects" as well as expunges. =head2 fetch @@ -1168,27 +1161,12 @@ This would result in L output similar to the following: } }; -You can specify I 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 -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-Efetch_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 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 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: + + $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 returns undef on failure. +If the server does not support the UIDPLUS extension, this method +returns undef. + =head2 uidnext Example: diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure.pm b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure.pm similarity index 99% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure.pm rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure.pm index 486ea53..31dc16e 100644 --- a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure.pm +++ b/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 diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure/Parse.grammar b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure/Parse.grammar similarity index 100% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure/Parse.grammar rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure/Parse.grammar diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure/Parse.pm b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure/Parse.pm similarity index 100% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure/Parse.pm rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure/Parse.pm diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure/Parse.pod b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure/Parse.pod similarity index 100% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient/BodyStructure/Parse.pod rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient/BodyStructure/Parse.pod diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/MessageSet.pm b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient/MessageSet.pm similarity index 100% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient/MessageSet.pm rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient/MessageSet.pm diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/Thread.grammar b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient/Thread.grammar similarity index 100% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient/Thread.grammar rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient/Thread.grammar diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/Thread.pm b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient/Thread.pm similarity index 100% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient/Thread.pm rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient/Thread.pm diff --git a/Mail-IMAPClient-3.19/lib/Mail/IMAPClient/Thread.pod b/Mail-IMAPClient-3.21/lib/Mail/IMAPClient/Thread.pod similarity index 100% rename from Mail-IMAPClient-3.19/lib/Mail/IMAPClient/Thread.pod rename to Mail-IMAPClient-3.21/lib/Mail/IMAPClient/Thread.pod diff --git a/Mail-IMAPClient-3.19/prepare_dist b/Mail-IMAPClient-3.21/prepare_dist similarity index 100% rename from Mail-IMAPClient-3.19/prepare_dist rename to Mail-IMAPClient-3.21/prepare_dist diff --git a/Mail-IMAPClient-3.19/sample.perldb b/Mail-IMAPClient-3.21/sample.perldb similarity index 100% rename from Mail-IMAPClient-3.19/sample.perldb rename to Mail-IMAPClient-3.21/sample.perldb diff --git a/Mail-IMAPClient-3.19/t/basic.t b/Mail-IMAPClient-3.21/t/basic.t similarity index 100% rename from Mail-IMAPClient-3.19/t/basic.t rename to Mail-IMAPClient-3.21/t/basic.t diff --git a/Mail-IMAPClient-3.19/t/bodystructure.t b/Mail-IMAPClient-3.21/t/bodystructure.t similarity index 100% rename from Mail-IMAPClient-3.19/t/bodystructure.t rename to Mail-IMAPClient-3.21/t/bodystructure.t diff --git a/Mail-IMAPClient-3.21/t/fetch_hash.t b/Mail-IMAPClient-3.21/t/fetch_hash.t new file mode 100644 index 0000000..179ebf5 --- /dev/null +++ b/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: +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 ; 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: +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 ; 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 ); diff --git a/Mail-IMAPClient-3.19/t/messageset.t b/Mail-IMAPClient-3.21/t/messageset.t similarity index 100% rename from Mail-IMAPClient-3.19/t/messageset.t rename to Mail-IMAPClient-3.21/t/messageset.t diff --git a/Mail-IMAPClient-3.19/t/pod.t b/Mail-IMAPClient-3.21/t/pod.t similarity index 100% rename from Mail-IMAPClient-3.19/t/pod.t rename to Mail-IMAPClient-3.21/t/pod.t diff --git a/Mail-IMAPClient-3.21/t/simple.t b/Mail-IMAPClient-3.21/t/simple.t new file mode 100644 index 0000000..335e121 --- /dev/null +++ b/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" ); + } + } +} diff --git a/Mail-IMAPClient-3.19/t/thread.t b/Mail-IMAPClient-3.21/t/thread.t similarity index 100% rename from Mail-IMAPClient-3.19/t/thread.t rename to Mail-IMAPClient-3.21/t/thread.t diff --git a/Mail-IMAPClient-3.19/test_template.txt b/Mail-IMAPClient-3.21/test_template.txt similarity index 100% rename from Mail-IMAPClient-3.19/test_template.txt rename to Mail-IMAPClient-3.21/test_template.txt diff --git a/Makefile b/Makefile index 105f4bd..faa39cd 100644 --- a/Makefile +++ b/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 diff --git a/README b/README index e41cab4..58caabb 100644 --- a/README +++ b/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 ] [--user2 ] [--passfile2 ] [--ssl1] [--ssl2] + [--tls1] [--tls2] [--authmech1 ] [--authmech2 ] [--noauthmd5] [--folder --folder ...] @@ -73,7 +74,7 @@ SYNOPSIS [--split1] [--split2] [--reconnectretry1 ] [--reconnectretry2 ] [--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 $ diff --git a/TODO b/TODO index a14c321..e625b7c 100644 --- a/TODO +++ b/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' diff --git a/VERSION b/VERSION index 55336d1..47cecd0 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.300 +1.303 diff --git a/imapsync b/imapsync index 63e947b..1732676 100755 --- a/imapsync +++ b/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 ] [--user2 ] [--passfile2 ] [--ssl1] [--ssl2] + [--tls1] [--tls2] [--authmech1 ] [--authmech2 ] [--noauthmd5] [--folder --folder ...] @@ -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 : 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 : sync this folder. --folder : and this one, etc. --folderrec : 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 : 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}; +} + diff --git a/learn/imapclient_tls b/learn/imapclient_tls new file mode 100755 index 0000000..fb14100 --- /dev/null +++ b/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(); diff --git a/tests.sh b/tests.sh index 69d25f4..3f1d671 100644 --- a/tests.sh +++ b/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