Context Navigation

source: npl/mailserver/imapsync/imapsync @ ac00c8f

Last change on this file since ac00c8f was c5c522c, checked in by Edwin Eefting <edwin@datux.nl>, 8 years ago
initial commit, transferred from cleaned syn3 svn tree
Property mode set to `100644`
File size: 83.6 KB

Line
1	#!/usr/bin/perl
2
3	=pod
4
5	=head1 NAME
6
7	imapsync - IMAP synchronisation, sync, copy or migration
8	tool. Synchronise mailboxes between two imap servers. Good
9	at IMAP migration. More than 32 different IMAP server softwares
10	supported with success.
11
12	$Revision: 1.267 $
13
14	=head1 INSTALL
15
16	imapsync works fine under any Unix OS with perl.
17	imapsync works fine under Windows (2000, XP) and ActiveState's 5.8 Perl
18
19	imapsync is already available directly on the following distributions (at least):
20	FreeBSD, Debian, Ubuntu, Gentoo, NetBSD, Darwin, Mandriva and OpenBSD (yeah!).
21
22	Get imapsync at
23	http://www.linux-france.org/prj/imapsync/dist/
24
25	You'll find a compressed tarball called imapsync-x.xx.tgz
26	where x.xx is the version number. Untar the tarball where
27	you want (on Unix):
28
29	tar xzvf imapsync-x.xx.tgz
30
31	Go into the directory imapsync-x.xx and read the INSTALL file.
32	The INSTALL file is also at
33	http://www.linux-france.org/prj/imapsync/INSTALL (for windows users)
34
35	The freshmeat record is at http://freshmeat.net/projects/imapsync/
36
37	=head1 SYNOPSIS
38
39	imapsync [options]
40
41	To get a description of each option just run imapsync like this :
42
43	imapsync --help
44	imapsync
45
46	The option list :
47
48	imapsync [--host1 server1] [--port1 <num>]
49	[--user1 <string>] [--passfile1 <string>]
50	[--host2 server2] [--port2 <num>]
51	[--user2 <string>] [--passfile2 <string>]
52	[--ssl1] [--ssl2]
53	[--authmech1 <string>] [--authmech2 <string>]
54	[--noauthmd5]
55	[--folder <string> --folder <string> ...]
56	[--folderrec <string> --folderrec <string> ...]
57	[--include <regex>] [--exclude <regex>]
58	[--prefix2 <string>] [--prefix1 <string>]
59	[--regextrans2 <regex> --regextrans2 <regex> ...]
60	[--sep1 <char>]
61	[--sep2 <char>]
62	[--justfolders] [--justfoldersizes] [--justconnect]
63	[--syncinternaldates]
64	[--idatefromheader]
65	[--buffersize <int>]
66	[--syncacls]
67	[--regexmess <regex>] [--regexmess <regex>]
68	[--maxsize <int>]
69	[--maxage <int>]
70	[--minage <int>]
71	[--skipheader <regex>]
72	[--useheader <string>] [--useheader <string>]
73	[--skipsize]
74	[--delete] [--delete2]
75	[--expunge] [--expunge1] [--expunge2]
76	[--subscribed] [--subscribe]
77	[--nofoldersizes]
78	[--dry]
79	[--debug] [--debugimap]
80	[--timeout <int>] [--fast]
81	[--split1] [--split2]
82	[--version] [--help]
83
84	=cut
85	# comment
86
87	=pod
88
89	=head1 DESCRIPTION
90
91	The command imapsync is a tool allowing incremental and
92	recursive imap transfer from one mailbox to another.
93
94	By default all folders are transfered, recursively.
95
96	We sometimes need to transfer mailboxes from one imap server to
97	another. This is called migration.
98
99	imapsync is the adequate tool because it reduces the amount
100	of data transferred by not transferring a given message if it
101	is already on both sides. Same headers, same message size
102	and the transfer is done only once. All flags are
103	preserved, unread will stay unread, read will stay read,
104	deleted will stay deleted. You can stop the transfer at any
105	time and restart it later, imapsync is adapted to a bad
106	connection. imapsync is CPU hungry so nice and renice
107	commands can be a good help. imapsync can be memory hungry too,
108	especially with large messages.
109
110	You can decide to delete the messages from the source mailbox
111	after a successful transfer (it is a good feature when migrating).
112	In that case, use the --delete --expunge1 options.
113
114	You can also just synchronize a mailbox A from another mailbox B
115	in case you just want to keep a "live" copy of B in A.
116
117	=head1 OPTIONS
118
119	To get a description of each option just invoke:
120
121	imapsync --help
122
123	=head1 HISTORY
124
125	I wrote imapsync because an enterprise (basystemes) paid me to install
126	a new imap server without loosing huge old mailboxes located on a far
127	away remote imap server accessible by a low bandwith link. The tool
128	imapcp (written in python) could not help me because I had to verify
129	every mailbox was well transferred and delete it after a good
130	transfer. imapsync started its life being a copy_folder.pl patch.
131	The tool copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl
132	module tarball source (in the examples/ directory of the tarball).
133
134	=head1 EXAMPLE
135
136	While working on imapsync parameters please run imapsync in
137	dry mode (no modification induced) with the --dry
138	option. Nothing bad can be done this way.
139
140	To synchronize the imap account "buddy" on host
141	"imap.src.fr" to the imap account "max" on host
142	"imap.dest.fr" (the passwords are located in two files
143	"/etc/secret1" for "buddy", "/etc/secret2" for "max") :
144
145	imapsync --host1 imap.src.fr --user1 buddy --passfile1 /etc/secret1 \
146	--host2 imap.dest.fr --user2 max --passfile2 /etc/secret2
147
148	Then, you will have max's mailbox updated from buddy's
149	mailbox.
150
151	=head1 SECURITY
152
153	You can use --password1 instead of --passfile1 to give the
154	password but it is dangerous because any user on your host
155	can see the password by using the 'ps auxwwww'
156	command. Using a variable (like $PASSWORD1) is also
157	dangerous because of the 'ps auxwwwwe' command. So, saving
158	the password in a well protected file (600 or rw-------) is
159	the best solution.
160
161	imasync is not totally protected against sniffers on the
162	network since passwords may be transferred in plain text in
163	case CRAM-MD5 is not supported by your imap servers. Use
164	--ssl1 and --ssl2 to enable encryption on host1 and host2.
165
166	You may authenticate as one user (typically an admin user),
167	but be authorized as someone else, which means you don't
168	need to know every user's personal password. Specify
169	--authuser1 "adminuser" to enable this on host1. In this
170	case, --authmech1 PLAIN will be used by default since it
171	is the only way to go for now. So don't use --authmech1 SOMETHING
172	with --authuser1 "adminuser", it will not work.
173	Same behavior with the --authuser2 option.
174
175
176	=head1 EXIT STATUS
177
178	imapsync will exit with a 0 status (return code) if everything went good.
179	Otherwise, it exits with a non-zero status.
180
181	So if you have a buggy internet connection, you can use this loop
182	in a Bourne shell:
183
184	while ! imapsync ...; do
185	echo imapsync not complete
186	done
187
188	=head1 AUTHOR
189
190	Gilles LAMIRAL <lamiral@linux-france.org>
191
192	Feedback good or bad is always welcome.
193
194	The newsgroup comp.mail.imap is a good place to talk about
195	imapsync. I read it when imapsync is concerned.
196
197	Gilles LAMIRAL earn his living writing, installing,
198	configuring and teaching free open and gratis
199	softwares. Do not hesitate to pay him for that services.
200
201
202	=head1 LICENSE
203
204	imapsync is free, gratis and open source software cover by
205	the GNU General Public License. See the GPL file included in
206	the distribution or the web site
207	http://www.gnu.org/licenses/licenses.html
208
209	=head1 MAILING-LIST
210
211	Here is the welcome message:
212
213	Welcome on the imapsync mailing-list.
214
215	This list is dedicated to the users of imapsync
216	http://www.linux-france.org/prj/imapsync/
217
218	To write on the list, the address is:
219	mailto:imapsync@linux-france.org
220
221	To unsubscribe, send a message to:
222	mailto:imapsync-unsubscribe@listes.linux-france.org
223
224	To subscribe, send a message to:
225	mailto:imapsync-subscribe@listes.linux-france.org
226
227	To contact the person in charge for the list:
228	mailto:imapsync-request@listes.linux-france.org
229
230	The list archives may be available at:
231	http://www.linux-france.org/prj/imapsync_list/
232	So consider that the list is public, anyone
233	can see your post. Use a pseudonym or do not
234	post to this list if you want to stay private.
235
236	Thank you for your participation.
237
238	=head1 BUGS and BUG REPORT
239
240	No known serious bug.
241
242	Report any bug or feature request to the author
243	or the mailing-list.
244
245	Before reporting bugs, read the FAQ, this README and the
246	TODO files.
247
248	Don't write imapsync in uppercase in the email title, I'll
249	know you run windows and you haven't read the README yet.
250
251	Make a good title, not just "imapsync" or "problem",
252	a good title is made of keywords summary, not too long (one visible line).
253
254	Before reporting bugs, read the FAQ, this README and the
255	TODO files. http://www.linux-france.org/prj/imapsync/
256
257	Help me to help you: in your report, please include:
258
259	- imapsync version.
260	- output given with --debug --debugimap near the failure point.
261	- operating system running imapsync.
262	- imap servers softwares on both side and their version number.
263	- imapsync with all the options you use, the full command line
264	you use (except the passwords of course).
265	- IMAPClient.pm version.
266
267	Those values can be found as a copy/paste at the begining of the output.
268
269	And also, if it can help :
270
271	- operating systems on both sides and the third side in case
272	you run imapsync on a foreign host from the both.
273
274	=head1 IMAP SERVERS
275
276	Failure stories reported with the following 4 imap servers :
277
278	- MailEnable 1.54 (Proprietary) http://www.mailenable.com/
279	- DBMail 0.9, 2.0.7 (GPL). But DBMail 1.2.1 works.
280	Patient and confident testers are welcome.
281	- dkimap4 2.39
282	- Imail 7.04 (maybe).
283
284	Success stories reported with the following 35 imap servers
285	(softwares names are in alphabetic order) :
286
287	- Archiveopteryx 2.03, 2.04, 2.09, 2.10 [dest], 3.0.0 [dest]
288	(OSL 3.0) http://www.archiveopteryx.org/
289	- BincImap 1.2.3 (GPL) (http://www.bincimap.org/)
290	- CommuniGatePro server (Redhat 8.0)
291	- Courier IMAP 1.5.1, 2.2.0, 2.1.1, 2.2.1, 3.0.8, 3.0.3, 4.1.1 (GPL)
292	(http://www.courier-mta.org/)
293	- Critical Path (7.0.020)
294	- Cyrus IMAP 1.5, 1.6, 2.1, 2.1.15, 2.1.16, 2.1.18
295	2.2.1, 2.2.2-BETA, 2.2.10, 2.2.12,
296	v2.2.3-Invoca-RPM-2.2.3-8,
297	2.3-alpha (OSI Approved),
298	v2.2.12-Invoca-RPM-2.2.12-3.RHEL4.1,
299	2.2.13,
300	v2.3.1-Invoca-RPM-2.3.1-2.7.fc5,
301	v2.3.7,
302	(http://asg.web.cmu.edu/cyrus/)
303	- David Tobit V8 (proprietary Message system).
304	- DBMail 1.2.1, 2.0.4, 2.0.9, 2.2rc1 (GPL) (http://www.dbmail.org/).
305	2.0.7 seems buggy.
306	- Deerfield VisNetic MailServer 5.8.6 [from]
307	- Dovecot 0.99.10.4, 0.99.14, 0.99.14-8.fc4, 1.0-0.beta2.7,
308	1.0.0 [dest/source] (LGPL) (http://www.dovecot.org/)
309	- Domino (Notes) 4.61[from], 6.5, 5.0.6, 5.0.7, 7.0.2, 6.0.2CF1, 7.0.1 [from]
310	- Eudora WorldMail v2
311	- GMX IMAP4 StreamProxy.
312	- Groupwise IMAP (Novell) 6.x and 7.0. Buggy so see the FAQ.
313	- iPlanet Messaging server 4.15, 5.1, 5.2
314	- IMail 7.15 (Ipswitch/Win2003), 8.12
315	- MDaemon 7.0.1, 8.0.2, 8.1, 9.5.4 (Windows server 2003 R2 platform)
316	- Mercury 4.1 (Windows server 2000 platform)
317	- Microsoft Exchange Server 5.5, 6.0.6249.0[from], 6.5.7638.1 [dest]
318	- Netscape Mail Server 3.6 (Wintel !)
319	- Netscape Messaging Server 4.15 Patch 7
320	- OpenMail IMAP server B.07.00.k0 (Samsung Contact ?)
321	- OpenWave
322	- Qualcomm Worldmail (NT)
323	- Rockliffe Mailsite 5.3.11, 4.5.6
324	- Samsung Contact IMAP server 8.5.0
325	- Scalix v10.1, 10.0.1.3, 11.0.0.431
326	- SmarterMail
327	- SunONE Messaging server 5.2, 6.0 (SUN JES - Java Enterprise System)
328	- Sun Java System Messaging Server 6.2-2.05
329	- Surgemail 3.6f5-5
330	- UW-imap servers (imap-2000b) rijkkramer IMAP4rev1 2000.287
331	(RedHat uses UW like 2003.338rh), v12.264 Solaris 5.7 (OSI Approved)
332	(http://www.washington.edu/imap/)
333	- UW - QMail v2.1
334	- Imap part of TCP/IP suite of VMS 7.3.2
335	- Zimbra-IMAP 3.0.1 GA 160, 3.1.0 Build 279, 4.0.5, 4.5.2, 4.5.6, 5.5.
336
337	Please report to the author any success or bad story with
338	imapsync and do not forget to mention the IMAP server
339	software names and version on both sides. This will help
340	future users. To help the author maintaining this section
341	report the two lines at the begining of the output if they
342	are useful to know the softwares. Example:
343
344	From software :* OK louloutte Cyrus IMAP4 v1.5.19 server ready
345	To software :* OK Courier-IMAP ready
346
347	You can use option --justconnect to get those lines.
348	Example :
349
350	imapsync --host1 imap.troc.org --host2 imap.trac.org --justconnect
351
352	Please rate imapsync at http://freshmeat.net/projects/imapsync/
353	or better give the author a book, he likes books:
354	http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/
355	(or its paypal account gilles.lamiral@laposte.net)
356
357	=head1 HUGE MIGRATION
358
359
360	Have a special attention on options
361	--subscribed
362	--subscribe
363	--delete
364	--delete2
365	--expunge
366	--expunge1
367	--expunge2
368	--maxage
369	--minage
370	--maxsize
371	--useheader
372
373	If you have many mailboxes to migrate think about a little
374	shell program. Write a file called file.csv (for example)
375	containing users and passwords.
376	The separator used in this example is ';'
377
378	The file.csv file content is :
379
380	user0001;password0001;user0002;password0002
381	user0011;password0011;user0012;password0012
382	...
383
384	And the shell program is just :
385
386	{ while IFS=';' read u1 p1 u2 p2; do
387	imapsync --user1 "$u1" --password1 "$p1" --user2 "$u2" --password2 "$p2" ...
388	done ; } < file.csv
389
390	Welcome in shell programming !
391
392	=head1 Hacking
393
394	Feel free to hack imapsync as the GPL Licence permits it.
395
396	=head1 Links
397
398	Entries for imapsync:
399	http://www.imap.org/products/showall.php
400
401
402	=head1 SIMILAR SOFTWARES
403
404	imap_tools : http://www.athensfbc.com/imap_tools
405	offlineimap : http://software.complete.org/offlineimap
406	mailsync : http://mailsync.sourceforge.net/
407	imapxfer : http://www.washington.edu/imap/
408	part of the imap-utils from UW.
409	mailutil : replace imapxfer in
410	part of the imap-utils from UW.
411	http://www.gsp.com/cgi-bin/man.cgi?topic=mailutil
412	imaprepl : http://www.bl0rg.net/software/
413	http://freshmeat.net/projects/imap-repl/
414	imap_migrate : http://freshmeat.net/projects/imapmigration/
415	imapcopy : http://home.arcor.de/armin.diehl/imapcopy/imapcopy.html
416	migrationtool : http://sourceforge.net/projects/migrationtool/
417	imapmigrate : http://sourceforge.net/projects/cyrus-utils/
418	wonko_imapsync: http://wonko.com/article/554
419	see also tools/wonko_ruby_imapsync
420	pop2imap : http://www.linux-france.org/prj/pop2imap/
421
422
423	Feedback (good or bad) will be always welcome.
424
425	$Id: imapsync,v 1.267 2008/10/07 11:36:02 gilles Exp $
426
427
428
429	=cut
430
431
432	use warnings;
433	++$\|;
434	use strict;
435	use Carp;
436	use Getopt::Long;
437	use Mail::IMAPClient;
438	use Digest::MD5 qw(md5_base64);
439	#use Term::ReadKey;
440	#use IO::Socket::SSL;
441	use MIME::Base64;
442	use English;
443	use POSIX qw(uname);
444	use Fcntl;
445
446	#use Test::Simple tests => 1;
447	use Test::More 'no_plan';
448
449	eval { require 'usr/include/sysexits.ph' };
450
451
452	my(
453	$rcs, $debug, $debugimap, $error,
454	$host1, $host2, $port1, $port2,
455	$user1, $user2, $password1, $password2, $passfile1, $passfile2,
456	@folder, @include, @exclude, @folderrec,
457	$prefix1, $prefix2,
458	@regextrans2, @regexmess, @regexflag,
459	$sep1, $sep2,
460	$syncinternaldates,
461	$idatefromheader,
462	$syncacls,
463	$fastio1, $fastio2,
464	$maxsize, $maxage, $minage,
465	$skipheader, @useheader,
466	$skipsize, $foldersizes, $buffersize,
467	$delete, $delete2,
468	$expunge, $expunge1, $expunge2, $dry,
469	$justfoldersizes,
470	$authmd5,
471	$subscribed, $subscribe,
472	$version, $VERSION, $help,
473	$justconnect, $justfolders,
474	$fast,
475	$nohash,
476	$mess_size_total_trans,
477	$mess_size_total_skipped,
478	$mess_size_total_error,
479	$mess_trans, $mess_skipped, $mess_skipped_dry,
480	$timeout, # whr (ESS/PRW)
481	$timestart, $timeend, $timediff,
482	$timesize, $timebefore,
483	$ssl1, $ssl2,
484	$authuser1, $authuser2,
485	$authmech1, $authmech2,
486	$split1, $split2,
487	$tests, $test_builder,
488	$allow3xx,
489	);
490
491	use vars qw ($opt_G); # missing code for this will be option.
492
493
494	$rcs = '$Id: imapsync,v 1.267 2008/10/07 11:36:02 gilles Exp $ ';
495	$rcs =~ m/,v (\d+\.\d+)/;
496	$VERSION = ($1) ? $1 : "UNKNOWN";
497
498	my $VERSION_IMAPClient = $Mail::IMAPClient::VERSION;
499
500
501
502	$mess_size_total_trans = 0;
503	$mess_size_total_skipped = 0;
504	$mess_size_total_error = 0;
505	$mess_trans = $mess_skipped = $mess_skipped_dry = 0;
506
507
508	sub check_lib_version {
509	$debug and print "VERSION_IMAPClient $1 $2 $3\n";
510	if ($VERSION_IMAPClient eq '2.2.9') {
511	override_imapclient();
512	return(1);
513	}
514	else{
515	# 3.x.x is still buggy with imapsync.
516	# uncomment "return 1" if you want to check it.
517	#return 1;
518	#return 0;
519	if ($allow3xx) {
520	*Mail::IMAPClient::Ssl = sub {
521	my $self = shift;
522
523	if (@_) { $self->{SSL} = shift }
524	return $self->{SSL};
525	};
526	return(1);
527
528	}else{
529	return(0);
530	}
531	}
532	}
533
534	$error=0;
535
536	sub modules_VERSION() {
537
538	no warnings 'uninitialized';
539	my $modules_releases = "
540	Mail::IMAPClient $Mail::IMAPClient::VERSION
541	IO::Socket $IO::Socket::VERSION
542	IO::Socket::SSL $IO::Socket::SSL::VERSION
543	Digest::MD5 $Digest::MD5::VERSION
544	Digest::HMAC_MD5 $Digest::HMAC_MD5::VERSION
545	Term::ReadKey $Term::ReadKey::VERSION
546	Date::Manip $Date::Manip::VERSION
547	";
548	return($modules_releases);
549
550	}
551
552
553	my $banner = join("",
554	'$RCSfile: imapsync,v $ ',
555	'$Revision: 1.267 $ ',
556	'$Date: 2008/10/07 11:36:02 $ ',
557	"\n",localhost_info(),
558	" and the module Mail::IMAPClient version used here is ",
559	$VERSION_IMAPClient,"\n",
560	"Command line used :\n",
561	"$0 @ARGV\n",
562	);
563
564	unless(defined(&_SYSEXITS_H)) {
565	# 64 on my linux box.
566	eval 'sub EX_USAGE () {64;}' unless defined(&EX_USAGE);
567	}
568
569	get_options();
570
571	check_lib_version() or
572	die "imapsync needs perl lib Mail::IMAPClient release 2.2.9 exactly, future imapsync release may suppoort 3.0.x, but sorry not now. See file BUG_IMAPClient_3.xx\n";
573
574
575	print $banner;
576
577	sub missing_option {
578	my ($option) = @_;
579	die "$option option must be used, run $0 --help for help\n";
580	}
581
582	# By default, 1000 at a time, not more.
583	$split1 \|\|= 1000;
584	$split2 \|\|= 1000;
585
586	$host1 \|\| missing_option("--host1") ;
587	$port1 \|\|= defined $ssl1 ? 993 : 143;
588
589	$host2 \|\| missing_option("--host2") ;
590	$port2 \|\|= defined $ssl2 ? 993 : 143;
591
592
593
594	sub connect_imap {
595	my($host, $port, $debugimap, $ssl) = @_;
596	my $imap = Mail::IMAPClient->new();
597	$imap->Server($host);
598	$imap->Port($port);
599	$imap->Debug($debugimap);
600	$imap->Ssl($ssl) if ($ssl);
601	$imap->connect()
602	or die "Can not open imap connection on [$host] : $@\n";
603	}
604
605	sub localhost_info {
606
607	my($infos) = join("",
608	"Here is a [$OSNAME] system (",
609	join(" ",
610	uname(),
611	),
612	")\n",
613	"with perl ",
614	sprintf("%vd", $PERL_VERSION),
615	modules_VERSION()
616	);
617	return($infos);
618
619	}
620
621	if ($justconnect) {
622	my $from = ();
623	my $to = ();
624
625	$from = connect_imap($host1, $port1, $debugimap, $ssl1);
626	print "From software : ", server_banner($from);
627	print "From capability : ", join(" ", $from->capability()), "\n";
628	$to = connect_imap($host2, $port2, $debugimap, $ssl2);
629	print "To software : ", server_banner($to);
630	print "To capability : ", join(" ", $to->capability()), "\n";
631	$from->logout();
632	$to->logout();
633	exit(0);
634	}
635
636	$user1 \|\| missing_option("--user1");
637	$user2 \|\| missing_option("--user2");
638
639	$syncinternaldates = defined($syncinternaldates) ? defined($syncinternaldates) : 1;
640
641	if($idatefromheader) {
642	print "Turned ON idatefromheader, ",
643	"will set the internal dates on host2 from the 'Date:' header line.\n";
644	$syncinternaldates = 0;
645
646	}
647	if ($syncinternaldates) {
648	print "Turned ON syncinternaldates, ",
649	"will set the internal dates on host2 same as host1.\n";
650	}else{
651	print "Turned OFF syncinternaldates\n";
652	}
653
654	if ($syncinternaldates \|\| $idatefromheader) {
655	no warnings 'redefine';
656	local *Carp::confess = sub { return undef; };
657	require Date::Manip;
658	Date::Manip->import(qw(ParseDate Date_Cmp UnixDate Date_Init Date_TimeZone));
659	#print "Date_init : [", join(" ",Date_Init()), "]\n";
660	print "TimeZone :[", Date_TimeZone(), "]\n";
661	if (not (Date_TimeZone())) {
662	warn "TimeZone not defined, setting it to GMT";
663	Date_Init("TZ=GMT");
664	print "TimeZone : [", Date_TimeZone(), "]\n";
665	}
666	}
667
668
669	if(defined($authmd5) and not($authmd5)) {
670	$authmech1 \|\|= 'LOGIN';
671	$authmech2 \|\|= 'LOGIN';
672	}
673	else{
674	$authmech1 \|\|= $authuser1 ? 'PLAIN' : 'CRAM-MD5';
675	$authmech2 \|\|= $authuser2 ? 'PLAIN' : 'CRAM-MD5';
676	}
677
678	$authmech1 = uc($authmech1);
679	$authmech2 = uc($authmech2);
680
681	$authuser1 \|\|= $user1;
682	$authuser2 \|\|= $user2;
683
684	print "Will try to use $authmech1 authentication on host1\n";
685	print "Will try to use $authmech2 authentication on host2\n";
686
687	$syncacls = (defined($syncacls)) ? $syncacls : 0;
688	$foldersizes = (defined($foldersizes)) ? $foldersizes : 1;
689
690	$fastio1 = (defined($fastio1)) ? $fastio1 : 0;
691	$fastio2 = (defined($fastio2)) ? $fastio2 : 0;
692
693
694
695	@useheader = ("ALL") unless (@useheader);
696
697	print "From imap server [$host1] port [$port1] user [$user1]\n";
698	print "To imap server [$host2] port [$port2] user [$user2]\n";
699
700
701	sub ask_for_password {
702	my ($user, $host) = @_;
703	print "What's the password for $user\@$host? ";
704	Term::ReadKey::ReadMode(2);
705	my $password = <>;
706	chomp $password;
707	printf "\n";
708	Term::ReadKey::ReadMode(0);
709	return $password;
710	}
711
712
713	$password1 \|\| $passfile1 \|\| do {
714	$password1 = ask_for_password($authuser1 \|\| $user1, $host1);
715	};
716
717	$password1 = (defined($passfile1)) ? firstline ($passfile1) : $password1;
718
719	$password2 \|\| $passfile2 \|\| do {
720	$password2 = ask_for_password($authuser2 \|\| $user2, $host2);
721	};
722
723	$password2 = (defined($passfile2)) ? firstline ($passfile2) : $password2;
724
725	my $from = ();
726	my $to = ();
727
728	$timestart = time();
729	$timebefore = $timestart;
730
731	$debugimap and print "From connection\n";
732	$from = login_imap($host1, $port1, $user1, $password1,
733	$debugimap, $timeout, $fastio1, $ssl1,
734	$authmech1, $authuser1);
735
736	$debugimap and print "To connection\n";
737	$to = login_imap($host2, $port2, $user2, $password2,
738	$debugimap, $timeout, $fastio2, $ssl2,
739	$authmech2, $authuser2);
740
741	# history
742
743	$debug and print "From Buffer I/O : ", $from->Buffer(), "\n";
744	$debug and print "To Buffer I/O : ", $to->Buffer(), "\n";
745
746
747	sub login_imap {
748	my($host, $port, $user, $password,
749	$debugimap, $timeout, $fastio,
750	$ssl, $authmech, $authuser) = @_;
751	my ($imap);
752
753	$imap = Mail::IMAPClient->new();
754
755	$imap->Ssl($ssl) if ($ssl);
756	$imap->Clear(20);
757	$imap->Server($host);
758	$imap->Port($port);
759	$imap->Fast_io($fastio);
760	$imap->Buffer($buffersize \|\| 4096);
761	$imap->Uid(1);
762	$imap->Peek(1);
763	$imap->Debug($debugimap);
764	$timeout and $imap->Timeout($timeout);
765
766	$imap->connect()
767	or die "Can not open imap connection on [$host] with user [$user] : $@\n";
768
769	print "Banner : ", server_banner($imap);
770
771	if ($imap->has_capability("AUTH=$authmech")
772	or $imap->has_capability($authmech)
773	) {
774	printf("Host %s says it has CAPABILITY for AUTHENTICATE %s\n",
775	$imap->Server, $authmech);
776	}
777	else {
778	printf("Host %s says it has NO CAPABILITY for AUTHENTICATE %s\n",
779	$imap->Server, $authmech);
780	if ($authmech eq 'PLAIN') {
781	print "Frequently PLAIN is only supported with SSL, ",
782	"try --ssl1 or --ssl2 option\n";
783	}
784	}
785
786	$imap->Authmechanism($authmech) unless ($authmech eq 'LOGIN');
787	$imap->Authcallback(\&plainauth) if $authmech eq "PLAIN";
788
789	$imap->User($user);
790	$imap->Authuser($authuser);
791	$imap->Password($password);
792	unless ($imap->login()) {
793	print "Error login : [$host] with user [$user] auth [$authmech]: $@\n";
794	die if ($authmech eq 'LOGIN');
795	die if $imap->IsUnconnected();
796	print "Trying LOGIN Auth mechanism on [$host] with user [$user]\n";
797	$imap->Authmechanism("");
798	$imap->login() or
799	die "Error login : [$host] with user [$user] auth [LOGIN] : $@";
800	}
801	print "Success login on [$host] with user [$user] auth [$authmech]\n";
802	return($imap);
803	}
804
805	sub plainauth() {
806	my $code = shift;
807	my $imap = shift;
808
809	my $string = sprintf("%s\x00%s\x00%s", $imap->User,
810	$imap->Authuser, $imap->Password);
811	return encode_base64("$string", "");
812	}
813
814
815	sub server_banner {
816	my $imap = shift;
817	for my $line ($imap->Results()) {
818	#print "LR: $line";
819	return $line if $line =~ /^\* (OK\|NO\|BAD)/;
820	}
821	return "No banner\n";
822	}
823
824
825
826	print "From capability : ", join(" ", $from->capability()), "\n";
827	print "To capability : ", join(" ", $to->capability()), "\n";
828
829	die unless $from->IsAuthenticated();
830	print "From state Authenticated\n";
831	die unless $to->IsAuthenticated();
832	print "To state Authenticated\n";
833
834	$split1 and $from->Split($split1);
835	$split2 and $to->Split($split2);
836
837	#
838	# Folder stuff
839	#
840
841	my (@f_folders, %requested_folder, @t_folders, @t_folders_list, %t_folders_list, %subscribed_folder, %t_folders);
842
843	sub tests_folder_routines {
844	ok( !give_requested_folders() ,"no requested folders" );
845	ok( !is_requested_folder('folder_foo') );
846	ok( add_to_requested_folders('folder_foo') );
847	ok( is_requested_folder('folder_foo') );
848	ok( !is_requested_folder('folder_NO_EXIST') );
849	ok( !remove_from_requested_folders('folder_foo'), "removed folder_foo");
850	ok( !is_requested_folder('folder_foo') );
851	my @f;
852	ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f");
853	ok( is_requested_folder('folder_bar') );
854	ok( is_requested_folder('folder_toto') );
855	ok( remove_from_requested_folders('folder_toto') );
856	ok( !is_requested_folder('folder_toto') );
857	ok( init_requested_folders() , 'empty requested folders');
858	ok( !give_requested_folders() , 'no requested folders' );
859	}
860
861	sub give_requested_folders {
862	return(keys(%requested_folder));
863	}
864
865	sub init_requested_folders {
866
867	%requested_folder = ();
868	return(1);
869
870	}
871
872	sub is_requested_folder {
873	my ( $folder ) = @_;
874
875	defined( $requested_folder{ $folder } );
876	}
877
878
879	sub add_to_requested_folders {
880	my @wanted_folders = @_;
881
882	foreach my $folder ( @wanted_folders ) {
883	++$requested_folder{ $folder };
884	}
885	return( keys( %requested_folder ) );
886	}
887
888	sub remove_from_requested_folders {
889	my @wanted_folders = @_;
890
891	foreach my $folder (@wanted_folders) {
892	delete $requested_folder{$folder};
893	}
894	return( keys(%requested_folder) );
895	}
896
897
898	# Make a hash of subscribed folders in source server.
899	map { $subscribed_folder{$_} = 1 } $from->subscribed();
900
901
902	my @all_source_folders = sort $from->folders();
903
904	if (scalar(@folder) or $subscribed or scalar(@folderrec)) {
905	# folders given by option --folder
906	if (scalar(@folder)) {
907	add_to_requested_folders(@folder);
908	}
909
910	# option --subscribed
911	if ($subscribed) {
912	add_to_requested_folders(keys (%subscribed_folder));
913	}
914
915	# option --folderrec
916	if (scalar(@folderrec)) {
917	foreach my $folderrec (@folderrec) {
918	add_to_requested_folders($from->folders($folderrec));
919	}
920	}
921	}
922	else {
923
924	# no include, no folder/subscribed/folderrec options => all folders
925	if (not scalar(@include)) {
926	add_to_requested_folders(@all_source_folders);
927	}
928	}
929
930
931	# consider (optional) includes and excludes
932	if (scalar(@include)) {
933	foreach my $include (@include) {
934	my @included_folders = grep /$include/, @all_source_folders;
935	add_to_requested_folders(@included_folders);
936	print "Including folders matching pattern '$include': @included_folders\n";
937	}
938	}
939
940	if (scalar(@exclude)) {
941	foreach my $exclude (@exclude) {
942	my @requested_folder = sort(keys(%requested_folder));
943	my @excluded_folders = grep /$exclude/, @requested_folder;
944	remove_from_requested_folders(@excluded_folders);
945	print "Excluding folders matching pattern '$exclude': @excluded_folders\n";
946	}
947	}
948
949	# Remove no selectable folders
950
951	foreach my $folder (keys(%requested_folder)) {
952	if ( not $from->selectable($folder)) {
953	print "Warning : ignoring folder $folder because it is not selectable\n";
954	remove_from_requested_folders($folder);
955	}
956	}
957
958
959	my @requested_folder = sort(keys(%requested_folder));
960
961	@f_folders = @requested_folder;
962
963	sub compare_lists {
964	my ($list_1_ref, $list_2_ref) = @_;
965
966	return(-1) if ((not defined($list_1_ref)) and defined($list_2_ref));
967	return(0) if (! $list_1_ref); # end if no list
968	return(1) if (! $list_2_ref); # end if only one list
969
970	if (not ref($list_1_ref)) {$list_1_ref = [$list_1_ref]};
971	if (not ref($list_2_ref)) {$list_2_ref = [$list_2_ref]};
972
973
974	my $last_used_indice = 0;
975	ELEMENT:
976	foreach my $indice ( 0 .. $#$list_1_ref ) {
977	$last_used_indice = $indice;
978
979	# End of list_2
980	return 1 if ($indice > $#$list_2_ref);
981
982	my $element_list_1 = $list_1_ref->[$indice];
983	my $element_list_2 = $list_2_ref->[$indice];
984	my $balance = $element_list_1 cmp $element_list_2 ;
985	next ELEMENT if ($balance == 0) ;
986	return $balance;
987	}
988	# each element equal until last indice of list_1
989	return -1 if ($last_used_indice < $#$list_2_ref);
990
991	# same size, each element equal
992	return 0
993	}
994
995	sub tests_compare_lists {
996
997
998	my $empty_list_ref = [];
999
1000	ok( 0 == compare_lists() , 'compare_lists, no args');
1001	ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing');
1002	ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef');
1003	ok(-1 == compare_lists(undef , []) , 'compare_lists, undef < []');
1004	ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing');
1005	ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef');
1006	ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []');
1007
1008	ok( 0 == compare_lists([1], 1 ) , "compare_lists, [1] = 1 ") ;
1009	ok( 0 == compare_lists( 1 , [1]) , "compare_lists, 1 = [1]") ;
1010	ok( 0 == compare_lists( 1 , 1 ) , "compare_lists, 1 = 1 ") ;
1011	ok(-1 == compare_lists( 1 , 2 ) , "compare_lists, 1 = 1 ") ;
1012	ok(+1 == compare_lists( 2 , 1 ) , "compare_lists, 1 = 1 ") ;
1013
1014
1015	ok( 0 == compare_lists([1,2], [1,2]) , "compare_lists, [1,2] = [1,2]") ;
1016	ok(-1 == compare_lists([1], [1,2]) , "compare_lists, [1] < [1,2]") ;
1017	ok(-1 == compare_lists([1], [1,1]) , "compare_lists, [1] < [1,1]") ;
1018	ok(+1 == compare_lists([1, 1], [1]) , "compare_lists, [1, 1] > [1]") ;
1019	ok( 0 == compare_lists([1 .. 20_000] , [1 .. 20_000])
1020	, "compare_lists, [1..20_000] = [1..20_000]") ;
1021	ok(-1 == compare_lists([1], [3]) , 'compare_lists, [1] < [3]') ;
1022	ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ;
1023	ok(+1 == compare_lists([3], [1]) , 'compare_lists, [3] > [1]') ;
1024
1025	ok(-1 == compare_lists(["a"], ["b"]) , 'compare_lists, ["a"] < ["b"]') ;
1026	ok( 0 == compare_lists(["a"], ["a"]) , 'compare_lists, ["a"] = ["a"]') ;
1027	ok( 0 == compare_lists(["ab"], ["ab"]) , 'compare_lists, ["ab"] = ["ab"]') ;
1028	ok(+1 == compare_lists(["b"], ["a"]) , 'compare_lists, ["b"] > ["a"]') ;
1029	ok(-1 == compare_lists(["a"], ["aa"]) , 'compare_lists, ["a"] < ["aa"]') ;
1030	ok(-1 == compare_lists(["a"], ["a", "a"]), 'compare_lists, ["a"] < ["a", "a"]') ;
1031	}
1032
1033
1034
1035
1036
1037	my($f_sep,$t_sep);
1038	# what are the private folders separators for each server ?
1039
1040
1041	$debug and print "Getting separators\n";
1042	$f_sep = get_separator($from, $sep1, "--sep1");
1043	$t_sep = get_separator($to, $sep2, "--sep2");
1044
1045	#my $f_namespace = $from->namespace();
1046	#my $t_namespace = $to->namespace();
1047	#$debug and print "From namespace:\n", Data::Dumper->Dump([$f_namespace]);
1048	#$debug and print "To namespace:\n", Data::Dumper->Dump([$t_namespace]);
1049
1050	my($f_prefix,$t_prefix);
1051	$f_prefix = get_prefix($from, $prefix1, "--prefix1");
1052	$t_prefix = get_prefix($to, $prefix2, "--prefix2");
1053
1054	sub get_prefix {
1055	my($imap, $prefix_in, $prefix_opt) = @_;
1056	my($prefix_out);
1057
1058	$debug and print "Getting prefix namespace\n";
1059	if (defined($prefix_in)) {
1060	print "Using [$prefix_in] given by $prefix_opt\n";
1061	$prefix_out = $prefix_in;
1062	return($prefix_out);
1063	}
1064	$debug and print "Calling namespace capability\n";
1065	if ($imap->has_capability("namespace")) {
1066	my $r_namespace = $imap->namespace();
1067	$prefix_out = $r_namespace->[0][0][0];
1068	return($prefix_out);
1069	}
1070	else{
1071	print
1072	"No NAMESPACE capability in imap server ",
1073	$imap->Server(),"\n",
1074	"Give the prefix namespace with the $prefix_opt option\n";
1075	exit(1);
1076	}
1077	}
1078
1079
1080	sub get_separator {
1081	my($imap, $sep_in, $sep_opt) = @_;
1082	my($sep_out);
1083
1084
1085	if ($sep_in) {
1086	print "Using [$sep_in] given by $sep_opt\n";
1087	$sep_out = $sep_in;
1088	return($sep_out);
1089	}
1090	$debug and print "Calling namespace capability\n";
1091	if ($imap->has_capability("namespace")) {
1092	$sep_out = $imap->separator();
1093	return($sep_out);
1094	}
1095	else{
1096	print
1097	"No NAMESPACE capability in imap server ",
1098	$imap->Server(),"\n",
1099	"Give the separator caracter with the $sep_opt option\n";
1100	exit(1);
1101	}
1102	}
1103
1104
1105	print "From separator and prefix : [$f_sep][$f_prefix]\n";
1106	print "To separator and prefix : [$t_sep][$t_prefix]\n";
1107
1108
1109	sub foldersizes {
1110
1111	my ($side, $imap, $folders_r) = @_;
1112	my $tot = 0;
1113	my $tmess = 0;
1114	my @folders = @{$folders_r};
1115	print "++++ Calculating sizes ++++\n";
1116	foreach my $folder (@folders) {
1117	my $stot = 0;
1118	my $smess = 0;
1119	printf("$side Folder %-35s", "[$folder]");
1120	unless($imap->exists($folder)) {
1121	print("does not exist yet\n");
1122	next;
1123	}
1124	unless ($imap->select($folder)) {
1125	warn
1126	"$side Folder $folder : Could not select ",
1127	$imap->LastError, "\n";
1128	#$error++;
1129	next;
1130	}
1131	if (defined($maxage) or defined($minage)) {
1132	# The pb is fetch_hash() can only be applied on ALL messages
1133	my @msgs = select_msgs($imap);
1134	$smess = scalar(@msgs);
1135	foreach my $m (@msgs) {
1136	my $s = $imap->size($m)
1137	or warn "Could not find size of message $m: $@\n";
1138	$stot += $s;
1139	}
1140	}
1141	else{
1142	my $hashref = {};
1143	$smess = $imap->message_count();
1144	unless ($smess == 0) {
1145	#$imap->Ranges(1);
1146	$imap->fetch_hash("RFC822.SIZE",$hashref) or die "$@";
1147	#$imap->Ranges(0);
1148	#print map {$hashref->{$_}->{"RFC822.SIZE"}, " "} keys %$hashref;
1149	map {$stot += $hashref->{$_}->{"RFC822.SIZE"}} keys %$hashref;
1150	}
1151	}
1152	printf(" Size: %9s", $stot);
1153	printf(" Messages: %5s\n", $smess);
1154	$tot += $stot;
1155	$tmess += $smess;
1156	}
1157	print "Total size: $tot\n";
1158	print "Total messages: $tmess\n";
1159	print "Time : ", timenext(), " s\n";
1160	}
1161
1162
1163	foreach my $f_fold (@f_folders) {
1164	my $t_fold;
1165	$t_fold = to_folder_name($f_fold);
1166	$t_folders{$t_fold}++;
1167	}
1168
1169	@t_folders = sort keys(%t_folders);
1170
1171
1172	if ($foldersizes) {
1173	foldersizes("From", $from, \@f_folders);
1174	foldersizes("To ", $to, \@t_folders);
1175	}
1176
1177
1178
1179
1180	sub timenext {
1181	my ($timenow, $timerel);
1182	# $timebefore is global, beurk !
1183	$timenow = time;
1184	$timerel = $timenow - $timebefore;
1185	$timebefore = $timenow;
1186	return($timerel);
1187	}
1188
1189	exit if ($justfoldersizes);
1190
1191	# needed for setting flags
1192	my $tohasuidplus = $to->has_capability("UIDPLUS");
1193
1194
1195	@t_folders_list = sort @{$to->folders()};
1196	foreach my $folder (@t_folders_list) {
1197	$t_folders_list{$folder}++;
1198	}
1199
1200	print
1201	"++++ Listing folders ++++\n",
1202	"From folders list : ", map("[$_] ",@f_folders),"\n",
1203	"To folders list : ", map("[$_] ",@t_folders_list),"\n";
1204
1205	print
1206	"From subscribed folders list : ",
1207	map("[$_] ", sort keys(%subscribed_folder)), "\n"
1208	if ($subscribed);
1209
1210	sub separator_invert {
1211	# The separator we hope we'll never encounter
1212	my $o_sep="\000";
1213
1214	my($f_fold, $f_sep, $t_sep) = @_;
1215
1216	my $t_fold = $f_fold;
1217	$t_fold =~ s@\Q$t_sep@$o_sep@g;
1218	$t_fold =~ s@\Q$f_sep@$t_sep@g;
1219	$t_fold =~ s@\Q$o_sep@$f_sep@g;
1220	return($t_fold);
1221	}
1222
1223	sub to_folder_name {
1224	my ($t_fold);
1225	my ($x_fold) = @_;
1226	# first we remove the prefix
1227	$x_fold =~ s/^$f_prefix//;
1228	$debug and print "removed source prefix : [$x_fold]\n";
1229	$t_fold = separator_invert($x_fold,$f_sep, $t_sep);
1230	$debug and print "inverted separators : [$t_fold]\n";
1231	# Adding the prefix supplied by namespace or the --prefix2 option
1232	$t_fold = $t_prefix . $t_fold
1233	unless(($t_prefix eq "INBOX.") and ($t_fold =~ m/^INBOX$/i));
1234	$debug and print "added target prefix : [$t_fold]\n";
1235
1236	# Transforming the folder name by the --regextrans2 option(s)
1237	foreach my $regextrans2 (@regextrans2) {
1238	$debug and print "eval \$t_fold =~ $regextrans2\n";
1239	eval("\$t_fold =~ $regextrans2");
1240	}
1241	return($t_fold);
1242	}
1243
1244	sub flags_regex {
1245	my ($flags_f) = @_;
1246	foreach my $regexflag (@regexflag) {
1247	$debug and print "eval \$flags_f =~ $regexflag\n";
1248	eval("\$flags_f =~ $regexflag");
1249	}
1250	return($flags_f);
1251	}
1252
1253	sub acls_sync {
1254	my($f_fold, $t_fold) = @_;
1255	if ($syncacls) {
1256	my $f_hash = $from->getacl($f_fold)
1257	or warn "Could not getacl for $f_fold: $@\n";
1258	my $t_hash = $to->getacl($t_fold)
1259	or warn "Could not getacl for $t_fold: $@\n";
1260	my %users = map({ ($_, 1) } (keys(%$f_hash), keys(%$t_hash)));
1261	foreach my $user (sort(keys(%users))) {
1262	my $acl = $f_hash->{$user} \|\| "none";
1263	print "acl $user : [$acl]\n";
1264	next if ($f_hash->{$user} && $t_hash->{$user} &&
1265	$f_hash->{$user} eq $t_hash->{$user});
1266	unless ($dry) {
1267	print "setting acl $t_fold $user $acl\n";
1268	$to->setacl($t_fold, $user, $acl)
1269	or warn "Could not set acl: $@\n";
1270	}
1271	}
1272	}
1273	}
1274
1275
1276	print "++++ Looping on each folder ++++\n";
1277
1278	FOLDER: foreach my $f_fold (@f_folders) {
1279	my $t_fold;
1280	print "From Folder [$f_fold]\n";
1281	$t_fold = to_folder_name($f_fold);
1282	print "To Folder [$t_fold]\n";
1283
1284	last FOLDER if $from->IsUnconnected();
1285	last FOLDER if $to->IsUnconnected();
1286
1287	unless ($from->select($f_fold)) {
1288	warn
1289	"From Folder $f_fold : Could not select ",
1290	$from->LastError, "\n";
1291	#$error++;
1292	next FOLDER;
1293	}
1294	if ( ! exists($t_folders_list{$t_fold})) {
1295	print "To Folder $t_fold does not exist\n";
1296	print "Creating folder [$t_fold]\n";
1297	unless ($dry){
1298	unless ($to->create($t_fold)){
1299	warn "Couldn't create [$t_fold]",
1300	$to->LastError,"\n";
1301	$error++;
1302	next FOLDER;
1303	}
1304	}
1305	else{
1306	next FOLDER;
1307	}
1308	}
1309
1310	acls_sync($f_fold, $t_fold);
1311
1312	unless ($to->select($t_fold)) {
1313	warn
1314	"To Folder $t_fold : Could not select ",
1315	$to->LastError, "\n";
1316	#$error++;
1317	next FOLDER;
1318	}
1319
1320	if ($expunge){
1321	print "Expunging $f_fold and $t_fold\n";
1322	unless($dry) { $from->expunge() };
1323	#unless($dry) { $to->expunge() };
1324	}
1325
1326	if ($subscribe and exists $subscribed_folder{$f_fold}) {
1327	print "Subscribing to folder $t_fold on destination server\n";
1328	unless($dry) { $to->subscribe($t_fold) };
1329	}
1330
1331	next FOLDER if ($justfolders);
1332
1333	last FOLDER if $from->IsUnconnected();
1334	last FOLDER if $to->IsUnconnected();
1335
1336	my @f_msgs = select_msgs($from);
1337
1338
1339
1340	$debug and print "LIST FROM : ", scalar(@f_msgs), " messages [@f_msgs]\n";
1341	# internal dates on "TO" are after the ones on "FROM"
1342	# normally...
1343	my @t_msgs = select_msgs($to);
1344
1345	$debug and print "LIST TO : ", scalar(@t_msgs), " messages [@t_msgs]\n";
1346
1347	my %f_hash = ();
1348	my %t_hash = ();
1349
1350	print "++++ From [$f_fold] Parse 1 ++++\n";
1351	last FOLDER if $from->IsUnconnected();
1352	last FOLDER if $to->IsUnconnected();
1353
1354	my $f_heads = $from->parse_headers([@f_msgs],
1355	@useheader)if (@f_msgs) ;
1356	$debug and print "Time headers: ", timenext(), " s\n";
1357	my $f_fir;
1358	if (!$nohash) {
1359	$f_fir=$from->fetch_hash("FLAGS",
1360	"INTERNALDATE",
1361	"RFC822.SIZE") if (@f_msgs);
1362	$debug and print "Time fir : ", timenext(), " s\n";
1363	}
1364
1365	foreach my $m (@f_msgs) {
1366	parse_header_msg1($from, $m, $f_heads, $f_fir, "F", \%f_hash);
1367	}
1368	$debug and print "Time headers: ", timenext(), " s\n";
1369
1370	print "++++ To [$t_fold] Parse 1 ++++\n";
1371	last FOLDER if $from->IsUnconnected();
1372	last FOLDER if $to->IsUnconnected();
1373
1374	my $t_heads = $to->parse_headers([@t_msgs],
1375	@useheader) if (@t_msgs);
1376	$debug and print "Time headers: ", timenext(), " s\n";
1377
1378	my $t_fir;
1379	if (!$nohash) {
1380	$t_fir=$to->fetch_hash("FLAGS",
1381	"INTERNALDATE",
1382	"RFC822.SIZE") if (@t_msgs);
1383	$debug and print "Time fir : ", timenext(), " s\n";
1384	}
1385
1386	foreach my $m (@t_msgs) {
1387	parse_header_msg1($to, $m, $t_heads, $t_fir, "T", \%t_hash);
1388	}
1389	$debug and print "Time headers: ", timenext(), " s\n";
1390
1391	print "++++ Verifying [$f_fold] -> [$t_fold] ++++\n";
1392	# messages in "from" that are not good in "to"
1393
1394	my @f_hash_keys_sorted_by_uid
1395	= sort {$f_hash{$a}{'m'} <=> $f_hash{$b}{'m'}} keys(%f_hash);
1396
1397	#print map { $f_hash{$_}{'m'} . " "} @f_hash_keys_sorted_by_uid;
1398
1399	my @t_hash_keys_sorted_by_uid
1400	= sort {$t_hash{$a}{'m'} <=> $t_hash{$b}{'m'}} keys(%t_hash);
1401
1402
1403	if($delete2) {
1404	foreach my $m_id (@t_hash_keys_sorted_by_uid) {
1405	#print "$m_id ";
1406	unless (exists($f_hash{$m_id})) {
1407	my $t_msg = $t_hash{$m_id}{'m'};
1408	print "deleting message $m_id $t_msg\n";
1409	$to->delete_message($t_msg) unless ($dry);
1410	}
1411	}
1412	}
1413
1414	MESS: foreach my $m_id (@f_hash_keys_sorted_by_uid) {
1415	my $f_size = $f_hash{$m_id}{'s'};
1416	my $f_msg = $f_hash{$m_id}{'m'};
1417	my $f_idate = $f_hash{$m_id}{'D'};
1418
1419	if (defined $maxsize and $f_size > $maxsize) {
1420	print "+ Skipping msg #$f_msg:$f_size in folder $f_fold (exceeds maxsize limit $maxsize bytes)\n";
1421	$mess_size_total_skipped += $f_size;
1422	$mess_skipped += 1;
1423	next MESS;
1424	}
1425	$debug and print "+ key $m_id #$f_msg\n";
1426	unless (exists($t_hash{$m_id})) {
1427	print "+ NO msg #$f_msg [$m_id] in $t_fold\n";
1428	# copy
1429	print "+ Copying msg #$f_msg:$f_size to folder $t_fold\n";
1430	last FOLDER if $from->IsUnconnected();
1431	my $string;
1432	$string = $from->message_string($f_msg);
1433	#print "AAAmessage_string[$string]ZZZ\n";
1434	#my $message_file = "tmp_imapsync_$$";
1435	#$from->select($f_fold);
1436	#unlink($message_file);
1437	#$from->message_to_file($message_file, $f_msg) or do {
1438	# warn "Could not put message #$f_msg to file $message_file",
1439	# $from->LastError;
1440	# $error++;
1441	# $mess_size_total_error += $f_size;
1442	# next MESS;
1443	#};
1444	#$string = file_to_string($message_file);
1445	#print "AAA1[$string]ZZZ\n";
1446	#unlink($message_file);
1447	if (@regexmess) {
1448	$string = regexmess($string);
1449
1450	#string_to_file($string, $message_file);
1451	}
1452
1453	sub tests_regexmess {
1454
1455	ok("blabla" eq regexmess("blabla"), "regexmess, nothing to do");
1456	@regexmess = ('s/p/Z/g');
1457	ok("ZoZoZo" eq regexmess("popopo"), "regexmess, s/p/Z/g");
1458	@regexmess = 's{c}{C}gxms';
1459	#print "RRR€\n", regexmess("H1: abc\nH2: cde\n\nBody abc"), "\n";
1460	ok("H1: abC\nH2: Cde\n\nBody abC"
1461	eq regexmess("H1: abc\nH2: cde\n\nBody abc"),
1462	"regexmess, c->C");
1463
1464	}
1465
1466	sub regexmess {
1467	my ($string) = @_;
1468	foreach my $regexmess (@regexmess) {
1469	$debug and print "eval \$string =~ $regexmess\n";
1470	eval("\$string =~ $regexmess");
1471	}
1472	return($string);
1473	}
1474
1475	$debug and print
1476	"=" x80, "\n",
1477	"F message content begin next line\n",
1478	$string,
1479	"F message content ended on previous line\n", "=" x 80, "\n";
1480	my $d = "";
1481	if ($syncinternaldates) {
1482	$d = $f_idate;
1483	$debug and print "internal date from 1: [$d]\n";
1484	$d = good_date($d);
1485	$debug and print "internal date from 1: [$d] (fixed)\n";
1486	}
1487
1488	if ($idatefromheader) {
1489
1490	$d = $from->get_header($f_msg,"Date");
1491	$debug and print "header date from 1: [$d]\n";
1492	$d = good_date($d);
1493	$debug and print "header date from 1: [$d] (fixed)\n";
1494	}
1495
1496	sub good_date {
1497	my ($d) = @_;
1498	$d = UnixDate(ParseDate($d), "%d-%b-%Y %H:%M:%S %z");
1499	$d = "\"$d\"";
1500	return($d);
1501	}
1502
1503	my $flags_f = $f_hash{$m_id}{'F'} \|\| "";
1504	# RFC 2060 : This flag can not be altered by any client
1505	$flags_f =~ s@\\Recent@@gi;
1506	$flags_f = flags_regex($flags_f) if @regexflag;
1507
1508	my $new_id;
1509	print "flags from : [$flags_f][$d]\n";
1510	last FOLDER if $to->IsUnconnected();
1511	unless ($dry) {
1512
1513	if ($OSNAME eq "MSWin32") {
1514	$new_id = $to->append_string($t_fold,$string, $flags_f, $d);
1515	}
1516	else {
1517	# just back to append_string since append_file 3.05 does not work.
1518	#$new_id = $to->append_file($t_fold, $message_file, "", $flags_f, $d);
1519	# append_string 3.05 does not work too some times with $d unset.
1520	$new_id = $to->append_string($t_fold,$string, $flags_f, $d);
1521	}
1522	unless($new_id){
1523	warn "Couldn't append msg #$f_msg (Subject:[".
1524	$from->subject($f_msg)."]) to folder $t_fold: ",
1525	$to->LastError, "\n";
1526	$error++;
1527	$mess_size_total_error += $f_size;
1528	next MESS;
1529	}
1530	else{
1531	# good
1532	# $new_id is an id if the IMAP server has the
1533	# UIDPLUS capability else just a ref
1534	print "Copied msg id [$f_msg] to folder $t_fold msg id [$new_id]\n";
1535	$mess_size_total_trans += $f_size;
1536	$mess_trans += 1;
1537	if($delete) {
1538	print "Deleting msg #$f_msg in folder $f_fold\n";
1539	$from->delete_message($f_msg) unless ($dry);
1540	$from->expunge() if ($expunge and not $dry);
1541	}
1542	}
1543	}
1544	else{
1545	$mess_skipped_dry += 1;
1546	}
1547	#unlink($message_file);
1548	next MESS;
1549	}
1550	else{
1551	$debug and print "Message id [$m_id] found in t:$t_fold\n";
1552	$mess_size_total_skipped += $f_size;
1553	$mess_skipped += 1;
1554	}
1555
1556	$fast and next MESS;
1557	#$debug and print "MESSAGE $m_id\n";
1558	my $t_size = $t_hash{$m_id}{'s'};
1559	my $t_msg = $t_hash{$m_id}{'m'};
1560
1561
1562	$debug and print "Setting flags\n";
1563	last FOLDER if $from->IsUnconnected();
1564	last FOLDER if $to->IsUnconnected();
1565
1566	my (@flags_f,@flags_t);
1567	my $flags_f_rv = $from->flags($f_msg);
1568	@flags_f = @{$flags_f_rv} if ref($flags_f_rv);
1569
1570	# No flag \Recent here, no ?
1571	my $flags_f = join(" ", @flags_f);
1572
1573	$flags_f = flags_regex($flags_f) if @regexflag;
1574
1575	# This add or change flags but no flag are removed with this
1576	$to->store($t_msg,
1577	"+FLAGS (" . $flags_f . ")"
1578	) unless ($dry) ;
1579
1580	my $flags_t_rv = $to->flags($t_msg);
1581	@flags_t = @{$flags_t_rv} if ref($flags_t_rv);
1582	my $flags_t = join(" ", @flags_t);
1583	$debug and print
1584	"flags from : $flags_f\n",
1585	"flags to : $flags_t\n";
1586
1587
1588	$debug and do {
1589	print "Looking dates\n";
1590	#my $d_f = $from->internaldate($f_msg);
1591	#my $d_t = $to->internaldate($t_msg);
1592	my $d_f = $f_hash{$m_id}{'D'};
1593	my $d_t = $t_hash{$m_id}{'D'};
1594	print
1595	"idate from : $d_f\n",
1596	"idate to : $d_t\n";
1597
1598	#unless ($d_f eq $d_t) {
1599	# print "!!! Dates differ !!!\n";
1600	#}
1601	};
1602	unless (($f_size == $t_size) or $skipsize) {
1603	# Bad size
1604	print
1605	"Message $m_id SZ_BAD f:$f_msg:$f_size t:$t_msg:$t_size\n";
1606	# delete in to and recopy ?
1607	# NO recopy CODE HERE. to be written if needed.
1608	$error++;
1609	if ($opt_G){
1610	print "Deleting msg f:#$t_msg in folder $t_fold\n";
1611	$to->delete_message($t_msg) unless ($dry);
1612	}
1613	}
1614	else {
1615	# Good
1616	$debug and print
1617	"Message $m_id SZ_GOOD f:$f_msg:$f_size t:$t_msg:$t_size\n";
1618	if($delete) {
1619	print "Deleting msg #$f_msg in folder $f_fold\n";
1620	$from->delete_message($f_msg) unless ($dry);
1621	$from->expunge() if ($expunge and not $dry);
1622	}
1623	}
1624	}
1625	if ($expunge1){
1626	print "Expunging source folder $f_fold\n";
1627	unless($dry) { $from->expunge() };
1628	}
1629	if ($expunge2){
1630	print "Expunging target folder $t_fold\n";
1631	unless($dry) { $to->expunge() };
1632	}
1633
1634	print "Time : ", timenext(), " s\n";
1635	}
1636
1637
1638
1639	$from->logout();
1640	$to->logout();
1641
1642	$timeend = time();
1643
1644	$timediff = $timeend - $timestart;
1645
1646	stats();
1647
1648
1649
1650
1651
1652	exit(1) if($error);
1653
1654	sub select_msgs {
1655	my ($imap) = @_;
1656	my (@msgs,@max,@min,@union,@inter);
1657
1658	unless (defined($maxage) or defined($minage)) {
1659	@msgs = $imap->search("ALL");
1660	return(@msgs);
1661	}
1662	if (defined($maxage)) {
1663	@max = $imap->sentsince(time - 86400 * $maxage);
1664	}
1665	if (defined($minage)) {
1666	@min = $imap->sentbefore(time - 86400 * $minage);
1667	}
1668	SWITCH: {
1669	unless(defined($minage)) {@msgs = @max; last SWITCH};
1670	unless(defined($maxage)) {@msgs = @min; last SWITCH};
1671	my (%union, %inter);
1672	foreach my $m (@min, @max) {$union{$m}++ && $inter{$m}++}
1673	@inter = keys(%inter);
1674	@union = keys(%union);
1675	# normal case
1676	if ($minage <= $maxage) {@msgs = @inter; last SWITCH};
1677	# just exclude messages between
1678	if ($minage > $maxage) {@msgs = @union; last SWITCH};
1679
1680	}
1681	return(@msgs);
1682	}
1683
1684	sub stats {
1685	print "++++ Statistics ++++\n";
1686	print "Time : $timediff sec\n";
1687	print "Messages transferred : $mess_trans ";
1688	print "(could be $mess_skipped_dry without dry mode)" if ($dry);
1689	print "\n";
1690	print "Messages skipped : $mess_skipped\n";
1691	print "Total bytes transferred: $mess_size_total_trans\n";
1692	print "Total bytes skipped : $mess_size_total_skipped\n";
1693	print "Total bytes error : $mess_size_total_error\n";
1694	print "Detected $error errors\n\n";
1695	print thank_author();
1696	}
1697
1698	sub thank_author {
1699
1700	return(join("", "Happy with this free, open and gratis GPL software?\n",
1701	"Please, thank the author (Gilles LAMIRAL) by giving him a book:\n",
1702	"http://www.amazon.com/gp/registry/wishlist/1C9UNDIH3P7R7/\n",
1703	"and rate imapsync at http://freshmeat.net/projects/imapsync/\n"));
1704
1705	}
1706
1707	sub get_options
1708	{
1709	my $numopt = scalar(@ARGV);
1710	my $opt_ret = GetOptions(
1711	"debug!" => \$debug,
1712	"debugimap!" => \$debugimap,
1713	"host1=s" => \$host1,
1714	"host2=s" => \$host2,
1715	"port1=i" => \$port1,
1716	"port2=i" => \$port2,
1717	"user1=s" => \$user1,
1718	"user2=s" => \$user2,
1719	"password1=s" => \$password1,
1720	"password2=s" => \$password2,
1721	"passfile1=s" => \$passfile1,
1722	"passfile2=s" => \$passfile2,
1723	"authmd5!" => \$authmd5,
1724	"sep1=s" => \$sep1,
1725	"sep2=s" => \$sep2,
1726	"folder=s" => \@folder,
1727	"folderrec=s" => \@folderrec,
1728	"include=s" => \@include,
1729	"exclude=s" => \@exclude,
1730	"prefix1=s" => \$prefix1,
1731	"prefix2=s" => \$prefix2,
1732	"regextrans2=s" => \@regextrans2,
1733	"regexmess=s" => \@regexmess,
1734	"regexflag=s" => \@regexflag,
1735	"delete!" => \$delete,
1736	"delete2!" => \$delete2,
1737	"syncinternaldates!" => \$syncinternaldates,
1738	"idatefromheader!" => \$idatefromheader,
1739	"syncacls!" => \$syncacls,
1740	"maxsize=i" => \$maxsize,
1741	"maxage=i" => \$maxage,
1742	"minage=i" => \$minage,
1743	"buffersize=i" => \$buffersize,
1744	"foldersizes!" => \$foldersizes,
1745	"dry!" => \$dry,
1746	"expunge!" => \$expunge,
1747	"expunge1!" => \$expunge1,
1748	"expunge2!" => \$expunge2,
1749	"subscribed!" => \$subscribed,
1750	"subscribe!" => \$subscribe,
1751	"justconnect!"=> \$justconnect,
1752	"justfolders!"=> \$justfolders,
1753	"justfoldersizes!" => \$justfoldersizes,
1754	"fast!" => \$fast,
1755	"nohash!" => \$nohash,
1756	"version" => \$version,
1757	"help" => \$help,
1758	"timeout=i" => \$timeout,
1759	"skipheader=s" => \$skipheader,
1760	"useheader=s" => \@useheader,
1761	"skipsize!" => \$skipsize,
1762	"fastio1!" => \$fastio1,
1763	"fastio2!" => \$fastio2,
1764	"ssl1!" => \$ssl1,
1765	"ssl2!" => \$ssl2,
1766	"authmech1=s" => \$authmech1,
1767	"authmech2=s" => \$authmech2,
1768	"authuser1=s" => \$authuser1,
1769	"authuser2=s" => \$authuser2,
1770	"split1=i" => \$split1,
1771	"split2=i" => \$split2,
1772	"tests" => \$tests,
1773	"allow3xx!" => \$allow3xx,
1774	);
1775
1776	$debug and print "get options: [$opt_ret]\n";
1777
1778	$test_builder = Test::More->builder;
1779	$test_builder->no_ending(1);
1780
1781	# just the version
1782	print "$VERSION\n" and exit if ($version) ;
1783
1784	if ($tests) {
1785	$test_builder->no_ending(0);
1786	tests();
1787	exit;
1788	}
1789
1790
1791	load_modules();
1792
1793	# exit with --help option or no option at all
1794	usage() and exit if ($help or ! $numopt) ;
1795
1796	# don't go on if options are not all known.
1797	exit(EX_USAGE()) unless ($opt_ret) ;
1798
1799
1800
1801	}
1802
1803
1804	sub load_modules {
1805
1806	require IO::Socket::SSL if ($ssl1 or $ssl2);
1807	require Date::Manip if ($syncinternaldates \|\| $idatefromheader) ;
1808
1809	# require Term::ReadKey if (
1810	# (not($password1 or $passfile1))
1811	# or (not($password2 or $passfile2))
1812	# or (not $help));
1813
1814	#require Data::Dumper if ($debug);
1815	}
1816
1817
1818
1819	sub parse_header_msg1 {
1820	my ($imap, $m_uid, $s_heads, $s_fir, $s, $s_hash) = @_;
1821
1822	my $head = $s_heads->{$m_uid};
1823	my $headnum = scalar(keys(%$head));
1824	$debug and print "Head NUM:", $headnum, "\n";
1825	unless($headnum) { print "Warning : no header used or found for message $m_uid\n"; }
1826	my $headstr;
1827
1828	foreach my $h (sort keys(%$head)){
1829	foreach my $val (sort @{$head->{$h}}) {
1830	# no 8-bit data in headers !
1831	$val =~ s/[\x80-\xff]/X/g;
1832
1833	# remove the first blanks (dbmail bug ?)
1834	# and uppercase header keywords
1835	# (dbmail and dovecot)
1836	$val =~ s/^\s*(.+)$/$1/;
1837
1838	#my $H = uc($h);
1839	my $H = "$h: $val";
1840	# show stuff in debug mode
1841	$debug and print "${s}H $H:", $val, "\n";
1842
1843	if ($skipheader and $H =~ m/$skipheader/i) {
1844	$debug and print "Skipping header $H\n";
1845	next;
1846	}
1847	#$headstr .= "$H:". $val;
1848	$headstr .= "$H";
1849	}
1850	}
1851	#return unless ($headstr);
1852	unless ($headstr){
1853	# taking everything is too heavy,
1854	# should take only 1 Ko
1855	#print "no header so taking everything\n";
1856	#$headstr = $imap->message_string($m_uid);
1857
1858	print "no header so we ignore this message\n";
1859	return;
1860	}
1861	my $size = $s_fir->{$m_uid}->{"RFC822.SIZE"};
1862	my $flags = $s_fir->{$m_uid}->{"FLAGS"};
1863	my $idate = $s_fir->{$m_uid}->{"INTERNALDATE"};
1864	$size = length($headstr) unless ($size);
1865	my $m_md5 = md5_base64($headstr);
1866	$debug and print "$s msg $m_uid:$m_md5:$size\n";
1867	my $key;
1868	if ($skipsize) {
1869	$key = "$m_md5";
1870	}
1871	else {
1872	$key = "$m_md5:$size";
1873	}
1874	$s_hash->{"$key"}{'5'} = $m_md5;
1875	$s_hash->{"$key"}{'s'} = $size;
1876	$s_hash->{"$key"}{'D'} = $idate;
1877	$s_hash->{"$key"}{'F'} = $flags;
1878	$s_hash->{"$key"}{'m'} = $m_uid;
1879	}
1880
1881
1882	sub firstline {
1883	# extract the first line of a file (without \n)
1884
1885	my($file) = @_;
1886	my $line = "";
1887
1888	open FILE, $file or die("error [$file]: $! ");
1889	chomp($line = <FILE>);
1890	close FILE;
1891	$line = ($line) ? $line : "error !EMPTY! [$file]";
1892	return $line;
1893	}
1894
1895
1896	sub file_to_string {
1897	my($file) = @_;
1898	my @string;
1899	open FILE, $file or die("error [$file]: $! ");
1900	@string = <FILE>;
1901	close FILE;
1902	return join("", @string);
1903	}
1904
1905
1906	sub string_to_file {
1907	my($string, $file) = @_;
1908	sysopen(FILE, $file,O_WRONLY\|O_TRUNC\|O_CREAT, 0600) or die("$! $file");
1909	print FILE $string;
1910	close FILE;
1911	}
1912
1913
1914
1915	sub usage {
1916	my $localhost_info = localhost_info();
1917	my $thank = thank_author();
1918	print <<EOF;
1919
1920	usage: $0 [options]
1921
1922	Several options are mandatory.
1923
1924	--host1 <string> : "from" imap server. Mandatory.
1925	--port1 <int> : port to connect on host1. Default is 143.
1926	--user1 <string> : user to login on host1. Mandatory.
1927	--authuser1 <string> : user to auth with on host1 (admin user).
1928	Avoid using --authmech1 SOMETHING with --authuser1.
1929	--password1 <string> : password for the user1. Dangerous, use --passfile1
1930	--passfile1 <string> : password file for the user1. Contains the password.
1931	--host2 <string> : "destination" imap server. Mandatory.
1932	--port2 <int> : port to connect on host2. Default is 143.
1933	--user2 <string> : user to login on host2. Mandatory.
1934	--authuser2 <string> : user to auth with on host2 (admin user).
1935	--password2 <string> : password for the user2. Dangerous, use --passfile2
1936	--passfile2 <string> : password file for the user2. Contains the password.
1937	--noauthmd5 : don't use MD5 authentification.
1938	--authmech1 <string> : auth mechanism to use with host1:
1939	PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE.
1940	--authmech2 <string> : auth mechanism to use with host2. See --authmech1
1941	--ssl1 : use an SSL connection on host1.
1942	--ssl2 : use an SSL connection on host2.
1943	--folder <string> : sync this folder.
1944	--folder <string> : and this one, etc.
1945	--folderrec <string> : sync this folder recursively.
1946	--folderrec <string> : and this one, etc.
1947	--include <regex> : sync folders matching this regular expression
1948	--include <regex> : or this one, etc.
1949	in case both --include --exclude options are
1950	use, include is done before.
1951	--exclude <regex> : skips folders matching this regular expression
1952	Several folders to avoid:
1953	--exclude 'fold1\|fold2\|f3' skips fold1, fold2 and f3.
1954	--exclude <regex> : or this one, etc.
1955	--prefix1 <string> : remove prefix to all destination folders
1956	(usually INBOX. for cyrus imap servers)
1957	you can use --prefix1 if your source imap server
1958	does not have NAMESPACE capability.
1959	--prefix2 <string> : add prefix to all destination folders
1960	(usually INBOX. for cyrus imap servers)
1961	use --prefix2 if your target imap server does not
1962	have NAMESPACE capability.
1963	--regextrans2 <regex> : Apply the whole regex to each destination folders.
1964	--regextrans2 <regex> : and this one. etc.
1965	When you play with the --regextrans2 option, first
1966	add also the safe options --dry --justfolders
1967	Then, when happy, remove --dry, remove --justfolders
1968	--regexmess <regex> : Apply the whole regex to each message before transfer.
1969	Example : 's/\\000/ /g' # to replace null by space.
1970	--regexmess <regex> : and this one.
1971	--regexmess <regex> : and this one, etc.
1972	--regexflag <regex> : Apply the whole regex to each flags list.
1973	Example : 's/\"Junk"//g' # to remove "Junk" flag.
1974	--regexflag <regex> : and this one, etc.
1975	--sep1 <string> : separator in case namespace is not supported.
1976	--sep2 <string> : idem.
1977	--delete : delete messages on source imap server after
1978	a successful transfer. Useful in case you
1979	want to migrate from one server to another one.
1980	With imap, delete tags messages as deleted, they
1981	are not really deleted. See expunge.
1982	--delete2 : delete messages on the destination imap server that
1983	are not on the source server.
1984	--expunge : expunge messages on source account.
1985	expunge really deletes messages marked deleted.
1986	expunge is made at the beginning on the
1987	source server only. newly transferred messages
1988	are expunged if option --expunge is given.
1989	no expunge is done on destination account but
1990	it will change in future releases.
1991	--expunge1 : expunge messages on source account.
1992	--expunge2 : expunge messages on target account.
1993	--syncinternaldates : sets the internal dates on host2 same as host1.
1994	Turned on by default.
1995	--idatefromheader : sets the internal dates on host2 same as the
1996	"Date:" headers.
1997	--buffersize <int> : sets the size of a block of I/O.
1998	--maxsize <int> : skip messages larger than <int> bytes
1999	--maxage <int> : skip messages older than <int> days.
2000	final stats (skipped) don't count older messages
2001	see also --minage
2002	--minage <int> : skip messages newer than <int> days.
2003	final stats (skipped) don't count newer messages
2004	You can do (+ are the messages selected):
2005	past\|----maxage+++++++++++++++>now
2006	past\|+++++++++++++++minage---->now
2007	past\|----maxage+++++minage---->now (intersection)
2008	past\|++++minage-----maxage++++>now (union)
2009	--skipheader <regex> : Don't take into account header keyword
2010	matching <string> ex: --skipheader 'X.*'
2011	--useheader <string> : Use this header to compare messages on both sides.
2012	Ex: Message-ID or Subject or Date.
2013	--useheader <string> and this one, etc.
2014	--skipsize : Don't take message size into account.
2015	--dry : do nothing, just print what would be done.
2016	--subscribed : transfers subscribed folders.
2017	--subscribe : subscribe to the folders transferred on the
2018	"destination" server that are subscribed
2019	on the "source" server.
2020	--(no)foldersizes : Calculate the size of each "From" folder in bytes
2021	and message counts. Meant to be used with
2022	--justfoldersizes. Turned on by default.
2023	--justfoldersizes : exit after printed the folder sizes.
2024	--syncacls : Synchronises acls (Access Control Lists).
2025	--nosyncacls : Does not synchronise acls. This is the default.
2026	--debug : debug mode.
2027	--debugimap : imap debug mode.
2028	--version : print software version.
2029	--justconnect : just connect to both servers and print useful
2030	information. Need only --host1 and --host2 options.
2031	--justfolders : just do things about folders (ignore messages).
2032	--fast : be faster (just does not sync flags).
2033	--nohash : be even faster: dont fetch hashen, requires much less cpu and resources. (i dont know what it breaks!)
2034	--split1 <int> : split the requests in several parts on source server.
2035	<int > is the number of messages handled per request.
2036	default is like --split1 1000
2037	--split2 <int> : same thing on the "destination" server.
2038	--fastio1 : use fastio with the "from" server.
2039	--fastio2 : use fastio with the "destination" server.
2040	--timeout <int> : imap connect timeout.
2041	--help : print this.
2042
2043	Example: to synchronise imap account "foo" on "imap.truc.org"
2044	to imap account "bar" on "imap.trac.org"
2045
2046	$0 \\
2047	--host1 imap.truc.org --user1 foo --passfile1 /etc/secret1 \\
2048	--host2 imap.trac.org --user2 bar --passfile2 /etc/secret2
2049
2050	$localhost_info
2051	$rcs
2052
2053	$thank
2054	EOF
2055	}
2056
2057
2058
2059	sub tests {
2060
2061	SKIP: {
2062	skip "No test in normal run" if (not $tests);
2063	tests_folder_routines();
2064	tests_compare_lists();
2065	tests_regexmess();
2066	}
2067	}
2068
2069	sub override_imapclient {
2070	no warnings 'redefine';
2071	no strict 'subs';
2072
2073	use constant Unconnected => 0;
2074	use constant Connected => 1; # connected; not logged in
2075	use constant Authenticated => 2; # logged in; no mailbox selected
2076	use constant Selected => 3; # mailbox selected
2077	use constant INDEX => 0; # Array index for output line number
2078	use constant TYPE => 1; # Array index for line type
2079	# (either OUTPUT, INPUT, or LITERAL)
2080	use constant DATA => 2; # Array index for output line data
2081	use constant NonFolderArg => 1; # Value to pass to Massage to
2082	# indicate non-folder argument
2083
2084
2085
2086	*Mail::IMAPClient::append_file = sub {
2087
2088	my $self = shift;
2089	my $folder = $self->Massage(shift);
2090	my $file = shift;
2091	my $control = shift \|\| undef;
2092	my $count = $self->Count($self->Count+1);
2093	my $flags = shift \|\| undef;
2094	my $date = shift \|\| undef;
2095
2096	if (defined($flags)) {
2097	$flags =~ s/^\s+//g;
2098	$flags =~ s/\s+$//g;
2099	}
2100
2101	if (defined($date)) {
2102	$date =~ s/^\s+//g;
2103	$date =~ s/\s+$//g;
2104	}
2105
2106	$flags = "($flags)" if $flags and $flags !~ /^\(.*\)$/ ;
2107	$date = qq/"$date"/ if $date and $date !~ /^"/ ;
2108
2109
2110	unless ( -f $file ) {
2111	$self->LastError("File $file not found.\n");
2112	return undef;
2113	}
2114
2115	my $fh = IO::File->new($file) ;
2116
2117	unless ($fh) {
2118	$self->LastError("Unable to open $file: $!\n");
2119	$@ = "Unable to open $file: $!" ;
2120	carp "unable to open $file: $!";
2121	return undef;
2122	}
2123
2124	my $bare_nl_count = scalar grep { /^\x0a$\|[^\x0d]\x0a$/} <$fh>;
2125
2126	seek($fh,0,0);
2127
2128	my $clear = $self->Clear;
2129
2130	$self->Clear($clear)
2131	if $self->Count >= $clear and $clear > 0;
2132
2133	my $length = ( -s $file ) + $bare_nl_count;
2134
2135	my $string = "$count APPEND $folder " .
2136	( $flags ? "$flags " : "" ) .
2137	( $date ? "$date " : "" ) .
2138	"{" . $length . "}\x0d\x0a" ;
2139
2140	$self->_record($count,[ $self->_next_index($count), "INPUT", "$string" ] );
2141
2142	my $feedback = $self->_send_line("$string");
2143
2144	unless ($feedback) {
2145	$self->LastError("Error sending '$string' to IMAP: $!\n");
2146	$fh->close;
2147	return undef;
2148	}
2149
2150	my ($code, $output) = ("","");
2151
2152	until ( $code ) {
2153	$output = $self->_read_line or $fh->close, return undef;
2154	foreach my $o (@$output) {
2155	$self->_record($count,$o); # $o is already an array ref
2156	($code) = $o->[DATA] =~ /(^\+\|^\d+\sNO\|^\d+\sBAD)/i;
2157	if ($o->[DATA] =~ /^\*\s+BYE/) {
2158	carp $o->[DATA];
2159	$self->State(Unconnected);
2160	$fh->close;
2161	return undef ;
2162	} elsif ( $o->[DATA]=~ /^\d+\s+(NO\|BAD)/i ) {
2163	carp $o->[DATA];
2164	$fh->close;
2165	return undef;
2166	}
2167	}
2168	}
2169
2170	{ # Narrow scope
2171	# Slurp up headers: later we'll make this more efficient I guess
2172	local $/ = "\x0d\x0a\x0d\x0a";
2173	my $text = <$fh>;
2174	$text =~ s/\x0d?\x0a/\x0d\x0a/g;
2175	$self->_record($count,[ $self->_next_index($count), "INPUT", "{From file $file}" ] ) ;
2176	$feedback = $self->_send_line($text);
2177
2178	unless ($feedback) {
2179	$self->LastError("Error sending append msg text to IMAP: $!\n");
2180	$fh->close;
2181	return undef;
2182	}
2183	_debug($self, "control points to $$control\n") if ref($control) and $self->Debug;
2184	$/ = ref($control) ? "\x0a" : $control ? $control : "\x0a";
2185	while (defined($text = <$fh>)) {
2186	$text =~ s/\x0d?\x0a/\x0d\x0a/g;
2187	$self->_record( $count,
2188	[ $self->_next_index($count), "INPUT", "{from $file}\x0d\x0a" ]
2189	);
2190	$feedback = $self->_send_line($text,1);
2191
2192	unless ($feedback) {
2193	$self->LastError("Error sending append msg text to IMAP: $!\n");
2194	$fh->close;
2195	return undef;
2196	}
2197	}
2198	$feedback = $self->_send_line("\x0d\x0a");
2199
2200	unless ($feedback) {
2201	$self->LastError("Error sending append msg text to IMAP: $!\n");
2202	$fh->close;
2203	return undef;
2204	}
2205	}
2206
2207	# Now for the crucial test: Did the append work or not?
2208	($code, $output) = ("","");
2209
2210	my $uid = undef;
2211	until ( $code ) {
2212	$output = $self->_read_line or return undef;
2213	foreach my $o (@$output) {
2214	$self->_record($count,$o); # $o is already an array ref
2215	$self->_debug("append_file: Deciding if " . $o->[DATA] . " has the code.\n")
2216	if $self->Debug;
2217	($code) = $o->[DATA] =~ /^\d+\s(NO\|BAD\|OK)/i;
2218	# try to grab new msg's uid from o/p
2219	$o->[DATA] =~ m#UID\s+\d+\s+(\d+)\]# and $uid = $1;
2220	if ($o->[DATA] =~ /^\*\s+BYE/) {
2221	carp $o->[DATA];
2222	$self->State(Unconnected);
2223	$fh->close;
2224	return undef ;
2225	} elsif ( $o->[DATA]=~ /^\d+\s+(NO\|BAD)/i ) {
2226	carp $o->[DATA];
2227	$fh->close;
2228	return undef;
2229	}
2230	}
2231	}
2232	$fh->close;
2233
2234	if ($code !~ /^OK/i) {
2235	return undef;
2236	}
2237
2238
2239	return defined($uid) ? $uid : $self;
2240	};
2241
2242
2243
2244
2245	*Mail::IMAPClient::fetch_hash = sub {
2246	# taken from original lib,
2247	# just added split code.
2248	my $self = shift;
2249	my $hash = ref($_[-1]) ? pop @_ : {};
2250	my @words = @_;
2251	for (@words) {
2252	s/([\( ])FAST([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE$2/i ;
2253	s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i ;
2254	}
2255	my $msgref_all = scalar($self->messages);
2256	my $split = $self->Split() \|\| scalar(@$msgref_all);
2257	while(my @msgs = splice(@$msgref_all, 0, $split)) {
2258	#print "SPLIT: @msgs\n";
2259	my $msgref = \@msgs;
2260	my $output = scalar($self->fetch($msgref,"(" . join(" ",@_) . ")"))
2261	; # unless grep(/\b(?:FAST\|FULL)\b/i,@words);
2262	my $x;
2263	for ($x = 0; $x <= $#$output ; $x++) {
2264	my $entry = {};
2265	my $l = $output->[$x];
2266	if ($self->Uid) {
2267	my($uid) = $l =~ /\((?:.* )?UID (\d+).*\)/i;
2268	next unless $uid;
2269	if ( exists $hash->{$uid} ) {
2270	$entry = $hash->{$uid} ;
2271	}
2272	else {
2273	$hash->{$uid} \|\|= $entry;
2274	}
2275	}
2276	else {
2277	my($mid) = $l =~ /^\* (\d+) FETCH/i;
2278	next unless $mid;
2279	if ( exists $hash->{$mid} ) {
2280	$entry = $hash->{$mid} ;
2281	}
2282	else {
2283	$hash->{$mid} \|\|= $entry;
2284	}
2285	}
2286
2287	foreach my $w (@words) {
2288	if ( $l =~ /\Q$w\E\s*$/i ) {
2289	$entry->{$w} = $output->[$x+1];
2290	$entry->{$w} =~ s/(?:\x0a?\x0d)+$//g;
2291	chomp $entry->{$w};
2292	}
2293	else {
2294	$l =~ /\( # open paren followed by ...
2295	(?:.*\s)? # ...optional stuff and a space
2296	\Q$w\E\s # escaped fetch field<sp>
2297	(?:" # then: a dbl-quote
2298	(\\.\| # then bslashed anychar(s) or ...
2299	[^"]+) # ... nonquote char(s)
2300	"\| # then closing quote; or ...
2301	\( # ...an open paren
2302	(\\.\| # then bslashed anychar or ...
2303	[^\)]+) # ... non-close-paren char
2304	\)\| # then closing paren; or ...
2305	(\S+)) # unquoted string
2306	(?:\s.*)? # possibly followed by space-stuff
2307	\) # close paren
2308	/xi;
2309	$entry->{$w}=defined($1)?$1:defined($2)?$2:$3;
2310	}
2311	}
2312	}
2313	}
2314	return wantarray ? %$hash : $hash;
2315	};
2316
2317
2318
2319	*Mail::IMAPClient::login = sub {
2320	my $self = shift;
2321	return $self->authenticate($self->Authmechanism,$self->Authcallback)
2322	if $self->{Authmechanism};
2323
2324	my $id = $self->User;
2325	my $has_quotes = $id =~ /^".*"$/ ? 1 : 0;
2326	my $string = "Login " . ( $has_quotes ? $id : qq("$id") ) .
2327	" " . $self->Password . "\r\n";
2328	$self->_imap_command($string)
2329	and $self->State(Authenticated);
2330	# $self->folders and $self->separator unless $self->NoAutoList;
2331	unless ( $self->IsAuthenticated) {
2332	my($carp) = $self->LastError;
2333	$carp =~ s/^[\S]+ ([^\x0d\x0a]*)\x0d?\x0a/$1/;
2334	carp $carp unless defined wantarray;
2335	return undef;
2336	};
2337	return $self;
2338	};
2339
2340
2341	*Mail::IMAPClient::get_header = sub {
2342	my($self , $msg, $header ) = @_;
2343	my $val;
2344
2345	#eval { $val = $self->parse_headers([$msg],$header)->{$header}[0] };
2346	my $h = $self->parse_headers([$msg],$header);
2347	#require Data::Dumper;
2348	#print Data::Dumper->Dump([$h]);
2349	#$val = $self->parse_headers([$msg],$header)->{$header}[0];
2350
2351	$val = $h->{$msg}{$header}[0];
2352	return defined($val)? $val : undef;
2353	};
2354
2355
2356	*Mail::IMAPClient::parse_headers = sub {
2357	my($self,$msgspec_all,@fields) = @_;
2358	my(%fieldmap) = map { ( lc($_),$_ ) } @fields;
2359	my $msg; my $string; my $field;
2360	#print ref($msgspec_all), "\n";
2361	#if(ref($msgspec_all) eq 'HASH') {
2362	# print ref($msgspec_all), "\n";
2363	#$msgspec_all = [$msgspec_all];
2364	#}
2365
2366	unless(ref($msgspec_all) eq 'ARRAY') {
2367	print "parse_headers want an ARRAY ref\n";
2368	#exit 1;
2369	return undef;
2370	}
2371
2372	my $headers = {}; # hash from message ids to header hash
2373	my $split = $self->Split() \|\| scalar(@$msgspec_all);
2374	while(my @msgs = splice(@$msgspec_all, 0, $split)) {
2375	$debug and print "SPLIT: @msgs\n";
2376	my $msgspec = \@msgs;
2377
2378	# Make $msg a comma separated list, of messages we want
2379	$msg = $self->Range($msgspec);
2380
2381	if ($fields[0] =~ /^[Aa][Ll]{2}$/ ) {
2382
2383	$string = "$msg body" .
2384	# use ".peek" if Peek parameter is a) defined and true,
2385	# or b) undefined, but not if it's defined and untrue:
2386
2387	( defined($self->Peek) ?
2388	( $self->Peek ? ".peek" : "" ) :
2389	".peek"
2390	) . "[header]" ;
2391
2392	}else {
2393	$string = "$msg body" .
2394	# use ".peek" if Peek parameter is a) defined and true, or
2395	# b) undefined, but not if it's defined and untrue:
2396
2397	( defined($self->Peek) ?
2398	( $self->Peek ? ".peek" : "" ) :
2399	".peek"
2400	) . "[header.fields (" . join(" ",@fields) . ')]' ;
2401	}
2402
2403	my @raw=$self->fetch( $string ) or return undef;
2404
2405
2406	my $h = 0; # reference to hash of current msgid, or 0 between msgs
2407
2408	for my $header (map { split(/(?:\x0d\x0a)/,$_) } @raw) {
2409
2410	no warnings;
2411	if ( $header =~ /^\\s+\d+\s+FETCH\s+\(.BODY\[HEADER(?:\]\|\.FIELDS)/i) {
2412	if ($self->Uid) {
2413	if ( my($msgid) = $header =~ /UID\s+(\d+)/ ) {
2414	$h = {};
2415	$headers->{$msgid} = $h;
2416	}
2417	else {
2418	$h = {};
2419	}
2420	}
2421	else {
2422	if ( my($msgid) = $header =~ /^\*\s+(\d+)/ ) {
2423	#start of new message header:
2424	$h = {};
2425	$headers->{$msgid} = $h;
2426	}
2427	}
2428	}
2429	next if $header =~ /^\s+$/;
2430
2431	# ( for vi
2432	if ($header =~ /^\)/) { # end of this message
2433	$h = 0; # set to be between messages
2434	next;
2435	}
2436	# check for '<optional_white_space>UID<white_space><UID_number><optional_white_space>)'
2437	# when parsing headers by UID.
2438	if ($self->Uid and my($msgid) = $header =~ /^\sUID\s+(\d+)\s\)/) {
2439	$headers->{$msgid} = $h; # store in results against this message
2440	$h = 0; # set to be between messages
2441	next;
2442	}
2443
2444	if ($h != 0) { # do we expect this to be a header?
2445	my $hdr = $header;
2446	chomp $hdr;
2447	$hdr =~ s/\r$//;
2448	#print "W[$hdr]", ref($hdr), "!\n";
2449	#next if ( ! defined($hdr));
2450	#print "X[$hdr]\n";
2451
2452	if (defined($hdr) and ($hdr =~ s/^(\S+):\s*//)) {
2453	# if ($hdr =~ s/^(\S+):\s*//) {
2454	#print "X1\n";
2455	$field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ;
2456	push @{$h->{$field}} , $hdr ;
2457	} elsif ($hdr =~ s/^.FETCH\s\(.BODY\[HEADER\.FIELDS.\)\]\s(\S+):\s//) {
2458	#print "X2\n";
2459	$field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ;
2460	push @{$h->{$field}} , $hdr ;
2461	} elsif ( ref($h->{$field}) eq 'ARRAY') {
2462	#print "X3\n";
2463
2464	$hdr =~ s/^\s+/ /;
2465	$h->{$field}[-1] .= $hdr ;
2466	}
2467	}
2468	}
2469	use warnings;
2470	# my $candump = 0;
2471	# if ($self->Debug) {
2472	# eval {
2473	# require Data::Dumper;
2474	# Data::Dumper->import;
2475	# };
2476	# $candump++ unless $@;
2477	# }
2478
2479	}
2480	# if we asked for one message, just return its hash,
2481	# otherwise, return hash of numbers => header hash
2482	# if (ref($msgspec) eq 'ARRAY') {
2483
2484	return $headers;
2485
2486	};
2487
2488
2489	*Mail::IMAPClient::authenticate = sub {
2490
2491	my $self = shift;
2492	my $scheme = shift;
2493	my $response = shift;
2494
2495	$scheme \|\|= $self->Authmechanism;
2496	$response \|\|= $self->Authcallback;
2497	my $clear = $self->Clear;
2498
2499	$self->Clear($clear)
2500	if $self->Count >= $clear and $clear > 0;
2501
2502	my $count = $self->Count($self->Count+1);
2503
2504
2505	my $string = "$count AUTHENTICATE $scheme";
2506
2507	$self->_record($count,[ $self->_next_index($self->Transaction),
2508	"INPUT", "$string\x0d\x0a"] );
2509
2510	my $feedback = $self->_send_line("$string");
2511
2512	unless ($feedback) {
2513	$self->LastError("Error sending '$string' to IMAP: $!\n");
2514	return undef;
2515	}
2516
2517	my ($code, $output);
2518
2519	until ($code) {
2520	$output = $self->_read_line or return undef;
2521
2522	foreach my $o (@$output) {
2523	$self->_record($count,$o); # $o is a ref
2524	($code) = $o->[DATA] =~ /^\+(.*)$/ ;
2525	if ($o->[DATA] =~ /^\*\s+BYE/) {
2526	$self->State(Unconnected);
2527	return undef ;
2528	}
2529	if ($o->[DATA]=~ /^\d+\s+(NO\|BAD)/i) {
2530	return undef ;
2531	}
2532	}
2533	}
2534
2535	if ('CRAM-MD5' eq $scheme && ! $response) {
2536	if ($Mail::IMAPClient::_CRAM_MD5_ERR) {
2537	$self->LastError($Mail::IMAPClient::_CRAM_MD5_ERR);
2538	carp $Mail::IMAPClient::_CRAM_MD5_ERR;
2539	}
2540	else {
2541	$response = \&Mail::IMAPClient::_cram_md5;
2542	}
2543	}
2544
2545	$feedback = $self->_send_line($response->($code, $self));
2546
2547	unless ($feedback) {
2548	$self->LastError("Error sending append msg text to IMAP: $!\n");
2549	return undef;
2550	}
2551
2552	$code = ""; # clear code
2553	until ($code) {
2554	$output = $self->_read_line or return undef;
2555	foreach my $o (@$output) {
2556	$self->_record($count,$o); # $o is a ref
2557	if ( ($code) = $o->[DATA] =~ /^\+ (.*)$/ ) {
2558	$feedback = $self->_send_line($response->($code,$self));
2559	unless ($feedback) {
2560	$self->LastError("Error sending append msg text to IMAP: $!\n");
2561	return undef;
2562	}
2563	$code = "" ; # Clear code; we're still not finished
2564	} else {
2565	$o->[DATA] =~ /^$count (OK\|NO\|BAD)/ and $code = $1;
2566	if ($o->[DATA] =~ /^\*\s+BYE/) {
2567	$self->State(Unconnected);
2568	return undef ;
2569	}
2570	}
2571	}
2572	}
2573
2574	$code =~ /^OK/ and $self->State(Authenticated) ;
2575	return $code =~ /^OK/ ? $self : undef ;
2576
2577	};
2578
2579
2580
2581	*Mail::IMAPClient::_cram_md5 = sub {
2582	my ($code, $client) = @_;
2583	my $hmac = Digest::HMAC_MD5::hmac_md5_hex(MIME::Base64::decode($code),
2584	$client->Password());
2585	return MIME::Base64::encode($client->User() . " $hmac", "");
2586	};
2587
2588	*Mail::IMAPClient::message_string = sub {
2589	my $self = shift;
2590	my $msg = shift;
2591	my $expected_size = $self->size($msg);
2592	return undef unless(defined $expected_size); # unable to get size
2593	my $cmd = $self->has_capability('IMAP4REV1') ?
2594	"BODY" . ( $self->Peek ? '.PEEK[]' : '[]' ) :
2595	"RFC822" . ( $self->Peek ? '.PEEK' : '' ) ;
2596
2597	$self->fetch($msg,$cmd) or return undef;
2598
2599	my $string = "";
2600
2601	foreach my $result (@{$self->{"History"}{$self->Transaction}}) {
2602	$string .= $result->[DATA]
2603	if defined($result) and $self->_is_literal($result) ;
2604	}
2605
2606	# BUG? should probably return undef if length != expected
2607	# No bug, somme servers are buggy.
2608
2609	if ( length($string) != $expected_size ) {
2610	warn "message_string: " .
2611	"expected $expected_size bytes but received " .
2612	length($string) . "\n";
2613	$self->LastError("message_string: expected ".
2614	"$expected_size bytes but received " .
2615	length($string)."\n");
2616	}
2617	return $string;
2618	};
2619
2620	*Mail::IMAPClient::Ssl = sub {
2621	my $self = shift;
2622
2623	if (@_) { $self->{SSL} = shift }
2624	return $self->{SSL};
2625	};
2626
2627
2628	*Mail::IMAPClient::connect = sub {
2629	my $self = shift;
2630
2631	$self->Port(143)
2632	if defined ($IO::Socket::INET::VERSION)
2633	and $IO::Socket::INET::VERSION eq '1.25'
2634	and !$self->Port;
2635	%$self = (%$self, @_);
2636
2637	my $sock = ($self->Ssl ? IO::Socket::SSL->new : IO::Socket::INET->new);
2638	my $dp = ($self->Ssl ? 'imaps(993)' : 'imap(143)');
2639
2640	my $ret = $sock->configure({
2641	PeerAddr => $self->Server ,
2642	PeerPort => $self->Port\|\|$dp ,
2643	Proto => 'tcp' ,
2644	Timeout => $self->Timeout\|\|0 ,
2645	Debug => $self->Debug ,
2646	});
2647	unless ( defined($ret) ) {
2648	$self->LastError( "$@\n");
2649	$@ = "$@";
2650	carp "$@"
2651	unless defined wantarray;
2652	return undef;
2653	}
2654	$self->Socket($sock);
2655	$self->State(Connected);
2656	$sock->autoflush(1) ;
2657	my ($code, $output);
2658	$output = "";
2659	until ( $code ) {
2660
2661	$output = $self->_read_line or return undef;
2662	for my $o (@$output) {
2663	$self->_debug("Connect: Received this from readline: " .
2664	join("/",@$o) . "\n");
2665	$self->_record($self->Count,$o); # $o is a ref
2666	next unless $o->[TYPE] eq "OUTPUT";
2667	($code) = $o->[DATA] =~ /^\*\s+(OK\|BAD\|NO)/i ;
2668	}
2669
2670	}
2671
2672	if ($code =~ /BYE\|NO /) {
2673	$self->State(Unconnected);
2674	return undef ;
2675	}
2676
2677	if ($self->User and $self->Password) {
2678	return $self->login ;
2679	}
2680	else {
2681	return $self;
2682	}
2683	}
2684
2685
2686
2687	}
2688
2689	package Mail::IMAPClient;
2690
2691
2692	sub Authuser {
2693	my $self = shift;
2694
2695	if (@_) { $self->{AUTHUSER} = shift }
2696	return $self->{AUTHUSER};
2697	}
2698
2699
2700	sub Split {
2701	my $self = shift;
2702
2703	if (@_) { $self->{SPLIT} = shift }
2704	return $self->{SPLIT};
2705	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: