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