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