blob: 4c941f44b879a598fd9c161b008a36f40f624185 [file] [log] [blame]
Matthias Andreas Benkardb382b102021-01-02 15:32:21 +01001#!/usr/bin/env perl
2
3# $Id: imapsync,v 1.977 2019/12/23 20:18:02 gilles Exp gilles $
4# structure
5# pod documentation
6# use pragmas
7# main program
8# global variables initialization
9# get_options( ) ;
10# default values
11# folder loop
12# subroutines
13# sub usage
14
15
16# pod documentation
17
18=pod
19
20=head1 NAME
21
22imapsync - Email IMAP tool for syncing, copying, migrating
23and archiving email mailboxes between two imap servers, one way,
24and without duplicates.
25
26=head1 VERSION
27
28This documentation refers to Imapsync $Revision: 1.977 $
29
30=head1 USAGE
31
32 To synchronize the source imap account
33 "test1" on server "test1.lamiral.info" with password "secret1"
34 to the destination imap account
35 "test2" on server "test2.lamiral.info" with password "secret2"
36 do:
37
38 imapsync \
39 --host1 test1.lamiral.info --user1 test1 --password1 secret1 \
40 --host2 test2.lamiral.info --user2 test2 --password2 secret2
41
42=head1 DESCRIPTION
43
44We sometimes need to transfer mailboxes from one imap server to
45one another.
46
47Imapsync command is a tool allowing incremental and
48recursive imap transfers from one mailbox to another.
49If you don't understand the previous sentence, it's normal,
50it's pedantic computer oriented jargon.
51
52All folders are transferred, recursively, meaning
53the whole folder hierarchy is taken, all messages in them,
54and all messages flags (\Seen \Answered \Flagged etc.)
55are synced too.
56
57Imapsync reduces the amount of data transferred by not transferring
58a given message if it already resides on the destination side.
59Messages that are on the destination side but not on the
60source side stay as they are (see the --delete2
61option to have a strict sync).
62
63How imapsync knows a message is already on both sides?
64Same specific headers and the transfer is done only once.
65By default, the identification headers are
66"Message-Id:" and "Received:" lines
67but this choice can be changed with the --useheader option.
68
69All flags are preserved, unread messages will stay unread,
70read ones will stay read, deleted will stay deleted.
71
72You can abort the transfer at any time and restart it later,
73imapsync works well with bad connections and interruptions,
74by design. On a terminal hit Ctr-c twice within two seconds
75in order to abort the program. Hit Ctr-c just once makes
76imapsync reconnect to both imap servers.
77
78A classical scenario is synchronizing a mailbox B from another mailbox A
79where you just want to keep a strict copy of A in B. Strict meaning
80all messages in A will be in B but no more.
81
82For this, option --delete2 has to be used, it deletes messages in host2
83folder B that are not in host1 folder A. If you also need to destroy
84host2 folders that are not in host1 then use --delete2folders. See also
85--delete2foldersonly and --delete2foldersbutnot to set up exceptions
86on folders to destroy. INBOX will never be destroy, it's a mandatory
87folder in IMAP.
88
89A different scenario is to delete the messages from the source mailbox
90after a successful transfer, it can be a good feature when migrating
91mailboxes since messages will be only on one side. The source account
92will only have messages that are not on the destination yet, ie,
93messages that arrived after a sync or that failed to be copied.
94
95In that case, use the --delete1 option. Option --delete1 implies also
96option --expunge1 so all messages marked deleted on host1 will be really
97deleted. In IMAP protocol deleting a message does not really delete it,
98it marks it with the flag \Deleted, allowing an undelete. Expunging
99a folder removes, definitively, all the messages marked as \Deleted
100in this folder.
101
102You can also decide to remove empty folders once all of their messages
103have been transferred. Add --delete1emptyfolders to obtain this
104behavior.
105
106
107Imapsync is not adequate for maintaining two active imap accounts
108in synchronization when the user plays independently on both sides.
109Use offlineimap (written by John Goerzen) or mbsync (written by
110Michael R. Elkins) for a 2 ways synchronization.
111
112
113=head1 OPTIONS
114
115 usage: imapsync [options]
116
117The standard options are the six values forming the credentials.
118Three values on each side are needed in order to log in into the IMAP
119servers. These six values are a host, a username, and a password, two times.
120
121Conventions used in the following descriptions of the options:
122
123 str means string
124 int means integer
125 reg means regular expression
126 cmd means command
127
128 --dry : Makes imapsync doing nothing for real, just print what
129 would be done without --dry.
130
131=head2 OPTIONS/credentials
132
133
134 --host1 str : Source or "from" imap server.
135 --port1 int : Port to connect on host1.
136 Optional since default ports are the
137 well known ports imap/143 or imaps/993.
138 --user1 str : User to login on host1.
139 --password1 str : Password for the user1.
140
141 --host2 str : "destination" imap server.
142 --port2 int : Port to connect on host2. Optional
143 --user2 str : User to login on host2.
144 --password2 str : Password for the user2.
145
146 --showpasswords : Shows passwords on output instead of "MASKED".
147 Useful to restart a complete run by just reading
148 the command line used in the log,
149 or to debug passwords.
150 It's not a secure practice at all.
151
152 --passfile1 str : Password file for the user1. It must contain the
153 password on the first line. This option avoids showing
154 the password on the command line like --password1 does.
155 --passfile2 str : Password file for the user2.
156
157You can also pass the passwords in the environment variables
158IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2
159
160=head2 OPTIONS/encryption
161
162 --nossl1 : Do not use a SSL connection on host1.
163 --ssl1 : Use a SSL connection on host1. On by default if possible.
164
165 --nossl2 : Do not use a SSL connection on host2.
166 --ssl2 : Use a SSL connection on host2. On by default if possible.
167
168 --notls1 : Do not use a TLS connection on host1.
169 --tls1 : Use a TLS connection on host1. On by default if possible.
170
171 --notls2 : Do not use a TLS connection on host2.
172 --tls2 : Use a TLS connection on host2. On by default if possible.
173
174 --debugssl int : SSL debug mode from 0 to 4.
175
176 --sslargs1 str : Pass any ssl parameter for host1 ssl or tls connection. Example:
177 --sslargs1 SSL_verify_mode=1 --sslargs1 SSL_version=SSLv3
178 See all possibilities in the new() method of IO::Socket::SSL
179 http://search.cpan.org/perldoc?IO::Socket::SSL#Description_Of_Methods
180 --sslargs2 str : Pass any ssl parameter for host2 ssl or tls connection.
181 See --sslargs1
182
183 --timeout1 int : Connection timeout in seconds for host1.
184 Default is 120 and 0 means no timeout at all.
185 --timeout2 int : Connection timeout in seconds for host2.
186 Default is 120 and 0 means no timeout at all.
187
188
189=head2 OPTIONS/authentication
190
191 --authmech1 str : Auth mechanism to use with host1:
192 PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE.
193 --authmech2 str : Auth mechanism to use with host2. See --authmech1
194
195 --authuser1 str : User to auth with on host1 (admin user).
196 Avoid using --authmech1 SOMETHING with --authuser1.
197 --authuser2 str : User to auth with on host2 (admin user).
198 --proxyauth1 : Use proxyauth on host1. Requires --authuser1.
199 Required by Sun/iPlanet/Netscape IMAP servers to
200 be able to use an administrative user.
201 --proxyauth2 : Use proxyauth on host2. Requires --authuser2.
202
203 --authmd51 : Use MD5 authentication for host1.
204 --authmd52 : Use MD5 authentication for host2.
205 --domain1 str : Domain on host1 (NTLM authentication).
206 --domain2 str : Domain on host2 (NTLM authentication).
207
208
209=head2 OPTIONS/folders
210
211
212 --folder str : Sync this folder.
213 --folder str : and this one, etc.
214 --folderrec str : Sync this folder recursively.
215 --folderrec str : and this one, etc.
216
217 --folderfirst str : Sync this folder first. Ex. --folderfirst "INBOX"
218 --folderfirst str : then this one, etc.
219 --folderlast str : Sync this folder last. --folderlast "[Gmail]/All Mail"
220 --folderlast str : then this one, etc.
221
222 --nomixfolders : Do not merge folders when host1 is case-sensitive
223 while host2 is not (like Exchange). Only the first
224 similar folder is synced (example: with folders
225 "Sent", "SENT" and "sent"
226 on host1 only "Sent" will be synced to host2).
227
228 --skipemptyfolders : Empty host1 folders are not created on host2.
229
230 --include reg : Sync folders matching this regular expression
231 --include reg : or this one, etc.
232 If both --include --exclude options are used, then
233 include is done before.
234 --exclude reg : Skips folders matching this regular expression
235 Several folders to avoid:
236 --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3.
237 --exclude reg : or this one, etc.
238
239 --automap : guesses folders mapping, for folders well known as
240 "Sent", "Junk", "Drafts", "All", "Archive", "Flagged".
241
242 --f1f2 str1=str2 : Force folder str1 to be synced to str2,
243 --f1f2 overrides --automap and --regextrans2.
244
245 --subfolder2 str : Syncs the whole host1 folders hierarchy under the
246 host2 folder named str.
247 It does it internally by adding three
248 --regextrans2 options before all others.
249 Add --debug to see what's really going on.
250
251 --subfolder1 str : Syncs the host1 folders hierarchy which is under folder
252 str to the root hierarchy of host2.
253 It's the couterpart of a sync done by --subfolder2
254 when doing it in the reverse order.
255 Backup/Restore scenario:
256 Use --subfolder2 str for a backup to the folder str
257 on host2. Then use --subfolder1 str for restoring
258 from the folder str, after inverting
259 host1/host2 user1/user2 values.
260
261
262 --subscribed : Transfers subscribed folders.
263 --subscribe : Subscribe to the folders transferred on the
264 host2 that are subscribed on host1. On by default.
265 --subscribeall : Subscribe to the folders transferred on the
266 host2 even if they are not subscribed on host1.
267
268 --prefix1 str : Remove prefix str to all destination folders,
269 usually "INBOX." or "INBOX/" or an empty string "".
270 imapsync guesses the prefix if host1 imap server
271 does not have NAMESPACE capability. So this option
272 should not be used most of the time.
273 --prefix2 str : Add prefix to all host2 folders. See --prefix1
274
275 --sep1 str : Host1 separator. This option should not be used
276 most of the time.
277 Imapsync gets the separator from the server itself,
278 by using NAMESPACE, or it tries to guess it
279 from the folders listing (it counts
280 characters / . \\ \ in folder names and choose the
281 more frequent, or finally / if nothing is found.
282 --sep2 str : Host2 separator. See --sep1
283
284 --regextrans2 reg : Apply the whole regex to each destination folders.
285 --regextrans2 reg : and this one. etc.
286 When you play with the --regextrans2 option, first
287 add also the safe options --dry --justfolders
288 Then, when happy, remove --dry for a run, then
289 remove --justfolders for the next ones.
290 Have in mind that --regextrans2 is applied after
291 the automatic prefix and separator inversion.
292 For examples see:
293 https://imapsync.lamiral.info/FAQ.d/FAQ.Folders_Mapping.txt
294
295=head2 OPTIONS/folders sizes
296
297 --nofoldersizes : Do not calculate the size of each folder at the
298 beginning of the sync. Default is to calculate them.
299 --nofoldersizesatend: Do not calculate the size of each folder at the
300 end of the sync. Default is to calculate them.
301 --justfoldersizes : Exit after having printed the initial folder sizes.
302
303
304=head2 OPTIONS/tmp
305
306
307 --tmpdir str : Where to store temporary files and subdirectories.
308 Will be created if it doesn't exist.
309 Default is system specific, Unix is /tmp but
310 /tmp is often too small and deleted at reboot.
311 --tmpdir /var/tmp should be better.
312 --pidfile str : The file where imapsync pid is written,
313 it can be dirname/filename.
314 Default name is imapsync.pid in tmpdir.
315 --pidfilelocking : Abort if pidfile already exists. Useful to avoid
316 concurrent transfers on the same mailbox.
317
318
319=head2 OPTIONS/log
320
321 --nolog : Turn off logging on file
322 --logfile str : Change the default log filename (can be dirname/filename).
323 --logdir str : Change the default log directory. Default is LOG_imapsync/
324
325The default logfile name is for example
326
327 LOG_imapsync/2019_12_22_23_57_59_532_user1_user2.txt
328
329where:
330
331 2019_12_22_23_57_59_532 is nearly the date of the start
332 YYYY_MM_DD_HH_MM_SS_mmm
333 year_month_day_hour_minute_seconde_millisecond
334
335and user1 user2 are the --user1 --user2 values.
336
337=head2 OPTIONS/messages
338
339 --skipmess reg : Skips messages matching the regex.
340 Example: 'm/[\x80-ff]/' # to avoid 8bits messages.
341 --skipmess is applied before --regexmess
342 --skipmess reg : or this one, etc.
343
344 --skipcrossduplicates : Avoid copying messages that are already copied
345 in another folder, good from Gmail to X when
346 X is not also Gmail.
347 Activated with --gmail1 unless --noskipcrossduplicates
348
349 --debugcrossduplicates : Prints which messages (UIDs) are skipped with
350 --skipcrossduplicates (and in what other folders
351 they are).
352
353 --pipemess cmd : Apply this cmd command to each message content
354 before the copy.
355 --pipemess cmd : and this one, etc.
356 With several --pipemess, the output of each cmd
357 command (STDOUT) is given to the input (STDIN)
358 of the next command.
359 For example,
360 --pipemess cmd1 --pipemess cmd2 --pipemess cmd3
361 is like a Unix pipe:
362 "cat message | cmd1 | cmd2 | cmd3"
363
364 --disarmreadreceipts : Disarms read receipts (host2 Exchange issue)
365
366 --regexmess reg : Apply the whole regex to each message before transfer.
367 Example: 's/\000/ /g' # to replace null by space.
368 --regexmess reg : and this one, etc.
369
370=head2 OPTIONS/labels
371
372Gmail present labels as folders in imap. Imapsync can accelerate the sync
373by syncing X-GM-LABELS, it will avoid to transfer messages when they are
374already on host2.
375
376
377 --synclabels : Syncs also Gmail labels when a message is copied to host2.
378 Activated by default with --gmail1 --gmail2 unless
379 --nosynclabels is added.
380
381 --resynclabels : Resyncs Gmail labels when a message is already on host2.
382 Activated by default with --gmail1 --gmail2 unless
383 --noresynclabels is added.
384
385For Gmail syncs, see also:
386https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt
387
388=head2 OPTIONS/flags
389
390 If you encounter flag problems see also:
391 https://imapsync.lamiral.info/FAQ.d/FAQ.Flags.txt
392
393 --regexflag reg : Apply the whole regex to each flags list.
394 Example: 's/"Junk"//g' # to remove "Junk" flag.
395 --regexflag reg : then this one, etc.
396
397 --resyncflags : Resync flags for already transferred messages.
398 On by default.
399 --noresyncflags : Do not resync flags for already transferred messages.
400 May be useful when a user has already started to play
401 with its host2 account.
402
403=head2 OPTIONS/deletions
404
405 --delete1 : Deletes messages on host1 server after a successful
406 transfer. Option --delete1 has the following behavior:
407 it marks messages as deleted with the IMAP flag
408 \Deleted, then messages are really deleted with an
409 EXPUNGE IMAP command. If expunging after each message
410 slows down too much the sync then use
411 --noexpungeaftereach to speed up, expunging will then be
412 done only twice per folder, one at the beginning and
413 one at the end of a folder sync.
414
415 --expunge1 : Expunge messages on host1 just before syncing a folder.
416 Expunge is done per folder.
417 Expunge aims is to really delete messages marked deleted.
418 An expunge is also done after each message copied
419 if option --delete1 is set (unless --noexpungeaftereach).
420
421 --noexpunge1 : Do not expunge messages on host1.
422
423 --delete1emptyfolders : Deletes empty folders on host1, INBOX excepted.
424 Useful with --delete1 since what remains on host1
425 is only what failed to be synced.
426
427 --delete2 : Delete messages in host2 that are not in
428 host1 server. Useful for backup or pre-sync.
429 --delete2 implies --uidexpunge2
430
431 --delete2duplicates : Delete messages in host2 that are duplicates.
432 Works only without --useuid since duplicates are
433 detected with an header part of each message.
434
435 --delete2folders : Delete folders in host2 that are not in host1 server.
436 For safety, first try it like this (it is safe):
437 --delete2folders --dry --justfolders --nofoldersizes
438 and see what folders will be deleted.
439
440 --delete2foldersonly reg : Delete only folders matching the regex reg.
441 Example: --delete2foldersonly "/^Junk$|^INBOX.Junk$/"
442 This option activates --delete2folders
443
444 --delete2foldersbutnot reg : Do not delete folders matching the regex rex.
445 Example: --delete2foldersbutnot "/Tasks$|Contacts$|Foo$/"
446 This option activates --delete2folders
447
448 --noexpunge2 : Do not expunge messages on host2.
449 --nouidexpunge2 : Do not uidexpunge messages on the host2 account
450 that are not on the host1 account.
451
452
453=head2 OPTIONS/dates
454
455 If you encounter problems with dates, see also:
456 https://imapsync.lamiral.info/FAQ.d/FAQ.Dates.txt
457
458 --syncinternaldates : Sets the internal dates on host2 same as host1.
459 Turned on by default. Internal date is the date
460 a message arrived on a host (Unix mtime).
461 --idatefromheader : Sets the internal dates on host2 same as the
462 ones in "Date:" headers.
463
464
465
466=head2 OPTIONS/message selection
467
468 --maxsize int : Skip messages larger (or equal) than int bytes
469 --minsize int : Skip messages smaller (or equal) than int bytes
470 --maxage int : Skip messages older than int days.
471 final stats (skipped) don't count older messages
472 see also --minage
473 --minage int : Skip messages newer than int days.
474 final stats (skipped) don't count newer messages
475 You can do (+ zone are the messages selected):
476 past|----maxage+++++++++++++++>now
477 past|+++++++++++++++minage---->now
478 past|----maxage+++++minage---->now (intersection)
479 past|++++minage-----maxage++++>now (union)
480
481 --search str : Selects only messages returned by this IMAP SEARCH
482 command. Applied on both sides.
483 For a complete set of what can be search see
484 https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Selection.txt
485
486 --search1 str : Same as --search but for selecting host1 messages only.
487 --search2 str : Same as --search but for selecting host2 messages only.
488 So --search CRIT equals --search1 CRIT --search2 CRIT
489
490 --maxlinelength int : skip messages with a line length longer than int bytes.
491 RFC 2822 says it must be no more than 1000 bytes but
492 real life servers and email clients do more.
493
494
495 --useheader str : Use this header to compare messages on both sides.
496 Ex: Message-ID or Subject or Date.
497 --useheader str and this one, etc.
498
499 --usecache : Use cache to speed up next syncs. Not set by default.
500 --nousecache : Do not use cache. Caveat: --useuid --nousecache creates
501 duplicates on multiple runs.
502 --useuid : Use UIDs instead of headers as a criterion to recognize
503 messages. Option --usecache is then implied unless
504 --nousecache is used.
505
506
507=head2 OPTIONS/miscellaneous
508
509 --syncacls : Synchronizes acls (Access Control Lists).
510 Acls in IMAP are not standardized, be careful
511 since one acl code on one side may signify something
512 else on the other one.
513 --nosyncacls : Does not synchronize acls. This is the default.
514
515 --addheader : When a message has no headers to be identified,
516 --addheader adds a "Message-Id" header,
517 like "Message-Id: 12345@imapsync", where 12345
518 is the imap UID of the message on the host1 folder.
519
520
521=head2 OPTIONS/debugging
522
523 --debug : Debug mode.
524 --debugfolders : Debug mode for the folders part only.
525 --debugcontent : Debug content of the messages transferred. Huge output.
526 --debugflags : Debug mode for flags.
527 --debugimap1 : IMAP debug mode for host1. Very verbose.
528 --debugimap2 : IMAP debug mode for host2. Very verbose.
529 --debugimap : IMAP debug mode for host1 and host2. Twice very verbose.
530 --debugmemory : Debug mode showing memory consumption after each copy.
531
532 --errorsmax int : Exit when int number of errors is reached. Default is 50.
533
534 --tests : Run local non-regression tests. Exit code 0 means all ok.
535 --testslive : Run a live test with test1.lamiral.info imap server.
536 Useful to check the basics. Needs internet connection.
537 --testslive6 : Run a live test with ks2ipv6.lamiral.info imap server.
538 Useful to check the ipv6 connectivity. Needs internet.
539
540
541=head2 OPTIONS/specific
542
543 --gmail1 : sets --host1 to Gmail and other options. See FAQ.Gmail.txt
544 --gmail2 : sets --host2 to Gmail and other options. See FAQ.Gmail.txt
545
546 --office1 : sets --host1 to Office365 and other options. See FAQ.Exchange.txt
547 --office2 : sets --host2 to Office365 and other options. See FAQ.Exchange.txt
548
549 --exchange1 : sets options for Exchange. See FAQ.Exchange.txt
550 --exchange2 : sets options for Exchange. See FAQ.Exchange.txt
551
552 --domino1 : sets options for Domino. See FAQ.Domino.txt
553 --domino2 : sets options for Domino. See FAQ.Domino.txt
554
555
556=head2 OPTIONS/behavior
557
558 --maxmessagespersecond int : limits the number of messages transferred per second.
559
560 --maxbytespersecond int : limits the average transfer rate per second.
561 --maxbytesafter int : starts --maxbytespersecond limitation only after
562 --maxbytesafter amount of data transferred.
563
564 --maxsleep int : do not sleep more than int seconds.
565 On by default, 2 seconds max, like --maxsleep 2
566
567 --abort : terminates a previous call still running.
568 It uses the pidfile to know what process to abort.
569
570 --exitwhenover int : Stop syncing and exits when int total bytes
571 transferred is reached.
572
573 --version : Print only software version.
574 --noreleasecheck : Do not check for any new imapsync release.
575 --releasecheck : Check for new imapsync release.
576 it's an http request to
577 http://imapsync.lamiral.info/prj/imapsync/VERSION
578
579 --noid : Do not send/receive ID command to imap servers.
580
581 --justconnect : Just connect to both servers and print useful
582 information. Need only --host1 and --host2 options.
583 Obsolete since "imapsync --host1 imaphost" alone
584 implies --justconnect
585
586 --justlogin : Just login to both host1 and host2 with users
587 credentials, then exit.
588
589 --justfolders : Do only things about folders (ignore messages).
590
591 --help : print this help.
592
593 Example: to synchronize imap account "test1" on "test1.lamiral.info"
594 to imap account "test2" on "test2.lamiral.info"
595 with test1 password "secret1"
596 and test2 password "secret2"
597
598 imapsync \
599 --host1 test1.lamiral.info --user1 test1 --password1 secret1 \
600 --host2 test2.lamiral.info --user2 test2 --password2 secret2
601
602
603=cut
604# comment
605
606=pod
607
608
609
610=head1 SECURITY
611
612You can use --passfile1 instead of --password1 to give the
613password since it is safer. With --password1 option, on Linux,
614any user on your host can see the password by using the 'ps auxwwww'
615command. Using a variable (like IMAPSYNC_PASSWORD1) is also
616dangerous because of the 'ps auxwwwwe' command. So, saving
617the password in a well protected file (600 or rw-------) is
618the best solution.
619
620Imapsync activates ssl or tls encryption by default, if possible.
621
622What detailed behavior is under this "if possible"?
623
624Imapsync activates ssl if the well known port imaps port (993) is open
625on the imap servers. If the imaps port is closed then it open a
626normal (clear) connection on port 143 but it looks for TLS support
627in the CAPABILITY list of the servers. If TLS is supported
628then imapsync goes to encryption.
629
630If the automatic ssl and the tls detections fail then imapsync will
631not protect against sniffing activities on the network, especially
632for passwords.
633
634If you want to force ssl or tls just use --ssl1 --ssl2 or --tls1 --tls2
635
636See also the document FAQ.Security.txt in the FAQ.d/ directory
637or at https://imapsync.lamiral.info/FAQ.d/FAQ.Security.txt
638
639=head1 EXIT STATUS
640
641Imapsync will exit with a 0 status (return code) if everything went good.
642Otherwise, it exits with a non-zero status. That's classical Unix behavior.
643Here is the list of the exit code values (an integer between 0 and 255).
644The names reflect their meaning:
645
646=for comment
647egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _'
648
649
650 EX_OK => 0 ; #/* successful termination */
651 EX_USAGE => 64 ; #/* command line usage error */
652 EX_NOINPUT => 66 ; #/* cannot open input */
653 EX_UNAVAILABLE => 69 ; #/* service unavailable */
654 EX_SOFTWARE => 70 ; #/* internal software error */
655 EXIT_CATCH_ALL => 1 ; # Any other error
656 EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num
657 EXIT_PID_FILE_ERROR => 8 ;
658 EXIT_CONNECTION_FAILURE => 10 ;
659 EXIT_TLS_FAILURE => 12 ;
660 EXIT_AUTHENTICATION_FAILURE => 16 ;
661 EXIT_SUBFOLDER1_NO_EXISTS => 21 ;
662 EXIT_WITH_ERRORS => 111 ;
663 EXIT_WITH_ERRORS_MAX => 112 ;
664 EXIT_TESTS_FAILED => 254 ; # Like Test::More API
665
666
667
668=head1 LICENSE AND COPYRIGHT
669
670Imapsync is free, open, public but not always gratis software
671cover by the NOLIMIT Public License, now called NLPL.
672See the LICENSE file included in the distribution or just read this
673simple sentence as it IS the licence text:
674
675 "No limits to do anything with this work and this license."
676
677In case it is not long enough, I repeat:
678
679 "No limits to do anything with this work and this license."
680
681Look at https://imapsync.lamiral.info/LICENSE
682
683=head1 AUTHOR
684
685Gilles LAMIRAL <gilles@lamiral.info>
686
687Good feedback is always welcome.
688Bad feedback is very often welcome.
689
690Gilles LAMIRAL earns his living by writing, installing,
691configuring and teaching free, open and often gratis
692software. Imapsync used to be "always gratis" but now it is
693only "often gratis" because imapsync is sold by its author,
694a good way to maintain and support free open public
695software over decades.
696
697=head1 BUGS AND LIMITATIONS
698
699See https://imapsync.lamiral.info/FAQ.d/FAQ.Reporting_Bugs.txt
700
701=head1 IMAP SERVERS supported
702
703See https://imapsync.lamiral.info/S/imapservers.shtml
704
705=head1 HUGE MIGRATION
706
707If you have many mailboxes to migrate think about a little
708shell program. Write a file called file.txt (for example)
709containing users and passwords.
710The separator used in this example is ';'
711
712The file.txt file contains:
713
714user001_1;password001_1;user001_2;password001_2
715user002_1;password002_1;user002_2;password002_2
716user003_1;password003_1;user003_2;password003_2
717user004_1;password004_1;user004_2;password004_2
718user005_1;password005_1;user005_2;password005_2
719...
720
721On Unix the shell program can be:
722
723 { while IFS=';' read u1 p1 u2 p2; do
724 imapsync --host1 imap.side1.org --user1 "$u1" --password1 "$p1" \
725 --host2 imap.side2.org --user2 "$u2" --password2 "$p2" ...
726 done ; } < file.txt
727
728On Windows the batch program can be:
729
730 FOR /F "tokens=1,2,3,4 delims=; eol=#" %%G IN (file.txt) DO imapsync ^
731 --host1 imap.side1.org --user1 %%G --password1 %%H ^
732 --host2 imap.side2.org --user2 %%I --password2 %%J ...
733
734The ... have to be replaced by nothing or any imapsync option.
735Welcome in shell or batch programming !
736
737You will find already written scripts at
738https://imapsync.lamiral.info/examples/
739
740=head1 INSTALL
741
742 Imapsync works under any Unix with Perl.
743
744 Imapsync works under most Windows (2000, XP, Vista, Seven, Eight, Ten
745 and all Server releases 2000, 2003, 2008 and R2, 2012 and R2, 2016)
746 as a standalone binary software called imapsync.exe,
747 usually launched from a batch file in order to avoid always typing
748 the options. There is also a 64bit binary called imapsync_64bit.exe
749
750 Imapsync works under OS X as a standalone binary
751 software called imapsync_bin_Darwin
752
753 Purchase latest imapsync at
754 https://imapsync.lamiral.info/
755
756 You'll receive a link to a compressed tarball called imapsync-x.xx.tgz
757 where x.xx is the version number. Untar the tarball where
758 you want (on Unix):
759
760 tar xzvf imapsync-x.xx.tgz
761
762 Go into the directory imapsync-x.xx and read the INSTALL file.
763 As mentioned at https://imapsync.lamiral.info/#install
764 the INSTALL file can also be found at
765 https://imapsync.lamiral.info/INSTALL.d/INSTALL.ANY.txt
766 It is now split in several files for each system
767 https://imapsync.lamiral.info/INSTALL.d/
768
769=head1 CONFIGURATION
770
771There is no specific configuration file for imapsync,
772everything is specified by the command line parameters
773and the default behavior.
774
775
776=head1 HACKING
777
778Feel free to hack imapsync as the NOLIMIT license permits it.
779
780
781=head1 SIMILAR SOFTWARE
782
783 See also https://imapsync.lamiral.info/S/external.shtml
784 for a better up to date list.
785
786Last updated and verified on Sun Dec 8, 2019.
787
788
789 imapsync: https://github.com/imapsync/imapsync (this is an imapsync copy, sometimes delayed, with --noreleasecheck by default since release 1.592, 2014/05/22)
790 imap_tools: https://web.archive.org/web/20161228145952/http://www.athensfbc.com/imap_tools/. The imap_tools code is now at https://github.com/andrewnimmo/rick-sanders-imap-tools
791 imaputils: https://github.com/mtsatsenko/imaputils (very old imap_tools fork)
792 Doveadm-Sync: https://wiki2.dovecot.org/Tools/Doveadm/Sync ( Dovecot sync tool )
793 davmail: http://davmail.sourceforge.net/
794 offlineimap: http://offlineimap.org/
795 mbsync: http://isync.sourceforge.net/
796 mailsync: http://mailsync.sourceforge.net/
797 mailutil: https://www.washington.edu/imap/ part of the UW IMAP toolkit. (well, seems abandoned now)
798 imaprepl: https://bl0rg.net/software/ http://freecode.com/projects/imap-repl/
799 imapcopy (Pascal): http://www.ardiehl.de/imapcopy/
800 imapcopy (Java): https://code.google.com/archive/p/imapcopy/
801 imapsize: http://www.broobles.com/imapsize/
802 migrationtool: http://sourceforge.net/projects/migrationtool/
803 imapmigrate: http://sourceforge.net/projects/cyrus-utils/
804 larch: https://github.com/rgrove/larch (derived from wonko_imapsync, good at Gmail)
805 wonko_imapsync: http://wonko.com/article/554 (superseded by larch)
806 pop2imap: http://www.linux-france.org/prj/pop2imap/ (I wrote that too)
807 exchange-away: http://exchange-away.sourceforge.net/
808 SyncBackPro: http://www.2brightsparks.com/syncback/sbpro.html
809 ImapSyncClient: https://github.com/ridaamirini/ImapSyncClient
810 MailStore: https://www.mailstore.com/en/products/mailstore-home/
811 mnIMAPSync: https://github.com/manusa/mnIMAPSync
812 imap-upload: http://imap-upload.sourceforge.net/ (A tool for uploading a local mbox file to IMAP4 server)
813 imapbackup: https://github.com/rcarmo/imapbackup (A Python script for incremental backups of IMAP mailboxes)
814 BitRecover email-backup 99 USD, 299 USD https://www.bitrecover.com/email-backup/.
815 ImportExportTools: https://addons.thunderbird.net/en-us/thunderbird/addon/importexporttools/ ImportExportTools for Mozilla Thunderbird by Paolo Kaosmos. ImportExportTools does not do IMAP.
816
817
818
819=head1 HISTORY
820
821I initially wrote imapsync in July 2001 because an enterprise,
822called BaSystemes, paid me to install a new imap server
823without losing huge old mailboxes located in a far
824away remote imap server, accessible by an
825often broken low-bandwidth ISDN link.
826
827I had to verify every mailbox was well transferred, all folders, all messages,
828without wasting bandwidth or creating duplicates upon resyncs. The imapsync
829design was made with the beautiful rsync command in mind.
830
831Imapsync started its life as a patch of the copy_folder.pl
832script. The script copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl
833module tarball source (more precisely in the examples/ directory of the
834Mail-IMAPClient tarball).
835
836So many happened since then that I wonder
837if it remains any lines of the original
838copy_folder.pl in imapsync source code.
839
840
841=cut
842
843
844# use pragmas
845#
846
847use strict ;
848use warnings ;
849use Carp ;
850use Data::Dumper ;
851use Digest::HMAC_SHA1 qw( hmac_sha1 hmac_sha1_hex ) ;
852use Digest::MD5 qw( md5 md5_hex md5_base64 ) ;
853use English qw( -no_match_vars ) ;
854use Errno qw(EAGAIN EPIPE ECONNRESET) ;
855use Fcntl ;
856use File::Basename ;
857use File::Copy::Recursive ;
858use File::Glob qw( :glob ) ;
859use File::Path qw( mkpath rmtree ) ;
860use File::Spec ;
861use File::stat ;
862use Getopt::Long ( ) ;
863use IO::File ;
864use IO::Socket qw( :crlf SOL_SOCKET SO_KEEPALIVE ) ;
865use IO::Socket::INET6 ;
866use IO::Socket::SSL ;
867use IO::Tee ;
868use IPC::Open3 'open3' ;
869use Mail::IMAPClient 3.30 ;
870use MIME::Base64 ;
871use Pod::Usage qw(pod2usage) ;
872use POSIX qw(uname SIGALRM :sys_wait_h) ;
873use Sys::Hostname ;
874use Term::ReadKey ;
875use Test::More ;
876use Time::HiRes qw( time sleep ) ;
877use Time::Local ;
878use Unicode::String ;
879use Cwd ;
880use Readonly ;
881use Sys::MemInfo ;
882use Regexp::Common ;
883use Text::ParseWords ; # for quotewords()
884use File::Tail ;
885
886use Encode ;
887use Encode::IMAPUTF7 ;
888
889
890local $OUTPUT_AUTOFLUSH = 1 ;
891
892# constants
893
894# Let us do like sysexits.h
895# /usr/include/sysexits.h
896# and https://www.tldp.org/LDP/abs/html/exitcodes.html
897
898# Should avoid 2 126 127 128..128+64=192 255
899# Should use 0 1 3..125 193..254
900
901Readonly my $EX_OK => 0 ; #/* successful termination */
902Readonly my $EX_USAGE => 64 ; #/* command line usage error */
903#Readonly my $EX_DATAERR => 65 ; #/* data format error */
904Readonly my $EX_NOINPUT => 66 ; #/* cannot open input */
905#Readonly my $EX_NOUSER => 67 ; #/* addressee unknown */
906#Readonly my $EX_NOHOST => 68 ; #/* host name unknown */
907Readonly my $EX_UNAVAILABLE => 69 ; #/* service unavailable */
908Readonly my $EX_SOFTWARE => 70 ; #/* internal software error */
909#Readonly my $EX_OSERR => 71 ; #/* system error (e.g., can't fork) */
910#Readonly my $EX_OSFILE => 72 ; #/* critical OS file missing */
911#Readonly my $EX_CANTCREAT => 73 ; #/* can't create (user) output file */
912#Readonly my $EX_IOERR => 74 ; #/* input/output error */
913#Readonly my $EX_TEMPFAIL => 75 ; #/* temp failure; user is invited to retry */
914#Readonly my $EX_PROTOCOL => 76 ; #/* remote error in protocol */
915#Readonly my $EX_NOPERM => 77 ; #/* permission denied */
916#Readonly my $EX_CONFIG => 78 ; #/* configuration error */
917
918# Mine
919Readonly my $EXIT_CATCH_ALL => 1 ; # Any other error
920Readonly my $EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num
921Readonly my $EXIT_PID_FILE_ERROR => 8 ;
922Readonly my $EXIT_CONNECTION_FAILURE => 10 ;
923Readonly my $EXIT_TLS_FAILURE => 12 ;
924Readonly my $EXIT_AUTHENTICATION_FAILURE => 16 ;
925Readonly my $EXIT_SUBFOLDER1_NO_EXISTS => 21 ;
926Readonly my $EXIT_WITH_ERRORS => 111 ;
927Readonly my $EXIT_WITH_ERRORS_MAX => 112 ;
928
929
930Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API
931
932
933Readonly my %EXIT_TXT => (
934 $EX_OK => 'EX_OK: successful termination',
935 $EX_USAGE => 'EX_USAGE: command line usage error',
936 $EX_NOINPUT => 'EX_NOINPUT: cannot open input',
937 $EX_UNAVAILABLE => 'EX_UNAVAILABLE: service unavailable',
938 $EX_SOFTWARE => 'EX_SOFTWARE: internal software error',
939
940 $EXIT_CATCH_ALL => 'EXIT_CATCH_ALL',
941 $EXIT_BY_SIGNAL => 'EXIT_BY_SIGNAL',
942 $EXIT_PID_FILE_ERROR => 'EXIT_PID_FILE_ERROR' ,
943 $EXIT_CONNECTION_FAILURE => 'EXIT_CONNECTION_FAILURE',
944 $EXIT_TLS_FAILURE => 'EXIT_TLS_FAILURE',
945 $EXIT_AUTHENTICATION_FAILURE => 'EXIT_AUTHENTICATION_FAILURE',
946 $EXIT_SUBFOLDER1_NO_EXISTS => 'EXIT_SUBFOLDER1_NO_EXISTS',
947 $EXIT_WITH_ERRORS => 'EXIT_WITH_ERRORS',
948 $EXIT_WITH_ERRORS_MAX => 'EXIT_WITH_ERRORS_MAX',
949 $EXIT_TESTS_FAILED => 'EXIT_TESTS_FAILED',
950) ;
951
952
953Readonly my $DEFAULT_LOGDIR => 'LOG_imapsync' ;
954
955Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors.
956Readonly my $ERRORS_MAX_CGI => 20 ; # exit after 20 errors in CGI context.
957
958
959
960Readonly my $INTERVAL_TO_EXIT => 2 ; # interval max to exit instead of reconnect
961
962Readonly my $SPLIT => 100 ; # By default, 100 at a time, not more.
963Readonly my $SPLIT_FACTOR => 10 ; # init_imap() calls Maxcommandlength( $SPLIT_FACTOR * $split )
964 # which means default Maxcommandlength is 10*100 = 1000 characters ;
965
966Readonly my $IMAP_PORT => 143 ; # Well know port for IMAP
967Readonly my $IMAP_SSL_PORT => 993 ; # Well know port for IMAP over SSL
968
969Readonly my $LAST => -1 ;
970Readonly my $MINUS_ONE => -1 ;
971Readonly my $MINUS_TWO => -2 ;
972
973Readonly my $RELEASE_NUMBER_EXAMPLE_1 => '1.351' ;
974Readonly my $RELEASE_NUMBER_EXAMPLE_2 => 42.4242 ;
975
976Readonly my $TCP_PING_TIMEOUT => 5 ;
977Readonly my $DEFAULT_TIMEOUT => 120 ;
978Readonly my $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND => 3 ;
979Readonly my $DEFAULT_UIDNEXT => 999_999 ;
980Readonly my $DEFAULT_BUFFER_SIZE => 4096 ;
981
982Readonly my $MAX_SLEEP => 2 ; # 2 seconds max for limiting too long sleeps from --maxbytespersecond and --maxmessagespersecond
983
984Readonly my $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12 => 3600 ;
985
986Readonly my $PERMISSION_FILTER => 7777 ;
987
988Readonly my $KIBI => 1024 ;
989
990Readonly my $NUMBER_10 => 10 ;
991Readonly my $NUMBER_42 => 42 ;
992Readonly my $NUMBER_100 => 100 ;
993Readonly my $NUMBER_200 => 200 ;
994Readonly my $NUMBER_300 => 300 ;
995Readonly my $NUMBER_123456 => 123_456 ;
996Readonly my $NUMBER_654321 => 654_321 ;
997
998Readonly my $NUMBER_20_000 => 20_000 ;
999
1000Readonly my $QUOTA_PERCENT_LIMIT => 90 ;
1001
1002Readonly my $NUMBER_104_857_600 => 104_857_600 ;
1003
1004Readonly my $SIZE_MAX_STR => 64 ;
1005
1006Readonly my $NB_SECONDS_IN_A_DAY => 86_400 ;
1007
1008Readonly my $STD_CHAR_PER_LINE => 80 ;
1009
1010Readonly my $TRUE => 1 ;
1011Readonly my $FALSE => 0 ;
1012
1013Readonly my $LAST_RESSORT_SEPARATOR => q{/} ;
1014
1015Readonly my $CGI_TMPDIR_TOP => '/var/tmp/imapsync_cgi' ;
1016Readonly my $CGI_HASHFILE => '/var/tmp/imapsync_hash' ;
1017Readonly my $UMASK_PARANO => '0077' ;
1018
1019Readonly my $STR_use_releasecheck => q{Check if a new imapsync release is available by adding --releasecheck} ;
1020
1021Readonly my $GMAIL_MAXSIZE => 35_651_584 ;
1022
1023Readonly my $FORCE => 1 ;
1024
1025# if ( 'MSWin32' eq $OSNAME )
1026# if ( 'darwin' eq $OSNAME )
1027# if ( 'linux' eq $OSNAME )
1028
1029
1030
1031# global variables
1032# Currently working to finish with only $sync
1033# Not finished yet...
1034
1035my(
1036 $sync,
1037 $timestart_str,
1038 $debugimap, $debugimap1, $debugimap2, $debugcontent, $debugflags,
1039 $debuglist, $debugdev, $debugmaxlinelength, $debugcgi,
1040 $domain1, $domain2,
1041
1042 @include, @exclude, @folderrec,
1043 @folderfirst, @folderlast,
1044 @h1_folders_all, %h1_folders_all,
1045 @h2_folders_all, %h2_folders_all,
1046 @h2_folders_from_1_wanted, %h2_folders_from_1_all,
1047 %requested_folder,
1048 $h1_folders_wanted_nb, $h1_folders_wanted_ct,
1049 @h2_folders_not_in_1,
1050 %h1_subscribed_folder, %h2_subscribed_folder,
1051 %h2_folders_from_1_wanted,
1052 %h2_folders_from_1_several,
1053
1054 $prefix1, $prefix2,
1055 @regexmess, @regexflag, @skipmess, @pipemess, $pipemesscheck,
1056 $flagscase, $filterflags, $syncflagsaftercopy,
1057 $syncinternaldates,
1058 $idatefromheader,
1059 $syncacls,
1060 $fastio1, $fastio2,
1061 $minsize, $maxage, $minage,
1062 $search,
1063 $skipheader, @useheader, %useheader,
1064 $skipsize, $allowsizemismatch, $buffersize,
1065
1066
1067 $authmd5, $authmd51, $authmd52,
1068 $subscribed, $subscribe, $subscribeall,
1069 $help,
1070 $justbanner,
1071 $fast,
1072
1073 $nb_msg_skipped_dry_mode,
1074 $h1_nb_msg_duplicate,
1075 $h2_nb_msg_duplicate,
1076 $h2_nb_msg_noheader,
1077
1078 $h2_nb_msg_deleted,
1079
1080 $h1_bytes_processed,
1081
1082 $h1_nb_msg_end, $h1_bytes_end,
1083 $h2_nb_msg_end, $h2_bytes_end,
1084
1085 $timeout,
1086 $timestart_int,
1087
1088 $uid1, $uid2,
1089 $authuser1, $authuser2,
1090 $proxyauth1, $proxyauth2,
1091 $authmech1, $authmech2,
1092 $split1, $split2,
1093 $reconnectretry1, $reconnectretry2,
1094 $max_msg_size_in_bytes,
1095 $modulesversion,
1096 $delete2folders, $delete2foldersonly, $delete2foldersbutnot,
1097 $usecache, $debugcache, $cacheaftercopy,
1098 $wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess,
1099 $checkmessageexists,
1100 $messageidnodomain,
1101 $fixInboxINBOX,
1102 $maxlinelength, $maxlinelengthcmd,
1103 $minmaxlinelength,
1104 $uidnext_default,
1105 $fixcolonbug,
1106 $create_folder_old,
1107 $skipcrossduplicates, $debugcrossduplicates,
1108 $disarmreadreceipts,
1109 $mixfolders,
1110 $fetch_hash_set,
1111 $cgidir,
1112 %month_abrev,
1113 $SSL_VERIFY_POLICY,
1114 $warn_release,
1115) ;
1116
1117single_sync( ) ;
1118
1119sub single_sync
1120{
1121
1122# main program
1123# global variables initialization
1124
1125# I'm currently removing all global variables except $sync
1126# passing each of them under $sync->{variable_name}
1127
1128$sync->{timestart} = time ; # Is a float because of use Time::HiRres
1129
1130$sync->{rcs} = q{$Id: imapsync,v 1.977 2019/12/23 20:18:02 gilles Exp gilles $} ;
1131
1132$sync->{ memory_consumption_at_start } = memory_consumption( ) || 0 ;
1133
1134
1135my @loadavg = loadavg( ) ;
1136
1137$sync->{cpu_number} = cpu_number( ) ;
1138$sync->{loaddelay} = load_and_delay( $sync->{cpu_number}, @loadavg ) ;
1139$sync->{loadavg} = join( q{ }, $loadavg[ 0 ] )
1140 . " on $sync->{cpu_number} cores and "
1141 . ram_memory_info( ) ;
1142
1143
1144
1145$sync->{ total_bytes_transferred } = 0 ;
1146$sync->{ total_bytes_skipped } = 0 ;
1147$sync->{ nb_msg_transferred } = 0 ;
1148$sync->{ nb_msg_skipped } = $nb_msg_skipped_dry_mode = 0 ;
1149$sync->{ h1_nb_msg_deleted } = 0 ;
1150$h2_nb_msg_deleted = 0 ;
1151$h1_nb_msg_duplicate = 0 ;
1152$h2_nb_msg_duplicate = 0 ;
1153$sync->{ h1_nb_msg_noheader } = 0 ;
1154$h2_nb_msg_noheader = 0 ;
1155
1156
1157$sync->{ h1_nb_msg_start } = 0 ;
1158$sync->{ h1_bytes_start } = 0 ;
1159$sync->{ h2_nb_msg_start } = 0 ;
1160$sync->{ h2_bytes_start } = 0 ;
1161$sync->{ h1_nb_msg_processed } = $h1_bytes_processed = 0 ;
1162
1163$sync->{ h2_nb_msg_crossdup } = 0 ;
1164
1165#$h1_nb_msg_end = $h1_bytes_end = 0 ;
1166#$h2_nb_msg_end = $h2_bytes_end = 0 ;
1167
1168$sync->{nb_errors} = 0;
1169$max_msg_size_in_bytes = 0;
1170
1171%month_abrev = (
1172 Jan => '00',
1173 Feb => '01',
1174 Mar => '02',
1175 Apr => '03',
1176 May => '04',
1177 Jun => '05',
1178 Jul => '06',
1179 Aug => '07',
1180 Sep => '08',
1181 Oct => '09',
1182 Nov => '10',
1183 Dec => '11',
1184);
1185
1186
1187
1188# Just create a CGI object if under cgi context only.
1189# Needed for the get_options() call
1190cgibegin( $sync ) ;
1191
1192# In cgi context, printing must start by the header so we delay other prints by using output() storage
1193my $options_good = get_options( $sync, @ARGV ) ;
1194# Is it the first myprint?
1195docker_context( $sync ) ;
1196cgibuildheader( $sync ) ;
1197
1198myprint( output( $sync ) ) ;
1199output_reset_with( $sync ) ;
1200
1201# Old place for cgiload( $sync ) ;
1202
1203# don't go on if options are not all known.
1204if ( ! defined $options_good ) { exit $EX_USAGE ; }
1205
1206# If you want releasecheck not to be done by default (like the github maintainer),
1207# then just uncomment the first "$sync->{releasecheck} =" line, the line ending with "0 ;",
1208# the second line (ending with "1 ;") can then stay active or be commented,
1209# the result will be the same: no releasecheck by default (because 0 is then the defined value).
1210
1211#$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 0 ;
1212$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 1 ;
1213
1214# just the version
1215if ( $sync->{ version } ) {
1216 myprint( imapsync_version( $sync ), "\n" ) ;
1217 exit 0 ;
1218}
1219
1220#$sync->{debugenv} = 1 ;
1221$sync->{debugenv} and printenv( $sync ) ; # if option --debugenv
1222load_modules( ) ;
1223
1224# after_get_options call usage and exit if --help or options were not well got
1225after_get_options( $sync, $options_good ) ;
1226
1227
1228# Under CGI environment, fix caveat emptor potential issues
1229cgisetcontext( $sync ) ;
1230
1231# --gmail --gmail --exchange --office etc.
1232easyany( $sync ) ;
1233
1234$sync->{ sanitize } = defined $sync->{ sanitize } ? $sync->{ sanitize } : 1 ;
1235sanitize( $sync ) ;
1236
1237$sync->{ tmpdir } ||= File::Spec->tmpdir( ) ;
1238
1239# Unit tests
1240testsexit( $sync ) ;
1241
1242# init live varaiables
1243testslive_init( $sync ) if ( $sync->{testslive} ) ;
1244testslive6_init( $sync ) if ( $sync->{testslive6} ) ;
1245
1246#
1247
1248pidfile( $sync ) ;
1249
1250# old abort place
1251
1252install_signals( $sync ) ;
1253
1254$sync->{log} = defined $sync->{log} ? $sync->{log} : 1 ;
1255$sync->{errorsdump} = defined $sync->{errorsdump} ? $sync->{errorsdump} : 1 ;
1256$sync->{errorsmax} = defined $sync->{errorsmax} ? $sync->{errorsmax} : $ERRORS_MAX ;
1257
1258# log and output
1259binmode STDOUT, ":encoding(UTF-8)" ;
1260
1261if ( $sync->{log} ) {
1262 setlogfile( $sync ) ;
1263 teelaunch( $sync ) ;
1264 # now $sync->{tee} is a filehandle to STDOUT and the logfile
1265}
1266
1267#binmode STDERR, ":encoding(UTF-8)" ;
1268# STDERR goes to the same place: LOG and STDOUT (if logging is on)
1269# Useful only for --debugssl
1270$sync->{tee} and local *STDERR = *${$sync->{tee}}{IO} ;
1271
1272
1273
1274$timestart_int = int( $sync->{timestart} ) ;
1275$sync->{timebefore} = $sync->{timestart} ;
1276
1277
1278$timestart_str = localtime( $sync->{timestart} ) ;
1279
1280# The prints in the log starts here
1281
1282myprint( localhost_info( $sync ), "\n" ) ;
1283myprint( "Transfer started at $timestart_str\n" ) ;
1284myprint( "PID is $PROCESS_ID my PPID is ", mygetppid( ), "\n" ) ;
1285myprint( "Log file is $sync->{logfile} ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) if ( $sync->{log} ) ;
1286myprint( "Load is " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $sync->{cpu_number} cores\n" ) ;
1287#myprintf( "Memory consumption so far: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ;
1288myprint( 'Current directory is ' . getcwd( ) . "\n" ) ;
1289myprint( 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ;
1290myprint( 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ;
1291
1292$modulesversion = defined $modulesversion ? $modulesversion : 1 ;
1293
1294$warn_release = ( $sync->{releasecheck} ) ? check_last_release( ) : $STR_use_releasecheck ;
1295
1296
1297$wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1;
1298
1299# Activate --usecache if --useuid is set and no --nousecache
1300$usecache = 1 if ( $useuid and ( ! defined $usecache ) ) ;
1301$cacheaftercopy = 1 if ( $usecache and ( ! defined $cacheaftercopy ) ) ;
1302
1303$sync->{ checkselectable } = defined $sync->{ checkselectable } ? $sync->{ checkselectable } : 1 ;
1304$sync->{ checkfoldersexist } = defined $sync->{ checkfoldersexist } ? $sync->{ checkfoldersexist } : 1 ;
1305$checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ;
1306$sync->{ expungeaftereach } = defined $sync->{ expungeaftereach } ? $sync->{ expungeaftereach } : 1 ;
1307
1308# abletosearch is on by default
1309$sync->{abletosearch} = defined $sync->{abletosearch} ? $sync->{abletosearch} : 1 ;
1310$sync->{abletosearch1} = defined $sync->{abletosearch1} ? $sync->{abletosearch1} : $sync->{abletosearch} ;
1311$sync->{abletosearch2} = defined $sync->{abletosearch2} ? $sync->{abletosearch2} : $sync->{abletosearch} ;
1312$checkmessageexists = 0 if ( not $sync->{abletosearch1} ) ;
1313
1314
1315$sync->{showpasswords} = defined $sync->{showpasswords} ? $sync->{showpasswords} : 0 ;
1316$sync->{ fixslash2 } = defined $sync->{ fixslash2 } ? $sync->{ fixslash2 } : 1 ;
1317$fixInboxINBOX = defined $fixInboxINBOX ? $fixInboxINBOX : 1 ;
1318$create_folder_old = defined $create_folder_old ? $create_folder_old : 0 ;
1319$mixfolders = defined $mixfolders ? $mixfolders : 1 ;
1320$sync->{automap} = defined $sync->{automap} ? $sync->{automap} : 0 ;
1321
1322$sync->{ delete2duplicates } = 1 if ( $sync->{ delete2 } and ( ! defined $sync->{ delete2duplicates } ) ) ;
1323
1324$sync->{maxmessagespersecond} = defined $sync->{maxmessagespersecond} ? $sync->{maxmessagespersecond} : 0 ;
1325$sync->{maxbytespersecond} = defined $sync->{maxbytespersecond} ? $sync->{maxbytespersecond} : 0 ;
1326
1327$sync->{sslcheck} = defined $sync->{sslcheck} ? $sync->{sslcheck} : 1 ;
1328
1329myprint( banner_imapsync( $sync, @ARGV ) ) ;
1330
1331myprint( "Temp directory is $sync->{ tmpdir } ( to change it use --tmpdir dirpath )\n" ) ;
1332
1333myprint( output( $sync ) ) ;
1334output_reset_with( $sync ) ;
1335
1336do_valid_directory( $sync->{ tmpdir } ) || croak "Error creating tmpdir $sync->{ tmpdir } : $OS_ERROR" ;
1337
1338remove_pidfile_not_running( $sync->{pidfile} ) ;
1339
1340# if another imapsync is running then tail -f its logfile and exit
1341# useful in cgi context
1342if ( $sync->{ tail } and tail( $sync ) )
1343{
1344 $sync->{nb_errors}++ ;
1345 exit_clean( $sync, $EX_OK, "Tail -f finished. Now finishing myself processus $PROCESS_ID\n" ) ;
1346 exit $EX_OK ;
1347}
1348
1349if ( ! write_pidfile( $sync ) ) {
1350 myprint( "Exiting with return value $EXIT_PID_FILE_ERROR ($EXIT_TXT{$EXIT_PID_FILE_ERROR}) $sync->{nb_errors}/$sync->{errorsmax} nb_errors/max_errors\n" ) ;
1351 exit $EXIT_PID_FILE_ERROR ;
1352}
1353
1354
1355# New place for abort
1356# abort before simulong in order to be able to abort a simulong sync
1357if ( $sync->{ abort } )
1358{
1359 abort( $sync ) ;
1360}
1361
1362# simulong is just a loop printing some lines for xx seconds with option "--simulong xx".
1363if ( $sync->{ simulong } )
1364{
1365 simulong( $sync->{ simulong } ) ;
1366}
1367
1368
1369# New place for cgiload 2019_03_03
1370# because I want to log it
1371# Can break here if load is too heavy
1372cgiload( $sync ) ;
1373
1374
1375$fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ;
1376
1377if ( $usecache and $fixcolonbug ) { tmpdir_fix_colon_bug( $sync ) } ;
1378
1379$modulesversion and myprint( "Modules version list:\n", modulesversion(), "( use --no-modulesversion to turn off printing this Perl modules list )\n" ) ;
1380
1381
1382check_lib_version( $sync ) or
1383 croak "imapsync needs perl lib Mail::IMAPClient release 3.30 or superior.\n";
1384
1385
1386exit_clean( $sync, $EX_OK ) if ( $justbanner ) ;
1387
1388# turn on RFC standard flags correction like \SEEN -> \Seen
1389$flagscase = defined $flagscase ? $flagscase : 1 ;
1390
1391# Use PERMANENTFLAGS if available
1392$filterflags = defined $filterflags ? $filterflags : 1 ;
1393
1394# sync flags just after an APPEND, some servers ignore the flags given in the APPEND
1395# like MailEnable IMAP server.
1396# Off by default since it takes time.
1397$syncflagsaftercopy = defined $syncflagsaftercopy ? $syncflagsaftercopy : 0 ;
1398
1399# update flags on host2 for already transferred messages
1400$sync->{resyncflags} = defined $sync->{resyncflags} ? $sync->{resyncflags} : 1 ;
1401if ( $sync->{resyncflags} ) {
1402 myprint( "Info: will resync flags for already transferred messages. Use --noresyncflags to not resync flags.\n" ) ;
1403}else{
1404 myprint( "Info: will not resync flags for already transferred messages. Use --resyncflags to resync flags.\n" ) ;
1405}
1406
1407
1408sslcheck( $sync ) ;
1409#print Data::Dumper->Dump( [ \$sync ] ) ;
1410
1411$split1 ||= $SPLIT ;
1412$split2 ||= $SPLIT ;
1413
1414#$sync->{host1} || missing_option( $sync, '--host1' ) ;
1415$sync->{port1} ||= ( $sync->{ssl1} ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
1416
1417#$sync->{host2} || missing_option( $sync, '--host2' ) ;
1418$sync->{port2} ||= ( $sync->{ssl2} ) ? $IMAP_SSL_PORT : $IMAP_PORT ;
1419
1420$debugimap1 = $debugimap2 = 1 if ( $debugimap ) ;
1421$sync->{ debug } = 1 if ( $debugimap1 or $debugimap2 ) ;
1422
1423# By default, don't take size to compare
1424$skipsize = (defined $skipsize) ? $skipsize : 1;
1425
1426$uid1 = defined $uid1 ? $uid1 : 1;
1427$uid2 = defined $uid2 ? $uid2 : 1;
1428
1429$subscribe = defined $subscribe ? $subscribe : 1;
1430
1431# Allow size mismatch by default
1432$allowsizemismatch = defined $allowsizemismatch ? $allowsizemismatch : 1;
1433
1434
1435if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) {
1436 $delete2folders = 1 ;
1437}
1438
1439
1440my %SSL_VERIFY_STR ;
1441
1442Readonly $SSL_VERIFY_POLICY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ;
1443Readonly %SSL_VERIFY_STR => (
1444 IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE, ie, do not check the certificate server.' ,
1445 IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER, ie, check the certificate server' ,
1446) ;
1447
1448$IO::Socket::SSL::DEBUG = defined( $sync->{debugssl} ) ? $sync->{debugssl} : 1 ;
1449
1450
1451if ( $sync->{ssl1} or $sync->{ssl2} or $sync->{tls1} or $sync->{tls2}) {
1452 myprint( "SSL debug mode level is --debugssl $IO::Socket::SSL::DEBUG (can be set from 0 meaning no debug to 4 meaning max debug)\n" ) ;
1453}
1454
1455if ( $sync->{ssl1} ) {
1456 myprint( qq{Host1: SSL default mode is like --sslargs1 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host1 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ;
1457 myprint( 'Host1: Use --sslargs1 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host1\n" ) ;
1458}
1459
1460if ( $sync->{ssl2} ) {
1461 myprint( qq{Host2: SSL default mode is like --sslargs2 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host2 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ;
1462 myprint( 'Host2: Use --sslargs2 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host2\n" ) ;
1463}
1464
1465# ID on by default since 1.832
1466$sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ;
1467
1468if ( $sync->{justconnect}
1469 or not $sync->{user1}
1470 or not $sync->{user2}
1471 or not $sync->{host1}
1472 or not $sync->{host2}
1473 )
1474{
1475 my $justconnect = justconnect( $sync ) ;
1476
1477 myprint( debugmemory( $sync, " after justconnect() call" ) ) ;
1478 exit_clean( $sync, $EX_OK,
1479 "Exiting after a justconnect on host(s): $justconnect\n"
1480 ) ;
1481}
1482
1483
1484#$sync->{user1} || missing_option( $sync, '--user1' ) ;
1485#$sync->{user2} || missing_option( $sync, '--user2' ) ;
1486
1487$syncinternaldates = defined $syncinternaldates ? $syncinternaldates : 1;
1488
1489# Turn on expunge if there is not explicit option --noexpunge1 and option
1490# --delete1 is given.
1491# Done because --delete1 --noexpunge1 is very dangerous on the second run:
1492# the Deleted flag is then synced to all previously transferred messages.
1493# So --delete1 implies --expunge1 is a better usability default behavior.
1494if ( $sync->{ delete1 } ) {
1495 if ( ! defined $sync->{ expunge1 } ) {
1496 myprint( "Info: turning on --expunge1 because --delete1 --noexpunge1 is very dangerous on the second run.\n" ) ;
1497 $sync->{ expunge1 } = 1 ;
1498 }
1499 myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ;
1500}
1501
1502if ( $sync->{ uidexpunge2 } and not Mail::IMAPClient->can( 'uidexpunge' ) ) {
1503 myprint( "Failure: uidexpunge not supported (IMAPClient release < 3.17), use nothing or --expunge2 instead\n" ) ;
1504 $sync->{nb_errors}++ ;
1505 exit_clean( $sync, $EX_SOFTWARE ) ;
1506}
1507
1508if ( ( $sync->{ delete2 } or $sync->{ delete2duplicates } ) and not defined $sync->{ uidexpunge2 } ) {
1509 if ( Mail::IMAPClient->can( 'uidexpunge' ) ) {
1510 myprint( "Info: will act as --uidexpunge2\n" ) ;
1511 $sync->{ uidexpunge2 } = 1 ;
1512 }elsif ( not defined $sync->{ expunge2 } ) {
1513 myprint( "Info: will act as --expunge2 (no uidexpunge support)\n" ) ;
1514 $sync->{ expunge2 } = 1 ;
1515 }
1516}
1517
1518if ( $sync->{ delete1 } and $sync->{ delete2 } ) {
1519 myprint( "Warning: using --delete1 and --delete2 together is almost always a bad idea, exiting imapsync\n" ) ;
1520 $sync->{nb_errors}++ ;
1521 exit_clean( $sync, $EX_USAGE ) ;
1522}
1523
1524if ( $idatefromheader ) {
1525 myprint( 'Turned ON idatefromheader, ',
1526 "will set the internal dates on host2 from the 'Date:' header line.\n" ) ;
1527 $syncinternaldates = 0 ;
1528}
1529
1530if ( $syncinternaldates ) {
1531 myprint( 'Info: turned ON syncinternaldates, ',
1532 "will set the internal dates (arrival dates) on host2 same as host1.\n" ) ;
1533}else{
1534 myprint( "Info: turned OFF syncinternaldates\n" ) ;
1535}
1536
1537if ( defined $authmd5 and $authmd5 ) {
1538 $authmd51 = 1 ;
1539 $authmd52 = 1 ;
1540}
1541
1542if ( defined $authmd51 and $authmd51 ) {
1543 $authmech1 ||= 'CRAM-MD5';
1544}
1545else{
1546 $authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN';
1547}
1548
1549if ( defined $authmd52 and $authmd52 ) {
1550 $authmech2 ||= 'CRAM-MD5';
1551}
1552else{
1553 $authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN';
1554}
1555
1556$authmech1 = uc $authmech1;
1557$authmech2 = uc $authmech2;
1558
1559if (defined $proxyauth1 && !$authuser1) {
1560 missing_option( $sync, 'With --proxyauth1, --authuser1' ) ;
1561}
1562
1563if (defined $proxyauth2 && !$authuser2) {
1564 missing_option( $sync, 'With --proxyauth2, --authuser2' ) ;
1565}
1566
1567#$authuser1 ||= $sync->{user1};
1568#$authuser2 ||= $sync->{user2};
1569
1570myprint( "Host1: will try to use $authmech1 authentication on host1\n") ;
1571myprint( "Host2: will try to use $authmech2 authentication on host2\n") ;
1572
1573$timeout = defined $timeout ? $timeout : $DEFAULT_TIMEOUT ;
1574
1575$sync->{h1}->{timeout} = defined $sync->{h1}->{timeout} ? $sync->{h1}->{timeout} : $timeout ;
1576myprint( "Host1: imap connection timeout is $sync->{h1}->{timeout} seconds\n") ;
1577$sync->{h2}->{timeout} = defined $sync->{h2}->{timeout} ? $sync->{h2}->{timeout} : $timeout ;
1578myprint( "Host2: imap connection timeout is $sync->{h2}->{timeout} seconds\n" ) ;
1579
1580$syncacls = defined $syncacls ? $syncacls : 0 ;
1581
1582# No folders sizes if --justfolders, unless really wanted.
1583if (
1584 $sync->{ justfolders }
1585 and not defined $sync->{ foldersizes }
1586 and not $sync->{ justfoldersizes } )
1587{
1588 $sync->{ foldersizes } = 0 ;
1589 $sync->{ foldersizesatend } = 1 ;
1590}
1591
1592$sync->{ foldersizes } = ( defined $sync->{ foldersizes } ) ? $sync->{ foldersizes } : 1 ;
1593$sync->{ foldersizesatend } = ( defined $sync->{ foldersizesatend } ) ? $sync->{ foldersizesatend } : $sync->{ foldersizes } ;
1594
1595
1596$fastio1 = defined $fastio1 ? $fastio1 : 0 ;
1597$fastio2 = defined $fastio2 ? $fastio2 : 0 ;
1598
1599$reconnectretry1 = defined $reconnectretry1 ? $reconnectretry1 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
1600$reconnectretry2 = defined $reconnectretry2 ? $reconnectretry2 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
1601
1602# Since select_msgs() returns no messages when uidnext does not return something
1603# then $uidnext_default is never used. So I have to remove it.
1604$uidnext_default = $DEFAULT_UIDNEXT ;
1605
1606if ( ! @useheader ) { @useheader = qw( Message-Id Received ) ; }
1607
1608# Make a hash %useheader of each --useheader 'key' in uppercase
1609for ( @useheader ) { $useheader{ uc $_ } = undef } ;
1610
1611#myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ;
1612#exit ;
1613
1614myprint( "Host1: IMAP server [$sync->{host1}] port [$sync->{port1}] user [$sync->{user1}]\n" ) ;
1615myprint( "Host2: IMAP server [$sync->{host2}] port [$sync->{port2}] user [$sync->{user2}]\n" ) ;
1616
1617get_password1( $sync ) ;
1618get_password2( $sync ) ;
1619
1620
1621$sync->{dry_message} = q{} ;
1622if( $sync->{dry} ) {
1623 $sync->{dry_message} = "\t(not really since --dry mode)" ;
1624}
1625
1626$sync->{ search1 } ||= $search if ( $search ) ;
1627$sync->{ search2 } ||= $search if ( $search ) ;
1628
1629if ( $disarmreadreceipts ) {
1630 push @regexmess, q{s{\A((?:[^\n]+\r\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims} ;
1631}
1632
1633$pipemesscheck = ( defined $pipemesscheck ) ? $pipemesscheck : 1 ;
1634
1635if ( @pipemess and $pipemesscheck ) {
1636 myprint( 'Checking each --pipemess command, '
1637 . join( q{, }, @pipemess )
1638 . ", with an space string. ( Can avoid this check with --nopipemesscheck )\n" ) ;
1639 my $string = pipemess( q{ }, @pipemess ) ;
1640 # string undef means something was bad.
1641 if ( not ( defined $string ) ) {
1642 $sync->{nb_errors}++ ;
1643 exit_clean( $sync, $EX_USAGE,
1644 "Error: one of --pipemess command is bad, check it\n"
1645 ) ;
1646 }
1647 myprint( "Ok with each --pipemess @pipemess\n" ) ;
1648}
1649
1650if ( $maxlinelengthcmd ) {
1651 myprint( "Checking --maxlinelengthcmd command,
1652 $maxlinelengthcmd, with an space string.\n"
1653 ) ;
1654 my $string = pipemess( q{ }, $maxlinelengthcmd ) ;
1655 # string undef means something was bad.
1656 if ( not ( defined $string ) ) {
1657 $sync->{nb_errors}++ ;
1658 exit_clean( $sync, $EX_USAGE,
1659 "Error: --maxlinelengthcmd command is bad, check it\n"
1660 ) ;
1661 }
1662 myprint( "Ok with --maxlinelengthcmd $maxlinelengthcmd\n" ) ;
1663}
1664
1665if ( @regexmess ) {
1666 my $string = regexmess( q{ } ) ;
1667 myprint( "Checking each --regexmess command with an space string.\n" ) ;
1668 # string undef means one of the eval regex was bad.
1669 if ( not ( defined $string ) ) {
1670 #errors_incr( $sync, 'Warning: one of --regexmess option may be bad, check them' ) ;
1671 exit_clean( $sync, $EX_USAGE,
1672 "Error: one of --regexmess option is bad, check it\n"
1673 ) ;
1674 }
1675 myprint( "Ok with each --regexmess\n" ) ;
1676}
1677
1678if ( @skipmess ) {
1679 myprint( "Checking each --skipmess command with an space string.\n" ) ;
1680 my $match = skipmess( q{ } ) ;
1681 # match undef means one of the eval regex was bad.
1682 if ( not ( defined $match ) ) {
1683 $sync->{nb_errors}++ ;
1684 exit_clean( $sync, $EX_USAGE,
1685 "Error: one of --skipmess option is bad, check it\n"
1686 ) ;
1687 }
1688 myprint( "Ok with each --skipmess\n" ) ;
1689}
1690
1691if ( @regexflag ) {
1692 myprint( "Checking each --regexflag command with an space string.\n" ) ;
1693 my $string = flags_regex( q{ } ) ;
1694 # string undef means one of the eval regex was bad.
1695 if ( not ( defined $string ) ) {
1696 $sync->{nb_errors}++ ;
1697 exit_clean( $sync, $EX_USAGE,
1698 "Error: one of --regexflag option is bad, check it\n"
1699 ) ;
1700 }
1701 myprint( "Ok with each --regexflag\n" ) ;
1702}
1703
1704$sync->{imap1} = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $domain1, $sync->{password1},
1705 $debugimap1, $sync->{h1}->{timeout}, $fastio1, $sync->{ssl1}, $sync->{tls1},
1706 $authmech1, $authuser1, $reconnectretry1,
1707 $proxyauth1, $uid1, $split1, 'Host1', $sync->{h1}, $sync ) ;
1708
1709$sync->{imap2} = login_imap( $sync->{host2}, $sync->{port2}, $sync->{user2}, $domain2, $sync->{password2},
1710 $debugimap2, $sync->{h2}->{timeout}, $fastio2, $sync->{ssl2}, $sync->{tls2},
1711 $authmech2, $authuser2, $reconnectretry2,
1712 $proxyauth2, $uid2, $split2, 'Host2', $sync->{h2}, $sync ) ;
1713
1714
1715$sync->{ debug } and myprint( 'Host1 Buffer I/O: ', $sync->{imap1}->Buffer(), "\n" ) ;
1716$sync->{ debug } and myprint( 'Host2 Buffer I/O: ', $sync->{imap2}->Buffer(), "\n" ) ;
1717
1718
1719if ( ! $sync->{imap1}->IsAuthenticated( ) )
1720{
1721 $sync->{nb_errors}++ ;
1722 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Not authenticated on host1\n" ) ;
1723}
1724myprint( "Host1: state Authenticated\n" ) ;
1725
1726if ( ! $sync->{imap2}->IsAuthenticated( ) )
1727{
1728 $sync->{nb_errors}++ ;
1729 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Not authenticated on host2\n" ) ;
1730}
1731myprint( "Host2: state Authenticated\n" ) ;
1732
1733myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $sync->{imap1}->capability() || [] }), "\n" ) ;
1734
1735#myprint( Data::Dumper->Dump( [ $sync->{imap1} ] ) ) ;
1736#myprint( "imap4rev1: " . $sync->{imap1}->imap4rev1() . "\n" ) ;
1737
1738myprint( 'Host2 capability once authenticated: ', join(q{ }, @{ $sync->{imap2}->capability() || [] }), "\n" ) ;
1739
1740imap_id_stuff( $sync ) ;
1741
1742#quota( $sync, $sync->{imap1}, 'h1' ) ; # quota on host1 is useless and pollute host2 output.
1743quota( $sync, $sync->{imap2}, 'h2' ) ;
1744
1745maxsize_setting( $sync ) ;
1746
1747if ( $sync->{ justlogin } ) {
1748 $sync->{imap1}->logout( ) ;
1749 $sync->{imap2}->logout( ) ;
1750 exit_clean( $sync, $EX_OK, "Exiting because of --justlogin\n" ) ;
1751}
1752
1753
1754#
1755# Folder stuff
1756#
1757
1758$h1_folders_wanted_nb = 0 ; # counter of folders to be done.
1759$h1_folders_wanted_ct = 0 ; # counter of folders done.
1760
1761# All folders on host1 and host2
1762
1763@h1_folders_all = sort $sync->{imap1}->folders( ) ;
1764@h2_folders_all = sort $sync->{imap2}->folders( ) ;
1765
1766myprint( 'Host1: found ', scalar @h1_folders_all , " folders.\n" ) ;
1767myprint( 'Host2: found ', scalar @h2_folders_all , " folders.\n" ) ;
1768
1769foreach my $f ( @h1_folders_all )
1770{
1771 $h1_folders_all{ $f } = 1
1772}
1773
1774foreach my $f ( @h2_folders_all )
1775{
1776 $h2_folders_all{ $f } = 1 ;
1777 $sync->{h2_folders_all_UPPER}{ uc $f } = 1 ;
1778}
1779
1780$sync->{h1_folders_all} = \%h1_folders_all ;
1781$sync->{h2_folders_all} = \%h2_folders_all ;
1782
1783
1784private_folders_separators_and_prefixes( ) ;
1785
1786
1787# Make a hash of subscribed folders in both servers.
1788
1789for ( $sync->{imap1}->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ;
1790for ( $sync->{imap2}->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ;
1791
1792
1793if ( defined $sync->{ subfolder1 } ) {
1794 subfolder1( $sync ) ;
1795}
1796
1797
1798
1799
1800if ( defined $sync->{ subfolder2 } ) {
1801 subfolder2( $sync ) ;
1802}
1803
1804if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) {
1805 push @{ $sync->{ regextrans2 } }, $reg ;
1806}
1807
1808
1809
1810if ( ( $sync->{ folder } and scalar @{ $sync->{ folder } } )
1811 or $subscribed
1812 or scalar @folderrec )
1813{
1814 # folders given by option --folder
1815 if ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) {
1816 add_to_requested_folders( @{ $sync->{ folder } } ) ;
1817 }
1818
1819 # option --subscribed
1820 if ( $subscribed ) {
1821 add_to_requested_folders( keys %h1_subscribed_folder ) ;
1822 }
1823
1824 # option --folderrec
1825 if ( scalar @folderrec ) {
1826 foreach my $folderrec ( @folderrec ) {
1827 add_to_requested_folders( $sync->{imap1}->folders( $folderrec ) ) ;
1828 }
1829 }
1830}
1831else
1832{
1833 # no include, no folder/subscribed/folderrec options => all folders
1834 if ( not scalar @include ) {
1835 myprint( "Including all folders found by default. Use --subscribed or --folder or --folderrec or --include to select specific folders. Use --exclude to unselect specific folders.\n" ) ;
1836 add_to_requested_folders( @h1_folders_all ) ;
1837 }
1838}
1839
1840
1841# consider (optional) includes and excludes
1842if ( scalar @include ) {
1843 foreach my $include ( @include ) {
1844 # No, do not add /x after the regex, never.
1845 # Users would kill you!
1846 my @included_folders = grep { /$include/ } @h1_folders_all ;
1847 add_to_requested_folders( @included_folders ) ;
1848 myprint( "Including folders matching pattern $include\n" . jux_utf8_list( @included_folders ) . "\n" ) ;
1849 }
1850}
1851
1852if ( scalar @exclude ) {
1853 foreach my $exclude ( @exclude ) {
1854 my @requested_folder = sort keys %requested_folder ;
1855 # No, do not add /x after the regex, never.
1856 # Users would kill you!
1857 my @excluded_folders = grep { /$exclude/ } @requested_folder ;
1858 remove_from_requested_folders( @excluded_folders ) ;
1859 myprint( "Excluding folders matching pattern $exclude\n" . jux_utf8_list( @excluded_folders ) . "\n" ) ;
1860 }
1861}
1862
1863
1864# sort before is not very powerful
1865# it adds --folderfirst and --folderlast even if they don't exist on host1
1866#@h1_folders_wanted = sort_requested_folders( ) ;
1867$sync->{h1_folders_wanted} = [ sort_requested_folders( ) ] ;
1868
1869# Remove no selectable folders
1870
1871
1872if ( $sync->{ checkfoldersexist } ) {
1873 my @h1_folders_wanted_exist ;
1874 myprint( "Host1: Checking wanted folders exist. Use --nocheckfoldersexist to avoid this check (shared of public namespace targeted).\n" ) ;
1875 foreach my $folder ( @{ $sync->{h1_folders_wanted} } ) {
1876 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ;
1877 if ( ! exists $h1_folders_all{ $folder } ) {
1878 myprint( "Host1: warning! ignoring folder $folder because it is not in host1 whole folders list.\n" ) ;
1879 next ;
1880 }else{
1881 push @h1_folders_wanted_exist, $folder ;
1882 }
1883 }
1884 @{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_exist ;
1885}else{
1886 myprint( "Host1: Not checking that wanted folders exist. Remove --nocheckfoldersexist to get this check.\n" ) ;
1887}
1888
1889
1890if ( $sync->{ checkselectable } ) {
1891 my @h1_folders_wanted_selectable ;
1892 myprint( "Host1: Checking wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ;
1893 foreach my $folder ( @{ $sync->{h1_folders_wanted} } ) {
1894 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder is selectable on host1\n" ) ;
1895 # It does an imap command LIST "" $folder and then search for no \Noselect
1896 if ( ! $sync->{imap1}->selectable( $folder ) ) {
1897 myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ;
1898 }else{
1899 push @h1_folders_wanted_selectable, $folder ;
1900 }
1901 }
1902 @{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_selectable ;
1903 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Host1: checking folders took ', timenext( $sync ), " s\n" ) ;
1904}else{
1905 myprint( "Host1: Not checking that wanted folders are selectable. Remove --nocheckselectable to get this check.\n" ) ;
1906}
1907
1908
1909
1910# Old place of private_folders_separators_and_prefixes( ) call.
1911#private_folders_separators_and_prefixes( ) ;
1912
1913
1914# this hack is because LWP post does not pass well a hash in the $form parameter
1915# but it does pass well an array
1916%{ $sync->{f1f2h} } = split_around_equal( @{ $sync->{f1f2} } ) ;
1917
1918automap( $sync ) ;
1919
1920
1921foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) {
1922 my $h2_fold ;
1923 $h2_fold = imap2_folder_name( $sync, $h1_fold ) ;
1924 $h2_folders_from_1_wanted{ $h2_fold }++ ;
1925 if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) {
1926 $h2_folders_from_1_several{ $h2_fold }++ ;
1927 }
1928}
1929
1930@h2_folders_from_1_wanted = sort keys %h2_folders_from_1_wanted;
1931
1932
1933foreach my $h1_fold ( @h1_folders_all ) {
1934 my $h2_fold ;
1935 $h2_fold = imap2_folder_name( $sync, $h1_fold ) ;
1936 $h2_folders_from_1_all{ $h2_fold }++ ;
1937 # Follows a fix to avoid deleting folder $sync->{ subfolder2 }
1938 # because it usually does not exist on host1.
1939 if ( $sync->{ subfolder2 } )
1940 {
1941 $h2_folders_from_1_all{ $sync->{ h2_prefix } . $sync->{ subfolder2 } }++ ;
1942 $h2_folders_from_1_all{ $sync->{ subfolder2 } }++ ;
1943 }
1944}
1945
1946
1947
1948myprint( << 'END_LISTING' ) ;
1949
1950++++ Listing folders
1951All foldernames are presented between brackets like [X] where X is the foldername.
1952When a foldername contains non-ASCII characters it is presented in the form
1953[X] = [Y] where
1954X is the imap foldername you have to use in command line options and
1955Y is the utf8 output just printed for convenience, to recognize it.
1956
1957END_LISTING
1958
1959myprint(
1960 "Host1: folders list (first the raw imap format then the [X] = [Y]):\n",
1961 $sync->{imap1}->list( ),
1962 "\n",
1963 jux_utf8_list( @h1_folders_all ),
1964 "\n",
1965 "Host2: folders list (first the raw imap format then the [X] = [Y]):\n",
1966 $sync->{imap2}->list( ),
1967 "\n",
1968 jux_utf8_list( @h2_folders_all ),
1969 "\n",
1970 q{}
1971) ;
1972
1973if ( $subscribed ) {
1974 myprint(
1975 'Host1 subscribed folders list: ',
1976 jux_utf8_list( sort keys %h1_subscribed_folder ), "\n",
1977 ) ;
1978}
1979
1980
1981
1982@h2_folders_not_in_1 = list_folders_in_2_not_in_1( ) ;
1983
1984if ( @h2_folders_not_in_1 ) {
1985 myprint( "Folders in host2 not in host1:\n",
1986 jux_utf8_list( @h2_folders_not_in_1 ), "\n" ) ;
1987}
1988
1989
1990if ( keys %{ $sync->{f1f2auto} } ) {
1991 myprint( "Folders mapping from --automap feature (use --f1f2 to override any mapping):\n" ) ;
1992 foreach my $h1_fold ( keys %{ $sync->{f1f2auto} } ) {
1993 my $h2_fold = $sync->{f1f2auto}{$h1_fold} ;
1994 myprintf( "%-40s -> %-40s\n",
1995 jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ;
1996 }
1997 myprint( "\n" ) ;
1998}
1999
2000if ( keys %{ $sync->{f1f2h} } ) {
2001 myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ;
2002 foreach my $h1_fold ( keys %{ $sync->{f1f2h} } ) {
2003 my $h2_fold = $sync->{f1f2h}{$h1_fold} ;
2004 my $warn = q{} ;
2005 if ( not exists $h1_folders_all{ $h1_fold } ) {
2006 $warn = "BUT $h1_fold does NOT exist on host1!" ;
2007 }
2008 myprintf( "%-40s -> %-40s %s\n",
2009 jux_utf8( $h1_fold ), jux_utf8( $h2_fold ), $warn ) ;
2010 }
2011 myprint( "\n" ) ;
2012}
2013
2014exit_clean( $sync, $EX_OK, "Exiting because of --justfolderlists\n" ) if ( $sync->{ justfolderlists } ) ;
2015exit_clean( $sync, $EX_OK, "Exiting because of --justautomap\n" ) if ( $sync->{ justautomap } ) ;
2016
2017debugsleep( $sync ) ;
2018
2019if ( $sync->{ skipemptyfolders } )
2020{
2021 myprint( "Host1: will not syncing empty folders on host1. Use --noskipemptyfolders to create them anyway on host2\n") ;
2022}
2023
2024
2025if ( $sync->{ foldersizes } ) {
2026
2027 foldersizes_at_the_beggining( $sync ) ;
2028 #foldersizes_at_the_beggining_old( $sync ) ;
2029}
2030
2031
2032
2033if ( $sync->{ justfoldersizes } )
2034{
2035 exit_clean( $sync, $EX_OK, "Exiting because of --justfoldersizes\n" ) ;
2036}
2037
2038$sync->{stats} = 1 ;
2039
2040if ( $sync->{ delete1emptyfolders } ) {
2041 delete1emptyfolders( $sync ) ;
2042}
2043
2044delete_folders_in_2_not_in_1( ) if $delete2folders ;
2045
2046# folder loop
2047$h1_folders_wanted_nb = scalar @{ $sync->{h1_folders_wanted} } ;
2048
2049myprint( "++++ Looping on each one of $h1_folders_wanted_nb folders to sync\n" ) ;
2050
2051$sync->{begin_transfer_time} = time ;
2052
2053my %uid_candidate_for_deletion ;
2054my %uid_candidate_no_deletion ;
2055
2056$sync->{ h2_folders_of_md5 } = { } ;
2057
2058
2059FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } )
2060{
2061 $sync->{ h1_current_folder } = $h1_fold ;
2062 eta_print( $sync ) ;
2063 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2064
2065 my $h2_fold = imap2_folder_name( $sync, $h1_fold ) ;
2066 $sync->{ h2_current_folder } = $h2_fold ;
2067
2068 $h1_folders_wanted_ct++ ;
2069 myprintf( "Folder %7s %-35s -> %-35s\n", "$h1_folders_wanted_ct/$h1_folders_wanted_nb",
2070 jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ;
2071 myprint( debugmemory( $sync, " at folder loop" ) ) ;
2072
2073 # host1 can not be fetched read only, select is needed because of expunge.
2074 select_folder( $sync, $sync->{imap1}, $h1_fold, 'Host1' ) or next FOLDER ;
2075
2076 debugsleep( $sync ) ;
2077
2078 my $h1_fold_nb_messages = count_from_select( $sync->{imap1}->History ) ;
2079 myprint( "Host1: folder [$h1_fold] has $h1_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ;
2080
2081 if ( $sync->{ skipemptyfolders } and 0 == $h1_fold_nb_messages ) {
2082 myprint( "Host1: skipping empty host1 folder [$h1_fold]\n" ) ;
2083 next FOLDER ;
2084 }
2085
2086 # Code added from https://github.com/imapsync/imapsync/issues/95
2087 # Thanks jh1995
2088 # Goal: do not create folder if --search or --max/minage return 0 message.
2089 # even if there are messages by SELECT (no not real empty, empty for the user point of vue).
2090 if ( $sync->{ skipemptyfolders } )
2091 {
2092 my $h1_msgs_all_hash_ref_tmp = { } ;
2093 my @h1_msgs_tmp = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref_tmp, $sync->{ search1 }, $h1_fold ) ;
2094 my $h1_fold_nb_messages_tmp = scalar( @h1_msgs_tmp ) ;
2095 if ( 0 == $h1_fold_nb_messages_tmp ) {
2096 myprint( "Host1: skipping empty host1 folder [$h1_fold] (0 message found by SEARCH)\n" ) ;
2097 next FOLDER ;
2098 }
2099 }
2100
2101 if ( ! exists $h2_folders_all{ $h2_fold } ) {
2102 create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) or next FOLDER ;
2103 }
2104
2105 acls_sync( $h1_fold, $h2_fold ) ;
2106
2107 # Sometimes the folder on host2 is listed (it exists) but is
2108 # not selectable but becomes selectable by a create (Gmail)
2109 select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' )
2110 or ( create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold )
2111 and select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) )
2112 or next FOLDER ;
2113 my @select_results = $sync->{imap2}->Results( ) ;
2114
2115 my $h2_fold_nb_messages = count_from_select( @select_results ) ;
2116 myprint( "Host2: folder [$h2_fold] has $h2_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ;
2117
2118 my $permanentflags2 = permanentflags( @select_results ) ;
2119 myprint( "Host2: folder [$h2_fold] permanentflags: $permanentflags2\n" ) ;
2120
2121 if ( $sync->{ expunge1 } )
2122 {
2123 myprint( "Host1: Expunging $h1_fold $sync->{dry_message}\n" ) ;
2124 if ( ! $sync->{dry} )
2125 {
2126 $sync->{imap1}->expunge( ) ;
2127 }
2128 }
2129
2130 if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribeall )
2131 and not exists $h2_subscribed_folder{ $h2_fold } )
2132 {
2133 myprint( "Host2: Subscribing to folder $h2_fold\n" ) ;
2134 if ( ! $sync->{dry} ) { $sync->{imap2}->subscribe( $h2_fold ) } ;
2135 }
2136
2137 next FOLDER if ( $sync->{ justfolders } ) ;
2138
2139 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2140
2141 my $h1_msgs_all_hash_ref = { } ;
2142 my @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold );
2143
2144 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2145
2146 my $h1_msgs_nb = scalar @h1_msgs ;
2147
2148 myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ;
2149 ( $sync->{ debug } or $debuglist ) and myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ;
2150 $sync->{ debug } and myprint( "Host1: selecting messages of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ;
2151
2152 my $h2_msgs_all_hash_ref = { } ;
2153 my @h2_msgs = select_msgs( $sync->{imap2}, $h2_msgs_all_hash_ref, $sync->{ search2 }, $sync->{abletosearch2}, $h2_fold ) ;
2154
2155 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2156
2157 my $h2_msgs_nb = scalar @h2_msgs ;
2158
2159 myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ;
2160 ( $sync->{ debug } or $debuglist ) and myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ;
2161 $sync->{ debug } and myprint( "Host2: selecting messages of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ;
2162
2163 my $cache_base = "$sync->{ tmpdir }/imapsync_cache/" ;
2164 my $cache_dir = cache_folder( $cache_base,
2165 "$sync->{host1}/$sync->{user1}/$sync->{host2}/$sync->{user2}", $h1_fold, $h2_fold ) ;
2166 my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ;
2167
2168 my $h1_uidvalidity = $sync->{imap1}->uidvalidity( ) || q{} ;
2169 my $h2_uidvalidity = $sync->{imap2}->uidvalidity( ) || q{} ;
2170
2171 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2172
2173 if ( $usecache ) {
2174 myprint( "Local cache directory: $cache_dir ( " . length( $cache_dir ) . " characters long )\n" ) ;
2175 mkpath( "$cache_dir" ) ;
2176 ( $cache_1_2_ref, $cache_2_1_ref )
2177 = get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ;
2178 myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ;
2179 $sync->{ debug } and myprint( '[',
2180 map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ;
2181 }
2182
2183 my %h1_hash = ( ) ;
2184 my %h2_hash = ( ) ;
2185
2186 my ( %h1_msgs, %h2_msgs ) ;
2187 @h1_msgs{ @h1_msgs } = ( ) ;
2188 @h2_msgs{ @h2_msgs } = ( ) ;
2189
2190 my @h1_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_1_2_ref } ;
2191 my @h2_msgs_in_cache = keys %{ $cache_2_1_ref } ;
2192
2193 my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ;
2194 %h1_msgs_not_in_cache = %h1_msgs ;
2195 %h2_msgs_not_in_cache = %h2_msgs ;
2196 delete @h1_msgs_not_in_cache{ @h1_msgs_in_cache } ;
2197 delete @h2_msgs_not_in_cache{ @h2_msgs_in_cache } ;
2198
2199 my @h1_msgs_not_in_cache = keys %h1_msgs_not_in_cache ;
2200 #myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ;
2201 my @h2_msgs_not_in_cache = keys %h2_msgs_not_in_cache ;
2202
2203 my @h2_msgs_delete2_not_in_cache = () ;
2204 %h1_msgs_copy_by_uid = ( ) ;
2205
2206 if ( $useuid ) {
2207 # use uid so we have to avoid getting header
2208 @h1_msgs_copy_by_uid{ @h1_msgs_not_in_cache } = ( ) ;
2209 @h2_msgs_delete2_not_in_cache = @h2_msgs_not_in_cache if $usecache ;
2210 @h1_msgs_not_in_cache = ( ) ;
2211 @h2_msgs_not_in_cache = ( ) ;
2212
2213 #myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ;
2214 }
2215
2216 $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold]\n" ) ;
2217
2218 my ($h1_heads_ref, $h1_fir_ref) = ({}, {});
2219 $h1_heads_ref = $sync->{imap1}->parse_headers([@h1_msgs_not_in_cache], @useheader) if (@h1_msgs_not_in_cache);
2220 $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ;
2221
2222 @{ $h1_fir_ref }{@h1_msgs} = ( undef ) ;
2223
2224 $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold]\n" ) ;
2225
2226 my @h1_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ;
2227 if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h1_common_fetch_param, 'X-GM-LABELS' ; }
2228
2229 if ( $sync->{abletosearch1} )
2230 {
2231 $h1_fir_ref = $sync->{imap1}->fetch_hash( \@h1_msgs, @h1_common_fetch_param, $h1_fir_ref )
2232 if ( @h1_msgs ) ;
2233 }
2234 else
2235 {
2236 my $uidnext = $sync->{imap1}->uidnext( $h1_fold ) || $uidnext_default ;
2237 my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
2238 $h1_fir_ref = $sync->{imap1}->fetch_hash( $fetch_hash_uids, @h1_common_fetch_param, $h1_fir_ref )
2239 if ( @h1_msgs ) ;
2240 }
2241
2242 $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ;
2243 if ( ! $h1_fir_ref )
2244 {
2245 my $error = join( q{}, "Host1: folder $h1_fold : Could not fetch_hash ",
2246 scalar @h1_msgs, ' msgs: ', $sync->{imap1}->LastError || q{}, "\n" ) ;
2247 errors_incr( $sync, $error ) ;
2248 next FOLDER ;
2249 }
2250
2251 my @h1_msgs_duplicate;
2252 foreach my $m ( @h1_msgs_not_in_cache )
2253 {
2254 my $rc = parse_header_msg( $sync, $sync->{imap1}, $m, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash ) ;
2255 if ( ! defined $rc )
2256 {
2257 my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
2258 myprint( "Host1: $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ) ;
2259 $sync->{ total_bytes_skipped } += $h1_size ;
2260 $sync->{ nb_msg_skipped } += 1 ;
2261 $sync->{ h1_nb_msg_noheader } +=1 ;
2262 $sync->{ h1_nb_msg_processed } +=1 ;
2263 } elsif(0 == $rc)
2264 {
2265 # duplicate
2266 push @h1_msgs_duplicate, $m;
2267 # duplicate, same id same size?
2268 my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0;
2269 $sync->{ nb_msg_skipped } += 1;
2270 $h1_nb_msg_duplicate += 1;
2271 $sync->{ h1_nb_msg_processed } +=1 ;
2272 }
2273 }
2274 my $h1_msgs_duplicate_nb = scalar @h1_msgs_duplicate ;
2275
2276 myprint( "Host1: folder [$h1_fold] selected $h1_msgs_nb messages, duplicates $h1_msgs_duplicate_nb\n" ) ;
2277
2278 $sync->{ debug } and myprint( 'Host1: whole time parsing headers took ', timenext( $sync ), " s\n" ) ;
2279 # Getting headers and metada can be so long that host2 might be disconnected here
2280 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2281
2282
2283 $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold]\n" ) ;
2284
2285 my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} );
2286 $h2_heads_ref = $sync->{imap2}->parse_headers([@h2_msgs_not_in_cache], @useheader) if (@h2_msgs_not_in_cache);
2287 $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ;
2288
2289 $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold]\n" ) ;
2290 @{ $h2_fir_ref }{@h2_msgs} = ( ); # fetch_hash can select by uid with last arg as ref
2291
2292
2293 my @h2_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ;
2294 if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h2_common_fetch_param, 'X-GM-LABELS' ; }
2295
2296 if ( $sync->{abletosearch2} and scalar( @h2_msgs ) ) {
2297 $h2_fir_ref = $sync->{imap2}->fetch_hash( \@h2_msgs, @h2_common_fetch_param, $h2_fir_ref) ;
2298 }else{
2299 my $uidnext = $sync->{imap2}->uidnext( $h2_fold ) || $uidnext_default ;
2300 my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
2301 $h2_fir_ref = $sync->{imap2}->fetch_hash( $fetch_hash_uids, @h2_common_fetch_param, $h2_fir_ref )
2302 if ( @h2_msgs ) ;
2303 }
2304
2305 $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ;
2306
2307 my @h2_msgs_duplicate;
2308 foreach my $m (@h2_msgs_not_in_cache) {
2309 my $rc = parse_header_msg( $sync, $sync->{imap2}, $m, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash ) ;
2310 my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ;
2311 if (! defined $rc ) {
2312 myprint( "Host2: $h2_fold/$m size $h2_size ignored (no wanted headers so we ignore this message)\n" ) ;
2313 $h2_nb_msg_noheader += 1 ;
2314 } elsif( 0 == $rc ) {
2315 # duplicate
2316 $h2_nb_msg_duplicate += 1 ;
2317 push @h2_msgs_duplicate, $m ;
2318 }
2319 }
2320
2321 # %h2_folders_of_md5
2322 foreach my $md5 ( keys %h2_hash ) {
2323 $sync->{ h2_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ;
2324 }
2325 # %h1_folders_of_md5
2326 foreach my $md5 ( keys %h1_hash ) {
2327 $sync->{ h1_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ;
2328 }
2329
2330
2331 my $h2_msgs_duplicate_nb = scalar @h2_msgs_duplicate ;
2332
2333 myprint( "Host2: folder [$h2_fold] selected $h2_msgs_nb messages, duplicates $h2_msgs_duplicate_nb\n" ) ;
2334
2335 $sync->{ debug } and myprint( 'Host2 whole time parsing headers took ', timenext( $sync ), " s\n" ) ;
2336
2337 $sync->{ debug } and myprint( "++++ Verifying [$h1_fold] -> [$h2_fold]\n" ) ;
2338 # messages in host1 that are not in host2
2339
2340 my @h1_hash_keys_sorted_by_uid
2341 = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys %h1_hash;
2342
2343 #myprint( map { $h1_hash{$_}{'m'} . q{ }} @h1_hash_keys_sorted_by_uid ) ;
2344
2345 my @h2_hash_keys_sorted_by_uid
2346 = sort {$h2_hash{$a}{'m'} <=> $h2_hash{$b}{'m'}} keys %h2_hash;
2347
2348 # Deletions on account2.
2349
2350 if( $sync->{ delete2duplicates } and not exists $h2_folders_from_1_several{ $h2_fold } ) {
2351 my @h2_expunge ;
2352
2353 foreach my $h2_msg ( @h2_msgs_duplicate ) {
2354 myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $sync->{dry_message}\n" ) ;
2355 push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ;
2356 if ( ! $sync->{dry} ) {
2357 $sync->{imap2}->delete_message( $h2_msg ) ;
2358 $h2_nb_msg_deleted += 1 ;
2359 }
2360 }
2361 my $cnt = scalar @h2_expunge ;
2362 if( @h2_expunge and not $sync->{ expunge2 } ) {
2363 myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
2364 $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
2365 }
2366 if ( $sync->{ expunge2 } ){
2367 myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
2368 $sync->{imap2}->expunge( ) if ! $sync->{dry} ;
2369 }
2370 }
2371
2372 if( $sync->{ delete2 } and not exists $h2_folders_from_1_several{ $h2_fold } ) {
2373 # No host1 folders f1a f1b ... going all to same f2 (via --regextrans2)
2374 my @h2_expunge;
2375 foreach my $m_id (@h2_hash_keys_sorted_by_uid) {
2376 #myprint( "$m_id " ) ;
2377 if ( ! exists $h1_hash{$m_id} ) {
2378 my $h2_msg = $h2_hash{$m_id}{'m'};
2379 my $h2_flags = $h2_hash{$m_id}{'F'} || q{};
2380 my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0;
2381 myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id] $sync->{dry_message}\n" )
2382 if ! $isdel;
2383 push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 };
2384 if ( ! ( $sync->{dry} or $isdel ) ) {
2385 $sync->{imap2}->delete_message($h2_msg);
2386 $h2_nb_msg_deleted += 1;
2387 }
2388 }
2389 }
2390 foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) {
2391 myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $sync->{dry_message}\n" ) ;
2392 push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 };
2393 if ( ! $sync->{dry} ) {
2394 $sync->{imap2}->delete_message($h2_msg);
2395 $h2_nb_msg_deleted += 1;
2396 }
2397 }
2398 my $cnt = scalar @h2_expunge ;
2399
2400 if( @h2_expunge and not $sync->{ expunge2 } ) {
2401 myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
2402 $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
2403 }
2404 if ( $sync->{ expunge2 } ) {
2405 myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
2406 $sync->{imap2}->expunge( ) if ! $sync->{dry} ;
2407 }
2408 }
2409
2410 if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } ) {
2411 myprint( "Host2: folder $h2_fold $h2_folders_from_1_several{ $h2_fold } folders left to sync there\n" ) ;
2412 my @h2_expunge;
2413 foreach my $m_id ( @h2_hash_keys_sorted_by_uid ) {
2414 my $h2_msg = $h2_hash{ $m_id }{ 'm' } ;
2415 if ( ! exists $h1_hash{ $m_id } ) {
2416 my $h2_flags = $h2_hash{ $m_id }{ 'F' } || q{} ;
2417 my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ;
2418 if ( ! $isdel ) {
2419 $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ;
2420 $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ;
2421 }
2422 }else{
2423 $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [$m_id]\n" ) ;
2424 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
2425 }
2426 }
2427 foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) {
2428 myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [not in cache]\n" ) ;
2429 $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ;
2430 }
2431
2432 foreach my $h2_msg ( @h2_msgs_in_cache ) {
2433 myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [in cache]\n" ) ;
2434 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
2435 }
2436
2437
2438 if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) {
2439 # last host1 folder going to $h2_fold
2440 myprint( "Last host1 folder going to $h2_fold\n" ) ;
2441 foreach my $h2_msg ( keys %{ $uid_candidate_for_deletion{ $h2_fold } } ) {
2442 $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ;
2443 if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) {
2444 $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ;
2445 }else{
2446 myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $sync->{dry_message}\n" ) ;
2447 push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ;
2448 if ( ! $sync->{dry} ) {
2449 $sync->{imap2}->delete_message( $h2_msg ) ;
2450 $h2_nb_msg_deleted += 1 ;
2451 }
2452 }
2453 }
2454 }
2455
2456 my $cnt = scalar @h2_expunge ;
2457 if( @h2_expunge and not $sync->{ expunge2 } ) {
2458 myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ;
2459 $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ;
2460 }
2461 if ( $sync->{ expunge2 } ) {
2462 myprint( "Host2: Expunging host2 folder $h2_fold $sync->{dry_message}\n" ) ;
2463 $sync->{imap2}->expunge( ) if ! $sync->{dry} ;
2464 }
2465
2466 $h2_folders_from_1_several{ $h2_fold }-- ;
2467 }
2468
2469 my $h2_uidnext = $sync->{imap2}->uidnext( $h2_fold ) ;
2470 $sync->{ debug } and myprint( "Host2: uidnext is $h2_uidnext\n" ) ;
2471 $h2_uidguess = $h2_uidnext ;
2472
2473 # Getting host2 headers, metada and delete2 stuff can be so long that host1 might be disconnected here
2474 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2475
2476 my @h1_msgs_to_delete ;
2477 MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) {
2478 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2479
2480 #myprint( "h1_nb_msg_processed: $sync->{ h1_nb_msg_processed }\n" ) ;
2481 my $h1_size = $h1_hash{$m_id}{'s'};
2482 my $h1_msg = $h1_hash{$m_id}{'m'};
2483 my $h1_idate = $h1_hash{$m_id}{'D'};
2484
2485 #my $labels = labels( $sync->{imap1}, $h1_msg ) ;
2486 #print "LABELS: $labels\n" ;
2487
2488 if ( ( not exists $h2_hash{ $m_id } )
2489 and ( not ( exists $sync->{ h2_folders_of_md5 }->{ $m_id } )
2490 or not $skipcrossduplicates ) )
2491 {
2492 # copy
2493 my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
2494 if ( $h2_msg and $sync->{ delete1 } and not $sync->{ expungeaftereach } ) {
2495 # not expunged
2496 push @h1_msgs_to_delete, $h1_msg ;
2497 }
2498
2499 # A bug here with imapsync 1.920, fixed in 1.921
2500 # Added $h2_msg in the condition. Errors of APPEND were not counted as missing messages on host2!
2501 if ( $h2_msg and not $sync->{ dry } )
2502 {
2503 $sync->{ h2_folders_of_md5 }->{ $m_id }->{ $h2_fold } ++ ;
2504 }
2505
2506 #
2507 if( $sync->{ delete2 } and ( exists $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) {
2508 myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ;
2509 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
2510 }
2511
2512 if ( total_bytes_max_reached( $sync ) ) {
2513 # a bug when using --delete1 --noexpungeaftereach
2514 # same thing below on all total_bytes_max_reached!
2515 last FOLDER ;
2516 }
2517 next MESS;
2518 }
2519 else
2520 {
2521 # already on host2
2522 if ( exists $h2_hash{ $m_id } )
2523 {
2524 my $h2_msg = $h2_hash{$m_id}{'m'} ;
2525 $sync->{ debug } and myprint( "Host1: found that msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ;
2526 if ( $usecache )
2527 {
2528 $debugcache and myprint( "touch $cache_dir/${h1_msg}_$h2_msg\n" ) ;
2529 touch( "$cache_dir/${h1_msg}_$h2_msg" )
2530 or croak( "Couldn't touch $cache_dir/${h1_msg}_$h2_msg" ) ;
2531 }
2532 }
2533 elsif( exists $sync->{ h2_folders_of_md5 }->{ $m_id } )
2534 {
2535 my @folders_dup = keys %{ $sync->{ h2_folders_of_md5 }->{ $m_id } } ;
2536 ( $sync->{ debug } or $debugcrossduplicates ) and myprint( "Host1: found that msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ;
2537 $sync->{ h2_nb_msg_crossdup } +=1 ;
2538 }
2539 $sync->{ total_bytes_skipped } += $h1_size ;
2540 $sync->{ nb_msg_skipped } += 1 ;
2541 $sync->{ h1_nb_msg_processed } +=1 ;
2542 }
2543
2544 if ( exists $h2_hash{ $m_id } ) {
2545 #$debug and myprint( "MESSAGE $m_id\n" ) ;
2546 my $h2_msg = $h2_hash{$m_id}{'m'};
2547 if ( $sync->{resyncflags} ) {
2548 sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ;
2549 }
2550 # Good
2551 my $h2_size = $h2_hash{$m_id}{'s'};
2552 $sync->{ debug } and myprint(
2553 "Host1: size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n" ) ;
2554
2555 if ( $sync->{ resynclabels } )
2556 {
2557 resynclabels( $sync, $h1_msg, $h2_msg, $h1_fir_ref, $h2_fir_ref, $h1_fold )
2558 }
2559 }
2560
2561 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2562
2563 if ( $sync->{ delete1 } ) {
2564 push @h1_msgs_to_delete, $h1_msg ;
2565 }
2566 }
2567 # END MESS: loop
2568
2569 delete_message_on_host1( $sync, $h1_fold, $sync->{ expunge1 }, @h1_msgs_to_delete, @h1_msgs_in_cache ) ;
2570
2571 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2572
2573 # MESS_IN_CACHE:
2574 if ( ! $sync->{ delete1 } )
2575 {
2576 foreach my $h1_msg ( @h1_msgs_in_cache )
2577 {
2578 my $h2_msg = $cache_1_2_ref->{ $h1_msg } ;
2579 $debugcache and myprint( "cache messages update flags $h1_msg->$h2_msg\n" ) ;
2580 if ( $sync->{resyncflags} )
2581 {
2582 sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ;
2583 }
2584 my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ;
2585 $sync->{ total_bytes_skipped } += $h1_size;
2586 $sync->{ nb_msg_skipped } += 1;
2587 $sync->{ h1_nb_msg_processed } +=1 ;
2588 }
2589 }
2590
2591 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2592
2593 @h1_msgs_to_delete = ( ) ;
2594 #myprint( "Messages by uid: ", map { "$_ " } keys %h1_msgs_copy_by_uid, "\n" ) ;
2595 # MESS_BY_UID:
2596 foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid )
2597 {
2598 $sync->{ debug } and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ;
2599 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; }
2600
2601 my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ;
2602 if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } and $h2_msg ) {
2603 myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ;
2604 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ;
2605 }
2606 last FOLDER if total_bytes_max_reached( $sync ) ;
2607 }
2608
2609 if ( $sync->{ expunge1 } ){
2610 myprint( "Host1: Expunging folder $h1_fold $sync->{dry_message}\n" ) ;
2611 if ( ! $sync->{dry} ) { $sync->{imap1}->expunge( ) } ;
2612 }
2613 if ( $sync->{ expunge2 } ){
2614 myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ;
2615 if ( ! $sync->{dry} ) { $sync->{imap2}->expunge( ) } ;
2616 }
2617 $sync->{ debug } and myprint( 'Time: ', timenext( $sync ), " s\n" ) ;
2618}
2619
2620eta_print( $sync ) ;
2621
2622myprint( "++++ End looping on each folder\n" ) ;
2623
2624if ( $sync->{ delete1 } and $sync->{ delete1emptyfolders } ) {
2625 delete1emptyfolders( $sync ) ;
2626}
2627
2628( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Time: ', timenext( $sync ), " s\n" ) ;
2629
2630
2631if ( $sync->{ foldersizesatend } ) {
2632 myprint( << 'END_SIZE' ) ;
2633
2634Folders sizes after the synchronization.
2635You can remove this foldersizes listing by using "--nofoldersizesatend"
2636END_SIZE
2637
2638 foldersizesatend( $sync ) ;
2639}
2640
2641if ( ! lost_connection( $sync, $sync->{imap1}, "for host1 [$sync->{host1}]" ) ) { $sync->{imap1}->logout( ) ; }
2642if ( ! lost_connection( $sync, $sync->{imap2}, "for host2 [$sync->{host2}]" ) ) { $sync->{imap2}->logout( ) ; }
2643
2644stats( $sync ) ;
2645myprint( errorsdump( $sync->{nb_errors}, errors_log( $sync ) ) ) if ( $sync->{errorsdump} ) ;
2646tests_live_result( $sync->{nb_errors} ) if ( $sync->{testslive} or $sync->{testslive6} ) ;
2647
2648
2649
2650if ( $sync->{nb_errors} )
2651{
2652 exit_clean( $sync, $EXIT_WITH_ERRORS ) ;
2653}
2654else
2655{
2656 exit_clean( $sync, $EX_OK ) ;
2657}
2658
2659return ;
2660}
2661
2662# END of sub single_sync
2663
2664
2665# subroutines
2666sub myprint
2667{
2668 #print @ARG ;
2669 print { $sync->{ tee } || \*STDOUT } @ARG ;
2670 return ;
2671}
2672
2673sub myprintf
2674{
2675 printf { $sync->{ tee } || \*STDOUT } @ARG ;
2676 return ;
2677}
2678
2679sub mysprintf
2680{
2681 my( $format, @list ) = @ARG ;
2682 return sprintf $format, @list ;
2683}
2684
2685sub output_start
2686{
2687 my $mysync = shift @ARG ;
2688
2689 if ( not $mysync ) { return ; }
2690
2691 my @output = @ARG ;
2692 $mysync->{ output } = join( q{}, @output ) . ( $mysync->{ output } || q{} ) ;
2693 return $mysync->{ output } ;
2694}
2695
2696
2697sub tests_output_start
2698{
2699 note( 'Entering tests_output_start()' ) ;
2700
2701 my $mysync = { } ;
2702
2703 is( undef, output_start( ), 'output_start: no args => undef' ) ;
2704 is( q{}, output_start( $mysync ), 'output_start: one arg => ""' ) ;
2705 is( 'rrrr', output_start( $mysync, 'rrrr' ), 'output_start: rrrr => rrrr' ) ;
2706 is( 'aaaarrrr', output_start( $mysync, 'aaaa' ), 'output_start: aaaa => aaaarrrr' ) ;
2707 is( "\naaaarrrr", output_start( $mysync, "\n" ), 'output_start: \n => \naaaarrrr' ) ;
2708 is( "ABC\naaaarrrr", output_start( $mysync, 'A', 'B', 'C' ), 'output_start: A B C => ABC\naaaarrrr' ) ;
2709
2710 note( 'Leaving tests_output_start()' ) ;
2711 return ;
2712}
2713
2714sub tests_output
2715{
2716 note( 'Entering tests_output()' ) ;
2717
2718 my $mysync = { } ;
2719
2720 is( undef, output( ), 'output: no args => undef' ) ;
2721 is( q{}, output( $mysync ), 'output: one arg => ""' ) ;
2722 is( 'rrrr', output( $mysync, 'rrrr' ), 'output: rrrr => rrrr' ) ;
2723 is( 'rrrraaaa', output( $mysync, 'aaaa' ), 'output: aaaa => rrrraaaa' ) ;
2724 is( "rrrraaaa\n", output( $mysync, "\n" ), 'output: \n => rrrraaaa\n' ) ;
2725 is( "rrrraaaa\nABC", output( $mysync, 'A', 'B', 'C' ), 'output: A B C => rrrraaaaABC\n' ) ;
2726
2727 note( 'Leaving tests_output()' ) ;
2728 return ;
2729}
2730
2731sub output
2732{
2733 my $mysync = shift @ARG ;
2734
2735 if ( not $mysync ) { return ; }
2736
2737 my @output = @ARG ;
2738 $mysync->{ output } .= join( q{}, @output ) ;
2739 return $mysync->{ output } ;
2740}
2741
2742
2743
2744sub tests_output_reset_with
2745{
2746 note( 'Entering tests_output_reset_with()' ) ;
2747
2748 my $mysync = { } ;
2749
2750 is( undef, output_reset_with( ), 'output_reset_with: no args => undef' ) ;
2751 is( q{}, output_reset_with( $mysync ), 'output_reset_with: one arg => ""' ) ;
2752 is( 'rrrr', output_reset_with( $mysync, 'rrrr' ), 'output_reset_with: rrrr => rrrr' ) ;
2753 is( 'aaaa', output_reset_with( $mysync, 'aaaa' ), 'output_reset_with: aaaa => aaaa' ) ;
2754 is( "\n", output_reset_with( $mysync, "\n" ), 'output_reset_with: \n => \n' ) ;
2755
2756 note( 'Leaving tests_output_reset_with()' ) ;
2757 return ;
2758}
2759
2760sub output_reset_with
2761{
2762 my $mysync = shift @ARG ;
2763
2764 if ( not $mysync ) { return ; }
2765
2766 my @output = @ARG ;
2767 $mysync->{ output } = join( q{}, @output ) ;
2768 return $mysync->{ output } ;
2769}
2770
2771sub pidfile
2772{
2773 my $mysync = shift ;
2774
2775 $mysync->{ pidfilelocking } = defined $mysync->{ pidfilelocking } ? $mysync->{ pidfilelocking } : 0 ;
2776
2777 my $host1 = $mysync->{ host1 } || q{} ;
2778 my $user1 = $mysync->{ user1 } || q{} ;
2779 my $host2 = $mysync->{ host2 } || q{} ;
2780 my $user2 = $mysync->{ user2 } || q{} ;
2781
2782 my $account1_filtered = filter_forbidden_characters( slash_to_underscore( $host1 . '_' . $user1 ) ) || q{} ;
2783 my $account2_filtered = filter_forbidden_characters( slash_to_underscore( $host2 . '_' . $user2 ) ) || q{} ;
2784
2785 my $pidfile_basename ;
2786
2787 if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) )
2788 {
2789 # under local webserver
2790 $pidfile_basename = 'imapsync' . '_' . $account1_filtered . '_' . $account2_filtered . '.pid' ;
2791 }
2792 else
2793 {
2794 $pidfile_basename = 'imapsync.pid' ;
2795 }
2796
2797 $mysync->{ pidfile } = defined $mysync->{ pidfile } ? $mysync-> { pidfile } : $mysync->{ tmpdir } . "/$pidfile_basename" ;
2798 return ;
2799}
2800
2801
2802sub tests_kill_zero
2803{
2804 note( 'Entering tests_kill_zero()' ) ;
2805
2806
2807
2808 SKIP: {
2809 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_kill_zero avoided on Windows', 8 ) ; }
2810
2811
2812 is( 1, kill( 'ZERO', $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID => 1" ) ;
2813 is( 2, kill( 'ZERO', $PROCESS_ID, $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID $PROCESS_ID => 2" ) ;
2814
2815 if ( (-e '/.dockerenv' ) or ( 0 == $EFFECTIVE_USER_ID) )
2816 {
2817 is( 1, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 1 (docker context or root)" ) ;
2818 is( 2, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 2 (docker context or root)" ) ;
2819 }
2820 else
2821 {
2822 is( 0, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 0 (non root)" ) ;
2823 is( 1, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 1 (one is non root)" ) ;
2824
2825 }
2826
2827
2828 my $pid_1 = fork( ) ;
2829 if ( $pid_1 )
2830 {
2831 # parent
2832 }
2833 else
2834 {
2835 # child
2836 sleep 3 ;
2837 exit ;
2838 }
2839
2840 my $pid_2 ;
2841 $pid_2 = fork( ) ;
2842 if ( $pid_2 )
2843 {
2844 # I am the parent
2845 ok( defined( $pid_2 ), "kill_zero: initial fork ok. I am the parent $PROCESS_ID" ) ;
2846 ok( $pid_2 , "kill_zero: initial fork ok, child pid is $pid_2" ) ;
2847 is( 3, kill( 'ZERO', $PROCESS_ID, $pid_2, $pid_1 ), "kill ZERO : myself $PROCESS_ID and child $pid_2 and brother $pid_1 => 3" ) ;
2848
2849 is( $pid_2, waitpid( $pid_2, 0 ), "kill_zero: child $pid_2 no more there => waitpid return $pid_2" ) ;
2850 }
2851 else
2852 {
2853 # I am the child
2854 note( 'This one fails under Windows, kill ZERO returns 0 instead of 2' ) ;
2855 is( 2, kill( 'ZERO', $PROCESS_ID, $pid_1 ), "kill ZERO : myself child $PROCESS_ID brother $pid_1 => 2" ) ;
2856 myprint( "I am the child pid $PROCESS_ID, Exiting\n" ) ;
2857 exit ;
2858 }
2859 wait( ) ;
2860
2861 # End of SKIP block
2862 }
2863
2864 note( 'Leaving tests_kill_zero()' ) ;
2865 return ;
2866}
2867
2868
2869
2870
2871sub tests_killpid_by_parent
2872{
2873 note( 'Entering tests_killpid_by_parent()' ) ;
2874
2875 SKIP: {
2876 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_killpid_by_parent avoided on Windows', 7 ) ; }
2877
2878 is( undef, killpid( ), 'killpid: no args => undef' ) ;
2879 note( "killpid: trying to kill myself pid $PROCESS_ID, hope I will not succeed" ) ;
2880 is( undef, killpid( $PROCESS_ID ), 'killpid: myself => undef' ) ;
2881
2882 local $SIG{'QUIT'} = sub { myprint "GOT SIG QUIT! I am PID $PROCESS_ID. Exiting\n" ; exit ; } ;
2883
2884 my $pid ;
2885 $pid = fork( ) ;
2886 if ( $pid )
2887 {
2888 # I am the parent
2889 ok( defined( $pid ), "killpid: initial fork ok. I am the parent $PROCESS_ID" ) ;
2890 ok( $pid , "killpid: initial fork ok, child pid is $pid" ) ;
2891
2892 is( 2, kill( 'ZERO', $PROCESS_ID, $pid ), "kill ZERO : myself $PROCESS_ID and child $pid => 2" ) ;
2893 is( 1, killpid( $pid ), "killpid: child $pid killed => 1" ) ;
2894 is( -1, waitpid( $pid, 0 ), "killpid: child $pid no more there => waitpid return -1" ) ;
2895 }
2896 else
2897 {
2898 # I am the child
2899 myprint( "I am the child pid $PROCESS_ID, sleeping 1 + 3 seconds then kill myself\n" ) ;
2900 sleep 1 ;
2901 myprint( "I am the child pid $PROCESS_ID, slept 1 second, should be killed by my parent now, PPID " . mygetppid( ) . "\n" ) ;
2902 sleep 3 ;
2903 # this test should not be run. If it happens => failure.
2904 ok( 0 == 1, "killpid: child pid $PROCESS_ID not dead => failure" ) ;
2905 myprint( "I am the child pid $PROCESS_ID, killing myself failure... Exiting\n" ) ;
2906 exit ;
2907 }
2908
2909 # End of SKIP block
2910 }
2911 note( 'Leaving tests_killpid_by_parent()' ) ;
2912 return ;
2913}
2914
2915sub tests_killpid_by_brother
2916{
2917 note( 'Entering tests_killpid_by_brother()' ) ;
2918
2919
2920 SKIP: {
2921 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_killpid_by_brother avoided on Windows', 2 ) ; }
2922
2923 local $SIG{'QUIT'} = sub { myprint "GOT SIG QUIT! I am PID $PROCESS_ID. Exiting\n" ; exit ; } ;
2924
2925 my $pid_parent = $PROCESS_ID ;
2926 myprint( "I am the parent pid $pid_parent\n" ) ;
2927 my $pid_1 = fork( ) ;
2928 if ( $pid_1 )
2929 {
2930 # parent
2931 }
2932 else
2933 {
2934 # child
2935 #while ( 1 ) { } ;
2936 sleep 2 ;
2937 sleep 2 ;
2938 # this test should not be run. If it happens => failure.
2939 # Well under Windows this always fails, shit!
2940 ok( 0 == 1 or ( 'MSWin32' eq $OSNAME ) , "killpid: child pid $PROCESS_ID killing by brother but not dead => failure" ) ;
2941 myprint( "I am the child pid $PROCESS_ID, killing by brother failed... Exiting\n" ) ;
2942 exit ;
2943 }
2944
2945 my $pid_2 ;
2946 $pid_2 = fork( ) ;
2947 if ( $pid_2 )
2948 {
2949 # parent
2950 }
2951 else
2952 {
2953 # I am the child
2954 myprint( "I am the child pid $PROCESS_ID, my brother has pid $pid_1\n" ) ;
2955 is( 1, killpid( $pid_1 ), "killpid: brother $pid_1 killed => 1" ) ;
2956 sleep 2 ;
2957 exit ;
2958 }
2959
2960 #sleep 1 ;
2961 is( $pid_1, waitpid( $pid_1, 0), "I am the parent $PROCESS_ID waitpid _1( $pid_1 )" ) ;
2962 is( $pid_2, waitpid( $pid_2, 0 ), "I am the parent $PROCESS_ID waitpid _2( $pid_2 )" ) ;
2963
2964
2965 # End of SKIP block
2966 }
2967
2968 note( 'Leaving tests_killpid_by_brother()' ) ;
2969 return ;
2970}
2971
2972
2973sub killpid
2974{
2975 my $pidtokill = shift ;
2976
2977 if ( ! $pidtokill ) {
2978 myprint( "No process to abort.\n" ) ;
2979 return ;
2980 }
2981
2982 if ( $PROCESS_ID == $pidtokill ) {
2983 myprint( "I will not kill myself pid $PROCESS_ID via killpid. Sractch it!\n" ) ;
2984 return ;
2985 }
2986
2987
2988 # First ask for suicide
2989 if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) {
2990 myprint( "Sending signal QUIT to PID $pidtokill \n" ) ;
2991 kill 'QUIT', $pidtokill ;
2992 sleep 2 ;
2993 waitpid( $pidtokill, WNOHANG) ;
2994 }else{
2995 myprint( "Can not send signal kill ZERO to PID $pidtokill.\n" ) ;
2996 return ;
2997 }
2998
2999 #while ( waitpid( $pidtokill, WNOHANG) > 0 ) { } ;
3000
3001 # Then murder
3002 if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) {
3003 myprint( "Sending signal KILL to PID $pidtokill \n" ) ;
3004 kill 'KILL', $pidtokill ;
3005 sleep 1 ;
3006 waitpid( $pidtokill, WNOHANG) ;
3007 }else{
3008 myprint( "Process PID $pidtokill ended.\n" ) ;
3009 return 1;
3010 }
3011 # Well ...
3012 if ( kill( 'ZERO', $pidtokill ) or ( 'xMSWin32' eq $OSNAME ) ) {
3013 myprint( "Process PID $pidtokill seems still there. Can not do much.\n" ) ;
3014 return ;
3015 }else{
3016 myprint( "Process PID $pidtokill ended.\n" ) ;
3017 return 1;
3018 }
3019
3020 return ;
3021}
3022
3023sub tests_abort
3024{
3025 note( 'Entering tests_abort()' ) ;
3026
3027 is( undef, abort( ), 'abort: no args => undef' ) ;
3028 note( 'Leaving tests_abort()' ) ;
3029 return ;
3030}
3031
3032
3033
3034
3035sub abort
3036{
3037 my $mysync = shift @ARG ;
3038
3039 if ( not $mysync ) { return ; }
3040
3041 if ( ! -r $mysync->{pidfile} ) {
3042 myprint( "Can not read pidfile $mysync->{pidfile}. Exiting.\n" ) ;
3043 exit $EX_OK ;
3044 }
3045 my $pidtokill = firstline( $mysync->{pidfile} ) ;
3046 if ( ! $pidtokill ) {
3047 myprint( "No process to abort. Exiting.\n" ) ;
3048 exit $EX_OK ;
3049 }
3050
3051 killpid( $pidtokill ) ;
3052
3053 # well, the abort job is done anyway, because even when not succeeded
3054 # in aborting another run, this run has to end without doing any
3055 # thing else
3056
3057 exit $EX_OK ;
3058}
3059
3060
3061sub under_docker_context
3062{
3063 my $mysync = shift ;
3064
3065 if ( -e '/.dockerenv' )
3066 {
3067 return 1 ;
3068 }
3069 else
3070 {
3071 return 0 ;
3072 }
3073
3074 return ;
3075}
3076
3077
3078sub docker_context
3079{
3080 my $mysync = shift ;
3081
3082 #-e '/.dockerenv' || return ;
3083
3084 if ( ! under_docker_context( $mysync ) )
3085 {
3086 return ;
3087 }
3088
3089 $mysync->{ debug } and myprint( "Docker context detected with /.dockerenv\n" ) ;
3090 # No pidfile
3091 $mysync->{pidfile} = q{} ;
3092 # No log
3093 $mysync->{log} = 0 ;
3094 # In case
3095 $mysync->{ debug } and myprint( "Changing current directory to /var/tmp/\n" ) ;
3096 chdir '/var/tmp/' ;
3097
3098 return ;
3099}
3100
3101sub cgibegin
3102{
3103 my $mysync = shift ;
3104 if ( ! under_cgi_context( $mysync ) ) { return ; }
3105 require CGI ;
3106 CGI->import( qw( -no_debug -utf8 ) ) ;
3107 require CGI::Carp ;
3108 CGI::Carp->import( qw( fatalsToBrowser ) ) ;
3109 $mysync->{cgi} = CGI->new( ) ;
3110 return ;
3111}
3112
3113sub tests_under_cgi_context
3114{
3115 note( 'Entering tests_under_cgi_context()' ) ;
3116
3117 # $ENV{SERVER_SOFTWARE} = 'under imapsync' ;
3118 do {
3119 # Not in cgi context
3120 delete local $ENV{SERVER_SOFTWARE} ;
3121 is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ;
3122 } ;
3123 do {
3124 # In cgi context
3125 local $ENV{SERVER_SOFTWARE} = 'under imapsync' ;
3126 is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ;
3127 } ;
3128 do {
3129 # Not in cgi context
3130 delete local $ENV{SERVER_SOFTWARE} ;
3131 is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ;
3132 } ;
3133 do {
3134 # In cgi context
3135 local $ENV{SERVER_SOFTWARE} = 'under imapsync' ;
3136 is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ;
3137 } ;
3138 note( 'Leaving tests_under_cgi_context()' ) ;
3139 return ;
3140}
3141
3142
3143sub under_cgi_context
3144{
3145 my $mysync = shift ;
3146 # Under cgi context
3147 if ( $ENV{SERVER_SOFTWARE} ) {
3148 return 1 ;
3149 }
3150 # Not in cgi context
3151 return ;
3152}
3153
3154sub cgibuildheader
3155{
3156 my $mysync = shift ;
3157 if ( ! under_cgi_context( $mysync ) ) { return ; }
3158
3159 my $imapsync_runs = $mysync->{cgi}->cookie( 'imapsync_runs' ) || 0 ;
3160 my $cookie = $mysync->{cgi}->cookie(
3161 -name => 'imapsync_runs',
3162 -value => 1 + $imapsync_runs,
3163 -expires => '+20y',
3164 -path => '/cgi-bin/imapsync',
3165 ) ;
3166 my $httpheader ;
3167 if ( $mysync->{ abort } ) {
3168 $httpheader = $mysync->{cgi}->header(
3169 -type => 'text/plain',
3170 -status => '200 OK to abort syncing IMAP boxes' . ". Here is " . hostname(),
3171 ) ;
3172 }elsif( $mysync->{ loaddelay } ) {
3173# https://tools.ietf.org/html/rfc2616#section-10.5.4
3174# 503 Service Unavailable
3175# The server is currently unable to handle the request due to a temporary overloading or maintenance of the server.
3176 $httpheader = $mysync->{cgi}->header(
3177 -type => 'text/plain',
3178 -status => '503 Service Unavailable' . ". Be back in $mysync->{ loaddelay } min. Load on " . hostname() . " is $mysync->{ loadavg }",
3179 ) ;
3180 }else{
3181 $httpheader = $mysync->{cgi}->header(
3182 -type => 'text/plain; charset=UTF-8',
3183 -status => '200 OK to sync IMAP boxes' . ". Load on " . hostname() . " is $mysync->{ loadavg }",
3184 -cookie => $cookie,
3185 ) ;
3186 }
3187 output_start( $mysync, $httpheader ) ;
3188
3189 return ;
3190}
3191
3192sub cgiload
3193{
3194 # Exit on heavy load in CGI context
3195 my $mysync = shift ;
3196 if ( ! under_cgi_context( $mysync ) ) { return ; }
3197 if ( $mysync->{ abort } ) { return ; } # keep going to abort since some ressources will be free soon
3198 if ( $mysync->{ loaddelay } )
3199 {
3200 $mysync->{nb_errors}++ ;
3201 exit_clean( $mysync, $EX_UNAVAILABLE,
3202 "Server is on heavy load. Be back in $mysync->{ loaddelay } min. Load is $mysync->{ loadavg }\n"
3203 ) ;
3204 }
3205 return ;
3206}
3207
3208sub tests_set_umask
3209{
3210 note( 'Entering tests_set_umask()' ) ;
3211
3212 my $save_umask = umask ;
3213
3214 my $mysync = {} ;
3215 if ( 'MSWin32' eq $OSNAME ) {
3216 is( undef, set_umask( $mysync ), "set_umask: set failure to $UMASK_PARANO on MSWin32" ) ;
3217 }else{
3218 is( 1, set_umask( $mysync ), "set_umask: set to $UMASK_PARANO" ) ;
3219 }
3220
3221 umask $save_umask ;
3222 note( 'Leaving tests_set_umask()' ) ;
3223 return ;
3224}
3225
3226sub set_umask
3227{
3228 my $mysync = shift ;
3229 my $previous_umask = umask_str( ) ;
3230 my $new_umask = umask_str( $UMASK_PARANO ) ;
3231 output( $mysync, "Umask set with $new_umask (was $previous_umask)\n" ) ;
3232 if ( $new_umask eq $UMASK_PARANO ) {
3233 return 1 ;
3234 }
3235 return ;
3236}
3237
3238sub tests_umask_str
3239{
3240 note( 'Entering tests_umask_str()' ) ;
3241
3242 my $save_umask = umask ;
3243
3244 is( umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent' ) ;
3245 is( my $save_umask_str = umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent + save' ) ;
3246 is( '0000', umask_str( q{ } ), 'umask_str: q{ } => 0000' ) ;
3247 is( '0000', umask_str( q{} ), 'umask_str: q{} => 0000' ) ;
3248 is( '0000', umask_str( '0000' ), 'umask_str: 0000 => 0000' ) ;
3249 is( '0000', umask_str( '0' ), 'umask_str: 0 => 0000' ) ;
3250 is( '0200', umask_str( '0200' ), 'umask_str: 0200 => 0200' ) ;
3251 is( '0400', umask_str( '0400' ), 'umask_str: 0400 => 0400' ) ;
3252 is( '0600', umask_str( '0600' ), 'umask_str: 0600 => 0600' ) ;
3253
3254 SKIP: {
3255 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 6 ) ; }
3256 is( '0100', umask_str( '0100' ), 'umask_str: 0100 => 0100' ) ;
3257 is( '0001', umask_str( '0001' ), 'umask_str: 0001 => 0001' ) ;
3258 is( '0777', umask_str( '0777' ), 'umask_str: 0777 => 0777' ) ;
3259 is( '0777', umask_str( '00777' ), 'umask_str: 00777 => 0777' ) ;
3260 is( '0777', umask_str( ' 777 ' ), 'umask_str: 777 => 0777' ) ;
3261 is( "$UMASK_PARANO", umask_str( $UMASK_PARANO ), "umask_str: UMASK_PARANO $UMASK_PARANO => $UMASK_PARANO" ) ;
3262 }
3263
3264 is( $save_umask_str, umask_str( $save_umask_str ), 'umask_str: restore with str' ) ;
3265 is( $save_umask, umask, 'umask_str: umask is restored, controlled by direct umask' ) ;
3266 is( $save_umask, umask $save_umask, 'umask_str: umask is restored by direct umask' ) ;
3267 is( $save_umask, umask, 'umask_str: umask initial controlled by direct umask' ) ;
3268
3269 note( 'Leaving tests_umask_str()' ) ;
3270 return ;
3271}
3272
3273sub umask_str
3274{
3275 my $value = shift ;
3276
3277 if ( defined $value ) {
3278 umask oct( $value ) ;
3279 }
3280 my $current = umask ;
3281
3282 return( sprintf( '%#04o', $current ) ) ;
3283}
3284
3285sub tests_umask
3286{
3287 note( 'Entering tests_umask()' ) ;
3288
3289 my $save_umask ;
3290 is( umask, umask, 'umask: umask is umask' ) ;
3291 is( $save_umask = umask, umask, "umask: umask is umask again + save it: $save_umask" ) ;
3292 is( $save_umask, umask oct(0000), 'umask: umask 0000' ) ;
3293 is( oct(0000), umask, 'umask: umask is now 0000' ) ;
3294 is( oct(0000), umask oct(777), 'umask: umask 0777 call, previous 0000' ) ;
3295
3296 SKIP: {
3297 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 2 ) ; }
3298 is( oct(777), umask, 'umask: umask is now 0777' ) ;
3299 is( oct(777), umask $save_umask, "umask: umask $save_umask restore inital value, previous 0777" ) ;
3300 }
3301
3302 ok( defined umask $save_umask, "umask: umask $save_umask restore inital value, previous defined" ) ;
3303 is( $save_umask, umask, 'umask: umask is umask restored' ) ;
3304 note( 'Leaving tests_umask()' ) ;
3305
3306 return ;
3307}
3308
3309sub cgisetcontext
3310{
3311 my $mysync = shift ;
3312 if ( ! under_cgi_context( $mysync ) ) { return ; }
3313
3314 output( $mysync, "Under cgi context\n" ) ;
3315 set_umask( $mysync ) ;
3316
3317 # Remove all content in unsafe evaled options
3318 @{ $mysync->{ regextrans2 } } = ( ) ;
3319 @regexflag = ( ) ;
3320 @regexmess = ( ) ;
3321 @skipmess = ( ) ;
3322 @pipemess = ( ) ;
3323 $delete2foldersonly = undef ;
3324 $delete2foldersbutnot = undef ;
3325 $maxlinelengthcmd = undef ;
3326
3327 # Set safe default values (I hope...)
3328
3329
3330 #$mysync->{pidfile} = 'imapsync.pid' ;
3331 $mysync->{pidfilelocking} = 1 ;
3332 $mysync->{errorsmax} = $ERRORS_MAX_CGI ;
3333 $modulesversion = 0 ;
3334 $mysync->{releasecheck} = defined $mysync->{releasecheck} ? $mysync->{releasecheck} : 1 ;
3335 $usecache = 0 ;
3336 $mysync->{showpasswords} = 0 ;
3337 $debugimap1 = $debugimap2 = $debugimap = 0 ;
3338 $reconnectretry1 = $reconnectretry2 = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ;
3339 $pipemesscheck = 0 ;
3340
3341 $mysync->{hashfile} = $CGI_HASHFILE ;
3342 my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ;
3343
3344 if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) )
3345 {
3346 # under local webserver
3347 $cgidir = q{.} ;
3348 }
3349 else
3350 {
3351 $cgidir = $CGI_TMPDIR_TOP . '/' . $hashsynclocal ;
3352 }
3353 -d $cgidir or mkpath $cgidir or die "Can not create $cgidir: $OS_ERROR\n" ;
3354 $mysync->{ tmpdir } = $cgidir ;
3355
3356 chdir $cgidir or die "Can not cd to $cgidir: $OS_ERROR\n" ;
3357 cgioutputenvcontext( $mysync ) ;
3358 $mysync->{ debug } and output( $mysync, 'Current directory is ' . getcwd( ) . "\n" ) ;
3359 $mysync->{ debug } and output( $mysync, 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ;
3360 $mysync->{ debug } and output( $mysync, 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ;
3361
3362 $mysync->{ skipemptyfolders } = defined $mysync->{ skipemptyfolders } ? $mysync->{ skipemptyfolders } : 1 ;
3363
3364 # Out of memory with messages over 1 GB ?
3365 $mysync->{ maxsize } = defined $mysync->{ maxsize } ? $mysync->{ maxsize } : 1_000_000_000 ;
3366
3367 # tail -f behaviour on by default
3368 $mysync->{ tail } = defined $mysync->{ tail } ? $mysync->{ tail } : 1 ;
3369
3370 # not sure it's for good
3371 @useheader = qw( Message-Id ) ;
3372
3373 # addheader on by default
3374 $mysync->{ addheader } = defined $mysync->{ addheader } ? $mysync->{ addheader } : 1 ;
3375
3376 return ;
3377}
3378
3379sub cgioutputenvcontext
3380{
3381 my $mysync = shift @ARG ;
3382
3383 for my $envvar ( qw( REMOTE_ADDR REMOTE_HOST HTTP_REFERER HTTP_USER_AGENT SERVER_SOFTWARE SERVER_PORT HTTP_COOKIE ) ) {
3384
3385 my $envval = $ENV{ $envvar } || q{} ;
3386 if ( $envval ) { output( $mysync, "$envvar is $envval\n" ) } ;
3387 }
3388
3389 return ;
3390}
3391
3392
3393sub debugsleep
3394{
3395 my $mysync = shift @ARG ;
3396 if ( defined $mysync->{debugsleep} ) {
3397 myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ;
3398 sleep $mysync->{debugsleep} ;
3399 }
3400 return ;
3401}
3402
3403sub tests_foldersize
3404{
3405 note( 'Entering tests_foldersize()' ) ;
3406
3407 is( undef, foldersize( ), 'foldersize: no args => undef' ) ;
3408
3409
3410 #is_deeply( {}, {}, 'foldersize: a hash is a hash' ) ;
3411 #is_deeply( [], [], 'foldersize: an array is an array' ) ;
3412 note( 'Leaving tests_foldersize()' ) ;
3413 return ;
3414}
3415
3416
3417
3418# Globals:
3419# $uidnext_default
3420# $fetch_hash_set
3421#
3422sub foldersize
3423{
3424 # size of one folder
3425 my ( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) = @ARG ;
3426
3427 if ( ! all_defined( $mysync, $side, $imap, $folder ) )
3428 {
3429 return ;
3430 }
3431
3432 # FTGate is RFC buggy with EXAMINE it does not act as SELECT
3433 #if ( ! $imap->examine( $folder ) ) {
3434 if ( ! $imap->select( $folder ) ) {
3435 my $error = join q{},
3436 "$side Folder $folder: Could not select: ",
3437 $imap->LastError, "\n" ;
3438 errors_incr( $mysync, $error ) ;
3439 return ;
3440 }
3441
3442 if ( $imap->IsUnconnected( ) )
3443 {
3444 return ;
3445 }
3446
3447 my $hash_ref = { } ;
3448 my @msgs = select_msgs( $imap, undef, $search_cmd, $abletosearch, $folder ) ;
3449 my $nb_msgs = scalar @msgs ;
3450 my $biggest_in_folder = 0 ;
3451 @{ $hash_ref }{ @msgs } = ( undef ) if @msgs ;
3452
3453 my $stot = 0 ;
3454
3455 if ( $imap->IsUnconnected( ) )
3456 {
3457 return ;
3458 }
3459
3460 if ( $nb_msgs > 0 and @msgs ) {
3461 if ( $abletosearch ) {
3462 if ( ! $imap->fetch_hash( \@msgs, 'RFC822.SIZE', $hash_ref) ) {
3463 my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ;
3464 errors_incr( $mysync, $error ) ;
3465 return ;
3466 }
3467 }
3468 else
3469 {
3470 my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ;
3471 my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
3472 if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) {
3473 my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ;
3474 errors_incr( $mysync, $error ) ;
3475 return ;
3476 }
3477 }
3478 for ( keys %{ $hash_ref } ) {
3479 my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ;
3480 $stot += $size ;
3481 $biggest_in_folder = max( $biggest_in_folder, $size ) ;
3482 }
3483 }
3484 return( $stot, $nb_msgs, $biggest_in_folder ) ;
3485
3486}
3487
3488
3489# The old subroutine that performed just one side at a time.
3490# Still here for a while, until confident with sub foldersize_diff_compute()
3491sub foldersizes
3492{
3493 my ( $mysync, $side, $imap, $search_cmd, $abletosearch, @folders ) = @_ ;
3494 my $total_size = 0 ;
3495 my $total_nb = 0 ;
3496 my $biggest_in_all = 0 ;
3497
3498 my $nb_folders = scalar @folders ;
3499 my $ct_folders = 0 ; # folder counter.
3500 myprint( "++++ Calculating sizes of $nb_folders folders on $side\n" ) ;
3501 foreach my $folder ( @folders ) {
3502 my $stot = 0 ;
3503 my $nb_msgs = 0 ;
3504 my $biggest_in_folder = 0 ;
3505
3506 $ct_folders++ ;
3507 myprintf( "$side folder %7s %-35s", "$ct_folders/$nb_folders", jux_utf8( $folder ) ) ;
3508 if ( 'Host2' eq $side and not exists $mysync->{h2_folders_all_UPPER}{ uc $folder } ) {
3509 myprint( " does not exist yet\n") ;
3510 next ;
3511 }
3512 if ( 'Host1' eq $side and not exists $h1_folders_all{ $folder } ) {
3513 myprint( " does not exist\n" ) ;
3514 next ;
3515 }
3516
3517 last if $imap->IsUnconnected( ) ;
3518
3519 ( $stot, $nb_msgs, $biggest_in_folder ) = foldersize( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) ;
3520
3521 myprintf( ' Size: %9s', $stot ) ;
3522 myprintf( ' Messages: %5s', $nb_msgs ) ;
3523 myprintf( " Biggest: %9s\n", $biggest_in_folder ) ;
3524 $total_size += $stot ;
3525 $total_nb += $nb_msgs ;
3526 $biggest_in_all = max( $biggest_in_all, $biggest_in_folder ) ;
3527 }
3528 myprintf( "%s Nb folders: %11s folders\n", $side, $nb_folders ) ;
3529 myprintf( "%s Nb messages: %11s messages\n", $side, $total_nb ) ;
3530 myprintf( "%s Total size: %11s bytes (%s)\n", $side, $total_size, bytes_display_string( $total_size ) ) ;
3531 myprintf( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string( $biggest_in_all ) ) ;
3532 myprintf( "%s Time spent on sizing: %11.1f seconds\n", $side, timenext( $mysync ) ) ;
3533 return( $total_nb, $total_size ) ;
3534}
3535
3536
3537sub foldersize_diff_present
3538{
3539 my $mysync = shift ;
3540 my $folder1 = shift ;
3541 my $folder2 = shift ;
3542 my $counter_str = shift ;
3543 my $force = shift ;
3544
3545 my $values1_str ;
3546 my $values2_str ;
3547
3548 if ( ! defined $mysync->{ folder1 }->{ $folder1 }->{ size } || $force )
3549 {
3550 foldersize_diff_compute( $mysync, $folder1, $folder2, $force ) ;
3551 }
3552
3553 # again, but this time it means no availaible data.
3554 if ( defined $mysync->{ folder1 }->{ $folder1 }->{ size } )
3555 {
3556 $values1_str = sprintf( "Size: %9s Messages: %5s Biggest: %9s\n",
3557 $mysync->{ folder1 }->{ $folder1 }->{ size },
3558 $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs },
3559 $mysync->{ folder1 }->{ $folder1 }->{ biggest },
3560 ) ;
3561 }
3562 else
3563 {
3564 $values1_str = " does not exist\n" ;
3565 }
3566
3567 if ( defined $mysync->{ folder2 }->{ $folder2 }->{ size } )
3568 {
3569 $values2_str = sprintf( "Size: %9s Messages: %5s Biggest: %9s\n",
3570 $mysync->{ folder2 }->{ $folder2 }->{ size },
3571 $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs },
3572 $mysync->{ folder2 }->{ $folder2 }->{ biggest },
3573 ) ;
3574 }
3575 else
3576 {
3577 $values2_str = " does not exist yet\n" ;
3578 }
3579
3580 myprintf( "Host1 folder %7s %-35s %s",
3581 "$counter_str",
3582 jux_utf8( $folder1 ),
3583 $values1_str
3584 ) ;
3585
3586 myprintf( "Host2 folder %7s %-35s %s",
3587 "$counter_str",
3588 jux_utf8( $folder2 ),
3589 $values2_str
3590 ) ;
3591
3592 myprintf( "Host2-Host1 %7s %-35s %9s %5s %9s\n\n",
3593 "",
3594 "",
3595 $mysync->{ folder1 }->{ $folder1 }->{ size_diff },
3596 $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs_diff },
3597 $mysync->{ folder1 }->{ $folder1 }->{ biggest_diff },
3598
3599 ) ;
3600
3601
3602
3603
3604 return ;
3605}
3606
3607sub foldersize_diff_compute
3608{
3609 my $mysync = shift ;
3610 my $folder1 = shift ;
3611 my $folder2 = shift ;
3612 my $force = shift ;
3613
3614
3615
3616 my ( $size_1, $nb_msgs_1, $biggest_1 ) ;
3617 # memoization
3618 if (
3619 exists $h1_folders_all{ $folder1 }
3620 &&
3621 (
3622 ! defined $mysync->{ folder1 }->{ $folder1 }->{ size }
3623 || $force
3624 )
3625 )
3626 {
3627 #myprint( "foldersize folder1 $h1_folders_all{ $folder1 }\n" ) ;
3628 ( $size_1, $nb_msgs_1, $biggest_1 ) =
3629 foldersize( $mysync,
3630 'Host1',
3631 $mysync->{ imap1 },
3632 $mysync->{ search1 },
3633 $mysync->{ abletosearch1 },
3634 $folder1
3635 ) ;
3636 $mysync->{ folder1 }->{ $folder1 }->{ size } = $size_1 ;
3637 $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } = $nb_msgs_1 ;
3638 $mysync->{ folder1 }->{ $folder1 }->{ biggest } = $biggest_1 ;
3639 }
3640 else
3641 {
3642 $size_1 = $mysync->{ folder1 }->{ $folder1 }->{ size } ;
3643 $nb_msgs_1 = $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } ;
3644 $biggest_1 = $mysync->{ folder1 }->{ $folder1 }->{ biggest } ;
3645
3646 }
3647
3648
3649 my ( $size_2, $nb_msgs_2, $biggest_2 ) ;
3650 if (
3651 exists $mysync->{ h2_folders_all_UPPER }{ uc $folder2 }
3652 &&
3653 (
3654 ! defined $mysync->{ folder2 }->{ $folder2 }->{ size }
3655 || $force
3656 )
3657 )
3658 {
3659 #myprint( "foldersize folder2\n" ) ;
3660 ( $size_2, $nb_msgs_2, $biggest_2 ) =
3661 foldersize( $mysync,
3662 'Host2',
3663 $mysync->{ imap2 },
3664 $mysync->{ search2 },
3665 $mysync->{ abletosearch2 },
3666 $folder2
3667 ) ;
3668
3669 $mysync->{ folder2 }->{ $folder2 }->{ size } = $size_2 ;
3670 $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } = $nb_msgs_2 ;
3671 $mysync->{ folder2 }->{ $folder2 }->{ biggest } = $biggest_2 ;
3672 }
3673 else
3674 {
3675 $size_2 = $mysync->{ folder2 }->{ $folder2 }->{ size } ;
3676 $nb_msgs_2 = $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } ;
3677 $biggest_2 = $mysync->{ folder2 }->{ $folder2 }->{ biggest } ;
3678
3679 }
3680
3681
3682 my $size_diff = diff( $size_2, $size_1 ) ;
3683 my $nb_msgs_diff = diff( $nb_msgs_2, $nb_msgs_1 ) ;
3684 my $biggest_diff = diff( $biggest_2, $biggest_1 ) ;
3685
3686 $mysync->{ folder1 }->{ $folder1 }->{ size_diff } = $size_diff ;
3687 $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs_diff } = $nb_msgs_diff ;
3688 $mysync->{ folder1 }->{ $folder1 }->{ biggest_diff } = $biggest_diff ;
3689
3690 # It's redundant but easier to access later
3691 $mysync->{ folder2 }->{ $folder2 }->{ size_diff } = $size_diff ;
3692 $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs_diff } = $nb_msgs_diff ;
3693 $mysync->{ folder2 }->{ $folder2 }->{ biggest_diff } = $biggest_diff ;
3694
3695 return ;
3696}
3697
3698sub diff
3699{
3700 my $x = shift ;
3701 my $y = shift ;
3702
3703 $x ||= 0 ;
3704 $y ||= 0 ;
3705
3706 return $x - $y ;
3707}
3708
3709sub add
3710{
3711 my $x = shift ;
3712 my $y = shift ;
3713
3714 $x ||= 0 ;
3715 $y ||= 0 ;
3716
3717 return $x + $y ;
3718}
3719
3720
3721sub foldersizes_diff_list
3722{
3723 my $mysync = shift ;
3724 my $force = shift ;
3725
3726 my @folders = @{ $mysync->{h1_folders_wanted} } ;
3727 my $nb_folders = scalar @folders ;
3728 my $ct_folders = 0 ; # folder counter.
3729
3730 foreach my $folder1 ( @folders )
3731 {
3732 $ct_folders++ ;
3733 my $counter_str = "$ct_folders/$nb_folders" ;
3734 my $folder2 = imap2_folder_name( $mysync, $folder1 ) ;
3735 foldersize_diff_present( $mysync, $folder1, $folder2, $counter_str, $force ) ;
3736 }
3737
3738 return ;
3739}
3740
3741sub foldersizes_total
3742{
3743 my $mysync = shift ;
3744
3745 my @folders_1 = @{ $mysync->{h1_folders_wanted} } ;
3746 my @folders_2 = @h2_folders_from_1_wanted ;
3747
3748 my $nb_folders_1 = scalar( @folders_1 ) ;
3749 my $nb_folders_2 = scalar( @folders_2 ) ;
3750
3751 my ( $total_size_1, $total_nb_1, $biggest_in_all_1 ) = ( 0, 0, 0 ) ;
3752 my ( $total_size_2, $total_nb_2, $biggest_in_all_2 ) = ( 0, 0, 0 ) ;
3753
3754 foreach my $folder1 ( @folders_1 )
3755 {
3756 $total_size_1 = add( $total_size_1, $mysync->{ folder1 }->{ $folder1 }->{ size } ) ;
3757 $total_nb_1 = add( $total_nb_1, $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } ) ;
3758 $biggest_in_all_1 = max( $biggest_in_all_1 , $mysync->{ folder1 }->{ $folder1 }->{ biggest } ) ;
3759 }
3760
3761 foreach my $folder2 ( @folders_2 )
3762 {
3763 $total_size_2 = add( $total_size_2, $mysync->{ folder2 }->{ $folder2 }->{ size } ) ;
3764 $total_nb_2 = add( $total_nb_2, $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } ) ;
3765 $biggest_in_all_2 = max( $biggest_in_all_2 , $mysync->{ folder2 }->{ $folder2 }->{ biggest } ) ;
3766
3767 }
3768
3769 myprintf( "Host1 Nb folders: %11s folders\n", $nb_folders_1 ) ;
3770 myprintf( "Host2 Nb folders: %11s folders\n", $nb_folders_2 ) ;
3771 myprint( "\n" ) ;
3772 myprintf( "Host1 Nb messages: %11s messages\n", $total_nb_1 ) ;
3773 myprintf( "Host2 Nb messages: %11s messages\n", $total_nb_2 ) ;
3774 myprint( "\n" ) ;
3775 myprintf( "Host1 Total size: %11s bytes (%s)\n", $total_size_1, bytes_display_string( $total_size_1 ) ) ;
3776 myprintf( "Host2 Total size: %11s bytes (%s)\n", $total_size_2, bytes_display_string( $total_size_2 ) ) ;
3777 myprint( "\n" ) ;
3778 myprintf( "Host1 Biggest message: %11s bytes (%s)\n", $biggest_in_all_1, bytes_display_string( $biggest_in_all_1 ) ) ;
3779 myprintf( "Host2 Biggest message: %11s bytes (%s)\n", $biggest_in_all_2, bytes_display_string( $biggest_in_all_2 ) ) ;
3780 myprint( "\n" ) ;
3781 myprintf( "Time spent on sizing: %11.1f seconds\n", timenext( $mysync ) ) ;
3782
3783 my @total_1_2 = ( $total_nb_1, $total_size_1, $total_nb_2, $total_size_2 ) ;
3784 return @total_1_2 ;
3785}
3786
3787sub foldersizesatend_old
3788{
3789 my $mysync = shift ;
3790 timenext( $mysync ) ;
3791 return if ( $mysync->{imap1}->IsUnconnected( ) ) ;
3792 return if ( $mysync->{imap2}->IsUnconnected( ) ) ;
3793 # Get all folders on host2 again since new were created
3794 @h2_folders_all = sort $mysync->{imap2}->folders();
3795 for ( @h2_folders_all ) {
3796 $h2_folders_all{ $_ } = 1 ;
3797 $mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ;
3798 } ;
3799 ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 }, $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ;
3800 ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 }, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ;
3801 if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) {
3802 my $error = "Failure getting foldersizes, final differences will not be calculated\n" ;
3803 errors_incr( $mysync, $error ) ;
3804 }
3805 return ;
3806}
3807
3808sub foldersizesatend
3809{
3810 my $mysync = shift ;
3811 timenext( $mysync ) ;
3812 return if ( $mysync->{imap1}->IsUnconnected( ) ) ;
3813 return if ( $mysync->{imap2}->IsUnconnected( ) ) ;
3814 # Get all folders on host2 again since new were created
3815 @h2_folders_all = sort $mysync->{imap2}->folders();
3816 for ( @h2_folders_all ) {
3817 $h2_folders_all{ $_ } = 1 ;
3818 $mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ;
3819 } ;
3820
3821
3822 foldersizes_diff_list( $mysync, $FORCE ) ;
3823
3824 ( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end )
3825 = foldersizes_total( $mysync ) ;
3826
3827
3828 if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) {
3829 my $error = "Failure getting foldersizes, final differences will not be calculated\n" ;
3830 errors_incr( $mysync, $error ) ;
3831 }
3832 return ;
3833}
3834
3835
3836sub foldersizes_at_the_beggining
3837{
3838 my $mysync = shift ;
3839
3840 myprint( << 'END_SIZE' ) ;
3841
3842Folders sizes before the synchronization.
3843You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend"
3844but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy.
3845END_SIZE
3846
3847 foldersizes_diff_list( $mysync ) ;
3848
3849 ( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start },
3850 $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } )
3851 = foldersizes_total( $mysync ) ;
3852
3853
3854 if ( not all_defined(
3855 $mysync->{ h1_nb_msg_start },
3856 $mysync->{ h1_bytes_start },
3857 $mysync->{ h2_nb_msg_start },
3858 $mysync->{ h2_bytes_start } ) )
3859 {
3860 my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ;
3861 errors_incr( $mysync, $error ) ;
3862 $mysync->{ foldersizes } = 0 ;
3863 $mysync->{ foldersizesatend } = 0 ;
3864 return ;
3865 }
3866
3867 my $h2_bytes_limit = $mysync->{h2}->{quota_limit_bytes} || 0 ;
3868 if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) )
3869 {
3870 my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ;
3871 my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $mysync->{ h1_bytes_start } bytes / $h2_bytes_limit bytes )\n" ;
3872 errors_incr( $mysync, $error ) ;
3873 }
3874 return ;
3875}
3876
3877
3878# Globals:
3879# @h2_folders_from_1_wanted
3880
3881sub foldersizes_at_the_beggining_old
3882{
3883 my $mysync = shift ;
3884
3885 myprint( << 'END_SIZE' ) ;
3886
3887Folders sizes before the synchronization.
3888You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend"
3889but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy.
3890END_SIZE
3891
3892 ( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start } ) =
3893 foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 },
3894 $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ;
3895 ( $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) =
3896 foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 },
3897 $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ;
3898
3899 if ( not all_defined( $mysync->{ h1_nb_msg_start },
3900 $mysync->{ h1_bytes_start }, $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) )
3901 {
3902 my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ;
3903 errors_incr( $mysync, $error ) ;
3904 $mysync->{ foldersizes } = 0 ;
3905 $mysync->{ foldersizesatend } = 0 ;
3906 return ;
3907 }
3908
3909 my $h2_bytes_limit = $mysync->{h2}->{quota_limit_bytes} || 0 ;
3910 if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) )
3911 {
3912 my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ;
3913 my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $mysync->{ h1_bytes_start } bytes / $h2_bytes_limit bytes )\n" ;
3914 errors_incr( $mysync, $error ) ;
3915 }
3916 return ;
3917}
3918
3919
3920sub total_bytes_max_reached
3921{
3922 my $mysync = shift ;
3923
3924 if ( ! $mysync->{ exitwhenover } ) {
3925 return( 0 ) ;
3926 }
3927 if ( $mysync->{ total_bytes_transferred } >= $mysync->{ exitwhenover } ) {
3928 myprint( "Maximum bytes transferred reached, $mysync->{total_bytes_transferred} >= $mysync->{ exitwhenover }, ending sync\n" ) ;
3929 return( 1 ) ;
3930 }
3931 return ;
3932}
3933
3934
3935sub tests_mock_capability
3936{
3937 note( 'Entering tests_mock_capability()' ) ;
3938
3939 my $myimap ;
3940 ok( $myimap = mock_capability( ),
3941 'mock_capability: (1) no args => a Test::MockObject'
3942 ) ;
3943 ok( $myimap->isa( 'Test::MockObject' ),
3944 'mock_capability: (2) no args => a Test::MockObject'
3945 ) ;
3946
3947 is( undef, $myimap->capability( ),
3948 'mock_capability: (3) no args => capability undef'
3949 ) ;
3950
3951 ok( mock_capability( $myimap ),
3952 'mock_capability: (1) one arg => MockObject'
3953 ) ;
3954
3955 is( undef, $myimap->capability( ),
3956 'mock_capability: (2) one arg OO style => capability undef'
3957 ) ;
3958
3959 ok( mock_capability( $myimap, $NUMBER_123456 ),
3960 'mock_capability: (1) two args 123456 => capability 123456'
3961 ) ;
3962
3963 is( $NUMBER_123456, $myimap->capability( ),
3964 'mock_capability: (2) two args 123456 => capability 123456'
3965 ) ;
3966
3967 ok( mock_capability( $myimap, 'ABCD' ),
3968 'mock_capability: (1) two args ABCD => capability ABCD'
3969 ) ;
3970 is( 'ABCD', $myimap->capability( ),
3971 'mock_capability: (2) two args ABCD => capability ABCD'
3972 ) ;
3973
3974 ok( mock_capability( $myimap, [ 'ABCD' ] ),
3975 'mock_capability: (1) two args [ ABCD ] => capability [ ABCD ]'
3976 ) ;
3977 is_deeply( [ 'ABCD' ], $myimap->capability( ),
3978 'mock_capability: (2) two args [ ABCD ] => capability [ ABCD ]'
3979 ) ;
3980
3981 ok( mock_capability( $myimap, [ 'ABC', 'DEF' ] ),
3982 'mock_capability: (1) two args [ ABC, DEF ] => capability [ ABC, DEF ]'
3983 ) ;
3984 is_deeply( [ 'ABC', 'DEF' ], $myimap->capability( ),
3985 'mock_capability: (2) two args [ ABC, DEF ] => capability capability [ ABC, DEF ]'
3986 ) ;
3987
3988 ok( mock_capability( $myimap, 'ABC', 'DEF' ),
3989 'mock_capability: (1) two args ABC, DEF => capability [ ABC, DEF ]'
3990 ) ;
3991 is_deeply( [ 'ABC', 'DEF' ], [ $myimap->capability( ) ],
3992 'mock_capability: (2) two args ABC, DEF => capability capability [ ABC, DEF ]'
3993 ) ;
3994
3995 ok( mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ),
3996 'mock_capability: (1) two args IMAP4rev1, APPENDLIMIT=123456 => capability [ IMAP4rev1, APPENDLIMIT=123456 ]'
3997 ) ;
3998 is_deeply( [ 'IMAP4rev1', 'APPENDLIMIT=123456' ], [ $myimap->capability( ) ],
3999 'mock_capability: (2) two args IMAP4rev1, APPENDLIMIT=123456 => capability capability [ IMAP4rev1, APPENDLIMIT=123456 ]'
4000 ) ;
4001
4002 note( 'Leaving tests_mock_capability()' ) ;
4003 return ;
4004}
4005
4006sub sig_install_toggle_sleep
4007{
4008 my $mysync = shift ;
4009 if ( 'MSWin32' ne $OSNAME ) {
4010 #myprint( "sig_install( $mysync, \&toggle_sleep, 'USR1' )\n" ) ;
4011 sig_install( $mysync, 'toggle_sleep', 'USR1' ) ;
4012 }
4013 #myprint( "Leaving sig_install_toggle_sleep\n" ) ;
4014 return ;
4015}
4016
4017
4018sub mock_capability
4019{
4020 my $myimap = shift ;
4021 my @has_capability_value = @ARG ;
4022 my ( $has_capability_value ) = @has_capability_value ;
4023
4024 if ( ! $myimap )
4025 {
4026 require_ok( "Test::MockObject" ) ;
4027 $myimap = Test::MockObject->new( ) ;
4028 }
4029
4030 $myimap->mock(
4031 'capability',
4032 sub { return wantarray ?
4033 @has_capability_value
4034 : $has_capability_value ;
4035 }
4036 ) ;
4037
4038 return $myimap ;
4039}
4040
4041
4042sub tests_capability_of
4043{
4044 note( 'Entering tests_capability_of()' ) ;
4045
4046 is( undef, capability_of( ),
4047 'capability_of: no args => undef' ) ;
4048
4049 my $myimap ;
4050 is( undef, capability_of( $myimap ),
4051 'capability_of: undef => undef' ) ;
4052
4053
4054 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ;
4055
4056 is( undef, capability_of( $myimap, 'CACA' ),
4057 'capability_of: two args unknown capability => undef' ) ;
4058
4059
4060 is( $NUMBER_123456, capability_of( $myimap, 'APPENDLIMIT' ),
4061 'capability_of: two args APPENDLIMIT 123456 => 123456 yeah!' ) ;
4062
4063 note( 'Leaving tests_capability_of()' ) ;
4064 return ;
4065}
4066
4067
4068sub capability_of
4069{
4070 my $imap = shift || return ;
4071 my $capability_keyword = shift || return ;
4072
4073 my @capability = $imap->capability ;
4074
4075 if ( ! @capability ) { return ; }
4076 my $capability_value = search_in_array( $capability_keyword, @capability ) ;
4077
4078 return $capability_value ;
4079}
4080
4081
4082sub tests_search_in_array
4083{
4084 note( 'Entering tests_search_in_array()' ) ;
4085
4086 is( undef, search_in_array( 'KA' ),
4087 'search_in_array: no array => undef ' ) ;
4088
4089 is( 'VA', search_in_array( 'KA', ( 'KA=VA' ) ),
4090 'search_in_array: KA KA=VA => VA ' ) ;
4091
4092 is( 'VA', search_in_array( 'KA', ( 'KA=VA', 'KB=VB' ) ),
4093 'search_in_array: KA KA=VA KB=VB => VA ' ) ;
4094
4095 is( 'VB', search_in_array( 'KB', ( 'KA=VA', 'KB=VB' ) ),
4096 'search_in_array: KA=VA KB=VB => VB ' ) ;
4097
4098 note( 'Leaving tests_search_in_array()' ) ;
4099 return ;
4100}
4101
4102sub search_in_array
4103{
4104 my ( $key, @array ) = @ARG ;
4105
4106 foreach my $item ( @array )
4107 {
4108
4109 if ( $item =~ /([^=]+)=(.*)/ )
4110 {
4111 if ( $1 eq $key )
4112 {
4113 return $2 ;
4114 }
4115 }
4116 }
4117
4118 return ;
4119}
4120
4121
4122
4123
4124sub tests_appendlimit_from_capability
4125{
4126 note( 'Entering tests_appendlimit_from_capability()' ) ;
4127
4128 is( undef, appendlimit_from_capability( ),
4129 'appendlimit_from_capability: no args => undef'
4130 ) ;
4131
4132 my $myimap ;
4133 is( undef, appendlimit_from_capability( $myimap ),
4134 'appendlimit_from_capability: undef arg => undef'
4135 ) ;
4136
4137
4138 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ;
4139
4140 # Normal behavior
4141 is( $NUMBER_123456, appendlimit_from_capability( $myimap ),
4142 'appendlimit_from_capability: APPENDLIMIT=123456 => 123456'
4143 ) ;
4144
4145 # Not a number
4146 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=ABC' ) ;
4147
4148 is( undef, appendlimit_from_capability( $myimap ),
4149 'appendlimit_from_capability: not a number => undef'
4150 ) ;
4151
4152 note( 'Leaving tests_appendlimit_from_capability()' ) ;
4153 return ;
4154}
4155
4156
4157sub appendlimit_from_capability
4158{
4159 my $myimap = shift ;
4160 if ( ! $myimap )
4161 {
4162 myprint( "Warn: no imap with call to appendlimit_from_capability\n" ) ;
4163 return ;
4164 }
4165
4166 #myprint( Data::Dumper->Dump( [ \$myimap ] ) ) ;
4167 my $appendlimit = capability_of( $myimap, 'APPENDLIMIT' ) ;
4168 #myprint( "has_capability APPENDLIMIT $appendlimit\n" ) ;
4169 if ( is_an_integer( $appendlimit ) )
4170 {
4171 return $appendlimit ;
4172 }
4173 return ;
4174}
4175
4176
4177sub tests_appendlimit
4178{
4179 note( 'Entering tests_appendlimit()' ) ;
4180
4181 is( undef, appendlimit( ),
4182 'appendlimit: no args => undef'
4183 ) ;
4184
4185 my $mysync = { } ;
4186
4187 is( undef, appendlimit( $mysync ),
4188 'appendlimit: no imap2 => undef'
4189 ) ;
4190
4191 my $myimap ;
4192 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ;
4193
4194 $mysync->{ imap2 } = $myimap ;
4195
4196 is( 123456, appendlimit( $mysync ),
4197 'appendlimit: imap2 with APPENDLIMIT=123456 => 123456'
4198 ) ;
4199
4200 note( 'Leaving tests_appendlimit()' ) ;
4201 return ;
4202}
4203
4204sub appendlimit
4205{
4206 my $mysync = shift || return ;
4207 my $myimap = $mysync->{ imap2 } ;
4208
4209 my $appendlimit = appendlimit_from_capability( $myimap ) ;
4210 if ( defined $appendlimit )
4211 {
4212 myprint( "Host2: found APPENDLIMIT=$appendlimit in CAPABILITY (use --appendlimit xxxx to override this automatic setting)\n" ) ;
4213 return $appendlimit ;
4214 }
4215 return ;
4216
4217}
4218
4219
4220sub tests_maxsize_setting
4221{
4222 note( 'Entering tests_maxsize_setting()' ) ;
4223
4224 is( undef, maxsize_setting( ),
4225 'maxsize_setting: no args => undef'
4226 ) ;
4227
4228 my $mysync ;
4229
4230 is( undef, maxsize_setting( $mysync ),
4231 'maxsize_setting: undef arg => undef'
4232 ) ;
4233
4234 $mysync = { } ;
4235 $mysync->{ maxsize } = $NUMBER_123456 ;
4236
4237 # --maxsize alone
4238 is( $NUMBER_123456, maxsize_setting( $mysync ),
4239 'maxsize_setting: --maxsize 123456 alone => 123456'
4240 ) ;
4241
4242
4243 $mysync = { } ;
4244 my $myimap ;
4245
4246 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ;
4247 $mysync->{ imap2 } = $myimap ;
4248
4249 # APPENDLIMIT alone
4250 is( $NUMBER_654321, maxsize_setting( $mysync ),
4251 'maxsize_setting: APPENDLIMIT 654321 alone => 654321'
4252 ) ;
4253
4254 is( $NUMBER_654321, $mysync->{ maxsize },
4255 'maxsize_setting: APPENDLIMIT 654321 alone => maxsize 654321'
4256 ) ;
4257
4258 # APPENDLIMIT with --appendlimit => --appendlimit wins
4259 $mysync->{ appendlimit } = $NUMBER_123456 ;
4260
4261 is( $NUMBER_123456, maxsize_setting( $mysync ),
4262 'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => 123456'
4263 ) ;
4264
4265 is( $NUMBER_123456, $mysync->{ maxsize },
4266 'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => maxsize 123456'
4267 ) ;
4268
4269 # Fresh
4270 $mysync = { } ;
4271 $mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ;
4272
4273 # Case: "APPENDLIMIT >= --maxsize" => maxsize.
4274 $mysync->{ maxsize } = $NUMBER_123456 ;
4275
4276 is( $NUMBER_123456, maxsize_setting( $mysync ),
4277 'maxsize_setting: APPENDLIMIT 654321 --maxsize 123456 => 123456'
4278 ) ;
4279
4280 # Case: "APPENDLIMIT < --maxsize" => APPENDLIMIT.
4281
4282
4283 # Fresh
4284 $mysync = { } ;
4285 $mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ;
4286 $mysync->{ maxsize } = $NUMBER_654321 ;
4287
4288 is( $NUMBER_123456, maxsize_setting( $mysync ),
4289 'maxsize_setting: APPENDLIMIT 123456 --maxsize 654321 => 123456 '
4290 ) ;
4291
4292 # Now --truncmess stuff
4293
4294
4295
4296 note( 'Leaving tests_maxsize_setting()' ) ;
4297
4298 return ;
4299}
4300
4301# Three variables to take account of
4302# appendlimit (given by --appendlimit or CAPABILITY...)
4303# maxsize
4304# truncmess
4305
4306sub maxsize_setting
4307{
4308 my $mysync = shift || return ;
4309
4310 if ( defined $mysync->{ appendlimit } )
4311 {
4312 myprint( "Host2: Getting appendlimit from --appendlimit $mysync->{ appendlimit }\n" ) ;
4313 }
4314 else
4315 {
4316 $mysync->{ appendlimit } = appendlimit( $mysync ) ;
4317 }
4318
4319
4320 if ( all_defined( $mysync->{ appendlimit }, $mysync->{ maxsize } ) )
4321 {
4322 my $min_maxsize_appendlimit = min( $mysync->{ maxsize }, $mysync->{ appendlimit } ) ;
4323 myprint( "Host2: Setting maxsize to $min_maxsize_appendlimit (min of --maxsize $mysync->{ maxsize } and appendlimit $mysync->{ appendlimit }\n" ) ;
4324 $mysync->{ maxsize } = $min_maxsize_appendlimit ;
4325 return $mysync->{ maxsize } ;
4326 }
4327 elsif ( defined $mysync->{ appendlimit } )
4328 {
4329 myprint( "Host2: Setting maxsize to appendlimit $mysync->{ appendlimit }\n" ) ;
4330 $mysync->{ maxsize } = $mysync->{ appendlimit } ;
4331 return $mysync->{ maxsize } ;
4332 }elsif ( defined $mysync->{ maxsize } )
4333 {
4334 return $mysync->{ maxsize } ;
4335 }else
4336 {
4337 return ;
4338 }
4339}
4340
4341
4342
4343
4344sub all_defined
4345{
4346 if ( not @ARG ) {
4347 return 0 ;
4348 }
4349 foreach my $elem ( @ARG ) {
4350 if ( not defined $elem ) {
4351 return 0 ;
4352 }
4353 }
4354 return 1 ;
4355}
4356
4357sub tests_all_defined
4358{
4359 note( 'Entering tests_all_defined()' ) ;
4360
4361 is( 0, all_defined( ), 'all_defined: no param => 0' ) ;
4362 is( 0, all_defined( () ), 'all_defined: void list => 0' ) ;
4363 is( 0, all_defined( undef ), 'all_defined: undef => 0' ) ;
4364 is( 0, all_defined( undef, undef ), 'all_defined: undef => 0' ) ;
4365 is( 0, all_defined( 1, undef ), 'all_defined: 1 undef => 0' ) ;
4366 is( 0, all_defined( undef, 1 ), 'all_defined: undef 1 => 0' ) ;
4367 is( 1, all_defined( 1, 1 ), 'all_defined: 1 1 => 1' ) ;
4368 is( 1, all_defined( (1, 1) ), 'all_defined: (1 1) => 1' ) ;
4369
4370 note( 'Leaving tests_all_defined()' ) ;
4371 return ;
4372}
4373
4374
4375sub tests_hashsynclocal
4376{
4377 note( 'Entering tests_hashsynclocal()' ) ;
4378
4379 my $mysync = {
4380 host1 => q{},
4381 user1 => q{},
4382 password1 => q{},
4383 host2 => q{},
4384 user2 => q{},
4385 password2 => q{},
4386 } ;
4387
4388 is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no hashfile name' ) ;
4389
4390 $mysync->{ hashfile } = q{} ;
4391 is( undef, hashsynclocal( $mysync ), 'hashsynclocal: empty hashfile name' ) ;
4392
4393 $mysync->{ hashfile } = './noexist/rrr' ;
4394 is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no exists hashfile dir' ) ;
4395
4396 SKIP: {
4397 if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) { skip( 'Tests only for non-root Unix', 1 ) ; }
4398 $mysync->{ hashfile } = '/rrr' ;
4399 is( undef, hashsynclocal( $mysync ), 'hashsynclocal: permission denied' ) ;
4400 }
4401 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'hashsynclocal: mkpath W/tmp/tests/' ) ;
4402 $mysync->{ hashfile } = 'W/tmp/tests/imapsync_hash' ;
4403
4404 ok( ! -e 'W/tmp/tests/imapsync_hash' || unlink 'W/tmp/tests/imapsync_hash', 'hashsynclocal: unlink W/tmp/tests/imapsync_hash' ) ;
4405 ok( ! -e 'W/tmp/tests/imapsync_hash', 'hashsynclocal: verify there is no W/tmp/tests/imapsync_hash' ) ;
4406 is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync, 'mukksyhpmbixkxkpjlqivmlqsulpictj' ), 'hashsynclocal: creating/reading W/tmp/tests/imapsync_hash' ) ;
4407 # A second time now
4408 is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync ), 'hashsynclocal: reading W/tmp/tests/imapsync_hash second time => same' ) ;
4409
4410 note( 'Leaving tests_hashsynclocal()' ) ;
4411 return ;
4412}
4413
4414sub hashsynclocal
4415{
4416 my $mysync = shift ;
4417 my $hashkey = shift ; # Optional, only there for tests
4418 my $hashfile = $mysync->{ hashfile } ;
4419 $hashfile = createhashfileifneeded( $hashfile, $hashkey ) ;
4420 if ( ! $hashfile ) {
4421 return ;
4422 }
4423 $hashkey = firstline( $hashfile ) ;
4424 if ( ! $hashkey ) {
4425 myprint( "No hashkey!\n" ) ;
4426 return ;
4427 }
4428 my $hashsynclocal = hashsync( $mysync, $hashkey ) ;
4429 return( $hashsynclocal ) ;
4430
4431}
4432
4433sub tests_hashsync
4434{
4435 note( 'Entering tests_hashsync()' ) ;
4436
4437
4438 is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( {}, q{} ), 'hashsync: empty args' ) ;
4439 my $mysync ;
4440 $mysync->{ host1 } = 'zzz' ;
4441 is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ;
4442 is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ;
4443 $mysync->{ host2 } = 'zzz' ;
4444 is( '15959573e4a86763253a7aedb1a2b0c60d133dc2', hashsync( $mysync, q{} ), 'hashsync: + host2 zzz => ' ) ;
4445 is( 'b8d4ab541b209c75928528020ca28ee43488bd8f', hashsync( $mysync, 'A' ), 'hashsync: + hashkey A => ' ) ;
4446
4447 note( 'Leaving tests_hashsync()' ) ;
4448 return ;
4449}
4450
4451sub hashsync
4452{
4453 my $mysync = shift ;
4454 my $hashkey = shift ;
4455
4456 my $mystring = join( q{},
4457 $mysync->{ host1 } || q{},
4458 $mysync->{ user1 } || q{},
4459 $mysync->{ password1 } || q{},
4460 $mysync->{ host2 } || q{},
4461 $mysync->{ user2 } || q{},
4462 $mysync->{ password2 } || q{},
4463 ) ;
4464 my $hashsync = hmac_sha1_hex( $mystring, $hashkey ) ;
4465 #myprint( "$hashsync\n" ) ;
4466 return( $hashsync ) ;
4467}
4468
4469
4470sub tests_createhashfileifneeded
4471{
4472 note( 'Entering tests_createhashfileifneeded()' ) ;
4473
4474 is( undef, createhashfileifneeded( ), 'createhashfileifneeded: no parameters => undef' ) ;
4475
4476 note( 'Leaving tests_createhashfileifneeded()' ) ;
4477 return ;
4478}
4479
4480sub createhashfileifneeded
4481{
4482 my $hashfile = shift ;
4483 my $hashkey = shift || rand32( ) ;
4484
4485 # no name
4486 if ( ! $hashfile ) {
4487 return ;
4488 }
4489 # already there
4490 if ( -e -r $hashfile ) {
4491 return $hashfile ;
4492 }
4493 # not creatable
4494 if ( ! -w dirname( $hashfile ) ) {
4495 return ;
4496 }
4497 # creatable
4498 open my $FILE_HANDLE, '>', $hashfile
4499 or do {
4500 myprint( "Could not open $hashfile for writing. Check permissions or disk space." ) ;
4501 return ;
4502 } ;
4503 myprint( "Writing random hashkey in $hashfile, once for all times\n" ) ;
4504 print $FILE_HANDLE $hashkey ;
4505 close $FILE_HANDLE ;
4506 # Should be there now
4507 if ( -e -r $hashfile ) {
4508 return $hashfile ;
4509 }
4510 # unknown failure
4511 return ;
4512}
4513
4514sub tests_rand32
4515{
4516 note( 'Entering tests_rand32()' ) ;
4517
4518 my $string = rand32( ) ;
4519 myprint( "$string\n" ) ;
4520 is( 32, length( $string ), 'rand32: 32 characters long' ) ;
4521 is( 32, length( rand32( ) ), 'rand32: 32 characters long, another one' ) ;
4522
4523 note( 'Leaving tests_rand32()' ) ;
4524 return ;
4525}
4526
4527sub rand32
4528{
4529 my @chars = ( "a".."z" ) ;
4530 my $string;
4531 $string .= $chars[rand @chars] for 1..32 ;
4532 return $string ;
4533}
4534
4535sub imap_id_stuff
4536{
4537 my $mysync = shift ;
4538
4539 if ( not $mysync->{id} ) { return ; } ;
4540
4541 $mysync->{h1_imap_id} = imap_id( $mysync, $mysync->{imap1}, 'Host1' ) ;
4542 #myprint( 'Host1: ' . $mysync->{h1_imap_id} ) ;
4543 $mysync->{h2_imap_id} = imap_id( $mysync, $mysync->{imap2}, 'Host2' ) ;
4544 #myprint( 'Host2: ' . $mysync->{h2_imap_id} ) ;
4545
4546 return ;
4547}
4548
4549sub imap_id
4550{
4551 my ( $mysync, $imap, $Side ) = @_ ;
4552
4553 if ( not $mysync->{id} ) { return q{} ; } ;
4554
4555 $Side ||= q{} ;
4556 my $imap_id_response = q{} ;
4557
4558 if ( not $imap->has_capability( 'ID' ) ) {
4559 $imap_id_response = 'No ID capability' ;
4560 myprint( "$Side: No ID capability\n" ) ;
4561 }else{
4562 my $id_inp = imapsync_id( $mysync, { side => lc $Side } ) ;
4563 myprint( "\n$Side: found ID capability. Sending/receiving ID, presented in raw IMAP for now.\n"
4564 . "In order to avoid sending/receiving ID, use option --noid\n" ) ;
4565 my $debug_before = $imap->Debug( ) ;
4566 $imap->Debug( 1 ) ;
4567 my $id_out = $imap->tag_and_run( 'ID ' . $id_inp ) ;
4568 #my $id_out = $imap->tag_and_run( 'ID NIL' ) ;
4569 myprint( "\n" ) ;
4570 $imap->Debug( $debug_before ) ;
4571 #$imap_id_response = Data::Dumper->Dump( [ $id_out ], [ 'IMAP_ID' ] ) ;
4572 }
4573 return( $imap_id_response ) ;
4574}
4575
4576sub imapsync_id
4577{
4578 my $mysync = shift ;
4579 my $overhashref = shift ;
4580 # See http://tools.ietf.org/html/rfc2971.html
4581
4582 my $imapsync_id = { } ;
4583
4584 my $imapsync_id_lamiral = {
4585 name => 'imapsync',
4586 version => imapsync_version( $mysync ),
4587 os => $OSNAME,
4588 vendor => 'Gilles LAMIRAL',
4589 'support-url' => 'https://imapsync.lamiral.info/',
4590 # Example of date-time: 19-Sep-2015 08:56:07
4591 date => date_from_rcs( q{$Date: 2019/12/23 20:18:02 $ } ),
4592 } ;
4593
4594 my $imapsync_id_github = {
4595 name => 'imapsync',
4596 version => imapsync_version( $mysync ),
4597 os => $OSNAME,
4598 vendor => 'github',
4599 'support-url' => 'https://github.com/imapsync/imapsync',
4600 date => date_from_rcs( q{$Date: 2019/12/23 20:18:02 $ } ),
4601 } ;
4602
4603 $imapsync_id = $imapsync_id_lamiral ;
4604 #$imapsync_id = $imapsync_id_github ;
4605 my %mix = ( %{ $imapsync_id }, %{ $overhashref } ) ;
4606 my $imapsync_id_str = format_for_imap_arg( \%mix ) ;
4607 #myprint( "$imapsync_id_str\n" ) ;
4608 return( $imapsync_id_str ) ;
4609}
4610
4611sub tests_imapsync_id
4612{
4613 note( 'Entering tests_imapsync_id()' ) ;
4614
4615 my $mysync ;
4616 ok( '("name" "imapsync" "version" "111" "os" "beurk" "vendor" "Gilles LAMIRAL" "support-url" "https://imapsync.lamiral.info/" "date" "22-12-1968" "side" "host1")'
4617 eq imapsync_id( $mysync,
4618 {
4619 version => 111,
4620 os => 'beurk',
4621 date => '22-12-1968',
4622 side => 'host1'
4623 }
4624 ),
4625 'tests_imapsync_id override'
4626 ) ;
4627
4628 note( 'Leaving tests_imapsync_id()' ) ;
4629 return ;
4630}
4631
4632sub format_for_imap_arg
4633{
4634 my $ref = shift ;
4635
4636 my $string = q{} ;
4637 my %terms = %{ $ref } ;
4638 my @terms = ( ) ;
4639 if ( not ( %terms ) ) { return( 'NIL' ) } ;
4640 # sort like in RFC then add extra key/values
4641 foreach my $key ( qw( name version os os-version vendor support-url address date command arguments environment) ) {
4642 if ( $terms{ $key } ) {
4643 push @terms, $key, $terms{ $key } ;
4644 delete $terms{ $key } ;
4645 }
4646 }
4647 push @terms, %terms ;
4648 $string = '(' . ( join q{ }, map { '"' . $_ . '"' } @terms ) . ')' ;
4649 return( $string ) ;
4650}
4651
4652
4653
4654sub tests_format_for_imap_arg
4655{
4656 note( 'Entering tests_format_for_imap_arg()' ) ;
4657
4658 ok( 'NIL' eq format_for_imap_arg( { } ), 'format_for_imap_arg empty hash ref' ) ;
4659 ok( '("name" "toto")' eq format_for_imap_arg( { name => 'toto' } ), 'format_for_imap_arg { name => toto }' ) ;
4660 ok( '("name" "toto" "key" "val")' eq format_for_imap_arg( { name => 'toto', key => 'val' } ), 'format_for_imap_arg 2 x key val' ) ;
4661
4662 note( 'Leaving tests_format_for_imap_arg()' ) ;
4663 return ;
4664}
4665
4666sub quota
4667{
4668 my ( $mysync, $imap, $side ) = @_ ;
4669
4670 my %side = (
4671 h1 => 'Host1',
4672 h2 => 'Host2',
4673 ) ;
4674 my $Side = $side{ $side } ;
4675 my $debug_before = $imap->Debug( ) ;
4676 $imap->Debug( 1 ) ;
4677 if ( not $imap->has_capability( 'QUOTA' ) ) {
4678 $imap->Debug( $debug_before ) ;
4679 return ;
4680 } ;
4681 myprint( "\n$Side: found quota, presented in raw IMAP\n" ) ;
4682 my $getquotaroot = $imap->getquotaroot( 'INBOX' ) ;
4683 # Gmail INBOX quotaroot is "" but with it Mail::IMAPClient does a literal GETQUOTA {2} \n ""
4684 #$imap->quota( 'ROOT' ) ;
4685 #$imap->quota( '""' ) ;
4686 myprint( "\n" ) ;
4687 $imap->Debug( $debug_before ) ;
4688 my $quota_limit_bytes = quota_extract_storage_limit_in_bytes( $mysync, $getquotaroot ) ;
4689 my $quota_current_bytes = quota_extract_storage_current_in_bytes( $mysync, $getquotaroot ) ;
4690 $mysync->{$side}->{quota_limit_bytes} = $quota_limit_bytes ;
4691 $mysync->{$side}->{quota_current_bytes} = $quota_current_bytes ;
4692 my $quota_percent ;
4693 if ( $quota_limit_bytes > 0 ) {
4694 $quota_percent = mysprintf( '%.2f', $NUMBER_100 * $quota_current_bytes / $quota_limit_bytes ) ;
4695 }else{
4696 $quota_percent = 0 ;
4697 }
4698 myprint( "$Side: Quota current storage is $quota_current_bytes bytes. Limit is $quota_limit_bytes bytes. So $quota_percent % full\n" ) ;
4699 if ( $QUOTA_PERCENT_LIMIT < $quota_percent ) {
4700 my $error = "$Side: $quota_percent % full: it is time to find a bigger place! ( $quota_current_bytes bytes / $quota_limit_bytes bytes )\n" ;
4701 errors_incr( $mysync, $error ) ;
4702 }
4703 return ;
4704}
4705
4706sub tests_quota_extract_storage_limit_in_bytes
4707{
4708 note( 'Entering tests_quota_extract_storage_limit_in_bytes()' ) ;
4709
4710 my $mysync = {} ;
4711 my $imap_output = [
4712 '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
4713 '* QUOTA "Storage quota" (STORAGE 1 104857600)',
4714 '* QUOTA "Messages quota" (MESSAGE 2 100000)',
4715 '5 OK Getquotaroot completed.'
4716 ] ;
4717 ok( $NUMBER_104_857_600 * $KIBI == quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes ') ;
4718
4719 note( 'Leaving tests_quota_extract_storage_limit_in_bytes()' ) ;
4720 return ;
4721}
4722
4723sub quota_extract_storage_limit_in_bytes
4724{
4725 my $mysync = shift ;
4726 my $imap_output = shift ;
4727
4728 my $limit_kb ;
4729 $limit_kb = ( map { /.*\(\s*STORAGE\s+\d+\s+(\d+)\s*\)/x ? $1 : () } @{ $imap_output } )[0] ;
4730 $limit_kb ||= 0 ;
4731 $mysync->{ debug } and myprint( "storage_limit_kb = $limit_kb\n" ) ;
4732 return( $KIBI * $limit_kb ) ;
4733}
4734
4735
4736sub tests_quota_extract_storage_current_in_bytes
4737{
4738 note( 'Entering tests_quota_extract_storage_current_in_bytes()' ) ;
4739
4740 my $mysync = {} ;
4741 my $imap_output = [
4742 '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"',
4743 '* QUOTA "Storage quota" (STORAGE 1 104857600)',
4744 '* QUOTA "Messages quota" (MESSAGE 2 100000)',
4745 '5 OK Getquotaroot completed.'
4746 ] ;
4747 ok( 1*$KIBI == quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ;
4748
4749 note( 'Leaving tests_quota_extract_storage_current_in_bytes()' ) ;
4750 return ;
4751}
4752
4753sub quota_extract_storage_current_in_bytes
4754{
4755 my $mysync = shift ;
4756 my $imap_output = shift ;
4757
4758 my $current_kb ;
4759 $current_kb = ( map { /.*\(\s*STORAGE\s+(\d+)\s+\d+\s*\)/x ? $1 : () } @{ $imap_output } )[0] ;
4760 $current_kb ||= 0 ;
4761 $mysync->{ debug } and myprint( "storage_current_kb = $current_kb\n" ) ;
4762 return( $KIBI * $current_kb ) ;
4763
4764}
4765
4766
4767sub automap
4768{
4769 my ( $mysync ) = @_ ;
4770
4771 if ( $mysync->{automap} ) {
4772 myprint( "Turned on automapping folders ( use --noautomap to turn off automapping )\n" ) ;
4773 }else{
4774 myprint( "Turned off automapping folders ( use --automap to turn on automapping )\n" ) ;
4775 return ;
4776 }
4777
4778 $mysync->{h1_special} = special_from_folders_hash( $mysync, $mysync->{imap1}, 'Host1' ) ;
4779 $mysync->{h2_special} = special_from_folders_hash( $mysync, $mysync->{imap2}, 'Host2' ) ;
4780
4781 build_possible_special( $mysync ) ;
4782 build_guess_special( $mysync ) ;
4783 build_automap( $mysync ) ;
4784
4785 return ;
4786}
4787
4788
4789
4790
4791sub build_guess_special
4792{
4793 my ( $mysync ) = shift ;
4794
4795 foreach my $h1_fold ( sort keys %{ $mysync->{h1_folders_all} } ) {
4796 my $special = guess_special( $h1_fold, $mysync->{possible_special}, $mysync->{h1_prefix} ) ;
4797 if ( $special ) {
4798 $mysync->{h1_special_guessed}{$h1_fold} = $special ;
4799 my $already_guessed = $mysync->{h1_special_guessed}{$special} ;
4800 if ( $already_guessed ) {
4801 myprint( "Host1: $h1_fold not $special because set to $already_guessed\n" ) ;
4802 }else{
4803 $mysync->{h1_special_guessed}{$special} = $h1_fold ;
4804 }
4805 }
4806 }
4807 foreach my $h2_fold ( sort keys %{ $mysync->{h2_folders_all} } ) {
4808 my $special = guess_special( $h2_fold, $mysync->{possible_special}, $mysync->{h2_prefix} ) ;
4809 if ( $special ) {
4810 $mysync->{h2_special_guessed}{$h2_fold} = $special ;
4811 my $already_guessed = $mysync->{h2_special_guessed}{$special} ;
4812 if ( $already_guessed ) {
4813 myprint( "Host2: $h2_fold not $special because set to $already_guessed\n" ) ;
4814 }else{
4815 $mysync->{h2_special_guessed}{$special} = $h2_fold ;
4816 }
4817 }
4818 }
4819 return ;
4820}
4821
4822sub guess_special
4823{
4824 my( $folder, $possible_special_ref, $prefix ) = @_ ;
4825
4826 my $folder_no_prefix = $folder ;
4827 $folder_no_prefix =~ s/\Q${prefix}\E//xms ;
4828 #$debug and myprint( "folder_no_prefix: $folder_no_prefix\n" ) ;
4829
4830 my $guess_special = $possible_special_ref->{ $folder }
4831 || $possible_special_ref->{ $folder_no_prefix }
4832 || q{} ;
4833
4834 return( $guess_special ) ;
4835}
4836
4837sub tests_guess_special
4838{
4839 note( 'Entering tests_guess_special()' ) ;
4840
4841 my $possible_special_ref = build_possible_special( my $mysync ) ;
4842 ok( '\Sent' eq guess_special( 'Sent', $possible_special_ref, q{} ) ,'guess_special: Sent => \Sent' ) ;
4843 ok( q{} eq guess_special( 'Blabla', $possible_special_ref, q{} ) ,'guess_special: Blabla => q{}' ) ;
4844 ok( '\Sent' eq guess_special( 'INBOX.Sent', $possible_special_ref, 'INBOX.' ) ,'guess_special: INBOX.Sent => \Sent' ) ;
4845 ok( '\Sent' eq guess_special( 'IN BOX.Sent', $possible_special_ref, 'IN BOX.' ) ,'guess_special: IN BOX.Sent => \Sent' ) ;
4846
4847 note( 'Leaving tests_guess_special()' ) ;
4848 return ;
4849}
4850
4851sub build_automap
4852{
4853 my $mysync = shift ;
4854 $mysync->{ debug } and myprint( "Entering build_automap\n" ) ;
4855 foreach my $h1_fold ( @{ $mysync->{h1_folders_wanted} } ) {
4856 my $h2_fold ;
4857 my $h1_special = $mysync->{h1_special}{$h1_fold} ;
4858 my $h1_special_guessed = $mysync->{h1_special_guessed}{$h1_fold} ;
4859
4860 # Case 1: special on both sides.
4861 if ( $h1_special
4862 and exists $mysync->{h2_special}{$h1_special} ) {
4863 $h2_fold = $mysync->{h2_special}{$h1_special} ;
4864 $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ;
4865 next ;
4866 }
4867 # Case 2: special on host1, not on host2
4868 if ( $h1_special
4869 and ( not exists $mysync->{h2_special}{$h1_special} )
4870 and ( exists $mysync->{h2_special_guessed}{$h1_special} )
4871 ) {
4872 # special_guessed on host2
4873 $h2_fold = $mysync->{h2_special_guessed}{$h1_special} ;
4874 $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ;
4875 next ;
4876 }
4877 # Case 3: no special on host1, special on host2
4878 if ( ( not $h1_special )
4879 and ( $h1_special_guessed )
4880 and ( exists $mysync->{h2_special}{$h1_special_guessed} )
4881 ) {
4882 $h2_fold = $mysync->{h2_special}{$h1_special_guessed} ;
4883 $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ;
4884 next ;
4885 }
4886 # Case 4: no special on both sides.
4887 if ( ( not $h1_special )
4888 and ( $h1_special_guessed )
4889 and ( not exists $mysync->{h2_special}{$h1_special_guessed} )
4890 and ( exists $mysync->{h2_special_guessed}{$h1_special_guessed} )
4891 ) {
4892 $h2_fold = $mysync->{h2_special_guessed}{$h1_special_guessed} ;
4893 $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ;
4894 next ;
4895 }
4896 }
4897 return( $mysync->{f1f2auto} ) ;
4898}
4899
4900# I will not add what there is at:
4901# http://stackoverflow.com/questions/2185391/localized-gmail-imap-folders/2185548#2185548
4902# because it works well without
4903sub build_possible_special
4904{
4905 my $mysync = shift ;
4906 my $possible_special = { } ;
4907 # All|Archive|Drafts|Flagged|Junk|Sent|Trash
4908
4909 $possible_special->{'\All'} = [ 'All', 'All Messages', '&BBIEQQQ1-' ] ;
4910 $possible_special->{'\Archive'} = [ 'Archive', 'Archives', '&BBAEQARFBDgEMg-' ] ;
4911 $possible_special->{'\Drafts'} = [ 'Drafts', 'DRAFTS', '&BCcENQRABD0EPgQyBDgEOgQ4-', 'Szkice', 'Wersje robocze' ] ;
4912 $possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ;
4913 $possible_special->{'\Junk'} = [ 'Junk', 'junk', 'Spam', 'SPAM', '&BCEEPwQwBDw-',
4914 'Potwierdzony spam', 'Wiadomo&AVs-ci-&AVs-mieci',
4915 'Junk E-Mail', 'Junk Email'] ;
4916 $possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items',
4917 'Gesendete Elemente', 'Gesendete Objekte',
4918 '&AMk-l&AOk-ments envoy&AOk-s', 'Envoy&AOk-', 'Objets envoy&AOk-s',
4919 'Elementos enviados',
4920 '&kAFP4W4IMH8wojCkMMYw4A-',
4921 '&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-',
4922 'Elementy wys&AUI-ane'] ;
4923 $possible_special->{'\Trash'} = [ 'Trash', 'TRASH',
4924 '&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-',
4925 'Kosz',
4926 'Deleted Items', 'Deleted Messages' ] ;
4927
4928
4929 foreach my $special ( qw( \All \Archive \Drafts \Flagged \Junk \Sent \Trash ) ){
4930 foreach my $possible_folder ( @{ $possible_special->{$special} } ) {
4931 $possible_special->{ $possible_folder } = $special ;
4932 } ;
4933 }
4934 $mysync->{possible_special} = $possible_special ;
4935 $mysync->{ debug } and myprint( Data::Dumper->Dump( [ $possible_special ], [ 'possible_special' ] ) ) ;
4936 return( $possible_special ) ;
4937}
4938
4939sub tests_special_from_folders_hash
4940{
4941 note( 'Entering tests_special_from_folders_hash()' ) ;
4942
4943 my $mysync = {} ;
4944 require_ok( "Test::MockObject" ) ;
4945 my $imapT = Test::MockObject->new( ) ;
4946
4947 is( undef, special_from_folders_hash( ), 'special_from_folders_hash: no args' ) ;
4948 is( undef, special_from_folders_hash( $mysync ), 'special_from_folders_hash: undef args' ) ;
4949 is_deeply( {}, special_from_folders_hash( $mysync, $imapT ), 'special_from_folders_hash: $imap void' ) ;
4950
4951 $imapT->mock( 'folders_hash', sub { return( [ { name => 'Sent', attrs => [ '\Sent' ] } ] ) } ) ;
4952
4953 is_deeply( { Sent => '\Sent', '\Sent' => 'Sent' },
4954 special_from_folders_hash( $mysync, $imapT ), 'special_from_folders_hash: $imap \Sent' ) ;
4955
4956 note( 'Leaving tests_special_from_folders_hash()' ) ;
4957 return( ) ;
4958}
4959
4960sub special_from_folders_hash
4961{
4962 my ( $mysync, $imap, $side ) = @_ ;
4963 my %special = ( ) ;
4964
4965 if ( ! defined $imap ) { return ; }
4966 $side = defined $side ? $side : 'Host?' ;
4967
4968 if ( ! $imap->can( 'folders_hash' ) ) {
4969 my $error = "$side: To have automagic rfc6154 folder mapping, upgrade Mail::IMAPClient >= 3.34\n" ;
4970 errors_incr( $mysync, $error ) ;
4971 return( \%special ) ; # empty hash ref
4972 }
4973 my $folders_hash = $imap->folders_hash( ) ;
4974 foreach my $fhash (@{ $folders_hash } ) {
4975 my @special = grep { /\\(?:All|Archive|Drafts|Flagged|Junk|Sent|Trash)/x } @{ $fhash->{attrs} } ;
4976 if ( @special ) {
4977 my $special = $special[0] ; # keep first one. Could be not very good.
4978 if ( exists $special{ $special } ) {
4979 myprintf( "%s: special %-20s = %s already assigned to %s\n",
4980 $side, $fhash->{name}, join( q{ }, @special ), $special{ $special } ) ;
4981 }else{
4982 myprintf( "%s: special %-20s = %s\n",
4983 $side, $fhash->{name}, join( q{ }, @special ) ) ;
4984 $special{ $special } = $fhash->{name} ;
4985 $special{ $fhash->{name} } = $special ; # double entry value => key
4986 }
4987 }
4988 }
4989 myprint( "\n" ) if ( %special ) ;
4990 return( \%special ) ;
4991}
4992
4993sub errors_incr
4994{
4995 my ( $mysync, @error ) = @ARG ;
4996 $mysync->{nb_errors}++ ;
4997
4998 if ( @error ) {
4999 errors_log( $mysync, @error ) ;
5000 myprint( @error ) ;
5001 }
5002
5003 $mysync->{errorsmax} ||= $ERRORS_MAX ;
5004 if ( $mysync->{nb_errors} >= $mysync->{errorsmax} ) {
5005 myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). Exiting.\n" ) ;
5006 if ( $mysync->{errorsdump} ) {
5007 myprint( errorsdump( $mysync->{nb_errors}, errors_log( $mysync ) ) ) ;
5008 # again since errorsdump( ) can be very verbose and masquerade previous warning
5009 myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). Exiting.\n" ) ;
5010 }
5011 exit_clean( $mysync, $EXIT_WITH_ERRORS_MAX ) ;
5012 }
5013 return ;
5014}
5015
5016sub tests_errors_log
5017{
5018 note( 'Entering tests_errors_log()' ) ;
5019 is( undef, errors_log( ), 'errors_log: no args => undef' ) ;
5020 my $mysync = {} ;
5021 is( undef, errors_log( $mysync ), 'errors_log: empty => undef' ) ;
5022 is_deeply( [ 'aieaie' ], [ errors_log( $mysync, 'aieaie' ) ], 'errors_log: aieaie => aieaie' ) ;
5023 # cumulative
5024 is_deeply( [ 'aieaie' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie' ) ;
5025 is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync, 'ouille' ) ], 'errors_log: ouille => aieaie ouille' ) ;
5026 is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie ouille' ) ;
5027 note( 'Leaving tests_errors_log()' ) ;
5028 return ;
5029}
5030
5031sub errors_log
5032{
5033 my ( $mysync, @error ) = @ARG ;
5034
5035 if ( ! $mysync->{errors_log} ) {
5036 $mysync->{errors_log} = [] ;
5037 }
5038
5039 if ( @error ) {
5040 push @{ $mysync->{errors_log} }, join( q{}, @error ) ;
5041 }
5042 if ( @{ $mysync->{errors_log} } ) {
5043 return @{ $mysync->{errors_log} } ;
5044 }
5045 else {
5046 return ;
5047 }
5048}
5049
5050
5051sub errorsdump
5052{
5053 my( $nb_errors, @errors_log ) = @ARG ;
5054 my $error_num = 0 ;
5055 my $errors_list = q{} ;
5056 if ( @errors_log ) {
5057 $errors_list = "++++ Listing $nb_errors errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n" ;
5058 foreach my $error ( @errors_log ) {
5059 $error_num++ ;
5060 $errors_list .= "Err $error_num/$nb_errors: $error" ;
5061 }
5062 }
5063 return( $errors_list ) ;
5064}
5065
5066
5067sub tests_live_result
5068{
5069 note( 'Entering tests_live_result()' ) ;
5070
5071 my $nb_errors = shift ;
5072 if ( $nb_errors ) {
5073 myprint( "Live tests failed with $nb_errors errors\n" ) ;
5074 } else {
5075 myprint( "Live tests ended successfully\n" ) ;
5076 }
5077 note( 'Leaving tests_live_result()' ) ;
5078 return ;
5079}
5080
5081
5082sub size_filtered_flag
5083{
5084 my $mysync = shift ;
5085 my $h1_size = shift ;
5086
5087 if ( defined $mysync->{ maxsize } and $h1_size >= $mysync->{ maxsize } ) {
5088 return( 1 ) ;
5089 }
5090 if ( defined $minsize and $h1_size <= $minsize ) {
5091 return( 1 ) ;
5092 }
5093 return( 0 ) ;
5094}
5095
5096sub sync_flags_fir
5097{
5098 my ( $mysync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ;
5099
5100 if ( not defined $h1_msg ) { return } ;
5101 if ( not defined $h2_msg ) { return } ;
5102
5103 my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} ;
5104 return if size_filtered_flag( $mysync, $h1_size ) ;
5105
5106 # used cached flag values for efficiency
5107 my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ 'FLAGS' } || q{} ;
5108 my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ 'FLAGS' } || q{} ;
5109
5110 sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ;
5111
5112 return ;
5113}
5114
5115sub sync_flags_after_copy
5116{
5117 # Activated with option --syncflagsaftercopy
5118 my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $permanentflags2 ) = @_ ;
5119
5120 if ( my @h2_flags = $mysync->{imap2}->flags( $h2_msg ) ) {
5121 my $h2_flags = "@h2_flags" ;
5122 ( $mysync->{ debug } or $debugflags ) and myprint( "Host2: msg $h2_fold/$h2_msg flags before sync flags after copy ( $h2_flags )\n" ) ;
5123 sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ;
5124 }else{
5125 myprint( "Host2: msg $h2_fold/$h2_msg could not get its flags for sync flags after copy\n" ) ;
5126 }
5127 return ;
5128}
5129
5130# Globals
5131# $debug
5132# $debugflags
5133# $permanentflags2
5134
5135
5136sub sync_flags
5137{
5138 my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) = @_ ;
5139
5140 ( $mysync->{ debug } or $debugflags ) and
5141 myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
5142
5143 $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ;
5144
5145 $h2_flags = flagscase( $h2_flags ) ;
5146
5147 ( $mysync->{ debug } or $debugflags ) and
5148 myprint( "Host1: flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ;
5149
5150
5151 # compare flags - set flags if there a difference
5152 my @h1_flags = sort split(q{ }, $h1_flags );
5153 my @h2_flags = sort split(q{ }, $h2_flags );
5154 my $diff = compare_lists( \@h1_flags, \@h2_flags );
5155
5156 $diff and ( $mysync->{ debug } or $debugflags )
5157 and myprint( "Host2: flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ;
5158
5159 # This sets flags exactly. So flags can be removed with this.
5160 # When you remove a \Seen flag on host1 you want it
5161 # to be removed on host2. Just add flags is not what
5162 # we need most of the time, so no + like in "+FLAGS.SILENT".
5163
5164 if ( not $mysync->{dry} and $diff and not $mysync->{imap2}->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) {
5165 my $error_msg = join q{}, "Host2: flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ",
5166 $mysync->{imap2}->LastError || q{}, "\n" ;
5167 errors_incr( $mysync, $error_msg ) ;
5168 }
5169
5170 return ;
5171}
5172
5173
5174
5175sub _filter
5176{
5177 my $mysync = shift ;
5178 my $str = shift or return q{} ;
5179 my $sz = $SIZE_MAX_STR ;
5180 my $len = length $str ;
5181 if ( not $mysync->{ debug } and $len > $sz*2 ) {
5182 my $beg = substr $str, 0, $sz ;
5183 my $end = substr $str, -$sz, $sz ;
5184 $str = $beg . '...' . $end ;
5185 }
5186 $str =~ s/\012?\015$//x ;
5187 return "(len=$len) " . $str ;
5188}
5189
5190
5191
5192sub lost_connection
5193{
5194 my( $mysync, $imap, $error_message ) = @_;
5195 if ( $imap->IsUnconnected( ) ) {
5196 $mysync->{nb_errors}++ ;
5197 my $lcomm = $imap->LastIMAPCommand || q{} ;
5198 my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ;
5199
5200 # if string is long try reduce to a more reasonable size
5201 $lcomm = _filter( $mysync, $lcomm ) ;
5202 $einfo = _filter( $mysync, $einfo ) ;
5203 myprint( "Failure: last command: $lcomm\n") if ( $mysync->{ debug } && $lcomm) ;
5204 myprint( "Failure: lost connection $error_message: ", $einfo, "\n") ;
5205 return( 1 ) ;
5206 }
5207 else{
5208 return( 0 ) ;
5209 }
5210}
5211
5212sub tests_max
5213{
5214 note( 'Entering tests_max()' ) ;
5215
5216 is( 0, max( 0 ), 'max 0 => 0' ) ;
5217 is( 1, max( 1 ), 'max 1 => 1' ) ;
5218 is( $MINUS_ONE, max( $MINUS_ONE ), 'max -1 => -1') ;
5219 is( undef, max( ), 'max no arg => undef' ) ;
5220 is( undef, max( undef ), 'undef => undef' ) ;
5221 is( undef, max( undef, undef ), 'undef, undef => undef' ) ;
5222
5223 is( $NUMBER_100, max( 1, $NUMBER_100 ), 'max 1 100 => 100' ) ;
5224 is( $NUMBER_100, max( $NUMBER_100, 1 ), 'max 100 1 => 100' ) ;
5225 is( $NUMBER_100, max( $NUMBER_100, $NUMBER_42, 1 ), 'max 100 42 1 => 100' ) ;
5226 is( $NUMBER_100, max( $NUMBER_100, '42', 1 ), 'max 100 42 1 => 100' ) ;
5227 is( $NUMBER_100, max( '100', '42', 1 ), 'max 100 42 1 => 100' ) ;
5228 is( $NUMBER_100, max( $NUMBER_100, 'haha', 1 ), 'max 100 haha 1 => 100') ;
5229 is( $NUMBER_100, max( 'bb', $NUMBER_100, 'haha' ), 'max bb 100 haha => 100') ;
5230 is( $MINUS_ONE, max( q{}, $MINUS_ONE, 'haha' ), 'max "" -1 haha => -1') ;
5231 is( $MINUS_ONE, max( q{}, $MINUS_ONE, $MINUS_TWO ), 'max "" -1 -2 => -1') ;
5232 is( $MINUS_ONE, max( 'haha', $MINUS_ONE, $MINUS_TWO ), 'max haha -1 -2 => -1') ;
5233 is( 1, max( $MINUS_ONE, 1 ), 'max -1 1 => 1') ;
5234 is( 1, max( undef, 1 ), 'max undef 1 => 1' ) ;
5235 is( 0, max( undef, 0 ), 'max undef 0 => 0' ) ;
5236 is( 'haha', max( 'haha' ), 'max haha => haha') ;
5237 is( 'bb', max( 'aa', 'bb' ), 'max aa bb => bb') ;
5238 is( 'bb', max( 'bb', 'aa' ), 'max bb aa => bb') ;
5239 is( 'bb', max( 'bb', 'aa', 'bb' ), 'max bb aa bb => bb') ;
5240 note( 'Leaving tests_max()' ) ;
5241 return ;
5242}
5243
5244sub max
5245{
5246 my @list = @_ ;
5247 return( undef ) if ( 0 == scalar @list ) ;
5248
5249 my( @numbers, @notnumbers ) ;
5250 foreach my $item ( @list )
5251 {
5252 if ( is_number( $item ) )
5253 {
5254 push @numbers, $item ;
5255 }
5256 elsif ( defined $item )
5257 {
5258 push @notnumbers, $item ;
5259 }
5260 }
5261
5262 my @sorted ;
5263
5264 if ( @numbers )
5265 {
5266 @sorted = sort { $a <=> $b } @numbers ;
5267 }
5268 elsif ( @notnumbers )
5269 {
5270 @sorted = sort { $a cmp $b } @notnumbers ;
5271 }
5272 else
5273 {
5274 return ;
5275 }
5276
5277 return( pop @sorted ) ;
5278}
5279
5280sub tests_is_number
5281{
5282 note( 'Entering tests_is_number()' ) ;
5283
5284 is( undef, is_number( ), 'is_number: no args => undef ' ) ;
5285 is( undef, is_number( undef ), 'is_number: undef => undef ' ) ;
5286 ok( is_number( 1 ), 'is_number: 1 => 1' ) ;
5287 ok( is_number( 1.1 ), 'is_number: 1.1 => 1' ) ;
5288 ok( is_number( 0 ), 'is_number: 0 => 1' ) ;
5289 ok( is_number( -1 ), 'is_number: -1 => 1' ) ;
5290 ok( ! is_number( 1.1.1 ), 'is_number: 1.1.1 => no' ) ;
5291 ok( ! is_number( q{} ), 'is_number: q{} => no' ) ;
5292 ok( ! is_number( 'haha' ), 'is_number: haha => no' ) ;
5293 ok( ! is_number( '0haha' ), 'is_number: 0haha => no' ) ;
5294 ok( ! is_number( '2haha' ), 'is_number: 2haha => no' ) ;
5295 ok( ! is_number( 'haha2' ), 'is_number: haha2 => no' ) ;
5296
5297 note( 'Leaving tests_is_number()' ) ;
5298 return ;
5299}
5300
5301
5302
5303sub is_number
5304{
5305 my $item = shift ;
5306
5307 if ( ! defined $item ) { return ; }
5308
5309 if ( $item =~ /\A$RE{num}{real}\Z/ ) {
5310 return 1 ;
5311 }
5312 return ;
5313}
5314
5315sub tests_min
5316{
5317 note( 'Entering tests_min()' ) ;
5318
5319 is( 0, min( 0 ), 'min 0 => 0' ) ;
5320 is( 1, min( 1 ), 'min 1 => 1' ) ;
5321 is( $MINUS_ONE, min( $MINUS_ONE ), 'min -1 => -1' ) ;
5322 is( undef, min( ), 'min no arg => undef' ) ;
5323 is( 1, min( 1, $NUMBER_100 ), 'min 1 100 => 1' ) ;
5324 is( 1, min( $NUMBER_100, 1 ), 'min 100 1 => 1' ) ;
5325 is( 1, min( $NUMBER_100, $NUMBER_42, 1 ), 'min 100 42 1 => 1' ) ;
5326 is( 1, min( $NUMBER_100, '42', 1 ), 'min 100 42 1 => 1' ) ;
5327 is( 1, min( '100', '42', 1 ), 'min 100 42 1 => 1' ) ;
5328 is( 1, min( $NUMBER_100, 'haha', 1 ), 'min 100 haha 1 => 1') ;
5329 is( $MINUS_ONE, min( $MINUS_ONE, 1 ), 'min -1 1 => -1') ;
5330
5331 is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ;
5332 is( 0, min( undef, 0 ), 'min undef 0 => 0' ) ;
5333 is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ;
5334 is( 0, min( undef, 2, 0, 1 ), 'min undef, 2, 0, 1 => 0' ) ;
5335
5336 is( 'haha', min( 'haha' ), 'min haha => haha') ;
5337 is( 'aa', min( 'aa', 'bb' ), 'min aa bb => aa') ;
5338 is( 'aa', min( 'bb', 'aa' ), 'min bb aa bb => aa') ;
5339 is( 'aa', min( 'bb', 'aa', 'bb' ), 'min bb aa bb => aa') ;
5340
5341 note( 'Leaving tests_min()' ) ;
5342 return ;
5343}
5344
5345
5346sub min
5347{
5348 my @list = @_ ;
5349 return( undef ) if ( 0 == scalar @list ) ;
5350
5351 my( @numbers, @notnumbers ) ;
5352 foreach my $item ( @list ) {
5353 if ( is_number( $item ) ) {
5354 push @numbers, $item ;
5355 }else{
5356 push @notnumbers, $item ;
5357 }
5358 }
5359
5360 my @sorted ;
5361 if ( @numbers ) {
5362 @sorted = sort { $a <=> $b } @numbers ;
5363 }elsif( @notnumbers ) {
5364 @sorted = sort { $a cmp $b } @notnumbers ;
5365 }else{
5366 return ;
5367 }
5368
5369 return( shift @sorted ) ;
5370}
5371
5372
5373sub check_lib_version
5374{
5375 my $mysync = shift ;
5376 $mysync->{ debug } and myprint( "IMAPClient $Mail::IMAPClient::VERSION\n" ) ;
5377 if ( '2.2.9' eq $Mail::IMAPClient::VERSION ) {
5378 myprint( "imapsync no longer supports Mail::IMAPClient 2.2.9, upgrade it\n" ) ;
5379 return 0 ;
5380 }
5381 else{
5382 # 3.x.x is no longer buggy with imapsync.
5383 # 3.30 or currently superior is imposed in the Perl "use Mail::IMAPClient line".
5384 return 1 ;
5385 }
5386 return ;
5387}
5388
5389sub module_version_str
5390{
5391 my( $module_name, $module_version ) = @_ ;
5392 my $str = mysprintf( "%-20s %s\n", $module_name, $module_version ) ;
5393 return( $str ) ;
5394}
5395
5396sub modulesversion
5397{
5398
5399 my @list_version;
5400
5401 my %modulesversion = (
5402 'Authen::NTLM' => sub { $Authen::NTLM::VERSION },
5403 'CGI' => sub { $CGI::VERSION },
5404 'Compress::Zlib' => sub { $Compress::Zlib::VERSION },
5405 'Crypt::OpenSSL::RSA' => sub { $Crypt::OpenSSL::RSA::VERSION },
5406 'Data::Uniqid' => sub { $Data::Uniqid::VERSION },
5407 'Digest::HMAC_MD5' => sub { $Digest::HMAC_MD5::VERSION },
5408 'Digest::HMAC_SHA1' => sub { $Digest::HMAC_SHA1::VERSION },
5409 'Digest::MD5' => sub { $Digest::MD5::VERSION },
5410 'Encode' => sub { $Encode::VERSION },
5411 'Encode::IMAPUTF7' => sub { $Encode::IMAPUTF7::VERSION },
5412 'File::Copy::Recursive' => sub { $File::Copy::Recursive::VERSION },
5413 'File::Spec' => sub { $File::Spec::VERSION },
5414 'Getopt::Long' => sub { $Getopt::Long::VERSION },
5415 'HTML::Entities' => sub { $HTML::Entities::VERSION },
5416 'IO::Socket' => sub { $IO::Socket::VERSION },
5417 'IO::Socket::INET' => sub { $IO::Socket::INET::VERSION },
5418 'IO::Socket::INET6' => sub { $IO::Socket::INET6::VERSION },
5419 'IO::Socket::IP' => sub { $IO::Socket::IP::VERSION },
5420 'IO::Socket::SSL' => sub { $IO::Socket::SSL::VERSION },
5421 'IO::Tee' => sub { $IO::Tee::VERSION },
5422 'JSON' => sub { $JSON::VERSION },
5423 'JSON::WebToken' => sub { $JSON::WebToken::VERSION },
5424 'LWP' => sub { $LWP::VERSION },
5425 'Mail::IMAPClient' => sub { $Mail::IMAPClient::VERSION },
5426 'MIME::Base64' => sub { $MIME::Base64::VERSION },
5427 'Net::Ping' => sub { $Net::Ping::VERSION },
5428 'Net::SSLeay' => sub { $Net::SSLeay::VERSION },
5429 'Term::ReadKey' => sub { $Term::ReadKey::VERSION },
5430 'Test::MockObject' => sub { $Test::MockObject::VERSION },
5431 'Time::HiRes' => sub { $Time::HiRes::VERSION },
5432 'Unicode::String' => sub { $Unicode::String::VERSION },
5433 'URI::Escape' => sub { $URI::Escape::VERSION },
5434 #'Lalala' => sub { $Lalala::VERSION },
5435 ) ;
5436
5437 foreach my $module_name ( sort keys %modulesversion ) {
5438 # trick from http://www.perlmonks.org/?node_id=152122
5439 my $file_name = $module_name . '.pm' ;
5440 $file_name =~s,::,/,xmgs; # Foo::Bar::Baz => Foo/Bar/Baz.pm
5441 my $v ;
5442 eval {
5443 require $file_name ;
5444 $v = defined $modulesversion{ $module_name } ? $modulesversion{ $module_name }->() : q{?} ;
5445 } or $v = q{Not installed} ;
5446
5447 push @list_version, module_version_str( $module_name, $v ) ;
5448 }
5449 return( @list_version ) ;
5450}
5451
5452
5453sub tests_command_line_nopassword
5454{
5455 note( 'Entering tests_command_line_nopassword()' ) ;
5456
5457 ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' );
5458 my $mysync = {} ;
5459 ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla' ), 'command_line_nopassword --blabla' );
5460 #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
5461 ok( '--password1 MASKED' eq command_line_nopassword( $mysync, qw{ --password1 secret1}), 'command_line_nopassword --password1' );
5462 ok( '--blabla --password1 MASKED --blibli'
5463 eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' );
5464 $mysync->{showpasswords} = 1 ;
5465 ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' );
5466 ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla'), 'command_line_nopassword --blabla' );
5467 #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ;
5468 ok( '--password1 secret1' eq command_line_nopassword( $mysync, qw{ --password1 secret1} ), 'command_line_nopassword --password1' );
5469 ok( '--blabla --password1 secret1 --blibli'
5470 eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' );
5471
5472 note( 'Leaving tests_command_line_nopassword()' ) ;
5473 return ;
5474}
5475
5476# Construct a command line copy with passwords replaced by MASKED.
5477sub command_line_nopassword
5478{
5479 my $mysync = shift @ARG ;
5480 my @argv = @ARG ;
5481 my @argv_nopassword ;
5482
5483 if ( $mysync->{ cmdcgi } ) {
5484 @argv_nopassword = mask_password_value( @{ $mysync->{ cmdcgi } } ) ;
5485 return( "@argv_nopassword" ) ;
5486 }
5487
5488 if ( $mysync->{showpasswords} )
5489 {
5490 return( "@argv" ) ;
5491 }
5492
5493 @argv_nopassword = mask_password_value( @argv ) ;
5494 return("@argv_nopassword") ;
5495}
5496
5497sub mask_password_value
5498{
5499 my @argv = @ARG ;
5500 my @argv_nopassword ;
5501 while ( @argv ) {
5502 my $arg = shift @argv ; # option name or value
5503 if ( $arg =~ m/-password[12]/x ) {
5504 shift @argv ; # password value
5505 push @argv_nopassword, $arg, 'MASKED' ; # option name and fake value
5506 }else{
5507 push @argv_nopassword, $arg ; # same option or value
5508 }
5509 }
5510 return @argv_nopassword ;
5511}
5512
5513
5514sub tests_get_stdin_masked
5515{
5516 note( 'Entering tests_get_stdin_masked()' ) ;
5517
5518 is( q{}, get_stdin_masked( ), 'get_stdin_masked: no args' ) ;
5519 is( q{}, get_stdin_masked( 'Please ENTER: ' ), 'get_stdin_masked: ENTER' ) ;
5520
5521 note( 'Leaving tests_get_stdin_masked()' ) ;
5522 return ;
5523}
5524
5525#######################################################
5526# The issue is that prompt() does not prompt the prompt
5527# when the program is used like
5528# { sleep 2 ; echo blablabla ; } | ./imapsync ...--host1 lo --user1 tata --host2 lo --user2 titi
5529
5530# use IO::Prompter ;
5531sub get_stdin_masked
5532{
5533 my $prompt = shift || 'Say something: ' ;
5534 local @ARGV = () ;
5535 my $input = prompt(
5536 -prompt => $prompt,
5537 -echo => '*',
5538 ) ;
5539 #myprint( "You said: $input\n" ) ;
5540 return $input ;
5541}
5542
5543sub ask_for_password_new
5544{
5545 my $prompt = shift ;
5546 my $password = get_stdin_masked( $prompt ) ;
5547 return $password ;
5548}
5549#########################################################
5550
5551
5552sub ask_for_password
5553{
5554 my $prompt = shift ;
5555 myprint( $prompt ) ;
5556 Term::ReadKey::ReadMode( 2 ) ;
5557 ## no critic (InputOutput::ProhibitExplicitStdin)
5558 my $password = <STDIN> ;
5559 chomp $password ;
5560 myprint( "\nGot it\n" ) ;
5561 Term::ReadKey::ReadMode( 0 ) ;
5562 return $password ;
5563}
5564
5565# Have to refactor get_password1() get_password2()
5566# to have only get_password() and two calls
5567sub get_password1
5568{
5569
5570 my $mysync = shift ;
5571
5572 $mysync->{password1}
5573 || $mysync->{ passfile1 }
5574 || 'PREAUTH' eq $authmech1
5575 || 'EXTERNAL' eq $authmech1
5576 || $ENV{IMAPSYNC_PASSWORD1}
5577 || do
5578 {
5579 myprint( << 'FIN_PASSFILE' ) ;
5580
5581If you are afraid of giving password on the command line arguments, you can put the
5582password of user1 in a file named file1 and use "--passfile1 file1" instead of typing it.
5583Then give this file restrictive permissions with the command "chmod 600 file1".
5584An other solution is to set the environment variable IMAPSYNC_PASSWORD1
5585FIN_PASSFILE
5586 my $user = $authuser1 || $mysync->{user1} ;
5587 my $host = $mysync->{host1} ;
5588 my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ;
5589 $mysync->{password1} = ask_for_password( $prompt ) ;
5590 } ;
5591
5592 if ( defined $mysync->{ passfile1 } ) {
5593 if ( ! -e -r $mysync->{ passfile1 } ) {
5594 myprint( "Failure: file from parameter --passfile1 $mysync->{ passfile1 } does not exist or is not readable\n" ) ;
5595 $mysync->{nb_errors}++ ;
5596 exit_clean( $mysync, $EX_NOINPUT ) ;
5597 }
5598 # passfile1 readable
5599 $mysync->{password1} = firstline ( $mysync->{ passfile1 } ) ;
5600 return ;
5601 }
5602 if ( $ENV{IMAPSYNC_PASSWORD1} ) {
5603 $mysync->{password1} = $ENV{IMAPSYNC_PASSWORD1} ;
5604 return ;
5605 }
5606 return ;
5607}
5608
5609sub get_password2
5610{
5611
5612 my $mysync = shift ;
5613
5614 $mysync->{password2}
5615 || $mysync->{ passfile2 }
5616 || 'PREAUTH' eq $authmech2
5617 || 'EXTERNAL' eq $authmech2
5618 || $ENV{IMAPSYNC_PASSWORD2}
5619 || do
5620 {
5621 myprint( << 'FIN_PASSFILE' ) ;
5622
5623If you are afraid of giving password on the command line arguments, you can put the
5624password of user2 in a file named file2 and use "--passfile2 file2" instead of typing it.
5625Then give this file restrictive permissions with the command "chmod 600 file2".
5626An other solution is to set the environment variable IMAPSYNC_PASSWORD2
5627FIN_PASSFILE
5628 my $user = $authuser2 || $mysync->{user2} ;
5629 my $host = $mysync->{host2} ;
5630 my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ;
5631 $mysync->{password2} = ask_for_password( $prompt ) ;
5632 } ;
5633
5634
5635 if ( defined $mysync->{ passfile2 } ) {
5636 if ( ! -e -r $mysync->{ passfile2 } ) {
5637 myprint( "Failure: file from parameter --passfile2 $mysync->{ passfile2 } does not exist or is not readable\n" ) ;
5638 $mysync->{nb_errors}++ ;
5639 exit_clean( $mysync, $EX_NOINPUT ) ;
5640 }
5641 # passfile2 readable
5642 $mysync->{password2} = firstline ( $mysync->{ passfile2 } ) ;
5643 return ;
5644 }
5645 if ( $ENV{IMAPSYNC_PASSWORD2} ) {
5646 $mysync->{password2} = $ENV{IMAPSYNC_PASSWORD2} ;
5647 return ;
5648 }
5649 return ;
5650}
5651
5652
5653
5654
5655sub remove_tmp_files
5656{
5657 my $mysync = shift or return ;
5658 $mysync->{pidfile} or return ;
5659 if ( -e $mysync->{pidfile} ) {
5660 unlink $mysync->{pidfile} ;
5661 }
5662 return ;
5663}
5664
5665sub cleanup_before_exit
5666{
5667 my $mysync = shift ;
5668 remove_tmp_files( $mysync ) ;
5669 if ( $mysync->{imap1} and $mysync->{imap1}->IsConnected() )
5670 {
5671 myprint( "Disconnecting from host1 $mysync->{ host1 } user1 $mysync->{ user1 }\n" ) ;
5672 $mysync->{imap1}->logout( ) ;
5673 }
5674 if ( $mysync->{imap2} and $mysync->{imap2}->IsConnected() )
5675 {
5676 myprint( "Disconnecting from host2 $mysync->{ host2 } user2 $mysync->{ user2 }\n" ) ;
5677 $mysync->{imap2}->logout( ) ;
5678 }
5679 if ( $mysync->{log} ) {
5680 myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ;
5681 }
5682 if ( $mysync->{log} and $mysync->{logfile_handle} ) {
5683 #myprint( "Closing $mysync->{ logfile }\n" ) ;
5684 close $mysync->{logfile_handle} ;
5685 }
5686 return ;
5687}
5688
5689
5690
5691sub exit_clean
5692{
5693 my $mysync = shift @ARG ;
5694 my $status = shift @ARG ;
5695 my @messages = @ARG ;
5696 if ( @messages )
5697 {
5698 myprint( @messages ) ;
5699 }
5700 myprint( "Exiting with return value $status ($EXIT_TXT{$status}) $mysync->{nb_errors}/$mysync->{errorsmax} nb_errors/max_errors\n" ) ;
5701 cleanup_before_exit( $mysync ) ;
5702
5703 exit $status ;
5704}
5705
5706sub missing_option
5707{
5708 my $mysync = shift ;
5709 my $option = shift ;
5710 $mysync->{nb_errors}++ ;
5711 exit_clean( $mysync, $EX_USAGE, "$option option is mandatory, for help run $PROGRAM_NAME --help\n" ) ;
5712 return ;
5713}
5714
5715
5716sub catch_ignore
5717{
5718 my $mysync = shift ;
5719 my $signame = shift ;
5720
5721 my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ;
5722 myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ),
5723 "). Received $sigcounter $signame signals so far. Thanks!\n" ) ;
5724 stats( $mysync ) ;
5725 return ;
5726}
5727
5728
5729sub catch_exit
5730{
5731 my $mysync = shift ;
5732 my $signame = shift || q{} ;
5733 if ( $signame ) {
5734 myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ),
5735 "). Asked to terminate\n" ) ;
5736 if ( $mysync->{stats} ) {
5737 myprint( "Here are the final stats of this sync not completely finished so far\n" ) ;
5738 stats( $mysync ) ;
5739 myprint( "Ended by a signal $signame (my PID is $PROCESS_ID my PPID is ",
5740 getppid( ), "). I am asked to terminate immediately.\n" ) ;
5741 myprint( "You should resynchronize those accounts by running a sync again,\n",
5742 "since some messages and entire folders might still be missing on host2.\n" ) ;
5743 }
5744 ## no critic (RequireLocalizedPunctuationVars)
5745 $SIG{ $signame } = 'DEFAULT'; # restore default action
5746 # kill myself with $signame
5747 # https://www.cons.org/cracauer/sigint.html
5748 myprint( "Killing myself with signal $signame\n" ) ;
5749 cleanup_before_exit( $mysync ) ;
5750 kill( $signame, $PROCESS_ID ) ;
5751 sleep 1 ;
5752 $mysync->{nb_errors}++ ;
5753 exit_clean( $mysync, $EXIT_BY_SIGNAL,
5754 "Still there after killing myself with signal $signame...\n"
5755 ) ;
5756 }
5757 else
5758 {
5759 $mysync->{nb_errors}++ ;
5760 exit_clean( $mysync, $EXIT_BY_SIGNAL, "Exiting in catch_exit with no signal...\n" ) ;
5761 }
5762 return ;
5763}
5764
5765
5766sub catch_print
5767{
5768 my $mysync = shift ;
5769 my $signame = shift ;
5770
5771 my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ;
5772 myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ),
5773 "). Received $sigcounter $signame signals so far. Thanks!\n" ) ;
5774 return ;
5775}
5776
5777sub here_twice
5778{
5779 my $mysync = shift ;
5780 my $now = time ;
5781 my $previous = $mysync->{lastcatch} || 0 ;
5782 $mysync->{lastcatch} = $now ;
5783
5784 if ( $INTERVAL_TO_EXIT >= $now - $previous ) {
5785 return $TRUE ;
5786 }else{
5787 return $FALSE ;
5788 }
5789}
5790
5791
5792sub catch_reconnect
5793{
5794 my $mysync = shift ;
5795 my $signame = shift ;
5796 if ( here_twice( $mysync ) ) {
5797 myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ;
5798 catch_exit( $mysync, $signame ) ;
5799 }else{
5800 myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), ")\n",
5801 "Hit 2 ctr-c within 2 seconds to exit the program\n",
5802 "Hit only 1 ctr-c to reconnect to both imap servers\n",
5803 ) ;
5804 myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ;
5805
5806 if ( ! defined $mysync->{imap1} ) { return ; }
5807 if ( ! defined $mysync->{imap2} ) { return ; }
5808
5809 myprint( "Info: reconnecting to host1 imap server $mysync->{host1}\n" ) ;
5810 $mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ;
5811 $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
5812 if ( $mysync->{imap1}->reconnect( ) )
5813 {
5814 myprint( "Info: reconnected to host1 imap server $mysync->{host1}\n" ) ;
5815 }
5816 else
5817 {
5818 $mysync->{nb_errors}++ ;
5819 exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ;
5820 }
5821 myprint( "Info: reconnecting to host2 imap server\n" ) ;
5822 $mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ;
5823 $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
5824 if ( $mysync->{imap2}->reconnect( ) )
5825 {
5826 myprint( "Info: reconnected to host2 imap server $mysync->{host2}\n" ) ;
5827 }
5828 else
5829 {
5830 $mysync->{nb_errors}++ ;
5831 exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ;
5832 }
5833 myprint( "Info: reconnected to both imap servers\n" ) ;
5834 }
5835 return ;
5836}
5837
5838sub install_signals
5839{
5840 my $mysync = shift ;
5841
5842 if ( under_docker_context( $mysync ) )
5843 {
5844 # output( $mysync, "Under docker context so leaving signals as they are\n" ) ;
5845 output( $mysync, "Under docker context so installing only signals to exit\n" ) ;
5846 @{ $mysync->{ sigexit } } = ( defined( $mysync->{ sigexit } ) ) ? @{ $mysync->{ sigexit } } : ( 'INT', 'QUIT', 'TERM' ) ;
5847 sig_install( $mysync, 'catch_exit', @{ $mysync->{ sigexit } } ) ;
5848 }
5849 else
5850 {
5851 # Unix signals
5852 @{ $mysync->{ sigexit } } = ( defined( $mysync->{ sigexit } ) ) ? @{ $mysync->{ sigexit } } : ( 'QUIT', 'TERM' ) ;
5853 @{ $mysync->{ sigreconnect } } = ( defined( $mysync->{ sigreconnect } ) ) ? @{ $mysync->{ sigreconnect } } : ( 'INT' ) ;
5854 @{ $mysync->{ sigprint } } = ( defined( $mysync->{ sigprint } ) ) ? @{ $mysync->{ sigprint } } : ( 'HUP' ) ;
5855 @{ $mysync->{ sigignore } } = ( defined( $mysync->{ sigignore } ) ) ? @{ $mysync->{ sigignore } } : ( ) ;
5856
5857 #local %SIG = %SIG ;
5858 sig_install( $mysync, 'catch_exit', @{ $mysync->{ sigexit } } ) ;
5859 sig_install( $mysync, 'catch_reconnect', @{ $mysync->{ sigreconnect } } ) ;
5860 sig_install( $mysync, 'catch_print', @{ $mysync->{ sigprint } } ) ;
5861 # --sigignore can override sigexit, sigreconnect and sigprint (for the same signals only)
5862 sig_install( $mysync, 'catch_ignore', @{ $mysync->{ sigignore } } ) ;
5863
5864 sig_install_toggle_sleep( $mysync ) ;
5865 }
5866
5867 return ;
5868}
5869
5870
5871
5872sub tests_reconnect_12_if_needed
5873{
5874 note( 'Entering tests_reconnect_12_if_needed()' ) ;
5875
5876 my $mysync ;
5877
5878 $mysync->{imap1} = Mail::IMAPClient->new( ) ;
5879 $mysync->{imap2} = Mail::IMAPClient->new( ) ;
5880 $mysync->{imap1}->Server( 'test1.lamiral.info' ) ;
5881 $mysync->{imap2}->Server( 'test2.lamiral.info' ) ;
5882 is( 2, reconnect_12_if_needed( $mysync ), 'reconnect_12_if_needed: test1&test2 .lamiral.info => 1' ) ;
5883 is( 1, $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test1.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ;
5884 is( 1, $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test2.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ;
5885
5886 note( 'Leaving tests_reconnect_12_if_needed()' ) ;
5887 return ;
5888}
5889
5890sub reconnect_12_if_needed
5891{
5892 my $mysync = shift ;
5893 #return 2 ;
5894 if ( ! reconnect_if_needed( $mysync->{imap1} ) ) {
5895 return ;
5896 }
5897 if ( ! reconnect_if_needed( $mysync->{imap2} ) ) {
5898 return ;
5899 }
5900 # both were good
5901 return 2 ;
5902}
5903
5904
5905sub tests_reconnect_if_needed
5906{
5907 note( 'Entering tests_reconnect_if_needed()' ) ;
5908
5909
5910 my $myimap ;
5911
5912 is( undef, reconnect_if_needed( ), 'reconnect_if_needed: no args => undef' ) ;
5913 is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: undef arg => undef' ) ;
5914
5915 $myimap = Mail::IMAPClient->new( ) ;
5916 $myimap->Debug( 1 ) ;
5917 is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: empty new Mail::IMAPClient => undef' ) ;
5918 $myimap->Server( 'test.lamiral.info' ) ;
5919 is( 1, reconnect_if_needed( $myimap ), 'reconnect_if_needed: test.lamiral.info => 1' ) ;
5920 is( 1, $myimap->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_if_needed: test.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ;
5921
5922 note( 'Leaving tests_reconnect_if_needed()' ) ;
5923 return ;
5924}
5925
5926sub reconnect_if_needed
5927{
5928 # return undef upon failure.
5929 # return 1 upon connection success, with or without reconnection.
5930
5931 my $imap = shift ;
5932
5933 if ( ! defined $imap ) { return ; }
5934 if ( ! $imap->Server( ) ) { return ; }
5935
5936 if ( $imap->IsUnconnected( ) ) {
5937 $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
5938 if ( $imap->reconnect( ) ) {
5939 return 1 ;
5940 }
5941 }else{
5942 return 1 ;
5943 }
5944
5945 # A last forced one
5946 $imap->State( Mail::IMAPClient::Unconnected ) ;
5947 $imap->reconnect( ) ;
5948 $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ;
5949 if ( $imap->noop ) {
5950 # NOOP is ok
5951 return 1 ;
5952 }
5953
5954 return ;
5955}
5956
5957
5958
5959# $sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ;
5960# imap_id_stuff( $sync ) ;
5961
5962sub justconnect
5963{
5964 my $mysync = shift ;
5965 my $justconnect1 = justconnect1( $sync ) ;
5966 my $justconnect2 = justconnect2( $sync ) ;
5967 return "$justconnect1 $justconnect2";
5968}
5969
5970sub justconnect1
5971{
5972 my $mysync = shift ;
5973 if ( $mysync->{host1} )
5974 {
5975 myprint( "Host1: Will just connect to $mysync->{host1} without login\n" ) ;
5976 $mysync->{imap1} = connect_imap(
5977 $mysync->{host1}, $mysync->{port1}, $debugimap1,
5978 $mysync->{ssl1}, $mysync->{tls1}, 'Host1',
5979 $mysync->{h1}->{timeout}, $mysync->{h1} ) ;
5980 imap_id( $mysync, $mysync->{imap1}, 'Host1' ) ;
5981 $mysync->{imap1}->logout( ) ;
5982 return $mysync->{host1} ;
5983 }
5984
5985 return q{} ;
5986}
5987
5988sub justconnect2
5989{
5990 my $mysync = shift ;
5991 if ( $mysync->{host2} )
5992 {
5993 myprint( "Host2: Will just connect to $mysync->{host2} without login\n" ) ;
5994 $mysync->{imap2} = connect_imap(
5995 $mysync->{host2}, $mysync->{port2}, $debugimap2,
5996 $mysync->{ssl2}, $mysync->{tls2}, 'Host2',
5997 $mysync->{h2}->{timeout}, $mysync->{h2} ) ;
5998 imap_id( $mysync, $mysync->{imap2}, 'Host2' ) ;
5999 $mysync->{imap2}->logout( ) ;
6000 return $mysync->{host2} ;
6001 }
6002
6003 return q{} ;
6004}
6005
6006sub skip_macosx
6007{
6008 #return ;
6009 return( 'macosx.polarhome.com' eq hostname() ) ;
6010}
6011
6012sub tests_mailimapclient_connect
6013{
6014 note( 'Entering tests_mailimapclient_connect()' ) ;
6015
6016 my $imap ;
6017 # ipv4
6018 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4: new' ) ;
6019 is( 'Mail::IMAPClient', ref( $imap ), 'mailimapclient_connect ipv4: ref is Mail::IMAPClient' ) ;
6020
6021 # Mail::IMAPClient 3.40 die on this... So we skip it, thanks to "mature" IO::Socket::IP
6022 # Mail::IMAPClient 3.42 is ok so this test is back.
6023 is( undef, $imap->connect( ), 'mailimapclient_connect ipv4: connect with no server => failure' ) ;
6024
6025
6026 is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4: setting Server(test.lamiral.info)' ) ;
6027 is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4: setting Debug( 1 )' ) ;
6028 is( 143, $imap->Port( 143 ), 'mailimapclient_connect ipv4: setting Port( 143 )' ) ;
6029 is( 3, $imap->Timeout( 3 ), 'mailimapclient_connect ipv4: setting Timout( 3 )' ) ;
6030 like( ref( $imap->connect( ) ), qr/IO::Socket::INET|IO::Socket::IP/, 'mailimapclient_connect ipv4: connect to test.lamiral.info' ) ;
6031 like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4: logout' ) ;
6032 is( undef, undef $imap, 'mailimapclient_connect ipv4: free variable' ) ;
6033
6034 # ipv4 + ssl
6035 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4 + ssl: new' ) ;
6036 is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4 + ssl: setting Server(test.lamiral.info)' ) ;
6037 is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ;
6038 ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv4 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ;
6039 is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv4 + ssl: setting Port( 993 )' ) ;
6040 like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv4 + ssl: connect to test.lamiral.info' ) ;
6041 like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4 + ssl: logout in ssl does not cause failure' ) ;
6042 is( undef, undef $imap, 'mailimapclient_connect ipv4 + ssl: free variable' ) ;
6043
6044 # ipv6 + ssl
6045 # Fails often on ks2ipv6.lamiral.info
6046
6047 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv6 + ssl: new' ) ;
6048 is( 'petiteipv6.lamiral.info', $imap->Server( 'petiteipv6.lamiral.info' ), 'mailimapclient_connect ipv6 + ssl: setting Server petiteipv6.lamiral.info' ) ;
6049 is( 3, $imap->Timeout( 3 ), 'mailimapclient_connect ipv4: setting Timout( 3 )' ) ;
6050 ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv6 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ;
6051 is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv6 + ssl: setting Port( 993 )' ) ;
6052 SKIP: {
6053 if (
6054 'CUILLERE' eq hostname()
6055 or
6056 skip_macosx()
6057 or
6058 -e '/.dockerenv'
6059 or
6060 'pcHPDV7-HP' eq hostname()
6061 )
6062 {
6063 skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 4 ) ;
6064 }
6065
6066 is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ;
6067
6068 # It sounds stupid but it avoids failures on the next test about $imap->connect
6069 is( '2a01:e34:ecde:70d0:223:54ff:fec2:36d7', resolv( 'petiteipv6.lamiral.info' ), 'resolv: petiteipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ;
6070
6071 like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv6 + ssl: connect to petiteipv6.lamiral.info' ) ;
6072 # This one is ok on petite, not on ks2, do not know why, so commented.
6073 like( ref( $imap->logout( ) ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv6 + ssl: logout in ssl is ok on petiteipv6.lamiral.info' ) ;
6074 }
6075
6076 is( undef, undef $imap, 'mailimapclient_connect ipv6 + ssl: free variable' ) ;
6077
6078
6079 note( 'Leaving tests_mailimapclient_connect()' ) ;
6080 return ;
6081}
6082
6083
6084sub tests_mailimapclient_connect_bug
6085{
6086 note( 'Entering tests_mailimapclient_connect_bug()' ) ;
6087
6088 my $imap ;
6089
6090 # ipv6
6091 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect_bug ipv6: new' ) ;
6092 is( 'ks2ipv6.lamiral.info', $imap->Server( 'ks2ipv6.lamiral.info' ), 'mailimapclient_connect_bug ipv6: setting Server(ks2ipv6.lamiral.info)' ) ;
6093 is( 143, $imap->Port( 143 ), 'mailimapclient_connect_bug ipv6: setting Port( 993 )' ) ;
6094
6095 SKIP: {
6096 if (
6097 'CUILLERE' eq hostname()
6098 or
6099 skip_macosx()
6100 or
6101 -e '/.dockerenv'
6102 or
6103 'pcHPDV7-HP' eq hostname()
6104 )
6105 {
6106 skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 1 ) ;
6107 }
6108 like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'mailimapclient_connect_bug ipv6: connect to ks2ipv6.lamiral.info' )
6109 or diag( 'mailimapclient_connect_bug ipv6: ', $imap->LastError( ), $!, ) ;
6110 }
6111 #is( $imap->logout( ), undef, 'mailimapclient_connect_bug ipv6: logout in ssl causes failure' ) ;
6112 is( undef, undef $imap, 'mailimapclient_connect_bug ipv6: free variable' ) ;
6113
6114 note( 'Leaving tests_mailimapclient_connect_bug()' ) ;
6115 return ;
6116}
6117
6118
6119
6120sub tests_connect_socket
6121{
6122 note( 'Entering tests_connect_socket()' ) ;
6123
6124 is( undef, connect_socket( ), 'connect_socket: no args' ) ;
6125
6126 my $socket ;
6127 my $imap ;
6128 SKIP: {
6129 if (
6130 'CUILLERE' eq hostname()
6131 or
6132 skip_macosx()
6133 or
6134 -e '/.dockerenv'
6135 or
6136 'pcHPDV7-HP' eq hostname()
6137 )
6138 {
6139 skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 2 ) ;
6140 }
6141
6142 $socket = IO::Socket::INET6->new(
6143 PeerAddr => 'ks2ipv6.lamiral.info',
6144 PeerPort => 143,
6145 ) ;
6146
6147
6148 ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 143 IO::Socket::INET6' ) ;
6149 #$imap->Debug( 1 ) ;
6150 # myprint( $imap->capability( ) ) ;
6151 if ( $imap ) {
6152 $imap->logout( ) ;
6153 }
6154
6155 $IO::Socket::SSL::DEBUG = 4 ;
6156 $socket = IO::Socket::SSL->new(
6157 PeerHost => 'ks2ipv6.lamiral.info',
6158 PeerPort => 993,
6159 SSL_verify_mode => SSL_VERIFY_NONE,
6160 SSL_cipher_list => 'DEFAULT:!DH',
6161 ) ;
6162 # myprint( $socket ) ;
6163 ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 993 IO::Socket::SSL' ) ;
6164 #$imap->Debug( 1 ) ;
6165 # myprint( $imap->capability( ) ) ;
6166 # $socket->close( ) ;
6167 if ( $imap ) {
6168 $socket->close( ) ;
6169 }
6170 #$socket->close(SSL_no_shutdown => 1) ;
6171 #$imap->logout( ) ;
6172 #myprint( "\n" ) ;
6173 #$imap->logout( ) ;
6174 }
6175 note( 'Leaving tests_connect_socket()' ) ;
6176 return ;
6177}
6178
6179sub connect_socket
6180{
6181 my( $socket ) = @ARG ;
6182
6183 if ( ! defined $socket ) { return ; }
6184
6185 my $host = $socket->peerhost( ) ;
6186 my $port = $socket->peerport( ) ;
6187 #print "socket->peerhost: ", $socket->peerhost( ), "\n" ;
6188 #print "socket->peerport: ", $socket->peerport( ), "\n" ;
6189 my $imap = Mail::IMAPClient->new( ) ;
6190 $imap->Socket( $socket ) ;
6191 my $banner = $imap->Results()->[0] ;
6192 #myprint( "banner: $banner" ) ;
6193 return $imap ;
6194}
6195
6196
6197sub tests_probe_imapssl
6198{
6199 note( 'Entering tests_probe_imapssl()' ) ;
6200
6201 is( undef, probe_imapssl( ), 'probe_imapssl: no args => undef' ) ;
6202 is( undef, probe_imapssl( 'unknown' ), 'probe_imapssl: unknown => undef' ) ;
6203
6204 note( "hostname is: ", hostname() ) ;
6205 SKIP: {
6206 if (
6207 'CUILLERE' eq hostname()
6208 or
6209 skip_macosx()
6210 or
6211 -e '/.dockerenv'
6212 or
6213 'pcHPDV7-HP' eq hostname()
6214 )
6215 {
6216 skip( 'Tests avoided on CUILLERE or pcHPDV7-HP or Mac or docker: cannot do ipv6', 0 ) ;
6217 }
6218 # fed up with this one
6219 #like( probe_imapssl( 'ks2ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks2ipv6.lamiral.info matches "* OK"' ) ;
6220 } ;
6221
6222
6223 # It sounds stupid but it avoids failures on the next test about $imap->connect
6224 ok( resolv( 'imap.gmail.com' ), 'resolv: imap.gmail.com => something' ) ;
6225 like( probe_imapssl( 'imap.gmail.com' ), qr/^\* OK/, 'probe_imapssl: imap.gmail.com matches "* OK"' ) ;
6226
6227 like( probe_imapssl( 'test1.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: test1.lamiral.info matches "* OK"' ) ;
6228
6229 note( 'Leaving tests_probe_imapssl()' ) ;
6230 return ;
6231}
6232
6233
6234sub probe_imapssl
6235{
6236 my $host = shift ;
6237
6238 if ( ! $host ) { return ; }
6239 $sync->{ debug } and $IO::Socket::SSL::DEBUG = 4 ;
6240 my $socket = IO::Socket::SSL->new(
6241 PeerHost => $host,
6242 PeerPort => $IMAP_SSL_PORT,
6243 SSL_verifycn_scheme => 'imap',
6244 SSL_verify_mode => $SSL_VERIFY_POLICY,
6245 SSL_cipher_list => 'DEFAULT:!DH',
6246 ) ;
6247 if ( ! $socket ) { return ; }
6248 $sync->{ debug } and print "socket: $socket\n" ;
6249
6250 my $banner ;
6251 $socket->sysread( $banner, 65_536 ) ;
6252 $sync->{ debug } and print "banner: $banner" ;
6253 $socket->close( ) ;
6254 return $banner ;
6255
6256}
6257
6258sub connect_imap
6259{
6260 my( $host, $port, $mydebugimap, $ssl, $tls, $Side, $mytimeout, $h ) = @_ ;
6261 my $imap = Mail::IMAPClient->new( ) ;
6262
6263 if ( $ssl ) { set_ssl( $imap, $h ) }
6264 $imap->Server( $host ) ;
6265 $imap->Port( $port ) ;
6266 $imap->Debug( $mydebugimap ) ;
6267 $imap->Timeout( $mytimeout ) ;
6268
6269 my $side = lc $Side ;
6270 myprint( "$Side: connecting on $side [$host] port [$port]\n" ) ;
6271
6272 if ( ! $imap->connect( ) )
6273 {
6274 $sync->{nb_errors}++ ;
6275 exit_clean( $sync, $EXIT_CONNECTION_FAILURE,
6276 "$Side: Can not open imap connection on [$host]: ",
6277 $imap->LastError,
6278 " $OS_ERROR\n"
6279 ) ;
6280 }
6281 myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ;
6282
6283 my $banner = $imap->Results()->[0] ;
6284
6285 myprint( "$Side banner: $banner" ) ;
6286 myprint( "$Side capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ;
6287
6288 if ( $tls ) {
6289 set_tls( $imap, $h ) ;
6290 if ( ! $imap->starttls( ) )
6291 {
6292 $sync->{nb_errors}++ ;
6293 exit_clean( $sync, $EXIT_TLS_FAILURE,
6294 "$Side: Can not go to tls encryption on $side [$host]:",
6295 $imap->LastError, "\n"
6296 ) ;
6297 }
6298 myprint( "$Side: Socket successfuly converted to SSL\n" ) ;
6299 }
6300 return( $imap ) ;
6301}
6302
6303
6304sub login_imap
6305{
6306
6307 my @allargs = @_ ;
6308 my(
6309 $host, $port, $user, $domain, $password,
6310 $mydebugimap, $mytimeout, $fastio,
6311 $ssl, $tls, $authmech, $authuser, $reconnectretry,
6312 $proxyauth, $uid, $split, $Side, $h, $mysync ) = @allargs ;
6313
6314 my $side = lc $Side ;
6315 myprint( "$Side: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ;
6316
6317 my $imap = init_imap( @allargs ) ;
6318
6319 if ( ! $imap->connect() )
6320 {
6321 $mysync->{nb_errors}++ ;
6322 exit_clean( $mysync, $EXIT_CONNECTION_FAILURE,
6323 "$Side failure: can not open imap connection on $side [$host] with user [$user]: ",
6324 $imap->LastError . " $OS_ERROR\n"
6325 ) ;
6326 }
6327 myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ;
6328 my $banner = $imap->Results()->[0] ;
6329
6330 myprint( "$Side banner: $banner" ) ;
6331 myprint( "$Side capability before authentication: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ;
6332
6333 if ( (! $ssl) and (! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) {
6334 myprint( "$Side: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ;
6335 $tls = 1 ;
6336 }
6337
6338 if ( $authmech eq 'PREAUTH' ) {
6339 if ( $imap->IsAuthenticated( ) ) {
6340 $imap->Socket ;
6341 myprintf("%s: Assuming PREAUTH for %s\n", $Side, $imap->Server ) ;
6342 }else{
6343 $mysync->{nb_errors}++ ;
6344 exit_clean(
6345 $mysync, $EXIT_AUTHENTICATION_FAILURE,
6346 "$Side failure: error login on $side [$host] with user [$user] auth [PREAUTH]\n"
6347 ) ;
6348 }
6349 }
6350
6351 if ( $tls ) {
6352 set_tls( $imap, $h ) ;
6353 if ( ! $imap->starttls( ) )
6354 {
6355 $mysync->{nb_errors}++ ;
6356 exit_clean( $mysync, $EXIT_TLS_FAILURE,
6357 "$Side failure: Can not go to tls encryption on $side [$host]:",
6358 $imap->LastError, "\n"
6359 ) ;
6360 }
6361 myprint( "$Side: Socket successfuly converted to SSL\n" ) ;
6362 }
6363
6364 authenticate_imap( $imap, @allargs ) ;
6365
6366 myprint( "$Side: success login on [$host] with user [$user] auth [$authmech]\n" ) ;
6367 return( $imap ) ;
6368}
6369
6370
6371sub authenticate_imap
6372{
6373 my( $imap,
6374 $host, $port, $user, $domain, $password,
6375 $mydebugimap, $mytimeout, $fastio,
6376 $ssl, $tls, $authmech, $authuser, $reconnectretry,
6377 $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ;
6378
6379 check_capability( $imap, $authmech, $Side ) ;
6380 $imap->User( $user ) ;
6381 $imap->Domain( $domain ) if ( defined $domain ) ;
6382 $imap->Authuser( $authuser ) ;
6383 $imap->Password( $password ) ;
6384
6385 if ( 'X-MASTERAUTH' eq $authmech )
6386 {
6387 xmasterauth( $imap ) ;
6388 return ;
6389 }
6390
6391 if ( $proxyauth ) {
6392 $imap->Authmechanism(q{}) ;
6393 $imap->User( $authuser ) ;
6394 } else {
6395 $imap->Authmechanism( $authmech ) unless ( $authmech eq 'LOGIN' or $authmech eq 'PREAUTH' ) ;
6396 }
6397
6398 $imap->Authcallback(\&xoauth) if ( 'XOAUTH' eq $authmech ) ;
6399 $imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $authmech ) ;
6400 $imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $authmech ) or ( 'EXTERNAL' eq $authmech ) ) ;
6401
6402
6403 unless ( $authmech eq 'PREAUTH' or $imap->login( ) ) {
6404 my $info = "$Side failure: Error login on [$host] with user [$user] auth" ;
6405 my $einfo = $imap->LastError || @{$imap->History}[$LAST] ;
6406 chomp $einfo ;
6407 my $error = "$info [$authmech]: $einfo\n" ;
6408 if ( ( $authmech eq 'LOGIN' ) or $imap->IsUnconnected( ) or $authuser ) {
6409 $authuser ||= "" ;
6410 myprint( "$Side info: authmech [$authmech] user [$user] authuser [$authuser] IsUnconnected [", $imap->IsUnconnected( ), "]\n" ) ;
6411 $mysync->{nb_errors}++ ;
6412 exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, $error ) ;
6413 }else{
6414 myprint( $error ) ;
6415 }
6416 # It is not secure to try plain text LOGIN when another authmech failed
6417 # but I do it.
6418 # I shell remove this code one day.
6419 myprint( "$Side info: trying LOGIN Auth mechanism on [$host] with user [$user]\n" ) ;
6420 $imap->Authmechanism(q{}) ;
6421 if ( ! $imap->login( ) )
6422 {
6423 $mysync->{nb_errors}++ ;
6424 exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE,
6425 "$info [LOGIN]: ",
6426 $imap->LastError, "\n"
6427 ) ;
6428 }
6429 }
6430
6431 if ( $proxyauth ) {
6432 if ( ! $imap->proxyauth( $user ) ) {
6433 my $info = "$Side failure: Error doing proxyauth as user [$user] on [$host] using proxy-login as [$authuser]" ;
6434 my $einfo = $imap->LastError || @{$imap->History}[$LAST] ;
6435 chomp $einfo ;
6436 $mysync->{nb_errors}++ ;
6437 exit_clean( $mysync,
6438 $EXIT_AUTHENTICATION_FAILURE,
6439 "$info: $einfo\n"
6440 ) ;
6441 }
6442 }
6443
6444 return ;
6445}
6446
6447sub check_capability
6448{
6449
6450 my( $imap, $authmech, $Side ) = @_ ;
6451
6452
6453 if ( $imap->has_capability( "AUTH=$authmech" )
6454 or $imap->has_capability( $authmech ) )
6455 {
6456 myprintf("%s: %s says it has CAPABILITY for AUTHENTICATE %s\n",
6457 $Side, $imap->Server, $authmech) ;
6458 return ;
6459 }
6460
6461 if ( $authmech eq 'LOGIN' )
6462 {
6463 # Well, the warning is so common and useless that I prefer to remove it
6464 # No more "... says it has NO CAPABILITY for AUTHENTICATE LOGIN"
6465 return ;
6466 }
6467
6468
6469 myprintf( "%s: %s says it has NO CAPABILITY for AUTHENTICATE %s\n",
6470 $Side, $imap->Server, $authmech ) ;
6471
6472 if ( $authmech eq 'PLAIN' )
6473 {
6474 myprint( "$Side: frequently PLAIN is only supported with SSL, try --ssl or --tls options\n" ) ;
6475 }
6476
6477 return ;
6478}
6479
6480sub set_ssl
6481{
6482 my ( $imap, $h ) = @_ ;
6483 # SSL_version can be
6484 # SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953)
6485 #
6486
6487 my $sslargs_hash = $h->{sslargs} ;
6488
6489 my $sslargs_default = {
6490 SSL_verify_mode => $SSL_VERIFY_POLICY,
6491 SSL_verifycn_scheme => 'imap',
6492 SSL_cipher_list => 'DEFAULT:!DH',
6493 } ;
6494
6495 # initiate with default values
6496 my %sslargs_mix = %{ $sslargs_default } ;
6497 # now override with passed values
6498 @sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ;
6499 # remove keys with undef values
6500 foreach my $key ( keys %sslargs_mix ) {
6501 delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ;
6502 }
6503 # back to an ARRAY
6504 my @sslargs_mix = %sslargs_mix ;
6505 #myprint( Data::Dumper->Dump( [ $sslargs_hash, $sslargs_default, \%sslargs_mix, \@sslargs_mix ] ) ) ;
6506 $imap->Ssl( \@sslargs_mix ) ;
6507 return ;
6508}
6509
6510sub set_tls
6511{
6512 my ( $imap, $h ) = @_ ;
6513
6514 my $sslargs_hash = $h->{sslargs} ;
6515
6516 my $sslargs_default = {
6517 SSL_verify_mode => $SSL_VERIFY_POLICY,
6518 SSL_cipher_list => 'DEFAULT:!DH',
6519 } ;
6520
6521 # initiate with default values
6522 my %sslargs_mix = %{ $sslargs_default } ;
6523 # now override with passed values
6524 @sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ;
6525 # remove keys with undef values
6526 foreach my $key ( keys %sslargs_mix ) {
6527 delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ;
6528 }
6529 # back to an ARRAY
6530 my @sslargs_mix = %sslargs_mix ;
6531
6532 $imap->Starttls( \@sslargs_mix ) ;
6533 return ;
6534}
6535
6536
6537
6538
6539sub init_imap
6540{
6541 my(
6542 $host, $port, $user, $domain, $password,
6543 $mydebugimap, $mytimeout, $fastio,
6544 $ssl, $tls, $authmech, $authuser, $reconnectretry,
6545 $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ;
6546
6547 my ( $imap ) ;
6548
6549 $imap = Mail::IMAPClient->new() ;
6550
6551 if ( $mysync->{ tee } )
6552 {
6553 # Well, it does not change anything, does it?
6554 # It does when suppressing the hack with *STDERR
6555 $imap->Debug_fh( $mysync->{ tee } ) ;
6556 }
6557
6558 if ( $ssl ) { set_ssl( $imap, $h ) }
6559 if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS
6560 $imap->Clear(1);
6561 $imap->Server($host);
6562 $imap->Port($port);
6563 $imap->Fast_io($fastio);
6564 $imap->Buffer($buffersize || $DEFAULT_BUFFER_SIZE);
6565 $imap->Uid($uid);
6566
6567
6568 $imap->Peek(1);
6569 $imap->Debug($mydebugimap);
6570 if ( $mysync->{ showpasswords } ) {
6571 $imap->Showcredentials( 1 ) ;
6572 }
6573 defined $mytimeout and $imap->Timeout( $mytimeout ) ;
6574
6575 $imap->Reconnectretry( $reconnectretry ) if ( $reconnectretry ) ;
6576 $imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ;
6577 $imap->Ignoresizeerrors( $allowsizemismatch ) ;
6578 $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ;
6579
6580
6581 return( $imap ) ;
6582
6583}
6584
6585sub plainauth
6586{
6587 my $code = shift;
6588 my $imap = shift;
6589
6590 my $string = mysprintf("%s\x00%s\x00%s", $imap->User,
6591 $imap->Authuser, $imap->Password);
6592 return encode_base64("$string", q{});
6593}
6594
6595# Copy from https://github.com/imapsync/imapsync/pull/25/files
6596# Changes "use" pragmas to "require".
6597# The openssl system call shall be replaced by pure Perl and
6598# https://metacpan.org/pod/Crypt::OpenSSL::PKCS12
6599
6600# Now the Joaquin Lopez code:
6601#
6602# Used this as an example: https://gist.github.com/gsainio/6322375
6603#
6604# And this as a reference: https://developers.google.com/accounts/docs/OAuth2ServiceAccount
6605# (note there is an http/rest tab, where the real info is hidden away... went on a witch hunt
6606# until I noticed that...)
6607#
6608# This is targeted at gmail to maintain compatibility after google's oauth1 service is deactivated
6609# on May 5th, 2015: https://developers.google.com/gmail/oauth_protocol
6610# If there are other oauth2 implementations out there, this would need to be modified to be
6611# compatible
6612#
6613# This is a good guide on setting up the google api/apps side of the equation:
6614# http://www.limilabs.com/blog/oauth2-gmail-imap-service-account
6615#
6616# 2016/05/27: Updated to support oauth/key data in the .json files Google now defaults to
6617# when creating gmail service accounts. They're easier to work with since they neither
6618# requiring decrypting nor specifying the oauth2 client id separately.
6619#
6620# If the password arg ends in .json, it will assume this new json method, otherwise it
6621# will fallback to the "oauth client id;.p12" format it was previously using.
6622sub xoauth2
6623{
6624 require JSON::WebToken ;
6625 require LWP::UserAgent ;
6626 require HTML::Entities ;
6627 require JSON ;
6628 require JSON::WebToken::Crypt::RSA ;
6629 require Crypt::OpenSSL::RSA ;
6630 require Encode::Byte ;
6631 require IO::Socket::SSL ;
6632
6633 my $code = shift;
6634 my $imap = shift;
6635
6636 my ($iss,$key);
6637
6638 if( $imap->Password =~ /^(.*\.json)$/x )
6639 {
6640 my $json = JSON->new( ) ;
6641 my $filename = $1;
6642 $sync->{ debug } and myprint( "XOAUTH2 json file: $filename\n" ) ;
6643 my $FILE ;
6644 if ( ! open( $FILE, '<', $filename ) )
6645 {
6646 $sync->{nb_errors}++ ;
6647 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
6648 "error [$filename]: $OS_ERROR\n"
6649 ) ;
6650 }
6651 my $jsonfile = $json->decode( join q{}, <$FILE> ) ;
6652 close $FILE ;
6653
6654 $iss = $jsonfile->{client_id};
6655 $key = $jsonfile->{private_key};
6656 $sync->{ debug } and myprint( "Service account: $iss\n");
6657 $sync->{ debug } and myprint( "Private key:\n$key\n");
6658 }
6659 else
6660 {
6661 # Get iss (service account address), keyfile name, and keypassword if necessary
6662 ( $iss, my $keyfile, my $keypass ) = $imap->Password =~ /([\-\d\w\@\.]+);([a-zA-Z0-9 \_\-\.\/]+);?(.*)?/x ;
6663
6664 # Assume key password is google default if not provided
6665 $keypass = 'notasecret' if not $keypass;
6666
6667 $sync->{ debug } and myprint( "Service account: $iss\nKey file: $keyfile\nKey password: $keypass\n");
6668
6669 # Get private key from p12 file (would be better in perl...)
6670 $key = `openssl pkcs12 -in "$keyfile" -nodes -nocerts -passin pass:$keypass -nomacver`;
6671
6672 $sync->{ debug } and myprint( "Private key:\n$key\n");
6673 }
6674
6675 # Create jwt of oauth2 request
6676 my $time = time ;
6677 my $jwt = JSON::WebToken->encode( {
6678 'iss' => $iss, # service account
6679 'scope' => 'https://mail.google.com/',
6680 'aud' => 'https://www.googleapis.com/oauth2/v3/token',
6681 'exp' => $time + $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12,
6682 'iat' => $time,
6683 'prn' => $imap->User # user to auth as
6684 },
6685 $key, 'RS256', {'typ' => 'JWT'} ); # Crypt::OpenSSL::RSA needed here.
6686
6687 # Post oauth2 request
6688 my $ua = LWP::UserAgent->new( ) ;
6689 $ua->env_proxy( ) ;
6690
6691 my $response = $ua->post('https://www.googleapis.com/oauth2/v3/token',
6692 { grant_type => HTML::Entities::encode_entities('urn:ietf:params:oauth:grant-type:jwt-bearer'),
6693 assertion => $jwt } ) ;
6694
6695 unless( $response->is_success( ) ) {
6696 $sync->{nb_errors}++ ;
6697 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
6698 $response->code, "\n", $response->content, "\n"
6699 ) ;
6700 }else{
6701 $sync->{ debug } and myprint( $response->content ) ;
6702 }
6703
6704 # access_token in response is what we need
6705 my $data = JSON::decode_json( $response->content ) ;
6706
6707 # format as oauth2 auth data
6708 my $xoauth2_string = encode_base64( 'user=' . $imap->User . "\1auth=Bearer " . $data->{access_token} . "\1\1", q{} ) ;
6709
6710 $sync->{ debug } and myprint( "XOAUTH2 String: $xoauth2_string\n");
6711 return($xoauth2_string);
6712}
6713
6714
6715
6716
6717# xoauth() thanks to Eduardo Bortoluzzi Junior
6718sub xoauth
6719{
6720 require URI::Escape ;
6721 require Data::Uniqid ;
6722
6723 my $code = shift;
6724 my $imap = shift;
6725
6726 # The base information needed to construct the OAUTH authentication
6727 my $method = 'GET' ;
6728 my $url = mysprintf( 'https://mail.google.com/mail/b/%s/imap/', $imap->User ) ;
6729 my $urlparm = mysprintf( 'xoauth_requestor_id=%s', URI::Escape::uri_escape( $imap->User ) ) ;
6730
6731 # For Google Apps, the consumer key is the primary domain
6732 # TODO: create a command line argument to define the consumer key
6733 my @user_parts = split /@/x, $imap->User ;
6734 $sync->{ debug } and myprint( "XOAUTH: consumer key: $user_parts[1]\n" ) ;
6735
6736 # All the parameters needed to be signed on the XOAUTH
6737 my %hash = ();
6738 $hash { 'xoauth_requestor_id' } = URI::Escape::uri_escape($imap->User);
6739 $hash { 'oauth_consumer_key' } = $user_parts[1];
6740 $hash { 'oauth_nonce' } = md5_hex(Data::Uniqid::uniqid(rand(), 1==1));
6741 $hash { 'oauth_signature_method' } = 'HMAC-SHA1';
6742 $hash { 'oauth_timestamp' } = time ;
6743 $hash { 'oauth_version' } = '1.0';
6744
6745 # Base will hold the string to be signed
6746 my $base = "$method&" . URI::Escape::uri_escape( $url ) . q{&} ;
6747
6748 # The parameters must be in dictionary order before signing
6749 my $baseparms = q{} ;
6750 foreach my $key ( sort keys %hash ) {
6751 if ( length( $baseparms ) > 0 ) {
6752 $baseparms .= q{&} ;
6753 }
6754
6755 $baseparms .= "$key=$hash{$key}" ;
6756 }
6757
6758 $base .= URI::Escape::uri_escape($baseparms);
6759 $sync->{ debug } and myprint( "XOAUTH: base request to sign: $base\n" ) ;
6760 # Sign it with the consumer secret, informed on the command line (password)
6761 my $digest = hmac_sha1( $base, URI::Escape::uri_escape( $imap->Password ) . q{&} ) ;
6762
6763 # The parameters signed become a parameter and...
6764 $hash { 'oauth_signature' } = URI::Escape::uri_escape( substr encode_base64( $digest ), 0, $MINUS_ONE ) ;
6765
6766 # ... we don't need the requestor_id anymore.
6767 delete $hash{'xoauth_requestor_id'} ;
6768
6769 # Create the final authentication string
6770 my $string = $method . q{ } . $url . q{?} . $urlparm .q{ } ;
6771
6772 # All the parameters must be sorted
6773 $baseparms = q{};
6774 foreach my $key (sort keys %hash) {
6775 if(length($baseparms)>0) {
6776 $baseparms .= q{,} ;
6777 }
6778
6779 $baseparms .= "$key=\"$hash{$key}\"";
6780 }
6781
6782 $string .= $baseparms;
6783
6784 $sync->{ debug } and myprint( "XOAUTH: authentication string: $string\n" ) ;
6785
6786 # It must be base64 encoded
6787 return encode_base64("$string", q{});
6788}
6789
6790
6791sub xmasterauth
6792{
6793 # This is Kerio auth admin
6794 # This code comes from
6795 # https://github.com/imapsync/imapsync/pull/53/files
6796
6797 my $imap = shift ;
6798
6799 my $user = $imap->User( ) ;
6800 my $password = $imap->Password( ) ;
6801 my $authmech = 'X-MASTERAUTH' ;
6802
6803 my @challenge = $imap->tag_and_run( $authmech, "+" ) ;
6804 if ( not defined $challenge[0] )
6805 {
6806 $sync->{nb_errors}++ ;
6807 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
6808 "Failure authenticate with $authmech: ",
6809 $imap->LastError, "\n"
6810 ) ;
6811 return ; # hahaha!
6812 }
6813 $sync->{ debug } and myprint( "X-MASTERAUTH challenge: [@challenge]\n" ) ;
6814
6815 $challenge[1] =~ s/^\+ |^\s+|\s+$//g ;
6816 if ( ! $imap->_imap_command( { addcrlf => 1, addtag => 0, tag => $imap->Count }, md5_hex( $challenge[1] . $password ) ) )
6817 {
6818 $sync->{nb_errors}++ ;
6819 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
6820 "Failure authenticate with $authmech: ",
6821 $imap->LastError, "\n"
6822 ) ;
6823 }
6824
6825 if ( ! $imap->tag_and_run( 'X-SETUSER ' . $user ) )
6826 {
6827 $sync->{nb_errors}++ ;
6828 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE,
6829 "Failure authenticate with $authmech: ",
6830 "X-SETUSER ", $imap->LastError, "\n"
6831 ) ;
6832 }
6833
6834 $imap->State( Mail::IMAPClient::Authenticated ) ;
6835 # I comment this state because "Selected" state is usually done by SELECT or EXAMINE imap commands
6836 # $imap->State( Mail::IMAPClient::Selected ) ;
6837
6838 return ;
6839}
6840
6841
6842sub tests_do_valid_directory
6843{
6844 note( 'Entering tests_do_valid_directory()' ) ;
6845
6846 Readonly my $NB_UNIX_tests_do_valid_directory => 2 ;
6847 SKIP: {
6848 skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory ) if ( 'MSWin32' eq $OSNAME ) ;
6849 ok( 1 == do_valid_directory( '.'), 'do_valid_directory: . good' ) ;
6850 ok( 1 == do_valid_directory( './W/tmp/tests/valid/sub'), 'do_valid_directory: ./W/tmp/tests/valid/sub good' ) ;
6851 }
6852 Readonly my $NB_UNIX_tests_do_valid_directory_non_root => 2 ;
6853 SKIP: {
6854 skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory_non_root ) if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ;
6855 diag( 'Error / not writable is on purpose' ) ;
6856 ok( 0 == do_valid_directory( '/'), 'do_valid_directory: / bad' ) ;
6857 diag( 'Error permission denied on /noway is on purpose' ) ;
6858 ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ;
6859 }
6860
6861
6862 note( 'Leaving tests_do_valid_directory()' ) ;
6863 return ;
6864}
6865
6866sub banner_imapsync
6867{
6868 my $mysync = shift @ARG ;
6869 my @argv = @ARG ;
6870
6871 my $banner_imapsync = join q{},
6872 q{$RCSfile: imapsync,v $ },
6873 q{$Revision: 1.977 $ },
6874 q{$Date: 2019/12/23 20:18:02 $ },
6875 "\n",
6876 "Command line used, run by $EXECUTABLE_NAME:\n",
6877 "$PROGRAM_NAME ", command_line_nopassword( $mysync, @argv ), "\n" ;
6878
6879 return( $banner_imapsync ) ;
6880}
6881
6882sub do_valid_directory
6883{
6884 my $dir = shift @ARG ;
6885
6886 # all good => return ok.
6887 return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
6888
6889 # exist but bad
6890 if ( -e $dir and not -d _ ) {
6891 myprint( "Error: $dir exists but is not a directory\n" ) ;
6892 return( 0 ) ;
6893 }
6894 if ( -e $dir and not -w _ ) {
6895 my $sb = stat $dir ;
6896 myprintf( "Error: directory %s is not writable for user %s, permissions are %04o and owner is %s ( uid %s )\n",
6897 $dir, getpwuid_any_os( $EFFECTIVE_USER_ID ), ($sb->mode & oct($PERMISSION_FILTER) ), getpwuid_any_os( $sb->uid ), $sb->uid( ) ) ;
6898 return( 0 ) ;
6899 }
6900 # Trying to create it
6901 myprint( "Creating directory $dir\n" ) ;
6902 if ( ! eval { mkpath( $dir ) } ) {
6903 myprint( "$EVAL_ERROR" ) if ( $EVAL_ERROR ) ;
6904 }
6905 return( 1 ) if ( -d $dir and -r _ and -w _ ) ;
6906 return( 0 ) ;
6907}
6908
6909
6910sub tests_match_a_pid_number
6911{
6912 note( 'Entering tests_match_a_pid_number()' ) ;
6913
6914 is( undef, match_a_pid_number( ), 'match_a_pid_number: no args => undef' ) ;
6915 is( undef, match_a_pid_number( q{} ), 'match_a_pid_number: "" => undef' ) ;
6916 is( undef, match_a_pid_number( 'lalala' ), 'match_a_pid_number: lalala => undef' ) ;
6917 is( 1, match_a_pid_number( 1 ), 'match_a_pid_number: 1 => 1' ) ;
6918 is( 1, match_a_pid_number( 123 ), 'match_a_pid_number: 123 => 1' ) ;
6919 is( 1, match_a_pid_number( -123 ), 'match_a_pid_number: -123 => 1' ) ;
6920 is( 1, match_a_pid_number( '123' ), 'match_a_pid_number: "123" => 1' ) ;
6921 is( 1, match_a_pid_number( '-123' ), 'match_a_pid_number: "-123" => 1' ) ;
6922 is( undef, match_a_pid_number( 'a123' ), 'match_a_pid_number: a123 => undef' ) ;
6923 is( undef, match_a_pid_number( '-a123' ), 'match_a_pid_number: -a123 => undef' ) ;
6924 is( 1, match_a_pid_number( 99999 ), 'match_a_pid_number: 99999 => 1' ) ;
6925 is( 1, match_a_pid_number( -99999 ), 'match_a_pid_number: -99999 => 1' ) ;
6926 is( undef, match_a_pid_number( 0 ), 'match_a_pid_number: 0 => undef' ) ;
6927 is( undef, match_a_pid_number( 100000 ), 'match_a_pid_number: 100000 => undef' ) ;
6928 is( undef, match_a_pid_number( 123456 ), 'match_a_pid_number: 123456 => undef' ) ;
6929 is( undef, match_a_pid_number( '-0' ), 'match_a_pid_number: "-0" => undef' ) ;
6930 is( undef, match_a_pid_number( -100000 ), 'match_a_pid_number: -100000 => undef' ) ;
6931 is( undef, match_a_pid_number( -123456 ), 'match_a_pid_number: -123456 => undef' ) ;
6932
6933 note( 'Leaving tests_match_a_pid_number()' ) ;
6934 return ;
6935}
6936
6937sub match_a_pid_number
6938{
6939 my $pid = shift @ARG ;
6940 if ( ! defined $pid ) { return ; }
6941 #print "$pid\n" ;
6942 if ( ! match( $pid, '^-?\d+$' ) ) { return ; }
6943 #print "$pid\n" ;
6944 # can be negative on Windows
6945 #if ( 0 > $pid ) { return ; }
6946 #if ( 65535 < $pid ) { return ; }
6947 if ( 99999 < abs( $pid ) ) { return ; }
6948 if ( 0 == abs( $pid ) ) { return ; }
6949 return 1 ;
6950}
6951
6952sub tests_remove_pidfile_not_running
6953{
6954 note( 'Entering tests_remove_pidfile_not_running()' ) ;
6955
6956 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'remove_pidfile_not_running: mkpath W/tmp/tests/' ) ;
6957 is( undef, remove_pidfile_not_running( ), 'remove_pidfile_not_running: no args => undef' ) ;
6958 is( undef, remove_pidfile_not_running( './W' ), 'remove_pidfile_not_running: a dir => undef' ) ;
6959 is( undef, remove_pidfile_not_running( 'noexists' ), 'remove_pidfile_not_running: noexists => undef' ) ;
6960 is( 1, touch( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: prepa empty W/tmp/tests/empty.pid' ) ;
6961 is( undef, remove_pidfile_not_running( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: W/tmp/tests/empty.pid => undef' ) ;
6962 is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/lalala.pid' ) ;
6963 is( undef, remove_pidfile_not_running( 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: W/tmp/tests/lalala.pid => undef' ) ;
6964 is( '55555', string_to_file( '55555', 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/notrunning.pid' ) ;
6965 is( 1, remove_pidfile_not_running( 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: W/tmp/tests/notrunning.pid => 1' ) ;
6966 is( $PROCESS_ID, string_to_file( $PROCESS_ID, 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/running.pid' ) ;
6967 is( undef, remove_pidfile_not_running( 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: W/tmp/tests/running.pid => undef' ) ;
6968
6969 note( 'Leaving tests_remove_pidfile_not_running()' ) ;
6970 return ;
6971}
6972
6973sub remove_pidfile_not_running
6974{
6975 #
6976 my $pid_filename = shift @ARG ;
6977
6978 if ( ! $pid_filename ) { myprint( "No variable pid_filename\n" ) ; return } ;
6979 if ( ! -e $pid_filename ) { myprint( "File $pid_filename does not exist\n" ) ; return } ;
6980 if ( ! -f $pid_filename ) { myprint( "File $pid_filename is not a file\n" ) ; return } ;
6981
6982 my $pid = firstline( $pid_filename ) ;
6983 if ( ! match_a_pid_number( $pid ) ) { myprint( "pid $pid in $pid_filename is not a number\n" ) ; return } ;
6984 # can't kill myself => do nothing
6985 if ( ! kill 'ZERO', $PROCESS_ID ) { myprint( "Can not kill ZERO myself $PROCESS_ID\n" ) ; return } ;
6986
6987 # can't kill ZERO the pid => it is gone or own by another user => remove pidfile
6988 if ( ! kill 'ZERO', $pid ) {
6989 myprint( "Removing old $pid_filename since its PID $pid is not running anymore (oo-killed?)\n" ) ;
6990 if ( unlink $pid_filename ) {
6991 myprint( "Removed old $pid_filename\n" ) ;
6992 return 1 ;
6993 }else{
6994 myprint( "Could not remove old $pid_filename because $!\n" ) ;
6995 return ;
6996 }
6997 }
6998 myprint( "Another imapsync process $pid is running as says pidfile $pid_filename\n" ) ;
6999 return ;
7000}
7001
7002
7003sub tests_tail
7004{
7005 note( 'Entering tests_tail()' ) ;
7006
7007 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'tail: mkpath W/tmp/tests/' ) ;
7008 ok( ( ! -e 'W/tmp/tests/tail.pid' || unlink 'W/tmp/tests/tail.pid' ), 'tail: unlink W/tmp/tests/tail.pid' ) ;
7009 ok( ( ! -e 'W/tmp/tests/tail.txt' || unlink 'W/tmp/tests/tail.txt' ), 'tail: unlink W/tmp/tests/tail.txt' ) ;
7010
7011 is( undef, tail( ), 'tail: no args => undef' ) ;
7012 my $mysync ;
7013 is( undef, tail( $mysync ), 'tail: no pidfile => undef' ) ;
7014
7015 $mysync->{pidfile} = 'W/tmp/tests/tail.pid' ;
7016 is( undef, tail( $mysync ), 'tail: no pidfilelocking => undef' ) ;
7017
7018 $mysync->{pidfilelocking} = 1 ;
7019 is( undef, tail( $mysync ), 'tail: pidfile no exists => undef' ) ;
7020
7021
7022 my $pidandlog = "33333\nW/tmp/tests/tail.txt\n" ;
7023 is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put pid 33333 and tail.txt in pidfile' ) ;
7024 is( undef, tail( $mysync ), 'tail: logfile to tail no exists => undef' ) ;
7025
7026 my $tailcontent = "L1\nL2\nL3\nL4\nL5\n" ;
7027 is( $tailcontent, string_to_file( $tailcontent, 'W/tmp/tests/tail.txt' ),
7028 'tail: put L1\nL2\nL3\nL4\nL5\n in W/tmp/tests/tail.txt' ) ;
7029
7030 is( undef, tail( $mysync ), 'tail: fake pid in pidfile + tail off => 1' ) ;
7031
7032 $mysync->{ tail } = 1 ;
7033 is( 1, tail( $mysync ), 'tail: fake pid in pidfile + tail on=> 1' ) ;
7034
7035 # put my own pid, won't do tail
7036 $pidandlog = "$PROCESS_ID\nW/tmp/tests/tail.txt\n" ;
7037 is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put my own PID in pidfile' ) ;
7038 is( undef, tail( $mysync ), 'tail: my own pid in pidfile => undef' ) ;
7039
7040 note( 'Leaving tests_tail()' ) ;
7041 return ;
7042}
7043
7044
7045
7046sub tail
7047{
7048 # return undef on failures
7049 # return 1 on success
7050
7051 my $mysync = shift ;
7052
7053 # no tail when aborting!
7054 if ( $mysync->{ abort } ) { return ; }
7055
7056 my $pidfile = $mysync->{pidfile} ;
7057 my $lock = $mysync->{pidfilelocking} ;
7058 my $tail = $mysync->{tail} ;
7059
7060 if ( ! $pidfile ) { return ; }
7061 if ( ! $lock ) { return ; }
7062 if ( ! $tail ) { return ; }
7063
7064 my $pidtotail = firstline( $pidfile ) ;
7065 if ( ! $pidtotail ) { return ; }
7066
7067
7068
7069 # It should not happen but who knows...
7070 if ( $pidtotail eq $PROCESS_ID ) { return ; }
7071
7072
7073 my $filetotail = secondline( $pidfile ) ;
7074 if ( ! $filetotail ) { return ; }
7075
7076 if ( ! -r $filetotail )
7077 {
7078 #myprint( "Error: can not read $filetotail\n" ) ;
7079 return ;
7080 }
7081
7082 myprint( "Doing a tail -f on $filetotail for processus pid $pidtotail until it is finished.\n" ) ;
7083 my $file = File::Tail->new(
7084 name => $filetotail,
7085 nowait => 1,
7086 interval => 1,
7087 tail => 1,
7088 adjustafter => 2
7089 );
7090
7091 my $moretimes = 200 ;
7092 # print one line at least
7093 my $line = $file->read ;
7094 myprint( $line ) ;
7095 while ( isrunning( $pidtotail, \$moretimes ) and defined( $line = $file->read ) )
7096 {
7097 myprint( $line );
7098 sleep( 0.02 ) ;
7099 }
7100
7101 return 1 ;
7102}
7103
7104sub isrunning
7105{
7106 my $pidtocheck = shift ;
7107 my $moretimes_ref = shift ;
7108
7109 if ( kill 'ZERO', $pidtocheck )
7110 {
7111 #myprint( "$pidtocheck running\n" ) ;
7112 return 1 ;
7113 }
7114 elsif ( $$moretimes_ref >= 0 )
7115 {
7116 # continue to consider it running
7117 $$moretimes_ref-- ;
7118 return 1 ;
7119 }
7120 else
7121 {
7122 myprint( "Tailed processus $pidtocheck ended\n" ) ;
7123 return ;
7124 }
7125}
7126
7127sub tests_write_pidfile
7128{
7129 note( 'Entering tests_write_pidfile()' ) ;
7130
7131 my $mysync ;
7132
7133 is( 1, write_pidfile( ), 'write_pidfile: no args => 1' ) ;
7134
7135 # no pidfile => ok
7136 $mysync->{pidfile} = q{} ;
7137 is( 1, write_pidfile( $mysync ), 'write_pidfile: no pidfile => undef' ) ;
7138
7139 # The pidfile path is bad => failure
7140 $mysync->{pidfile} = '/no/no/no.pid' ;
7141 is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid, no lock => undef' ) ;
7142
7143 $mysync->{pidfilelocking} = 1 ;
7144 is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid + lock => undef' ) ;
7145
7146 $mysync->{pidfile} = 'W/tmp/tests/test.pid' ;
7147 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'write_pidfile: mkpath W/tmp/tests/' ) ;
7148 is( 1, touch( $mysync->{pidfile} ), 'write_pidfile: lock prepa' ) ;
7149
7150 $mysync->{pidfilelocking} = 0 ;
7151 is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock => 1' ) ;
7152 is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains $PROCESS_ID" ) ;
7153 is( q{}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains no second line" ) ;
7154
7155 $mysync->{pidfilelocking} = 1 ;
7156 is( undef, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + lock => undef' ) ;
7157
7158
7159 $mysync->{pidfilelocking} = 0 ;
7160 $mysync->{ logfile } = 'rrrr.txt' ;
7161 is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock + logfile => 1' ) ;
7162 is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains $PROCESS_ID" ) ;
7163 is( q{rrrr.txt}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains rrrr.txt" ) ;
7164
7165
7166 note( 'Leaving tests_write_pidfile()' ) ;
7167 return ;
7168}
7169
7170
7171
7172sub write_pidfile
7173{
7174 # returns undef if something is considered fatal
7175 # returns 1 otherwise
7176
7177 if ( ! @ARG ) { return 1 ; }
7178
7179 my $mysync = shift @ARG ;
7180
7181 # Do not write the pid file if this process goal is to abort the process designed by the pid file
7182 if ( $mysync->{abort} ) { return 1 ; }
7183
7184 #
7185 my $pid_filename = $mysync->{ pidfile } ;
7186 my $lock = $mysync->{ pidfilelocking } ;
7187
7188 if ( ! $pid_filename )
7189 {
7190 myprint( "PID file is unset ( to set it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ;
7191 return( 1 ) ;
7192 }
7193
7194 myprint( "PID file is $pid_filename ( to change it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ;
7195 if ( -e $pid_filename and $lock ) {
7196 myprint( "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ) ;
7197 return ;
7198
7199 }
7200
7201 if ( -e $pid_filename ) {
7202 myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ;
7203 }
7204
7205 my $pid_string = "$PROCESS_ID\n" ;
7206 my $pid_message = "Writing my PID $PROCESS_ID in $pid_filename\n" ;
7207
7208 if ( $mysync->{ logfile } )
7209 {
7210 $pid_string .= "$mysync->{ logfile }\n" ;
7211 $pid_message .= "Writing also my logfile name in $pid_filename : $mysync->{ logfile }\n" ;
7212 }
7213
7214 if ( open my $FILE_HANDLE, '>', $pid_filename ) {
7215 myprint( $pid_message ) ;
7216 print $FILE_HANDLE $pid_string ;
7217 close $FILE_HANDLE ;
7218 return( 1 ) ;
7219 }
7220 else
7221 {
7222 myprint( "Could not open $pid_filename for writing. Check permissions or disk space: $OS_ERROR\n" ) ;
7223 return ;
7224 }
7225}
7226
7227
7228sub fix_Inbox_INBOX_mapping
7229{
7230 my( $h1_all, $h2_all ) = @_ ;
7231
7232 my $regex = q{} ;
7233 SWITCH: {
7234 if ( exists $h1_all->{INBOX} and exists $h2_all->{INBOX} ) { $regex = q{} ; last SWITCH ; } ;
7235 if ( exists $h1_all->{Inbox} and exists $h2_all->{Inbox} ) { $regex = q{} ; last SWITCH ; } ;
7236 if ( exists $h1_all->{INBOX} and exists $h2_all->{Inbox} ) { $regex = q{s/^INBOX$/Inbox/x} ; last SWITCH ; } ;
7237 if ( exists $h1_all->{Inbox} and exists $h2_all->{INBOX} ) { $regex = q{s/^Inbox$/INBOX/x} ; last SWITCH ; } ;
7238 } ;
7239 return( $regex ) ;
7240}
7241
7242sub tests_fix_Inbox_INBOX_mapping
7243{
7244 note( 'Entering tests_fix_Inbox_INBOX_mapping()' ) ;
7245
7246
7247 my( $h1_all, $h2_all ) ;
7248
7249 $h1_all = { 'INBOX' => q{} } ;
7250 $h2_all = { 'INBOX' => q{} } ;
7251 ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX INBOX' ) ;
7252
7253 $h1_all = { 'Inbox' => q{} } ;
7254 $h2_all = { 'Inbox' => q{} } ;
7255 ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox Inbox' ) ;
7256
7257 $h1_all = { 'INBOX' => q{} } ;
7258 $h2_all = { 'Inbox' => q{} } ;
7259 ok( q{s/^INBOX$/Inbox/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX Inbox' ) ;
7260
7261 $h1_all = { 'Inbox' => q{} } ;
7262 $h2_all = { 'INBOX' => q{} } ;
7263 ok( q{s/^Inbox$/INBOX/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox INBOX' ) ;
7264
7265 $h1_all = { 'INBOX' => q{} } ;
7266 $h2_all = { 'rrrrr' => q{} } ;
7267 ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX rrrrrr' ) ;
7268
7269 $h1_all = { 'rrrrr' => q{} } ;
7270 $h2_all = { 'Inbox' => q{} } ;
7271 ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: rrrrr Inbox' ) ;
7272
7273 note( 'Leaving tests_fix_Inbox_INBOX_mapping()' ) ;
7274 return ;
7275}
7276
7277
7278sub jux_utf8_list
7279{
7280 my @s_inp = @_ ;
7281 my $s_out = q{} ;
7282 foreach my $s ( @s_inp ) {
7283 $s_out .= jux_utf8( $s ) . "\n" ;
7284 }
7285 return( $s_out ) ;
7286}
7287
7288sub tests_jux_utf8_list
7289{
7290 note( 'Entering tests_jux_utf8_list()' ) ;
7291
7292 use utf8 ;
7293 is( q{}, jux_utf8_list( ), 'jux_utf8_list: void' ) ;
7294 is( "[]\n", jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ;
7295 is( "[INBOX]\n", jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ;
7296 is( "[&ANY-] = [Ö]\n", jux_utf8_list( '&ANY-' ), 'jux_utf8_list: [&ANY-] = [Ö]' ) ;
7297
7298 note( 'Leaving tests_jux_utf8_list()' ) ;
7299 return( 0 ) ;
7300}
7301
7302# editing utf8 can be tricky without an utf8 editor
7303sub tests_jux_utf8_old
7304{
7305 note( 'Entering tests_jux_utf8_old()' ) ;
7306
7307 no utf8 ;
7308
7309 is( '[]', jux_utf8_old( q{} ), 'jux_utf8_old: void => []' ) ;
7310 is( '[INBOX]', jux_utf8_old( 'INBOX'), 'jux_utf8_old: INBOX => [INBOX]' ) ;
7311 is( '[&ZTZO9nux-] = [收件箱]', jux_utf8_old( '&ZTZO9nux-'), 'jux_utf8_old: => [&ZTZO9nux-] = [收件箱]' ) ;
7312 is( '[&ANY-] = [Ö]', jux_utf8_old( '&ANY-'), 'jux_utf8_old: &ANY- => [&ANY-] = [Ö]' ) ;
7313 # +BD8EQAQ1BDQEOwQ+BDM- SHOULD stay as is!
7314 is( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]', jux_utf8_old( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8_old: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ;
7315 is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8_old( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8_old: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ;
7316
7317 note( 'Leaving tests_jux_utf8_old()' ) ;
7318 return ;
7319}
7320
7321sub jux_utf8_old
7322{
7323 # juxtapose utf8 at the right if different
7324 my ( $s_utf7 ) = shift ;
7325 my ( $s_utf8 ) = imap_utf7_decode_old( $s_utf7 ) ;
7326
7327 if ( $s_utf7 eq $s_utf8 ) {
7328 #myprint( "[$s_utf7]\n" ) ;
7329 return( "[$s_utf7]" ) ;
7330 }else{
7331 #myprint( "[$s_utf7] = [$s_utf8]\n" ) ;
7332 return( "[$s_utf7] = [$s_utf8]" ) ;
7333 }
7334}
7335
7336# Copied from http://cpansearch.perl.org/src/FABPOT/Unicode-IMAPUtf7-2.01/lib/Unicode/IMAPUtf7.pm
7337# and then fixed with
7338# https://rt.cpan.org/Public/Bug/Display.html?id=11172
7339sub imap_utf7_decode_old
7340{
7341 my ( $s ) = shift ;
7342
7343 # Algorithm
7344 # On remplace , par / dans les BASE 64 (, entre & et -)
7345 # On remplace les &, non suivi d'un - par +
7346 # On remplace les &- par &
7347 $s =~ s/&([^,&\-]*),([^,\-&]*)\-/&$1\/$2\-/xg ;
7348 $s =~ s/&(?!\-)/\+/xg ;
7349 $s =~ s/&\-/&/xg ;
7350 return( Unicode::String::utf7( $s )->utf8 ) ;
7351}
7352
7353
7354
7355
7356
7357sub tests_jux_utf8
7358{
7359 note( 'Entering tests_jux_utf8()' ) ;
7360 #no utf8 ;
7361 use utf8 ;
7362
7363 #binmode STDOUT, ":encoding(UTF-8)" ;
7364 binmode STDERR, ":encoding(UTF-8)" ;
7365
7366 # This test is because the binary can fail on it, a PAR.pm issue.
7367 # The failure was with the underlying Encode::IMAPUTF7 module line 66 release 1.05
7368 # Was solved by including Encode in imapsync and using "pp -x".
7369 ok( find_encoding( "UTF-16BE"), 'jux_utf8: Encode::find_encoding: UTF-16BE' ) ;
7370
7371 #
7372 is( '[]', jux_utf8( q{} ), 'jux_utf8: void => []' ) ;
7373 is( '[INBOX]', jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ;
7374 is( '[&ANY-] = [Ö]', jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ;
7375 # +BD8EQAQ1BDQEOwQ+BDM- must stay as is
7376 is( '[+BD8EQAQ1BDQEOwQ+BDM-]', jux_utf8( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8: => [+BD8EQAQ1BDQEOwQ+BDM-] = [+BD8EQAQ1BDQEOwQ+BDM-]' ) ;
7377 is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ;
7378
7379 is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( q{R&AOk-ponses 1200+1201+1202} ), 'jux_utf8: [R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]' ) ;
7380 my $str = Encode::IMAPUTF7::encode("IMAP-UTF-7", 'Réponses 1200+1201+1202' ) ;
7381 is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( $str ), "jux_utf8: [$str] = [Réponses 1200+1201+1202]" ) ;
7382
7383 is( '[INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éà çù&*]', jux_utf8( 'INBOX.&AOkA4ADnAPk-&-*' ), "jux_utf8: [INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éà çù&*]" ) ;
7384
7385 is( '[&ZTZO9nux-] = [收件箱]', jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ;
7386 #
7387 note( 'Leaving tests_jux_utf8()' ) ;
7388 return ;
7389}
7390
7391sub jux_utf8
7392{
7393 #use utf8 ;
7394 # juxtapose utf8 at the right if different
7395 my ( $s_utf7 ) = shift ;
7396 my ( $s_utf8 ) = imap_utf7_decode( $s_utf7 ) ;
7397
7398 if ( $s_utf7 eq $s_utf8 ) {
7399 #myprint( "[$s_utf7]\n" ) ;
7400 return( "[$s_utf7]" ) ;
7401 }else{
7402 #myprint( "[$s_utf7] = [$s_utf8]\n" ) ;
7403 return( "[$s_utf7] = [$s_utf8]" ) ;
7404 }
7405}
7406
7407sub imap_utf7_decode
7408{
7409 #use utf8 ;
7410 my ( $s ) = shift ;
7411 return( Encode::IMAPUTF7::decode("IMAP-UTF-7", $s ) ) ;
7412}
7413
7414sub imap_utf7_encode
7415{
7416 #use utf8 ;
7417 my ( $s ) = shift ;
7418 return( Encode::IMAPUTF7::encode("IMAP-UTF-7", $s ) ) ;
7419}
7420
7421
7422
7423sub imap_utf7_encode_old
7424{
7425 my ( $s ) = @_ ;
7426
7427 $s = Unicode::String::utf8( $s )->utf7 ;
7428
7429 $s =~ s/\+([^\/&\-]*)\/([^\/\-&]*)\-/\+$1,$2\-/xg ;
7430 $s =~ s/&/&\-/xg ;
7431 $s =~ s/\+([^+\-]+)?\-/&$1\-/xg ;
7432 return( $s ) ;
7433}
7434
7435
7436
7437
7438sub select_folder
7439{
7440 my ( $mysync, $imap, $folder, $hostside ) = @_ ;
7441 if ( ! $imap->select( $folder ) ) {
7442 my $error = join q{},
7443 "$hostside folder $folder: Could not select: ",
7444 $imap->LastError, "\n" ;
7445 errors_incr( $mysync, $error ) ;
7446 return( 0 ) ;
7447 }else{
7448 # ok select succeeded
7449 return( 1 ) ;
7450 }
7451}
7452
7453sub examine_folder
7454{
7455 my ( $mysync, $imap, $folder, $hostside ) = @_ ;
7456 if ( ! $imap->examine( $folder ) ) {
7457 my $error = join q{},
7458 "$hostside folder $folder: Could not examine: ",
7459 $imap->LastError, "\n" ;
7460 errors_incr( $mysync, $error ) ;
7461 return( 0 ) ;
7462 }else{
7463 # ok select succeeded
7464 return( 1 ) ;
7465 }
7466}
7467
7468
7469sub count_from_select
7470{
7471 my @lines = @ARG ;
7472 my $count ;
7473 foreach my $line ( @lines ) {
7474 #myprint( "line = [$line]\n" ) ;
7475 if ( $line =~ m/^\*\s+(\d+)\s+EXISTS/x ) {
7476 $count = $1 ;
7477 return( $count ) ;
7478 }
7479 }
7480 return( undef ) ;
7481}
7482
7483
7484
7485sub create_folder_old
7486{
7487 my $mysync = shift @ARG ;
7488 my( $imap, $h2_fold, $h1_fold ) = @ARG ;
7489
7490 myprint( "Creating (old way) folder [$h2_fold] on host2\n" ) ;
7491 if ( ( 'INBOX' eq uc $h2_fold )
7492 and ( $imap->exists( $h2_fold ) ) ) {
7493 myprint( "Folder [$h2_fold] already exists\n" ) ;
7494 return( 1 ) ;
7495 }
7496 if ( ! $mysync->{dry} ){
7497 if ( ! $imap->create( $h2_fold ) ) {
7498 my $error = join q{},
7499 "Could not create folder [$h2_fold] from [$h1_fold]: ",
7500 $imap->LastError( ), "\n" ;
7501 errors_incr( $mysync, $error ) ;
7502 # success if folder exists ("already exists" error)
7503 return( 1 ) if $imap->exists( $h2_fold ) ;
7504 # failure since create failed
7505 return( 0 ) ;
7506 }else{
7507 #create succeeded
7508 myprint( "Created ( the old way ) folder [$h2_fold] on host2\n" ) ;
7509 return( 1 ) ;
7510 }
7511 }else{
7512 # dry mode, no folder so many imap will fail, assuming failure
7513 myprint( "Created ( the old way ) folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ;
7514 return( 0 ) ;
7515 }
7516}
7517
7518
7519sub create_folder
7520{
7521 my $mysync = shift @ARG ;
7522 my( $myimap2 , $h2_fold , $h1_fold ) = @ARG ;
7523 my( @parts , $parent ) ;
7524
7525 if ( $myimap2->IsUnconnected( ) ) {
7526 myprint( "Host2: Unconnected state\n" ) ;
7527 return( 0 ) ;
7528 }
7529
7530 if ( $create_folder_old ) {
7531 return( create_folder_old( $mysync, $myimap2 , $h2_fold , $h1_fold ) ) ;
7532 }
7533 myprint( "Creating folder [$h2_fold] on host2\n" ) ;
7534 if ( ( 'INBOX' eq uc $h2_fold )
7535 and ( $myimap2->exists( $h2_fold ) ) ) {
7536 myprint( "Folder [$h2_fold] already exists\n" ) ;
7537 return( 1 ) ;
7538 }
7539
7540 if ( $mixfolders and $myimap2->exists( $h2_fold ) ) {
7541 myprint( "Folder [$h2_fold] already exists (--nomixfolders is not set)\n" ) ;
7542 return( 1 ) ;
7543 }
7544
7545
7546 if ( ( not $mixfolders ) and ( $myimap2->exists( $h2_fold ) ) ) {
7547 myprint( "Folder [$h2_fold] already exists and --nomixfolders is set\n" ) ;
7548 return( 0 ) ;
7549 }
7550
7551 @parts = split /\Q$mysync->{ h2_sep }\E/x, $h2_fold ;
7552 pop @parts ;
7553 $parent = join $mysync->{ h2_sep }, @parts ;
7554 $parent =~ s/^\s+|\s+$//xg ;
7555 if ( ( $parent ne q{} ) and ( ! $myimap2->exists( $parent ) ) ) {
7556 create_folder( $mysync, $myimap2 , $parent , $h1_fold ) ;
7557 }
7558
7559 if ( ! $mysync->{dry} ) {
7560 if ( ! $myimap2->create( $h2_fold ) ) {
7561 my $error = join q{},
7562 "Could not create folder [$h2_fold] from [$h1_fold]: " ,
7563 $myimap2->LastError( ), "\n" ;
7564 errors_incr( $mysync, $error ) ;
7565 # success if folder exists ("already exists" error)
7566 return( 1 ) if $myimap2->exists( $h2_fold ) ;
7567 # failure since create failed
7568 return( 0 ) ;
7569 }else{
7570 #create succeeded
7571 myprint( "Created folder [$h2_fold] on host2\n" ) ;
7572 return( 1 ) ;
7573 }
7574 }else{
7575 # dry mode, no folder so many imap will fail, assuming failure
7576 myprint( "Created folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ;
7577 if ( ! $mysync->{ justfolders } ) {
7578 myprint( "Since --dry mode is on and folder [$h2_fold] on host2 does not exist yet, syncing messages will not be simulated.\n"
7579 . "To simulate message syncing, use --justfolders without --dry to first create the missing folders then rerun the --dry sync.\n" ) ;
7580 }
7581 return( 0 ) ;
7582 }
7583}
7584
7585
7586
7587sub tests_folder_routines
7588{
7589 note( 'Entering tests_folder_routines()' ) ;
7590
7591 ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 1' );
7592 ok( add_to_requested_folders('folder_foo'), 'add_to_requested_folders folder_foo' );
7593 ok( is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 2' );
7594 ok( !is_requested_folder('folder_NO_EXIST'), 'is_requested_folder folder_NO_EXIST' );
7595
7596 is_deeply( [ 'folder_foo' ], [ remove_from_requested_folders( 'folder_foo' ) ], 'removed folder_foo => folder_foo' ) ;
7597 ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 3' );
7598 my @f ;
7599 ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f" );
7600 ok( is_requested_folder('folder_bar'), 'is_requested_folder 4' );
7601 ok( is_requested_folder('folder_toto'), 'is_requested_folder 5' );
7602 ok( remove_from_requested_folders('folder_toto'), 'remove_from_requested_folders: ' );
7603 ok( !is_requested_folder('folder_toto'), 'is_requested_folder 6' );
7604
7605 is_deeply( [ 'folder_bar' ], [ remove_from_requested_folders('folder_bar') ], 'remove_from_requested_folders: empty' ) ;
7606
7607 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [] ), 'sort_requested_folders: all empty' ) ;
7608 ok( add_to_requested_folders( 'A_99', 'M_55', 'Z_11' ), 'add_to_requested_folders M_55 Z_11' );
7609 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'A_99', 'M_55', 'Z_11' ] ), 'sort_requested_folders: middle' ) ;
7610
7611
7612 @folderfirst = ( 'Z_11' ) ;
7613
7614 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'A_99', 'M_55' ] ), 'sort_requested_folders: first+middle' ) ;
7615
7616 is_deeply( [ 'Z_11', 'A_99', 'M_55' ], [ sort_requested_folders( ) ], 'sort_requested_folders: first+middle is_deeply' ) ;
7617
7618 @folderlast = ( 'A_99' ) ;
7619 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_55', 'A_99' ] ), 'sort_requested_folders: first+middle+last 1' ) ;
7620
7621 ok( add_to_requested_folders('M_55', 'M_44',), 'add_to_requested_folders M_55 M_44' ) ;
7622
7623 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_44', 'M_55', 'A_99'] ), 'sort_requested_folders: first+middle+last 2' ) ;
7624
7625
7626 ok( add_to_requested_folders('A_88', 'Z_22',), 'add_to_requested_folders A_88 Z_22' ) ;
7627 @folderfirst = qw( Z_22 Z_11 ) ;
7628 @folderlast = qw( A_99 A_88 ) ;
7629 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_22', 'Z_11', 'M_44', 'M_55', 'A_99', 'A_88' ] ), 'sort_requested_folders: first+middle+last 3' ) ;
7630 undef @folderfirst ;
7631 undef @folderlast ;
7632
7633 note( 'Leaving tests_folder_routines()' ) ;
7634 return ;
7635}
7636
7637
7638sub sort_requested_folders
7639{
7640 my @requested_folders_sorted = () ;
7641
7642 #myprint "folderfirst: @folderfirst\n" ;
7643 my @folderfirst_requested = remove_from_requested_folders( @folderfirst ) ;
7644 #myprint "folderfirst_requested: @folderfirst_requested\n" ;
7645
7646 my @folderlast_requested = remove_from_requested_folders( @folderlast ) ;
7647
7648 my @middle = sort keys %requested_folder ;
7649
7650 @requested_folders_sorted = ( @folderfirst_requested, @middle, @folderlast_requested ) ;
7651 #myprint "requested_folders_sorted: @requested_folders_sorted\n" ;
7652 add_to_requested_folders( @requested_folders_sorted ) ;
7653
7654 return( @requested_folders_sorted ) ;
7655}
7656
7657sub is_requested_folder
7658{
7659 my ( $folder ) = @_;
7660
7661 return( defined $requested_folder{ $folder } ) ;
7662}
7663
7664
7665sub add_to_requested_folders
7666{
7667 my @wanted_folders = @_ ;
7668
7669 foreach my $folder ( @wanted_folders ) {
7670 ++$requested_folder{ $folder } ;
7671 }
7672 return( keys %requested_folder ) ;
7673}
7674
7675sub tests_remove_from_requested_folders
7676{
7677 note( 'Entering tests_remove_from_requested_folders()' ) ;
7678
7679 is( undef, undef, 'remove_from_requested_folders: undef is undef' ) ;
7680 is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: no args' ) ;
7681 %requested_folder = (
7682 'F1' => 1,
7683 ) ;
7684 is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 => nothing' ) ;
7685 is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 => nothing' ) ;
7686 is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 => F1' ) ;
7687 is_deeply( { }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 => %requested_folder emptied' ) ;
7688
7689 %requested_folder = (
7690 'F1' => 1,
7691 'F2' => 1,
7692 ) ;
7693 is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 F2 => nothing' ) ;
7694 is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 F2 => nothing' ) ;
7695 is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 F2 => F1' ) ;
7696 is_deeply( { 'F2' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ;
7697
7698 is_deeply( [], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F2 => nothing' ) ;
7699 is_deeply( [ 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F2 => F2' ) ;
7700 is_deeply( {}, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ;
7701
7702 %requested_folder = (
7703 'F1' => 1,
7704 'F2' => 1,
7705 'F3' => 1,
7706 ) ;
7707 is_deeply( [ 'F1', 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => F1 F2' ) ;
7708 is_deeply( { 'F3' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => %requested_folder F3' ) ;
7709
7710
7711
7712 note( 'Leaving tests_remove_from_requested_folders()' ) ;
7713 return ;
7714}
7715
7716
7717sub remove_from_requested_folders
7718{
7719 my @unwanted_folders = @_ ;
7720
7721 my @removed_folders = () ;
7722 foreach my $folder ( @unwanted_folders ) {
7723 if ( exists $requested_folder{ $folder } )
7724 {
7725 delete $requested_folder{ $folder } ;
7726 push @removed_folders, $folder ;
7727 }
7728 }
7729 return( @removed_folders ) ;
7730}
7731
7732sub compare_lists
7733{
7734 my ($list_1_ref, $list_2_ref) = @_;
7735
7736 return($MINUS_ONE) if ((not defined $list_1_ref) and defined $list_2_ref);
7737 return(0) if ((not defined $list_1_ref) and not defined $list_2_ref); # end if no list
7738 return(1) if (not defined $list_2_ref); # end if only one list
7739
7740 if (not ref $list_1_ref ) {$list_1_ref = [$list_1_ref]};
7741 if (not ref $list_2_ref ) {$list_2_ref = [$list_2_ref]};
7742
7743
7744 my $last_used_indice = $MINUS_ONE;
7745
7746
7747 ELEMENT:
7748 foreach my $indice ( 0 .. $#{ $list_1_ref } ) {
7749 $last_used_indice = $indice ;
7750
7751 # End of list_2
7752 return 1 if ($indice > $#{ $list_2_ref } ) ;
7753
7754 my $element_list_1 = $list_1_ref->[$indice] ;
7755 my $element_list_2 = $list_2_ref->[$indice] ;
7756 my $balance = $element_list_1 cmp $element_list_2 ;
7757 next ELEMENT if ($balance == 0) ;
7758 return $balance ;
7759 }
7760 # each element equal until last indice of list_1
7761 return $MINUS_ONE if ($last_used_indice < $#{ $list_2_ref } ) ;
7762
7763 # same size, each element equal
7764 return 0 ;
7765}
7766
7767sub tests_compare_lists
7768{
7769 note( 'Entering tests_compare_lists()' ) ;
7770
7771 my $empty_list_ref = [];
7772
7773 ok( 0 == compare_lists() , 'compare_lists, no args');
7774 ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing');
7775 ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef');
7776 ok($MINUS_ONE == compare_lists(undef , []) , 'compare_lists, undef < []');
7777 ok($MINUS_ONE == compare_lists(undef , [1]) , 'compare_lists, undef < [1]');
7778 ok($MINUS_ONE == compare_lists(undef , [0]) , 'compare_lists, undef < [0]');
7779 ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing');
7780 ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef');
7781 ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []');
7782
7783 ok($MINUS_ONE == compare_lists([] , [1]) , 'compare_lists, [] < [1]');
7784 ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []');
7785
7786
7787 ok( 0 == compare_lists([1], 1 ) , 'compare_lists, [1] = 1 ') ;
7788 ok( 0 == compare_lists( 1 , [1]) , 'compare_lists, 1 = [1]') ;
7789 ok( 0 == compare_lists( 1 , 1 ) , 'compare_lists, 1 = 1 ') ;
7790 ok($MINUS_ONE == compare_lists( 0 , 1 ) , 'compare_lists, 0 < 1 ') ;
7791 ok($MINUS_ONE == compare_lists($MINUS_ONE , 0 ) , 'compare_lists, -1 < 0 ') ;
7792 ok($MINUS_ONE == compare_lists( 1 , 2 ) , 'compare_lists, 1 < 2 ') ;
7793 ok(+1 == compare_lists( 2 , 1 ) , 'compare_lists, 2 > 1 ') ;
7794
7795
7796 ok( 0 == compare_lists([1,2], [1,2]) , 'compare_lists, [1,2] = [1,2]' ) ;
7797 ok($MINUS_ONE == compare_lists([1], [1,2]) , 'compare_lists, [1] < [1,2]' ) ;
7798 ok(+1 == compare_lists([2], [1,2]) , 'compare_lists, [2] > [1,2]' ) ;
7799 ok($MINUS_ONE == compare_lists([1], [1,1]) , 'compare_lists, [1] < [1,1]' ) ;
7800 ok(+1 == compare_lists([1, 1], [1]) , 'compare_lists, [1, 1] > [1]' ) ;
7801 ok( 0 == compare_lists([1 .. $NUMBER_20_000] , [1 .. $NUMBER_20_000])
7802 , 'compare_lists, [1..20_000] = [1..20_000]' ) ;
7803 ok($MINUS_ONE == compare_lists([1], [2]) , 'compare_lists, [1] < [2]') ;
7804 ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ;
7805 ok(+1 == compare_lists([2], [1]) , 'compare_lists, [2] > [1]') ;
7806
7807 ok($MINUS_ONE == compare_lists(['a'], ['b']) , 'compare_lists, ["a"] < ["b"]') ;
7808 ok( 0 == compare_lists(['a'], ['a']) , 'compare_lists, ["a"] = ["a"]') ;
7809 ok( 0 == compare_lists(['ab'], ['ab']) , 'compare_lists, ["ab"] = ["ab"]') ;
7810 ok(+1 == compare_lists(['b'], ['a']) , 'compare_lists, ["b"] > ["a"]') ;
7811 ok($MINUS_ONE == compare_lists(['a'], ['aa']) , 'compare_lists, ["a"] < ["aa"]') ;
7812 ok($MINUS_ONE == compare_lists(['a'], ['a', 'a']), 'compare_lists, ["a"] < ["a", "a"]') ;
7813 ok( 0 == compare_lists([split q{ }, 'a b' ], ['a', 'b']), 'compare_lists, split') ;
7814 ok( 0 == compare_lists([sort split q{ }, 'b a' ], ['a', 'b']), 'compare_lists, sort split') ;
7815
7816 note( 'Leaving tests_compare_lists()' ) ;
7817 return ;
7818}
7819
7820
7821sub guess_prefix
7822{
7823 my @foldernames = @_ ;
7824
7825 my $prefix_guessed = q{} ;
7826 foreach my $folder ( @foldernames ) {
7827 next if ( $folder =~ m{^INBOX$}xi ) ; # no guessing from INBOX
7828 if ( $folder !~ m{^INBOX}xi ) {
7829 $prefix_guessed = q{} ; # prefix empty guessed
7830 last ;
7831 }
7832 if ( $folder =~ m{^(INBOX(?:\.|\/))}xi ) {
7833 $prefix_guessed = $1 ; # prefix Inbox/ or INBOX. guessed
7834 }
7835 }
7836 return( $prefix_guessed ) ;
7837}
7838
7839sub tests_guess_prefix
7840{
7841 note( 'Entering tests_guess_prefix()' ) ;
7842
7843 is( guess_prefix( ), q{}, 'guess_prefix: no args => empty string' ) ;
7844 is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ;
7845 is( q{} , guess_prefix( 'Inbox' ), 'guess_prefix: Inbox alone' ) ;
7846 is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ;
7847 is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk' ), 'guess_prefix: INBOX INBOX/Junk' ) ;
7848 is( 'INBOX.' , guess_prefix( 'INBOX', 'INBOX.Junk' ), 'guess_prefix: INBOX INBOX.Junk' ) ;
7849 is( 'Inbox/' , guess_prefix( 'Inbox', 'Inbox/Junk' ), 'guess_prefix: Inbox Inbox/Junk' ) ;
7850 is( 'Inbox.' , guess_prefix( 'Inbox', 'Inbox.Junk' ), 'guess_prefix: Inbox Inbox.Junk' ) ;
7851 is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr' ) ;
7852 is( q{} , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr', 'zzz' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr zzz' ) ;
7853 is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ;
7854 is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ;
7855
7856 note( 'Leaving tests_guess_prefix()' ) ;
7857 return ;
7858}
7859
7860sub get_prefix
7861{
7862 my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @_ ;
7863 my( $prefix_out, $prefix_guessed ) ;
7864
7865 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting prefix\n" ) ;
7866 $prefix_guessed = guess_prefix( @{ $folders_ref } ) ;
7867 myprint( "$Side: guessing prefix from folder listing: [$prefix_guessed]\n" ) ;
7868 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Calling namespace capability\n" ) ;
7869 if ( $imap->has_capability( 'namespace' ) ) {
7870 my $r_namespace = $imap->namespace( ) ;
7871 $prefix_out = $r_namespace->[0][0][0] ;
7872 myprint( "$Side: prefix given by NAMESPACE: [$prefix_out]\n" ) ;
7873 if ( defined $prefix_in ) {
7874 myprint( "$Side: but using [$prefix_in] given by $prefix_opt\n" ) ;
7875 $prefix_out = $prefix_in ;
7876 return( $prefix_out ) ;
7877 }else{
7878 # all good
7879 return( $prefix_out ) ;
7880 }
7881 }
7882 else{
7883 if ( defined $prefix_in ) {
7884 myprint( "$Side: using [$prefix_in] given by $prefix_opt\n" ) ;
7885 $prefix_out = $prefix_in ;
7886 return( $prefix_out ) ;
7887 }else{
7888 myprint(
7889 "$Side: No NAMESPACE capability so using guessed prefix [$prefix_guessed]\n",
7890 help_to_guess_prefix( $imap, $prefix_opt ) ) ;
7891 return( $prefix_guessed ) ;
7892 }
7893 }
7894 return ;
7895}
7896
7897
7898sub guess_separator
7899{
7900 my @foldernames = @_ ;
7901
7902 #return( undef ) unless ( @foldernames ) ;
7903
7904 my $sep_guessed ;
7905 my %counter ;
7906 foreach my $folder ( @foldernames ) {
7907 $counter{'/'}++ while ( $folder =~ m{/}xg ) ; # count /
7908 $counter{'.'}++ while ( $folder =~ m{\.}xg ) ; # count .
7909 $counter{'\\\\'}++ while ( $folder =~ m{(\\){2}}xg ) ; # count \\
7910 $counter{'\\'}++ while ( $folder =~ m{[^\\](\\){1}(?=[^\\])}xg ) ; # count \
7911 }
7912 my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ;
7913 $sync->{ debug } and myprint( "@foldernames\n@race_sorted\n", %counter, "\n" ) ;
7914 $sep_guessed = shift @race_sorted || $LAST_RESSORT_SEPARATOR ; # / when nothing found.
7915 return( $sep_guessed ) ;
7916}
7917
7918sub tests_guess_separator
7919{
7920 note( 'Entering tests_guess_separator()' ) ;
7921
7922 ok( '/' eq guess_separator( ), 'guess_separator: no args' ) ;
7923 ok( '/' eq guess_separator( 'abcd' ), 'guess_separator: abcd' ) ;
7924 ok( '/' eq guess_separator( 'a/b/c.d' ), 'guess_separator: a/b/c.d' ) ;
7925 ok( '.' eq guess_separator( 'a.b/c.d' ), 'guess_separator: a.b/c.d' ) ;
7926 ok( '\\\\' eq guess_separator( 'a\\\\b\\\\c.c\\\\d/e/f' ), 'guess_separator: a\\\\b\\\\c.c\\\\d/e/f' ) ;
7927 ok( '\\' eq guess_separator( 'a\\b\\c.c\\d/e/f' ), 'guess_separator: a\\b\\c.c\\d/e/f' ) ;
7928 ok( '\\' eq guess_separator( 'a\\b' ), 'guess_separator: a\\b' ) ;
7929 ok( '\\' eq guess_separator( 'a\\b\\c' ), 'guess_separator: a\\b\\c' ) ;
7930
7931 note( 'Leaving tests_guess_separator()' ) ;
7932 return ;
7933}
7934
7935sub get_separator
7936{
7937 my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @_ ;
7938 my( $sep_out, $sep_guessed ) ;
7939
7940 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting separator\n" ) ;
7941 $sep_guessed = guess_separator( @{ $folders_ref } ) ;
7942 myprint( "$Side: guessing separator from folder listing: [$sep_guessed]\n" ) ;
7943
7944 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: calling namespace capability\n" ) ;
7945 if ( $imap->has_capability( 'namespace' ) )
7946 {
7947 $sep_out = $imap->separator( ) ;
7948 if ( defined $sep_out ) {
7949 myprint( "$Side: separator given by NAMESPACE: [$sep_out]\n" ) ;
7950 if ( defined $sep_in ) {
7951 myprint( "$Side: but using [$sep_in] given by $sep_opt\n" ) ;
7952 $sep_out = $sep_in ;
7953 return( $sep_out ) ;
7954 }else{
7955 return( $sep_out ) ;
7956 }
7957 }else{
7958 if ( defined $sep_in ) {
7959 myprint( "$Side: NAMESPACE request failed but using [$sep_in] given by $sep_opt\n" ) ;
7960 $sep_out = $sep_in ;
7961 return( $sep_out ) ;
7962 }else{
7963 myprint(
7964 "$Side: NAMESPACE request failed so using guessed separator [$sep_guessed]\n",
7965 help_to_guess_sep( $imap, $sep_opt ) ) ;
7966 return( $sep_guessed ) ;
7967 }
7968 }
7969 }
7970 else
7971 {
7972 if ( defined $sep_in ) {
7973 myprint( "$Side: No NAMESPACE capability but using [$sep_in] given by $sep_opt\n" ) ;
7974 $sep_out = $sep_in ;
7975 return( $sep_out ) ;
7976 }else{
7977 myprint(
7978 "$Side: No NAMESPACE capability, so using guessed separator [$sep_guessed]\n",
7979 help_to_guess_sep( $imap, $sep_opt ) ) ;
7980 return( $sep_guessed ) ;
7981 }
7982 }
7983 return ;
7984}
7985
7986sub help_to_guess_sep
7987{
7988 my( $imap, $sep_opt ) = @_ ;
7989
7990 my $help_to_guess_sep = "You can set the separator character with the $sep_opt option,\n"
7991 . "the complete listing of folders may help you to find it\n"
7992 . folders_list_to_help( $imap ) ;
7993
7994 return( $help_to_guess_sep ) ;
7995}
7996
7997sub help_to_guess_prefix
7998{
7999 my( $imap, $prefix_opt ) = @_ ;
8000
8001 my $help_to_guess_prefix = "You can set the prefix namespace with the $prefix_opt option,\n"
8002 . "the folowing listing of folders may help you to find it:\n"
8003 . folders_list_to_help( $imap ) ;
8004
8005 return( $help_to_guess_prefix ) ;
8006}
8007
8008
8009sub folders_list_to_help
8010{
8011 my( $imap ) = shift ;
8012
8013 my @folders = $imap->folders ;
8014 my $listing = join q{}, map { "[$_]\n" } @folders ;
8015 return( $listing ) ;
8016}
8017
8018sub private_folders_separators_and_prefixes
8019{
8020# what are the private folders separators and prefixes for each server ?
8021
8022 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Getting separators\n" ) ;
8023 $sync->{ h1_sep } = get_separator( $sync->{imap1}, $sync->{ sep1 }, '--sep1', 'Host1', \@h1_folders_all ) ;
8024 $sync->{ h2_sep } = get_separator( $sync->{imap2}, $sync->{ sep2 }, '--sep2', 'Host2', \@h2_folders_all ) ;
8025
8026
8027 $sync->{ h1_prefix } = get_prefix( $sync->{imap1}, $prefix1, '--prefix1', 'Host1', \@h1_folders_all ) ;
8028 $sync->{ h2_prefix } = get_prefix( $sync->{imap2}, $prefix2, '--prefix2', 'Host2', \@h2_folders_all ) ;
8029
8030 myprint( "Host1: separator and prefix: [$sync->{ h1_sep }][$sync->{ h1_prefix }]\n" ) ;
8031 myprint( "Host2: separator and prefix: [$sync->{ h2_sep }][$sync->{ h2_prefix }]\n" ) ;
8032 return ;
8033}
8034
8035
8036sub subfolder1
8037{
8038 my $mysync = shift ;
8039 my $subfolder1 = sanitize_subfolder( $mysync->{ subfolder1 } ) ;
8040
8041 if ( $subfolder1 )
8042 {
8043 # turns off automap
8044 myprint( "Turning off automapping folders because of --subfolder1\n" ) ;
8045 $mysync->{ automap } = undef ;
8046 myprint( "Sanitizing subfolder1: [$mysync->{ subfolder1 }] => [$subfolder1]\n" ) ;
8047 $mysync->{ subfolder1 } = $subfolder1 ;
8048 if ( ! add_subfolder1_to_folderrec( $mysync ) )
8049 {
8050 $mysync->{nb_errors}++ ;
8051 exit_clean( $mysync, $EXIT_SUBFOLDER1_NO_EXISTS, "subfolder1 $subfolder1 does not exist\n" ) ;
8052 }
8053 }
8054 else
8055 {
8056 $mysync->{ subfolder1 } = undef ;
8057 }
8058
8059 return ;
8060}
8061
8062sub subfolder2
8063{
8064 my $mysync = shift ;
8065 my $subfolder2 = sanitize_subfolder( $mysync->{ subfolder2 } ) ;
8066 if ( $subfolder2 )
8067 {
8068 # turns off automap
8069 myprint( "Turning off automapping folders because of --subfolder2\n" ) ;
8070 $mysync->{ automap } = undef ;
8071 myprint( "Sanitizing subfolder2: [$mysync->{ subfolder2 }] => [$subfolder2]\n" ) ;
8072 $mysync->{ subfolder2 } = $subfolder2 ;
8073 set_regextrans2_for_subfolder2( $mysync ) ;
8074 }
8075 else
8076 {
8077 $mysync->{ subfolder2 } = undef ;
8078 }
8079
8080 return ;
8081}
8082
8083sub tests_sanitize_subfolder
8084{
8085 note( 'Entering tests_sanitize_subfolder()' ) ;
8086
8087 is( undef, sanitize_subfolder( ), 'sanitize_subfolder: no args => undef' ) ;
8088 is( undef, sanitize_subfolder( q{} ), 'sanitize_subfolder: empty => undef' ) ;
8089 is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blank => undef' ) ;
8090 is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blanks => undef' ) ;
8091 is( 'abcd', sanitize_subfolder( 'abcd' ), 'sanitize_subfolder: abcd => abcd' ) ;
8092 is( 'ab cd', sanitize_subfolder( ' ab cd ' ), 'sanitize_subfolder: " ab cd " => "ab cd"' ) ;
8093 is( 'abcd', sanitize_subfolder( q{a&~b#\\c[]=d;} ), 'sanitize_subfolder: "a&~b#\\c[]=d;" => "abcd"' ) ;
8094 is( 'aA.b-_ 8c/dD', sanitize_subfolder( 'aA.b-_ 8c/dD' ), 'sanitize_subfolder: aA.b-_ 8c/dD => aA.b-_ 8c/dD' ) ;
8095 note( 'Leaving tests_sanitize_subfolder()' ) ;
8096 return ;
8097}
8098
8099
8100sub sanitize_subfolder
8101{
8102 my $subfolder = shift ;
8103
8104 if ( ! $subfolder )
8105 {
8106 return ;
8107 }
8108 # Remove edging blanks
8109 $subfolder =~ s,^ +| +$,,g ;
8110 # Keep only abcd...ABCD...0123... and -_./
8111 $subfolder =~ tr,-_a-zA-Z0-9./ ,,cd ;
8112
8113 # A blank subfolder is not a subfolder
8114 if ( ! $subfolder )
8115 {
8116 return ;
8117 }
8118 else
8119 {
8120 return $subfolder ;
8121 }
8122}
8123
8124
8125
8126
8127
8128sub tests_add_subfolder1_to_folderrec
8129{
8130 note( 'Entering tests_add_subfolder1_to_folderrec()' ) ;
8131
8132 is( undef, add_subfolder1_to_folderrec( ), 'add_subfolder1_to_folderrec: undef => undef' ) ;
8133 is_deeply( [], [ add_subfolder1_to_folderrec( ) ], 'add_subfolder1_to_folderrec: no args => empty array' ) ;
8134 @folderrec = () ;
8135 my $mysync = {} ;
8136 is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: empty => empty array' ) ;
8137 is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: empty => empty folderrec' ) ;
8138 $mysync->{ subfolder1 } = 'SUBI' ;
8139 $h1_folders_all{ 'SUBI' } = 1 ;
8140 $mysync->{ h1_prefix } = 'INBOX/' ;
8141 is_deeply( [ 'SUBI' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBI => SUBI' ) ;
8142 is_deeply( [ 'SUBI' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBI => folderrec SUBI ' ) ;
8143
8144 @folderrec = () ;
8145 $mysync->{ subfolder1 } = 'SUBO' ;
8146 is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO no exists => empty array' ) ;
8147 is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO no exists => empty folderrec' ) ;
8148 $h1_folders_all{ 'INBOX/SUBO' } = 1 ;
8149 is_deeply( [ 'INBOX/SUBO' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO' ) ;
8150 is_deeply( [ 'INBOX/SUBO' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO folderrec' ) ;
8151
8152 note( 'Leaving tests_add_subfolder1_to_folderrec()' ) ;
8153 return ;
8154}
8155
8156
8157sub add_subfolder1_to_folderrec
8158{
8159 my $mysync = shift ;
8160 if ( ! $mysync || ! $mysync->{ subfolder1 } )
8161 {
8162 return ;
8163 }
8164
8165 my $subfolder1 = $mysync->{ subfolder1 } ;
8166 my $subfolder1_extended = $mysync->{ h1_prefix } . $subfolder1 ;
8167
8168 if ( exists $h1_folders_all{ $subfolder1 } )
8169 {
8170 myprint( qq{Acting like --folderrec "$subfolder1"\n} ) ;
8171 push @folderrec, $subfolder1 ;
8172 }
8173 elsif ( exists $h1_folders_all{ $subfolder1_extended } )
8174 {
8175 myprint( qq{Acting like --folderrec "$subfolder1_extended"\n} ) ;
8176 push @folderrec, $subfolder1_extended ;
8177 }
8178 else
8179 {
8180 myprint( qq{Nor folder "$subfolder1" nor "$subfolder1_extended" exists on host1\n} ) ;
8181 }
8182 return @folderrec ;
8183}
8184
8185sub set_regextrans2_for_subfolder2
8186{
8187 my $mysync = shift ;
8188
8189
8190 unshift @{ $mysync->{ regextrans2 } },
8191 q(s,^$mysync->{ h2_prefix }(.*),$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }$1,),
8192 q(s,^INBOX$,$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }INBOX,),
8193 q(s,^($mysync->{ h2_prefix }){2},$mysync->{ h2_prefix },);
8194
8195 #myprint( "@{ $mysync->{ regextrans2 } }\n" ) ;
8196 return ;
8197}
8198
8199
8200
8201# Looks like no globals here
8202
8203sub tests_imap2_folder_name
8204{
8205 note( 'Entering tests_imap2_folder_name()' ) ;
8206
8207 my $mysync = {} ;
8208 $mysync->{ h1_prefix } = q{} ;
8209 $mysync->{ h2_prefix } = q{} ;
8210 $mysync->{ h1_sep } = '/';
8211 $mysync->{ h2_sep } = '.';
8212
8213 $mysync->{ debug } and myprint( <<"EOS"
8214prefix1: [$mysync->{ h1_prefix }]
8215prefix2: [$mysync->{ h2_prefix }]
8216sep1: [$sync->{ h1_sep }]
8217sep2: [$sync->{ h2_sep }]
8218EOS
8219) ;
8220
8221 $mysync->{ fixslash2 } = 0 ;
8222 is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string' ) ;
8223 is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ;
8224 is('spam.spam', imap2_folder_name( $mysync, 'spam/spam' ), 'imap2_folder_name: spam/spam' ) ;
8225
8226 is( 'spam/spam', imap2_folder_name( $mysync, 'spam.spam' ), 'imap2_folder_name: spam.spam') ;
8227 is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam' ) ;
8228 is( 's pam.spam/sp am', imap2_folder_name( $mysync, 's pam/spam.sp am' ), 'imap2_folder_name: s pam/spam.sp am' ) ;
8229
8230 $mysync->{f1f2h}{ 'auto' } = 'moto' ;
8231 is( 'moto', imap2_folder_name( $mysync, 'auto' ), 'imap2_folder_name: auto' ) ;
8232 $mysync->{f1f2h}{ 'auto/auto' } = 'moto x 2' ;
8233 is( 'moto x 2', imap2_folder_name( $mysync, 'auto/auto' ), 'imap2_folder_name: auto/auto' ) ;
8234
8235 @{ $mysync->{ regextrans2 } } = ( 's,/,X,g' ) ;
8236 is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string [s,/,X,g]' ) ;
8237 is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla [s,/,X,g]' ) ;
8238 is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam [s,/,X,g]');
8239 is('spamXspam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam [s,/,X,g]');
8240 is('spam.spamXspam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam [s,/,X,g]');
8241
8242 @{ $mysync->{ regextrans2 } } = ( 's, ,_,g' ) ;
8243 is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla [s, ,_,g]');
8244 is('bla_bla', imap2_folder_name( $mysync, 'bla bla'), 'imap2_folder_name: blabla [s, ,_,g]');
8245
8246 @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ;
8247 is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), q{imap2_folder_name: blabla [s,\U(.*)\E,$1,]} ) ;
8248
8249 $mysync->{ fixslash2 } = 1 ;
8250 @{ $mysync->{ regextrans2 } } = ( ) ;
8251 is(q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string');
8252 is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla');
8253 is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam');
8254 is('spam_spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam_spam');
8255 is('spam.spam_spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam_spam');
8256 is('s pam.spam_spa m', imap2_folder_name( $mysync, 's pam/spam.spa m'), 'imap2_folder_name: s pam/spam.spa m -> s pam.spam_spa m');
8257
8258 $mysync->{ h1_sep } = '.';
8259 $mysync->{ h2_sep } = '/';
8260 is( q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string');
8261 is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla');
8262 is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam');
8263 is('spam/spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam/spam');
8264 is('spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam');
8265
8266
8267
8268 $mysync->{ fixslash2 } = 0 ;
8269 $mysync->{ h1_prefix } = q{ };
8270
8271 is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ;
8272 is( 'spam.spam/spam', imap2_folder_name( $mysync, ' spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ;
8273
8274 $mysync->{ h1_sep } = '.' ;
8275 $mysync->{ h2_sep } = '/' ;
8276 $mysync->{ h1_prefix } = 'INBOX.' ;
8277 $mysync->{ h2_prefix } = q{} ;
8278 @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ;
8279 is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ;
8280 is( 'TEST/TEST/TEST/TEST', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ;
8281 @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\L$1,} ) ;
8282 is( 'test/test/test/test', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ;
8283
8284 # INBOX
8285 $mysync = {} ;
8286 $mysync->{ h1_prefix } = q{Pf1.} ;
8287 $mysync->{ h2_prefix } = q{Pf2/} ;
8288 $mysync->{ h1_sep } = '.';
8289 $mysync->{ h2_sep } = '/';
8290
8291 #
8292 #$mysync->{ debug } = 1 ;
8293 is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'F1.F2.F3' ), 'imap2_folder_name: F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
8294 is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'F1.INBOX' ), 'imap2_folder_name: F1.INBOX -> Pf2/F1/INBOX' ) ;
8295 is( 'INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> INBOX' ) ;
8296
8297 is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.F1.F2.F3' ), 'imap2_folder_name: Pf1.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
8298 is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'Pf1.F1.INBOX' ), 'imap2_folder_name: Pf1.F1.INBOX -> Pf2/F1/INBOX' ) ;
8299 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.INBOX' ), 'imap2_folder_name: Pf1.INBOX -> INBOX' ) ; # not Pf2/INBOX: Yes I can!
8300
8301
8302
8303 # subfolder2
8304 $mysync = {} ;
8305 $mysync->{ h1_prefix } = q{} ;
8306 $mysync->{ h2_prefix } = q{} ;
8307 $mysync->{ h1_sep } = '/';
8308 $mysync->{ h2_sep } = '.';
8309
8310
8311 set_regextrans2_for_subfolder2( $mysync ) ;
8312 $mysync->{ subfolder2 } = 'S1.S2' ;
8313 is( 'S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.F1.F2.F3' ) ;
8314 is( 'S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.INBOX' ) ;
8315
8316 $mysync = {} ;
8317 $mysync->{ h1_prefix } = q{Pf1/} ;
8318 $mysync->{ h2_prefix } = q{Pf2.} ;
8319 $mysync->{ h1_sep } = '/';
8320 $mysync->{ h2_sep } = '.';
8321 #$mysync->{ debug } = 1 ;
8322
8323 set_regextrans2_for_subfolder2( $mysync ) ;
8324 $mysync->{ subfolder2 } = 'Pf2.S1.S2' ;
8325 is( 'Pf2.S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> Pf2.S1.S2.F1.F2.F3' ) ;
8326 is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ;
8327 is( 'Pf2.S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'Pf1/F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> Pf2.S1.S2.F1.F2.F3' ) ;
8328 is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'Pf1/INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ;
8329
8330 # subfolder1
8331 # scenario as the reverse of the previous tests, separators point of vue
8332 $mysync = {} ;
8333 $mysync->{ h1_prefix } = q{Pf1.} ;
8334 $mysync->{ h2_prefix } = q{Pf2/} ;
8335 $mysync->{ h1_sep } = '.';
8336 $mysync->{ h2_sep } = '/';
8337 #$mysync->{ debug } = 1 ;
8338
8339 $mysync->{ subfolder1 } = 'S1.S2' ;
8340 is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'S1.S2.F1.F2.F3' ), 'imap2_folder_name: S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
8341 is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.S1.S2.F1.F2.F3' ), 'imap2_folder_name: Pf1.S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
8342
8343 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ;
8344 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ;
8345 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ;
8346
8347 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ;
8348 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ;
8349 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ;
8350
8351
8352 $mysync->{ subfolder1 } = 'S1.S2.' ;
8353 is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'S1.S2.F1.F2.F3' ), 'imap2_folder_name: S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
8354 is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.S1.S2.F1.F2.F3' ), 'imap2_folder_name: Pf1.S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ;
8355
8356 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ;
8357 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ;
8358 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ;
8359
8360 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ;
8361 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ;
8362 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ;
8363
8364
8365 # subfolder1
8366 # scenario as Gmail
8367 $mysync = {} ;
8368 $mysync->{ h1_prefix } = q{} ;
8369 $mysync->{ h2_prefix } = q{} ;
8370 $mysync->{ h1_sep } = '/';
8371 $mysync->{ h2_sep } = '/';
8372 #$mysync->{ debug } = 1 ;
8373
8374 $mysync->{ subfolder1 } = 'S1/S2' ;
8375 is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ;
8376 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ;
8377 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ;
8378 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ;
8379
8380 $mysync->{ subfolder1 } = 'S1/S2/' ;
8381 is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ;
8382 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ;
8383 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ;
8384 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ;
8385
8386
8387 note( 'Leaving tests_imap2_folder_name()' ) ;
8388 return ;
8389}
8390
8391
8392# Global variables to remove:
8393# None?
8394
8395
8396sub imap2_folder_name
8397{
8398 my $mysync = shift ;
8399 my ( $h1_fold ) = shift ;
8400 my ( $h2_fold ) ;
8401 if ( $mysync->{f1f2h}{ $h1_fold } ) {
8402 $h2_fold = $mysync->{f1f2h}{ $h1_fold } ;
8403 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "f1f2 [$h1_fold] -> [$h2_fold]\n" ) ;
8404 return( $h2_fold ) ;
8405 }
8406 if ( $mysync->{f1f2auto}{ $h1_fold } ) {
8407 $h2_fold = $mysync->{f1f2auto}{ $h1_fold } ;
8408 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "automap [$h1_fold] -> [$h2_fold]\n" ) ;
8409 return( $h2_fold ) ;
8410 }
8411
8412 if ( $mysync->{ subfolder1 } )
8413 {
8414 my $esc_h1_sep = "\\" . $mysync->{ h1_sep } ;
8415 # case where subfolder1 has the sep1 at the end, then remove it
8416 my $part_to_removed = remove_last_char_if_is( $mysync->{ subfolder1 }, $mysync->{ h1_sep } ) ;
8417 # remove the subfolder1 part and the sep1 if present after
8418 $h1_fold =~ s{$part_to_removed($esc_h1_sep)?}{} ;
8419 #myprint( "h1_fold=$h1_fold\n" ) ;
8420 }
8421
8422 if ( ( q{} eq $h1_fold ) or ( $mysync->{ h1_prefix } eq $h1_fold ) )
8423 {
8424 $h1_fold = 'INBOX' ;
8425 }
8426
8427 $h2_fold = prefix_seperator_invertion( $mysync, $h1_fold ) ;
8428 $h2_fold = regextrans2( $mysync, $h2_fold ) ;
8429 return( $h2_fold ) ;
8430}
8431
8432
8433sub tests_remove_last_char_if_is
8434{
8435 note( 'Entering tests_remove_last_char_if_is()' ) ;
8436
8437 is( undef, remove_last_char_if_is( ), 'remove_last_char_if_is: no args => undef' ) ;
8438 is( q{}, remove_last_char_if_is( q{} ), 'remove_last_char_if_is: empty => empty' ) ;
8439 is( q{}, remove_last_char_if_is( q{}, 'Z' ), 'remove_last_char_if_is: empty Z => empty' ) ;
8440 is( q{}, remove_last_char_if_is( 'Z', 'Z' ), 'remove_last_char_if_is: Z Z => empty' ) ;
8441 is( 'abc', remove_last_char_if_is( 'abcZ', 'Z' ), 'remove_last_char_if_is: abcZ Z => abc' ) ;
8442 is( 'abcY', remove_last_char_if_is( 'abcY', 'Z' ), 'remove_last_char_if_is: abcY Z => abcY' ) ;
8443 note( 'Leaving tests_remove_last_char_if_is()' ) ;
8444 return ;
8445}
8446
8447
8448
8449
8450sub remove_last_char_if_is
8451{
8452 my $string = shift ;
8453 my $char = shift ;
8454
8455 if ( ! defined $string )
8456 {
8457 return ;
8458 }
8459
8460 if ( ! defined $char )
8461 {
8462 return $string ;
8463 }
8464
8465 my $last_char = substr $string, -1 ;
8466 if ( $char eq $last_char )
8467 {
8468 chop $string ;
8469 return $string ;
8470 }
8471 else
8472 {
8473 return $string ;
8474 }
8475}
8476
8477sub tests_prefix_seperator_invertion
8478{
8479 note( 'Entering tests_prefix_seperator_invertion()' ) ;
8480
8481 is( undef, prefix_seperator_invertion( ), 'prefix_seperator_invertion: no args => undef' ) ;
8482 is( q{}, prefix_seperator_invertion( undef, q{} ), 'prefix_seperator_invertion: empty string => empty string' ) ;
8483 is( 'lalala', prefix_seperator_invertion( undef, 'lalala' ), 'prefix_seperator_invertion: lalala => lalala' ) ;
8484 is( 'lal/ala', prefix_seperator_invertion( undef, 'lal/ala' ), 'prefix_seperator_invertion: lal/ala => lal/ala' ) ;
8485 is( 'lal.ala', prefix_seperator_invertion( undef, 'lal.ala' ), 'prefix_seperator_invertion: lal.ala => lal.ala' ) ;
8486 is( '////', prefix_seperator_invertion( undef, '////' ), 'prefix_seperator_invertion: //// => ////' ) ;
8487 is( '.....', prefix_seperator_invertion( undef, '.....' ), 'prefix_seperator_invertion: ..... => .....' ) ;
8488
8489 my $mysync = {
8490 h1_prefix => q{},
8491 h2_prefix => q{},
8492 h1_sep => '/',
8493 h2_sep => '/',
8494 } ;
8495
8496 is( q{}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: $mysync empty string => empty string' ) ;
8497 is( 'lalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: $mysync lalala => lalala' ) ;
8498 is( 'lal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: $mysync lal/ala => lal/ala' ) ;
8499 is( 'lal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: $mysync lal.ala => lal.ala' ) ;
8500 is( '////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: $mysync //// => ////' ) ;
8501 is( '.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: $mysync ..... => .....' ) ;
8502
8503 $mysync = {
8504 h1_prefix => 'PPP',
8505 h2_prefix => 'QQQ',
8506 h1_sep => 's',
8507 h2_sep => 't',
8508 } ;
8509
8510 is( q{QQQ}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: PPPQQQst empty string => QQQ' ) ;
8511 is( 'QQQlalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: PPPQQQst lalala => QQQlalala' ) ;
8512 is( 'QQQlal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: PPPQQQst lal/ala => QQQlal/ala' ) ;
8513 is( 'QQQlal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: PPPQQQst lal.ala => QQQlal.ala' ) ;
8514 is( 'QQQ////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: PPPQQQst //// => QQQ////' ) ;
8515 is( 'QQQ.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: PPPQQQst ..... => QQQ.....' ) ;
8516
8517 is( 'QQQPlalala', prefix_seperator_invertion( $mysync, 'PPPPlalala' ), 'prefix_seperator_invertion: PPPQQQst PPPPlalala => QQQPlalala' ) ;
8518 is( 'QQQ', prefix_seperator_invertion( $mysync, 'PPP' ), 'prefix_seperator_invertion: PPPQQQst PPP => QQQ' ) ;
8519 is( 'QQQttt', prefix_seperator_invertion( $mysync, 'sss' ), 'prefix_seperator_invertion: PPPQQQst sss => QQQttt' ) ;
8520 is( 'QQQt', prefix_seperator_invertion( $mysync, 's' ), 'prefix_seperator_invertion: PPPQQQst s => QQQt' ) ;
8521 is( 'QQQtAAAtBBB', prefix_seperator_invertion( $mysync, 'PPPsAAAsBBB' ), 'prefix_seperator_invertion: PPPQQQst PPPsAAAsBBB => QQQtAAAtBBB' ) ;
8522
8523 note( 'Leaving tests_prefix_seperator_invertion()' ) ;
8524 return ;
8525}
8526
8527# Global variables to remove:
8528
8529
8530sub prefix_seperator_invertion
8531{
8532 my $mysync = shift ;
8533 my $h1_fold = shift ;
8534 my $h2_fold ;
8535
8536 if ( not defined $h1_fold ) { return ; }
8537
8538 my $my_h1_prefix = $mysync->{ h1_prefix } || q{} ;
8539 my $my_h2_prefix = $mysync->{ h2_prefix } || q{} ;
8540 my $my_h1_sep = $mysync->{ h1_sep } || '/' ;
8541 my $my_h2_sep = $mysync->{ h2_sep } || '/' ;
8542
8543 # first we remove the prefix
8544 $h1_fold =~ s/^\Q$my_h1_prefix\E//x ;
8545 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ;
8546 $h2_fold = separator_invert( $mysync, $h1_fold, $my_h1_sep, $my_h2_sep ) ;
8547 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ;
8548
8549 # Adding the prefix supplied by namespace or the --prefix2 option
8550 # except for INBOX or Inbox
8551 if ( $h2_fold !~ m/^INBOX$/xi )
8552 {
8553 $h2_fold = $my_h2_prefix . $h2_fold ;
8554 }
8555
8556 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ;
8557 return( $h2_fold ) ;
8558}
8559
8560sub tests_separator_invert
8561{
8562 note( 'Entering tests_separator_invert()' ) ;
8563
8564 my $mysync = {} ;
8565 $mysync->{ fixslash2 } = 0 ;
8566 ok( not( defined separator_invert( ) ), 'separator_invert: no args' ) ;
8567 ok( not( defined separator_invert( q{} ) ), 'separator_invert: not enough args' ) ;
8568 ok( not( defined separator_invert( q{}, q{} ) ), 'separator_invert: not enough args' ) ;
8569
8570 ok( q{} eq separator_invert( $mysync, q{}, q{}, q{} ), 'separator_invert: 3 empty strings' ) ;
8571 ok( 'lalala' eq separator_invert( $mysync, 'lalala', q{}, q{} ), 'separator_invert: empty separator' ) ;
8572 ok( 'lalala' eq separator_invert( $mysync, 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ;
8573 ok( 'lal/ala' eq separator_invert( $mysync, 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ;
8574 ok( 'lal.ala' eq separator_invert( $mysync, 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
8575 ok( 'lal/ala' eq separator_invert( $mysync, 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
8576 ok( 'la.l/ala' eq separator_invert( $mysync, 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ;
8577
8578 ok( 'l/al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
8579 $mysync->{ fixslash2 } = 1 ;
8580 ok( 'l_al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ;
8581
8582 note( 'Leaving tests_separator_invert()' ) ;
8583 return ;
8584}
8585
8586# Global variables to remove:
8587#
8588sub separator_invert
8589{
8590 my( $mysync, $h1_fold, $h1_separator, $h2_separator ) = @_ ;
8591
8592 return( undef ) if ( not all_defined( $mysync, $h1_fold, $h1_separator, $h2_separator ) ) ;
8593 # The separator we hope we'll never encounter: 00000000 == 0x00
8594 my $o_sep = "\000" ;
8595
8596 my $h2_fold = $h1_fold ;
8597 $h2_fold =~ s,\Q$h2_separator,$o_sep,xg ;
8598 $h2_fold =~ s,\Q$h1_separator,$h2_separator,xg ;
8599 $h2_fold =~ s,\Q$o_sep,$h1_separator,xg ;
8600 $h2_fold =~ s,/,_,xg if( $mysync->{ fixslash2 } and '/' ne $h2_separator and '/' eq $h1_separator ) ;
8601 return( $h2_fold ) ;
8602}
8603
8604
8605sub regextrans2
8606{
8607 my( $mysync, $h2_fold ) = @_ ;
8608 # Transforming the folder name by the --regextrans2 option(s)
8609 foreach my $regextrans2 ( @{ $mysync->{ regextrans2 } } ) {
8610 my $h2_fold_before = $h2_fold ;
8611 my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ;
8612 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ;
8613 if ( not ( defined $ret ) or $EVAL_ERROR ) {
8614 $mysync->{nb_errors}++ ;
8615 exit_clean( $mysync, $EX_USAGE,
8616 "error: eval regextrans2 '$regextrans2': $EVAL_ERROR\n"
8617 ) ;
8618 }
8619 }
8620 return( $h2_fold ) ;
8621}
8622
8623
8624sub tests_decompose_regex
8625{
8626 note( 'Entering tests_decompose_regex()' ) ;
8627
8628 ok( 1, 'decompose_regex 1' ) ;
8629 ok( 0 == compare_lists( [ q{}, q{} ], [ decompose_regex( q{} ) ] ), 'decompose_regex empty string' ) ;
8630 ok( 0 == compare_lists( [ '.*', 'lala' ], [ decompose_regex( 's/.*/lala/' ) ] ), 'decompose_regex s/.*/lala/' ) ;
8631
8632 note( 'Leaving tests_decompose_regex()' ) ;
8633 return ;
8634}
8635
8636sub decompose_regex
8637{
8638 my $regex = shift ;
8639 my( $left_part, $right_part ) ;
8640
8641 ( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x;
8642 return( q{}, q{} ) if not $left_part ;
8643 return( $left_part, $right_part ) ;
8644}
8645
8646
8647
8648sub tests_timenext
8649{
8650 note( 'Entering tests_timenext()' ) ;
8651
8652 is( undef, timenext( ), 'timenext: no args => undef' ) ;
8653 my $mysync ;
8654 is( undef, timenext( $mysync ), 'timenext: undef => undef' ) ;
8655 $mysync = {} ;
8656 ok( time - timenext( $mysync ) <= 1e-02, 'timenext: defined first time => ~ time' ) ;
8657 ok( timenext( $mysync ) <= 1e-02, 'timenext: second time => less than 1e-02' ) ;
8658 ok( timenext( $mysync ) <= 1e-02, 'timenext: third time => less than 1e-02' ) ;
8659
8660 note( 'Leaving tests_timenext()' ) ;
8661 return ;
8662}
8663
8664
8665sub timenext
8666{
8667 my $mysync = shift ;
8668
8669 if ( ! defined $mysync )
8670 {
8671 return ;
8672 }
8673 my ( $timenow, $timediff ) ;
8674
8675 $mysync->{ timebefore } ||= 0; # epoch...
8676 $timenow = time ;
8677 $timediff = $timenow - $mysync->{ timebefore } ;
8678 $mysync->{ timebefore } = $timenow ;
8679 # myprint( "timenext: $timediff\n" ) ;
8680 return( $timediff ) ;
8681}
8682
8683
8684sub tests_timesince
8685{
8686 note( 'Entering tests_timesince()' ) ;
8687
8688 ok( timesince( time - 1 ) - 1 <= 1e-02, 'timesince: time - 1 => <= 1 + 1e-02' ) ;
8689 ok( timesince( time ) <= 1e-02, 'timesince: time => <= 1e-02' ) ;
8690 ok( timesince( ) - time <= 1e-02, 'timesince: no args => <= time + 1e-02' ) ;
8691 note( 'Leaving tests_timesince()' ) ;
8692 return ;
8693}
8694
8695
8696
8697sub timesince
8698{
8699 my $timeinit = shift || 0 ;
8700 my ( $timenow, $timediff ) ;
8701 $timenow = time ;
8702 $timediff = $timenow - $timeinit ;
8703 # Often used in a division so no 0 but a nano seconde.
8704 return( max( $timediff, min( 1e-09, $timediff ) ) ) ;
8705}
8706
8707
8708
8709
8710sub tests_flags_regex
8711{
8712 note( 'Entering tests_flags_regex()' ) ;
8713
8714 ok( q{} eq flags_regex(q{} ), 'flags_regex, null string q{}' ) ;
8715 ok( q{\Seen NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, nothing to do} ) ;
8716
8717 @regexflag = ('I am BAD' ) ;
8718 ok( not ( defined flags_regex( q{} ) ), 'flags_regex, bad regex' ) ;
8719
8720 @regexflag = ( 's/NonJunk//g' ) ;
8721 ok( q{\Seen $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove NonJunk: 's/NonJunk//g'} ) ;
8722 @regexflag = ( q{s/\$Spam//g} ) ;
8723 ok( q{\Seen NonJunk } eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove $Spam: 's/\$Spam//g'} ) ;
8724
8725 @regexflag = ( 's/\\\\Seen//g' ) ;
8726
8727 ok( q{ NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove \Seen: 's/\\\\\\\\Seen//g'} ) ;
8728
8729 @regexflag = ( 's/(\s|^)[^\\\\]\w+//g' ) ;
8730 ok( q{\Seen \Middle \End} eq flags_regex( q{\Seen NonJunk \Middle $Spam \End} ), q{flags_regex: only \word among \Seen NonJunk \Middle $Spam \End} ) ;
8731 ok( q{ \Seen \Middle \End1} eq flags_regex( q{Begin \Seen NonJunk \Middle $Spam \End1 End} ),
8732 q{flags_regex: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ;
8733
8734 @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g} ) ;
8735 ok( 'Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), 'Keep only regex' ) ;
8736
8737 ok( 'Keep1 Keep2 ' eq flags_regex( 'REM REM Keep1 Keep2'), 'Keep only regex' ) ;
8738 ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 REM REM Keep2'), 'Keep only regex' ) ;
8739 ok( 'Keep1 Keep2 ' eq flags_regex( 'REM Keep1 REM REM Keep2'), 'Keep only regex' ) ;
8740 ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2'), 'Keep only regex' ) ;
8741 ok( 'Keep1 ' eq flags_regex( 'REM Keep1'), 'Keep only regex' ) ;
8742
8743 @regexflag = ( q{s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g} ) ;
8744 ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 ReB'), 'Keep only regex' ) ;
8745 ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 REM REM REM'), 'Keep only regex' ) ;
8746 ok( 'Keep2 ' eq flags_regex('Keep2 REM REM REM'), 'Keep only regex' ) ;
8747
8748
8749 @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g},
8750 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ;
8751 ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), 'Keep only regex' ) ;
8752 ok( 'Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex' ) ;
8753 ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex' ) ;
8754 ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex' ) ;
8755 ok( 'Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex' ) ;
8756 ok( 'Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex' ) ;
8757 ok( 'Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex' ) ;
8758
8759 @regexflag = ( 's/(.*)/$1 jrdH8u/' ) ;
8760 ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), q{Add jrdH8u 's/(.*)/\$1 jrdH8u/'} ) ;
8761 @regexflag = ('s/jrdH8u *//');
8762 ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), q{Remove jrdH8u s/jrdH8u *//} ) ;
8763
8764 @regexflag = (
8765 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg'
8766 );
8767
8768 ok( '\\Deleted \\Answered '
8769 eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'),
8770 'Keep only regex: Exchange case (Phil)' ) ;
8771
8772 ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ;
8773
8774 ok( q{}
8775 eq flags_regex('Blabla $Junk machin truc'),
8776 'Keep only regex: Exchange case, no accepted flags (Phil)' ) ;
8777
8778 ok('\\Deleted \\Answered \\Draft \\Flagged '
8779 eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '),
8780 'Keep only regex: Exchange case (Phil)' ) ;
8781
8782 @regexflag = ( 's/\\\\Flagged//g' ) ;
8783
8784 is('\Deleted \Answered \Draft ',
8785 flags_regex('\\Deleted \\Answered \\Draft \\Flagged '),
8786 'flags_regex: remove \Flagged 1' ) ;
8787 is('\\Deleted \\Answered \\Draft',
8788 flags_regex('\\Deleted \\Flagged \\Answered \\Draft'),
8789 'flags_regex: remove \Flagged 2' ) ;
8790
8791 # I didn't understand why it gives \F
8792 # https://perldoc.perl.org/perlrebackslash.html
8793 # \F Foldcase till \E. Not in [].
8794 # https://perldoc.perl.org/functions/fc.html
8795
8796 # \F Not available in old Perl so I comment the test
8797
8798 # @regexflag = ( 's/\\Flagged/X/g' ) ;
8799 #is('\Deleted FX \Answered \FX \Draft \FX',
8800 #flags_regex( '\Deleted Flagged \Answered \Flagged \Draft \Flagged' ),
8801 # 'flags_regex: remove \Flagged 3 mistery...' ) ;
8802
8803 note( 'Leaving tests_flags_regex()' ) ;
8804 return ;
8805}
8806
8807sub flags_regex
8808{
8809 my ( $h1_flags ) = @_ ;
8810 foreach my $regexflag ( @regexflag ) {
8811 my $h1_flags_orig = $h1_flags ;
8812 $debugflags and myprint( "eval \$h1_flags =~ $regexflag\n" ) ;
8813 my $ret = eval "\$h1_flags =~ $regexflag ; 1 " ;
8814 $debugflags and myprint( "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n" ) ;
8815 if( not ( defined $ret ) or $EVAL_ERROR ) {
8816 myprint( "Error: eval regexflag '$regexflag': $EVAL_ERROR\n" ) ;
8817 return( undef ) ;
8818 }
8819 }
8820 return( $h1_flags ) ;
8821}
8822
8823sub acls_sync
8824{
8825 my($h1_fold, $h2_fold) = @_ ;
8826 if ( $syncacls ) {
8827 my $h1_hash = $sync->{imap1}->getacl($h1_fold)
8828 or myprint( "Could not getacl for $h1_fold: $EVAL_ERROR\n" ) ;
8829 my $h2_hash = $sync->{imap2}->getacl($h2_fold)
8830 or myprint( "Could not getacl for $h2_fold: $EVAL_ERROR\n" ) ;
8831 my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ;
8832 foreach my $user (sort keys %users ) {
8833 my $acl = $h1_hash->{$user} || 'none' ;
8834 myprint( "acl $user: [$acl]\n" ) ;
8835 next if ($h1_hash->{$user} && $h2_hash->{$user} &&
8836 $h1_hash->{$user} eq $h2_hash->{$user});
8837 unless ($sync->{dry}) {
8838 myprint( "setting acl $h2_fold $user $acl\n" ) ;
8839 $sync->{imap2}->setacl($h2_fold, $user, $acl)
8840 or myprint( "Could not set acl: $EVAL_ERROR\n" ) ;
8841 }
8842 }
8843 }
8844 return ;
8845}
8846
8847
8848sub tests_permanentflags
8849{
8850 note( 'Entering tests_permanentflags()' ) ;
8851
8852 my $string;
8853 ok(q{} eq permanentflags(' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited'),
8854 'permanentflags \*');
8855 ok('\Draft \Answered' eq permanentflags(' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited'),
8856 'permanentflags \Draft \Answered');
8857 ok('\Draft \Answered'
8858 eq permanentflags('Blabla',
8859 ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited',
8860 'Blabla'),
8861 'permanentflags \Draft \Answered'
8862 );
8863 ok(q{} eq permanentflags('Blabla'), 'permanentflags nothing');
8864
8865 note( 'Leaving tests_permanentflags()' ) ;
8866 return ;
8867}
8868
8869sub permanentflags
8870{
8871 my @lines = @_ ;
8872
8873 foreach my $line (@lines) {
8874 if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) {
8875 ( $debugflags or $sync->{ debug } ) and myprint( "permanentflags: $line" ) ;
8876 my $permanentflags = $1 ;
8877 if ( $permanentflags =~ m{\\\*}x ) {
8878 $permanentflags = q{} ;
8879 }
8880 return($permanentflags) ;
8881 } ;
8882 }
8883 return( q{} ) ;
8884}
8885
8886sub tests_flags_filter
8887{
8888 note( 'Entering tests_flags_filter()' ) ;
8889
8890 ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' );
8891 ok( q{} eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' );
8892 ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' );
8893 ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' );
8894 ok( '\Seen \Draft'
8895 eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' );
8896 ok( '\Seen \Draft'
8897 eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' );
8898
8899 note( 'Leaving tests_flags_filter()' ) ;
8900 return ;
8901}
8902
8903sub flags_filter
8904{
8905 my( $flags, $allowed_flags ) = @_ ;
8906
8907 my @flags = split /\s+/x, $flags ;
8908 my %allowed_flags = map { $_ => 1 } split q{ }, $allowed_flags ;
8909 my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags ;
8910
8911 my $flags_out = join q{ }, @flags_out ;
8912
8913 return( $flags_out ) ;
8914}
8915
8916sub flagscase
8917{
8918 my $flags = shift ;
8919
8920 my @flags = split /\s+/x, $flags ;
8921 my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ;
8922 my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ;
8923
8924 my $flags_out = join q{ }, @flags_out ;
8925
8926 return( $flags_out ) ;
8927}
8928
8929sub tests_flagscase
8930{
8931 note( 'Entering tests_flagscase()' ) ;
8932
8933 ok( '\Seen' eq flagscase( '\Seen' ), 'flagscase: \Seen -> \Seen' ) ;
8934 ok( '\Seen' eq flagscase( '\SEEN' ), 'flagscase: \SEEN -> \Seen' ) ;
8935
8936 ok( '\Seen \Draft' eq flagscase( '\SEEN \DRAFT' ), 'flagscase: \SEEN \DRAFT -> \Seen \Draft' ) ;
8937 ok( '\Draft \Seen' eq flagscase( '\DRAFT \SEEN' ), 'flagscase: \DRAFT \SEEN -> \Draft \Seen' ) ;
8938
8939 ok( '\Draft LALA \Seen' eq flagscase( '\DRAFT LALA \SEEN' ), 'flagscase: \DRAFT LALA \SEEN -> \Draft LALA \Seen' ) ;
8940 ok( '\Draft lala \Seen' eq flagscase( '\DRAFT lala \SEEN' ), 'flagscase: \DRAFT lala \SEEN -> \Draft lala \Seen' ) ;
8941
8942 note( 'Leaving tests_flagscase()' ) ;
8943 return ;
8944}
8945
8946
8947
8948sub ucsecond
8949{
8950 my $string = shift ;
8951 my $output ;
8952
8953 return( $string ) if ( 1 >= length $string ) ;
8954
8955 $output = ( substr( $string, 0, 1) ) . ( uc substr $string, 1, 1 ) . ( substr $string, 2 ) ;
8956 #myprint( "UUU $string -> $output\n" ) ;
8957 return( $output ) ;
8958}
8959
8960
8961sub tests_ucsecond
8962{
8963 note( 'Entering tests_ucsecond()' ) ;
8964
8965 ok( 'aBcde' eq ucsecond( 'abcde' ), 'ucsecond: abcde -> aBcde' ) ;
8966 ok( 'ABCDE' eq ucsecond( 'ABCDE' ), 'ucsecond: ABCDE -> ABCDE' ) ;
8967 ok( 'ABCDE' eq ucsecond( 'AbCDE' ), 'ucsecond: AbCDE -> ABCDE' ) ;
8968 ok( 'ABCde' eq ucsecond( 'AbCde' ), 'ucsecond: AbCde -> ABCde' ) ;
8969 ok( 'A' eq ucsecond( 'A' ), 'ucsecond: A -> A' ) ;
8970 ok( 'AB' eq ucsecond( 'Ab' ), 'ucsecond: Ab -> AB' ) ;
8971 ok( '\B' eq ucsecond( '\b' ), 'ucsecond: \b -> \B' ) ;
8972 ok( '\Bcde' eq ucsecond( '\bcde' ), 'ucsecond: \bcde -> \Bcde' ) ;
8973
8974 note( 'Leaving tests_ucsecond()' ) ;
8975 return ;
8976}
8977
8978
8979sub select_msgs
8980{
8981 my ( $imap, $msgs_all_hash_ref, $search_cmd, $abletosearch, $folder ) = @_ ;
8982 my ( @msgs ) ;
8983
8984 if ( $abletosearch ) {
8985 @msgs = select_msgs_by_search( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ;
8986 }else{
8987 @msgs = select_msgs_by_fetch( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ;
8988 }
8989 return( @msgs ) ;
8990
8991}
8992
8993sub select_msgs_by_search
8994{
8995 my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ;
8996 my ( @msgs, @msgs_all ) ;
8997
8998 # Need to have the whole list in msgs_all_hash_ref
8999 # without calling messages() several times.
9000 # Need all messages list to avoid deleting useful cache part
9001 # in case of --search or --minage or --maxage
9002
9003 if ( ( defined $msgs_all_hash_ref and $usecache )
9004 or ( not defined $maxage and not defined $minage and not defined $search_cmd )
9005 ) {
9006
9007 $debugdev and myprint( "Calling messages()\n" ) ;
9008 @msgs_all = $imap->messages( ) ;
9009
9010 return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ;
9011
9012 if ( defined $msgs_all_hash_ref ) {
9013 @{ $msgs_all_hash_ref }{ @msgs_all } = () ;
9014 }
9015 # return all messages
9016 if ( not defined $maxage and not defined $minage and not defined $search_cmd ) {
9017 return( @msgs_all ) ;
9018 }
9019 }
9020
9021 if ( defined $search_cmd ) {
9022 @msgs = $imap->search( $search_cmd ) ;
9023 return( @msgs ) ;
9024 }
9025
9026 # we are here only if $maxage or $minage is defined
9027 @msgs = select_msgs_by_age( $imap ) ;
9028 return( @msgs );
9029}
9030
9031
9032sub select_msgs_by_fetch
9033{
9034 my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ;
9035 my ( @msgs, @msgs_all, %fetch ) ;
9036
9037 # Need to have the whole list in msgs_all_hash_ref
9038 # without calling messages() several times.
9039 # Need all messages list to avoid deleting useful cache part
9040 # in case of --search or --minage or --maxage
9041
9042
9043 $debugdev and myprint( "Calling fetch_hash()\n" ) ;
9044 my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ;
9045 my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ;
9046 %fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ;
9047
9048 @msgs_all = sort { $a <=> $b } keys %fetch ;
9049 $debugdev and myprint( "Done fetch_hash()\n" ) ;
9050
9051 return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ;
9052
9053 if ( defined $msgs_all_hash_ref ) {
9054 @{ $msgs_all_hash_ref }{ @msgs_all } = () ;
9055 }
9056 # return all messages
9057 if ( not defined $maxage and not defined $minage and not defined $search_cmd ) {
9058 return( @msgs_all ) ;
9059 }
9060
9061 if ( defined $search_cmd ) {
9062 myprint( "Warning: strange to see --search with --noabletosearch, an error can happen\n" ) ;
9063 @msgs = $imap->search( $search_cmd ) ;
9064 return( @msgs ) ;
9065 }
9066
9067 # we are here only if $maxage or $minage is defined
9068 my( @max, @min, $maxage_epoch, $minage_epoch ) ;
9069 if ( defined $maxage ) { $maxage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ; }
9070 if ( defined $minage ) { $minage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ; }
9071 foreach my $msg ( @msgs_all ) {
9072 my $idate = $fetch{ $msg }->{'INTERNALDATE'} ;
9073 #myprint( "$idate\n" ) ;
9074 if ( defined $maxage and ( epoch( $idate ) >= $maxage_epoch ) ) {
9075 push @max, $msg ;
9076 }
9077 if ( defined $minage and ( epoch( $idate ) <= $minage_epoch ) ) {
9078 push @min, $msg ;
9079 }
9080 }
9081 @msgs = msgs_from_maxmin( \@max, \@min ) ;
9082 return( @msgs ) ;
9083}
9084
9085sub select_msgs_by_age
9086{
9087 my( $imap ) = @_ ;
9088
9089 my( @max, @min, @msgs, @inter, @union ) ;
9090
9091 if ( defined $maxage ) {
9092 @max = $imap->sentsince( $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ) ;
9093 }
9094 if ( defined $minage ) {
9095 @min = $imap->sentbefore( $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ) ;
9096 }
9097
9098 @msgs = msgs_from_maxmin( \@max, \@min ) ;
9099 return( @msgs ) ;
9100}
9101
9102sub msgs_from_maxmin
9103{
9104 my( $max_ref, $min_ref ) = @_ ;
9105 my( @max, @min, @msgs, @inter, @union ) ;
9106
9107 @max = @{ $max_ref } ;
9108 @min = @{ $min_ref } ;
9109
9110 SWITCH: {
9111 unless( defined $minage ) { @msgs = @max ; last SWITCH } ;
9112 unless( defined $maxage ) { @msgs = @min ; last SWITCH } ;
9113 my ( %union, %inter ) ;
9114 foreach my $m ( @min, @max ) { $union{ $m }++ && $inter{ $m }++ }
9115 @inter = sort { $a <=> $b } keys %inter ;
9116 @union = sort { $a <=> $b } keys %union ;
9117 # normal case
9118 if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ;
9119 # just exclude messages between
9120 if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ;
9121
9122 }
9123 return( @msgs ) ;
9124}
9125
9126sub tests_msgs_from_maxmin
9127{
9128 note( 'Entering tests_msgs_from_maxmin()' ) ;
9129
9130 my @msgs ;
9131 $maxage = $NUMBER_200 ;
9132 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
9133 ok( 0 == compare_lists( [ '1', '2' ], \@msgs ), 'msgs_from_maxmin: maxage++' ) ;
9134 $minage = $NUMBER_100 ;
9135 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
9136 ok( 0 == compare_lists( [ '2' ], \@msgs ), 'msgs_from_maxmin: -maxage++minage-' ) ;
9137 $minage = $NUMBER_300 ;
9138 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
9139 ok( 0 == compare_lists( [ '1', '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++maxage-minage++' ) ;
9140 $maxage = undef ;
9141 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ;
9142 ok( 0 == compare_lists( [ '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++minage-' ) ;
9143
9144 note( 'Leaving tests_msgs_from_maxmin()' ) ;
9145 return ;
9146}
9147
9148sub tests_info_date_from_uid
9149{
9150 note( 'Entering tests_info_date_from_uid()' ) ;
9151 note( 'Leaving tests_info_date_from_uid()' ) ;
9152
9153 return ;
9154}
9155
9156sub info_date_from_uid
9157{
9158
9159 #my $first_uid = $msgs_all[ 0 ] ;
9160 #my $first_idate = $fetch{ $first_uid }->{'INTERNALDATE'} ;
9161 #my $first_epoch = epoch( $first_idate ) ;
9162 #my $first_days = ( $timestart_int - $first_epoch ) / $NB_SECONDS_IN_A_DAY ;
9163 #myprint( "\nOldest msg has UID $first_uid INTERNALDATE $first_idate EPOCH $first_epoch DAYS AGO $first_days\n" ) ;
9164}
9165
9166
9167sub lastuid
9168{
9169 my $imap = shift ;
9170 my $folder = shift ;
9171 my $lastuid_guess = shift ;
9172 my $lastuid ;
9173
9174 # rfc3501: The only reliable way to identify recent messages is to
9175 # look at message flags to see which have the \Recent flag
9176 # set, or to do a SEARCH RECENT.
9177 # SEARCH RECENT doesn't work this way on courrier.
9178
9179 my @recent_messages ;
9180 # SEARCH RECENT for each transfer can be expensive with a big folder
9181 # Call commented for now
9182 #@recent_messages = $imap->recent( ) ;
9183 #myprint( "Recent: @recent_messages\n" ) ;
9184
9185 my $max_recent ;
9186 $max_recent = max( @recent_messages ) ;
9187
9188 if ( defined $max_recent and ($lastuid_guess <= $max_recent ) ) {
9189 $lastuid = $max_recent ;
9190 }else{
9191 $lastuid = $lastuid_guess
9192 }
9193 return( $lastuid ) ;
9194}
9195
9196sub size_filtered
9197{
9198 my( $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @_ ;
9199
9200 $h1_size = 0 if ( ! $h1_size ) ; # null if empty or undef
9201 if ( defined $sync->{ maxsize } and $h1_size > $sync->{ maxsize } ) {
9202 myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $sync->{ maxsize } bytes)\n" ) ;
9203 $sync->{ total_bytes_skipped } += $h1_size;
9204 $sync->{ nb_msg_skipped } += 1;
9205 return( 1 ) ;
9206 }
9207 if ( defined $minsize and $h1_size <= $minsize ) {
9208 myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ;
9209 $sync->{ total_bytes_skipped } += $h1_size;
9210 $sync->{ nb_msg_skipped } += 1;
9211 return( 1 ) ;
9212 }
9213 return( 0 ) ;
9214}
9215
9216sub message_exists
9217{
9218 my( $imap, $msg ) = @_ ;
9219 return( 1 ) if not $imap->Uid( ) ;
9220
9221 my $search_uid ;
9222 ( $search_uid ) = $imap->search( "UID $msg" ) ;
9223 #myprint( "$search ? $msg\n" ) ;
9224 return( 1 ) if ( $search_uid eq $msg ) ;
9225 return( 0 ) ;
9226}
9227
9228
9229# Globals
9230# $sync->{ total_bytes_skipped }
9231# $sync->{ nb_msg_skipped }
9232# $mysync->{ h1_nb_msg_processed }
9233sub stats_update_skip_message
9234{
9235 my $mysync = shift ; # to be used
9236 my $h1_size = shift ;
9237
9238 $mysync->{ total_bytes_skipped } += $h1_size ;
9239 $mysync->{ nb_msg_skipped } += 1 ;
9240 $mysync->{ h1_nb_msg_processed } +=1 ;
9241 return ;
9242}
9243
9244sub copy_message
9245{
9246 # copy
9247
9248 my ( $mysync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ;
9249 ( $mysync->{ debug } or $mysync->{dry} )
9250 and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $mysync->{dry_message} " . eta( $mysync ) . "\n" ) ;
9251
9252 my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ;
9253 my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ;
9254 my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ;
9255
9256
9257 if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) {
9258 $mysync->{ h1_nb_msg_processed } +=1 ;
9259 return ;
9260 }
9261
9262 debugsleep( $mysync ) ;
9263 myprint( "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" ) if ( ! $h1_size ) ;
9264
9265 if ( $checkmessageexists and not message_exists( $mysync->{imap1}, $h1_msg ) ) {
9266 stats_update_skip_message( $mysync, $h1_size ) ;
9267 return ;
9268 }
9269 myprint( debugmemory( $mysync, " at C1" ) ) ;
9270
9271 my ( $string, $string_len ) ;
9272 ( $string_len ) = message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ;
9273
9274 myprint( debugmemory( $mysync, " at C2" ) ) ;
9275
9276 # not defined or empty $string
9277 if ( ( not $string ) or ( not $string_len ) ) {
9278 myprint( "- msg $h1_fold/$h1_msg skipped.\n" ) ;
9279 stats_update_skip_message( $mysync, $h1_size ) ;
9280 return ;
9281 }
9282
9283 # Lines too long (or not enough) => do no copy or fix
9284 if ( ( defined $maxlinelength ) or ( defined $minmaxlinelength ) ) {
9285 $string = linelengthstuff( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) ;
9286 if ( not defined $string ) {
9287 stats_update_skip_message( $mysync, $h1_size ) ;
9288 return ;
9289 }
9290 }
9291
9292 my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ;
9293
9294 ( $mysync->{ debug } or $debugflags ) and
9295 myprint( "Host1: flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ;
9296
9297 $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ;
9298
9299 ( $mysync->{ debug } or $debugflags ) and
9300 myprint( "Host1: flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ;
9301
9302 $h1_date = undef if ( $h1_date eq q{} ) ;
9303
9304 my $new_id = append_message_on_host2( $mysync, \$string, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) ;
9305
9306
9307
9308 if ( $new_id and $syncflagsaftercopy ) {
9309 sync_flags_after_copy( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id, $permanentflags2 ) ;
9310 }
9311
9312 myprint( debugmemory( $mysync, " at C3" ) ) ;
9313
9314 return $new_id ;
9315}
9316
9317
9318
9319sub linelengthstuff
9320{
9321 my( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) = @_ ;
9322 my $maxlinelength_string = max_line_length( $string ) ;
9323 $debugmaxlinelength and myprint( "msg $h1_fold/$h1_msg maxlinelength: $maxlinelength_string\n" ) ;
9324
9325 if ( ( defined $minmaxlinelength ) and ( $maxlinelength_string <= $minmaxlinelength ) ) {
9326 my $subject = subject( $string ) ;
9327 $debugdev and myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] "
9328 . "(Subject:[$subject]) (max line length under minmaxlinelength $minmaxlinelength bytes)\n" ) ;
9329 return ;
9330 }
9331
9332 if ( ( defined $maxlinelength ) and ( $maxlinelength_string > $maxlinelength ) ) {
9333 my $subject = subject( $string ) ;
9334 if ( $maxlinelengthcmd ) {
9335 $string = pipemess( $string, $maxlinelengthcmd ) ;
9336 # string undef means something was bad.
9337 if ( not ( defined $string ) ) {
9338 myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] "
9339 . "(Subject:[$subject]) could not be successfully transformed by --maxlinelengthcmd option\n" ) ;
9340 return ;
9341 }else{
9342 return $string ;
9343 }
9344 }
9345 myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] "
9346 . "(Subject:[$subject]) (line length exceeds maxlinelength $maxlinelength bytes)\n" ) ;
9347 return ;
9348 }
9349 return $string ;
9350}
9351
9352
9353sub message_for_host2
9354{
9355
9356# global variable list:
9357# @skipmess
9358# @regexmess
9359# @pipemess
9360# $debugcontent
9361# $debug
9362#
9363# API current
9364#
9365# at failure:
9366# * return nothing ( will then be undef or () )
9367# * $string_ref content is undef or empty
9368# at success:
9369# * return string length ($string_ref content length)
9370# * $string_ref content filled with message
9371
9372# API future
9373#
9374#
9375 my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) = @_ ;
9376
9377 # abort when missing a parameter
9378 if ( ( ! $mysync ) or ( ! $h1_msg ) or ( ! $h1_fold ) or ( ! defined $h1_size )
9379 or ( ! defined $h1_flags) or ( ! defined $h1_idate )
9380 or ( ! $h1_fir_ref) or ( ! $string_ref ) )
9381 {
9382 return ;
9383 }
9384
9385 myprint( debugmemory( $mysync, " at M1" ) ) ;
9386
9387
9388 my $string_ok = $mysync->{imap1}->message_to_file( $string_ref, $h1_msg ) ;
9389
9390 myprint( debugmemory( $mysync, " at M2" ) ) ;
9391
9392 my $string_len = length_ref( $string_ref ) ;
9393
9394
9395 unless ( defined $string_ok and $string_len ) {
9396 # undef or 0 length
9397 my $error = join q{},
9398 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] could not be fetched: ",
9399 $mysync->{imap1}->LastError || q{}, "\n" ;
9400 errors_incr( $mysync, $error ) ;
9401 $mysync->{ h1_nb_msg_processed } +=1 ;
9402 return ;
9403 }
9404
9405 if ( @skipmess ) {
9406 my $match = skipmess( ${ $string_ref } ) ;
9407 # string undef means the eval regex was bad.
9408 if ( not ( defined $match ) ) {
9409 myprint(
9410 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
9411 . " could not be skipped by --skipmess option, bad regex\n" ) ;
9412 return ;
9413 }
9414 if ( $match ) {
9415 my $subject = subject( ${ $string_ref } ) ;
9416 myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
9417 . " (Subject:[$subject]) skipped by --skipmess\n" ) ;
9418 return ;
9419 }
9420 }
9421
9422 if ( @regexmess ) {
9423 ${ $string_ref } = regexmess( ${ $string_ref } ) ;
9424 # string undef means the eval regex was bad.
9425 if ( not ( defined ${ $string_ref } ) ) {
9426 myprint(
9427 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
9428 . " could not be transformed by --regexmess\n" ) ;
9429 return ;
9430 }
9431 }
9432
9433 if ( @pipemess ) {
9434 ${ $string_ref } = pipemess( ${ $string_ref }, @pipemess ) ;
9435 # string undef means something was bad.
9436 if ( not ( defined ${ $string_ref } ) ) {
9437 myprint(
9438 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]"
9439 . " could not be successfully transformed by --pipemess option\n" ) ;
9440 return ;
9441 }
9442 }
9443
9444 if ( $mysync->{addheader} and defined $h1_fir_ref->{$h1_msg}->{'NO_HEADER'} ) {
9445 my $header = add_header( $h1_msg ) ;
9446 $mysync->{ debug } and myprint( "msg $h1_fold/$h1_msg adding custom header [$header]\n" ) ;
9447 ${ $string_ref } = $header . "\r\n" . ${ $string_ref } ;
9448 }
9449
9450 if ( ( defined $mysync->{ truncmess } ) and is_an_integer( $mysync->{ truncmess } ) )
9451 {
9452 ${ $string_ref } = truncmess( ${ $string_ref }, $mysync->{ truncmess } ) ;
9453 }
9454
9455 $string_len = length_ref( $string_ref ) ;
9456
9457 $debugcontent and myprint(
9458 q{=} x $STD_CHAR_PER_LINE, "\n",
9459 "F message content begin next line ($string_len characters long)\n",
9460 ${ $string_ref },
9461 "\nF message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n" ) ;
9462
9463 myprint( debugmemory( $mysync, " at M3" ) ) ;
9464
9465 return $string_len ;
9466}
9467
9468sub tests_truncmess
9469{
9470 note( 'Entering tests_truncmess()' ) ;
9471
9472 is( undef, truncmess( ), 'truncmess: no args => undef' ) ;
9473 is( 'abc', truncmess( 'abc' ), 'truncmess: abc => abc' ) ;
9474 is( 'ab', truncmess( 'abc', 2 ), 'truncmess: abc 2 => ab' ) ;
9475 is( 'abc', truncmess( 'abc', 3 ), 'truncmess: abc 3 => abc' ) ;
9476 is( 'abc', truncmess( 'abc', 4 ), 'truncmess: abc 4 => abc' ) ;
9477 is( '12345', truncmess( "123456789\n", 5 ), 'truncmess: "123456789\n", 5 => 12345' ) ;
9478 is( "123456789\n" x 5000, truncmess( "123456789\n" x 100000, 50000 ), 'truncmess: "123456789\n" x 100000, 50000 => "123456789\n" x 5000' ) ;
9479 note( 'Leaving tests_truncmess()' ) ;
9480 return ;
9481}
9482
9483sub truncmess
9484{
9485 my $string = shift ;
9486 my $length = shift ;
9487
9488 if ( not defined $string ) { return ; }
9489 if ( not defined $length ) { return $string ; }
9490
9491 $string = substr $string, 0, $length ;
9492 return $string ;
9493}
9494
9495sub tests_message_for_host2
9496{
9497 note( 'Entering tests_message_for_host2()' ) ;
9498
9499
9500 my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) ;
9501
9502 is( undef, message_for_host2( ), q{message_for_host2: no args} ) ;
9503 is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), q{message_for_host2: undef args} ) ;
9504
9505 require_ok( "Test::MockObject" ) ;
9506 my $imapT = Test::MockObject->new( ) ;
9507 $mysync->{imap1} = $imapT ;
9508 my $string ;
9509
9510 $h1_msg = 1 ;
9511 $h1_fold = 'FoldFoo';
9512 $h1_size = 9 ;
9513 $h1_flags = q{} ;
9514 $h1_idate = '10-Jul-2015 09:00:00 +0200' ;
9515 $h1_fir_ref = {} ;
9516 $string_ref = \$string ;
9517 $imapT->mock( 'message_to_file',
9518 sub {
9519 my ( $imap, $mystring_ref, $msg ) = @_ ;
9520 ${$mystring_ref} = 'blablabla' ;
9521 return length ${$mystring_ref} ;
9522 }
9523 ) ;
9524 is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
9525 q{message_for_host2: msg 1 == "blablabla", length} ) ;
9526 is( 'blablabla', $string, q{message_for_host2: msg 1 == "blablabla", value} ) ;
9527
9528 # so far so good
9529 # now the --pipemess stuff
9530
9531 SKIP: {
9532 Readonly my $NB_WIN_tests_message_for_host2 => 0 ;
9533 skip( 'Not on MSWin32', $NB_WIN_tests_message_for_host2 ) if ('MSWin32' ne $OSNAME) ;
9534 # Windows
9535 # "type" command does not accept redirection of STDIN with <
9536 # "sort" does
9537
9538 } ;
9539
9540 SKIP: {
9541 Readonly my $NB_UNX_tests_message_for_host2 => 6 ;
9542 skip( 'Not on Unix', $NB_UNX_tests_message_for_host2 ) if ('MSWin32' eq $OSNAME) ;
9543 # Unix
9544
9545 # no change by cat
9546 @pipemess = ( 'cat' ) ;
9547 is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
9548 q{message_for_host2: --pipemess 'cat', length} ) ;
9549 is( 'blablabla', $string, q{message_for_host2: --pipemess 'cat', value} ) ;
9550
9551
9552 # failure by false
9553 @pipemess = ( 'false' ) ;
9554 is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
9555 q{message_for_host2: --pipemess 'false', length} ) ;
9556 is( undef, $string, q{message_for_host2: --pipemess 'false', value} ) ;
9557
9558 # failure by true since no output
9559 @pipemess = ( 'true' ) ;
9560 is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ),
9561 q{message_for_host2: --pipemess 'true', length} ) ;
9562 is( undef, $string, q{message_for_host2: --pipemess 'true', value} ) ;
9563 }
9564
9565 note( 'Leaving tests_message_for_host2()' ) ;
9566 return ;
9567}
9568
9569sub tests_labels_remove_subfolder1
9570{
9571 note( 'Entering tests_labels_remove_subfolder1()' ) ;
9572 is( undef, labels_remove_subfolder1( ), 'labels_remove_subfolder1: no parameters => undef' ) ;
9573 is( 'Blabla', labels_remove_subfolder1( 'Blabla' ), 'labels_remove_subfolder1: one parameter Blabla => Blabla' ) ;
9574 is( 'Blan blue', labels_remove_subfolder1( 'Blan blue' ), 'labels_remove_subfolder1: one parameter Blan blue => Blan blue' ) ;
9575 is( '\Bla "Blan blan" Blabla', labels_remove_subfolder1( '\Bla "Blan blan" Blabla' ),
9576 'labels_remove_subfolder1: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ;
9577
9578 is( 'Bla', labels_remove_subfolder1( 'Subf/Bla', 'Subf' ), 'labels_remove_subfolder1: Subf/Bla Subf => "Bla"' ) ;
9579
9580
9581 is( '"\\\\Bla"', labels_remove_subfolder1( '"\\\\Bla"', 'Subf' ), 'labels_remove_subfolder1: "\\\\Bla" Subf => "\\\\Bla"' ) ;
9582
9583 is( 'Bla Kii', labels_remove_subfolder1( 'Subf/Bla Subf/Kii', 'Subf' ),
9584 'labels_remove_subfolder1: Subf/Bla Subf/Kii, Subf => "Bla" "Kii"' ) ;
9585
9586 is( '"\\\\Bla" Kii', labels_remove_subfolder1( '"\\\\Bla" Subf/Kii', 'Subf' ),
9587 'labels_remove_subfolder1: "\\\\Bla" Subf/Kii Subf => "\\\\Bla" Kii' ) ;
9588
9589 is( '"Blan blan"', labels_remove_subfolder1( '"Subf/Blan blan"', 'Subf' ),
9590 'labels_remove_subfolder1: "Subf/Blan blan" Subf => "Blan blan"' ) ;
9591
9592 is( '"\\\\Loo" "Blan blan" Kii', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii', 'Subf' ),
9593 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii + Subf => "\\\\Loo" "Blan blan" Kii' ) ;
9594
9595 is( '"\\\\Inbox"', labels_remove_subfolder1( 'Subf/INBOX', 'Subf' ),
9596 'labels_remove_subfolder1: Subf/INBOX + Subf => "\\\\Inbox"' ) ;
9597
9598 is( '"\\\\Loo" "Blan blan" Kii "\\\\Inbox"', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX', 'Subf' ),
9599 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX + Subf => "\\\\Loo" "Blan blan" Kii "\\\\Inbox"' ) ;
9600
9601
9602 note( 'Leaving tests_labels_remove_subfolder1()' ) ;
9603 return ;
9604}
9605
9606
9607
9608sub labels_remove_subfolder1
9609{
9610 my $labels = shift ;
9611 my $subfolder1 = shift ;
9612
9613 if ( not defined $labels ) { return ; }
9614 if ( not defined $subfolder1 ) { return $labels ; }
9615
9616 my @labels = quotewords('\s+', 1, $labels ) ;
9617 #myprint( "@labels\n" ) ;
9618 my @labels_subfolder2 ;
9619
9620 foreach my $label ( @labels )
9621 {
9622 if ( $label =~ m{zzzzzzzzzz} )
9623 {
9624 # \Seen \Deleted ... stay the same
9625 push @labels_subfolder2, $label ;
9626 }
9627 else
9628 {
9629 # Remove surrounding quotes if any, to add them again in case of space
9630 $label = join( q{}, quotewords('\s+', 0, $label ) ) ;
9631 $label =~ s{$subfolder1/?}{} ;
9632 if ( 'INBOX' eq $label )
9633 {
9634 push @labels_subfolder2, q{"\\\\Inbox"} ;
9635 }
9636 elsif ( $label =~ m{\\} )
9637 {
9638 push @labels_subfolder2, qq{"\\$label"} ;
9639 }
9640 elsif ( $label =~ m{ } )
9641 {
9642 push @labels_subfolder2, qq{"$label"} ;
9643 }
9644 else
9645 {
9646 push @labels_subfolder2, $label ;
9647 }
9648 }
9649 }
9650
9651 my $labels_subfolder2 = join( ' ', sort uniq( @labels_subfolder2 ) ) ;
9652
9653 return $labels_subfolder2 ;
9654}
9655
9656sub tests_labels_remove_special
9657{
9658 note( 'Entering tests_labels_remove_special()' ) ;
9659
9660 is( undef, labels_remove_special( ), 'labels_remove_special: no parameters => undef' ) ;
9661 is( q{}, labels_remove_special( q{} ), 'labels_remove_special: empty string => empty string' ) ;
9662 is( q{}, labels_remove_special( '"\\\\Inbox"' ), 'labels_remove_special:"\\\\Inbox" => empty string' ) ;
9663 is( q{}, labels_remove_special( '"\\\\Inbox" "\\\\Starred"' ), 'labels_remove_special:"\\\\Inbox" "\\\\Starred" => empty string' ) ;
9664 is( 'Bar Foo', labels_remove_special( 'Foo Bar' ), 'labels_remove_special:Foo Bar => Bar Foo' ) ;
9665 is( 'Bar Foo', labels_remove_special( 'Foo Bar "\\\\Inbox"' ), 'labels_remove_special:Foo Bar "\\\\Inbox" => Bar Foo' ) ;
9666 note( 'Leaving tests_labels_remove_special()' ) ;
9667 return ;
9668}
9669
9670
9671
9672
9673sub labels_remove_special
9674{
9675 my $labels = shift ;
9676
9677 if ( not defined $labels ) { return ; }
9678
9679 my @labels = quotewords('\s+', 1, $labels ) ;
9680 myprint( "labels before remove_non_folded: @labels\n" ) ;
9681 my @labels_remove_special ;
9682
9683 foreach my $label ( @labels )
9684 {
9685 if ( $label =~ m{^\"\\\\} )
9686 {
9687 # not kept
9688 }
9689 else
9690 {
9691 push @labels_remove_special, $label ;
9692 }
9693 }
9694
9695 my $labels_remove_special = join( ' ', sort @labels_remove_special ) ;
9696
9697 return $labels_remove_special ;
9698}
9699
9700
9701sub tests_labels_add_subfolder2
9702{
9703 note( 'Entering tests_labels_add_subfolder2()' ) ;
9704 is( undef, labels_add_subfolder2( ), 'labels_add_subfolder2: no parameters => undef' ) ;
9705 is( 'Blabla', labels_add_subfolder2( 'Blabla' ), 'labels_add_subfolder2: one parameter Blabla => Blabla' ) ;
9706 is( 'Blan blue', labels_add_subfolder2( 'Blan blue' ), 'labels_add_subfolder2: one parameter Blan blue => Blan blue' ) ;
9707 is( '\Bla "Blan blan" Blabla', labels_add_subfolder2( '\Bla "Blan blan" Blabla' ),
9708 'labels_add_subfolder2: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ;
9709
9710 is( 'Subf/Bla', labels_add_subfolder2( 'Bla', 'Subf' ), 'labels_add_subfolder2: Bla Subf => "Subf/Bla"' ) ;
9711
9712
9713 is( 'Subf/\Bla', labels_add_subfolder2( '\\\\Bla', 'Subf' ), 'labels_add_subfolder2: \Bla Subf => \Bla' ) ;
9714
9715 is( 'Subf/Bla Subf/Kii', labels_add_subfolder2( 'Bla Kii', 'Subf' ),
9716 'labels_add_subfolder2: Bla Kii Subf => "Subf/Bla" "Subf/Kii"' ) ;
9717
9718 is( 'Subf/Kii Subf/\Bla', labels_add_subfolder2( '\\\\Bla Kii', 'Subf' ),
9719 'labels_add_subfolder2: \Bla Kii Subf => \Bla Subf/Kii' ) ;
9720
9721 is( '"Subf/Blan blan"', labels_add_subfolder2( '"Blan blan"', 'Subf' ),
9722 'labels_add_subfolder2: "Blan blan" Subf => "Subf/Blan blan"' ) ;
9723
9724 is( '"Subf/Blan blan" Subf/Kii Subf/\Loo', labels_add_subfolder2( '\\\\Loo "Blan blan" Kii', 'Subf' ),
9725 'labels_add_subfolder2: \Loo "Blan blan" Kii + Subf => "Subf/Blan blan" Subf/Kii Subf/\Loo' ) ;
9726
9727 # "\\Inbox" is special, add to subfolder INBOX also because Gmail will but ...
9728 is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox"', 'Subf' ),
9729 'labels_add_subfolder2: "\\\\Inbox" Subf => "Subf/\\\\Inbox" Subf/INBOX' ) ;
9730
9731 # but not with INBOX folder
9732 is( '"Subf/\\\\Inbox"', labels_add_subfolder2( '"\\\\Inbox"', 'Subf', 'INBOX' ),
9733 'labels_add_subfolder2: "\\\\Inbox" Subf INBOX => "Subf/\\\\Inbox"' ) ;
9734
9735 # two times => one time
9736 is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox" "\\\\Inbox"', 'Subf' ),
9737 'labels_add_subfolder2: "\\\\Inbox" "\\\\Inbox" Subf => "Subf/\\\\Inbox"' ) ;
9738
9739 is( '"Subf/\\\\Starred"', labels_add_subfolder2( '"\\\\Starred"', 'Subf' ),
9740 'labels_add_subfolder2: "\\\\Starred" Subf => "Subf/\\\\Starred"' ) ;
9741
9742 note( 'Leaving tests_labels_add_subfolder2()' ) ;
9743 return ;
9744}
9745
9746sub labels_add_subfolder2
9747{
9748 my $labels = shift ;
9749 my $subfolder2 = shift ;
9750 my $h1_folder = shift || q{} ;
9751
9752 if ( not defined $labels ) { return ; }
9753 if ( not defined $subfolder2 ) { return $labels ; }
9754
9755 # Isn't it messy?
9756 if ( 'INBOX' eq $h1_folder )
9757 {
9758 $labels .= ' "\\\\Inbox"' ;
9759 }
9760
9761 my @labels = uniq( quotewords('\s+', 1, $labels ) ) ;
9762 myprint( "labels before subfolder2: @labels\n" ) ;
9763 my @labels_subfolder2 ;
9764
9765
9766 foreach my $label ( @labels )
9767 {
9768 # Isn't it more messy?
9769 if ( ( q{"\\\\Inbox"} eq $label ) and ( 'INBOX' ne $h1_folder ) )
9770 {
9771 if ( $subfolder2 =~ m{ } )
9772 {
9773 push @labels_subfolder2, qq{"$subfolder2/INBOX"} ;
9774 }
9775 else
9776 {
9777 push @labels_subfolder2, "$subfolder2/INBOX" ;
9778 }
9779 }
9780 if ( $label =~ m{^\"\\\\} )
9781 {
9782 # \Seen \Deleted ... stay the same
9783 #push @labels_subfolder2, $label ;
9784 # Remove surrounding quotes if any, to add them again
9785 $label = join( q{}, quotewords('\s+', 0, $label ) ) ;
9786 push @labels_subfolder2, qq{"$subfolder2/\\$label"} ;
9787
9788 }
9789 else
9790 {
9791 # Remove surrounding quotes if any, to add them again in case of space
9792 $label = join( q{}, quotewords('\s+', 0, $label ) ) ;
9793 if ( $label =~ m{ } )
9794 {
9795 push @labels_subfolder2, qq{"$subfolder2/$label"} ;
9796 }
9797 else
9798 {
9799 push @labels_subfolder2, "$subfolder2/$label" ;
9800 }
9801 }
9802 }
9803
9804 my $labels_subfolder2 = join( ' ', sort @labels_subfolder2 ) ;
9805
9806 return $labels_subfolder2 ;
9807}
9808
9809sub tests_labels
9810{
9811 note( 'Entering tests_labels()' ) ;
9812
9813 is( undef, labels( ), 'labels: no parameters => undef' ) ;
9814 is( undef, labels( undef ), 'labels: undef => undef' ) ;
9815 require_ok( "Test::MockObject" ) ;
9816 my $myimap = Test::MockObject->new( ) ;
9817
9818 $myimap->mock( 'fetch_hash',
9819 sub {
9820 return(
9821 { '1' => {
9822 'X-GM-LABELS' => '\Seen Blabla'
9823 }
9824 }
9825 ) ;
9826 }
9827 ) ;
9828 $myimap->mock( 'Debug' , sub { } ) ;
9829 $myimap->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one
9830
9831 is( undef, labels( $myimap ), 'labels: one parameter => undef' ) ;
9832 is( '\Seen Blabla', labels( $myimap, '1' ), 'labels: $mysync UID_1 => \Seen Blabla' ) ;
9833
9834 note( 'Leaving tests_labels()' ) ;
9835 return ;
9836}
9837
9838sub labels
9839{
9840 my ( $myimap, $uid ) = @ARG ;
9841
9842 if ( not all_defined( $myimap, $uid ) ) {
9843 return ;
9844 }
9845
9846 my $hash = $myimap->fetch_hash( [ $uid ], 'X-GM-LABELS' ) ;
9847
9848 my $labels = $hash->{ $uid }->{ 'X-GM-LABELS' } ;
9849 #$labels = $myimap->Unescape( $labels ) ;
9850 return $labels ;
9851}
9852
9853sub tests_synclabels
9854{
9855 note( 'Entering tests_synclabels()' ) ;
9856
9857 is( undef, synclabels( ), 'synclabels: no parameters => undef' ) ;
9858 is( undef, synclabels( undef ), 'synclabels: undef => undef' ) ;
9859 my $mysync ;
9860 is( undef, synclabels( $mysync ), 'synclabels: var undef => undef' ) ;
9861
9862 require_ok( "Test::MockObject" ) ;
9863 $mysync = {} ;
9864
9865 my $myimap1 = Test::MockObject->new( ) ;
9866 $myimap1->mock( 'fetch_hash',
9867 sub {
9868 return(
9869 { '1' => {
9870 'X-GM-LABELS' => '\Seen Blabla'
9871 }
9872 }
9873 ) ;
9874 }
9875 ) ;
9876 $myimap1->mock( 'Debug', sub { } ) ;
9877 $myimap1->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one
9878
9879 my $myimap2 = Test::MockObject->new( ) ;
9880
9881 $myimap2->mock( 'store',
9882 sub {
9883 return 1 ;
9884 }
9885 ) ;
9886
9887
9888 $mysync->{imap1} = $myimap1 ;
9889 $mysync->{imap2} = $myimap2 ;
9890
9891 is( undef, synclabels( $mysync ), 'synclabels: fresh $mysync => undef' ) ;
9892
9893 is( undef, synclabels( $mysync, '1' ), 'synclabels: $mysync UID_1 alone => undef' ) ;
9894 is( 1, synclabels( $mysync, '1', '2' ), 'synclabels: $mysync UID_1 UID_2 => 1' ) ;
9895
9896 note( 'Leaving tests_synclabels()' ) ;
9897 return ;
9898}
9899
9900
9901sub synclabels
9902{
9903 my( $mysync, $uid1, $uid2 ) = @ARG ;
9904
9905 if ( not all_defined( $mysync, $uid1, $uid2 ) ) {
9906 return ;
9907 }
9908 my $myimap1 = $mysync->{ 'imap1' } || return ;
9909 my $myimap2 = $mysync->{ 'imap2' } || return ;
9910
9911 $mysync->{debuglabels} and $myimap1->Debug( 1 ) ;
9912 my $labels1 = labels( $myimap1, $uid1 ) ;
9913 $mysync->{debuglabels} and $myimap1->Debug( 0 ) ;
9914 $mysync->{debuglabels} and myprint( "Host1 labels: $labels1\n" ) ;
9915
9916
9917
9918 if ( $mysync->{ subfolder1 } and $labels1 )
9919 {
9920 $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ;
9921 $mysync->{debuglabels} and myprint( "Host1 labels with subfolder1: $labels1\n" ) ;
9922 }
9923
9924 if ( $mysync->{ subfolder2 } and $labels1 )
9925 {
9926 $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 } ) ;
9927 $mysync->{debuglabels} and myprint( "Host1 labels with subfolder2: $labels1\n" ) ;
9928 }
9929
9930 my $store ;
9931 if ( $labels1 and not $mysync->{ dry } )
9932 {
9933 $mysync->{ debuglabels } and $myimap2->Debug( 1 ) ;
9934 $store = $myimap2->store( $uid2, "X-GM-LABELS ($labels1)" ) ;
9935 $mysync->{ debuglabels } and $myimap2->Debug( 0 ) ;
9936 }
9937 return $store ;
9938}
9939
9940
9941sub tests_resynclabels
9942{
9943 note( 'Entering tests_resynclabels()' ) ;
9944
9945 is( undef, resynclabels( ), 'resynclabels: no parameters => undef' ) ;
9946 is( undef, resynclabels( undef ), 'resynclabels: undef => undef' ) ;
9947 my $mysync ;
9948 is( undef, resynclabels( $mysync ), 'resynclabels: var undef => undef' ) ;
9949
9950 my ( $h1_fir_ref, $h2_fir_ref ) ;
9951
9952 $mysync->{ debuglabels } = 1 ;
9953 $h1_fir_ref->{ 11 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ;
9954 $h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ;
9955
9956 # labels are equal
9957 is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ),
9958 'resynclabels: $mysync UID_1 UID_2 labels are equal => 1' ) ;
9959
9960 # labels are different
9961 $h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Zuu' ;
9962 require_ok( "Test::MockObject" ) ;
9963 my $myimap2 = Test::MockObject->new( ) ;
9964 $myimap2->mock( 'store',
9965 sub {
9966 return 1 ;
9967 }
9968 ) ;
9969 $myimap2->mock( 'Debug', sub { } ) ;
9970 $mysync->{imap2} = $myimap2 ;
9971
9972 is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ),
9973 'resynclabels: $mysync UID_1 UID_2 labels are not equal => store => 1' ) ;
9974
9975 note( 'Leaving tests_resynclabels()' ) ;
9976 return ;
9977}
9978
9979
9980
9981sub resynclabels
9982{
9983 my( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref, $h1_folder ) = @ARG ;
9984
9985 if ( not all_defined( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref ) ) {
9986 return ;
9987 }
9988
9989 my $labels1 = $h1_fir_ref->{ $uid1 }->{ 'X-GM-LABELS' } || q{} ;
9990 my $labels2 = $h2_fir_ref->{ $uid2 }->{ 'X-GM-LABELS' } || q{} ;
9991
9992 if ( $mysync->{ subfolder1 } and $labels1 )
9993 {
9994 $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ;
9995 }
9996
9997 if ( $mysync->{ subfolder2 } and $labels1 )
9998 {
9999 $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 }, $h1_folder ) ;
10000 $labels2 = labels_remove_special( $labels2 ) ;
10001 }
10002 $mysync->{ debuglabels } and myprint( "Host1 labels fixed: $labels1\n" ) ;
10003 $mysync->{ debuglabels } and myprint( "Host2 labels : $labels2\n" ) ;
10004
10005 my $store ;
10006 if ( $labels1 eq $labels2 )
10007 {
10008 # no sync needed
10009 $mysync->{ debuglabels } and myprint( "Labels are already equal\n" ) ;
10010 return 1 ;
10011 }
10012 elsif ( not $mysync->{ dry } )
10013 {
10014 # sync needed
10015 $mysync->{debuglabels} and $mysync->{imap2}->Debug( 1 ) ;
10016 $store = $mysync->{imap2}->store( $uid2, "X-GM-LABELS ($labels1)" ) ;
10017 $mysync->{debuglabels} and $mysync->{imap2}->Debug( 0 ) ;
10018 }
10019
10020 return $store ;
10021}
10022
10023sub tests_uniq
10024{
10025 note( 'Entering tests_uniq()' ) ;
10026
10027 is( 0, uniq( ), 'uniq: undef => 0' ) ;
10028 is_deeply( [ 'one' ], [ uniq( 'one' ) ], 'uniq: one => one' ) ;
10029 is_deeply( [ 'one' ], [ uniq( 'one', 'one' ) ], 'uniq: one one => one' ) ;
10030 is_deeply( [ 'one', 'two' ], [ uniq( 'one', 'one', 'two', 'one', 'two' ) ], 'uniq: one one two one two => one two' ) ;
10031 note( 'Leaving tests_uniq()' ) ;
10032 return ;
10033}
10034
10035sub uniq
10036{
10037 my @list = @ARG ;
10038 my %seen = ( ) ;
10039 my @uniq = ( ) ;
10040 foreach my $item ( @list ) {
10041 if ( ! $seen{ $item } ) {
10042 $seen{ $item } = 1 ;
10043 push( @uniq, $item ) ;
10044 }
10045 }
10046 return @uniq ;
10047}
10048
10049
10050sub length_ref
10051{
10052 my $string_ref = shift ;
10053 my $string_len = defined ${ $string_ref } ? length( ${ $string_ref } ) : q{} ; # length or empty string
10054 return $string_len ;
10055}
10056
10057sub tests_length_ref
10058{
10059 note( 'Entering tests_length_ref()' ) ;
10060
10061 my $notdefined ;
10062 is( q{}, length_ref( \$notdefined ), q{length_ref: value not defined} ) ;
10063 my $notref ;
10064 is( q{}, length_ref( $notref ), q{length_ref: param not a ref} ) ;
10065
10066 my $lala = 'lala' ;
10067 is( 4, length_ref( \$lala ), q{length_ref: lala length == 4} ) ;
10068 is( 4, length_ref( \'lili' ), q{length_ref: lili length == 4} ) ;
10069
10070 note( 'Leaving tests_length_ref()' ) ;
10071 return ;
10072}
10073
10074sub date_for_host2
10075{
10076 my( $h1_msg, $h1_idate ) = @_ ;
10077
10078 my $h1_date = q{} ;
10079
10080 if ( $syncinternaldates ) {
10081 $h1_date = $h1_idate ;
10082 $sync->{ debug } and myprint( "internal date from host1: [$h1_date]\n" ) ;
10083 $h1_date = good_date( $h1_date ) ;
10084 $sync->{ debug } and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ;
10085 }
10086
10087 if ( $idatefromheader ) {
10088 $h1_date = $sync->{imap1}->get_header( $h1_msg, 'Date' ) ;
10089 $sync->{ debug } and myprint( "header date from host1: [$h1_date]\n" ) ;
10090 $h1_date = good_date( $h1_date ) ;
10091 $sync->{ debug } and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ;
10092 }
10093
10094 return( $h1_date ) ;
10095}
10096
10097sub flags_for_host2
10098{
10099 my( $h1_flags, $permanentflags2 ) = @_ ;
10100 # RFC 2060: This flag can not be altered by any client
10101 $h1_flags =~ s@\\Recent\s?@@xgi ;
10102 my $h1_flags_re ;
10103 if ( @regexflag and defined( $h1_flags_re = flags_regex( $h1_flags ) ) ) {
10104 $h1_flags = $h1_flags_re ;
10105 }
10106 $h1_flags = flagscase( $h1_flags ) if $flagscase ;
10107 $h1_flags = flags_filter( $h1_flags, $permanentflags2) if ( $permanentflags2 and $filterflags ) ;
10108
10109 return( $h1_flags ) ;
10110}
10111
10112sub subject
10113{
10114 my $string = shift ;
10115 my $subject = q{} ;
10116
10117 my $header = extract_header( $string ) ;
10118
10119 if( $header =~ m/^Subject:\s*([^\n\r]*)\r?$/msx ) {
10120 #myprint( "MMM[$1]\n" ) ;
10121 $subject = $1 ;
10122 }
10123 return( $subject ) ;
10124}
10125
10126sub tests_subject
10127{
10128 note( 'Entering tests_subject()' ) ;
10129
10130 ok( q{} eq subject( q{} ), 'subject: null') ;
10131 ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'subject: toto le hero') ;
10132 ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'subject: toto le hero blank') ;
10133 ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'subject: toto le hero\r\n') ;
10134
10135 my $MESS ;
10136 $MESS = <<'EOF';
10137From: lalala
10138Subject: toto le hero
10139Date: zzzzzz
10140
10141Boogie boogie
10142EOF
10143 ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 2') ;
10144
10145 $MESS = <<'EOF';
10146Subject: toto le hero
10147From: lalala
10148Date: zzzzzz
10149
10150Boogie boogie
10151EOF
10152 ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 3') ;
10153
10154
10155 $MESS = <<'EOF';
10156From: lalala
10157Subject: cuicui
10158Date: zzzzzz
10159
10160Subject: toto le hero
10161EOF
10162 ok( 'cuicui' eq subject( $MESS ), 'subject: cuicui') ;
10163
10164 $MESS = <<'EOF';
10165From: lalala
10166Date: zzzzzz
10167
10168Subject: toto le hero
10169EOF
10170 ok( q{} eq subject( $MESS ), 'subject: null but body could') ;
10171
10172 note( 'Leaving tests_subject()' ) ;
10173 return ;
10174}
10175
10176
10177# GlobVar
10178# $max_msg_size_in_bytes
10179# $h2_uidguess
10180# ...
10181#
10182#
10183sub append_message_on_host2
10184{
10185 my( $mysync, $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ;
10186 myprint( debugmemory( $mysync, " at A1" ) ) ;
10187
10188 my $new_id ;
10189 if ( ! $mysync->{dry} ) {
10190 $max_msg_size_in_bytes = max( $string_len, $max_msg_size_in_bytes ) ;
10191 $new_id = $mysync->{imap2}->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ;
10192 myprint( debugmemory( $mysync, " at A2" ) ) ;
10193 if ( ! $new_id){
10194 my $subject = subject( ${ $string_ref } ) ;
10195 my $error_imap = $mysync->{imap2}->LastError || q{} ;
10196 my $error = "- msg $h1_fold/$h1_msg {$string_len} could not append ( Subject:[$subject], Date:[$h1_date], Size:[$h1_size], Flags:[$h1_flags] ) to folder $h2_fold: $error_imap\n" ;
10197 errors_incr( $mysync, $error ) ;
10198 $mysync->{ h1_nb_msg_processed } +=1 ;
10199 return ;
10200 }
10201 else{
10202 # good
10203 # $new_id is an id if the IMAP server has the
10204 # UIDPLUS capability else just a ref
10205 if ( $new_id !~ m{^\d+$}x ) {
10206 $new_id = lastuid( $mysync->{imap2}, $h2_fold, $h2_uidguess ) ;
10207 }
10208 if ( $mysync->{ synclabels } ) { synclabels( $mysync, $h1_msg, $new_id ) }
10209 $h2_uidguess += 1 ;
10210 $mysync->{ total_bytes_transferred } += $string_len ;
10211 $mysync->{ nb_msg_transferred } += 1 ;
10212 $mysync->{ h1_nb_msg_processed } +=1 ;
10213
10214 my $time_spent = timesince( $mysync->{begin_transfer_time} ) ;
10215 my $rate = bytes_display_string( $mysync->{total_bytes_transferred} / $time_spent ) ;
10216 my $eta = eta( $mysync ) ;
10217 my $amount_transferred = bytes_display_string( $mysync->{total_bytes_transferred} ) ;
10218 myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n",
10219 $h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $mysync->{nb_msg_transferred}/$time_spent, $rate,
10220 $amount_transferred,
10221 $eta );
10222 sleep_if_needed( $mysync ) ;
10223 if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$}x ) {
10224 $debugcache and myprint( "touch $cache_dir/${h1_msg}_$new_id\n" ) ;
10225 touch( "$cache_dir/${h1_msg}_$new_id" )
10226 or croak( "Couldn't touch $cache_dir/${h1_msg}_$new_id" ) ;
10227 }
10228 if ( $mysync->{ delete1 } ) {
10229 delete_message_on_host1( $mysync, $h1_fold, $mysync->{ expungeaftereach }, $h1_msg ) ;
10230 }
10231 #myprint( "PRESS ENTER" ) and my $a = <> ;
10232
10233 return( $new_id ) ;
10234 }
10235 }
10236 else{
10237 $nb_msg_skipped_dry_mode += 1 ;
10238 $mysync->{ h1_nb_msg_processed } += 1 ;
10239 }
10240
10241 return ;
10242}
10243
10244
10245sub tests_sleep_if_needed
10246{
10247 note( 'Entering tests_sleep_if_needed()' ) ;
10248
10249 is( undef, sleep_if_needed( ), 'sleep_if_needed: no args => undef' ) ;
10250 my $mysync ;
10251 is( undef, sleep_if_needed( $mysync ), 'sleep_if_needed: arg undef => undef' ) ;
10252
10253 $mysync->{maxbytespersecond} = 1000 ;
10254 is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytespersecond only => no sleep => 0' ) ;
10255 $mysync->{begin_transfer_time} = time ; # now
10256 is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: begin_transfer_time now => no sleep => 0' ) ;
10257 $mysync->{begin_transfer_time} = time - 2 ; # 2 s before
10258 is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 0 => no sleep => 0' ) ;
10259
10260 $mysync->{total_bytes_transferred} = 2200 ;
10261 $mysync->{begin_transfer_time} = time - 2 ; # 2 s before
10262 is( '0.20', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2s => sleep 0.2s' ) ;
10263 is( '0', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2+2 == 4s => no sleep' ) ;
10264
10265 $mysync->{maxsleep} = 0.1 ;
10266 $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again
10267 is( '0.10', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 4000 since 2s but maxsleep 0.1s => sleep 0.1s' ) ;
10268
10269 $mysync->{maxbytesafter} = 4000 ;
10270 $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again
10271 is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytesafter == total_bytes_transferred => no sleep => 0' ) ;
10272
10273 note( 'Leaving tests_sleep_if_needed()' ) ;
10274 return ;
10275}
10276
10277
10278sub sleep_if_needed
10279{
10280 my( $mysync ) = shift ;
10281
10282 if ( ! $mysync ) {
10283 return ;
10284 }
10285 # No need to go further if there is no limit set
10286 if ( not ( $mysync->{maxmessagespersecond}
10287 or $mysync->{maxbytespersecond} )
10288 ) {
10289 return ;
10290 }
10291
10292 $mysync->{maxsleep} = defined $mysync->{maxsleep} ? $mysync->{maxsleep} : $MAX_SLEEP ;
10293 # Must be positive
10294 $mysync->{maxsleep} = max( 0, $mysync->{maxsleep} ) ;
10295
10296 my $time_spent = timesince( $mysync->{begin_transfer_time} ) ;
10297 my $sleep_max_messages = sleep_max_messages( $mysync->{nb_msg_transferred}, $time_spent, $mysync->{maxmessagespersecond} ) ;
10298
10299 my $maxbytesafter = $mysync->{maxbytesafter} || 0 ;
10300 my $total_bytes_transferred = $mysync->{total_bytes_transferred} || 0 ;
10301 my $total_bytes_to_consider = $total_bytes_transferred - $maxbytesafter ;
10302
10303 #myprint( "maxbytesafter:$maxbytesafter\n" ) ;
10304 #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ;
10305
10306 my $sleep_max_bytes = sleep_max_bytes( $total_bytes_to_consider, $time_spent, $mysync->{maxbytespersecond} ) ;
10307 my $sleep_max = min( $mysync->{maxsleep}, max( $sleep_max_messages, $sleep_max_bytes ) ) ;
10308 $sleep_max = mysprintf( "%.2f", $sleep_max ) ; # round with 2 decimals.
10309 if ( $sleep_max > 0 ) {
10310 myprint( "sleeping $sleep_max s\n" ) ;
10311 sleep $sleep_max ;
10312 # Slept
10313 return $sleep_max ;
10314 }
10315 # No sleep
10316 return 0 ;
10317}
10318
10319sub sleep_max_messages
10320{
10321 # how long we have to sleep to go under max_messages_per_second
10322 my( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) = @_ ;
10323 if ( ( not defined $maxmessagespersecond ) or $maxmessagespersecond <= 0 ) { return( 0 ) } ;
10324 my $sleep = ( $nb_msg_transferred / $maxmessagespersecond ) - $time_spent ;
10325 # the sleep must be positive
10326 return( max( 0, $sleep ) ) ;
10327}
10328
10329
10330sub tests_sleep_max_messages
10331{
10332 note( 'Entering tests_sleep_max_messages()' ) ;
10333
10334 ok( 0 == sleep_max_messages( 4, 2, undef ), 'sleep_max_messages: maxmessagespersecond = undef') ;
10335 ok( 0 == sleep_max_messages( 4, 2, 0 ), 'sleep_max_messages: maxmessagespersecond = 0') ;
10336 ok( 0 == sleep_max_messages( 4, 2, $MINUS_ONE ), 'sleep_max_messages: maxmessagespersecond = -1') ;
10337 ok( 0 == sleep_max_messages( 4, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max reached') ;
10338 ok( 2 == sleep_max_messages( 8, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max over') ;
10339 ok( 0 == sleep_max_messages( 2, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max not reached') ;
10340
10341 note( 'Leaving tests_sleep_max_messages()' ) ;
10342 return ;
10343}
10344
10345
10346sub sleep_max_bytes
10347{
10348 # how long we have to sleep to go under max_bytes_per_second
10349 my( $total_bytes_to_consider, $time_spent, $maxbytespersecond ) = @_ ;
10350 $total_bytes_to_consider ||= 0 ;
10351 $time_spent ||= 0 ;
10352
10353 if ( ( not defined $maxbytespersecond ) or $maxbytespersecond <= 0 ) { return( 0 ) } ;
10354 #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ;
10355 my $sleep = ( $total_bytes_to_consider / $maxbytespersecond ) - $time_spent ;
10356 # the sleep must be positive
10357 return( max( 0, $sleep ) ) ;
10358}
10359
10360
10361sub tests_sleep_max_bytes
10362{
10363 note( 'Entering tests_sleep_max_bytes()' ) ;
10364
10365 ok( 0 == sleep_max_bytes( 4000, 2, undef ), 'sleep_max_bytes: maxbytespersecond == undef => sleep 0' ) ;
10366 ok( 0 == sleep_max_bytes( 4000, 2, 0 ), 'sleep_max_bytes: maxbytespersecond = 0 => sleep 0') ;
10367 ok( 0 == sleep_max_bytes( 4000, 2, $MINUS_ONE ), 'sleep_max_bytes: maxbytespersecond = -1 => sleep 0') ;
10368 ok( 0 == sleep_max_bytes( 4000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max reached sharp => sleep 0') ;
10369 ok( 2 == sleep_max_bytes( 8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max over => sleep a little') ;
10370 ok( 0 == sleep_max_bytes( -8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ;
10371 ok( 0 == sleep_max_bytes( 2000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ;
10372 ok( 0 == sleep_max_bytes( -2000, 2, 1000 ), 'sleep_max_bytes: maxbytespersecond = 1k max not reached => sleep 0') ;
10373
10374 note( 'Leaving tests_sleep_max_bytes()' ) ;
10375 return ;
10376}
10377
10378
10379sub delete_message_on_host1
10380{
10381 my( $mysync, $h1_fold, $expunge, @h1_msg ) = @_ ;
10382 if ( ! $mysync->{ delete1 } ) { return ; }
10383 if ( ! @h1_msg ) { return ; }
10384 delete_messages_on_any(
10385 $mysync,
10386 $mysync->{imap1},
10387 "Host1: $h1_fold",
10388 $expunge,
10389 $split1,
10390 @h1_msg ) ;
10391 return ;
10392}
10393
10394sub tests_operators_and_exclam_precedence
10395{
10396 note( 'Entering tests_operators_and_exclam_precedence()' ) ;
10397
10398 is( 1, ! 0, 'tests_operators_and_exclam_precedence: ! 0 => 1' ) ;
10399 is( "", ! 1, 'tests_operators_and_exclam_precedence: ! 1 => ""' ) ;
10400 is( 1, not( 0 ), 'tests_operators_and_exclam_precedence: not( 0 ) => 1' ) ;
10401 is( "", not( 1 ), 'tests_operators_and_exclam_precedence: not( 1 ) => ""' ) ;
10402
10403 # I wrote those tests to avoid perlcrit "Mixed high and low-precedence booleans"
10404 # and change sub delete_messages_on_any() but got 4 more warnings... So now commented.
10405
10406 #is( 0, ( ! 0 and 0 ), 'tests_operators_and_exclam_precedence: ! 0 and 0 ) => 0' ) ;
10407 #is( 1, ( ! 0 and 1 ), 'tests_operators_and_exclam_precedence: ! 0 and 1 ) => 1' ) ;
10408 #is( "", ( ! 1 and 0 ), 'tests_operators_and_exclam_precedence: ! 1 and 0 ) => ""' ) ;
10409 #is( "", ( ! 1 and 1 ), 'tests_operators_and_exclam_precedence: ! 1 and 1 ) => ""' ) ;
10410
10411 is( 0, ( ! 0 && 0 ), 'tests_operators_and_exclam_precedence: ! 0 && 0 ) => 0' ) ;
10412 is( 1, ( ! 0 && 1 ), 'tests_operators_and_exclam_precedence: ! 0 && 1 ) => 1' ) ;
10413 is( "", ( ! 1 && 0 ), 'tests_operators_and_exclam_precedence: ! 1 && 0 ) => ""' ) ;
10414 is( "", ( ! 1 && 1 ), 'tests_operators_and_exclam_precedence: ! 1 && 1 ) => ""' ) ;
10415
10416 is( 2, ( ! 0 && 2 ), 'tests_operators_and_exclam_precedence: ! 0 && 2 ) => 1' ) ;
10417
10418 note( 'Leaving tests_operators_and_exclam_precedence()' ) ;
10419 return ;
10420}
10421
10422sub delete_messages_on_any
10423{
10424 my( $mysync, $imap, $hostX_folder, $expunge, $split, @messages ) = @_ ;
10425 my $expunge_message = q{} ;
10426
10427 my $dry_message = $mysync->{ dry_message } ;
10428 $expunge_message = 'and expunged' if ( $expunge ) ;
10429 # "Host1: msg "
10430
10431 $imap->Debug( 1 ) ;
10432
10433 while ( my @messages_part = splice @messages, 0, $split )
10434 {
10435 foreach my $message ( @messages_part )
10436 {
10437 myprint( "$hostX_folder/$message marking deleted $expunge_message $dry_message\n" ) ;
10438 }
10439 if ( ! $mysync->{dry} && @messages_part )
10440 {
10441 my $nb_deleted = $imap->delete_message( $imap->Range( @messages_part ) ) ;
10442 if ( defined $nb_deleted )
10443 {
10444 # $nb_deleted is not accurate
10445 $mysync->{ h1_nb_msg_deleted } += scalar @messages_part ;
10446 }
10447 else
10448 {
10449 my $error_imap = $imap->LastError || q{} ;
10450 my $error = join( q{}, "$hostX_folder folder, could not delete ",
10451 scalar @messages_part, ' messages: ', $error_imap, "\n" ) ;
10452 errors_incr( $mysync, $error ) ;
10453 }
10454 }
10455 }
10456
10457 if ( $expunge ) {
10458 uidexpunge_or_expunge( $mysync, $imap, @messages ) ;
10459 }
10460
10461 $imap->Debug( 0 ) ;
10462
10463 return ;
10464}
10465
10466
10467sub tests_uidexpunge_or_expunge
10468{
10469 note( 'Entering tests_uidexpunge_or_expunge()' ) ;
10470
10471
10472 is( undef, uidexpunge_or_expunge( ), 'uidexpunge_or_expunge: no args => undef' ) ;
10473 my $mysync ;
10474 is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: undef args => undef' ) ;
10475 $mysync = {} ;
10476 is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: arg empty => undef' ) ;
10477 my $imap ;
10478 is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: undef Mail-IMAPClient instance => undef' ) ;
10479
10480 require_ok( "Test::MockObject" ) ;
10481 $imap = Test::MockObject->new( ) ;
10482 is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: no message (1) to uidexpunge => undef' ) ;
10483
10484 my @messages = ( ) ;
10485 is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: no message (2) to uidexpunge => undef' ) ;
10486
10487 @messages = ( '2', '1' ) ;
10488 $imap->mock( 'uidexpunge', sub { return ; } ) ;
10489 $imap->mock( 'expunge', sub { return ; } ) ;
10490 is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge failure => undef' ) ;
10491
10492 $imap->mock( 'expunge', sub { return 1 ; } ) ;
10493 is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge ok => 1' ) ;
10494
10495 $imap->mock( 'uidexpunge', sub { return 1 ; } ) ;
10496 is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: messages to uidexpunge ok => 1' ) ;
10497
10498 note( 'Leaving tests_uidexpunge_or_expunge()' ) ;
10499 return ;
10500}
10501
10502sub uidexpunge_or_expunge
10503{
10504 my $mysync = shift ;
10505 my $imap = shift ;
10506 my @messages = @ARG ;
10507
10508 if ( ! $imap ) { return ; } ;
10509 if ( ! @messages ) { return ; } ;
10510
10511 # Doing uidexpunge
10512 my @uidexpunge_result = $imap->uidexpunge( @messages ) ;
10513 if ( @uidexpunge_result ) {
10514 return 1 ;
10515 }
10516 # Failure so doing expunge
10517 my $expunge_result = $imap->expunge( ) ;
10518 if ( $expunge_result ) {
10519 return 1 ;
10520 }
10521 # bad trip
10522 return ;
10523}
10524
10525sub eta_print
10526{
10527 my $mysync = shift ;
10528 if ( my $eta = eta( $mysync ) )
10529 {
10530 myprint( "$eta\n" ) ;
10531 }
10532 return ;
10533}
10534
10535sub tests_eta
10536{
10537 note( 'Entering tests_eta()' ) ;
10538
10539 is( q{}, eta( ), 'eta: no args => ""' ) ;
10540 is( q{}, eta( undef ), 'eta: undef => ""' ) ;
10541 my $mysync = {} ;
10542 # No foldersizes
10543 is( q{}, eta( $mysync ), 'eta: No foldersizes => ""' ) ;
10544
10545 $mysync->{ foldersizes } = 1 ;
10546
10547 $mysync->{ begin_transfer_time } = time ; # Now
10548 $mysync->{ h1_nb_msg_processed } = 0 ;
10549
10550 is( "ETA: " . localtime( time ) . " 0 s 0/0 msgs left",
10551 eta( $mysync ),
10552 'eta: no args => ETA: "Now" 0 s 0/0 msgs left' ) ;
10553
10554 $mysync->{ h1_nb_msg_processed } = 1 ;
10555 $mysync->{ h1_nb_msg_start } = 2 ;
10556 is( "ETA: " . localtime( time ) . " 0 s 1/2 msgs left",
10557 eta( $mysync ),
10558 'eta: 1, 1, 2 => ETA: "Now" 0 s 1/2 msgs left' ) ;
10559
10560 note( 'Leaving tests_eta()' ) ;
10561 return ;
10562}
10563
10564
10565sub eta
10566{
10567 my( $mysync ) = shift ;
10568
10569 if ( ! $mysync )
10570 {
10571 return q{} ;
10572 }
10573
10574 return( q{} ) if not $mysync->{ foldersizes } ;
10575
10576 my $h1_nb_msg_start = $mysync->{ h1_nb_msg_start } ;
10577 my $h1_nb_processed = $mysync->{ h1_nb_msg_processed } ;
10578 my $nb_msg_transferred = ( $mysync->{dry} ) ? $mysync->{ h1_nb_msg_processed } : $mysync->{ nb_msg_transferred } ;
10579 my $time_spent = timesince( $mysync->{ begin_transfer_time } ) ;
10580 $h1_nb_processed ||= 0 ;
10581 $h1_nb_msg_start ||= 0 ;
10582 $time_spent ||= 0 ;
10583
10584 my $time_remaining = time_remaining( $time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_msg_transferred ) ;
10585 $mysync->{ debug } and myprint( "time_spent: $time_spent time_remaining: $time_remaining\n" ) ;
10586 my $nb_msg_remaining = $h1_nb_msg_start - $h1_nb_processed ;
10587 my $eta_date = localtime( time + $time_remaining ) ;
10588 return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left',
10589 $eta_date, $time_remaining, $nb_msg_remaining, $h1_nb_msg_start ) ) ;
10590}
10591
10592
10593
10594
10595sub time_remaining
10596{
10597
10598 my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ;
10599
10600 $nb_transferred ||= 1 ; # At least one is done (no division by zero)
10601 $h1_nb_processed ||= 0 ;
10602 $h1_nb_msg_start ||= $h1_nb_processed ;
10603 $my_time_spent ||= 0 ;
10604
10605 my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $h1_nb_msg_start - $h1_nb_processed ) ;
10606 return( $time_remaining ) ;
10607}
10608
10609
10610sub tests_time_remaining
10611{
10612 note( 'Entering tests_time_remaining()' ) ;
10613
10614 # time_spent, nb_processed, nb_to_do_total, nb_transferred
10615 is( 0, time_remaining( ), 'time_remaining: no args -> 0' ) ;
10616 is( 0, time_remaining( 0, 0, 0, 0 ), 'time_remaining: 0, 0, 0, 0 -> 0' ) ;
10617 is( 1, time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ;
10618 is( 1, time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ;
10619 is( 9, time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 9' ) ;
10620 is( 5, time_remaining( 5, 5, 10, 5 ), 'time_remaining: 5, 5, 10, 5 -> 5' ) ;
10621 is( 25, time_remaining( 5, 5, 10, 0 ), 'time_remaining: 5, 5, 10, 0 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ;
10622 is( 25, time_remaining( 5, 5, 10, 1 ), 'time_remaining: 5, 5, 10, 1 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ;
10623
10624 note( 'Leaving tests_time_remaining()' ) ;
10625 return ;
10626}
10627
10628
10629sub cache_map
10630{
10631 my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_;
10632 my ( %map1_2, %map2_1, %done2 ) ;
10633
10634 my $h1_msgs_hash_ref = { } ;
10635 my $h2_msgs_hash_ref = { } ;
10636
10637 @{ $h1_msgs_hash_ref }{ @{ $h1_msgs_ref } } = ( ) ;
10638 @{ $h2_msgs_hash_ref }{ @{ $h2_msgs_ref } } = ( ) ;
10639
10640 foreach my $file ( sort @{ $cache_files_ref } ) {
10641 $debugcache and myprint( "C12: $file\n" ) ;
10642 ( $uid1, $uid2 ) = match_a_cache_file( $file ) ;
10643
10644 if ( exists( $h1_msgs_hash_ref->{ defined $uid1 ? $uid1 : q{} } )
10645 and exists( $h2_msgs_hash_ref->{ defined $uid2 ? $uid2 : q{} } ) ) {
10646 # keep only the greatest uid2
10647 # 130_2301 and
10648 # 130_231 => keep only 130 -> 2301
10649
10650 # keep only the greatest uid1
10651 # 1601_260 and
10652 # 161_260 => keep only 1601 -> 260
10653 my $max_uid2 = max( $uid2, $map1_2{ $uid1 } || $MINUS_ONE ) ;
10654 if ( exists $done2{ $max_uid2 } ) {
10655 if ( $done2{ $max_uid2 } < $uid1 ) {
10656 $map1_2{ $uid1 } = $max_uid2 ;
10657 delete $map1_2{ $done2{ $max_uid2 } } ;
10658 $done2{ $max_uid2 } = $uid1 ;
10659 }
10660 }else{
10661 $map1_2{ $uid1 } = $max_uid2 ;
10662 $done2{ $max_uid2 } = $uid1 ;
10663 }
10664 };
10665
10666 }
10667 %map2_1 = reverse %map1_2 ;
10668 return( \%map1_2, \%map2_1) ;
10669}
10670
10671sub tests_cache_map
10672{
10673 note( 'Entering tests_cache_map()' ) ;
10674
10675 #$debugcache = 1 ;
10676 my @cache_files = qw (
10677 100_200
10678 101_201
10679 120_220
10680 142_242
10681 143_243
10682 177_277
10683 177_278
10684 177_279
10685 155_255
10686 180_280
10687 181_280
10688 182_280
10689 130_231
10690 130_2301
10691 161_260
10692 1601_260
10693 ) ;
10694
10695 my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ];
10696 my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ];
10697
10698 my( $c12, $c21 ) ;
10699 ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' );
10700 my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ;
10701 my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ;
10702 ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' );
10703 ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' );
10704 ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' );
10705 ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' );
10706 ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' );
10707 #myprint( $c12->{1601}, "\n" ) ;
10708
10709 note( 'Leaving tests_cache_map()' ) ;
10710 return ;
10711
10712}
10713
10714sub cache_dir_fix
10715{
10716 my $cache_dir = shift ;
10717 $cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ;
10718 #myprint( "cache_dir_fix: $cache_dir\n" ) ;
10719 return( $cache_dir ) ;
10720}
10721
10722sub tests_cache_dir_fix
10723{
10724 note( 'Entering tests_cache_dir_fix()' ) ;
10725
10726 ok( 'lalala' eq cache_dir_fix('lalala'), 'cache_dir_fix: lalala -> lalala' );
10727 ok( 'ii\\\\ii' eq cache_dir_fix('ii\ii'), 'cache_dir_fix: ii\ii -> ii\\\\ii' );
10728 ok( 'ii@ii' eq cache_dir_fix('ii@ii'), 'cache_dir_fix: ii@ii -> ii@ii' );
10729 ok( 'ii@ii\\:ii' eq cache_dir_fix('ii@ii:ii'), 'cache_dir_fix: ii@ii:ii -> ii@ii\\:ii' );
10730 ok( 'i\\\\i\\\\ii' eq cache_dir_fix('i\i\ii'), 'cache_dir_fix: i\i\ii -> i\\\\i\\\\ii' );
10731 ok( 'i\\\\ii' eq cache_dir_fix('i\\ii'), 'cache_dir_fix: i\\ii -> i\\\\\\\\ii' );
10732 ok( '\\\\ ' eq cache_dir_fix('\\ '), 'cache_dir_fix: \\ -> \\\\\ ' );
10733 ok( '\\\\ ' eq cache_dir_fix('\ '), 'cache_dir_fix: \ -> \\\\\ ' );
10734 ok( '\[bracket\]' eq cache_dir_fix('[bracket]'), 'cache_dir_fix: [bracket] -> \[bracket\]' );
10735
10736 note( 'Leaving tests_cache_dir_fix()' ) ;
10737 return ;
10738}
10739
10740sub cache_dir_fix_win
10741{
10742 my $cache_dir = shift ;
10743 $cache_dir =~ s/(\[|\])/[$1]/xg ;
10744 #myprint( "cache_dir_fix_win: $cache_dir\n" ) ;
10745 return( $cache_dir ) ;
10746}
10747
10748sub tests_cache_dir_fix_win
10749{
10750 note( 'Entering tests_cache_dir_fix_win()' ) ;
10751
10752 ok( 'lalala' eq cache_dir_fix_win('lalala'), 'cache_dir_fix_win: lalala -> lalala' );
10753 ok( '[[]bracket[]]' eq cache_dir_fix_win('[bracket]'), 'cache_dir_fix_win: [bracket] -> [[]bracket[]]' );
10754
10755 note( 'Leaving tests_cache_dir_fix_win()' ) ;
10756 return ;
10757}
10758
10759
10760
10761
10762sub get_cache
10763{
10764 my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_;
10765
10766 $debugcache and myprint( "Entering get_cache\n" ) ;
10767
10768 -d $cache_dir or return( undef ); # exit if cache directory doesn't exist
10769 $debugcache and myprint( "cache_dir : $cache_dir\n" ) ;
10770
10771
10772 if ( 'MSWin32' ne $OSNAME ) {
10773 $cache_dir = cache_dir_fix( $cache_dir ) ;
10774 }else{
10775 $cache_dir = cache_dir_fix_win( $cache_dir ) ;
10776 }
10777
10778 $debugcache and myprint( "cache_dir_fix: $cache_dir\n" ) ;
10779
10780 my @cache_files = bsd_glob( "$cache_dir/*" ) ;
10781 #$debugcache and myprint( "cache_files: [@cache_files]\n" ) ;
10782
10783 $debugcache and myprint( 'cache_files: ', scalar @cache_files , " files found\n" ) ;
10784
10785 my( $cache_1_2_ref, $cache_2_1_ref )
10786 = cache_map( \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ;
10787
10788 clean_cache( \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ;
10789
10790 $debugcache and myprint( "Exiting get_cache\n" ) ;
10791 return( $cache_1_2_ref, $cache_2_1_ref ) ;
10792}
10793
10794
10795sub tests_get_cache
10796{
10797 note( 'Entering tests_get_cache()' ) ;
10798
10799 ok( not( get_cache('/cache_no_exist') ), 'get_cache: /cache_no_exist' );
10800 ok( ( not -d 'W/tmp/cache/F1/F2' or rmtree( 'W/tmp/cache/F1/F2' ) ), 'get_cache: rmtree W/tmp/cache/F1/F2' ) ;
10801 ok( mkpath( 'W/tmp/cache/F1/F2' ), 'get_cache: mkpath W/tmp/cache/F1/F2' ) ;
10802
10803 my @test_files_cache = ( qw(
10804 W/tmp/cache/F1/F2/100_200
10805 W/tmp/cache/F1/F2/101_201
10806 W/tmp/cache/F1/F2/120_220
10807 W/tmp/cache/F1/F2/142_242
10808 W/tmp/cache/F1/F2/143_243
10809 W/tmp/cache/F1/F2/177_277
10810 W/tmp/cache/F1/F2/177_377
10811 W/tmp/cache/F1/F2/177_777
10812 W/tmp/cache/F1/F2/155_255
10813 ) ) ;
10814 ok( touch( @test_files_cache ), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ;
10815
10816
10817 # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255
10818 # on live:
10819 my $msgs_1 = [120, 142, 143, 144, 177 ];
10820 my $msgs_2 = [ 242, 243, 299, 377, 777, 255 ];
10821
10822 my $msgs_all_1 = { 120 => 0, 142 => 0, 143 => 0, 144 => 0, 177 => 0 } ;
10823 my $msgs_all_2 = { 242 => 0, 243 => 0, 299 => 0, 377 => 0, 777 => 0, 255 => 0 } ;
10824
10825 my( $c12, $c21 ) ;
10826 ok( ( $c12, $c21 ) = get_cache( 'W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' );
10827 my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ;
10828 my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ;
10829 ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: 03' );
10830 ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: 04' );
10831 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242');
10832 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243');
10833 ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file removed 100_200');
10834 ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file removed 101_201');
10835
10836 # test clean_cache executed
10837 $maxage = 2 ;
10838 ok( touch(@test_files_cache), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ;
10839 ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' );
10840 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242');
10841 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243');
10842 ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file NOT removed 100_200');
10843 ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file NOT removed 101_201');
10844
10845
10846 # strange files
10847 #$debugcache = 1 ;
10848 $maxage = undef ;
10849 ok( ( not -d 'W/tmp/cache/rr\uee' or rmtree( 'W/tmp/cache/rr\uee' )), 'get_cache: rmtree W/tmp/cache/rr\uee' ) ;
10850 ok( mkpath( 'W/tmp/cache/rr\uee' ), 'get_cache: mkpath W/tmp/cache/rr\uee' ) ;
10851
10852 @test_files_cache = ( qw(
10853 W/tmp/cache/rr\uee/100_200
10854 W/tmp/cache/rr\uee/101_201
10855 W/tmp/cache/rr\uee/120_220
10856 W/tmp/cache/rr\uee/142_242
10857 W/tmp/cache/rr\uee/143_243
10858 W/tmp/cache/rr\uee/177_277
10859 W/tmp/cache/rr\uee/177_377
10860 W/tmp/cache/rr\uee/177_777
10861 W/tmp/cache/rr\uee/155_255
10862 ) ) ;
10863 ok( touch(@test_files_cache), 'get_cache: touch strange W/tmp/cache/...' ) ;
10864
10865 # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255
10866 # on live:
10867 $msgs_1 = [120, 142, 143, 144, 177 ] ;
10868 $msgs_2 = [ 242, 243, 299, 377, 777, 255 ] ;
10869
10870 $msgs_all_1 = { 120 => q{}, 142 => q{}, 143 => q{}, 144 => q{}, 177 => q{} } ;
10871 $msgs_all_2 = { 242 => q{}, 243 => q{}, 299 => q{}, 377 => q{}, 777 => q{}, 255 => q{} } ;
10872
10873 ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/rr\uee', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2), 'get_cache: strange path 02' );
10874 $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ;
10875 $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ;
10876 ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: strange path 03' );
10877 ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: strange path 04' );
10878 ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 142_242');
10879 ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 143_243');
10880 ok( ! -f 'W/tmp/cache/rr\uee/100_200', 'get_cache: strange path file removed 100_200');
10881 ok( ! -f 'W/tmp/cache/rr\uee/101_201', 'get_cache: strange path file removed 101_201');
10882
10883 note( 'Leaving tests_get_cache()' ) ;
10884 return ;
10885}
10886
10887sub match_a_cache_file
10888{
10889 my $file = shift ;
10890 my ( $cache_uid1, $cache_uid2 ) ;
10891
10892 return( ( undef, undef ) ) if ( ! $file ) ;
10893 if ( $file =~ m{(?:^|/)(\d+)_(\d+)$}x ) {
10894 $cache_uid1 = $1 ;
10895 $cache_uid2 = $2 ;
10896 }
10897 return( $cache_uid1, $cache_uid2 ) ;
10898}
10899
10900sub tests_match_a_cache_file
10901{
10902 note( 'Entering tests_match_a_cache_file()' ) ;
10903
10904 my ( $tuid1, $tuid2 ) ;
10905 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ;
10906 ok( ! defined $tuid1 , 'match_a_cache_file: no arg 1' ) ;
10907 ok( ! defined $tuid2 , 'match_a_cache_file: no arg 2' ) ;
10908
10909 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( q{} ), 'match_a_cache_file: empty arg' ) ;
10910 ok( ! defined $tuid1 , 'match_a_cache_file: empty arg 1' ) ;
10911 ok( ! defined $tuid2 , 'match_a_cache_file: empty arg 2' ) ;
10912
10913 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ;
10914 ok( '000' eq $tuid1, 'match_a_cache_file: 000_000 1' ) ;
10915 ok( '000' eq $tuid2, 'match_a_cache_file: 000_000 2' ) ;
10916
10917 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ;
10918 ok( '123' eq $tuid1, 'match_a_cache_file: 123_456 1' ) ;
10919 ok( '456' eq $tuid2, 'match_a_cache_file: 123_456 2' ) ;
10920
10921 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ;
10922 ok( '123' eq $tuid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ;
10923 ok( '456' eq $tuid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ;
10924
10925 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ;
10926 ok( ! $tuid1, 'match_a_cache_file: /lala123_456 1' ) ;
10927 ok( ! $tuid2, 'match_a_cache_file: /lala123_456 2' ) ;
10928
10929 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ;
10930 ok( ! $tuid1, 'match_a_cache_file: la123_456 1' ) ;
10931 ok( ! $tuid2, 'match_a_cache_file: la123_456 2' ) ;
10932
10933 note( 'Leaving tests_match_a_cache_file()' ) ;
10934 return ;
10935}
10936
10937sub clean_cache
10938{
10939 my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ;
10940
10941 $debugcache and myprint( "Entering clean_cache\n" ) ;
10942
10943 $debugcache and myprint( map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %{ $cache_1_2_ref } ) ;
10944 foreach my $file ( @{ $cache_files_ref } ) {
10945 $debugcache and myprint( "$file\n" ) ;
10946 my ( $cache_uid1, $cache_uid2 ) = match_a_cache_file( $file ) ;
10947 $debugcache and myprint( "u1: $cache_uid1 u2: $cache_uid2 c12: ", $cache_1_2_ref->{ $cache_uid1 } || q{}, "\n") ;
10948# or ( ! exists( $cache_1_2_ref->{ $cache_uid1 } ) )
10949# or ( ! ( $cache_uid2 == $cache_1_2_ref->{ $cache_uid1 } ) )
10950 if ( ( not defined $cache_uid1 )
10951 or ( not defined $cache_uid2 )
10952 or ( not exists $h1_msgs_all_hash_ref->{ $cache_uid1 } )
10953 or ( not exists $h2_msgs_all_hash_ref->{ $cache_uid2 } )
10954 ) {
10955 $debugcache and myprint( "remove $file\n" ) ;
10956 unlink $file or myprint( "$OS_ERROR" ) ;
10957 }
10958 }
10959
10960 $debugcache and myprint( "Exiting clean_cache\n" ) ;
10961 return( 1 ) ;
10962}
10963
10964sub tests_clean_cache
10965{
10966 note( 'Entering tests_clean_cache()' ) ;
10967
10968 ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache: rmtree W/tmp/cache/G1/G2' ) ;
10969 ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache: mkpath W/tmp/cache/G1/G2' ) ;
10970
10971 my @test_files_cache = ( qw(
10972 W/tmp/cache/G1/G2/100_200
10973 W/tmp/cache/G1/G2/101_201
10974 W/tmp/cache/G1/G2/120_220
10975 W/tmp/cache/G1/G2/142_242
10976 W/tmp/cache/G1/G2/143_243
10977 W/tmp/cache/G1/G2/177_277
10978 W/tmp/cache/G1/G2/177_377
10979 W/tmp/cache/G1/G2/177_777
10980 W/tmp/cache/G1/G2/155_255
10981 ) ) ;
10982 ok( touch(@test_files_cache), 'clean_cache: touch W/tmp/cache/G1/G2/...' ) ;
10983
10984 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' );
10985 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' );
10986 ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' );
10987 ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' );
10988 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' );
10989 ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' );
10990
10991 my $cache = {
10992 142 => 242,
10993 177 => 777,
10994 } ;
10995
10996 my $all_1 = {
10997 142 => q{},
10998 177 => q{},
10999 } ;
11000
11001 my $all_2 = {
11002 200 => q{},
11003 242 => q{},
11004 777 => q{},
11005 } ;
11006 ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache: ' ) ;
11007
11008 ok( ! -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 after' );
11009 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 after' );
11010 ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 after' );
11011 ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 after' );
11012 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 after' );
11013 ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 after' );
11014
11015 note( 'Leaving tests_clean_cache()' ) ;
11016 return ;
11017}
11018
11019sub tests_clean_cache_2
11020{
11021 note( 'Entering tests_clean_cache_2()' ) ;
11022
11023 ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ;
11024 ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ;
11025
11026 my @test_files_cache = ( qw(
11027 W/tmp/cache/G1/G2/100_200
11028 W/tmp/cache/G1/G2/101_201
11029 W/tmp/cache/G1/G2/120_220
11030 W/tmp/cache/G1/G2/142_242
11031 W/tmp/cache/G1/G2/143_243
11032 W/tmp/cache/G1/G2/177_277
11033 W/tmp/cache/G1/G2/177_377
11034 W/tmp/cache/G1/G2/177_777
11035 W/tmp/cache/G1/G2/155_255
11036 ) ) ;
11037 ok( touch(@test_files_cache), 'clean_cache_2: touch W/tmp/cache/G1/G2/...' ) ;
11038
11039 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' );
11040 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' );
11041 ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' );
11042 ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' );
11043 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' );
11044 ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' );
11045
11046 my $cache = {
11047 142 => 242,
11048 177 => 777,
11049 } ;
11050
11051 my $all_1 = {
11052 $NUMBER_100 => q{},
11053 142 => q{},
11054 177 => q{},
11055 } ;
11056
11057 my $all_2 = {
11058 200 => q{},
11059 242 => q{},
11060 777 => q{},
11061 } ;
11062
11063
11064
11065 ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache_2: ' ) ;
11066
11067 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 after' );
11068 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 after' );
11069 ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 after' );
11070 ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 after' );
11071 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 after' );
11072 ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 after' );
11073
11074 note( 'Leaving tests_clean_cache_2()' ) ;
11075 return ;
11076}
11077
11078
11079
11080sub tests_mkpath
11081{
11082 note( 'Entering tests_mkpath()' ) ;
11083
11084 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'mkpath: mkpath W/tmp/tests/' ) ;
11085
11086 SKIP: {
11087 skip( 'Tests only for Unix', 10 ) if ( 'MSWin32' eq $OSNAME ) ;
11088 my $long_path_unix = '123456789/' x 30 ;
11089 ok( ( -d "W/tmp/tests/long/$long_path_unix" or mkpath( "W/tmp/tests/long/$long_path_unix" ) ), 'mkpath: mkpath 300 char' ) ;
11090 ok( -d "W/tmp/tests/long/$long_path_unix", 'mkpath: mkpath > 300 char verified' ) ;
11091 ok( ( -d "W/tmp/tests/long/$long_path_unix" and rmtree( 'W/tmp/tests/long/' ) ), 'mkpath: rmtree 300 char' ) ;
11092 ok( ! -d "W/tmp/tests/long/$long_path_unix", 'mkpath: rmtree 300 char verified' ) ;
11093
11094 ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ;
11095 ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ;
11096 ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ;
11097 ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ;
11098
11099 eval { ok( 1 / 0, 'mkpath: divide by 0' ) ; } or ok( 1, 'mkpath: can not divide by 0' ) ;
11100 ok( 1, 'mkpath: still alive' ) ;
11101 } ;
11102
11103 SKIP: {
11104 skip( 'Tests only for MSWin32', 13 ) if ( 'MSWin32' ne $OSNAME ) ;
11105 my $long_path_2_prefix = ".\\imapsync_tests" || '\\\?\\E:\\TEMP\\imapsync_tests' ;
11106 myprint( "long_path_2_prefix: $long_path_2_prefix\n" ) ;
11107
11108 my $long_path_100 = $long_path_2_prefix . '\\' . '123456789\\' x 10 . 'END' ;
11109 my $long_path_300 = $long_path_2_prefix . '\\' . '123456789\\' x 30 . 'END' ;
11110
11111 #myprint( "$long_path_100\n" ) ;
11112
11113 ok( ( -d $long_path_2_prefix or mkpath( $long_path_2_prefix ) ), 'mkpath: -d mkpath small path' ) ;
11114 ok( ( -d $long_path_2_prefix ), 'mkpath: -d mkpath small path done' ) ;
11115 ok( ( -d $long_path_100 or mkpath( $long_path_100 ) ), 'mkpath: mkpath > 100 char' ) ;
11116 ok( ( -d $long_path_100 ), 'mkpath: -d mkpath > 200 char done' ) ;
11117 ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'mkpath: rmtree > 100 char' ) ;
11118 ok( (! -d $long_path_2_prefix ), 'mkpath: ! -d rmtree done' ) ;
11119
11120 # Without the eval the following mkpath 300 just kill the whole process without a whisper
11121 #myprint( "$long_path_300\n" ) ;
11122 eval { ok( ( -d $long_path_300 or mkpath( $long_path_300 ) ), 'mkpath: create a path with 300 characters' ) ; }
11123 or ok( 1, 'mkpath: can not create a path with 300 characters' ) ;
11124 ok( ( ( ! -d $long_path_300 ) or -d $long_path_300 and rmtree( $long_path_300 ) ), 'mkpath: rmtree the 300 character path' ) ;
11125 ok( 1, 'mkpath: still alive' ) ;
11126
11127 ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ;
11128 ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ;
11129 ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ;
11130 ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ;
11131
11132
11133 } ;
11134
11135 note( 'Leaving tests_mkpath()' ) ;
11136 # Keep this because of the eval used by the caller (failed badly?)
11137 return 1 ;
11138}
11139
11140sub tests_touch
11141{
11142 note( 'Entering tests_touch()' ) ;
11143
11144 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'touch: mkpath W/tmp/tests/' ) ;
11145 ok( 1 == touch( 'W/tmp/tests/lala'), 'touch: W/tmp/tests/lala') ;
11146 ok( 1 == touch( 'W/tmp/tests/\y'), 'touch: W/tmp/tests/\y') ;
11147 ok( 0 == touch( '/no/no/no/aaa'), 'touch: not /aaa') ;
11148 ok( 1 == touch( 'W/tmp/tests/lili', 'W/tmp/tests/lolo'), 'touch: 2 files') ;
11149 ok( 0 == touch( 'W/tmp/tests/\y', '/no/no/aaa'), 'touch: 2 files, 1 fails' ) ;
11150
11151 note( 'Leaving tests_touch()' ) ;
11152 return ;
11153}
11154
11155
11156sub touch
11157{
11158 my @files = @_ ;
11159 my $failures = 0 ;
11160
11161 foreach my $file ( @files ) {
11162 my $fh = IO::File->new ;
11163 if ( $fh->open(">> $file" ) ) {
11164 $fh->close ;
11165 }else{
11166 myprint( "Could not open file $file in write/append mode\n" ) ;
11167 $failures++ ;
11168 }
11169 }
11170 return( ! $failures );
11171}
11172
11173
11174sub tests_tmpdir_has_colon_bug
11175{
11176 note( 'Entering tests_tmpdir_has_colon_bug()' ) ;
11177
11178 ok( 0 == tmpdir_has_colon_bug( q{} ), 'tmpdir_has_colon_bug: ' ) ;
11179 ok( 0 == tmpdir_has_colon_bug( '/tmp' ), 'tmpdir_has_colon_bug: /tmp' ) ;
11180 ok( 1 == tmpdir_has_colon_bug( 'C:' ), 'tmpdir_has_colon_bug: C:' ) ;
11181 ok( 1 == tmpdir_has_colon_bug( 'C:\temp' ), 'tmpdir_has_colon_bug: C:\temp' ) ;
11182
11183 note( 'Leaving tests_tmpdir_has_colon_bug()' ) ;
11184 return ;
11185}
11186
11187sub tmpdir_has_colon_bug
11188{
11189 my $path = shift ;
11190
11191 my $path_filtered = filter_forbidden_characters( $path ) ;
11192 if ( $path_filtered ne $path ) {
11193 ( -d $path_filtered ) and myprint( "Path $path was previously mistakely changed to $path_filtered\n" ) ;
11194 return( 1 ) ;
11195 }
11196 return( 0 ) ;
11197}
11198
11199sub tmpdir_fix_colon_bug
11200{
11201 my $mysync = shift ;
11202 my $err = 0 ;
11203 if ( not (-d $mysync->{ tmpdir } and -r _ and -w _) ) {
11204 myprint( "tmpdir $mysync->{ tmpdir } is not valid\n" ) ;
11205 return( 0 ) ;
11206 }
11207 my $cachedir_new = "$mysync->{ tmpdir }/imapsync_cache" ;
11208
11209 if ( not tmpdir_has_colon_bug( $cachedir_new ) ) { return( 0 ) } ;
11210
11211 # check if old cache directory already exists
11212 my $cachedir_old = filter_forbidden_characters( $cachedir_new ) ;
11213 if ( not ( -d $cachedir_old ) ) {
11214 myprint( "Old cache directory $cachedir_new no exists, nothing to do\n" ) ;
11215 return( 1 ) ;
11216 }
11217 # check if new cache directory already exists
11218 if ( -d $cachedir_new ) {
11219 myprint( "New fixed cache directory $cachedir_new already exists, not moving the old one $cachedir_old. Fix this manually.\n" ) ;
11220 return( 0 ) ;
11221 }else{
11222 # move the old one to the new place
11223 myprint( "Moving $cachedir_old to $cachedir_new Do not interrupt this task.\n" ) ;
11224 File::Copy::Recursive::rmove( $cachedir_old, $cachedir_new )
11225 or do {
11226 myprint( "Could not move $cachedir_old to $cachedir_new\n" ) ;
11227 $err++ ;
11228 } ;
11229 # check it succeeded
11230 if ( -d $cachedir_new and -r _ and -w _ ) {
11231 myprint( "New fixed cache directory $cachedir_new ok\n" ) ;
11232 }else{
11233 myprint( "New fixed cache directory $cachedir_new does not exist\n" ) ;
11234 $err++ ;
11235 }
11236 if ( -d $cachedir_old ) {
11237 myprint( "Old cache directory $cachedir_old still exists\n" ) ;
11238 $err++ ;
11239 }else{
11240 myprint( "Old cache directory $cachedir_old successfuly moved\n" ) ;
11241 }
11242 }
11243 return( not $err ) ;
11244}
11245
11246
11247sub tests_cache_folder
11248{
11249 note( 'Entering tests_cache_folder()' ) ;
11250
11251 ok( '/path/fold1/fold2' eq cache_folder( q{}, '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ;
11252 ok( '/pa_th/fold1/fold2' eq cache_folder( q{}, '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ;
11253 ok( '/_p_a__th/fol_d1/fold2' eq cache_folder( q{}, '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ;
11254
11255 ok( 'D:/path/fold1/fold2' eq cache_folder( 'D:', '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ;
11256 ok( 'D:/pa_th/fold1/fold2' eq cache_folder( 'D:', '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ;
11257 ok( 'D:/_p_a__th/fol_d1/fold2' eq cache_folder( 'D:', '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ;
11258 ok( '//' eq cache_folder( q{}, q{}, q{}, q{}), 'cache_folder: -> //' ) ;
11259 ok( '//_______' eq cache_folder( q{}, q{}, q{}, '*|?:"<>'), 'cache_folder: *|?:"<> -> //_______' ) ;
11260
11261 note( 'Leaving tests_cache_folder()' ) ;
11262 return ;
11263}
11264
11265sub cache_folder
11266{
11267 my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ;
11268
11269 my $sep_1 = $sync->{ h1_sep } || '/';
11270 my $sep_2 = $sync->{ h2_sep } || '/';
11271
11272 #myprint( "$cache_dir h1_fold $h1_fold sep1 $sep_1 h2_fold $h2_fold sep2 $sep_2\n" ) ;
11273 $h1_fold = convert_sep_to_slash( $h1_fold, $sep_1 ) ;
11274 $h2_fold = convert_sep_to_slash( $h2_fold, $sep_2 ) ;
11275
11276 my $cache_folder = "$cache_base" . filter_forbidden_characters( "$cache_dir/$h1_fold/$h2_fold" ) ;
11277 #myprint( "cache_folder [$cache_folder]\n" ) ;
11278 return( $cache_folder ) ;
11279}
11280
11281sub tests_filter_forbidden_characters
11282{
11283 note( 'Entering tests_filter_forbidden_characters()' ) ;
11284
11285 ok( 'a_b' eq filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ;
11286 ok( 'a_b' eq filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ;
11287 ok( 'a_b' eq filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ;
11288 ok( 'a_b' eq filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ;
11289 ok( 'a_______b' eq filter_forbidden_characters( 'a*|?:"<>b' ), 'filter_forbidden_characters: a*|?:"<>b -> a_______b' ) ;
11290
11291 SKIP: {
11292 skip( 'Not on MSWin32', 1 ) if ( 'MSWin32' eq $OSNAME ) ;
11293 ok( ( 'a b ' eq filter_forbidden_characters( 'a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b "' ) ;
11294 } ;
11295
11296 SKIP: {
11297 skip( 'Only on MSWin32', 2 ) if ( 'MSWin32' ne $OSNAME ) ;
11298 ok( ( ' a b_' eq filter_forbidden_characters( ' a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b_"' ) ;
11299 ok( ( ' a b_/ c d_' eq filter_forbidden_characters( ' a b / c d ' ) ), 'filter_forbidden_characters: " a b / c d " -> "a b_/ c d_"' ) ;
11300 } ;
11301
11302 ok( 'a_b' eq filter_forbidden_characters( "a\tb" ), 'filter_forbidden_characters: a\tb -> a_b' ) ;
11303 ok( "a_b" eq filter_forbidden_characters( "a\rb" ), 'filter_forbidden_characters: a\rb -> a_b' ) ;
11304 ok( "a_b" eq filter_forbidden_characters( "a\nb" ), 'filter_forbidden_characters: a\nb -> a_b' ) ;
11305 ok( "a_b" eq filter_forbidden_characters( "a\\b" ), 'filter_forbidden_characters: a\b -> a_b' ) ;
11306
11307 note( 'Leaving tests_filter_forbidden_characters()' ) ;
11308 return ;
11309}
11310
11311sub filter_forbidden_characters
11312{
11313 my $string = shift ;
11314
11315 if ( ! defined $string ) { return ; }
11316
11317 if ( 'MSWin32' eq $OSNAME ) {
11318 # Move trailing whitespace to _ " a b /c d " -> " a b_/c d_"
11319 $string =~ s{\ (/|$)}{_$1}xg ;
11320 }
11321 $string =~ s{[\Q*|?:"<>\E\t\r\n\\]}{_}xg ;
11322 #myprint( "[$string]\n" ) ;
11323 return( $string ) ;
11324}
11325
11326sub tests_convert_sep_to_slash
11327{
11328 note( 'Entering tests_convert_sep_to_slash()' ) ;
11329
11330
11331 ok(q{} eq convert_sep_to_slash(q{}, '/'), 'convert_sep_to_slash: no folder');
11332 ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX');
11333 ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo');
11334 ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo');
11335 ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob');
11336 ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo');
11337 ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi');
11338
11339 note( 'Leaving tests_convert_sep_to_slash()' ) ;
11340 return ;
11341}
11342
11343sub convert_sep_to_slash
11344{
11345 my ( $folder, $sep ) = @_ ;
11346
11347 $folder =~ s{\Q$sep\E}{/}xg ;
11348 return( $folder ) ;
11349}
11350
11351
11352sub tests_regexmess
11353{
11354 note( 'Entering tests_regexmess()' ) ;
11355
11356 ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess, no regexmess, nothing to do' ) ;
11357
11358 @regexmess = ( 'lalala' ) ;
11359 ok( not( defined regexmess( 'popopo' ) ), 'regexmess, bad regex lalala' ) ;
11360
11361 @regexmess = ( 's/p/Z/g' ) ;
11362 ok( 'ZoZoZo' eq regexmess( 'popopo' ), 'regexmess, s/p/Z/g' ) ;
11363
11364 @regexmess = ( 's{c}{C}gxms' ) ;
11365 ok("H1: abC\nH2: Cde\n\nBody abC"
11366 eq regexmess( "H1: abc\nH2: cde\n\nBody abc"),
11367 'regexmess, c->C');
11368
11369 @regexmess = ( 's{\AFrom\ }{From:}gxms' ) ;
11370 ok( q{}
11371 eq regexmess(q{}),
11372 'From mbox 1 add colon blank');
11373
11374 ok( 'From:<tartanpion@machin.truc>'
11375 eq regexmess('From <tartanpion@machin.truc>'),
11376 'From mbox 2 add colo');
11377
11378 ok( "\n" . 'From <tartanpion@machin.truc>'
11379 eq regexmess("\n" . 'From <tartanpion@machin.truc>'),
11380 'From mbox 3 add colo') ;
11381
11382 ok( "From: zzz\n" . 'From <tartanpion@machin.truc>'
11383 eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'),
11384 'From mbox 4 add colo') ;
11385
11386 @regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ;
11387 ok( q{}
11388 eq regexmess(q{}),
11389 'From mbox 1 remove, blank');
11390
11391 ok( q{}
11392 eq regexmess('From <tartanpion@machin.truc>'),
11393 'From mbox 2 remove');
11394
11395 ok( "\n" . 'From <tartanpion@machin.truc>'
11396 eq regexmess("\n" . 'From <tartanpion@machin.truc>'),
11397 'From mbox 3 remove');
11398
11399 #myprint( "[", regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), "]" ) ;
11400 ok( q{} . 'From <tartanpion@machin.truc>'
11401 eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'),
11402 'From mbox 4 remove');
11403
11404
11405 ok(
11406<<'EOM'
11407Date: Sat, 10 Jul 2010 05:34:45 -0700
11408From:<tartanpion@machin.truc>
11409
11410Hello,
11411Bye.
11412EOM
11413 eq regexmess(
11414<<'EOM'
11415From zzz
11416Date: Sat, 10 Jul 2010 05:34:45 -0700
11417From:<tartanpion@machin.truc>
11418
11419Hello,
11420Bye.
11421EOM
11422), 'From mbox 5 remove');
11423
11424
11425@regexmess = ( 's{\A((?:[^\n]+\n)+|)^Disposition-Notification-To:[^\n]*\n(\r?\n|.*\n\r?\n)}{$1$2}xms' ) ; # SUPER SUPER BEST!
11426 ok(
11427<<'EOM'
11428Date: Sat, 10 Jul 2010 05:34:45 -0700
11429From:<tartanpion@machin.truc>
11430
11431Hello,
11432Bye.
11433EOM
11434 eq regexmess(
11435<<'EOM'
11436Date: Sat, 10 Jul 2010 05:34:45 -0700
11437Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11438From:<tartanpion@machin.truc>
11439
11440Hello,
11441Bye.
11442EOM
11443 ),
11444 'regexmess: 1 Delete header Disposition-Notification-To:');
11445
11446 ok(
11447<<'EOM'
11448Date: Sat, 10 Jul 2010 05:34:45 -0700
11449From:<tartanpion@machin.truc>
11450
11451Hello,
11452Bye.
11453EOM
11454 eq regexmess(
11455<<'EOM'
11456Date: Sat, 10 Jul 2010 05:34:45 -0700
11457From:<tartanpion@machin.truc>
11458Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11459
11460Hello,
11461Bye.
11462EOM
11463),
11464 'regexmess: 2 Delete header Disposition-Notification-To:');
11465
11466 ok(
11467<<'EOM'
11468Date: Sat, 10 Jul 2010 05:34:45 -0700
11469From:<tartanpion@machin.truc>
11470
11471Hello,
11472Bye.
11473EOM
11474 eq regexmess(
11475<<'EOM'
11476Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11477Date: Sat, 10 Jul 2010 05:34:45 -0700
11478From:<tartanpion@machin.truc>
11479
11480Hello,
11481Bye.
11482EOM
11483),
11484 'regexmess: 3 Delete header Disposition-Notification-To:');
11485
11486 ok(
11487<<'EOM'
11488Date: Sat, 10 Jul 2010 05:34:45 -0700
11489From:<tartanpion@machin.truc>
11490
11491Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11492Bye.
11493EOM
11494 eq regexmess(
11495<<'EOM'
11496Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11497Date: Sat, 10 Jul 2010 05:34:45 -0700
11498From:<tartanpion@machin.truc>
11499
11500Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11501Bye.
11502EOM
11503),
11504 'regexmess: 4 Delete header Disposition-Notification-To:');
11505
11506
11507 ok(
11508<<'EOM'
11509Date: Sat, 10 Jul 2010 05:34:45 -0700
11510From:<tartanpion@machin.truc>
11511
11512Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11513Bye.
11514EOM
11515 eq regexmess(
11516<<'EOM'
11517Date: Sat, 10 Jul 2010 05:34:45 -0700
11518From:<tartanpion@machin.truc>
11519
11520Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11521Bye.
11522EOM
11523),
11524 'regexmess: 5 Delete header Disposition-Notification-To:');
11525
11526
11527ok(
11528<<'EOM'
11529Date: Sat, 10 Jul 2010 05:34:45 -0700
11530From:<tartanpion@machin.truc>
11531
11532Hello,
11533Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11534Bye.
11535EOM
11536 eq regexmess(
11537<<'EOM'
11538Date: Sat, 10 Jul 2010 05:34:45 -0700
11539From:<tartanpion@machin.truc>
11540
11541Hello,
11542Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11543Bye.
11544EOM
11545),
11546 'regexmess: 6 Delete header Disposition-Notification-To:');
11547
11548ok(
11549<<'EOM'
11550Date: Sat, 10 Jul 2010 05:34:45 -0700
11551From:<tartanpion@machin.truc>
11552
11553Hello,
11554Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11555
11556Bye.
11557EOM
11558 eq regexmess(
11559<<'EOM'
11560Date: Sat, 10 Jul 2010 05:34:45 -0700
11561From:<tartanpion@machin.truc>
11562
11563Hello,
11564Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11565
11566Bye.
11567EOM
11568),
11569 'regexmess: 7 Delete header Disposition-Notification-To:');
11570
11571
11572ok(
11573<<'EOM'
11574Date: Sat, 10 Jul 2010 05:34:45 -0700
11575From:<tartanpion@machin.truc>
11576
11577Hello,
11578Bye.
11579EOM
11580 eq regexmess(
11581<<'EOM'
11582Date: Sat, 10 Jul 2010 05:34:45 -0700
11583From:<tartanpion@machin.truc>
11584
11585Hello,
11586Bye.
11587EOM
11588),
11589 'regexmess: 8 Delete header Disposition-Notification-To:');
11590
11591
11592ok(
11593<<'EOM'
11594Date: Sat, 10 Jul 2010 05:34:45 -0700
11595From:<tartanpion@machin.truc>
11596
11597Hello,
11598Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11599Bye.
11600EOM
11601 eq regexmess(
11602<<'EOM'
11603Date: Sat, 10 Jul 2010 05:34:45 -0700
11604From:<tartanpion@machin.truc>
11605
11606Hello,
11607Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11608Bye.
11609EOM
11610),
11611 'regexmess: 9 Delete header Disposition-Notification-To:');
11612
11613
11614
11615ok(
11616<<'EOM'
11617Date: Sat, 10 Jul 2010 05:34:45 -0700
11618From:<tartanpion@machin.truc>
11619
11620Hello,
11621Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11622
11623
11624Bye.
11625EOM
11626 eq regexmess(
11627<<'EOM'
11628Date: Sat, 10 Jul 2010 05:34:45 -0700
11629From:<tartanpion@machin.truc>
11630
11631Hello,
11632Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11633
11634
11635Bye.
11636EOM
11637),
11638 'regexmess: 10 Delete header Disposition-Notification-To:');
11639
11640ok(
11641<<'EOM'
11642Date: Sat, 10 Jul 2010 05:34:45 -0700
11643From:<tartanpion@machin.truc>
11644
11645Hello,
11646
11647Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11648
11649Bye.
11650EOM
11651 eq regexmess(
11652<<'EOM'
11653Date: Sat, 10 Jul 2010 05:34:45 -0700
11654From:<tartanpion@machin.truc>
11655
11656Hello,
11657
11658Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11659
11660Bye.
11661EOM
11662),
11663 'regexmess: 11 Delete header Disposition-Notification-To:');
11664
11665ok(
11666<<'EOM'
11667Date: Sat, 10 Jul 2010 05:34:45 -0700
11668From:<tartanpion@machin.truc>
11669
11670Hello,
11671
11672Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11673
11674Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11675
11676Bye.
11677EOM
11678 eq regexmess(
11679<<'EOM'
11680Date: Sat, 10 Jul 2010 05:34:45 -0700
11681From:<tartanpion@machin.truc>
11682
11683Hello,
11684
11685Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11686
11687Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11688
11689Bye.
11690EOM
11691),
11692 'regexmess: 12 Delete header Disposition-Notification-To:');
11693
11694
11695@regexmess = ( 's{\A(.*?(?! ^$))^Disposition-Notification-To:(.*?)$}{$1X-Disposition-Notification-To:$2}igxms' ) ; # BAD!
11696@regexmess = ( 's{\A((?:[^\n]+\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims' ) ;
11697
11698
11699ok(
11700<<'EOM'
11701Date: Sat, 10 Jul 2010 05:34:45 -0700
11702From:<tartanpion@machin.truc>
11703
11704Hello,
11705
11706Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11707
11708Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11709
11710Bye.
11711EOM
11712 eq regexmess(
11713<<'EOM'
11714Date: Sat, 10 Jul 2010 05:34:45 -0700
11715From:<tartanpion@machin.truc>
11716
11717Hello,
11718
11719Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11720
11721Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11722
11723Bye.
11724EOM
11725),
11726 'regexmess: 13 Delete header Disposition-Notification-To:');
11727
11728ok(
11729<<'EOM'
11730Date: Sat, 10 Jul 2010 05:34:45 -0700
11731X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11732From:<tartanpion@machin.truc>
11733
11734Hello,
11735
11736Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11737
11738Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11739
11740Bye.
11741EOM
11742 eq regexmess(
11743<<'EOM'
11744Date: Sat, 10 Jul 2010 05:34:45 -0700
11745Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11746From:<tartanpion@machin.truc>
11747
11748Hello,
11749
11750Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11751
11752Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11753
11754Bye.
11755EOM
11756),
11757 'regexmess: 14 Delete header Disposition-Notification-To:');
11758
11759ok(
11760<<'EOM'
11761Date: Sat, 10 Jul 2010 05:34:45 -0700
11762X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11763From:<tartanpion@machin.truc>
11764
11765Hello,
11766
11767Bye.
11768EOM
11769 eq regexmess(
11770<<'EOM'
11771Date: Sat, 10 Jul 2010 05:34:45 -0700
11772Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11773From:<tartanpion@machin.truc>
11774
11775Hello,
11776
11777Bye.
11778EOM
11779),
11780 'regexmess: 15 Delete header Disposition-Notification-To:');
11781
11782
11783ok(
11784<<'EOM'
11785Date: Sat, 10 Jul 2010 05:34:45 -0700
11786From:<tartanpion@machin.truc>
11787X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11788
11789Hello,
11790
11791Bye.
11792EOM
11793 eq regexmess(
11794<<'EOM'
11795Date: Sat, 10 Jul 2010 05:34:45 -0700
11796From:<tartanpion@machin.truc>
11797Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11798
11799Hello,
11800
11801Bye.
11802EOM
11803),
11804 'regexmess: 16 Delete header Disposition-Notification-To:');
11805
11806ok(
11807<<'EOM'
11808X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11809Date: Sat, 10 Jul 2010 05:34:45 -0700
11810From:<tartanpion@machin.truc>
11811
11812Hello,
11813
11814Bye.
11815EOM
11816 eq regexmess(
11817<<'EOM'
11818Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info>
11819Date: Sat, 10 Jul 2010 05:34:45 -0700
11820From:<tartanpion@machin.truc>
11821
11822Hello,
11823
11824Bye.
11825EOM
11826),
11827 'regexmess: 17 Delete header Disposition-Notification-To:');
11828
11829 @regexmess = ( 's/.{11}\K.*//gs' ) ;
11830 is( "0123456789\n", regexmess( "0123456789\n" x 100 ), 'regexmess, truncate whole message after 11 characters' ) ;
11831 is( "0123456789\n", regexmess( "0123456789\n" x 100_000 ), 'regexmess, truncate whole message after 11 characters ~ 1MB' ) ;
11832
11833 @regexmess = ( 's/.{10000}\K.*//gs' ) ;
11834 is( "123456789\n" x 1000, regexmess( "123456789\n" x 100_000 ), 'regexmess, truncate whole message after 10000 characters ~ 1MB' ) ;
11835
11836@regexmess = ( 's/^(X-Ham-Report.*?\n)^X-/X-/sm' ) ;
11837
11838is(
11839<<'EOM'
11840X-Spam-Score: -1
11841X-Spam-Bar: /
11842X-Spam-Flag: NO
11843Date: Sat, 10 Jul 2010 05:34:45 -0700
11844From:<tartanpion@machin.truc>
11845
11846Hello,
11847
11848Bye.
11849EOM
11850,
11851regexmess(
11852<<'EOM'
11853X-Spam-Score: -1
11854X-Spam-Bar: /
11855X-Ham-Report: =?utf-8?Q?Spam_detection_software=2C_running?=
11856 =?utf-8?Q?_on_the_system_=22ohp-ag006.int200?=
11857_has_NOT_identified_thi?=
11858 =?utf-8?Q?s_incoming_email_as_spam.__The_o?=
11859_message_has_been_attac?=
11860 =?utf-8?Q?hed_to_this_so_you_can_view_it_o?=
11861___________________________?=
11862 =?utf-8?Q?__author's_domain
11863X-Spam-Flag: NO
11864Date: Sat, 10 Jul 2010 05:34:45 -0700
11865From:<tartanpion@machin.truc>
11866
11867Hello,
11868
11869Bye.
11870EOM
11871),
11872 'regexmess: 1 Delete header X-Ham-Report:');
11873
11874
11875# regex to play with Date: from the FAQ
11876#@regexmess = 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms'
11877
11878
11879
11880
11881
11882 note( 'Leaving tests_regexmess()' ) ;
11883 return ;
11884
11885}
11886
11887sub regexmess
11888{
11889 my ( $string ) = @_ ;
11890 foreach my $regexmess ( @regexmess ) {
11891 $sync->{ debug } and myprint( "eval \$string =~ $regexmess\n" ) ;
11892 my $ret = eval "\$string =~ $regexmess ; 1" ;
11893 #myprint( "eval [$ret]\n" ) ;
11894 if ( ( not $ret ) or $EVAL_ERROR ) {
11895 myprint( "Error: eval regexmess '$regexmess': $EVAL_ERROR" ) ;
11896 return( undef ) ;
11897 }
11898 }
11899 $sync->{ debug } and myprint( "$string\n" ) ;
11900 return( $string ) ;
11901}
11902
11903
11904sub tests_skipmess
11905{
11906 note( 'Entering tests_skipmess()' ) ;
11907
11908 ok( not( defined skipmess( 'blabla' ) ), 'skipmess, no skipmess, no skip' ) ;
11909
11910 @skipmess = ('[') ;
11911 ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex [' ) ;
11912
11913 @skipmess = ('lalala') ;
11914 ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex lalala' ) ;
11915
11916 @skipmess = ('/popopo/') ;
11917 ok( 1 == skipmess( 'popopo' ), 'skipmess, popopo match regex /popopo/' ) ;
11918
11919 @skipmess = ('/popopo/') ;
11920 ok( 0 == skipmess( 'rrrrrr' ), 'skipmess, rrrrrr does not match regex /popopo/' ) ;
11921
11922 @skipmess = ('m{^$}') ;
11923 ok( 1 == skipmess( q{} ), 'skipmess: empty string yes' ) ;
11924 ok( 0 == skipmess( 'Hi!' ), 'skipmess: empty string no' ) ;
11925
11926 @skipmess = ('m{i}') ;
11927 ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ;
11928 ok( 0 == skipmess( 'Bye!' ), 'skipmess: i string no' ) ;
11929
11930 @skipmess = ('m{[\x80-\xff]}') ;
11931 ok( 0 == skipmess( 'Hi!' ), 'skipmess: i 8bit no' ) ;
11932 ok( 1 == skipmess( "\xff" ), 'skipmess: \xff 8bit yes' ) ;
11933
11934 @skipmess = ('m{A}', 'm{B}') ;
11935 ok( 0 == skipmess( 'Hi!' ), 'skipmess: A or B no' ) ;
11936 ok( 0 == skipmess( 'lala' ), 'skipmess: A or B no' ) ;
11937 ok( 0 == skipmess( "\xff" ), 'skipmess: A or B no' ) ;
11938 ok( 1 == skipmess( 'AB' ), 'skipmess: A or B yes' ) ;
11939 ok( 1 == skipmess( 'BA' ), 'skipmess: A or B yes' ) ;
11940 ok( 1 == skipmess( 'AA' ), 'skipmess: A or B yes' ) ;
11941 ok( 1 == skipmess( 'Ok Bye' ), 'skipmess: A or B yes' ) ;
11942
11943
11944 @skipmess = ( 'm#\A((?:[^\n]+\n)+|)^Content-Type: Message/Partial;[^\n]*\n(?:\n|.*\n\n)#ism' ) ; # SUPER BEST!
11945
11946
11947
11948 ok( 1 == skipmess(
11949<<'EOM'
11950Date: Sat, 10 Jul 2010 05:34:45 -0700
11951Content-Type: Message/Partial; blabla
11952From:<tartanpion@machin.truc>
11953
11954Hello!
11955Bye.
11956EOM
11957),
11958 'skipmess: 1 match Content-Type: Message/Partial' ) ;
11959
11960 ok( 0 == skipmess(
11961<<'EOM'
11962Date: Sat, 10 Jul 2010 05:34:45 -0700
11963From:<tartanpion@machin.truc>
11964
11965Hello!
11966Bye.
11967EOM
11968),
11969 'skipmess: 2 not match Content-Type: Message/Partial' ) ;
11970
11971
11972 ok( 1 == skipmess(
11973<<'EOM'
11974Date: Sat, 10 Jul 2010 05:34:45 -0700
11975From:<tartanpion@machin.truc>
11976Content-Type: Message/Partial; blabla
11977
11978Hello!
11979Bye.
11980EOM
11981),
11982 'skipmess: 3 match Content-Type: Message/Partial' ) ;
11983
11984 ok( 0 == skipmess(
11985<<'EOM'
11986Date: Sat, 10 Jul 2010 05:34:45 -0700
11987From:<tartanpion@machin.truc>
11988
11989Hello!
11990Content-Type: Message/Partial; blabla
11991Bye.
11992EOM
11993),
11994 'skipmess: 4 not match Content-Type: Message/Partial' ) ;
11995
11996
11997 ok( 0 == skipmess(
11998<<'EOM'
11999Date: Sat, 10 Jul 2010 05:34:45 -0700
12000From:<tartanpion@machin.truc>
12001
12002Hello!
12003Content-Type: Message/Partial; blabla
12004
12005Bye.
12006EOM
12007),
12008 'skipmess: 5 not match Content-Type: Message/Partial' ) ;
12009
12010
12011 ok( 1 == skipmess(
12012<<'EOM'
12013Date: Sat, 10 Jul 2010 05:34:45 -0700
12014Content-Type: Message/Partial; blabla
12015From:<tartanpion@machin.truc>
12016
12017Hello!
12018
12019Content-Type: Message/Partial; blabla
12020
12021Bye.
12022EOM
12023),
12024 'skipmess: 6 match Content-Type: Message/Partial' ) ;
12025
12026 ok( 1 == skipmess(
12027<<'EOM'
12028Date: Sat, 10 Jul 2010 05:34:45 -0700
12029Content-Type: Message/Partial;
12030From:<tartanpion@machin.truc>
12031
12032Hello!
12033Bye.
12034EOM
12035),
12036 'skipmess: 7 match Content-Type: Message/Partial' ) ;
12037
12038 ok( 1 == skipmess(
12039<<'EOM'
12040Date: Wed, 2 Jul 2014 02:26:40 +0000
12041MIME-Version: 1.0
12042Content-Type: message/partial;
12043 id="TAN_U_P<1404267997.00007489ed17>";
12044 number=3;
12045 total=3
12046
120476HQ6Hh3CdXj77qEGixerQ6zHx0OnQ/Cf5On4W0Y6vtU2crABZQtD46Hx1EOh8dDz4+OnTr1G
12048
12049
12050Hello!
12051Bye.
12052EOM
12053),
12054 'skipmess: 8 match Content-Type: Message/Partial' ) ;
12055
12056
12057ok( 1 == skipmess(
12058<<'EOM'
12059Return-Path: <gilles@lamiral.info>
12060Received: by lamiral.info (Postfix, from userid 1000)
12061 id 21EB12443BF; Mon, 2 Mar 2015 15:38:35 +0100 (CET)
12062Subject: test: aethaecohngiexao
12063To: <tata@petite.lamiral.info>
12064X-Mailer: mail (GNU Mailutils 2.2)
12065Message-Id: <20150302143835.21EB12443BF@lamiral.info>
12066Content-Type: message/partial;
12067 id="TAN_U_P<1404267997.00007489ed17>";
12068 number=3;
12069 total=3
12070Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET)
12071From: gilles@lamiral.info (Gilles LAMIRAL)
12072
12073test: aethaecohngiexao
12074EOM
12075),
12076 'skipmess: 9 match Content-Type: Message/Partial' ) ;
12077
12078ok( 1 == skipmess(
12079<<'EOM'
12080Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET)
12081From: gilles@lamiral.info (Gilles LAMIRAL)
12082Content-Type: message/partial;
12083 id="TAN_U_P<1404267997.00007489ed17>";
12084 number=3;
12085 total=3
12086
12087test: aethaecohngiexao
12088EOM
12089. "lalala\n" x 3_000_000
12090),
12091 'skipmess: 10 match Content-Type: Message/Partial' ) ;
12092
12093ok( 0 == skipmess(
12094<<'EOM'
12095Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET)
12096From: gilles@lamiral.info (Gilles LAMIRAL)
12097
12098test: aethaecohngiexao
12099EOM
12100. "lalala\n" x 3_000_000
12101),
12102 'skipmess: 11 match Content-Type: Message/Partial' ) ;
12103
12104
12105ok( 0 == skipmess(
12106<<"EOM"
12107From: fff\r
12108To: fff\r
12109Subject: Testing imapsync --skipmess\r
12110Date: Mon, 22 Aug 2011 08:40:20 +0800\r
12111Mime-Version: 1.0\r
12112Content-Type: text/plain; charset=iso-8859-1\r
12113Content-Transfer-Encoding: 7bit\r
12114\r
12115EOM
12116. qq{!#"d%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefg\r\n } x 32_730
12117),
12118 'skipmess: 12 not match Content-Type: Message/Partial' ) ;
12119 # Complex regular subexpression recursion limit (32766) exceeded with more lines
12120 # exit;
12121
12122 note( 'Leaving tests_skipmess()' ) ;
12123 return ;
12124}
12125
12126sub skipmess
12127{
12128 my ( $string ) = @_ ;
12129 my $match ;
12130 #myprint( "$string\n" ) ;
12131 foreach my $skipmess ( @skipmess ) {
12132 $sync->{ debug } and myprint( "eval \$match = \$string =~ $skipmess\n" ) ;
12133 my $ret = eval "\$match = \$string =~ $skipmess ; 1" ;
12134 #myprint( "eval [$ret]\n" ) ;
12135 $sync->{ debug } and myprint( "match [$match]\n" ) ;
12136 if ( ( not $ret ) or $EVAL_ERROR ) {
12137 myprint( "Error: eval skipmess '$skipmess': $EVAL_ERROR" ) ;
12138 return( undef ) ;
12139 }
12140 return( $match ) if ( $match ) ;
12141 }
12142 return( $match ) ;
12143}
12144
12145
12146
12147
12148sub tests_bytes_display_string
12149{
12150 note( 'Entering tests_bytes_display_string()' ) ;
12151
12152
12153 is( 'NA', bytes_display_string( ), 'bytes_display_string: no args => NA' ) ;
12154 is( 'NA', bytes_display_string( undef ), 'bytes_display_string: undef => NA' ) ;
12155 is( 'NA', bytes_display_string( 'blabla' ), 'bytes_display_string: blabla => NA' ) ;
12156
12157 ok( '0.000 KiB' eq bytes_display_string( 0 ), 'bytes_display_string: 0' ) ;
12158 ok( '0.001 KiB' eq bytes_display_string( 1 ), 'bytes_display_string: 1' ) ;
12159 ok( '0.010 KiB' eq bytes_display_string( 10 ), 'bytes_display_string: 10' ) ;
12160 ok( '1.000 MiB' eq bytes_display_string( 1_048_575 ), 'bytes_display_string: 1_048_575' ) ;
12161 ok( '1.000 MiB' eq bytes_display_string( 1_048_576 ), 'bytes_display_string: 1_048_576' ) ;
12162
12163 ok( '1.000 GiB' eq bytes_display_string( 1_073_741_823 ), 'bytes_display_string: 1_073_741_823 ' ) ;
12164 ok( '1.000 GiB' eq bytes_display_string( 1_073_741_824 ), 'bytes_display_string: 1_073_741_824 ' ) ;
12165
12166 ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_775 ), 'bytes_display_string: 1_099_511_627_775' ) ;
12167 ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_776 ), 'bytes_display_string: 1_099_511_627_776' ) ;
12168
12169 ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_623 ), 'bytes_display_string: 1_125_899_906_842_623' ) ;
12170 ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_624 ), 'bytes_display_string: 1_125_899_906_842_624' ) ;
12171
12172 ok( '1024.000 PiB' eq bytes_display_string( 1_152_921_504_606_846_975 ), 'bytes_display_string: 1_152_921_504_606_846_975' ) ;
12173 ok( '1024.000 PiB' eq bytes_display_string( 1_152_921_504_606_846_976 ), 'bytes_display_string: 1_152_921_504_606_846_976' ) ;
12174
12175 ok( '1048576.000 PiB' eq bytes_display_string( 1_180_591_620_717_411_303_424 ), 'bytes_display_string: 1_180_591_620_717_411_303_424' ) ;
12176
12177 #myprint( bytes_display_string( 1_180_591_620_717_411_303_424 ), "\n" ) ;
12178 note( 'Leaving tests_bytes_display_string()' ) ;
12179
12180 return ;
12181}
12182
12183sub bytes_display_string
12184{
12185 my ( $bytes ) = @_ ;
12186
12187 my $readable_value = q{} ;
12188
12189 if ( ! defined( $bytes ) ) {
12190 return( 'NA' ) ;
12191 }
12192
12193 if ( not match_number( $bytes ) ) {
12194 return( 'NA' ) ;
12195 }
12196
12197
12198
12199 SWITCH: {
12200 if ( abs( $bytes ) < ( 1000 * $KIBI ) ) {
12201 $readable_value = mysprintf( '%.3f KiB', $bytes / $KIBI) ;
12202 last SWITCH ;
12203 }
12204 if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI ) ) {
12205 $readable_value = mysprintf( '%.3f MiB', $bytes / ($KIBI * $KIBI) ) ;
12206 last SWITCH ;
12207 }
12208 if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI) ) {
12209 $readable_value = mysprintf( '%.3f GiB', $bytes / ($KIBI * $KIBI * $KIBI) ) ;
12210 last SWITCH ;
12211 }
12212 if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI * $KIBI) ) {
12213 $readable_value = mysprintf( '%.3f TiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI) ) ;
12214 last SWITCH ;
12215 } else {
12216 $readable_value = mysprintf( '%.3f PiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI * $KIBI) ) ;
12217 }
12218 # if you have exabytes (EiB) of email to transfer, you have too much email!
12219 }
12220 #myprint( "$bytes = $readable_value\n" ) ;
12221 return( $readable_value ) ;
12222}
12223
12224
12225sub tests_useheader_suggestion
12226{
12227 note( 'Entering tests_useheader_suggestion()' ) ;
12228
12229 is( undef, useheader_suggestion( ), 'useheader_suggestion: no args => undef' ) ;
12230 my $mysync = {} ;
12231
12232 $mysync->{ h1_nb_msg_noheader } = 0 ;
12233 is( q{}, useheader_suggestion( $mysync ), 'useheader_suggestion: h1_nb_msg_noheader count null => no suggestion' ) ;
12234 $mysync->{ h1_nb_msg_noheader } = 2 ;
12235 is( q{in order to sync those 2 unidentified messages, add option --addheader}, useheader_suggestion( $mysync ),
12236 'useheader_suggestion: h1_nb_msg_noheader count 2 => suggestion of --addheader' ) ;
12237
12238 note( 'Leaving tests_useheader_suggestion()' ) ;
12239 return ;
12240}
12241
12242sub useheader_suggestion
12243{
12244 my $mysync = shift ;
12245 if ( ! defined $mysync->{ h1_nb_msg_noheader } )
12246 {
12247 return ;
12248 }
12249 elsif ( 1 <= $mysync->{ h1_nb_msg_noheader } )
12250 {
12251 return qq{in order to sync those $mysync->{ h1_nb_msg_noheader } unidentified messages, add option --addheader} ;
12252 }
12253 else
12254 {
12255 return q{} ;
12256 }
12257 return ;
12258}
12259
12260sub stats
12261{
12262 my $mysync = shift ;
12263
12264 if ( ! $mysync->{stats} ) {
12265 return ;
12266 }
12267
12268 my $timeend = time ;
12269 my $timediff = $timeend - $mysync->{timestart} ;
12270
12271 my $timeend_str = localtime $timeend ;
12272
12273 my $memory_consumption_at_end = memory_consumption( ) || 0 ;
12274 my $memory_consumption_at_start = $mysync->{ memory_consumption_at_start } || 0 ;
12275 my $memory_ratio = ($max_msg_size_in_bytes) ?
12276 mysprintf('%.1f', $memory_consumption_at_end / $max_msg_size_in_bytes) : 'NA' ;
12277
12278 # my $useheader_suggestion = useheader_suggestion( $mysync ) ;
12279 myprint( "++++ Statistics\n" ) ;
12280 myprint( "Transfer started on : $timestart_str\n" ) ;
12281 myprint( "Transfer ended on : $timeend_str\n" ) ;
12282 myprintf( "Transfer time : %.1f sec\n", $timediff ) ;
12283 myprint( "Folders synced : $h1_folders_wanted_ct/$h1_folders_wanted_nb synced\n" ) ;
12284 myprint( "Messages transferred : $mysync->{ nb_msg_transferred } " ) ;
12285 myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $mysync->{dry} ) ;
12286 myprint( "\n" ) ;
12287 myprint( "Messages skipped : $mysync->{ nb_msg_skipped }\n" ) ;
12288 myprint( "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n" ) ;
12289 myprint( "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n" ) ;
12290 myprint( "Messages found crossduplicate on host2 : $mysync->{ h2_nb_msg_crossdup }\n" ) ;
12291 myprint( "Messages void (noheader) on host1 : $mysync->{ h1_nb_msg_noheader } ", useheader_suggestion( $mysync ), "\n" ) ;
12292 myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ;
12293 nb_messages_in_1_not_in_2( $mysync ) ;
12294 nb_messages_in_2_not_in_1( $mysync ) ;
12295 myprintf( "Messages found in host1 not in host2 : %s messages\n", $mysync->{ nb_messages_in_1_not_in_2 } ) ;
12296 myprintf( "Messages found in host2 not in host1 : %s messages\n", $mysync->{ nb_messages_in_2_not_in_1 } ) ;
12297 myprint( "Messages deleted on host1 : $mysync->{ h1_nb_msg_deleted }\n" ) ;
12298 myprint( "Messages deleted on host2 : $h2_nb_msg_deleted\n" ) ;
12299 myprintf( "Total bytes transferred : %s (%s)\n",
12300 $mysync->{total_bytes_transferred},
12301 bytes_display_string( $mysync->{total_bytes_transferred} ) ) ;
12302 myprintf( "Total bytes skipped : %s (%s)\n",
12303 $mysync->{ total_bytes_skipped },
12304 bytes_display_string( $mysync->{ total_bytes_skipped } ) ) ;
12305 $timediff ||= 1 ; # No division per 0
12306 myprintf("Message rate : %.1f messages/s\n", $mysync->{nb_msg_transferred} / $timediff ) ;
12307 myprintf("Average bandwidth rate : %.1f KiB/s\n", $mysync->{total_bytes_transferred} / $KIBI / $timediff ) ;
12308 myprint( "Reconnections to host1 : $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ;
12309 myprint( "Reconnections to host2 : $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ;
12310 myprintf("Memory consumption at the end : %.1f MiB (started with %.1f MiB)\n",
12311 $memory_consumption_at_end / $KIBI / $KIBI,
12312 $memory_consumption_at_start / $KIBI / $KIBI ) ;
12313 myprint( "Load end is : " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $mysync->{cpu_number} cores\n" ) ;
12314
12315 myprintf("Biggest message : %s bytes (%s)\n",
12316 $max_msg_size_in_bytes,
12317 bytes_display_string( $max_msg_size_in_bytes) ) ;
12318 myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ;
12319 if ( $mysync->{ foldersizesatend } and $mysync->{ foldersizes } ) {
12320
12321
12322 my $nb_msg_start_diff = diff_or_NA( $mysync->{ h2_nb_msg_start }, $mysync->{ h1_nb_msg_start } ) ;
12323 my $bytes_start_diff = diff_or_NA( $mysync->{ h2_bytes_start }, $mysync->{ h1_bytes_start } ) ;
12324
12325 myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff,
12326 $bytes_start_diff,
12327 bytes_display_string( $bytes_start_diff ) ) ;
12328
12329 my $nb_msg_end_diff = diff_or_NA( $h2_nb_msg_end, $h1_nb_msg_end ) ;
12330 my $bytes_end_diff = diff_or_NA( $h2_bytes_end, $h1_bytes_end ) ;
12331
12332 myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff,
12333 $bytes_end_diff,
12334 bytes_display_string( $bytes_end_diff ) ) ;
12335 }
12336
12337 comment_on_final_diff_in_1_not_in_2( $mysync ) ;
12338 comment_on_final_diff_in_2_not_in_1( $mysync ) ;
12339 myprint( "Detected $mysync->{nb_errors} errors\n\n" ) ;
12340
12341 myprint( $warn_release, "\n" ) ;
12342 myprint( homepage( ), "\n" ) ;
12343 return ;
12344}
12345
12346sub diff_or_NA
12347{
12348 my( $n1, $n2 ) = @ARG ;
12349
12350 if ( not defined $n1 or not defined $n2 ) {
12351 return 'NA' ;
12352 }
12353
12354 if ( not match_number( $n1 )
12355 or not match_number( $n2 ) ) {
12356 return 'NA' ;
12357 }
12358
12359 return( $n1 - $n2 ) ;
12360}
12361
12362sub match_number
12363{
12364 my $n = shift @ARG ;
12365
12366 if ( not defined $n ) {
12367 return 0 ;
12368 }
12369 if ( $n =~ /[0-9]+\.?[0-9]?/x ) {
12370 return 1 ;
12371 }
12372 else {
12373 return 0 ;
12374 }
12375}
12376
12377
12378sub tests_match_number
12379{
12380 note( 'Entering tests_match_number()' ) ;
12381
12382
12383 is( 0, match_number( ), 'match_number: no parameters => 0' ) ;
12384 is( 0, match_number( undef ), 'match_number: undef => 0' ) ;
12385 is( 0, match_number( 'blabla' ), 'match_number: blabla => 0' ) ;
12386 is( 1, match_number( 0 ), 'match_number: 0 => 1' ) ;
12387 is( 1, match_number( 1 ), 'match_number: 1 => 1' ) ;
12388 is( 1, match_number( 1.0 ), 'match_number: 1.0 => 1' ) ;
12389 is( 1, match_number( 0.0 ), 'match_number: 0.0 => 1' ) ;
12390
12391 note( 'Leaving tests_match_number()' ) ;
12392 return ;
12393}
12394
12395
12396
12397sub tests_diff_or_NA
12398{
12399 note( 'Entering tests_diff_or_NA()' ) ;
12400
12401
12402 is( 'NA', diff_or_NA( ), 'diff_or_NA: no parameters => NA' ) ;
12403 is( 'NA', diff_or_NA( undef ), 'diff_or_NA: undef => NA' ) ;
12404 is( 'NA', diff_or_NA( undef, undef ), 'diff_or_NA: undef undef => NA' ) ;
12405 is( 'NA', diff_or_NA( undef, 1 ), 'diff_or_NA: undef 1 => NA' ) ;
12406 is( 'NA', diff_or_NA( 1, undef ), 'diff_or_NA: 1 undef => NA' ) ;
12407 is( 'NA', diff_or_NA( 'blabla', 1 ), 'diff_or_NA: blabla 1 => NA' ) ;
12408 is( 'NA', diff_or_NA( 1, 'blabla' ), 'diff_or_NA: 1 blabla => NA' ) ;
12409 is( 0, diff_or_NA( 1, 1 ), 'diff_or_NA: 1 1 => 0' ) ;
12410 is( 1, diff_or_NA( 1, 0 ), 'diff_or_NA: 1 0 => 1' ) ;
12411 is( -1, diff_or_NA( 0, 1 ), 'diff_or_NA: 0 1 => -1' ) ;
12412 is( 0, diff_or_NA( 1.0, 1 ), 'diff_or_NA: 1.0 1 => 0' ) ;
12413 is( 1, diff_or_NA( 1.0, 0 ), 'diff_or_NA: 1.0 0 => 1' ) ;
12414 is( -1, diff_or_NA( 0, 1.0 ), 'diff_or_NA: 0 1.0 => -1' ) ;
12415
12416 note( 'Leaving tests_diff_or_NA()' ) ;
12417 return ;
12418}
12419
12420sub homepage
12421{
12422 return( 'Homepage: https://imapsync.lamiral.info/' ) ;
12423}
12424
12425
12426sub load_modules
12427{
12428 if ( $sync->{ssl1}
12429 or $sync->{ssl2}
12430 or $sync->{tls1}
12431 or $sync->{tls2}) {
12432 if ( $sync->{inet4} ) {
12433 IO::Socket::SSL->import( 'inet4' ) ;
12434 }
12435 if ( $sync->{inet6} ) {
12436 IO::Socket::SSL->import( 'inet6' ) ;
12437 }
12438 }
12439 return ;
12440}
12441
12442
12443
12444sub parse_header_msg
12445{
12446 my ( $mysync, $imap, $m_uid, $s_heads, $s_fir, $side, $s_hash ) = @_ ;
12447
12448 my $head = $s_heads->{$m_uid} ;
12449 my $headnum = scalar keys %{ $head } ;
12450 $mysync->{ debug } and myprint( "$side: uid $m_uid number of headers, pass one: ", $headnum, "\n" ) ;
12451
12452 if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){
12453 $mysync->{ debug } and myprint( "$side: uid $m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ) ;
12454 $imap->fetch($m_uid, 'BODY.PEEK[HEADER]' ) ;
12455 my $whole_header = $imap->_transaction_literals ;
12456
12457 #myprint( $whole_header ) ;
12458 $head = decompose_header( $whole_header ) ;
12459
12460 $headnum = scalar keys %{ $head } ;
12461 $mysync->{ debug } and myprint( "$side: uid $m_uid number of headers, pass two: ", $headnum, "\n" ) ;
12462 }
12463
12464 #myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ;
12465
12466 my $headstr ;
12467
12468 $headstr = header_construct( $head, $side, $m_uid ) ;
12469
12470 if ( ( ! $headstr ) and ( $mysync->{addheader} ) and ( $side eq 'Host1' ) ) {
12471 my $header = add_header( $m_uid ) ;
12472 $mysync->{ debug } and myprint( "$side: uid $m_uid no header found so adding our own [$header]\n" ) ;
12473 $headstr .= uc $header ;
12474 $s_fir->{$m_uid}->{NO_HEADER} = 1;
12475 }
12476
12477 return if ( ! $headstr ) ;
12478
12479 my $size = $s_fir->{$m_uid}->{'RFC822.SIZE'} ;
12480 my $flags = $s_fir->{$m_uid}->{'FLAGS'} ;
12481 my $idate = $s_fir->{$m_uid}->{'INTERNALDATE'} ;
12482 $size = length $headstr unless ( $size ) ;
12483 my $m_md5 = md5_base64( $headstr ) ;
12484 $mysync->{ debug } and myprint( "$side: uid $m_uid sig $m_md5 size $size idate $idate\n" ) ;
12485 my $key ;
12486 if ($skipsize) {
12487 $key = "$m_md5";
12488 }
12489 else {
12490 $key = "$m_md5:$size";
12491 }
12492 # 0 return code is used to identify duplicate message hash
12493 return 0 if exists $s_hash->{"$key"};
12494 $s_hash->{"$key"}{'5'} = $m_md5;
12495 $s_hash->{"$key"}{'s'} = $size;
12496 $s_hash->{"$key"}{'D'} = $idate;
12497 $s_hash->{"$key"}{'F'} = $flags;
12498 $s_hash->{"$key"}{'m'} = $m_uid;
12499
12500 return( 1 ) ;
12501}
12502
12503sub header_construct
12504{
12505
12506 my( $head, $side, $m_uid ) = @_ ;
12507
12508 my $headstr ;
12509 foreach my $h ( sort keys %{ $head } ) {
12510 next if ( not ( exists $useheader{ uc $h } )
12511 and ( not exists $useheader{ 'ALL' } )
12512 ) ;
12513 foreach my $val ( sort @{$head->{$h}} ) {
12514
12515 my $H = header_line_normalize( $h, $val ) ;
12516
12517 # show stuff in debug mode
12518 $sync->{ debug } and myprint( "$side uid $m_uid header [$H]", "\n" ) ;
12519
12520 if ($skipheader and $H =~ m/$skipheader/xi) {
12521 $sync->{ debug } and myprint( "$side uid $m_uid skipping header [$H]\n" ) ;
12522 next ;
12523 }
12524 $headstr .= "$H" ;
12525 }
12526 }
12527 return( $headstr ) ;
12528}
12529
12530
12531sub header_line_normalize
12532{
12533 my( $header_key, $header_val ) = @_ ;
12534
12535 # no 8-bit data in headers !
12536 $header_val =~ s/[\x80-\xff]/X/xog;
12537
12538 # change tabulations to space (Gmail bug on with "Received:" on multilines)
12539 $header_val =~ s/\t/\ /xgo ;
12540
12541 # remove the first blanks ( dbmail bug? )
12542 $header_val =~ s/^\s*//xo;
12543
12544 # remove the last blanks ( Gmail bug )
12545 $header_val =~ s/\s*$//xo;
12546
12547 # remove successive blanks ( Mailenable does it )
12548 $header_val =~ s/\s+/ /xgo;
12549
12550 # remove Message-Id value domain part ( Mailenable changes it )
12551 if ( ( $messageidnodomain ) and ( 'MESSAGE-ID' eq uc $header_key ) ) { $header_val =~ s/^([^@]+).*$/$1/xo ; }
12552
12553 # and uppercase header line
12554 # (dbmail and dovecot)
12555
12556 my $header_line = uc "$header_key: $header_val" ;
12557
12558 return( $header_line ) ;
12559}
12560
12561sub tests_header_line_normalize
12562{
12563 note( 'Entering tests_header_line_normalize()' ) ;
12564
12565
12566 ok( ': ' eq header_line_normalize( q{}, q{} ), 'header_line_normalize: empty args' ) ;
12567 ok( 'HHH: VVV' eq header_line_normalize( 'hhh', 'vvv' ), 'header_line_normalize: hhh vvv ' ) ;
12568 ok( 'HHH: VVV' eq header_line_normalize( 'hhh', ' vvv' ), 'header_line_normalize: remove first blancs' ) ;
12569 ok( 'HHH: AA BB CCC D' eq header_line_normalize( 'hhh', 'aa bb ccc d' ), 'header_line_normalize: remove succesive blanks' ) ;
12570 ok( 'HHH: AA BB CCC' eq header_line_normalize( 'hhh', 'aa bb ccc ' ), 'header_line_normalize: remove last blanks' ) ;
12571 ok( 'HHH: VVV XX YY' eq header_line_normalize( 'hhh', "vvv\t\txx\tyy" ), 'header_line_normalize: tabs' ) ;
12572 ok( 'HHH: XABX' eq header_line_normalize( 'hhh', "\x80AB\xff" ), 'header_line_normalize: 8bit' ) ;
12573
12574 note( 'Leaving tests_header_line_normalize()' ) ;
12575 return ;
12576}
12577
12578
12579sub tests_firstline
12580{
12581 note( 'Entering tests_firstline()' ) ;
12582
12583 is( q{}, firstline( 'W/tmp/tests/noexist.txt' ), 'firstline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
12584
12585 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'firstline: mkpath W/tmp/tests/' ) ;
12586
12587 is( "blabla\n" , string_to_file( "blabla\n", 'W/tmp/tests/firstline.txt' ), 'firstline: put blabla in W/tmp/tests/firstline.txt' ) ;
12588 is( 'blabla' , firstline( 'W/tmp/tests/firstline.txt' ), 'firstline: get blabla from W/tmp/tests/firstline.txt' ) ;
12589
12590 is( q{} , string_to_file( q{}, 'W/tmp/tests/firstline2.txt' ), 'firstline: put empty string in W/tmp/tests/firstline2.txt' ) ;
12591 is( q{} , firstline( 'W/tmp/tests/firstline2.txt' ), 'firstline: get empty string from W/tmp/tests/firstline2.txt' ) ;
12592
12593 is( "\n" , string_to_file( "\n", 'W/tmp/tests/firstline3.txt' ), 'firstline: put CR in W/tmp/tests/firstline3.txt' ) ;
12594 is( q{} , firstline( 'W/tmp/tests/firstline3.txt' ), 'firstline: get empty string from W/tmp/tests/firstline3.txt' ) ;
12595
12596 is( "blabla\nTiti\n" , string_to_file( "blabla\nTiti\n", 'W/tmp/tests/firstline4.txt' ), 'firstline: put blabla\nTiti\n in W/tmp/tests/firstline4.txt' ) ;
12597 is( 'blabla' , firstline( 'W/tmp/tests/firstline4.txt' ), 'firstline: get blabla from W/tmp/tests/firstline4.txt' ) ;
12598
12599 note( 'Leaving tests_firstline()' ) ;
12600 return ;
12601}
12602
12603sub firstline
12604{
12605 # extract the first line of a file (without \n)
12606 # return empty string if error or empty string
12607
12608 my $file = shift ;
12609 my $line ;
12610
12611 $line = nthline( $file, 1 ) ;
12612 return $line ;
12613}
12614
12615
12616
12617sub tests_secondline
12618{
12619 note( 'Entering tests_secondline()' ) ;
12620
12621 is( q{}, secondline( 'W/tmp/tests/noexist.txt' ), 'secondline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
12622 is( q{}, secondline( 'W/tmp/tests/noexist.txt', 2 ), 'secondline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
12623
12624 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'secondline: mkpath W/tmp/tests/' ) ;
12625
12626 is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/secondline.txt' ), 'secondline: put L1\nL2\nL3\nL4\n in W/tmp/tests/secondline.txt' ) ;
12627 is( 'L2' , secondline( 'W/tmp/tests/secondline.txt' ), 'secondline: get L2 from W/tmp/tests/secondline.txt' ) ;
12628
12629
12630 note( 'Leaving tests_secondline()' ) ;
12631 return ;
12632}
12633
12634
12635sub secondline
12636{
12637 # extract the second line of a file (without \n)
12638 # return empty string if error or empty string
12639
12640 my $file = shift ;
12641 my $line ;
12642
12643 $line = nthline( $file, 2 ) ;
12644 return $line ;
12645}
12646
12647
12648
12649
12650sub tests_nthline
12651{
12652 note( 'Entering tests_nthline()' ) ;
12653
12654 is( q{}, nthline( 'W/tmp/tests/noexist.txt' ), 'nthline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
12655 is( q{}, nthline( 'W/tmp/tests/noexist.txt', 2 ), 'nthline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ;
12656
12657 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'nthline: mkpath W/tmp/tests/' ) ;
12658
12659 is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/nthline.txt' ), 'nthline: put L1\nL2\nL3\nL4\n in W/tmp/tests/nthline.txt' ) ;
12660 is( 'L3' , nthline( 'W/tmp/tests/nthline.txt', 3 ), 'nthline: get L3 from W/tmp/tests/nthline.txt' ) ;
12661
12662
12663 note( 'Leaving tests_nthline()' ) ;
12664 return ;
12665}
12666
12667
12668sub nthline
12669{
12670 # extract the nth line of a file (without \n)
12671 # return empty string if error or empty string
12672
12673 my $file = shift ;
12674 my $num = shift ;
12675
12676 if ( ! all_defined( $file, $num ) ) { return q{} ; }
12677
12678 my $line ;
12679
12680 $line = ( file_to_array( $file ) )[$num - 1] ;
12681 if ( ! defined $line )
12682 {
12683 return q{} ;
12684 }
12685 else
12686 {
12687 chomp $line ;
12688 return $line ;
12689 }
12690}
12691
12692
12693# Should be unit tested and then be used by file_to_string, refactoring file_to_string
12694sub file_to_array
12695{
12696
12697 my( $file ) = shift ;
12698 my @string ;
12699
12700 open my $FILE, '<', $file or do {
12701 myprint( "Error reading file $file : $OS_ERROR\n" ) ;
12702 return ;
12703 } ;
12704 @string = <$FILE> ;
12705 close $FILE ;
12706 return( @string ) ;
12707}
12708
12709
12710sub tests_file_to_string
12711{
12712 note( 'Entering tests_file_to_string()' ) ;
12713
12714 is( undef, file_to_string( ), 'file_to_string: no args => undef' ) ;
12715 is( undef, file_to_string( '/noexist' ), 'file_to_string: /noexist => undef' ) ;
12716 is( undef, file_to_string( '/' ), 'file_to_string: reading a directory => undef' ) ;
12717 ok( file_to_string( $PROGRAM_NAME ), 'file_to_string: reading myself' ) ;
12718
12719 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'file_to_string: mkpath W/tmp/tests/' ) ;
12720
12721 is( 'lilili', string_to_file( 'lilili', 'W/tmp/tests/canbewritten' ), 'file_to_string: string_to_file filling W/tmp/tests/canbewritten with lilili' ) ;
12722 is( 'lilili', file_to_string( 'W/tmp/tests/canbewritten' ), 'file_to_string: reading W/tmp/tests/canbewritten is lilili' ) ;
12723
12724 is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'file_to_string: string_to_file filling W/tmp/tests/empty with empty string' ) ;
12725 is( q{}, file_to_string( 'W/tmp/tests/empty' ), 'file_to_string: reading W/tmp/tests/empty is empty' ) ;
12726
12727 note( 'Leaving tests_file_to_string()' ) ;
12728 return ;
12729}
12730
12731sub file_to_string
12732{
12733 my $file = shift ;
12734 if ( ! $file ) { return ; }
12735 if ( ! -e $file ) { return ; }
12736 if ( ! -f $file ) { return ; }
12737 if ( ! -r $file ) { return ; }
12738 my @string ;
12739 if ( open my $FILE, '<', $file ) {
12740 @string = <$FILE> ;
12741 close $FILE ;
12742 return( join q{}, @string ) ;
12743 }else{
12744 myprint( "Error reading file $file : $OS_ERROR\n" ) ;
12745 return ;
12746 }
12747}
12748
12749
12750sub tests_string_to_file
12751{
12752 note( 'Entering tests_string_to_file()' ) ;
12753
12754 is( undef, string_to_file( ), 'string_to_file: no args => undef' ) ;
12755 is( undef, string_to_file( 'lalala' ), 'string_to_file: one arg => undef' ) ;
12756 is( undef, string_to_file( 'lalala', '.' ), 'string_to_file: writing a directory => undef' ) ;
12757 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'string_to_file: mkpath W/tmp/tests/' ) ;
12758 is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/canbewritten' ), 'string_to_file: W/tmp/tests/canbewritten with lalala' ) ;
12759 is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'string_to_file: W/tmp/tests/empty with empty string' ) ;
12760
12761 SKIP: {
12762 Readonly my $NB_UNX_tests_string_to_file => 1 ;
12763 skip( 'Not on Unix non-root', $NB_UNX_tests_string_to_file ) if ('MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ;
12764 is( undef, string_to_file( 'lalala', '/cantouch' ), 'string_to_file: /cantouch denied => undef' ) ;
12765 }
12766
12767 note( 'Leaving tests_string_to_file()' ) ;
12768 return ;
12769}
12770
12771sub string_to_file
12772{
12773 my( $string, $file ) = @_ ;
12774 if( ! defined $string ) { return ; }
12775 if( ! defined $file ) { return ; }
12776
12777 if ( ! -e $file && ! -w dirname( $file ) ) {
12778 myprint( "string_to_file: directory of $file is not writable\n" ) ;
12779 return ;
12780 }
12781
12782 if ( ! sysopen( FILE, $file, O_WRONLY|O_TRUNC|O_CREAT, 0600) ) {
12783 myprint( "string_to_file: failure writing to $file with error: $OS_ERROR\n" ) ;
12784 return ;
12785 }
12786 print FILE $string ;
12787 close FILE ;
12788 return $string ;
12789}
12790
127910 and <<'MULTILINE_COMMENT' ;
12792This is a multiline comment.
12793Based on David Carter discussion, to do:
12794* Call parameters stay the same.
12795* Now always "return( $string, $error )". Descriptions below.
12796OK * Still capture STDOUT via "1> $output_tmpfile" to finish in $string and "return( $string, $error )"
12797OK * Now also capture STDERR via "2> $error_tmpfile" to finish in $error and "return( $string, $error )"
12798OK * in case of CHILD_ERROR, return( undef, $error )
12799 and print $error, with folder/UID/maybeSubject context,
12800 on console and at the end with the final error listing. Count this as a sync error.
12801* in case of good command, take final $string as is, unless void. In case $error with value then print it.
12802* in case of good command and final $string empty, consider it like CHILD_ERROR =>
12803 return( undef, $error ) and print $error, with folder/UID/maybeSubject context,
12804 on console and at the end with the final error listing. Count this as a sync error.
12805MULTILINE_COMMENT
12806# End of multiline comment.
12807
12808sub pipemess
12809{
12810 my ( $string, @commands ) = @_ ;
12811 my $error = q{} ;
12812 foreach my $command ( @commands ) {
12813 my $input_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.inp.txt" ;
12814 my $output_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.out.txt" ;
12815 my $error_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.err.txt" ;
12816 string_to_file( $string, $input_tmpfile ) ;
12817 ` $command < $input_tmpfile 1> $output_tmpfile 2> $error_tmpfile ` ;
12818 my $is_command_ko = $CHILD_ERROR ;
12819 my $error_cmd = file_to_string( $error_tmpfile ) ;
12820 chomp( $error_cmd ) ;
12821 $string = file_to_string( $output_tmpfile ) ;
12822 my $string_len = length( $string ) ;
12823 unlink $input_tmpfile, $output_tmpfile, $error_tmpfile ;
12824
12825 if ( $is_command_ko or ( ! $string_len ) ) {
12826 my $cmd_exit_value = $CHILD_ERROR >> 8 ;
12827 my $cmd_end_signal = $CHILD_ERROR & 127 ;
12828 my $signal_log = ( $cmd_end_signal ) ? " signal $cmd_end_signal and" : q{} ;
12829 my $error_log = qq{Failure: --pipemess command "$command" ended with$signal_log "$string_len" characters exit value "$cmd_exit_value" and STDERR "$error_cmd"\n} ;
12830 myprint( $error_log ) ;
12831 if ( wantarray ) {
12832 return @{ [ undef, $error_log ] }
12833 }else{
12834 return ;
12835 }
12836 }
12837 if ( $error_cmd ) {
12838 $error .= qq{STDERR of --pipemess "$command": $error_cmd\n} ;
12839 myprint( qq{STDERR of --pipemess "$command": $error_cmd\n} ) ;
12840 }
12841 }
12842 #myprint( "[$string]\n" ) ;
12843 if ( wantarray ) {
12844 return ( $string, $error ) ;
12845 }else{
12846 return $string ;
12847 }
12848}
12849
12850
12851
12852sub tests_pipemess
12853{
12854 note( 'Entering tests_pipemess()' ) ;
12855
12856
12857 SKIP: {
12858 Readonly my $NB_WIN_tests_pipemess => 3 ;
12859 skip( 'Not on MSWin32', $NB_WIN_tests_pipemess ) if ('MSWin32' ne $OSNAME) ;
12860 # Windows
12861 # "type" command does not accept redirection of STDIN with <
12862 # "sort" does
12863 ok( "nochange\n" eq pipemess( 'nochange', 'sort' ), 'pipemess: nearly no change by sort' ) ;
12864 ok( "nochange2\n" eq pipemess( 'nochange2', qw( sort sort ) ), 'pipemess: nearly no change by sort,sort' ) ;
12865 # command not found
12866 #diag( 'Warning and failure about cacaprout are on purpose' ) ;
12867 ok( ! defined( pipemess( q{}, 'cacaprout' ) ), 'pipemess: command not found' ) ;
12868
12869 } ;
12870
12871 my ( $stringT, $errorT ) ;
12872
12873 SKIP: {
12874 Readonly my $NB_UNX_tests_pipemess => 25 ;
12875 skip( 'Not on Unix', $NB_UNX_tests_pipemess ) if ('MSWin32' eq $OSNAME) ;
12876 # Unix
12877 ok( 'nochange' eq pipemess( 'nochange', 'cat' ), 'pipemess: no change by cat' ) ;
12878
12879 ok( 'nochange2' eq pipemess( 'nochange2', 'cat', 'cat' ), 'pipemess: no change by cat,cat' ) ;
12880
12881 ok( " 1\tnumberize\n" eq pipemess( "numberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ;
12882 ok( " 1\tnumberize\n 2\tnumberize\n" eq pipemess( "numberize\nnumberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ;
12883
12884 ok( "A\nB\nC\n" eq pipemess( "A\nC\nB\n", 'sort' ), 'pipemess: sort' ) ;
12885
12886 # command not found
12887 #diag( 'Warning and failure about cacaprout are on purpose' ) ;
12888 is( undef, pipemess( q{}, 'cacaprout' ), 'pipemess: command not found' ) ;
12889
12890 # success with true but no output at all
12891 is( undef, pipemess( q{blabla}, 'true' ), 'pipemess: true but no output' ) ;
12892
12893 # failure with false and no output at all
12894 is( undef, pipemess( q{blabla}, 'false' ), 'pipemess: false and no output' ) ;
12895
12896 # Failure since pipemess is not a real pipe, so first cat wait for standard input
12897 is( q{blabla}, pipemess( q{blabla}, '( cat|cat ) ' ), 'pipemess: ok by ( cat|cat )' ) ;
12898
12899
12900 ( $stringT, $errorT ) = pipemess( 'nochange', 'cat' ) ;
12901 is( $stringT, 'nochange', 'pipemess: list context, no change by cat, string' ) ;
12902 is( $errorT, q{}, 'pipemess: list context, no change by cat, no error' ) ;
12903
12904 ( $stringT, $errorT ) = pipemess( 'dontcare', 'true' ) ;
12905 is( $stringT, undef, 'pipemess: list context, true but no output, string' ) ;
12906 like( $errorT, qr{\QFailure: --pipemess command "true" ended with "0" characters exit value "0" and STDERR ""\E}xm, 'pipemess: list context, true but no output, error' ) ;
12907
12908 ( $stringT, $errorT ) = pipemess( 'dontcare', 'false' ) ;
12909 is( $stringT, undef, 'pipemess: list context, false and no output, string' ) ;
12910 like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm,
12911 'pipemess: list context, false and no output, error' ) ;
12912
12913 ( $stringT, $errorT ) = pipemess( 'dontcare', '/bin/echo -n blablabla' ) ;
12914 is( $stringT, q{blablabla}, 'pipemess: list context, "echo -n blablabla", string' ) ;
12915 is( $errorT, q{}, 'pipemess: list context, "echo blablabla", error' ) ;
12916
12917
12918 ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ;
12919 is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla", string' ) ;
12920 like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla", error' ) ;
12921
12922
12923 ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )', 'false' ) ;
12924 is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla then false", string' ) ;
12925 like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla then false", error' ) ;
12926
12927 ( $stringT, $errorT ) = pipemess( 'dontcare', 'false', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ;
12928 is( $stringT, undef, 'pipemess: list context, "false then STDERR blablabla", string' ) ;
12929 like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm,
12930 'pipemess: list context, "false then STDERR blablabla", error' ) ;
12931
12932 ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo rrrrr ; echo -n error_blablabla 3>&1 1>&2 2>&3 )' ) ;
12933 like( $stringT, qr{rrrrr}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", string' ) ;
12934 like( $errorT, qr{STDERR.*error_blablabla}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", error' ) ;
12935
12936 }
12937
12938 ( $stringT, $errorT ) = pipemess( 'dontcare', 'cacaprout' ) ;
12939 is( $stringT, undef, 'pipemess: list context, cacaprout not found, string' ) ;
12940 like( $errorT, qr{\QFailure: --pipemess command "cacaprout" ended with "0" characters exit value\E}xm,
12941 'pipemess: list context, cacaprout not found, error' ) ;
12942
12943 note( 'Leaving tests_pipemess()' ) ;
12944 return ;
12945}
12946
12947
12948
12949sub tests_is_a_release_number
12950{
12951 note( 'Entering tests_is_a_release_number()' ) ;
12952
12953 is( undef, is_a_release_number( ), 'is_a_release_number: no args => undef' ) ;
12954 ok( is_a_release_number( $RELEASE_NUMBER_EXAMPLE_1 ), 'is_a_release_number 1.351' ) ;
12955 ok( is_a_release_number( $RELEASE_NUMBER_EXAMPLE_2 ), 'is_a_release_number 42.4242' ) ;
12956 ok( is_a_release_number( imapsync_version( $sync ) ), 'is_a_release_number imapsync_version( )' ) ;
12957 ok( ! is_a_release_number( 'blabla' ), '! is_a_release_number blabla' ) ;
12958
12959 note( 'Leaving tests_is_a_release_number()' ) ;
12960 return ;
12961}
12962
12963sub is_a_release_number
12964{
12965 my $number = shift ;
12966 if ( ! defined $number ) { return ; }
12967 return( $number =~ m{^\d+\.\d+$}xo ) ;
12968}
12969
12970
12971
12972sub imapsync_version_public
12973{
12974
12975 my $local_version = imapsync_version( $sync ) ;
12976 my $imapsync_basename = imapsync_basename( ) ;
12977 my $context = imapsync_context( ) ;
12978 my $agent_info = "$OSNAME system, perl "
12979 . mysprintf( '%vd', $PERL_VERSION)
12980 . ", Mail::IMAPClient $Mail::IMAPClient::VERSION"
12981 . " $imapsync_basename"
12982 . " $context" ;
12983 my $sock = IO::Socket::INET->new(
12984 PeerAddr => 'imapsync.lamiral.info',
12985 PeerPort => 80,
12986 Proto => 'tcp',
12987 ) ;
12988 return( 'unknown' ) if not $sock ;
12989 print $sock
12990 "GET /prj/imapsync/VERSION HTTP/1.0\r\n",
12991 "User-Agent: imapsync/$local_version ($agent_info)\r\n",
12992 "Host: ks.lamiral.info\r\n\r\n" ;
12993 my @line = <$sock> ;
12994 close $sock ;
12995 my $last_release = $line[$LAST] ;
12996 chomp $last_release ;
12997 return( $last_release ) ;
12998}
12999
13000sub not_long_imapsync_version_public
13001{
13002 #myprint( "Entering not_long_imapsync_version_public\n" ) ;
13003
13004 my $fake = shift ;
13005 if ( $fake ) { return $fake }
13006
13007 my $val ;
13008
13009 # Doesn't work with gethostbyname (see perlipc)
13010 #local $SIG{ALRM} = sub { die "alarm\n" } ;
13011
13012 if ('MSWin32' eq $OSNAME) {
13013 local $SIG{ALRM} = sub { die "alarm\n" } ;
13014 }else{
13015
13016 POSIX::sigaction(SIGALRM,
13017 POSIX::SigAction->new(sub { croak 'alarm' } ) )
13018 or myprint( "Error setting SIGALRM handler: $OS_ERROR\n" ) ;
13019 }
13020
13021 my $ret = eval {
13022 alarm 3 ;
13023 {
13024 $val = imapsync_version_public( ) ;
13025 #sleep 4 ;
13026 #myprint( "End of imapsync_version_public\n" ) ;
13027 }
13028 alarm 0 ;
13029 1 ;
13030 } ;
13031 #myprint( "eval [$ret]\n" ) ;
13032 if ( ( not $ret ) or $EVAL_ERROR ) {
13033 #myprint( "$EVAL_ERROR" ) ;
13034 if ($EVAL_ERROR =~ /alarm/) {
13035 # timed out
13036 return('timeout') ;
13037 }else{
13038 alarm 0 ;
13039 return( 'unknown' ) ; # propagate unexpected errors
13040 }
13041 }else {
13042 # Good!
13043 return( $val ) ;
13044 }
13045}
13046
13047sub tests_not_long_imapsync_version_public
13048{
13049 note( 'Entering tests_not_long_imapsync_version_public()' ) ;
13050
13051
13052 is( 1, is_a_release_number( not_long_imapsync_version_public( ) ),
13053 'not_long_imapsync_version_public: public release is a number' ) ;
13054
13055 note( 'Leaving tests_not_long_imapsync_version_public()' ) ;
13056 return ;
13057}
13058
13059sub check_last_release
13060{
13061 my $fake = shift ;
13062 my $public_release = not_long_imapsync_version_public( $fake ) ;
13063 $sync->{ debug } and myprint( "check_last_release: [$public_release]\n" ) ;
13064 my $inline_help_when_on = '( Use --noreleasecheck to avoid this release check. )' ;
13065
13066 if ( $public_release eq 'unknown' ) {
13067 return( 'Imapsync public release is unknown.' . $inline_help_when_on ) ;
13068 }
13069
13070 if ( $public_release eq 'timeout' ) {
13071 return( 'Imapsync public release is unknown (timeout).' . $inline_help_when_on ) ;
13072 }
13073
13074 if ( ! is_a_release_number( $public_release ) ) {
13075 return( "Imapsync public release is unknown ($public_release)." . $inline_help_when_on ) ;
13076 }
13077
13078 my $imapsync_here = imapsync_version( $sync ) ;
13079
13080 if ( $public_release > $imapsync_here ) {
13081 return( 'This imapsync is not up to date. ' . "( local $imapsync_here < official $public_release )" . $inline_help_when_on ) ;
13082 }else{
13083 return( 'This imapsync is up to date. ' . "( local $imapsync_here >= official $public_release )" . $inline_help_when_on ) ;
13084 }
13085
13086 return( 'really unknown' ) ; # Should never arrive here
13087}
13088
13089sub tests_check_last_release
13090{
13091 note( 'Entering tests_check_last_release()' ) ;
13092
13093 diag( check_last_release( 1.1 ) ) ;
13094 # \Q \E here to avoid putting \ before each space
13095 like( check_last_release( 1.1 ), qr/\Qis up to date\E/mxs, 'check_last_release: up to date' ) ;
13096 like( check_last_release( 1.1 ), qr/1\.1/mxs, 'check_last_release: up to date, include number' ) ;
13097 diag( check_last_release( 999.999 ) ) ;
13098 like( check_last_release( 999.999 ), qr/\Qnot up to date\E/mxs, 'check_last_release: not up to date' ) ;
13099 like( check_last_release( 999.999 ), qr/999\.999/mxs, 'check_last_release: not up to date, include number' ) ;
13100 like( check_last_release( 'unknown' ), qr/\QImapsync public release is unknown\E/mxs, 'check_last_release: unknown' ) ;
13101 like( check_last_release( 'timeout' ), qr/\QImapsync public release is unknown (timeout)\E/mxs, 'check_last_release: timeout' ) ;
13102 like( check_last_release( 'lalala' ), qr/\QImapsync public release is unknown (lalala)\E/mxs, 'check_last_release: lalala' ) ;
13103 diag( check_last_release( ) ) ;
13104
13105 note( 'Leaving tests_check_last_release()' ) ;
13106 return ;
13107}
13108
13109sub tests_imapsync_context
13110{
13111 note( 'Entering tests_imapsync_context()' ) ;
13112
13113 like( imapsync_context( ), qr/^CGI|^Docker|^DockerCGI|^Standard/, 'imapsync_context: CGI or Docker or DockerCGI or Standard' ) ;
13114 note( 'Leaving tests_imapsync_context()' ) ;
13115 return ;
13116}
13117
13118sub imapsync_context
13119{
13120 my $mysync = shift ;
13121
13122 my $context = q{} ;
13123
13124 if ( under_docker_context( $mysync ) && under_cgi_context( $mysync ) )
13125 {
13126 $context = 'DockerCGI' ;
13127 }
13128 elsif ( under_docker_context( $mysync ) )
13129 {
13130 $context = 'Docker' ;
13131 }
13132 elsif ( under_cgi_context( $mysync ) )
13133 {
13134 $context = 'CGI' ;
13135 }
13136 else
13137 {
13138 $context = 'Standard' ;
13139 }
13140
13141 return $context ;
13142
13143}
13144
13145sub imapsync_version
13146{
13147 my $mysync = shift ;
13148 my $rcs = $mysync->{rcs} ;
13149 my $version ;
13150
13151 $version = version_from_rcs( $rcs ) ;
13152 return( $version ) ;
13153}
13154
13155
13156sub tests_version_from_rcs
13157{
13158 note( 'Entering tests_version_from_rcs()' ) ;
13159
13160 is( undef, version_from_rcs( ), 'version_from_rcs: no args => UNKNOWN' ) ;
13161 is( 1.831, version_from_rcs( q{imapsync,v 1.831 2017/08/27} ), 'version_from_rcs: imapsync,v 1.831 2017/08/27 => 1.831' ) ;
13162 is( 'UNKNOWN', version_from_rcs( 1.831 ), 'version_from_rcs: 1.831 => UNKNOWN' ) ;
13163
13164 note( 'Leaving tests_version_from_rcs()' ) ;
13165 return ;
13166}
13167
13168
13169sub version_from_rcs
13170{
13171
13172 my $rcs = shift ;
13173 if ( ! $rcs ) { return ; }
13174
13175 my $version = 'UNKNOWN' ;
13176
13177 if ( $rcs =~ m{,v\s+(\d+\.\d+)}mxso ) {
13178 $version = $1
13179 }
13180
13181 return( $version ) ;
13182}
13183
13184
13185sub tests_imapsync_basename
13186{
13187 note( 'Entering tests_imapsync_basename()' ) ;
13188
13189 ok( imapsync_basename() =~ m/imapsync/, 'imapsync_basename: match imapsync');
13190 ok( 'blabla' ne imapsync_basename(), 'imapsync_basename: do not equal blabla');
13191
13192 note( 'Leaving tests_imapsync_basename()' ) ;
13193 return ;
13194}
13195
13196sub imapsync_basename
13197{
13198
13199 return basename( $PROGRAM_NAME ) ;
13200
13201}
13202
13203
13204sub localhost_info
13205{
13206 my $mysync = shift ;
13207 my( $infos ) = join( q{},
13208 "Here is imapsync ", imapsync_version( $mysync ),
13209 " on host " . hostname(),
13210 ", a $OSNAME system with ",
13211 ram_memory_info( ),
13212 "\n",
13213 'with Perl ',
13214 mysprintf( '%vd ', $PERL_VERSION),
13215 "and Mail::IMAPClient $Mail::IMAPClient::VERSION",
13216 ) ;
13217 return( $infos ) ;
13218}
13219
13220sub tests_cpu_number
13221{
13222 note( 'Entering tests_cpu_number()' ) ;
13223
13224 is( 1, is_an_integer( cpu_number( ) ), "cpu_number: is_an_integer" ) ;
13225 ok( 1 <= cpu_number( ), "cpu_number: 1 or more" ) ;
13226 is( 1, cpu_number( 1 ), "cpu_number: 1 => 1" ) ;
13227 is( 1, cpu_number( $MINUS_ONE ), "cpu_number: -1 => 1" ) ;
13228 is( 1, cpu_number( 'lalala' ), "cpu_number: lalala => 1" ) ;
13229 is( $NUMBER_42, cpu_number( $NUMBER_42 ), "cpu_number: $NUMBER_42 => $NUMBER_42" ) ;
13230 note( 'Leaving tests_cpu_number()' ) ;
13231 return ;
13232}
13233
13234sub cpu_number
13235{
13236
13237 my $cpu_number_forced = shift ;
13238 # Well, here 1 is better than 0 or undef
13239 my $cpu_number = 1 ; # Default value, erased if better found
13240
13241 my @cpuinfo ;
13242 if ( $ENV{"NUMBER_OF_PROCESSORS"} ) {
13243 # might be under a Windows system
13244 $cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ;
13245 $sync->{ debug } and myprint( "Number of processors found by env var NUMBER_OF_PROCESSORS: $cpu_number\n" ) ;
13246 }elsif ( 'darwin' eq $OSNAME or 'freebsd' eq $OSNAME ) {
13247 $cpu_number = backtick( "sysctl -n hw.ncpu" ) ;
13248 chomp( $cpu_number ) ;
13249 $sync->{ debug } and myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ;
13250 }elsif ( ! -e '/proc/cpuinfo' ) {
13251 $sync->{ debug } and myprint( "Number of processors not found so I might assume there is only 1\n" ) ;
13252 $cpu_number = 1 ;
13253 }elsif( @cpuinfo = file_to_array( '/proc/cpuinfo' ) ) {
13254 $cpu_number = grep { /^processor/mxs } @cpuinfo ;
13255 $sync->{ debug } and myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ;
13256 }
13257
13258 if ( defined $cpu_number_forced ) {
13259 $cpu_number = $cpu_number_forced ;
13260 }
13261 return( integer_or_1( $cpu_number ) ) ;
13262}
13263
13264
13265sub tests_integer_or_1
13266{
13267 note( 'Entering tests_integer_or_1()' ) ;
13268
13269 is( 1, integer_or_1( ), 'integer_or_1: no args => 1' ) ;
13270 is( 1, integer_or_1( undef ), 'integer_or_1: undef => 1' ) ;
13271 is( $NUMBER_10, integer_or_1( $NUMBER_10 ), 'integer_or_1: 10 => 10' ) ;
13272 is( 1, integer_or_1( q{} ), 'integer_or_1: empty string => 1' ) ;
13273 is( 1, integer_or_1( 'lalala' ), 'integer_or_1: lalala => 1' ) ;
13274
13275 note( 'Leaving tests_integer_or_1()' ) ;
13276 return ;
13277}
13278
13279sub integer_or_1
13280{
13281 my $number = shift ;
13282 if ( is_an_integer( $number ) ) {
13283 return $number ;
13284 }
13285 # else
13286 return 1 ;
13287}
13288
13289sub tests_is_an_integer
13290{
13291 note( 'Entering tests_is_an_integer()' ) ;
13292
13293 is( undef, is_an_integer( ), 'is_an_integer: no args => undef ' ) ;
13294 ok( is_an_integer( 1 ), 'is_an_integer: 1 => yes ') ;
13295 ok( is_an_integer( $NUMBER_42 ), 'is_an_integer: 42 => yes ') ;
13296 ok( is_an_integer( "$NUMBER_42" ), 'is_an_integer: "$NUMBER_42" => yes ') ;
13297 ok( is_an_integer( '42' ), 'is_an_integer: "42" => yes ') ;
13298 ok( is_an_integer( $NUMBER_104_857_600 ), 'is_an_integer: 104_857_600 => yes') ;
13299 ok( is_an_integer( "$NUMBER_104_857_600" ), 'is_an_integer: "$NUMBER_104_857_600" => yes') ;
13300 ok( is_an_integer( '104857600' ), 'is_an_integer: 104857600 => yes') ;
13301 ok( ! is_an_integer( 'blabla' ), 'is_an_integer: blabla => no' ) ;
13302 ok( ! is_an_integer( q{} ), 'is_an_integer: empty string => no' ) ;
13303
13304 note( 'Leaving tests_is_an_integer()' ) ;
13305 return ;
13306}
13307
13308sub is_an_integer
13309{
13310 my $number = shift ;
13311 if ( ! defined $number ) { return ; }
13312 return( $number =~ m{^\d+$}xo ) ;
13313}
13314
13315
13316
13317
13318sub tests_loadavg
13319{
13320 note( 'Entering tests_loadavg()' ) ;
13321
13322
13323 SKIP: {
13324 skip( 'Tests for darwin', 2 ) if ('darwin' ne $OSNAME) ;
13325 is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ;
13326 is_deeply( [ '0.11', '0.22', '0.33' ],
13327 [ loadavg( 'W/t/loadavg.out' ) ],
13328 'loadavg W/t/loadavg.out => 0.11 0.22 0.33' ) ;
13329 } ;
13330
13331 SKIP: {
13332 skip( 'Tests for linux', 3 ) if ('linux' ne $OSNAME) ;
13333 is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ;
13334 ok( loadavg( ), 'loadavg: no args' ) ;
13335
13336 is_deeply( [ '0.39', '0.30', '0.37', '1/602' ],
13337 [ loadavg( '0.39 0.30 0.37 1/602 6073' ) ],
13338 'loadavg 0.39 0.30 0.37 1/602 6073 => [0.39, 0.30, 0.37, 1/602]' ) ;
13339 } ;
13340
13341 SKIP: {
13342 skip( 'Tests for Windows', 1 ) if ('MSWin32' ne $OSNAME) ;
13343 is_deeply( [ 0 ],
13344 [ loadavg( ) ],
13345 'loadavg on MSWin32 => 0' ) ;
13346
13347 } ;
13348
13349 note( 'Leaving tests_loadavg()' ) ;
13350 return ;
13351}
13352
13353
13354sub loadavg
13355{
13356 if ( 'linux' eq $OSNAME ) {
13357 return ( loadavg_linux( @ARG ) ) ;
13358 }
13359 if ( 'freebsd' eq $OSNAME ) {
13360 return ( loadavg_freebsd( @ARG ) ) ;
13361 }
13362 if ( 'darwin' eq $OSNAME ) {
13363 return ( loadavg_darwin( @ARG ) ) ;
13364 }
13365 if ( 'MSWin32' eq $OSNAME ) {
13366 return ( loadavg_windows( @ARG ) ) ;
13367 }
13368 return( 'unknown' ) ;
13369
13370}
13371
13372sub loadavg_linux
13373{
13374 my $line = shift ;
13375
13376 if ( ! $line ) {
13377 $line = firstline( '/proc/loadavg' ) or return ;
13378 }
13379
13380 my ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) = split /\s/mxs, $line ;
13381 if ( all_defined( $avg_1_min, $avg_5_min, $avg_15_min ) ) {
13382 $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min $current_runs\n" ) ;
13383 return ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) ;
13384 }
13385 return ;
13386}
13387
13388sub loadavg_freebsd
13389{
13390 my $file = shift ;
13391 # Example of output of command "sysctl vm.loadavg":
13392 # vm.loadavg: { 0.15 0.08 0.08 }
13393 my $loadavg ;
13394
13395 if ( ! defined $file ) {
13396 eval {
13397 $loadavg = `/sbin/sysctl vm.loadavg` ;
13398 #myprint( "LOADAVG FREEBSD: $loadavg\n" ) ;
13399 } ;
13400 if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; }
13401 }else{
13402 $loadavg = firstline( $file ) or return ;
13403 }
13404
13405 my ( $avg_1_min, $avg_5_min, $avg_15_min )
13406 = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ;
13407 $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ;
13408 return ( $avg_1_min, $avg_5_min, $avg_15_min ) ;
13409}
13410
13411sub loadavg_darwin
13412{
13413 my $file = shift ;
13414 # Example of output of command "sysctl vm.loadavg":
13415 # vm.loadavg: { 0.15 0.08 0.08 }
13416 my $loadavg ;
13417
13418 if ( ! defined $file ) {
13419 eval {
13420 $loadavg = `/usr/sbin/sysctl vm.loadavg` ;
13421 #myprint( "LOADAVG DARWIN: $loadavg\n" ) ;
13422 } ;
13423 if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; }
13424 }else{
13425 $loadavg = firstline( $file ) or return ;
13426 }
13427
13428 my ( $avg_1_min, $avg_5_min, $avg_15_min )
13429 = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ;
13430 $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ;
13431 return ( $avg_1_min, $avg_5_min, $avg_15_min ) ;
13432}
13433
13434sub loadavg_windows
13435{
13436 my $file = shift ;
13437 # Example of output of command "wmic cpu get loadpercentage":
13438 # LoadPercentage
13439 # 12
13440 my $loadavg ;
13441
13442 if ( ! defined $file ) {
13443 eval {
13444 #$loadavg = `CMD wmic cpu get loadpercentage` ;
13445 $loadavg = "LoadPercentage\n0\n" ;
13446 #myprint( "LOADAVG WIN: $loadavg\n" ) ;
13447 } ;
13448 if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; }
13449 }else{
13450 $loadavg = file_to_string( $file ) or return ;
13451 #myprint( "$loadavg" ) ;
13452 }
13453 $loadavg =~ /LoadPercentage\n(\d+)/xms ;
13454 my $num = $1 ;
13455 $num /= 100 ;
13456
13457 $sync->{ debug } and myprint( "System load: $num\n" ) ;
13458 return ( $num ) ;
13459}
13460
13461
13462
13463
13464
13465
13466sub tests_load_and_delay
13467{
13468 note( 'Entering tests_load_and_delay()' ) ;
13469
13470 is( undef, load_and_delay( ), 'load_and_delay: no args => undef ' ) ;
13471 is( undef, load_and_delay( 1 ), 'load_and_delay: not 4 args => undef ' ) ;
13472 is( undef, load_and_delay( 0, 1, 1, 1 ), 'load_and_delay: division per 0 => undef ' ) ;
13473 is( 0, load_and_delay( 1, 1, 1, 1 ), 'load_and_delay: one core, loads are all 1 => ok ' ) ;
13474 is( 0, load_and_delay( 1, 1, 1, 1, 'lalala' ), 'load_and_delay: five arguments is ok' ) ;
13475 is( 0, load_and_delay( 2, 2, 2, 2 ), 'load_and_delay: two core, loads are all 2 => ok ' ) ;
13476 is( 0, load_and_delay( 2, 2, 4, 5 ), 'load_and_delay: two core, load1m is 2 => ok ' ) ;
13477
13478# Old behavior, rather strict
13479 # is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ;
13480 # is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ;
13481 # is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ;
13482 # is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ;
13483 # is( 1, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ;
13484 # is( 1, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ;
13485 # is( 5, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ;
13486 # is( 15, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ;
13487
13488 # is( 0, load_and_delay( 4, 0, 2, 2 ), 'load_and_delay: four core, load1m=0 load5m=2 load15m=2 => 0 ' ) ;
13489 # is( 1, load_and_delay( 4, 8, 0, 0 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=0 => 1 ' ) ;
13490 # is( 1, load_and_delay( 4, 8, 0, 2 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=2 => 1 ' ) ;
13491 # is( 5, load_and_delay( 4, 8, 8, 0 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=0 => 5 ' ) ;
13492 # is( 15, load_and_delay( 4, 8, 8, 8 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=2 => 15 ' ) ;
13493
13494# New behavior, tolerate more load
13495
13496 is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ;
13497 is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ;
13498 is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ;
13499 is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ;
13500 is( 0, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ;
13501 is( 0, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ;
13502 is( 0, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ;
13503 is( 0, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ;
13504
13505 is( 1, load_and_delay( 1, 4, 0, 0 ), 'load_and_delay: one core, load1m=4 load5m=0 load15m=0 => 1 ' ) ;
13506 is( 1, load_and_delay( 1, 4, 0, 4 ), 'load_and_delay: one core, load1m=4 load5m=0 load15m=4 => 1 ' ) ;
13507 is( 5, load_and_delay( 1, 4, 4, 0 ), 'load_and_delay: one core, load1m=4 load5m=4 load15m=0 => 5 ' ) ;
13508 is( 15, load_and_delay( 1, 4, 4, 4 ), 'load_and_delay: one core, load1m=4 load5m=4 load15m=4 => 15 ' ) ;
13509
13510 is( 0, load_and_delay( 4, 0, 9, 9 ), 'load_and_delay: four core, load1m=0 load5m=9 load15m=9 => 0 ' ) ;
13511 is( 1, load_and_delay( 4, 9, 0, 0 ), 'load_and_delay: four core, load1m=9 load5m=0 load15m=0 => 1 ' ) ;
13512 is( 1, load_and_delay( 4, 9, 0, 9 ), 'load_and_delay: four core, load1m=9 load5m=0 load15m=9 => 1 ' ) ;
13513 is( 5, load_and_delay( 4, 9, 9, 0 ), 'load_and_delay: four core, load1m=9 load5m=9 load15m=0 => 5 ' ) ;
13514 is( 15, load_and_delay( 4, 9, 9, 9 ), 'load_and_delay: four core, load1m=9 load5m=9 load15m=9 => 15 ' ) ;
13515
13516 note( 'Leaving tests_load_and_delay()' ) ;
13517 return ;
13518}
13519
13520sub load_and_delay
13521{
13522 # Basically return 0 if load is not heavy, ie <= 1 per processor
13523
13524 # Not enough arguments
13525 if ( 4 > scalar @ARG ) { return ; }
13526
13527 my ( $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ;
13528
13529 if ( 0 == $cpu_num ) { return ; }
13530
13531 # Let divide by number of cores
13532 ( $avg_1_min, $avg_5_min, $avg_15_min ) = map { $_ / $cpu_num } ( $avg_1_min, $avg_5_min, $avg_15_min ) ;
13533 # One of avg ok => ok, for now it is a OR
13534 if ( $avg_1_min <= 2 ) { return 0 ; }
13535 if ( $avg_5_min <= 2 ) { return 1 ; } # Retry in 1 minute
13536 if ( $avg_15_min <= 2 ) { return 5 ; } # Retry in 5 minutes
13537 return 15 ; # Retry in 15 minutes
13538}
13539
13540sub ram_memory_info
13541{
13542 # In GigaBytes so division by 1024 * 1024 * 1024
13543 #
13544 return(
13545 sprintf( "%.1f/%.1f free GiB of RAM",
13546 Sys::MemInfo::get("freemem") / ( $KIBI ** 3 ),
13547 Sys::MemInfo::get("totalmem") / ( $KIBI ** 3 ),
13548 )
13549 ) ;
13550}
13551
13552
13553
13554sub tests_memory_stress
13555{
13556 note( 'Entering tests_memory_stress()' ) ;
13557
13558 is( undef, memory_stress( ), 'memory_stress: => undef' ) ;
13559
13560 note( 'Leaving tests_memory_stress()' ) ;
13561 return ;
13562}
13563
13564sub memory_stress
13565{
13566
13567 my $total_ram_in_MB = Sys::MemInfo::get("totalmem") / ( $KIBI * $KIBI ) ;
13568 my $i = 1 ;
13569
13570 myprintf("Stress memory consumption before: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ;
13571 while ( $i < $total_ram_in_MB / 1.7 ) { $a .= "A" x 1000_000; $i++ } ;
13572 myprintf("Stress memory consumption after: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ;
13573 return ;
13574
13575}
13576
13577sub tests_memory_consumption
13578{
13579 note( 'Entering tests_memory_consumption()' ) ;
13580
13581 like( memory_consumption( ), qr{\d+}xms,'memory_consumption no args') ;
13582 like( memory_consumption( 1 ), qr{\d+}xms,'memory_consumption 1') ;
13583 like( memory_consumption( $PROCESS_ID ), qr{\d+}xms,"memory_consumption_of_pids $PROCESS_ID") ;
13584
13585 like( memory_consumption_ratio(), qr{\d+}xms, 'memory_consumption_ratio' ) ;
13586 like( memory_consumption_ratio(1), qr{\d+}xms, 'memory_consumption_ratio 1' ) ;
13587 like( memory_consumption_ratio(10), qr{\d+}xms, 'memory_consumption_ratio 10' ) ;
13588
13589 like( memory_consumption(), qr{\d+}xms, "memory_consumption\n" ) ;
13590
13591 note( 'Leaving tests_memory_consumption()' ) ;
13592 return ;
13593}
13594
13595sub memory_consumption
13596{
13597 # memory consumed by imapsync until now in bytes
13598 return( ( memory_consumption_of_pids( ) )[0] );
13599}
13600
13601sub debugmemory
13602{
13603 my $mysync = shift ;
13604 if ( ! $mysync->{debugmemory} ) { return q{} ; }
13605
13606 my $precision = shift ;
13607 return( mysprintf( "Memory consumption$precision: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ) ;
13608}
13609
13610sub memory_consumption_of_pids
13611{
13612
13613 my @pid = @_;
13614 @pid = ( @pid ) ? @pid : ( $PROCESS_ID ) ;
13615
13616 $sync->{ debug } and myprint( "memory_consumption_of_pids PIDs: @pid\n" ) ;
13617 my @val ;
13618 if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) {
13619 @val = memory_consumption_of_pids_win32( @pid ) ;
13620 }else{
13621 # Unix
13622 my @ps = qx{ ps -o vsz -p @pid } ;
13623 #myprint( "ps: @ps" ) ;
13624
13625 # Use IPC::Open3 from perlcrit -3
13626 # It stalls on Darwin, don't understand why!
13627 #my @ps = backtick( "ps -o vsz -p @pid" ) ;
13628 #myprint( "ps: @ps" ) ;
13629
13630 shift @ps; # First line is column name "VSZ"
13631 chomp @ps;
13632 # convert to octets
13633
13634 @val = map { $_ * $KIBI } @ps ;
13635 }
13636 $sync->{ debug } and myprint( "@val\n" ) ;
13637 return( @val ) ;
13638}
13639
13640sub memory_consumption_of_pids_win32
13641{
13642 # Windows
13643 my @PID = @_;
13644 my %PID;
13645 # hash of pids as key values
13646 map { $PID{$_}++ } @PID;
13647
13648 # Does not work but should work reading the tasklist documentation
13649 #@ps = qx{ tasklist /FI "PID eq @PID" };
13650
13651 my @ps = qx{ tasklist /NH /FO CSV } ;
13652 #my @ps = backtick( 'tasklist /NH /FO CSV' ) ;
13653 #myprint( "-" x $STD_CHAR_PER_LINE, "\n", @ps, "-" x $STD_CHAR_PER_LINE, "\n" ) ;
13654 my @val;
13655 foreach my $line (@ps) {
13656 my($name, $pid, $mem) = (split ',', $line )[0,1,4];
13657 next if (! $pid);
13658 #myprint( "[$name][$pid][$mem]" ) ;
13659 if ($PID{remove_qq($pid)}) {
13660 #myprint( "MATCH !\n" ) ;
13661 chomp $mem ;
13662 $mem = remove_qq($mem);
13663 $mem = remove_Ko($mem);
13664 $mem = remove_not_num($mem);
13665 #myprint( "[$mem]\n" ) ;
13666 push @val, $mem * $KIBI;
13667 }
13668 }
13669 return(@val);
13670}
13671
13672
13673sub tests_backtick
13674{
13675 note( 'Entering tests_backtick()' ) ;
13676
13677 is( undef, backtick( ), 'backtick: no args' ) ;
13678 is( undef, backtick( q{} ), 'backtick: empty command' ) ;
13679
13680 SKIP: {
13681 skip( 'test for MSWin32', 5 ) if ('MSWin32' ne $OSNAME) ;
13682 my @output ;
13683 @output = backtick( 'echo Hello World!' ) ;
13684 # Add \r on Windows.
13685 ok( "Hello World!\r\n" eq $output[0], 'backtick: echo Hello World!' ) ;
13686 $sync->{ debug } and myprint( "[@output]" ) ;
13687 @output = backtick( 'echo Hello & echo World!' ) ;
13688 ok( "Hello \r\n" eq $output[0], 'backtick: echo Hello & echo World! line 1' ) ;
13689 ok( "World!\r\n" eq $output[1], 'backtick: echo Hello & echo World! line 2' ) ;
13690 $sync->{ debug } and myprint( "[@output][$output[0]][$output[1]]" ) ;
13691 # Scalar context
13692 ok( "Hello World!\r\n" eq backtick( 'echo Hello World!' ),
13693 'backtick: echo Hello World! scalar' ) ;
13694 ok( "Hello \r\nWorld!\r\n" eq backtick( 'echo Hello & echo World!' ),
13695 'backtick: echo Hello & echo World! scalar 2 lines' ) ;
13696 } ;
13697 SKIP: {
13698 skip( 'test for Unix', 7 ) if ('MSWin32' eq $OSNAME) ;
13699 is( undef, backtick( 'aaaarrrg' ), 'backtick: aaaarrrg command not found' ) ;
13700 # Array context
13701 my @output ;
13702 @output = backtick( 'echo Hello World!' ) ;
13703 ok( "Hello World!\n" eq $output[0], 'backtick: echo Hello World!' ) ;
13704 $sync->{ debug } and myprint( "[@output]" ) ;
13705 @output = backtick( "echo Hello\necho World!" ) ;
13706 ok( "Hello\n" eq $output[0], 'backtick: echo Hello; echo World! line 1' ) ;
13707 ok( "World!\n" eq $output[1], 'backtick: echo Hello; echo World! line 2' ) ;
13708 $sync->{ debug } and myprint( "[@output]" ) ;
13709 # Scalar context
13710 ok( "Hello World!\n" eq backtick( 'echo Hello World!' ),
13711 'backtick: echo Hello World! scalar' ) ;
13712 ok( "Hello\nWorld!\n" eq backtick( "echo Hello\necho World!" ),
13713 'backtick: echo Hello; echo World! scalar 2 lines' ) ;
13714 # Return error positive value, that's ok
13715 is( undef, backtick( 'false' ), 'backtick: false returns no output' ) ;
13716 my $mem = backtick( "ps -o vsz -p $PROCESS_ID" ) ;
13717 $sync->{ debug } and myprint( "MEM=$mem\n" ) ;
13718
13719 }
13720
13721 note( 'Leaving tests_backtick()' ) ;
13722 return ;
13723}
13724
13725
13726sub backtick
13727{
13728 my $command = shift ;
13729
13730 if ( ! $command ) { return ; }
13731
13732 my ( $writer, $reader, $err ) ;
13733 my @output ;
13734 my $pid ;
13735 my $eval = eval {
13736 $pid = IPC::Open3::open3( $writer, $reader, $err, $command ) ;
13737 } ;
13738 if ( $EVAL_ERROR ) {
13739 myprint( $EVAL_ERROR ) ;
13740 return ;
13741 }
13742 if ( ! $eval ) { return ; }
13743 if ( ! $pid ) { return ; }
13744 waitpid( $pid, 0 ) ;
13745 @output = <$reader>; # Output here
13746 #
13747 #my @errors = <$err>; #Errors here, instead of the console
13748 if ( not @output ) { return ; }
13749 #myprint( @output ) ;
13750
13751 if ( $output[0] =~ /\Qopen3: exec of $command failed\E/mxs ) { return ; }
13752 if ( wantarray ) {
13753 return( @output ) ;
13754 } else {
13755 return( join( q{}, @output) ) ;
13756 }
13757}
13758
13759
13760
13761sub tests_check_binary_embed_all_dyn_libs
13762{
13763 note( 'Entering tests_check_binary_embed_all_dyn_libs()' ) ;
13764
13765 is( 1, check_binary_embed_all_dyn_libs( ), 'check_binary_embed_all_dyn_libs: no args => 1' ) ;
13766
13767 note( 'Leaving tests_check_binary_embed_all_dyn_libs()' ) ;
13768
13769 return ;
13770}
13771
13772
13773sub check_binary_embed_all_dyn_libs
13774{
13775 my @search_dyn_lib_locale = search_dyn_lib_locale( ) ;
13776
13777 if ( @search_dyn_lib_locale )
13778 {
13779 myprint( "Found myself $PROGRAM_NAME pid $PROCESS_ID using locale dynamic libraries that seems out of myself:\n" ) ;
13780 myprint( @search_dyn_lib_locale ) ;
13781 if ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} )
13782 {
13783 return 0 ;
13784 }
13785 elsif ( $PROGRAM_NAME =~ m{imapsync.*\.exe} )
13786 {
13787 return 0 ;
13788 }
13789 else
13790 {
13791 # is always ok for non binary
13792 return 1 ;
13793 }
13794 }
13795 else
13796 {
13797 # Found only embedded dynamic lib
13798 myprint( "Found nothing\n" ) ;
13799 return 1 ;
13800 }
13801}
13802
13803sub search_dyn_lib_locale
13804{
13805 if ( 'darwin' eq $OSNAME )
13806 {
13807 return search_dyn_lib_locale_darwin( ) ;
13808 }
13809 if ( 'linux' eq $OSNAME )
13810 {
13811 return search_dyn_lib_locale_linux( ) ;
13812 }
13813 if ( 'MSWin32' eq $OSNAME )
13814 {
13815 return search_dyn_lib_locale_MSWin32( ) ;
13816 }
13817
13818}
13819
13820sub search_dyn_lib_locale_darwin
13821{
13822 my $command = qq{ lsof -p $PID | grep ' REG ' | grep .dylib | grep -v '/par-' } ;
13823 myprint( "Search non embeded dynamic libs with the command: $command\n" ) ;
13824 return backtick( $command ) ;
13825}
13826
13827sub search_dyn_lib_locale_linux
13828{
13829 my $command = qq{ lsof -p $PID | grep ' REG ' | grep -v '/tmp/par-' | grep '\.so' } ;
13830 myprint( "Search non embeded dynamic libs with the command: $command\n" ) ;
13831 return backtick( $command ) ;
13832}
13833
13834sub search_dyn_lib_locale_MSWin32
13835{
13836 my $command = qq{ Listdlls.exe $PID|findstr Strawberry } ;
13837 # $command = qq{ Listdlls.exe $PID|findstr Strawberry } ;
13838 myprint( "Search non embeded dynamic libs with the command: $command\n" ) ;
13839 return qx( $command ) ;
13840}
13841
13842
13843
13844sub remove_not_num
13845{
13846
13847 my $string = shift ;
13848 $string =~ tr/0-9//cd ;
13849 #myprint( "tr [$string]\n" ) ;
13850 return( $string ) ;
13851}
13852
13853sub tests_remove_not_num
13854{
13855 note( 'Entering tests_remove_not_num()' ) ;
13856
13857 ok( '123' eq remove_not_num( 123 ), 'remove_not_num( 123 )' ) ;
13858 ok( '123' eq remove_not_num( '123' ), q{remove_not_num( '123' )} ) ;
13859 ok( '123' eq remove_not_num( '12 3' ), q{remove_not_num( '12 3' )} ) ;
13860 ok( '123' eq remove_not_num( 'a 12 3 Ko' ), q{remove_not_num( 'a 12 3 Ko' )} ) ;
13861
13862 note( 'Leaving tests_remove_not_num()' ) ;
13863 return ;
13864}
13865
13866sub remove_Ko
13867{
13868 my $string = shift;
13869 if ($string =~ /^(.*)\sKo$/xo) {
13870 return($1);
13871 }else{
13872 return($string);
13873 }
13874}
13875
13876sub remove_qq
13877{
13878 my $string = shift;
13879 if ($string =~ /^"(.*)"$/xo) {
13880 return($1);
13881 }else{
13882 return($string);
13883 }
13884}
13885
13886sub memory_consumption_ratio
13887{
13888
13889 my ($base) = @_;
13890 $base ||= 1;
13891 my $consu = memory_consumption();
13892 return($consu / $base);
13893}
13894
13895
13896sub date_from_rcs
13897{
13898 my $d = shift ;
13899
13900 my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ;
13901 if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) {
13902 # Handles the following format
13903 # 2015/07/10 11:05:59 -- Generated by RCS Date tag.
13904 #myprint( "$d\n" ) ;
13905 #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ;
13906 my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ;
13907 $month = $num2mon{$month} ;
13908 $d = "$day-$month-$year $hour:$min:$sec +0000" ;
13909 #myprint( "$d\n" ) ;
13910 }
13911 return( $d ) ;
13912}
13913
13914sub tests_date_from_rcs
13915{
13916 note( 'Entering tests_date_from_rcs()' ) ;
13917
13918 ok('19-Sep-2015 16:11:07 +0000'
13919 eq date_from_rcs('Date: 2015/09/19 16:11:07 '), 'date_from_rcs from RCS date' ) ;
13920
13921 note( 'Leaving tests_date_from_rcs()' ) ;
13922 return ;
13923}
13924
13925sub good_date
13926{
13927 # two incoming formats:
13928 # header Tue, 24 Aug 2010 16:00:00 +0200
13929 # internal 24-Aug-2010 16:00:00 +0200
13930
13931 # outgoing format: internal date format
13932 # 24-Aug-2010 16:00:00 +0200
13933
13934 my $d = shift ;
13935 return(q{}) if not defined $d;
13936
13937 SWITCH: {
13938 if ( $d =~ m{(\d?)(\d-...-\d{4})(\s\d{2}:\d{2}:\d{2})(\s(?:\+|-)\d{4})?}xo ) {
13939 #myprint( "internal: [$1][$2][$3][$4]\n" ) ;
13940 my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4) ;
13941 $day_1 = '0' if ($day_1 eq q{}) ;
13942 $zone = ' +0000' if not defined $zone ;
13943 $d = $day_1 . $date_rest . $hour . $zone ;
13944 last SWITCH ;
13945 }
13946
13947 if ($d =~ m{(?:\w{3,},\s)?(\d{1,2}),?\s+(\w{3,})\s+(\d{2,4})\s+(\d{1,2})(?::|\.)(\d{1,2})(?:(?::|\.)(\d{1,2}))?\s*((?:\+|-)\d{4})?}xo ) {
13948 # Handles any combination of following formats
13949 # Tue, 24 Aug 2010 16:00:00 +0200 -- Standard
13950 # 24 Aug 2010 16:00:00 +0200 -- Missing Day of Week
13951 # Tue, 24 Aug 97 16:00:00 +0200 -- Two digit year
13952 # Tue, 24 Aug 1997 16.00.00 +0200 -- Periods instead of colons
13953 # Tue, 24 Aug 1997 16:00:00 +0200 -- Extra whitespace between year and hour
13954 # Tue, 24 Aug 1997 6:5:2 +0200 -- Single digit hour, min, or second
13955 # Tue, 24, Aug 1997 16:00:00 +0200 -- Extra comma
13956
13957 #myprint( "header: [$1][$2][$3][$4][$5][$6][$7][$8]\n" ) ;
13958 my ($day, $month, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7,$8);
13959 $year = '19' . $year if length($year) == 2 && $year =~ m/^[789]/xo;
13960 $year = '20' . $year if length($year) == 2;
13961
13962 $month = substr $month, 0, 3 if length($month) > 4;
13963 $day = mysprintf( '%02d', $day);
13964 $hour = mysprintf( '%02d', $hour);
13965 $min = mysprintf( '%02d', $min);
13966 $sec = '00' if not defined $sec ;
13967 $sec = mysprintf( '%02d', $sec ) ;
13968 $zone = '+0000' if not defined $zone ;
13969 $d = "$day-$month-$year $hour:$min:$sec $zone" ;
13970 last SWITCH ;
13971 }
13972
13973 if ($d =~ m{(?:.{3})\s(...)\s+(\d{1,2})\s(\d{1,2}):(\d{1,2}):(\d{1,2})\s(?:\w{3})?\s?(\d{4})}xo ) {
13974 # Handles any combination of following formats
13975 # Sun Aug 20 11:55:09 2006
13976 # Wed Jan 24 11:58:38 MST 2007
13977 # Wed Jan 2 08:40:57 2008
13978
13979 #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ;
13980 my ($month, $day, $hour, $min, $sec, $year) = ($1,$2,$3,$4,$5,$6);
13981 $day = mysprintf( '%02d', $day ) ;
13982 $hour = mysprintf( '%02d', $hour ) ;
13983 $min = mysprintf( '%02d', $min ) ;
13984 $sec = mysprintf( '%02d', $sec ) ;
13985 $d = "$day-$month-$year $hour:$min:$sec +0000" ;
13986 last SWITCH ;
13987 }
13988 my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ;
13989
13990 if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) {
13991 # Handles the following format
13992 # 2015/07/10 11:05:59 -- Generated by RCS Date tag.
13993 #myprint( "$d\n" ) ;
13994 #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ;
13995 my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ;
13996 $month = $num2mon{$month} ;
13997 $d = "$day-$month-$year $hour:$min:$sec +0000" ;
13998 #myprint( "$d\n" ) ;
13999 last SWITCH ;
14000 }
14001
14002 if ($d =~ m{(\d{2})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) {
14003 # Handles the following format
14004 # 02/06/09 22:18:08 -- Generated by AVTECH TemPageR devices
14005
14006 #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ;
14007 my ($month, $day, $year, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6);
14008 $year = '20' . $year;
14009 $month = $num2mon{$month};
14010 $d = "$day-$month-$year $hour:$min:$sec +0000";
14011 last SWITCH ;
14012 }
14013
14014 if ($d =~ m{\w{6,},\s(\w{3})\w+\s+(\d{1,2}),\s(\d{4})\s(\d{2}):(\d{2})\s(AM|PM)}xo ) {
14015 # Handles the following format
14016 # Saturday, December 14, 2002 05:00 PM - KBtoys.com order confirmations
14017
14018 my ($month, $day, $year, $hour, $min, $apm) = ($1,$2,$3,$4,$5,$6);
14019
14020 $hour += 12 if $apm eq 'PM' ;
14021 $day = mysprintf( '%02d', $day ) ;
14022 $d = "$day-$month-$year $hour:$min:00 +0000" ;
14023 last SWITCH ;
14024 }
14025
14026 if ($d =~ m{(\w{3})\s(\d{1,2})\s(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-)\d{4})}xo ) {
14027 # Handles the following format
14028 # Saturday, December 14, 2002 05:00 PM - jr.com order confirmations
14029
14030 my ($month, $day, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7);
14031
14032 $day = mysprintf( '%02d', $day ) ;
14033 $d = "$day-$month-$year $hour:$min:$sec $zone";
14034 last SWITCH ;
14035 }
14036
14037 if ($d =~ m{(\d{1,2})-(\w{3})-(\d{4})}xo ) {
14038 # Handles the following format
14039 # 21-Jun-2001 - register.com domain transfer email circa 2001
14040
14041 my ($day, $month, $year) = ($1,$2,$3);
14042 $day = mysprintf( '%02d', $day);
14043 $d = "$day-$month-$year 11:11:11 +0000";
14044 last SWITCH ;
14045 }
14046
14047 # unknown or unmatch => return same string
14048 return($d);
14049 }
14050
14051 $d = qq("$d") ;
14052 return( $d ) ;
14053}
14054
14055
14056sub tests_good_date
14057{
14058 note( 'Entering tests_good_date()' ) ;
14059
14060 ok(q{} eq good_date(), 'good_date no arg');
14061 ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24-Aug-2010 16:00:00 +0200'), 'good_date internal 2digit zone');
14062 ok('"24-Aug-2010 16:00:00 +0000"' eq good_date('24-Aug-2010 16:00:00'), 'good_date internal 2digit no zone');
14063 ok('"01-Sep-2010 16:00:00 +0200"' eq good_date( '1-Sep-2010 16:00:00 +0200'), 'good_date internal SP 1digit');
14064 ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('Tue, 24 Aug 2010 16:00:00 +0200'), 'good_date header 2digit zone');
14065 ok('"01-Sep-2010 16:00:00 +0000"' eq good_date('Wed, 1 Sep 2010 16:00:00'), 'good_date header SP 1digit zone');
14066 ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200'), 'good_date header SP 1digit zone');
14067 ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200 (CEST)'), 'good_date header SP 1digit zone');
14068 ok('"06-Feb-2009 22:18:08 +0000"' eq good_date('02/06/09 22:18:08'), 'good_date header TemPageR');
14069 ok('"02-Jan-2008 08:40:57 +0000"' eq good_date('Wed Jan 2 08:40:57 2008'), 'good_date header dice.com support 1digit day');
14070 ok('"20-Aug-2006 11:55:09 +0000"' eq good_date('Sun Aug 20 11:55:09 2006'), 'good_date header dice.com support 2digit day');
14071 ok('"24-Jan-2007 11:58:38 +0000"' eq good_date('Wed Jan 24 11:58:38 MST 2007'), 'good_date header status-now.com');
14072 ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24 Aug 2010 16:00:00 +0200'), 'good_date header missing date of week');
14073 ok('"24-Aug-2067 16:00:00 +0200"' eq good_date('Tue, 24 Aug 67 16:00:00 +0200'), 'good_date header 2digit year');
14074 ok('"24-Aug-1977 16:00:00 +0200"' eq good_date('Tue, 24 Aug 77 16:00:00 +0200'), 'good_date header 2digit year');
14075 ok('"24-Aug-1987 16:00:00 +0200"' eq good_date('Tue, 24 Aug 87 16:00:00 +0200'), 'good_date header 2digit year');
14076 ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 97 16:00:00 +0200'), 'good_date header 2digit year');
14077 ok('"24-Aug-2004 16:00:00 +0200"' eq good_date('Tue, 24 Aug 04 16:00:00 +0200'), 'good_date header 2digit year');
14078 ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16.00.00 +0200'), 'good_date header period time sep');
14079 ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16:00:00 +0200'), 'good_date header extra white space type1');
14080 ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24 Aug 1997 5:6:2 +0200'), 'good_date header 1digit time vals');
14081 ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24, Aug 1997 05:06:02 +0200'), 'good_date header extra commas');
14082 ok('"01-Oct-2003 12:45:24 +0000"' eq good_date('Wednesday, 01 October 2003 12:45:24 CDT'), 'good_date header no abbrev');
14083 ok('"11-Jan-2005 17:58:27 -0500"' eq good_date('Tue, 11 Jan 2005 17:58:27 -0500'), 'good_date extra white space');
14084 ok('"18-Dec-2002 15:07:00 +0000"' eq good_date('Wednesday, December 18, 2002 03:07 PM'), 'good_date kbtoys.com orders');
14085 ok('"16-Dec-2004 02:01:49 -0500"' eq good_date('Dec 16 2004 02:01:49 -0500'), 'good_date jr.com orders');
14086 ok('"21-Jun-2001 11:11:11 +0000"' eq good_date('21-Jun-2001'), 'good_date register.com domain transfer');
14087 ok('"18-Nov-2012 18:34:38 +0100"' eq good_date('Sun, 18 Nov 2012 18:34:38 +0100'), 'good_date pop2imap bug (Westeuropäische Normalzeit)');
14088 ok('"19-Sep-2015 16:11:07 +0000"' eq good_date('Date: 2015/09/19 16:11:07 '), 'good_date from RCS date' ) ;
14089
14090 note( 'Leaving tests_good_date()' ) ;
14091 return ;
14092}
14093
14094
14095sub tests_list_keys_in_2_not_in_1
14096{
14097 note( 'Entering tests_list_keys_in_2_not_in_1()' ) ;
14098
14099
14100 my @list;
14101 ok( ! list_keys_in_2_not_in_1( {}, {}), 'list_keys_in_2_not_in_1: {} {}');
14102 ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {}, {} ) ] ), 'list_keys_in_2_not_in_1: {} {}');
14103 ok( 0 == compare_lists( ['a','b'], [ list_keys_in_2_not_in_1( {}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {} {a, b}');
14104 ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a} {a, b}');
14105 ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b} {a, b}');
14106 ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}');
14107 ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}');
14108
14109 note( 'Leaving tests_list_keys_in_2_not_in_1()' ) ;
14110 return ;
14111}
14112
14113sub list_keys_in_2_not_in_1
14114{
14115 my $hash_1_ref = shift;
14116 my $hash_2_ref = shift;
14117 my @list;
14118
14119 foreach my $key ( sort keys %{ $hash_2_ref } ) {
14120 #$sync->{ debug } and print "$key\n" ;
14121 if ( exists $hash_1_ref->{$key} )
14122 {
14123 next ;
14124 }
14125 #$sync->{ debug } and print "list_keys_in_2_not_in_1: $key\n" ;
14126 push @list, $key ;
14127 }
14128 #$sync->{ debug } and print "@list\n" ;
14129 return( @list ) ;
14130}
14131
14132
14133sub list_folders_in_2_not_in_1
14134{
14135
14136 my ( @h2_folders_not_in_h1, %h2_folders_not_in_h1 ) ;
14137 @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all ) ;
14138 map { $h2_folders_not_in_h1{$_} = 1} @h2_folders_not_in_h1 ;
14139 @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_h1 ) ;
14140 #$sync->{ debug } and print "h2_folders_not_in_h1: @h2_folders_not_in_h1\n" ;
14141 return( reverse @h2_folders_not_in_h1 ) ;
14142}
14143
14144sub tests_nb_messages_in_2_not_in_1
14145{
14146 note( 'Entering tests_stats_across_folders()' ) ;
14147 is( undef, nb_messages_in_2_not_in_1( ), 'nb_messages_in_2_not_in_1: no args => undef' ) ;
14148
14149 my $mysync->{ h1_folders_of_md5 }->{ 'some_id_01' }->{ 'some_folder_01' } = 1 ;
14150 is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: no messages in 2 => 0' ) ;
14151
14152 $mysync->{ h1_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_01' } = 2 ;
14153 $mysync->{ h2_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_02' } = 4 ;
14154
14155 is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: a common message => 0' ) ;
14156
14157 $mysync->{ h2_folders_of_md5 }->{ 'some_id_in_2_not_in_1' }->{ 'some_folder_02' } = 1 ;
14158 is( 1, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: one message in_2_not_in_1 => 1' ) ;
14159
14160 $mysync->{ h2_folders_of_md5 }->{ 'some_other_id_in_2_not_in_1' }->{ 'some_folder_02' } = 3 ;
14161 is( 2, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: two messages in_2_not_in_1 => 2' ) ;
14162
14163 note( 'Leaving tests_stats_across_folders()' ) ;
14164 return ;
14165}
14166
14167sub nb_messages_in_2_not_in_1
14168{
14169 my $mysync = shift ;
14170 if ( not defined $mysync ) { return ; }
14171
14172 $mysync->{ nb_messages_in_2_not_in_1 } = scalar(
14173 list_keys_in_2_not_in_1(
14174 $mysync->{ h1_folders_of_md5 },
14175 $mysync->{ h2_folders_of_md5 } ) ) ;
14176
14177 return $mysync->{ nb_messages_in_2_not_in_1 } ;
14178}
14179
14180
14181sub nb_messages_in_1_not_in_2
14182{
14183 my $mysync = shift ;
14184 if ( not defined $mysync ) { return ; }
14185
14186 $mysync->{ nb_messages_in_1_not_in_2 } = scalar(
14187 list_keys_in_2_not_in_1(
14188 $mysync->{ h2_folders_of_md5 },
14189 $mysync->{ h1_folders_of_md5 } ) ) ;
14190
14191 return $mysync->{ nb_messages_in_1_not_in_2 } ;
14192}
14193
14194
14195
14196sub comment_on_final_diff_in_1_not_in_2
14197{
14198 my $mysync = shift ;
14199
14200 if ( not defined $mysync
14201 or $mysync->{ justfolders }
14202 or $mysync->{ useuid }
14203 )
14204 {
14205 return ;
14206 }
14207
14208 my $nb_identified_h1_messages = scalar( keys %{ $mysync->{ h1_folders_of_md5 } } ) ;
14209 my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ;
14210 $mysync->{ debug } and myprint( "nb_keys h1_folders_of_md5 $nb_identified_h1_messages\n" ) ;
14211 $mysync->{ debug } and myprint( "nb_keys h2_folders_of_md5 $nb_identified_h2_messages\n" ) ;
14212
14213 if ( 0 == $nb_identified_h1_messages ) { return ; }
14214
14215 # Calculate if not yet done
14216 if ( not defined $mysync->{ nb_messages_in_1_not_in_2 } )
14217 {
14218 nb_messages_in_1_not_in_2( $mysync ) ;
14219 }
14220
14221
14222 if ( 0 == $mysync->{ nb_messages_in_1_not_in_2 } )
14223 {
14224 myprint( "The sync looks good, all ",
14225 $nb_identified_h1_messages,
14226 " identified messages in host1 are on host2.\n" ) ;
14227 }
14228 else
14229 {
14230 myprint( "The sync is not finished, there are ",
14231 $mysync->{ nb_messages_in_1_not_in_2 },
14232 " identified messages in host1 that are not on host2.\n" ) ;
14233 }
14234
14235
14236 if ( 1 <= $mysync->{ h1_nb_msg_noheader } )
14237 {
14238 myprint( "There are ",
14239 $mysync->{ h1_nb_msg_noheader },
14240 " unidentified messages (usually Sent or Draft messages).",
14241 " To sync them add option --addheader\n" ) ;
14242 }
14243 else
14244 {
14245 myprint( "There is no unidentified message\n" ) ;
14246 }
14247
14248 return ;
14249}
14250
14251sub comment_on_final_diff_in_2_not_in_1
14252{
14253 my $mysync = shift ;
14254
14255 if ( not defined $mysync
14256 or $mysync->{ justfolders }
14257 or $mysync->{ useuid }
14258 )
14259 {
14260 return ;
14261 }
14262
14263 my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ;
14264 # Calculate if not done yet
14265 if ( not defined $mysync->{ nb_messages_in_2_not_in_1 } )
14266 {
14267 nb_messages_in_2_not_in_1( $mysync ) ;
14268 }
14269
14270 if ( 0 == $mysync->{ nb_messages_in_2_not_in_1 } )
14271 {
14272 myprint( "The sync is strict, all ",
14273 $nb_identified_h2_messages,
14274 " identified messages in host2 are on host1.\n" ) ;
14275 }
14276 else
14277 {
14278 myprint( "The sync is not strict, there are ",
14279 $mysync->{ nb_messages_in_2_not_in_1 },
14280 " messages in host2 that are not on host1.",
14281 " Use --delete2 to delete them and have a strict sync.",
14282 " ($nb_identified_h2_messages identified messages in host2)\n" ) ;
14283 }
14284 return ;
14285}
14286
14287
14288sub tests_match
14289{
14290 note( 'Entering tests_match()' ) ;
14291
14292 # undef serie
14293 is( undef, match( ), 'match: no args => undef' ) ;
14294 is( undef, match( 'lalala' ), 'match: one args => undef' ) ;
14295
14296 # This one gives 0 under a binary made by pp
14297 # but 1 under "normal" Perl interpreter. So a PAR bug?
14298 #is( 1, match( q{}, q{} ), 'match: q{} =~ q{} => 1' ) ;
14299
14300 is( 'lalala', match( 'lalala', 'lalala' ), 'match: lalala =~ lalala => lalala' ) ;
14301 is( 'lalala', match( 'lalala', '^lalala' ), 'match: lalala =~ ^lalala => lalala' ) ;
14302 is( 'lalala', match( 'lalala', 'lalala$' ), 'match: lalala =~ lalala$ => lalala' ) ;
14303 is( 'lalala', match( 'lalala', '^lalala$' ), 'match: lalala =~ ^lalala$ => lalala' ) ;
14304 is( '_lalala_', match( '_lalala_', 'lalala' ), 'match: _lalala_ =~ lalala => _lalala_' ) ;
14305 is( 'lalala', match( 'lalala', '.*' ), 'match: lalala =~ .* => lalala' ) ;
14306 is( 'lalala', match( 'lalala', '.' ), 'match: lalala =~ . => lalala' ) ;
14307 is( '/lalala/', match( '/lalala/', '/lalala/' ), 'match: /lalala/ =~ /lalala/ => /lalala/' ) ;
14308
14309 is( 0, match( 'foo', 's/foo/bar/g' ), 'match: foo =~ s/foo/bar/g => 0' ) ;
14310 is( 's/foo/bar/g', match( 's/foo/bar/g', 's/foo/bar/g' ), 'match: s/foo/bar/g =~ s/foo/bar/g => s/foo/bar/g' ) ;
14311
14312
14313 is( 0, match( 'lalala', 'ooo' ), 'match: lalala =~ ooo => 0' ) ;
14314 is( 0, match( 'lalala', 'lal_ala' ), 'match: lalala =~ lal_ala => 0' ) ;
14315 is( 0, match( 'lalala', '\.' ), 'match: lalala =~ \. => 0' ) ;
14316 is( 0, match( 'lalalaX', '^lalala$' ), 'match: lalalaX =~ ^lalala$ => 0' ) ;
14317 is( 0, match( 'lalala', '/lalala/' ), 'match: lalala =~ /lalala/ => 0' ) ;
14318
14319 is( 'LALALA', match( 'LALALA', '(?i:lalala)' ), 'match: LALALA =~ (?i:lalala) => 1' ) ;
14320
14321 is( undef, match( 'LALALA', '(?{`ls /`})' ), 'match: LALALA =~ (?{`ls /`}) => undef' ) ;
14322 is( undef, match( 'LALALA', '(?{print "CACA"})' ), 'match: LALALA =~ (?{print "CACA"}) => undef' ) ;
14323 is( undef, match( 'CACA', '(??{print "CACA"})' ), 'match: CACA =~ (??{print "CACA"}) => undef' ) ;
14324
14325 note( 'Leaving tests_match()' ) ;
14326
14327 return ;
14328}
14329
14330sub match
14331{
14332 my( $var, $regex ) = @ARG ;
14333
14334 # undef cases
14335 if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; }
14336
14337 # normal cases
14338 if ( eval { $var =~ qr{$regex} } ) {
14339 return $var ;
14340 }elsif ( $EVAL_ERROR ) {
14341 myprint( "Fatal regex $regex\n" ) ;
14342 return ;
14343 } else {
14344 return 0 ;
14345 }
14346 return ;
14347}
14348
14349
14350sub tests_notmatch
14351{
14352 note( 'Entering tests_notmatch()' ) ;
14353
14354 # undef serie
14355 is( undef, notmatch( ), 'notmatch: no args => undef' ) ;
14356 is( undef, notmatch( 'lalala' ), 'notmatch: one args => undef' ) ;
14357
14358 is( 1, notmatch( 'lalala', '/lalala/' ), 'notmatch: lalala !~ /lalala/ => 1' ) ;
14359 is( 0, notmatch( '/lalala/', '/lalala/' ), 'notmatch: /lalala/ !~ /lalala/ => 0' ) ;
14360 is( 1, notmatch( 'lalala', '/ooo/' ), 'notmatch: lalala !~ /ooo/ => 1' ) ;
14361
14362 # This one gives 1 under a binary made by pp
14363 # but 0 under "normal" Perl interpreter. So a PAR bug, same in tests_match .
14364 #is( 0, notmatch( q{}, q{} ), 'notmatch: q{} !~ q{} => 0' ) ;
14365
14366 is( 0, notmatch( 'lalala', 'lalala' ), 'notmatch: lalala !~ lalala => 0' ) ;
14367 is( 0, notmatch( 'lalala', '^lalala' ), 'notmatch: lalala !~ ^lalala => 0' ) ;
14368 is( 0, notmatch( 'lalala', 'lalala$' ), 'notmatch: lalala !~ lalala$ => 0' ) ;
14369 is( 0, notmatch( 'lalala', '^lalala$' ), 'notmatch: lalala !~ ^lalala$ => 0' ) ;
14370 is( 0, notmatch( '_lalala_', 'lalala' ), 'notmatch: _lalala_ !~ lalala => 0' ) ;
14371 is( 0, notmatch( 'lalala', '.*' ), 'notmatch: lalala !~ .* => 0' ) ;
14372 is( 0, notmatch( 'lalala', '.' ), 'notmatch: lalala !~ . => 0' ) ;
14373
14374
14375 is( 1, notmatch( 'lalala', 'ooo' ), 'notmatch: does not match regex => 1' ) ;
14376 is( 1, notmatch( 'lalala', 'lal_ala' ), 'notmatch: does not match regex => 1' ) ;
14377 is( 1, notmatch( 'lalala', '\.' ), 'notmatch: matches regex => 0' ) ;
14378 is( 1, notmatch( 'lalalaX', '^lalala$' ), 'notmatch: does not match regex => 1' ) ;
14379
14380 note( 'Leaving tests_notmatch()' ) ;
14381
14382 return ;
14383}
14384
14385sub notmatch
14386{
14387 my( $var, $regex ) = @ARG ;
14388
14389 # undef cases
14390 if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; }
14391
14392 # normal cases
14393 if ( eval { $var !~ $regex } ) {
14394 return 1 ;
14395 }elsif ( $EVAL_ERROR ) {
14396 myprint( "Fatal regex $regex\n" ) ;
14397 return ;
14398 }else{
14399 return 0 ;
14400 }
14401 return ;
14402}
14403
14404
14405sub delete_folders_in_2_not_in_1
14406{
14407
14408 foreach my $folder ( @h2_folders_not_in_1 ) {
14409 if ( defined $delete2foldersonly and eval "\$folder !~ $delete2foldersonly" ) {
14410 myprint( "Not deleting $folder because of --delete2foldersonly $delete2foldersonly\n" ) ;
14411 next ;
14412 }
14413 if ( defined $delete2foldersbutnot and eval "\$folder =~ $delete2foldersbutnot" ) {
14414 myprint( "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n" ) ;
14415 next ;
14416 }
14417 my $res = $sync->{dry} ; # always success in dry mode!
14418 $sync->{imap2}->unsubscribe( $folder ) if ( ! $sync->{dry} ) ;
14419 $res = $sync->{imap2}->delete( $folder ) if ( ! $sync->{dry} ) ;
14420 if ( $res ) {
14421 myprint( "Deleted $folder", "$sync->{dry_message}", "\n" ) ;
14422 }else{
14423 myprint( "Deleting $folder failed", "\n" ) ;
14424 }
14425 }
14426 return ;
14427}
14428
14429sub delete_folder
14430{
14431 my ( $mysync, $imap, $folder, $Side ) = @_ ;
14432 if ( ! $mysync ) { return ; }
14433 if ( ! $imap ) { return ; }
14434 if ( ! $folder ) { return ; }
14435 $Side ||= 'HostX' ;
14436
14437 my $res = $mysync->{dry} ; # always success in dry mode!
14438 if ( ! $mysync->{dry} ) {
14439 $imap->unsubscribe( $folder ) ;
14440 $res = $imap->delete( $folder ) ;
14441 }
14442 if ( $res ) {
14443 myprint( "$Side deleted $folder", $mysync->{dry_message}, "\n" ) ;
14444 return 1 ;
14445 }else{
14446 myprint( "$Side deleting $folder failed", "\n" ) ;
14447 return ;
14448 }
14449}
14450
14451sub delete1emptyfolders
14452{
14453 my $mysync = shift ;
14454 if ( ! $mysync ) { return ; } # abort if no parameter
14455 if ( ! $mysync->{delete1emptyfolders} ) { return ; } # abort if --delete1emptyfolders off
14456 my $imap = $mysync->{imap1} ;
14457 if ( ! $imap ) { return ; } # abort if no imap
14458 if ( $imap->IsUnconnected( ) ) { return ; } # abort if disconnected
14459
14460 my %folders_kept ;
14461 myprint( qq{Host1 deleting empty folders\n} ) ;
14462 foreach my $folder ( reverse sort @{ $mysync->{h1_folders_wanted} } ) {
14463 my $parenthood = $imap->is_parent( $folder ) ;
14464 if ( defined $parenthood and $parenthood ) {
14465 myprint( "Host1: folder $folder has subfolders\n" ) ;
14466 $folders_kept{ $folder }++ ;
14467 next ;
14468 }
14469 my $nb_messages_select = examine_folder_and_count( $mysync, $imap, $folder, 'Host1' ) ;
14470 if ( ! defined $nb_messages_select ) { next ; } # Select failed => Neither continue nor keep this folder }
14471 my $nb_messages_search = scalar( @{ $imap->messages( ) } ) ;
14472 if ( 0 != $nb_messages_select and 0 != $nb_messages_search ) {
14473 myprint( "Host1: folder $folder has messages: $nb_messages_search (search) $nb_messages_select (select)\n" ) ;
14474 $folders_kept{ $folder }++ ;
14475 next ;
14476 }
14477 if ( 0 != $nb_messages_select + $nb_messages_search ) {
14478 myprint( "Host1: folder $folder odd messages count: $nb_messages_search (search) $nb_messages_select (select)\n" ) ;
14479 $folders_kept{ $folder }++ ;
14480 next ;
14481 }
14482 # Here we must have 0 messages by messages() aka "SEARCH ALL" and also "EXAMINE"
14483 if ( uc $folder eq 'INBOX' ) {
14484 myprint( "Host1: Not deleting $folder\n" ) ;
14485 $folders_kept{ $folder }++ ;
14486 next ;
14487 }
14488 myprint( "Host1: deleting empty folder $folder\n" ) ;
14489 # can not delete a SELECTed or EXAMINEd folder so closing it
14490 # could changed be SELECT INBOX
14491 $imap->close( ) ; # close after examine does not expunge; anyway expunging an empty folder...
14492 if ( delete_folder( $mysync, $imap, $folder, 'Host1' ) ) {
14493 next ; # Deleted, good!
14494 }else{
14495 $folders_kept{ $folder }++ ;
14496 next ; # Not deleted, bad!
14497 }
14498 }
14499 remove_deleted_folders_from_wanted_list( $mysync, %folders_kept ) ;
14500 myprint( qq{Host1 ended deleting empty folders\n} ) ;
14501 return ;
14502}
14503
14504sub remove_deleted_folders_from_wanted_list
14505{
14506 my ( $mysync, %folders_kept ) = @ARG ;
14507
14508 my @h1_folders_wanted_init = @{ $mysync->{h1_folders_wanted} } ;
14509 my @h1_folders_wanted_last ;
14510 foreach my $folder ( @h1_folders_wanted_init ) {
14511 if ( $folders_kept{ $folder } ) {
14512 push @h1_folders_wanted_last, $folder ;
14513 }
14514 }
14515 @{ $mysync->{h1_folders_wanted} } = @h1_folders_wanted_last ;
14516 return ;
14517}
14518
14519
14520sub examine_folder_and_count
14521{
14522 my ( $mysync, $imap, $folder, $Side ) = @_ ;
14523 $Side ||= 'HostX' ;
14524
14525 if ( ! examine_folder( $mysync, $imap, $folder, $Side ) ) {
14526 return ;
14527 }
14528 my $nb_messages_select = count_from_select( $imap->History ) ;
14529 return $nb_messages_select ;
14530}
14531
14532
14533sub tests_delete1emptyfolders
14534{
14535 note( 'Entering tests_delete1emptyfolders()' ) ;
14536
14537
14538 is( undef, delete1emptyfolders( ), q{delete1emptyfolders: undef} ) ;
14539 my $syncT ;
14540 is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef 2} ) ;
14541 my $imapT ;
14542 $syncT->{imap1} = $imapT ;
14543 is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef imap} ) ;
14544
14545 require_ok( "Test::MockObject" ) ;
14546 $imapT = Test::MockObject->new( ) ;
14547 $syncT->{imap1} = $imapT ;
14548
14549 $imapT->set_true( 'IsUnconnected' ) ;
14550 is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: Unconnected imap} ) ;
14551
14552 # Now connected tests
14553 $imapT->set_false( 'IsUnconnected' ) ;
14554 $imapT->mock( 'LastError', sub { q{LastError mocked} } ) ;
14555
14556 $syncT->{delete1emptyfolders} = 0 ;
14557 tests_delete1emptyfolders_unit(
14558 $syncT,
14559 [ qw{ INBOX DELME1 DELME2 } ],
14560 [ qw{ INBOX DELME1 DELME2 } ],
14561 q{tests_delete1emptyfolders: --delete1emptyfolders OFF}
14562 ) ;
14563
14564 # All are parents => no deletion at all
14565 $imapT->set_true( 'is_parent' ) ;
14566 $syncT->{delete1emptyfolders} = 1 ;
14567 tests_delete1emptyfolders_unit(
14568 $syncT,
14569 [ qw{ INBOX DELME1 DELME2 } ],
14570 [ qw{ INBOX DELME1 DELME2 } ],
14571 q{tests_delete1emptyfolders: --delete1emptyfolders ON}
14572 ) ;
14573
14574 # No parents but examine false for all => skip all
14575 $imapT->set_false( 'is_parent', 'examine' ) ;
14576
14577 tests_delete1emptyfolders_unit(
14578 $syncT,
14579 [ qw{ INBOX DELME1 DELME2 } ],
14580 [ ],
14581 q{tests_delete1emptyfolders: EXAMINE fails}
14582 ) ;
14583
14584 # examine ok for all but History bad => skip all
14585 $imapT->set_true( 'examine' ) ;
14586 $imapT->mock( 'History', sub { ( q{History badly mocked} ) } ) ;
14587 tests_delete1emptyfolders_unit(
14588 $syncT,
14589 [ qw{ INBOX DELME1 DELME2 } ],
14590 [ ],
14591 q{tests_delete1emptyfolders: examine ok but History badly mocked so count messages fails}
14592 ) ;
14593
14594 # History good but some messages EXISTS == messages() => no deletion
14595 $imapT->mock( 'History', sub { ( q{* 2 EXISTS} ) } ) ;
14596 $imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ;
14597 tests_delete1emptyfolders_unit(
14598 $syncT,
14599 [ qw{ INBOX DELME1 DELME2 } ],
14600 [ qw{ INBOX DELME1 DELME2 } ],
14601 q{tests_delete1emptyfolders: History EXAMINE ok, several messages}
14602 ) ;
14603
14604 # 0 EXISTS but != messages() => no deletion
14605 $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ;
14606 $imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ;
14607 tests_delete1emptyfolders_unit(
14608 $syncT,
14609 [ qw{ INBOX DELME1 DELME2 } ],
14610 [ qw{ INBOX DELME1 DELME2 } ],
14611 q{tests_delete1emptyfolders: 0 EXISTS but 2 by messages()}
14612 ) ;
14613
14614 # 1 EXISTS but != 0 == messages() => no deletion
14615 $imapT->mock( 'History', sub { ( q{* 1 EXISTS} ) } ) ;
14616 $imapT->mock( 'messages', sub { [ ] } ) ;
14617 tests_delete1emptyfolders_unit(
14618 $syncT,
14619 [ qw{ INBOX DELME1 DELME2 } ],
14620 [ qw{ INBOX DELME1 DELME2 } ],
14621 q{tests_delete1emptyfolders: 1 EXISTS but 0 by messages()}
14622 ) ;
14623
14624 # 0 EXISTS and 0 == messages() => deletion except INBOX
14625 $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ;
14626 $imapT->mock( 'messages', sub { [ ] } ) ;
14627 $imapT->set_true( qw{ delete close unsubscribe } ) ;
14628 $syncT->{dry_message} = q{ (not really since in a mocked test)} ;
14629 tests_delete1emptyfolders_unit(
14630 $syncT,
14631 [ qw{ INBOX DELME1 DELME2 } ],
14632 [ qw{ INBOX } ],
14633 q{tests_delete1emptyfolders: 0 EXISTS 0 by messages() delete folders, keep INBOX}
14634 ) ;
14635
14636 note( 'Leaving tests_delete1emptyfolders()' ) ;
14637 return ;
14638}
14639
14640sub tests_delete1emptyfolders_unit
14641{
14642 note( 'Entering tests_delete1emptyfolders_unit()' ) ;
14643
14644 my $syncT = shift ;
14645 my $folders1wanted_init_ref = shift ;
14646 my $folders1wanted_after_ref = shift ;
14647 my $comment = shift || q{delete1emptyfolders:} ;
14648
14649 my @folders1wanted_init = @{ $folders1wanted_init_ref } ;
14650 my @folders1wanted_after = @{ $folders1wanted_after_ref } ;
14651
14652 @{ $syncT->{h1_folders_wanted} } = @folders1wanted_init ;
14653
14654 is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_init, qq{$comment, init check} ) ;
14655 delete1emptyfolders( $syncT ) ;
14656 is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_after, qq{$comment, after check} ) ;
14657
14658 note( 'Leaving tests_delete1emptyfolders_unit()' ) ;
14659 return ;
14660}
14661
14662sub extract_header
14663{
14664 my $string = shift ;
14665
14666 my ( $header ) = split /\n\n/x, $string ;
14667 if ( ! $header ) { return( q{} ) ; }
14668 #myprint( "[$header]\n" ) ;
14669 return( $header ) ;
14670}
14671
14672sub tests_extract_header
14673{
14674 note( 'Entering tests_extract_header()' ) ;
14675
14676my $h = <<'EOM';
14677Message-Id: <20100428101817.A66CB162474E@plume.est.belle>
14678Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
14679From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)
14680EOM
14681chomp $h ;
14682ok( $h eq extract_header(
14683<<'EOM'
14684Message-Id: <20100428101817.A66CB162474E@plume.est.belle>
14685Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
14686From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)
14687
14688body
14689lalala
14690EOM
14691), 'extract_header: 1') ;
14692
14693
14694
14695 note( 'Leaving tests_extract_header()' ) ;
14696 return ;
14697}
14698
14699sub decompose_header{
14700 my $string = shift ;
14701
14702 # a hash, for a keyword header KEY value are list of strings [VAL1, VAL1_other, etc]
14703 # Think of multiple "Received:" header lines.
14704 my $header = { } ;
14705
14706 my ($key, $val ) ;
14707 my @line = split /\n|\r\n/x, $string ;
14708 foreach my $line ( @line ) {
14709 #myprint( "DDD $line\n" ) ;
14710 # End of header
14711 last if ( $line =~ m{^$}xo ) ;
14712 # Key: value
14713 if ( $line =~ m/(^[^:]+):\s(.*)/xo ) {
14714 $key = $1 ;
14715 $val = $2 ;
14716 $debugdev and myprint( "DDD KV [$key] [$val]\n" ) ;
14717 push @{ $header->{ $key } }, $val ;
14718 # blanc and value => value from previous line continues
14719 }elsif( $line =~ m/^(\s+)(.*)/xo ) {
14720 $val = $2 ;
14721 $debugdev and myprint( "DDD V [$val]\n" ) ;
14722 @{ $header->{ $key } }[ $LAST ] .= " $val" if $key ;
14723 # dirty line?
14724 }else{
14725 next ;
14726 }
14727 }
14728
14729 #myprint( Data::Dumper->Dump( [ $header ] ) ) ;
14730
14731 return( $header ) ;
14732}
14733
14734
14735sub tests_decompose_header{
14736 note( 'Entering tests_decompose_header()' ) ;
14737
14738
14739 my $header_dec ;
14740
14741 $header_dec = decompose_header(
14742<<'EOH'
14743KEY_1: VAL_1
14744KEY_2: VAL_2
14745 VAL_2_+
14746 VAL_2_++
14747KEY_3: VAL_3
14748KEY_1: VAL_1_other
14749KEY_4: VAL_4
14750 VAL_4_+
14751KEY_5 BLANC: VAL_5
14752
14753KEY_6_BAD_BODY: VAL_6
14754EOH
14755 ) ;
14756
14757 ok( 'VAL_3'
14758 eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: VAL_3' ) ;
14759
14760 ok( 'VAL_1'
14761 eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: VAL_1' ) ;
14762
14763 ok( 'VAL_1_other'
14764 eq $header_dec->{ 'KEY_1' }[1], 'decompose_header: VAL_1_other' ) ;
14765
14766 ok( 'VAL_2 VAL_2_+ VAL_2_++'
14767 eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: VAL_2 VAL_2_+ VAL_2_++' ) ;
14768
14769 ok( 'VAL_4 VAL_4_+'
14770 eq $header_dec->{ 'KEY_4' }[0], 'decompose_header: VAL_4 VAL_4_+' ) ;
14771
14772 ok( ' VAL_5'
14773 eq $header_dec->{ 'KEY_5 BLANC' }[0], 'decompose_header: KEY_5 BLANC' ) ;
14774
14775 ok( not( defined $header_dec->{ 'KEY_6_BAD_BODY' }[0] ), 'decompose_header: KEY_6_BAD_BODY' ) ;
14776
14777
14778 $header_dec = decompose_header(
14779<<'EOH'
14780Message-Id: <20100428101817.A66CB162474E@plume.est.belle>
14781Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST)
14782From: gilles@louloutte.dyndns.org (Gilles LAMIRAL)
14783EOH
14784 ) ;
14785
14786 ok( '<20100428101817.A66CB162474E@plume.est.belle>'
14787 eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ;
14788
14789 $header_dec = decompose_header(
14790<<'EOH'
14791Return-Path: <gilles@louloutte.dyndns.org>
14792Received: by plume.est.belle (Postfix, from userid 1000)
14793 id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)
14794Subject: test:eekahceishukohpe
14795EOH
14796) ;
14797 ok(
14798'by plume.est.belle (Postfix, from userid 1000) id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)'
14799 eq $header_dec->{ 'Received' }[0], 'decompose_header: 2' ) ;
14800
14801 $header_dec = decompose_header(
14802<<'EOH'
14803Received: from plume (localhost [127.0.0.1])
14804 by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9
14805 for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET)
14806Received: from plume [192.168.68.7]
14807 by plume with POP3 (fetchmail-6.3.6)
14808 for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)
14809EOH
14810 ) ;
14811 ok(
14812 'from plume (localhost [127.0.0.1]) by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET)'
14813 eq $header_dec->{ 'Received' }[0], 'decompose_header: 3' ) ;
14814 ok(
14815 'from plume [192.168.68.7] by plume with POP3 (fetchmail-6.3.6) for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)'
14816 eq $header_dec->{ 'Received' }[1], 'decompose_header: 3' ) ;
14817
14818# Bad header beginning with a blank character
14819 $header_dec = decompose_header(
14820<<'EOH'
14821 KEY_1: VAL_1
14822KEY_2: VAL_2
14823 VAL_2_+
14824 VAL_2_++
14825KEY_3: VAL_3
14826KEY_1: VAL_1_other
14827EOH
14828 ) ;
14829
14830 ok( 'VAL_3'
14831 eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: Bad header VAL_3' ) ;
14832
14833 ok( 'VAL_1_other'
14834 eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: Bad header VAL_1_other' ) ;
14835
14836 ok( 'VAL_2 VAL_2_+ VAL_2_++'
14837 eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: Bad header VAL_2 VAL_2_+ VAL_2_++' ) ;
14838
14839 note( 'Leaving tests_decompose_header()' ) ;
14840 return ;
14841}
14842
14843sub tests_epoch
14844{
14845 note( 'Entering tests_epoch()' ) ;
14846
14847 ok( '1282658400' eq epoch( '24-Aug-2010 16:00:00 +0200' ), 'epoch 24-Aug-2010 16:00:00 +0200 -> 1282658400' ) ;
14848 ok( '1282658400' eq epoch( '24-Aug-2010 14:00:00 +0000' ), 'epoch 24-Aug-2010 14:00:00 +0000 -> 1282658400' ) ;
14849 ok( '1282658400' eq epoch( '24-Aug-2010 12:00:00 -0200' ), 'epoch 24-Aug-2010 12:00:00 -0200 -> 1282658400' ) ;
14850 ok( '1282658400' eq epoch( '24-Aug-2010 16:01:00 +0201' ), 'epoch 24-Aug-2010 16:01:00 +0201 -> 1282658400' ) ;
14851 ok( '1282658400' eq epoch( '24-Aug-2010 14:01:00 +0001' ), 'epoch 24-Aug-2010 14:01:00 +0001 -> 1282658400' ) ;
14852
14853 ok( '1280671200' eq epoch( '1-Aug-2010 16:00:00 +0200' ), 'epoch 1-Aug-2010 16:00:00 +0200 -> 1280671200' ) ;
14854 ok( '1280671200' eq epoch( '1-Aug-2010 14:00:00 +0000' ), 'epoch 1-Aug-2010 14:00:00 +0000 -> 1280671200' ) ;
14855 ok( '1280671200' eq epoch( '1-Aug-2010 12:00:00 -0200' ), 'epoch 1-Aug-2010 12:00:00 -0200 -> 1280671200' ) ;
14856 ok( '1280671200' eq epoch( '1-Aug-2010 16:01:00 +0201' ), 'epoch 1-Aug-2010 16:01:00 +0201 -> 1280671200' ) ;
14857 ok( '1280671200' eq epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ;
14858
14859 is( '1280671200', epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ;
14860 is( '946684800', epoch( '00-Jan-0000 00:00:00 +0000' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ;
14861
14862 note( 'Leaving tests_epoch()' ) ;
14863 return ;
14864}
14865
14866sub epoch
14867{
14868 # incoming format:
14869 # internal date 24-Aug-2010 16:00:00 +0200
14870
14871 # outgoing format: epoch
14872
14873
14874 my $d = shift ;
14875 return(q{}) if not defined $d;
14876
14877 my ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) ;
14878 my $time ;
14879
14880 if ( $d =~ m{(\d{1,2})-([A-Z][a-z]{2})-(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-))(\d{2})(\d{2})}xo ) {
14881 #myprint( "internal: [$1][$2][$3][$4][$5][$6][$7][$8][$9]\n" ) ;
14882 ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )
14883 = ( $1, $2, $3, $4, $5, $6, $7, $8, $9 ) ;
14884 #myprint( "( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )\n" ) ;
14885
14886 $sign = +1 if ( '+' eq $sign ) ;
14887 $sign = $MINUS_ONE if ( '-' eq $sign ) ;
14888
14889 if ( 0 == $mday ) {
14890 myprint( "buggy day in $d. Fixed to 01\n" ) ;
14891 $mday = '01' ;
14892 }
14893 $time = timegm( $sec, $min, $hour, $mday, $month_abrev{$month}, $year )
14894 - $sign * ( 3600 * $zone_h + 60 * $zone_m ) ;
14895
14896 #myprint( "$time ", scalar localtime($time), "\n");
14897 }
14898 return( $time ) ;
14899}
14900
14901sub tests_add_header
14902{
14903 note( 'Entering tests_add_header()' ) ;
14904
14905 ok( 'Message-Id: <mistake@imapsync>' eq add_header(), 'add_header no arg' ) ;
14906 ok( 'Message-Id: <123456789@imapsync>' eq add_header( '123456789' ), 'add_header 123456789' ) ;
14907
14908 note( 'Leaving tests_add_header()' ) ;
14909 return ;
14910}
14911
14912sub add_header
14913{
14914 my $header_uid = shift || 'mistake' ;
14915 my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ;
14916 return( $header_Message_Id ) ;
14917}
14918
14919
14920
14921
14922sub tests_max_line_length
14923{
14924 note( 'Entering tests_max_line_length()' ) ;
14925
14926 ok( 0 == max_line_length( q{} ), 'max_line_length: 0 == null string' ) ;
14927 ok( 1 == max_line_length( "\n" ), 'max_line_length: 1 == \n' ) ;
14928 ok( 1 == max_line_length( "\n\n" ), 'max_line_length: 1 == \n\n' ) ;
14929 ok( 1 == max_line_length( "\n" x 500 ), 'max_line_length: 1 == 500 \n' ) ;
14930 ok( 1 == max_line_length( 'a' ), 'max_line_length: 1 == a' ) ;
14931 ok( 2 == max_line_length( "a\na" ), 'max_line_length: 2 == a\na' ) ;
14932 ok( 2 == max_line_length( "a\na\n" ), 'max_line_length: 2 == a\na\n' ) ;
14933 ok( 3 == max_line_length( "a\nab\n" ), 'max_line_length: 3 == a\nab\n' ) ;
14934 ok( 3 == max_line_length( "a\nab\n" x 1_000 ), 'max_line_length: 3 == 1_000 a\nab\n' ) ;
14935 ok( 3 == max_line_length( "a\nab\nabc" ), 'max_line_length: 3 == a\nab\nabc' ) ;
14936
14937 ok( 4 == max_line_length( "a\nab\nabc\n" ), 'max_line_length: 4 == a\nab\nabc\n' ) ;
14938 ok( 5 == max_line_length( "a\nabcd\nabc\n" ), 'max_line_length: 5 == a\nabcd\nabc\n' ) ;
14939 ok( 5 == max_line_length( "a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd" ), 'max_line_length: 5 == a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd' ) ;
14940
14941 note( 'Leaving tests_max_line_length()' ) ;
14942 return ;
14943}
14944
14945sub max_line_length
14946{
14947 my $string = shift ;
14948 my $max = 0 ;
14949
14950 while ( $string =~ m/([^\n]*\n?)/msxg ) {
14951 $max = max( $max, length $1 ) ;
14952 }
14953 return( $max ) ;
14954}
14955
14956
14957sub tests_setlogfile
14958{
14959 note( 'Entering tests_setlogfile()' ) ;
14960
14961 my $mysync = {} ;
14962 $mysync->{logdir} = 'vallogdir' ;
14963 $mysync->{logfile} = 'vallogfile.txt' ;
14964 is( 'vallogdir/vallogfile.txt', setlogfile( $mysync ),
14965 'setlogfile: logdir vallogdir, logfile vallogfile.txt, vallogdir/vallogfile.txt' ) ;
14966
14967 SKIP: {
14968 skip( 'Too hard to have a well known timezone on Windows', 9 ) if ( 'MSWin32' eq $OSNAME ) ;
14969
14970 local $ENV{TZ} = 'GMT' ;
14971
14972 $mysync = {
14973 timestart => 2,
14974 } ;
14975
14976 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000__.txt", setlogfile( $mysync ),
14977 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000__.txt" ) ;
14978
14979 $mysync = {
14980 timestart => 2,
14981 user1 => 'user1',
14982 user2 => 'user2',
14983 abort => 1,
14984 } ;
14985
14986 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_abort.txt", setlogfile( $mysync ),
14987 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_abort.txt" ) ;
14988
14989 $mysync = {
14990 timestart => 2,
14991 user1 => 'user1',
14992 user2 => 'user2',
14993 remote => 'zzz',
14994 } ;
14995
14996 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote.txt", setlogfile( $mysync ),
14997 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote.txt" ) ;
14998
14999 $mysync = {
15000 timestart => 2,
15001 user1 => 'user1',
15002 user2 => 'user2',
15003 remote => 'zzz',
15004 abort => 1,
15005 } ;
15006
15007 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote_abort.txt", setlogfile( $mysync ),
15008 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote_abort.txt" ) ;
15009
15010
15011 $mysync = {
15012 timestart => 2,
15013 user1 => 'user1',
15014 user2 => 'user2',
15015 } ;
15016
15017 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt", setlogfile( $mysync ),
15018 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt" ) ;
15019
15020 $mysync->{logdir} = undef ;
15021 $mysync->{logfile} = undef ;
15022 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt", setlogfile( $mysync ),
15023 "setlogfile: logdir undef, $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt" ) ;
15024
15025 $mysync->{logdir} = q{} ;
15026 $mysync->{logfile} = undef ;
15027 is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ),
15028 'setlogfile: logdir empty, 1970_01_01_00_00_02_000_user1_user2.txt' ) ;
15029
15030 $mysync->{logdir} = 'vallogdir' ;
15031 $mysync->{logfile} = undef ;
15032 is( 'vallogdir/1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ),
15033 'setlogfile: logdir vallogdir, vallogdir/1970_01_01_00_00_02_000_user1_user2.txt' ) ;
15034
15035 $mysync = {
15036 user1 => 'us/er1a*|?:"<>b',
15037 user2 => 'u/ser2a*|?:"<>b',
15038 } ;
15039
15040 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt", setlogfile( $mysync ),
15041 "setlogfile: logdir undef, $DEFAULT_LOGDIR/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt" ) ;
15042
15043
15044
15045 } ;
15046
15047 note( 'Leaving tests_setlogfile()' ) ;
15048 return ;
15049}
15050
15051sub setlogfile
15052{
15053 my( $mysync ) = shift ;
15054
15055 # When aborting another process the log file name finishes with "_abort.txt"
15056 my $abort_suffix = ( $mysync->{abort} ) ? '_abort' : q{} ;
15057 # When acting as a proxy the log file name finishes with "_remote.txt"
15058 # proxy mode is not done yet
15059 my $remote_suffix = ( $mysync->{remote} ) ? '_remote' : q{} ;
15060
15061 my $suffix = (
15062 filter_forbidden_characters( slash_to_underscore( $mysync->{user1} ) ) || q{} )
15063 . '_'
15064 . ( filter_forbidden_characters( slash_to_underscore( $mysync->{user2} ) ) || q{} )
15065 . $remote_suffix . $abort_suffix ;
15066
15067 $mysync->{logdir} = defined $mysync->{logdir} ? $mysync->{logdir} : $DEFAULT_LOGDIR ;
15068
15069 $mysync->{logfile} = defined $mysync->{logfile}
15070 ? "$mysync->{logdir}/$mysync->{logfile}"
15071 : logfile( $mysync->{timestart}, $suffix, $mysync->{logdir} ) ;
15072
15073 return( $mysync->{logfile} ) ;
15074}
15075
15076sub tests_logfile
15077{
15078 note( 'Entering tests_logfile()' ) ;
15079
15080 SKIP: {
15081 # Too hard to have a well known timezone on Windows
15082 skip( 'Too hard to have a well known timezone on Windows', 10 ) if ( 'MSWin32' eq $OSNAME ) ;
15083
15084 local $ENV{TZ} = 'GMT' ;
15085 { POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
15086 is( '1970_01_01_00_00_00_000.txt', logfile( ), 'logfile: no args => 1970_01_01_00_00_00.txt' ) ;
15087 is( '1970_01_01_00_00_00_000.txt', logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00.txt' ) ;
15088 is( '1970_01_01_00_01_01_000.txt', logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ;
15089 is( '1970_01_01_00_01_01_234.txt', logfile( 61.234 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ;
15090 is( '2010_08_24_14_00_00_000.txt', logfile( 1_282_658_400 ), 'logfile: 1_282_658_400 => 2010_08_24_14_00_00.txt' ) ;
15091 is( '2010_08_24_14_01_01_000.txt', logfile( 1_282_658_461 ), 'logfile: 1_282_658_461 => 2010_08_24_14_01_01.txt' ) ;
15092 is( '2010_08_24_14_01_01_000_poupinette.txt', logfile( 1_282_658_461, 'poupinette' ), 'logfile: 1_282_658_461 poupinette => 2010_08_24_14_01_01_poupinette.txt' ) ;
15093 is( '2010_08_24_14_01_01_000_removeblanks.txt', logfile( 1_282_658_461, ' remove blanks ' ), 'logfile: 1_282_658_461 remove blanks => 2010_08_24_14_01_01_000_removeblanks' ) ;
15094
15095 is( '2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup' ),
15096 'logfile: 1_282_658_461.2347 poup => 2010_08_24_14_01_01_234_poup.txt' ) ;
15097
15098 is( 'dirdir/2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup', 'dirdir' ),
15099 'logfile: 1_282_658_461.2347 poup dirdir => dirdir/2010_08_24_14_01_01_234_poup.txt' ) ;
15100
15101
15102
15103 }
15104 POSIX::tzset unless ('MSWin32' eq $OSNAME) ;
15105 } ;
15106
15107 note( 'Leaving tests_logfile()' ) ;
15108 return ;
15109}
15110
15111
15112sub logfile
15113{
15114 my ( $time, $suffix, $dir ) = @_ ;
15115
15116 $time ||= 0 ;
15117 $suffix ||= q{} ;
15118 $suffix =~ tr/ //ds ;
15119 my $sep_suffix = ( $suffix ) ? '_' : q{} ;
15120 $dir ||= q{} ;
15121 my $sep_dir = ( $dir ) ? '/' : q{} ;
15122
15123 my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ;
15124 # Because of ab tests or web accesses, more than one sync withing one second is possible
15125 # so we add also milliseconds
15126 $date_str .= sprintf "_%03d", ($time - int( $time ) ) * 1000 ; # without rounding
15127 my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ;
15128 return( $logfile ) ;
15129}
15130
15131
15132
15133sub tests_slash_to_underscore
15134{
15135 note( 'Entering tests_slash_to_underscore()' ) ;
15136
15137 is( undef, slash_to_underscore( ), 'slash_to_underscore: no parameters => undef' ) ;
15138 is( '_', slash_to_underscore( '/' ), 'slash_to_underscore: / => _' ) ;
15139 is( '_abc_def_', slash_to_underscore( '/abc/def/' ), 'slash_to_underscore: /abc/def/ => _abc_def_' ) ;
15140 note( 'Leaving tests_slash_to_underscore()' ) ;
15141 return ;
15142}
15143
15144sub slash_to_underscore
15145{
15146 my $string = shift ;
15147
15148 if ( ! defined $string ) { return ; }
15149
15150 $string =~ tr{/}{_} ;
15151
15152 return( $string ) ;
15153}
15154
15155
15156
15157
15158sub tests_million_folders_baby_2
15159{
15160 note( 'Entering tests_million_folders_baby_2()' ) ;
15161
15162 my %long ;
15163 @long{ 1 .. 900_000 } = (1) x 900_000 ;
15164 #myprint( %long, "\n" ) ;
15165 my $pasglop = 0 ;
15166 foreach my $elem ( 1 .. 900_000 ) {
15167 #$debug and myprint( "$elem " ) ;
15168 if ( not exists $long{ $elem } ) {
15169 $pasglop++ ;
15170 }
15171 }
15172 ok( 0 == $pasglop, 'tests_million_folders_baby_2: search among 900_000' ) ;
15173 # myprint( "$pasglop\n" ) ;
15174
15175 note( 'Leaving tests_million_folders_baby_2()' ) ;
15176 return ;
15177}
15178
15179
15180
15181sub tests_always_fail
15182{
15183 note( 'Entering tests_always_fail()' ) ;
15184
15185 is( 0, 1, 'always_fail: 0 is 1' ) ;
15186
15187 note( 'Leaving tests_always_fail()' ) ;
15188 return ;
15189}
15190
15191
15192sub tests_logfileprepa
15193{
15194 note( 'Entering tests_logfileprepa()' ) ;
15195
15196 is( undef, logfileprepa( ), 'logfileprepa: no args => undef' ) ;
15197 my $logfile = 'W/tmp/tests/tests_logfileprepa.txt' ;
15198 is( 1, logfileprepa( $logfile ), 'logfileprepa: W/tmp/tests/tests_logfileprepa.txt => 1' ) ;
15199
15200 note( 'Leaving tests_logfileprepa()' ) ;
15201 return ;
15202}
15203
15204sub logfileprepa
15205{
15206 my $logfile = shift ;
15207
15208 if ( ! defined( $logfile ) )
15209 {
15210 return ;
15211 }else
15212 {
15213 #myprint( "[$logfile]\n" ) ;
15214 my $dirname = dirname( $logfile ) ;
15215 do_valid_directory( $dirname ) || return( 0 ) ;
15216 return( 1 ) ;
15217 }
15218}
15219
15220
15221sub tests_teelaunch
15222{
15223 note( 'Entering tests_teelaunch()' ) ;
15224
15225 is( undef, teelaunch( ), 'teelaunch: no args => undef' ) ;
15226 my $mysync = {} ;
15227 is( undef, teelaunch( $mysync ), 'teelaunch: arg empty {} => undef' ) ;
15228 $mysync->{logfile} = q{} ;
15229 is( undef, teelaunch( $mysync ), 'teelaunch: logfile empty string => undef' ) ;
15230 $mysync->{logfile} = 'W/tmp/tests/tests_teelaunch.txt' ;
15231 isa_ok( my $tee = teelaunch( $mysync ), 'IO::Tee' , 'teelaunch: logfile W/tmp/tests/tests_teelaunch.txt' ) ;
15232 is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ;
15233 is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\n' ) ;
15234 is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ;
15235 is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\nHoo\n' ) ;
15236
15237 note( 'Leaving tests_teelaunch()' ) ;
15238 return ;
15239}
15240
15241sub teelaunch
15242{
15243 my $mysync = shift ;
15244
15245 if ( ! defined( $mysync ) )
15246 {
15247 return ;
15248 }
15249
15250 my $logfile = $mysync->{logfile} ;
15251
15252 if ( ! $logfile )
15253 {
15254 return ;
15255 }
15256
15257 logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $OS_ERROR" ;
15258
15259 # This is a log file opened during the whole sync
15260 ## no critic (InputOutput::RequireBriefOpen)
15261 open my $logfile_handle, '>', $logfile
15262 or croak( "Can not open $logfile for write: $OS_ERROR" ) ;
15263 binmode $logfile_handle, ":encoding(UTF-8)" ;
15264 my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ;
15265 $tee->autoflush( 1 ) ;
15266 $mysync->{logfile_handle} = $logfile_handle ;
15267 $mysync->{tee} = $tee ;
15268 return $tee ;
15269}
15270
15271sub getpwuid_any_os
15272{
15273 my $uid = shift ;
15274
15275 return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system
15276 return( scalar getpwuid $uid ) ; # Unix system
15277
15278
15279}
15280
15281sub simulong
15282{
15283 my $max_seconds = shift ;
15284 my $division = 5 ;
15285 my $last_count = $division * $max_seconds ;
15286 foreach my $i ( 1 .. ( $last_count ) ) {
15287 myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" ) ;
15288 #myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" . ( "Ah" x 40 . "\n") x 4000 ) ;
15289 sleep( 1 / $division ) ;
15290 }
15291
15292 return ;
15293}
15294
15295
15296
15297sub printenv
15298{
15299 myprint( "Environment variables listing:\n",
15300 ( map { "$_ => $ENV{$_}\n" } sort keys %ENV),
15301 "Environment variables listing end\n" ) ;
15302 return ;
15303}
15304
15305sub testsexit
15306{
15307 my $mysync = shift ;
15308 if ( ! ( $mysync->{ tests } or $mysync->{ testsdebug } or $mysync->{ testsunit } ) ) {
15309 return ;
15310 }
15311 my $test_builder = Test::More->builder ;
15312 tests( $mysync ) ;
15313 testsdebug( $mysync ) ;
15314 testunitsession( $mysync ) ;
15315
15316 my @summary = $test_builder->summary() ;
15317 my @details = $test_builder->details() ;
15318 my $nb_tests_run = scalar( @summary ) ;
15319 my $nb_tests_expected = $test_builder->expected_tests() ;
15320 my $nb_tests_failed = count_0s( @summary ) ;
15321 my $tests_failed = report_failures( @details ) ;
15322 if ( $nb_tests_failed or ( $nb_tests_run != $nb_tests_expected ) ) {
15323 #$test_builder->reset( ) ;
15324 myprint( "Summary of tests: failed $nb_tests_failed tests, run $nb_tests_run tests, expected to run $nb_tests_expected tests.\n",
15325 "List of failed tests:\n", $tests_failed ) ;
15326 exit $EXIT_TESTS_FAILED ;
15327 }
15328
15329 cleanup_mess_from_tests( ) ;
15330 # Cover is larger with --tests --testslive
15331 if ( ! $mysync->{ testslive } )
15332 {
15333 exit ;
15334 }
15335 return ;
15336}
15337
15338sub cleanup_mess_from_tests
15339{
15340 undef @pipemess ;
15341 return ;
15342}
15343
15344sub after_get_options
15345{
15346 my $mysync = shift ;
15347 my $numopt = shift ;
15348
15349
15350 # exit with --help option or no option at all
15351 $mysync->{ debug } and myprint( "numopt:$numopt\n" ) ;
15352
15353 if ( $help or not $numopt ) {
15354 myprint( usage( $mysync ) ) ;
15355 exit ;
15356 }
15357
15358 return ;
15359}
15360
15361sub tests_remove_edging_blanks
15362{
15363 note( 'Entering tests_remove_edging_blanks()' ) ;
15364
15365 is( undef, remove_edging_blanks( ), 'remove_edging_blanks: no args => undef' ) ;
15366 is( 'abcd', remove_edging_blanks( 'abcd' ), 'remove_edging_blanks: abcd => abcd' ) ;
15367 is( 'ab cd', remove_edging_blanks( ' ab cd ' ), 'remove_edging_blanks: " ab cd " => "ab cd"' ) ;
15368
15369 note( 'Leaving tests_remove_edging_blanks()' ) ;
15370 return ;
15371}
15372
15373
15374
15375sub remove_edging_blanks
15376{
15377 my $string = shift ;
15378 if ( ! defined $string )
15379 {
15380 return ;
15381 }
15382 $string =~ s,^ +| +$,,g ;
15383 return $string ;
15384}
15385
15386
15387sub tests_sanitize
15388{
15389 note( 'Entering tests_remove_edging_blanks()' ) ;
15390
15391 is( undef, sanitize( ), 'sanitize: no args => undef' ) ;
15392 my $mysync = {} ;
15393
15394 $mysync->{ host1 } = ' example.com ' ;
15395 $mysync->{ user1 } = ' to to ' ;
15396 $mysync->{ password1 } = ' sex is good! ' ;
15397 is( undef, sanitize( $mysync ), 'sanitize: => undef' ) ;
15398 is( 'example.com', $mysync->{ host1 }, 'sanitize: host1 " example.com " => "example.com"' ) ;
15399 is( 'to to', $mysync->{ user1 }, 'sanitize: user1 " to to " => "to to"' ) ;
15400 is( 'sex is good!', $mysync->{ password1 }, 'sanitize: password1 " sex is good! " => "sex is good!"' ) ;
15401 note( 'Leaving tests_remove_edging_blanks()' ) ;
15402 return ;
15403}
15404
15405
15406sub sanitize
15407{
15408 my $mysync = shift ;
15409 if ( ! defined $mysync )
15410 {
15411 return ;
15412 }
15413
15414 foreach my $parameter ( qw( host1 host2 user1 user2 password1 password2 ) )
15415 {
15416 $mysync->{ $parameter } = remove_edging_blanks( $mysync->{ $parameter } ) ;
15417 }
15418 return ;
15419}
15420
15421sub easyany
15422{
15423 my $mysync = shift ;
15424
15425 # Gmail
15426 if ( $mysync->{gmail1} and $mysync->{gmail2} ) {
15427 $mysync->{ debug } and myprint( "gmail1 gmail2\n") ;
15428 gmail12( $mysync ) ;
15429 return ;
15430 }
15431 if ( $mysync->{gmail1} ) {
15432 $mysync->{ debug } and myprint( "gmail1\n" ) ;
15433 gmail1( $mysync ) ;
15434 }
15435 if ( $mysync->{gmail2} ) {
15436 $mysync->{ debug } and myprint( "gmail2\n" ) ;
15437 gmail2( $mysync ) ;
15438 }
15439 # Office 365
15440 if ( $mysync->{office1} ) {
15441 office1( $mysync ) ;
15442 }
15443
15444 if ( $mysync->{office2} ) {
15445 office2( $mysync ) ;
15446 }
15447
15448 # Exchange
15449 if ( $mysync->{exchange1} ) {
15450 exchange1( $mysync ) ;
15451 }
15452
15453 if ( $mysync->{exchange2} ) {
15454 exchange2( $mysync ) ;
15455 }
15456
15457
15458 # Domino
15459 if ( $mysync->{domino1} ) {
15460 domino1( $mysync ) ;
15461 }
15462
15463 if ( $mysync->{domino2} ) {
15464 domino2( $mysync ) ;
15465 }
15466
15467 return ;
15468}
15469
15470# From and for https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt
15471sub gmail12
15472{
15473 my $mysync = shift ;
15474 # Gmail at host1 and host2
15475 $mysync->{host1} ||= 'imap.gmail.com' ;
15476 $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ;
15477 $mysync->{host2} ||= 'imap.gmail.com' ;
15478 $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ;
15479 $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 when computed from Gmail documentation
15480 $mysync->{maxbytesafter} ||= 1_000_000_000 ;
15481 $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ;
15482 $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ;
15483 $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 0 ;
15484 $mysync->{ synclabels } = ( defined $mysync->{ synclabels } ) ? $mysync->{ synclabels } : 1 ;
15485 $mysync->{ resynclabels } = ( defined $mysync->{ resynclabels } ) ? $mysync->{ resynclabels } : 1 ;
15486 push @exclude, '\[Gmail\]$' ;
15487 push @folderlast, '[Gmail]/All Mail' ;
15488 return ;
15489}
15490
15491
15492sub gmail1
15493{
15494 my $mysync = shift ;
15495 # Gmail at host2
15496 $mysync->{host1} ||= 'imap.gmail.com' ;
15497 $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ;
15498 $mysync->{maxbytespersecond} ||= 40_000 ; # should be 20_000 computed from by Gmail documentation
15499 $mysync->{maxbytesafter} ||= 2_500_000_000 ;
15500 $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ;
15501 $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ;
15502 $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ;
15503
15504 push @useheader, 'X-Gmail-Received', 'Message-Id' ;
15505 push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ;
15506 push @folderlast, '[Gmail]/All Mail' ;
15507 return ;
15508}
15509
15510sub gmail2
15511{
15512 my $mysync = shift ;
15513 # Gmail at host2
15514 $mysync->{host2} ||= 'imap.gmail.com' ;
15515 $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ;
15516 $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 computed from by Gmail documentation
15517 $mysync->{maxbytesafter} ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000
15518
15519 $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ;
15520 #$skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ;
15521 $mysync->{ expunge1 } = ( defined $mysync->{ expunge1 } ) ? $mysync->{ expunge1 } : 1 ;
15522 $mysync->{addheader} = ( defined $mysync->{addheader} ) ? $mysync->{addheader} : 1 ;
15523 $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ;
15524
15525 $mysync->{maxsize} = ( defined $mysync->{maxsize} ) ? $mysync->{maxsize} : $GMAIL_MAXSIZE ;
15526
15527 if ( ! $mysync->{noexclude} ) {
15528 push @exclude, '\[Gmail\]$' ;
15529 }
15530 push @useheader, 'Message-Id' ;
15531 push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ;
15532
15533 # push @{ $mysync->{ regextrans2 } }, 's/[ ]+/_/g' ; # is now replaced
15534 # by the two more specific following regexes,
15535 # they remove just the beginning and trailing blanks, not all.
15536 push @{ $mysync->{ regextrans2 } }, 's,^ +| +$,,g' ;
15537 push @{ $mysync->{ regextrans2 } }, 's,/ +| +/,/,g' ;
15538 #
15539 push @{ $mysync->{ regextrans2 } }, q{s/['\\^"]/_/g} ; # Verified this
15540 push @folderlast, '[Gmail]/All Mail' ;
15541 return ;
15542}
15543
15544
15545# From https://imapsync.lamiral.info/FAQ.d/FAQ.Exchange.txt
15546sub office1
15547{
15548 # Office 365 at host1
15549 my $mysync = shift ;
15550
15551 output( $mysync, q{Option --office1 is like: --host1 outlook.office365.com --ssl1 --exclude "^Files$"} . "\n" ) ;
15552 output( $mysync, "Option --office1 (cont) : unless overrided with --host1 otherhost --nossl1 --noexclude\n" ) ;
15553 $mysync->{host1} ||= 'outlook.office365.com' ;
15554 $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ;
15555 if ( ! $mysync->{noexclude} ) {
15556 push @exclude, '^Files$' ;
15557 }
15558 return ;
15559}
15560
15561
15562sub office2
15563{
15564 # Office 365 at host2
15565 my $mysync = shift ;
15566 output( $mysync, qq{Option --office2 is like: --host2 outlook.office365.com --ssl2 --maxsize 45_000_000 --maxmessagespersecond 4\n} ) ;
15567 output( $mysync, qq{Option --office2 (cont) : --disarmreadreceipts --regexmess "wrap 10500" --f1f2 "Files=Files_renamed_by_imapsync"\n} ) ;
15568 output( $mysync, qq{Option --office2 (cont) : unless overrided with --host2 otherhost --nossl2 ... --nodisarmreadreceipts --noregexmess\n} ) ;
15569 output( $mysync, qq{Option --office2 (cont) : and --nof1f2 to avoid Files folder renamed to Files_renamed_by_imapsync\n} ) ;
15570 $mysync->{host2} ||= 'outlook.office365.com' ;
15571 $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ;
15572 $mysync->{ maxsize } ||= 45_000_000 ;
15573 $mysync->{maxmessagespersecond} ||= 4 ;
15574 #push @regexflag, 's/\\\\Flagged//g' ; # No problem without! tested 2018_09_10
15575 $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ;
15576 # I dislike double negation but here is one
15577 if ( ! $mysync->{noregexmess} )
15578 {
15579 push @regexmess, 's,(.{10239}),$1\r\n,g' ;
15580 }
15581 # and another...
15582 if ( ! $mysync->{nof1f2} )
15583 {
15584 push @{ $mysync->{f1f2} }, 'Files=Files_renamed_by_imapsync' ;
15585 }
15586 return ;
15587}
15588
15589sub exchange1
15590{
15591 # Exchange 2010/2013 at host1
15592 my $mysync = shift ;
15593 output( $mysync, "Option --exchange1 does nothing (except printing this line...)\n" ) ;
15594 # Well nothing to do so far
15595 return ;
15596}
15597
15598sub exchange2
15599{
15600 # Exchange 2010/2013 at host2
15601 my $mysync = shift ;
15602 output( $mysync, "Option --exchange2 is like: --maxsize 10_000_000 --maxmessagespersecond 4 --disarmreadreceipts\n" ) ;
15603 output( $mysync, "Option --exchange2 (cont) : --regexflag del Flagged --regexmess wrap 10500\n" ) ;
15604 output( $mysync, "Option --exchange2 (cont) : unless overrided with --maxsize xxx --nodisarmreadreceipts --noregexflag --noregexmess\n" ) ;
15605 $mysync->{ maxsize } ||= 10_000_000 ;
15606 $mysync->{maxmessagespersecond} ||= 4 ;
15607 $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ;
15608 # I dislike double negation but here are two
15609 if ( ! $mysync->{noregexflag} ) {
15610 push @regexflag, 's/\\\\Flagged//g' ;
15611 }
15612 if ( ! $mysync->{noregexmess} ) {
15613 push @regexmess, 's,(.{10239}),$1\r\n,g' ;
15614 }
15615 return ;
15616}
15617
15618sub domino1
15619{
15620 # Domino at host1
15621 my $mysync = shift ;
15622
15623 $mysync->{ sep1 } = q{\\} ;
15624 $prefix1 = q{} ;
15625 $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ;
15626 return ;
15627}
15628
15629sub domino2
15630{
15631 # Domino at host1
15632 my $mysync = shift ;
15633
15634 $mysync->{ sep2 } = q{\\} ;
15635 $prefix2 = q{} ;
15636 $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ;
15637 push @{ $mysync->{ regextrans2 } }, 's,^Inbox\\\\(.*),$1,i' ;
15638 return ;
15639}
15640
15641
15642sub tests_resolv
15643{
15644 note( 'Entering tests_resolv()' ) ;
15645
15646 # is( , resolv( ), 'resolv: => ' ) ;
15647 is( undef, resolv( ), 'resolv: no args => undef' ) ;
15648 is( undef, resolv( q{} ), 'resolv: empty string => undef' ) ;
15649 is( undef, resolv( 'hostnotexist' ), 'resolv: hostnotexist => undef' ) ;
15650 is( '127.0.0.1', resolv( '127.0.0.1' ), 'resolv: 127.0.0.1 => 127.0.0.1' ) ;
15651 is( '127.0.0.1', resolv( 'localhost' ), 'resolv: localhost => 127.0.0.1' ) ;
15652 is( '5.135.158.182', resolv( 'imapsync.lamiral.info' ), 'resolv: imapsync.lamiral.info => 5.135.158.182' ) ;
15653
15654 # ip6-localhost ( in /etc/hosts )
15655 is( '::1', resolv( 'ip6-localhost' ), 'resolv: ip6-localhost => ::1' ) ;
15656 is( '::1', resolv( '::1' ), 'resolv: ::1 => ::1' ) ;
15657 # ks2
15658 is( '2001:41d0:8:d8b6::1', resolv( '2001:41d0:8:d8b6::1' ), 'resolv: 2001:41d0:8:d8b6::1 => 2001:41d0:8:d8b6::1' ) ;
15659 is( '2001:41d0:8:d8b6::1', resolv( 'ks2ipv6.lamiral.info' ), 'resolv: ks2ipv6.lamiral.info => 2001:41d0:8:d8b6::1' ) ;
15660 # ks3
15661 is( '2001:41d0:8:bebd::1', resolv( '2001:41d0:8:bebd::1' ), 'resolv: 2001:41d0:8:bebd::1 => 2001:41d0:8:bebd::1' ) ;
15662 is( '2001:41d0:8:bebd::1', resolv( 'ks3ipv6.lamiral.info' ), 'resolv: ks3ipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ;
15663
15664
15665 note( 'Leaving tests_resolv()' ) ;
15666 return ;
15667}
15668
15669
15670
15671sub resolv
15672{
15673 my $host = shift @ARG ;
15674
15675 if ( ! $host ) { return ; }
15676 my $addr ;
15677 if ( defined &Socket::getaddrinfo ) {
15678 $addr = resolv_with_getaddrinfo( $host ) ;
15679 return( $addr ) ;
15680 }
15681
15682
15683
15684 my $iaddr = inet_aton( $host ) ;
15685 if ( ! $iaddr ) { return ; }
15686 $addr = inet_ntoa( $iaddr ) ;
15687
15688 return $addr ;
15689}
15690
15691sub resolv_with_getaddrinfo
15692{
15693 my $host = shift @ARG ;
15694
15695 if ( ! $host ) { return ; }
15696
15697 my ( $err_getaddrinfo, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ;
15698 if ( $err_getaddrinfo ) {
15699 myprint( "Cannot getaddrinfo of $host: $err_getaddrinfo\n" ) ;
15700 return ;
15701 }
15702
15703 my @addr ;
15704 while( my $ai = shift @res ) {
15705 my ( $err_getnameinfo, $ipaddr ) = Socket::getnameinfo( $ai->{addr}, Socket::NI_NUMERICHOST(), Socket::NIx_NOSERV() ) ;
15706 if ( $err_getnameinfo ) {
15707 myprint( "Cannot getnameinfo of $host: $err_getnameinfo\n" ) ;
15708 return ;
15709 }
15710 $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ;
15711 push @addr, $ipaddr ;
15712 my $reverse ;
15713 ( $err_getnameinfo, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ;
15714 $sync->{ debug } and myprint( "$host => $ipaddr => $reverse\n" ) ;
15715 }
15716
15717 return $addr[0] ;
15718}
15719
15720sub tests_resolvrev
15721{
15722 note( 'Entering tests_resolvrev()' ) ;
15723
15724 # is( , resolvrev( ), 'resolvrev: => ' ) ;
15725 is( undef, resolvrev( ), 'resolvrev: no args => undef' ) ;
15726 is( undef, resolvrev( q{} ), 'resolvrev: empty string => undef' ) ;
15727 is( undef, resolvrev( 'hostnotexist' ), 'resolvrev: hostnotexist => undef' ) ;
15728 is( 'localhost', resolvrev( '127.0.0.1' ), 'resolvrev: 127.0.0.1 => localhost' ) ;
15729 is( 'localhost', resolvrev( 'localhost' ), 'resolvrev: localhost => localhost' ) ;
15730 is( 'ks.lamiral.info', resolvrev( 'imapsync.lamiral.info' ), 'resolvrev: imapsync.lamiral.info => ks.lamiral.info' ) ;
15731
15732 # ip6-localhost ( in /etc/hosts )
15733 is( 'ip6-localhost', resolvrev( 'ip6-localhost' ), 'resolvrev: ip6-localhost => ip6-localhost' ) ;
15734 is( 'ip6-localhost', resolvrev( '::1' ), 'resolvrev: ::1 => ip6-localhost' ) ;
15735 # ks2
15736 is( 'ks2ipv6.lamiral.info', resolvrev( '2001:41d0:8:d8b6::1' ), 'resolvrev: 2001:41d0:8:d8b6::1 => ks2ipv6.lamiral.info' ) ;
15737 is( 'ks2ipv6.lamiral.info', resolvrev( 'ks2ipv6.lamiral.info' ), 'resolvrev: ks2ipv6.lamiral.info => ks2ipv6.lamiral.info' ) ;
15738 # ks3
15739 is( 'ks3ipv6.lamiral.info', resolvrev( '2001:41d0:8:bebd::1' ), 'resolvrev: 2001:41d0:8:bebd::1 => ks3ipv6.lamiral.info' ) ;
15740 is( 'ks3ipv6.lamiral.info', resolvrev( 'ks3ipv6.lamiral.info' ), 'resolvrev: ks3ipv6.lamiral.info => ks3ipv6.lamiral.info' ) ;
15741
15742
15743 note( 'Leaving tests_resolvrev()' ) ;
15744 return ;
15745}
15746
15747sub resolvrev
15748{
15749 my $host = shift @ARG ;
15750
15751 if ( ! $host ) { return ; }
15752
15753 if ( defined &Socket::getaddrinfo ) {
15754 my $name = resolvrev_with_getaddrinfo( $host ) ;
15755 return( $name ) ;
15756 }
15757
15758 return ;
15759}
15760
15761sub resolvrev_with_getaddrinfo
15762{
15763 my $host = shift @ARG ;
15764
15765 if ( ! $host ) { return ; }
15766
15767 my ( $err, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ;
15768 if ( $err ) {
15769 myprint( "Cannot getaddrinfo of $host: $err\n" ) ;
15770 return ;
15771 }
15772
15773 my @name ;
15774 while( my $ai = shift @res ) {
15775 my ( $err, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ;
15776 if ( $err ) {
15777 myprint( "Cannot getnameinfo of $host: $err\n" ) ;
15778 return ;
15779 }
15780 $sync->{ debug } and myprint( "$host => $reverse\n" ) ;
15781 push @name, $reverse ;
15782 }
15783
15784 return $name[0] ;
15785}
15786
15787
15788
15789sub tests_imapsping
15790{
15791 note( 'Entering tests_imapsping()' ) ;
15792
15793 is( undef, imapsping( ), 'imapsping: no args => undef' ) ;
15794 is( undef, imapsping( 'hostnotexist' ), 'imapsping: hostnotexist => undef' ) ;
15795 is( 1, imapsping( 'imapsync.lamiral.info' ), 'imapsping: imapsync.lamiral.info => 1' ) ;
15796 is( 1, imapsping( 'ks2ipv6.lamiral.info' ), 'imapsping: ks2ipv6.lamiral.info => 1' ) ;
15797 note( 'Leaving tests_imapsping()' ) ;
15798 return ;
15799}
15800
15801sub imapsping
15802{
15803 my $host = shift ;
15804 return tcpping( $host, $IMAP_SSL_PORT ) ;
15805}
15806
15807sub tests_tcpping
15808{
15809 note( 'Entering tests_tcpping()' ) ;
15810
15811 is( undef, tcpping( ), 'tcpping: no args => undef' ) ;
15812 is( undef, tcpping( 'hostnotexist' ), 'tcpping: one arg => undef' ) ;
15813 is( undef, tcpping( undef, 888 ), 'tcpping: arg undef, port => undef' ) ;
15814 is( undef, tcpping( 'hostnotexist', 993 ), 'tcpping: hostnotexist 993 => undef' ) ;
15815 is( undef, tcpping( 'hostnotexist', 888 ), 'tcpping: hostnotexist 888 => undef' ) ;
15816 is( 1, tcpping( 'imapsync.lamiral.info', 993 ), 'tcpping: imapsync.lamiral.info 993 => 1' ) ;
15817 is( 0, tcpping( 'imapsync.lamiral.info', 888 ), 'tcpping: imapsync.lamiral.info 888 => 0' ) ;
15818 is( 1, tcpping( '5.135.158.182', 993 ), 'tcpping: 5.135.158.182 993 => 1' ) ;
15819 is( 0, tcpping( '5.135.158.182', 888 ), 'tcpping: 5.135.158.182 888 => 0' ) ;
15820
15821 # Net::Ping supports ipv6 only after release 1.50
15822 # http://cpansearch.perl.org/src/RURBAN/Net-Ping-2.59/Changes
15823 # Anyway I plan to avoid Net-Ping for that too long standing feature
15824 # Net-Ping is integrated in Perl itself, who knows ipv6 for a long time
15825 is( 1, tcpping( '2001:41d0:8:d8b6::1', 993 ), 'tcpping: 2001:41d0:8:d8b6::1 993 => 1' ) ;
15826 is( 0, tcpping( '2001:41d0:8:d8b6::1', 888 ), 'tcpping: 2001:41d0:8:d8b6::1 888 => 0' ) ;
15827
15828 note( 'Leaving tests_tcpping()' ) ;
15829 return ;
15830}
15831
15832sub tcpping
15833{
15834 if ( 2 != scalar( @ARG ) ) {
15835 return ;
15836 }
15837 my ( $host, $port ) = @ARG ;
15838 if ( ! $host ) { return ; }
15839 if ( ! $port ) { return ; }
15840
15841 my $mytimeout = $TCP_PING_TIMEOUT ;
15842 require Net::Ping ;
15843 #my $p = Net::Ping->new( 'tcp' ) ;
15844 my $p = Net::Ping->new( ) ;
15845 $p->{port_num} = $port ;
15846 $p->service_check( 1 ) ;
15847 $p->hires( 1 ) ;
15848 my ($ping_ok, $rtt, $ip ) = $p->ping( $host, $mytimeout ) ;
15849 if ( ! defined $ping_ok ) { return ; }
15850 my $rtt_approx = sprintf( "%.3f", $rtt ) ;
15851 $sync->{ debug } and myprint( "Host $host timeout $mytimeout port $port ok $ping_ok ip $ip acked in $rtt_approx s\n" ) ;
15852 $p->close( ) ;
15853 if( $ping_ok ) {
15854 return 1 ;
15855 }else{
15856 return 0 ;
15857 }
15858}
15859
15860sub tests_sslcheck
15861{
15862 note( 'Entering tests_sslcheck()' ) ;
15863
15864 my $mysync ;
15865
15866 is( undef, sslcheck( $mysync ), 'sslcheck: no sslcheck => undef' ) ;
15867
15868 $mysync = {
15869 sslcheck => 1,
15870 } ;
15871
15872 is( 0, sslcheck( $mysync ), 'sslcheck: no host => 0' ) ;
15873
15874 $mysync = {
15875 sslcheck => 1,
15876 host1 => 'imapsync.lamiral.info',
15877 tls1 => 1,
15878 } ;
15879
15880 is( 0, sslcheck( $mysync ), 'sslcheck: tls1 => 0' ) ;
15881
15882 $mysync = {
15883 sslcheck => 1,
15884 host1 => 'imapsync.lamiral.info',
15885 } ;
15886
15887
15888 is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info => 1' ) ;
15889 is( 1, $mysync->{ssl1}, 'sslcheck: imapsync.lamiral.info => ssl1 1' ) ;
15890
15891 $mysync->{sslcheck} = 0 ;
15892 is( undef, sslcheck( $mysync ), 'sslcheck: sslcheck off => undef' ) ;
15893
15894 $mysync = {
15895 sslcheck => 1,
15896 host1 => 'imapsync.lamiral.info',
15897 host2 => 'test2.lamiral.info',
15898 } ;
15899
15900 is( 2, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info + test2.lamiral.info => 2' ) ;
15901
15902 $mysync = {
15903 sslcheck => 1,
15904 host1 => 'imapsync.lamiral.info',
15905 host2 => 'test2.lamiral.info',
15906 tls1 => 1,
15907 } ;
15908
15909 is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info + test2.lamiral.info + tls1 => 1' ) ;
15910
15911 note( 'Leaving tests_sslcheck()' ) ;
15912 return ;
15913}
15914
15915sub sslcheck
15916{
15917 my $mysync = shift ;
15918
15919 if ( ! $mysync->{sslcheck} ) {
15920 return ;
15921 }
15922 my $nb_on = 0 ;
15923 $mysync->{ debug } and myprint( "sslcheck\n" ) ;
15924 if (
15925 ( ! defined $mysync->{port1} )
15926 and
15927 ( ! defined $mysync->{tls1} )
15928 and
15929 ( ! defined $mysync->{ssl1} )
15930 and
15931 ( defined $mysync->{host1} )
15932 ) {
15933 myprint( "Host1: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ;
15934 if ( probe_imapssl( $mysync->{host1} ) ) {
15935 $mysync->{ssl1} = 1 ;
15936 myprint( "Host1: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl1 --notls1 to turn off SSL and TLS wizardry)\n" ) ;
15937 $nb_on++ ;
15938 }else{
15939 myprint( "Host1: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ;
15940 }
15941 }
15942
15943 if (
15944 ( ! defined $mysync->{port2} )
15945 and
15946 ( ! defined $mysync->{tls2} )
15947 and
15948 ( ! defined $mysync->{ssl2} )
15949 and
15950 ( defined $mysync->{host2} )
15951 ) {
15952 myprint( "Host2: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ;
15953 if ( probe_imapssl( $mysync->{host2} ) ) {
15954 $mysync->{ssl2} = 1 ;
15955 myprint( "Host2: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl2 --notls2 to turn off SSL and TLS wizardry)\n" ) ;
15956 $nb_on++ ;
15957 }else{
15958 myprint( "Host2: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ;
15959 }
15960 }
15961 return $nb_on ;
15962}
15963
15964
15965sub testslive_init
15966{
15967 my $mysync = shift ;
15968 $mysync->{host1} ||= 'test1.lamiral.info' ;
15969 $mysync->{user1} ||= 'test1' ;
15970 $mysync->{password1} ||= 'secret1' ;
15971 $mysync->{host2} ||= 'test2.lamiral.info' ;
15972 $mysync->{user2} ||= 'test2' ;
15973 $mysync->{password2} ||= 'secret2' ;
15974 return ;
15975}
15976
15977sub testslive6_init
15978{
15979 my $mysync = shift ;
15980 $mysync->{host1} ||= 'ks2ipv6.lamiral.info' ;
15981 $mysync->{user1} ||= 'test1' ;
15982 $mysync->{password1} ||= 'secret1' ;
15983 $mysync->{host2} ||= 'ks2ipv6.lamiral.info' ;
15984 $mysync->{user2} ||= 'test2' ;
15985 $mysync->{password2} ||= 'secret2' ;
15986 return ;
15987}
15988
15989
15990sub tests_backslash_caret
15991{
15992 note( 'Entering tests_backslash_caret()' ) ;
15993
15994 is( "lalala", backslash_caret( "lalala" ), 'backslash_caret: lalala => lalala' ) ;
15995 is( "lalala\n", backslash_caret( "lalala\n" ), 'backslash_caret: lalala => lalala 2nd' ) ;
15996 is( '^', backslash_caret( '\\' ), 'backslash_caret: \\ => ^' ) ;
15997 is( "^\n", backslash_caret( "\\\n" ), 'backslash_caret: \\ => ^' ) ;
15998 is( "\\lalala", backslash_caret( "\\lalala" ), 'backslash_caret: \\lalala => \\lalala' ) ;
15999 is( "\\lal\\ala", backslash_caret( "\\lal\\ala" ), 'backslash_caret: \\lal\\ala => \\lal\\ala' ) ;
16000 is( "\\lalala\n", backslash_caret( "\\lalala\n" ), 'backslash_caret: \\lalala => \\lalala 2nd' ) ;
16001 is( "lalala^\n", backslash_caret( "lalala\\\n" ), 'backslash_caret: lalala\\\n => lalala^\n' ) ;
16002 is( "lalala^\nlalala^\n", backslash_caret( "lalala\\\nlalala\\\n" ), 'backslash_caret: lalala\\\nlalala\\\n => lalala^\nlalala^\n' ) ;
16003 is( "lal\\ala^\nlalala^\n", backslash_caret( "lal\\ala\\\nlalala\\\n" ), 'backslash_caret: lal\\ala\\\nlalala\\\n => lal\\ala^\nlalala^\n' ) ;
16004
16005 note( 'Leaving tests_backslash_caret()' ) ;
16006 return ;
16007}
16008
16009sub backslash_caret
16010{
16011 my $string = shift ;
16012
16013 $string =~ s{\\ $ }{^}gxms ;
16014
16015 return $string ;
16016}
16017
16018sub tests_split_around_equal
16019{
16020 note( 'Entering tests_split_around_equal()' ) ;
16021
16022 is( undef, split_around_equal( ), 'split_around_equal: no args => undef' ) ;
16023 is_deeply( { toto => 'titi' }, { split_around_equal( 'toto=titi' ) }, 'split_around_equal: toto=titi => toto => titi' ) ;
16024 is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B=C=D' ) }, 'split_around_equal: toto=titi => toto => titi' ) ;
16025 is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B', 'C=D' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ;
16026
16027 note( 'Leaving tests_split_around_equal()' ) ;
16028 return ;
16029}
16030
16031sub split_around_equal
16032{
16033 if ( ! @ARG ) { return ; } ;
16034 return map { split /=/mxs, $_ } @ARG ;
16035
16036}
16037
16038
16039
16040sub tests_sig_install
16041{
16042 note( 'Entering tests_sig_install()' ) ;
16043
16044 my $mysync ;
16045 is( undef, sig_install( ), 'sig_install: no args => undef' ) ;
16046 is( undef, sig_install( $mysync ), 'sig_install: arg undef => undef' ) ;
16047 $mysync = { } ;
16048 is( undef, sig_install( $mysync ), 'sig_install: empty hash => undef' ) ;
16049
16050 SKIP: {
16051 Readonly my $SKIP_15 => 15 ;
16052 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_15 ) ; }
16053 # Default to ignore USR1 USR2 in case future install fails
16054 local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ;
16055 kill( 'USR1', $PROCESS_ID ) ;
16056
16057 $mysync->{ debugsig } = 1 ;
16058 # Assign USR1 to call sub tototo
16059 # Surely a better value than undef should be returned when doing real signal stuff
16060 is( undef, sig_install( $mysync, 'tototo', 'USR1' ), 'sig_install: USR1 tototo' ) ;
16061
16062 is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 1' ) ;
16063 is( 1, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 1' ) ;
16064
16065 #return ;
16066 # Assign USR2 to call sub tototo
16067 is( undef, sig_install( $mysync, 'tototo', 'USR2' ), 'sig_install: USR2 tototo' ) ;
16068
16069 is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR2 myself 1' ) ;
16070 is( 2, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 2' ) ;
16071
16072 is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ;
16073 is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 3' ) ;
16074
16075
16076 local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ;
16077 is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 3' ) ;
16078 is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call still nb 3' ) ;
16079
16080 # Assign USR1 + USR2 to call sub tototo
16081 is( undef, sig_install( $mysync, 'tototo', 'USR1', 'USR2' ), 'sig_install: USR1 USR2 tototo' ) ;
16082 is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 4' ) ;
16083 is( 4, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 4' ) ;
16084
16085 is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ;
16086 is( 5, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 5' ) ;
16087 }
16088
16089
16090 note( 'Leaving tests_sig_install()' ) ;
16091 return ;
16092}
16093
16094
16095#
16096sub sig_install
16097{
16098 my $mysync = shift ;
16099 if ( ! $mysync ) { return ; }
16100 my $mysubname = shift ;
16101 if ( ! $mysubname ) { return ; }
16102
16103 if ( ! @ARG ) { return ; }
16104
16105 my @signals = @ARG ;
16106
16107 my $mysub = \&$mysubname ;
16108 #$mysync->{ debugsig } = 1 ;
16109 $mysync->{ debugsig } and myprint( "In sig_install with sub $mysubname and signal @ARG\n" ) ;
16110
16111 my $subsignal = sub {
16112 my $signame = shift ;
16113 $mysync->{ debugsig } and myprint( "In subsignal with $signame and $mysubname\n" ) ;
16114 &$mysub( $mysync, $signame ) ;
16115 } ;
16116
16117 foreach my $signal ( @signals ) {
16118 $mysync->{ debugsig } and myprint( "Installing signal $signal to call sub $mysubname\n") ;
16119 output( $mysync, "kill -$signal $PROCESS_ID # special behavior: call to sub $mysubname\n" ) ;
16120 ## no critic (RequireLocalizedPunctuationVars)
16121 $SIG{ $signal } = $subsignal ;
16122 }
16123 return ;
16124}
16125
16126
16127sub tototo
16128{
16129 my $mysync = shift ;
16130 myprint("In tototo with @ARG\n" ) ;
16131 $mysync->{ tototo_calls } += 1 ;
16132 return ;
16133}
16134
16135sub mygetppid
16136{
16137 if ( 'MSWin32' eq $OSNAME ) {
16138 return( 'unknown under MSWin32 (too complicated)' ) ;
16139 } else {
16140 # Unix
16141 return( getppid( ) ) ;
16142 }
16143}
16144
16145
16146
16147sub tests_toggle_sleep
16148{
16149 note( 'Entering tests_toggle_sleep()' ) ;
16150
16151 is( undef, toggle_sleep( ), 'toggle_sleep: no args => undef' ) ;
16152 my $mysync ;
16153 is( undef, toggle_sleep( $mysync ), 'toggle_sleep: undef => undef' ) ;
16154 $mysync = { } ;
16155 is( undef, toggle_sleep( $mysync ), 'toggle_sleep: no maxsleep => undef' ) ;
16156
16157 $mysync->{maxsleep} = 3 ;
16158 is( 0, toggle_sleep( $mysync ), 'toggle_sleep: 3 => 0' ) ;
16159
16160 is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ;
16161 is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ;
16162 is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ;
16163 is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ;
16164
16165 SKIP: {
16166 Readonly my $SKIP_9 => 9 ;
16167 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_9 ) ; }
16168 # Default to ignore USR1 USR2 in case future install fails
16169 local $SIG{ USR1 } = sub { } ;
16170 kill( 'USR1', $PROCESS_ID ) ;
16171
16172 $mysync->{ debugsig } = 1 ;
16173 # Assign USR1 to call sub toggle_sleep
16174 is( undef, sig_install( $mysync, \&toggle_sleep, 'USR1' ), 'toggle_sleep: install USR1 toggle_sleep' ) ;
16175
16176
16177 $mysync->{maxsleep} = 4 ;
16178 is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ;
16179 is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ;
16180
16181 is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ;
16182 is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ;
16183
16184 is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ;
16185 is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ;
16186
16187 is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ;
16188 is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ;
16189 }
16190
16191 note( 'Leaving tests_toggle_sleep()' ) ;
16192 return ;
16193}
16194
16195
16196sub toggle_sleep
16197{
16198 my $mysync = shift ;
16199
16200 myprint("In toggle_sleep with @ARG\n" ) ;
16201
16202 if ( !defined( $mysync ) ) { return ; }
16203 if ( !defined( $mysync->{maxsleep} ) ) { return ; }
16204
16205 $mysync->{ maxsleep } = max( 0, $MAX_SLEEP - $mysync->{maxsleep} ) ;
16206 myprint("Resetting maxsleep to ", $mysync->{maxsleep}, "s\n" ) ;
16207 return $mysync->{maxsleep} ;
16208}
16209
16210sub mypod2usage
16211{
16212 my $fh_pod2usage = shift ;
16213
16214 pod2usage(
16215 -exitval => 'NOEXIT',
16216 -noperldoc => 1,
16217 -verbose => 99,
16218 -sections => [ qw(NAME VERSION USAGE OPTIONS) ],
16219 -indent => 1,
16220 -loose => 1,
16221 -output => $fh_pod2usage,
16222 ) ;
16223
16224 return ;
16225}
16226
16227sub usage
16228{
16229 my $mysync = shift ;
16230
16231 if ( ! defined $mysync ) { return ; }
16232
16233 my $usage = q{} ;
16234 my $usage_from_pod ;
16235 my $usage_footer = usage_footer( $mysync ) ;
16236
16237 # pod2usage writes on a filehandle only and I want a variable
16238 open my $fh_pod2usage, ">", \$usage_from_pod
16239 or do { warn $OS_ERROR ; return ; } ;
16240 mypod2usage( $fh_pod2usage ) ;
16241 close $fh_pod2usage ;
16242
16243 if ( 'MSWin32' eq $OSNAME ) {
16244 $usage_from_pod = backslash_caret( $usage_from_pod ) ;
16245 }
16246 $usage = join( q{}, $usage_from_pod, $usage_footer ) ;
16247
16248 return( $usage ) ;
16249}
16250
16251sub tests_usage
16252{
16253 note( 'Entering tests_usage()' ) ;
16254
16255 my $usage ;
16256 like( $usage = usage( $sync ), qr/Name:/, 'usage: contains Name:' ) ;
16257 myprint( $usage ) ;
16258 like( $usage, qr/Version:/, 'usage: contains Version:' ) ;
16259 like( $usage, qr/Usage:/, 'usage: contains Usage:' ) ;
16260 like( $usage, qr/imapsync/, 'usage: contains imapsync' ) ;
16261
16262 is( undef, usage( ), 'usage: no args => undef' ) ;
16263
16264 note( 'Leaving tests_usage()' ) ;
16265 return ;
16266}
16267
16268
16269sub usage_footer
16270{
16271 my $mysync = shift ;
16272
16273 my $footer = q{} ;
16274
16275 my $localhost_info = localhost_info( $mysync ) ;
16276 my $rcs = $mysync->{rcs} ;
16277 my $homepage = homepage( ) ;
16278
16279 my $imapsync_release = $STR_use_releasecheck ;
16280
16281 if ( $mysync->{releasecheck} ) {
16282 $imapsync_release = check_last_release( ) ;
16283 }
16284
16285 $footer = qq{$localhost_info
16286$rcs
16287$imapsync_release
16288$homepage
16289} ;
16290 return( $footer ) ;
16291}
16292
16293
16294
16295sub usage_complete
16296{
16297 # Unused, I guess this function could be deleted
16298 my $usage = <<'EOF' ;
16299--skipheader reg : Don't take into account header keyword
16300 matching reg ex: --skipheader 'X.*'
16301
16302--skipsize : Don't take message size into account to compare
16303 messages on both sides. On by default.
16304 Use --no-skipsize for using size comparaison.
16305--allowsizemismatch : allow RFC822.SIZE != fetched msg size
16306 consider also --skipsize to avoid duplicate messages
16307 when running syncs more than one time per mailbox
16308
16309--reconnectretry1 int : reconnect to host1 if connection is lost up to
16310 int times per imap command (default is 3)
16311--reconnectretry2 int : same as --reconnectretry1 but for host2
16312--split1 int : split the requests in several parts on host1.
16313 int is the number of messages handled per request.
16314 default is like --split1 100.
16315--split2 int : same thing on host2.
16316--nofixInboxINBOX : Don't fix Inbox INBOX mapping.
16317EOF
16318 return( $usage ) ;
16319}
16320
16321sub myGetOptions
16322{
16323
16324 # Started as a copy of Luke Ross Getopt::Long::CGI
16325 # https://metacpan.org/release/Getopt-Long-CGI
16326 # So this sub function is under the same license as Getopt-Long-CGI Luke Ross wants it,
16327 # which was Perl 5.6 or later licenses at the date of the copy.
16328
16329 my $mysync = shift @ARG ;
16330 my $arguments_ref = shift @ARG ;
16331 my %options = @ARG ;
16332
16333 my $mycgi = $mysync->{cgi} ;
16334
16335 if ( not under_cgi_context() ) {
16336
16337 # Not CGI - pass upstream for normal command line handling
16338 return Getopt::Long::GetOptionsFromArray( $arguments_ref, %options ) ;
16339 }
16340
16341 # We must be in CGI context now
16342 if ( ! defined( $mycgi ) ) { return ; }
16343
16344 my $badthings = 0 ;
16345 foreach my $key ( sort keys %options ) {
16346 my $val = $options{$key} ;
16347
16348 if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) {
16349 $badthings++ ;
16350 next ; # Unknown item
16351 }
16352
16353 my $name = [ split '|', $1, 1 ]->[0] ;
16354
16355 if ( ( $3 || q{} ) eq '+' ) {
16356 ${$val} = $mycgi->param( $name ) ; # "Incremental" integer
16357 }
16358 elsif ( $2 ) {
16359 my @values = $mycgi->multi_param( $name ) ;
16360 my $type = $2 ;
16361
16362 #myprint( "type[$type]values[@values]\$3[", $3 || q{}, "]val[$val]ref(val)[", ref($val), "]\n" ) ;
16363 if ( ( $3 || q{} ) eq '%' or ref( $val ) eq 'HASH' ) {
16364 my %values = map { split /=/mxs, $_ } @values ;
16365
16366 if ( $type =~ m/i$/mxs ) {
16367 foreach my $k ( keys %values ) {
16368 $values{$k} = int $values{$k} ;
16369 }
16370 }
16371 elsif ( $type =~ m/f$/mxs ) {
16372 foreach my $k ( keys %values ) {
16373 $values{$k} = 0 + $values{$k};
16374 }
16375 }
16376 if ( 'REF' eq ref $val ) {
16377 %{ ${$val} } = %values ;
16378 }
16379 else {
16380 %{$val} = %values ;
16381 }
16382 }
16383 else {
16384 if ( $type =~ m/i$/mxs ) {
16385 @values = map { q{} ne $_ ? int $_ : undef } @values ;
16386 }
16387 elsif ( $type =~ m/f$/mxs ) {
16388 @values = map { 0 + $_ } @values ;
16389 }
16390 if ( ( $3 || q{} ) eq '@' ) {
16391 @{ ${$val} } = @values ;
16392 my @option = map { +( "--$name", "$_" ) } @values ;
16393 push @{ $mysync->{ cmdcgi } }, @option ;
16394 }
16395 elsif ( ref( $val ) eq 'ARRAY' ) {
16396 @{$val} = @values ;
16397 }
16398 elsif ( my $value = $values[0] )
16399 {
16400 ${$val} = $value ;
16401 push @{ $mysync->{ cmdcgi } }, "--$name", $value ;
16402 }
16403 else
16404 {
16405
16406 }
16407 }
16408 }
16409 else
16410 {
16411 # Checkbox
16412 # Considers only --name
16413 # Should consider also --no-name and --noname
16414 my $value = $mycgi->param( $name ) ;
16415 if ( $value )
16416 {
16417 ${$val} = 1 ;
16418 push @{ $mysync->{ cmdcgi } }, "--$name" ;
16419 }
16420 else
16421 {
16422 ${$val} = undef ;
16423 }
16424 }
16425 }
16426 if ( $badthings ) {
16427 return ; # undef or ()
16428 }
16429 else {
16430 return ( 1 ) ;
16431 }
16432}
16433
16434
16435my @blabla ; # just used to check get_options_cgi() with an array
16436
16437sub tests_get_options_cgi_context
16438{
16439 note( 'Entering tests_get_options_cgi()' ) ;
16440
16441# Temporary, have to think harder about testing CGI context in command line --tests
16442 # API:
16443 # * input arguments: two ways, command line or CGI
16444 # * the program arguments
16445 # * QUERY_STRING env variable
16446 # * return
16447 # * QUERY_STRING length
16448
16449 # CGI context
16450 local $ENV{SERVER_SOFTWARE} = 'Votre serviteur' ;
16451
16452 # Real full test
16453 # = 'host1=test1.lamiral.info&user1=test1&password1=secret1&host2=test2.lamiral.info&user2=test2&password2=secret2&debugenv=on'
16454 my $mysync ;
16455 is( undef, get_options( $mysync ), 'get_options cgi context: no CGI module => undef' ) ;
16456
16457 require CGI ;
16458 CGI->import( qw( -no_debug -utf8 ) ) ;
16459
16460 is( undef, get_options( $mysync ), 'get_options cgi context: no CGI param => undef' ) ;
16461 # Testing boolean
16462 $mysync->{cgi} = CGI->new( 'version=on&debugenv=on' ) ;
16463 local $ENV{'QUERY_STRING'} = 'version=on&debugenv=on' ;
16464 is( 22, get_options( $mysync ), 'get_options cgi context: QUERY_STRING => 22' ) ;
16465 is( 1, $mysync->{ version }, 'get_options cgi context: --version => 1' ) ;
16466 # debugenv is not allowed in cgi context
16467 is( undef, $mysync->{debugenv}, 'get_options cgi context: $mysync->{debugenv} => undef' ) ;
16468
16469 # QUERY_STRING in this test is only for return value of get_options
16470 # Have to think harder, GET/POST context, is this return value a good thing?
16471 local $ENV{'QUERY_STRING'} = 'host1=test1.lamiral.info&user1=test1' ;
16472 $mysync->{cgi} = CGI->new( 'host1=test1.lamiral.info&user1=test1' ) ;
16473 is( 36, get_options( $mysync, ), 'get_options cgi context: QUERY_STRING => 36' ) ;
16474 is( 'test1', $mysync->{user1}, 'get_options cgi context: $mysync->{user1} => test1' ) ;
16475 #local $ENV{'QUERY_STRING'} = undef ;
16476
16477 # Testing @
16478 $mysync->{cgi} = CGI->new( 'blabla=fd1' ) ;
16479 get_options( $mysync ) ;
16480 is_deeply( [ 'fd1' ], [ @blabla ], 'get_options cgi context: @blabla => fd1' ) ;
16481 $mysync->{cgi} = CGI->new( 'blabla=fd1&blabla=fd2' ) ;
16482 get_options( $mysync ) ;
16483 is_deeply( [ 'fd1', 'fd2' ], [ @blabla ], 'get_options cgi context: @blabla => fd1, fd2' ) ;
16484
16485 # Testing s@ as ref
16486 $mysync->{cgi} = CGI->new( 'folder=fd1' ) ;
16487 get_options( $mysync ) ;
16488 is_deeply( [ 'fd1' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1' ) ;
16489 $mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ;
16490 get_options( $mysync ) ;
16491 is_deeply( [ 'fd1', 'fd2' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1, fd2' ) ;
16492
16493 # Testing %
16494 $mysync->{cgi} = CGI->new( 'f1f2h=s1=d1&f1f2h=s2=d2&f1f2h=s3=d3' ) ;
16495 get_options( $mysync ) ;
16496
16497 is_deeply( { 's1' => 'd1', 's2' => 'd2', 's3' => 'd3' },
16498 $mysync->{f1f2h}, 'get_options cgi context: f1f2h => s1=d1 s2=d2 s3=d3' ) ;
16499
16500 # Testing boolean ! with --noxxx, doesnot work
16501 $mysync->{cgi} = CGI->new( 'nodry=on' ) ;
16502 get_options( $mysync ) ;
16503 is( undef, $mysync->{dry}, 'get_options cgi context: --nodry => $mysync->{dry} => undef' ) ;
16504
16505 $mysync->{cgi} = CGI->new( 'host1=example.com' ) ;
16506 get_options( $mysync ) ;
16507 is( 'example.com', $mysync->{host1}, 'get_options cgi context: --host1=example.com => $mysync->{host1} => example.com' ) ;
16508
16509 #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
16510 $mysync->{cgi} = CGI->new( 'simulong=' ) ;
16511 get_options( $mysync ) ;
16512 is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong= => $mysync->{simulong} => undef' ) ;
16513
16514 $mysync->{cgi} = CGI->new( 'simulong' ) ;
16515 get_options( $mysync ) ;
16516 is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong => $mysync->{simulong} => undef' ) ;
16517
16518 $mysync->{cgi} = CGI->new( 'simulong=4' ) ;
16519 get_options( $mysync ) ;
16520 is( 4, $mysync->{simulong}, 'get_options cgi context: --simulong=4 => $mysync->{simulong} => 4' ) ;
16521 is( undef, $mysync->{ folder }, 'get_options cgi context: --simulong=4 => $mysync->{ folder } => undef' ) ;
16522 #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
16523
16524 $mysync ={} ;
16525 $mysync->{cgi} = CGI->new( 'justfoldersizes=on' ) ;
16526 get_options( $mysync ) ;
16527 is( 1, $mysync->{ justfoldersizes }, 'get_options cgi context: --justfoldersizes=1 => justfoldersizes => 1' ) ;
16528 myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
16529
16530 note( 'Leaving tests_get_options_cgi_context()' ) ;
16531 return ;
16532}
16533
16534
16535
16536sub get_options_cgi
16537{
16538 # In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET).
16539 my $mysync = shift @ARG ;
16540 $mysync->{cgi} || return ;
16541 my @arguments = @ARG ;
16542 # final 0 is used to print usage when no option is given
16543 my $numopt = length $ENV{'QUERY_STRING'} || 1 ;
16544 $mysync->{f1f2h} = {} ;
16545 my $opt_ret = myGetOptions(
16546 $mysync,
16547 \@arguments,
16548 'abort' => \$mysync->{abort},
16549 'host1=s' => \$mysync->{ host1 },
16550 'host2=s' => \$mysync->{ host2 },
16551 'user1=s' => \$mysync->{ user1 },
16552 'user2=s' => \$mysync->{ user2 },
16553 'password1=s' => \$mysync->{password1},
16554 'password2=s' => \$mysync->{password2},
16555 'dry!' => \$mysync->{dry},
16556 'version' => \$mysync->{version},
16557 'ssl1!' => \$mysync->{ssl1},
16558 'ssl2!' => \$mysync->{ssl2},
16559 'tls1!' => \$mysync->{tls1},
16560 'tls2!' => \$mysync->{tls2},
16561 'justlogin!' => \$mysync->{justlogin},
16562 'justconnect!' => \$mysync->{justconnect},
16563 'addheader!' => \$mysync->{addheader},
16564 'automap!' => \$mysync->{automap},
16565 'justautomap!' => \$mysync->{justautomap},
16566 'gmail1' => \$mysync->{gmail1},
16567 'gmail2' => \$mysync->{gmail2},
16568 'office1' => \$mysync->{office1},
16569 'office2' => \$mysync->{office2},
16570 'exchange1' => \$mysync->{exchange1},
16571 'exchange2' => \$mysync->{exchange2},
16572 'domino1' => \$mysync->{domino1},
16573 'domino2' => \$mysync->{domino2},
16574 'f1f2=s@' => \$mysync->{f1f2},
16575 'f1f2h=s%' => \$mysync->{f1f2h},
16576 'folder=s@' => \$mysync->{ folder },
16577 'blabla=s' => \@blabla,
16578 'testslive!' => \$mysync->{testslive},
16579 'testslive6!' => \$mysync->{testslive6},
16580 'releasecheck!' => \$mysync->{releasecheck},
16581 'simulong=i' => \$mysync->{simulong},
16582 'debugsleep=f' => \$mysync->{debugsleep},
16583 'subfolder1=s' => \$mysync->{ subfolder1 },
16584 'subfolder2=s' => \$mysync->{ subfolder2 },
16585 'justfolders!' => \$mysync->{ justfolders },
16586 'justfoldersizes!' => \$mysync->{ justfoldersizes },
16587 'delete1!' => \$mysync->{ delete1 },
16588 'delete2!' => \$mysync->{ delete2 },
16589 'delete2duplicates!' => \$mysync->{ delete2duplicates },
16590 'tail!' => \$mysync->{tail},
16591
16592# blabla and f1f2h=s% could be removed but
16593# tests_get_options_cgi() should be split before
16594# with a sub tests_myGetOptions()
16595 ) ;
16596
16597 $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ;
16598
16599 if ( ! $opt_ret ) {
16600 return ;
16601 }
16602 return $numopt ;
16603}
16604
16605sub get_options_cmd
16606{
16607 my $mysync = shift @ARG ;
16608 my @arguments = @ARG ;
16609 my $mycgi = $mysync->{cgi} ;
16610 # final 0 is used to print usage when no option is given on command line
16611 my $numopt = scalar @arguments || 0 ;
16612 my $argv = join "\x00", @arguments ;
16613
16614 if ( $argv =~ m/-delete\x002/x ) {
16615 output( $mysync, "May be you mean --delete2 instead of --delete 2\n" ) ;
16616 return ;
16617 }
16618 $mysync->{f1f2h} = {} ;
16619 my $opt_ret = myGetOptions(
16620 $mysync,
16621 \@arguments,
16622 'debug!' => \$mysync->{ debug },
16623 'debuglist!' => \$debuglist,
16624 'debugcontent!' => \$debugcontent,
16625 'debugsleep=f' => \$mysync->{debugsleep},
16626 'debugflags!' => \$debugflags,
16627 'debugimap!' => \$debugimap,
16628 'debugimap1!' => \$debugimap1,
16629 'debugimap2!' => \$debugimap2,
16630 'debugdev!' => \$debugdev,
16631 'debugmemory!' => \$mysync->{debugmemory},
16632 'debugfolders!' => \$mysync->{debugfolders},
16633 'debugssl=i' => \$mysync->{debugssl},
16634 'debugcgi!' => \$debugcgi,
16635 'debugenv!' => \$mysync->{debugenv},
16636 'debugsig!' => \$mysync->{debugsig},
16637 'debuglabels!' => \$mysync->{debuglabels},
16638 'simulong=i' => \$mysync->{simulong},
16639 'abort' => \$mysync->{abort},
16640 'host1=s' => \$mysync->{ host1 },
16641 'host2=s' => \$mysync->{ host2 },
16642 'port1=i' => \$mysync->{port1},
16643 'port2=i' => \$mysync->{port2},
16644 'inet4|ipv4' => \$mysync->{inet4},
16645 'inet6|ipv6' => \$mysync->{inet6},
16646 'user1=s' => \$mysync->{ user1 },
16647 'user2=s' => \$mysync->{ user2 },
16648 'gmail1' => \$mysync->{gmail1},
16649 'gmail2' => \$mysync->{gmail2},
16650 'office1' => \$mysync->{office1},
16651 'office2' => \$mysync->{office2},
16652 'exchange1' => \$mysync->{exchange1},
16653 'exchange2' => \$mysync->{exchange2},
16654 'domino1' => \$mysync->{domino1},
16655 'domino2' => \$mysync->{domino2},
16656 'domain1=s' => \$domain1,
16657 'domain2=s' => \$domain2,
16658 'password1=s' => \$mysync->{password1},
16659 'password2=s' => \$mysync->{password2},
16660 'passfile1=s' => \$mysync->{ passfile1 },
16661 'passfile2=s' => \$mysync->{ passfile2 },
16662 'authmd5!' => \$authmd5,
16663 'authmd51!' => \$authmd51,
16664 'authmd52!' => \$authmd52,
16665 'sep1=s' => \$mysync->{ sep1 },
16666 'sep2=s' => \$mysync->{ sep2 },
16667 'sanitize!' => \$mysync->{ sanitize },
16668 'folder=s@' => \$mysync->{ folder },
16669 'folderrec=s' => \@folderrec,
16670 'include=s' => \@include,
16671 'exclude=s' => \@exclude,
16672 'noexclude' => \$mysync->{noexclude},
16673 'folderfirst=s' => \@folderfirst,
16674 'folderlast=s' => \@folderlast,
16675 'prefix1=s' => \$prefix1,
16676 'prefix2=s' => \$prefix2,
16677 'subfolder1=s' => \$mysync->{ subfolder1 },
16678 'subfolder2=s' => \$mysync->{ subfolder2 },
16679 'fixslash2!' => \$mysync->{ fixslash2 },
16680 'fixInboxINBOX!' => \$fixInboxINBOX,
16681 'regextrans2=s@' => \$mysync->{ regextrans2 },
16682 'mixfolders!' => \$mixfolders,
16683 'skipemptyfolders!' => \$mysync->{ skipemptyfolders },
16684 'regexmess=s' => \@regexmess,
16685 'noregexmess' => \$mysync->{noregexmess},
16686 'skipmess=s' => \@skipmess,
16687 'pipemess=s' => \@pipemess,
16688 'pipemesscheck!' => \$pipemesscheck,
16689 'disarmreadreceipts!' => \$disarmreadreceipts,
16690 'regexflag=s' => \@regexflag,
16691 'noregexflag' => \$mysync->{noregexflag},
16692 'filterflags!' => \$filterflags,
16693 'flagscase!' => \$flagscase,
16694 'syncflagsaftercopy!' => \$syncflagsaftercopy,
16695 'resyncflags!' => \$mysync->{ resyncflags },
16696 'synclabels!' => \$mysync->{ synclabels },
16697 'resynclabels!' => \$mysync->{ resynclabels },
16698 'delete|delete1!' => \$mysync->{ delete1 },
16699 'delete2!' => \$mysync->{ delete2 },
16700 'delete2duplicates!' => \$mysync->{ delete2duplicates },
16701 'delete2folders!' => \$delete2folders,
16702 'delete2foldersonly=s' => \$delete2foldersonly,
16703 'delete2foldersbutnot=s' => \$delete2foldersbutnot,
16704 'syncinternaldates!' => \$syncinternaldates,
16705 'idatefromheader!' => \$idatefromheader,
16706 'syncacls!' => \$syncacls,
16707 'maxsize=i' => \$mysync->{ maxsize },
16708 'appendlimit=i' => \$mysync->{ appendlimit },
16709 'truncmess=i' => \$mysync->{ truncmess },
16710 'minsize=i' => \$minsize,
16711 'maxage=f' => \$maxage,
16712 'minage=f' => \$minage,
16713 'search=s' => \$search,
16714 'search1=s' => \$mysync->{ search1 },
16715 'search2=s' => \$mysync->{ search2 },
16716 'foldersizes!' => \$mysync->{ foldersizes },
16717 'foldersizesatend!' => \$mysync->{ foldersizesatend },
16718 'dry!' => \$mysync->{dry},
16719 'expunge1|expunge!' => \$mysync->{ expunge1 },
16720 'expunge2!' => \$mysync->{ expunge2 },
16721 'uidexpunge2!' => \$mysync->{ uidexpunge2 },
16722 'subscribed' => \$subscribed,
16723 'subscribe!' => \$subscribe,
16724 'subscribeall|subscribe_all!' => \$subscribeall,
16725 'justbanner!' => \$justbanner,
16726 'justfolders!'=> \$mysync->{ justfolders },
16727 'justfoldersizes!' => \$mysync->{ justfoldersizes },
16728 'fast!' => \$fast,
16729 'version' => \$mysync->{version},
16730 'help' => \$help,
16731 'timeout=i' => \$timeout,
16732 'timeout1=i' => \$mysync->{h1}->{timeout},
16733 'timeout2=i' => \$mysync->{h2}->{timeout},
16734 'skipheader=s' => \$skipheader,
16735 'useheader=s' => \@useheader,
16736 'wholeheaderifneeded!' => \$wholeheaderifneeded,
16737 'messageidnodomain!' => \$messageidnodomain,
16738 'skipsize!' => \$skipsize,
16739 'allowsizemismatch!' => \$allowsizemismatch,
16740 'fastio1!' => \$fastio1,
16741 'fastio2!' => \$fastio2,
16742 'sslcheck!' => \$mysync->{sslcheck},
16743 'ssl1!' => \$mysync->{ssl1},
16744 'ssl2!' => \$mysync->{ssl2},
16745 'ssl1_ssl_version=s' => \$mysync->{h1}->{sslargs}->{SSL_version},
16746 'ssl2_ssl_version=s' => \$mysync->{h2}->{sslargs}->{SSL_version},
16747 'sslargs1=s%' => \$mysync->{h1}->{sslargs},
16748 'sslargs2=s%' => \$mysync->{h2}->{sslargs},
16749 'tls1!' => \$mysync->{tls1},
16750 'tls2!' => \$mysync->{tls2},
16751 'uid1!' => \$uid1,
16752 'uid2!' => \$uid2,
16753 'authmech1=s' => \$authmech1,
16754 'authmech2=s' => \$authmech2,
16755 'authuser1=s' => \$authuser1,
16756 'authuser2=s' => \$authuser2,
16757 'proxyauth1' => \$proxyauth1,
16758 'proxyauth2' => \$proxyauth2,
16759 'split1=i' => \$split1,
16760 'split2=i' => \$split2,
16761 'buffersize=i' => \$buffersize,
16762 'reconnectretry1=i' => \$reconnectretry1,
16763 'reconnectretry2=i' => \$reconnectretry2,
16764 'tests!' => \$mysync->{ tests },
16765 'testsdebug|tests_debug!' => \$mysync->{ testsdebug },
16766 'testsunit=s@' => \$mysync->{testsunit},
16767 'testslive!' => \$mysync->{testslive},
16768 'testslive6!' => \$mysync->{testslive6},
16769 'justlogin!' => \$mysync->{justlogin},
16770 'justconnect!' => \$mysync->{justconnect},
16771 'tmpdir=s' => \$mysync->{ tmpdir },
16772 'pidfile=s' => \$mysync->{pidfile},
16773 'pidfilelocking!' => \$mysync->{pidfilelocking},
16774 'sigexit=s@' => \$mysync->{ sigexit },
16775 'sigreconnect=s@' => \$mysync->{ sigreconnect },
16776 'sigignore=s@' => \$mysync->{ sigignore },
16777 'releasecheck!' => \$mysync->{releasecheck},
16778 'modulesversion|modules_version!' => \$modulesversion,
16779 'usecache!' => \$usecache,
16780 'cacheaftercopy!' => \$cacheaftercopy,
16781 'debugcache!' => \$debugcache,
16782 'useuid!' => \$useuid,
16783 'addheader!' => \$mysync->{addheader},
16784 'exitwhenover=i' => \$mysync->{ exitwhenover },
16785 'checkselectable!' => \$mysync->{ checkselectable },
16786 'checkfoldersexist!' => \$mysync->{ checkfoldersexist },
16787 'checkmessageexists!' => \$checkmessageexists,
16788 'expungeaftereach!' => \$mysync->{ expungeaftereach },
16789 'abletosearch!' => \$mysync->{abletosearch},
16790 'abletosearch1!' => \$mysync->{abletosearch1},
16791 'abletosearch2!' => \$mysync->{abletosearch2},
16792 'showpasswords!' => \$mysync->{showpasswords},
16793 'maxlinelength=i' => \$maxlinelength,
16794 'maxlinelengthcmd=s' => \$maxlinelengthcmd,
16795 'minmaxlinelength=i' => \$minmaxlinelength,
16796 'debugmaxlinelength!' => \$debugmaxlinelength,
16797 'fixcolonbug!' => \$fixcolonbug,
16798 'create_folder_old!' => \$create_folder_old,
16799 'maxmessagespersecond=f' => \$mysync->{maxmessagespersecond},
16800 'maxbytespersecond=i' => \$mysync->{maxbytespersecond},
16801 'maxbytesafter=i' => \$mysync->{maxbytesafter},
16802 'maxsleep=f' => \$mysync->{maxsleep},
16803 'skipcrossduplicates!' => \$skipcrossduplicates,
16804 'debugcrossduplicates!' => \$debugcrossduplicates,
16805 'log!' => \$mysync->{log},
16806 'tail!' => \$mysync->{tail},
16807 'logfile=s' => \$mysync->{logfile},
16808 'logdir=s' => \$mysync->{logdir},
16809 'errorsmax=i' => \$mysync->{errorsmax},
16810 'errorsdump!' => \$mysync->{errorsdump},
16811 'fetch_hash_set=s' => \$fetch_hash_set,
16812 'automap!' => \$mysync->{automap},
16813 'justautomap!' => \$mysync->{justautomap},
16814 'id!' => \$mysync->{id},
16815 'f1f2=s@' => \$mysync->{f1f2},
16816 'nof1f2' => \$mysync->{nof1f2},
16817 'f1f2h=s%' => \$mysync->{f1f2h},
16818 'justfolderlists!' => \$mysync->{justfolderlists},
16819 'delete1emptyfolders' => \$mysync->{delete1emptyfolders},
16820 ) ;
16821 #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
16822 $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ;
16823 my $numopt_after = scalar @arguments ;
16824 #myprint( "get options: [$opt_ret][$numopt][$numopt_after]\n" ) ;
16825 if ( $numopt_after ) {
16826 myprint(
16827 "Extra arguments found: @arguments\n",
16828 "It usually means a quoting issue in the command line ",
16829 "or some misspelling options.\n",
16830 ) ;
16831 return ;
16832 }
16833 if ( ! $opt_ret ) {
16834 return ;
16835 }
16836 return $numopt ;
16837}
16838
16839
16840
16841sub tests_get_options
16842{
16843 note( 'Entering tests_get_options()' ) ;
16844
16845 # CAVEAT: still setting global variables, be careful
16846 # with tests, the context increases! $debug stays on for example.
16847 # API:
16848 # * input arguments: two ways, command line or CGI
16849 # * the program arguments
16850 # * QUERY_STRING env variable
16851 # * return
16852 # * undef if bad things happened like
16853 # * options not known
16854 # * --delete 2 input
16855 # * number of arguments or QUERY_STRING length
16856 my $mysync = { } ;
16857 is( undef, get_options( $mysync, qw( --noexist ) ), 'get_options: --noexist => undef' ) ;
16858 is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ;
16859 $mysync = { } ;
16860 is( undef, get_options( $mysync, qw( --lalala --noexist --version ) ), 'get_options: --lalala --noexist --version => undef' ) ;
16861 is( 1, $mysync->{ version }, 'get_options: --version => 1' ) ;
16862 is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ;
16863 $mysync = { } ;
16864 is( 1, get_options( $mysync, qw( --delete2 ) ), 'get_options: --delete2 => 1' ) ;
16865 is( 1, $mysync->{ delete2 }, 'get_options: --delete2 => var delete2 = 1' ) ;
16866 $mysync = { } ;
16867 is( undef, get_options( $mysync, qw( --delete 2 ) ), 'get_options: --delete 2 => var undef' ) ;
16868 is( undef, $mysync->{ delete1 }, 'get_options: --delete 2 => var still undef ; good!' ) ;
16869 $mysync = { } ;
16870 is( undef, get_options( $mysync, "--delete 2" ), 'get_options: --delete 2 => undef' ) ;
16871
16872 is( 1, get_options( $mysync, "--version" ), 'get_options: --version => 1' ) ;
16873 is( 1, get_options( $mysync, "--help" ), 'get_options: --help => 1' ) ;
16874
16875 is( undef, get_options( $mysync, qw( --noexist --version ) ), 'get_options: --debug --noexist --version => undef' ) ;
16876 is( 1, get_options( $mysync, qw( --version ) ), 'get_options: --version => 1' ) ;
16877 is( undef, get_options( $mysync, qw( extra ) ), 'get_options: extra => undef' ) ;
16878 is( undef, get_options( $mysync, qw( extra1 --version extra2 ) ), 'get_options: extra1 --version extra2 => undef' ) ;
16879
16880 $mysync = { } ;
16881 is( 2, get_options( $mysync, qw( --host1 HOST_01) ), 'get_options: --host1 HOST_01 => 1' ) ;
16882 is( 'HOST_01', $mysync->{ host1 }, 'get_options: --host1 HOST_01 => HOST_01' ) ;
16883 #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ;
16884
16885 note( 'Leaving tests_get_options()' ) ;
16886 return ;
16887}
16888
16889
16890
16891sub get_options
16892{
16893 my $mysync = shift @ARG ;
16894 my @arguments = @ARG ;
16895 #myprint( "1 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ;
16896 my $ret ;
16897 if ( under_cgi_context( ) ) {
16898 # CGI context
16899 $ret = get_options_cgi( $mysync, @arguments ) ;
16900 }else{
16901 # Command line context ;
16902 $ret = get_options_cmd( $mysync, @arguments ) ;
16903 } ;
16904 #myprint( "2 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ;
16905 foreach my $key ( sort keys %{ $mysync } ) {
16906 if ( ! defined $mysync->{$key} ) {
16907 delete $mysync->{$key} ;
16908 next ;
16909 }
16910 if ( 'ARRAY' eq ref( $mysync->{$key} )
16911 and 0 == scalar( @{ $mysync->{$key} } ) ) {
16912 delete $mysync->{$key} ;
16913 }
16914 }
16915 return $ret ;
16916}
16917
16918sub testunitsession
16919{
16920 my $mysync = shift ;
16921
16922 if ( ! $mysync ) { return ; }
16923 if ( ! $mysync->{ testsunit } ) { return ; }
16924
16925 my @functions = @{ $mysync->{ testsunit } } ;
16926
16927 if ( ! @functions ) { return ; }
16928
16929 SKIP: {
16930 if ( ! @functions ) { skip 'No test in normal run' ; }
16931 testsunit( @functions ) ;
16932 done_testing( ) ;
16933 }
16934 return ;
16935}
16936
16937sub tests_count_0s
16938{
16939 note( 'Entering tests_count_zeros()' ) ;
16940 is( 0, count_0s( ), 'count_0s: no parameters => 0' ) ;
16941 is( 1, count_0s( 0 ), 'count_0s: 0 => 1' ) ;
16942 is( 0, count_0s( 1 ), 'count_0s: 1 => 0' ) ;
16943 is( 1, count_0s( 1, 0, 1 ), 'count_0s: 1, 0, 1 => 1' ) ;
16944 is( 2, count_0s( 1, 0, 1, 0 ), 'count_0s: 1, 0, 1, 0 => 2' ) ;
16945 note( 'Leaving tests_count_zeros()' ) ;
16946 return ;
16947}
16948sub count_0s
16949{
16950 my @array = @ARG ;
16951
16952 if ( ! @array ) { return 0 ; }
16953 my $nb_zeros = 0 ;
16954 map { $_ == 0 and $nb_zeros += 1 } @array ;
16955 return $nb_zeros ;
16956}
16957
16958sub tests_report_failures
16959{
16960 note( 'Entering tests_report_failures()' ) ;
16961
16962 is( undef, report_failures( ), 'report_failures: no parameters => undef' ) ;
16963 is( "nb 1 - first\n", report_failures( ({'ok' => 0, name => 'first'}) ), 'report_failures: "first" failed => nb 1 - first' ) ;
16964 is( q{}, report_failures( ( {'ok' => 1, name => 'first'} ) ), 'report_failures: "first" success =>' ) ;
16965 is( "nb 2 - second\n", report_failures( ( {'ok' => 1, name => 'second'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: "second" failed => nb 2 - second' ) ;
16966 is( "nb 1 - first\nnb 2 - second\n", report_failures( ( {'ok' => 0, name => 'first'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: both failed => nb 1 - first nb 2 - second' ) ;
16967 note( 'Leaving tests_report_failures()' ) ;
16968 return ;
16969}
16970
16971sub report_failures
16972{
16973 my @details = @ARG ;
16974
16975 if ( ! @details ) { return ; }
16976
16977 my $counter = 1 ;
16978 my $report = q{} ;
16979 foreach my $details ( @details ) {
16980 if ( ! $details->{ 'ok' } ) {
16981 my $name = $details->{ 'name' } || 'NONAME' ;
16982 $report .= "nb $counter - $name\n" ;
16983 }
16984 $counter += 1 ;
16985 }
16986 return $report ;
16987
16988}
16989
16990sub tests_true
16991{
16992 note( 'Entering tests_true()' ) ;
16993
16994 is( 1, 1, 'true: 1 is 1' ) ;
16995 note( 'Leaving tests_true()' ) ;
16996 return ;
16997}
16998
16999sub tests_testsunit
17000{
17001 note( 'Entering tests_testunit()' ) ;
17002
17003 is( undef, testsunit( ), 'testsunit: no parameters => undef' ) ;
17004 is( undef, testsunit( undef ), 'testsunit: an undef parameter => undef' ) ;
17005 is( undef, testsunit( q{} ), 'testsunit: an empty parameter => undef' ) ;
17006 is( undef, testsunit( 'idonotexist' ), 'testsunit: a do not exist function as parameter => undef' ) ;
17007 is( undef, testsunit( 'tests_true' ), 'testsunit: tests_true => undef' ) ;
17008 note( 'Leaving tests_testunit()' ) ;
17009 return ;
17010}
17011
17012sub testsunit
17013{
17014 my @functions = @ARG ;
17015
17016 if ( ! @functions ) { #
17017 myprint( "testsunit warning: no argument given\n" ) ;
17018 return ;
17019 }
17020
17021 foreach my $function ( @functions ) {
17022 if ( ! $function ) {
17023 myprint( "testsunit warning: argument is empty\n" ) ;
17024 next ;
17025 }
17026 if ( ! exists &$function ) {
17027 myprint( "testsunit warning: function $function does not exist\n" ) ;
17028 next ;
17029 }
17030 if ( ! defined &$function ) {
17031 myprint( "testsunit warning: function $function is not defined\n" ) ;
17032 next ;
17033 }
17034 my $function_ref = \&{ $function } ;
17035 &$function_ref() ;
17036 }
17037 return ;
17038}
17039
17040sub testsdebug
17041{
17042 # Now a little obsolete since there is
17043 # imapsync ... --testsunit "anyfunction"
17044 my $mysync = shift ;
17045 if ( ! $mysync->{ testsdebug } ) { return ; }
17046 SKIP: {
17047 if ( ! $mysync->{ testsdebug } ) {
17048 skip 'No test in normal run' ;
17049 }
17050
17051 note( 'Entering testsdebug()' ) ;
17052 #ok( ( ( not -d 'W/tmp/tests' ) or rmtree( 'W/tmp/tests/' ) ), 'testsdebug: rmtree W/tmp/tests' ) ;
17053 #tests_check_binary_embed_all_dyn_libs( ) ;
17054 #tests_killpid_by_parent( ) ;
17055 #tests_killpid_by_brother( ) ;
17056 #tests_kill_zero( ) ;
17057 #tests_connect_socket( ) ;
17058 tests_probe_imapssl( ) ;
17059 #tests_always_fail( ) ;
17060
17061 note( 'Leaving testsdebug()' ) ;
17062 done_testing( ) ;
17063 }
17064 return ;
17065}
17066
17067
17068sub tests
17069{
17070 my $mysync = shift ;
17071 if ( ! $mysync->{ tests } ) { return ; }
17072
17073 SKIP: {
17074 skip 'No test in normal run' if ( ! $mysync->{ tests } ) ;
17075 note( 'Entering tests()' ) ;
17076 tests_folder_routines( ) ;
17077 tests_compare_lists( ) ;
17078 tests_regexmess( ) ;
17079 tests_skipmess( ) ;
17080 tests_flags_regex();
17081 tests_ucsecond( ) ;
17082 tests_permanentflags();
17083 tests_flags_filter( ) ;
17084 tests_separator_invert( ) ;
17085 tests_imap2_folder_name( ) ;
17086 tests_command_line_nopassword( ) ;
17087 tests_good_date( ) ;
17088 tests_max( ) ;
17089 tests_remove_not_num();
17090 tests_memory_consumption( ) ;
17091 tests_is_a_release_number();
17092 tests_imapsync_basename();
17093 tests_list_keys_in_2_not_in_1();
17094 tests_convert_sep_to_slash( ) ;
17095 tests_match_a_cache_file( ) ;
17096 tests_cache_map( ) ;
17097 tests_get_cache( ) ;
17098 tests_clean_cache( ) ;
17099 tests_clean_cache_2( ) ;
17100 tests_touch( ) ;
17101 tests_flagscase( ) ;
17102 tests_mkpath( ) ;
17103 tests_extract_header( ) ;
17104 tests_decompose_header( ) ;
17105 tests_epoch( ) ;
17106 tests_add_header( ) ;
17107 tests_cache_dir_fix( ) ;
17108 tests_cache_dir_fix_win( ) ;
17109 tests_filter_forbidden_characters( ) ;
17110 tests_cache_folder( ) ;
17111 tests_time_remaining( ) ;
17112 tests_decompose_regex( ) ;
17113 tests_backtick( ) ;
17114 tests_bytes_display_string( ) ;
17115 tests_header_line_normalize( ) ;
17116 tests_fix_Inbox_INBOX_mapping( ) ;
17117 tests_max_line_length( ) ;
17118 tests_subject( ) ;
17119 tests_msgs_from_maxmin( ) ;
17120 tests_tmpdir_has_colon_bug( ) ;
17121 tests_sleep_max_messages( ) ;
17122 tests_sleep_max_bytes( ) ;
17123 tests_logfile( ) ;
17124 tests_setlogfile( ) ;
17125 tests_jux_utf8_old( ) ;
17126 tests_jux_utf8( ) ;
17127 tests_pipemess( ) ;
17128 tests_jux_utf8_list( ) ;
17129 tests_guess_prefix( ) ;
17130 tests_guess_separator( ) ;
17131 tests_format_for_imap_arg( ) ;
17132 tests_imapsync_id( ) ;
17133 tests_date_from_rcs( ) ;
17134 tests_quota_extract_storage_limit_in_bytes( ) ;
17135 tests_quota_extract_storage_current_in_bytes( ) ;
17136 tests_guess_special( ) ;
17137 tests_do_valid_directory( ) ;
17138 tests_delete1emptyfolders( ) ;
17139 tests_message_for_host2( ) ;
17140 tests_length_ref( ) ;
17141 tests_firstline( ) ;
17142 tests_diff_or_NA( ) ;
17143 tests_match_number( ) ;
17144 tests_all_defined( ) ;
17145 tests_special_from_folders_hash( ) ;
17146 tests_notmatch( ) ;
17147 tests_match( ) ;
17148 tests_get_options( ) ;
17149 tests_get_options_cgi_context( ) ;
17150 tests_rand32( ) ;
17151 tests_hashsynclocal( ) ;
17152 tests_hashsync( ) ;
17153 tests_output( ) ;
17154 tests_output_reset_with( ) ;
17155 tests_output_start( ) ;
17156 tests_check_last_release( ) ;
17157 tests_loadavg( ) ;
17158 tests_cpu_number( ) ;
17159 tests_load_and_delay( ) ;
17160 #tests_imapsping( ) ;
17161 #tests_tcpping( ) ;
17162 tests_sslcheck( ) ;
17163 tests_not_long_imapsync_version_public( ) ;
17164 tests_reconnect_if_needed( ) ;
17165 tests_reconnect_12_if_needed( ) ;
17166 tests_sleep_if_needed( ) ;
17167 tests_string_to_file( ) ;
17168 tests_file_to_string( ) ;
17169 tests_under_cgi_context( ) ;
17170 tests_umask( ) ;
17171 tests_umask_str( ) ;
17172 tests_set_umask( ) ;
17173 tests_createhashfileifneeded( ) ;
17174 tests_slash_to_underscore( ) ;
17175 tests_testsunit( ) ;
17176 tests_count_0s( ) ;
17177 tests_report_failures( ) ;
17178 tests_min( ) ;
17179 #tests_connect_socket( ) ;
17180 #tests_resolvrev( ) ;
17181 tests_usage( ) ;
17182 tests_version_from_rcs( ) ;
17183 tests_backslash_caret( ) ;
17184 #tests_mailimapclient_connect_bug( ) ; # it fails with Mail-IMAPClient <= 3.39
17185 tests_write_pidfile( ) ;
17186 tests_remove_pidfile_not_running( ) ;
17187 tests_match_a_pid_number( ) ;
17188 tests_prefix_seperator_invertion( ) ;
17189 tests_is_an_integer( ) ;
17190 tests_integer_or_1( ) ;
17191 tests_is_number( ) ;
17192 tests_sig_install( ) ;
17193 tests_template( ) ;
17194 tests_split_around_equal( ) ;
17195 tests_toggle_sleep( ) ;
17196 tests_labels( ) ;
17197 tests_synclabels( ) ;
17198 tests_uidexpunge_or_expunge( ) ;
17199 tests_appendlimit_from_capability( ) ;
17200 tests_maxsize_setting( ) ;
17201 tests_mock_capability( ) ;
17202 tests_appendlimit( ) ;
17203 tests_capability_of( ) ;
17204 tests_search_in_array( ) ;
17205 tests_operators_and_exclam_precedence( ) ;
17206 tests_teelaunch( ) ;
17207 tests_logfileprepa( ) ;
17208 tests_useheader_suggestion( ) ;
17209 tests_nb_messages_in_2_not_in_1( ) ;
17210 tests_labels_add_subfolder2( ) ;
17211 tests_labels_remove_subfolder1( ) ;
17212 tests_resynclabels( ) ;
17213 tests_labels_remove_special( ) ;
17214 tests_uniq( ) ;
17215 tests_remove_from_requested_folders( ) ;
17216 tests_errors_log( ) ;
17217 tests_add_subfolder1_to_folderrec( ) ;
17218 tests_sanitize_subfolder( ) ;
17219 tests_remove_edging_blanks( ) ;
17220 tests_sanitize( ) ;
17221 tests_remove_last_char_if_is( ) ;
17222 tests_check_binary_embed_all_dyn_libs( ) ;
17223 tests_nthline( ) ;
17224 tests_secondline( ) ;
17225 tests_tail( ) ;
17226 tests_truncmess( ) ;
17227 tests_eta( ) ;
17228 tests_timesince( ) ;
17229 tests_timenext( ) ;
17230 tests_foldersize( ) ;
17231 tests_imapsync_context( ) ;
17232 tests_abort( ) ;
17233 tests_probe_imapssl( ) ;
17234 tests_mailimapclient_connect( ) ;
17235 #tests_resolv( ) ;
17236
17237 # Those three are for later use, when webserver will be inside imapsync
17238 # or will be deleted them if I abandon the project.
17239 #tests_killpid_by_parent( ) ;
17240 #tests_killpid_by_brother( ) ;
17241 #tests_kill_zero( ) ;
17242
17243 #tests_always_fail( ) ;
17244 done_testing( 1496 ) ;
17245 note( 'Leaving tests()' ) ;
17246 }
17247 return ;
17248}
17249
17250sub tests_template
17251{
17252 note( 'Entering tests_template()' ) ;
17253
17254 is( undef, undef, 'template: no args => undef' ) ;
17255 is_deeply( {}, {}, 'template: a hash is a hash' ) ;
17256 is_deeply( [], [], 'template: an array is an array' ) ;
17257 note( 'Leaving tests_template()' ) ;
17258 return ;
17259}
17260
17261