1#!/usr/bin/env perl 2 3# $Id: imapsync,v 1.945 2019/06/26 19:30:56 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 and migrating 23email mailboxes between two imap servers, one way, 24and without duplicates. 25 26=head1 VERSION 27 28This documentation refers to Imapsync $Revision: 1.945 $ 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 79in case 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 117Standard options are the six values forming the credentials, 118three on each sides, needed to log in into the IMAP servers, ie, 119a host, a username, and a password, two times. 120 121Conventions used: 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 143 or 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. 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. --folderfirst "Work" 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 under str 252 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. 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, remove --justfolders. 289 Have in mind that --regextrans2 is applied after 290 the automatic prefix and separator inversion. 291 For examples see: 292 https://imapsync.lamiral.info/FAQ.d/FAQ.Folders_Mapping.txt 293 294=head2 OPTIONS/folders sizes 295 296 --nofoldersizes : Do not calculate the size of each folder at the 297 beginning of the sync. Default is to calculate them. 298 --nofoldersizesatend: Do not calculate the size of each folder at the 299 end of the sync. Default is to calculate them. 300 --justfoldersizes : Exit after having printed the initial folder sizes. 301 302 303=head2 OPTIONS/tmp 304 305 306 --tmpdir str : Where to store temporary files and subdirectories. 307 Will be created if it doesn't exist. 308 Default is system specific, Unix is /tmp but 309 /tmp is often too small and deleted at reboot. 310 --tmpdir /var/tmp should be better. 311 --pidfile str : The file where imapsync pid is written, 312 it can be dirname/filename. 313 Default name is imapsync.pid in tmpdir. 314 --pidfilelocking : Abort if pidfile already exists. Useful to avoid 315 concurrent transfers on the same mailbox. 316 317 318=head2 OPTIONS/log 319 320 --nolog : Turn off logging on file 321 --logfile str : Change the default log filename (can be dirname/filename). 322 --logdir str : Change the default log directory. Default is LOG_imapsync/ 323 324 325=head2 OPTIONS/messages 326 327 --skipmess reg : Skips messages matching the regex. 328 Example: 'm/[\x80-ff]/' # to avoid 8bits messages. 329 --skipmess is applied before --regexmess 330 --skipmess reg : or this one, etc. 331 332 --pipemess cmd : Apply this cmd command to each message content 333 before the copy. 334 --pipemess cmd : and this one, etc. 335 With several --pipemess, the output of each cmd 336 command (STDOUT) is given to the input (STDIN) 337 of the next command. 338 For example, 339 --pipemess cmd1 --pipemess cmd2 --pipemess cmd3 340 is like a Unix pipe: 341 "cat message | cmd1 | cmd2 | cmd3" 342 343 --disarmreadreceipts : Disarms read receipts (host2 Exchange issue) 344 345 --regexmess reg : Apply the whole regex to each message before transfer. 346 Example: 's/\000/ /g' # to replace null by space. 347 --regexmess reg : and this one, etc. 348 349 350=head2 OPTIONS/flags 351 352 If you encounter flag problems see also: 353 https://imapsync.lamiral.info/FAQ.d/FAQ.Flags.txt 354 355 --regexflag reg : Apply the whole regex to each flags list. 356 Example: 's/"Junk"//g' # to remove "Junk" flag. 357 --regexflag reg : then this one, etc. 358 359 --resyncflags : Resync flags for already transferred messages. 360 On by default. 361 --noresyncflags : Do not resync flags for already transferred messages. 362 May be useful when a user has already started to play 363 with its host2 account. 364 365=head2 OPTIONS/deletions 366 367 --delete1 : Deletes messages on host1 server after a successful 368 transfer. Option --delete1 has the following behavior: 369 it marks messages as deleted with the IMAP flag 370 \Deleted, then messages are really deleted with an 371 EXPUNGE IMAP command. If expunging after each message 372 slows down too much the sync then use 373 --noexpungeaftereach to speed up, expunging will then be 374 done only twice per folder, one at the beginning and 375 one at the end of a folder sync. 376 377 --expunge1 : Expunge messages on host1 just before syncing a folder. 378 Expunge is done per folder. 379 Expunge aims is to really delete messages marked deleted. 380 An expunge is also done after each message copied 381 if option --delete1 is set (unless --noexpungeaftereach). 382 383 --noexpunge1 : Do not expunge messages on host1. 384 385 --delete1emptyfolders : Deletes empty folders on host1, INBOX excepted. 386 Useful with --delete1 since what remains on host1 387 is only what failed to be synced. 388 389 --delete2 : Delete messages in host2 that are not in 390 host1 server. Useful for backup or pre-sync. 391 --delete2 implies --uidexpunge2 392 393 --delete2duplicates : Delete messages in host2 that are duplicates. 394 Works only without --useuid since duplicates are 395 detected with an header part of each message. 396 397 --delete2folders : Delete folders in host2 that are not in host1 server. 398 For safety, first try it like this (it is safe): 399 --delete2folders --dry --justfolders --nofoldersizes 400 401 --delete2foldersonly reg : Deleted only folders matching regex. 402 Example: --delete2foldersonly "/^Junk$|^INBOX.Junk$/" 403 404 --delete2foldersbutnot reg : Do not delete folders matching regex. 405 Example: --delete2foldersbutnot "/Tasks$|Contacts$|Foo$/" 406 407 --noexpunge2 : Do not expunge messages on host2. 408 --nouidexpunge2 : Do not uidexpunge messages on the host2 account 409 that are not on the host1 account. 410 411 412=head2 OPTIONS/dates 413 414 If you encounter problems with dates, see also: 415 https://imapsync.lamiral.info/FAQ.d/FAQ.Dates.txt 416 417 --syncinternaldates : Sets the internal dates on host2 same as host1. 418 Turned on by default. Internal date is the date 419 a message arrived on a host (Unix mtime). 420 --idatefromheader : Sets the internal dates on host2 same as the 421 ones in "Date:" headers. 422 423 424 425=head2 OPTIONS/message selection 426 427 --maxsize int : Skip messages larger (or equal) than int bytes 428 --minsize int : Skip messages smaller (or equal) than int bytes 429 --maxage int : Skip messages older than int days. 430 final stats (skipped) don't count older messages 431 see also --minage 432 --minage int : Skip messages newer than int days. 433 final stats (skipped) don't count newer messages 434 You can do (+ are the messages selected): 435 past|----maxage+++++++++++++++>now 436 past|+++++++++++++++minage---->now 437 past|----maxage+++++minage---->now (intersection) 438 past|++++minage-----maxage++++>now (union) 439 440 --search str : Selects only messages returned by this IMAP SEARCH 441 command. Applied on both sides. 442 For a complete of what can be search see 443 https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Selection.txt 444 445 --search1 str : Same as --search but for selecting host1 messages only. 446 --search2 str : Same as --search but for selecting host2 messages only. 447 --search CRIT equals --search1 CRIT --search2 CRIT 448 449 --maxlinelength int : skip messages with a line length longer than int bytes. 450 RFC 2822 says it must be no more than 1000 bytes. 451 452 453 --useheader str : Use this header to compare messages on both sides. 454 Ex: Message-ID or Subject or Date. 455 --useheader str and this one, etc. 456 457 --usecache : Use cache to speed up the sync. 458 --nousecache : Do not use cache. Caveat: --useuid --nousecache creates 459 duplicates on multiple runs. 460 --useuid : Use UIDs instead of headers as a criterion to recognize 461 messages. Option --usecache is then implied unless 462 --nousecache is used. 463 464 465=head2 OPTIONS/miscellaneous 466 467 --syncacls : Synchronizes acls (Access Control Lists). 468 --nosyncacls : Does not synchronize acls. This is the default. 469 Acls in IMAP are not standardized, be careful 470 since one acl code on one side may signify something 471 else on the other one. 472 473 --addheader : When a message has no headers to be identified, 474 --addheader adds a "Message-Id" header, 475 like "Message-Id: 12345@imapsync", where 12345 476 is the imap UID of the message on the host1 folder. 477 478 479=head2 OPTIONS/debugging 480 481 --debug : Debug mode. 482 --debugfolders : Debug mode for the folders part only. 483 --debugcontent : Debug content of the messages transferred. Huge output. 484 --debugflags : Debug mode for flags. 485 --debugimap1 : IMAP debug mode for host1. Very verbose. 486 --debugimap2 : IMAP debug mode for host2. Very verbose. 487 --debugimap : IMAP debug mode for host1 and host2. Twice very verbose. 488 --debugmemory : Debug mode showing memory consumption after each copy. 489 490 --errorsmax int : Exit when int number of errors is reached. Default is 50. 491 492 --tests : Run local non-regression tests. Exit code 0 means all ok. 493 --testslive : Run a live test with test1.lamiral.info imap server. 494 Useful to check the basics. Needs internet connection. 495 --testslive6 : Run a live test with ks2ipv6.lamiral.info imap server. 496 Useful to check the ipv6 connectivity. Needs internet. 497 498 499=head2 OPTIONS/specific 500 501 --gmail1 : sets --host1 to Gmail and options from FAQ.Gmail.txt 502 --gmail2 : sets --host2 to Gmail and options from FAQ.Gmail.txt 503 504 --office1 : sets --host1 to Office365 options from FAQ.Exchange.txt 505 --office2 : sets --host2 to Office365 options from FAQ.Exchange.txt 506 507 --exchange1 : sets options from FAQ.Exchange.txt, account1 part 508 --exchange2 : sets options from FAQ.Exchange.txt, account2 part 509 510 --domino1 : sets options from FAQ.Domino.txt, account1 part 511 --domino2 : sets options from FAQ.Domino.txt, account2 part 512 513 514=head2 OPTIONS/behavior 515 516 --maxmessagespersecond int : limits the number of messages transferred per second. 517 518 --maxbytespersecond int : limits the average transfer rate per second. 519 --maxbytesafter int : starts --maxbytespersecond limitation only after 520 --maxbytesafter amount of data transferred. 521 522 --maxsleep int : do not sleep more than int seconds. 523 On by default, 2 seconds max, like --maxsleep 2 524 525 --abort : terminates a previous call still running. 526 It uses the pidfile to know what process to abort. 527 528 --exitwhenover int : Stop syncing and exits when int total bytes 529 transferred is reached. 530 531 --version : Print only software version. 532 --noreleasecheck : Do not check for new imapsync release 533 --releasecheck : Check for new imapsync release. 534 it's an http request to 535 http://imapsync.lamiral.info/prj/imapsync/VERSION 536 537 --noid : Do not send/receive ID command to imap servers. 538 539 --justconnect : Just connect to both servers and print useful 540 information. Need only --host1 and --host2 options. 541 Obsolete since "imapsync --host1 imaphost" alone 542 implies --justconnect 543 544 --justlogin : Just login to both host1 and host2 with users 545 credentials, then exit. 546 547 --justfolders : Do only things about folders (ignore messages). 548 549 --help : print this help. 550 551 Example: to synchronize imap account "test1" on "test1.lamiral.info" 552 to imap account "test2" on "test2.lamiral.info" 553 with test1 password "secret1" 554 and test2 password "secret2" 555 556 imapsync \ 557 --host1 test1.lamiral.info --user1 test1 --password1 secret1 \ 558 --host2 test2.lamiral.info --user2 test2 --password2 secret2 559 560 561=cut 562# comment 563 564=pod 565 566 567 568=head1 SECURITY 569 570You can use --passfile1 instead of --password1 to give the 571password since it is safer. With --password1 option, on Linux, 572any user on your host can see the password by using the 'ps auxwwww' 573command. Using a variable (like IMAPSYNC_PASSWORD1) is also 574dangerous because of the 'ps auxwwwwe' command. So, saving 575the password in a well protected file (600 or rw-------) is 576the best solution. 577 578Imapsync activates ssl or tls encryption by default, if possible. 579 580What detailed behavior is under this "if possible"? 581 582Imapsync activates ssl if the well known port imaps port (993) is open 583on the imap servers. If the imaps port is closed then it open a 584normal (clear) connection on port 143 but it looks for TLS support 585in the CAPABILITY list of the servers. If TLS is supported 586then imapsync goes to encryption. 587 588If the automatic ssl/tls detection fails then imapsync will 589not protect against sniffing activities on the 590network, especially for passwords. 591 592If you want to force ssl or tls just use --ssl1 --ssl2 or --tls1 --tls2 593 594See also the document FAQ.Security.txt in the FAQ.d/ directory 595or at https://imapsync.lamiral.info/FAQ.d/FAQ.Security.txt 596 597=head1 EXIT STATUS 598 599Imapsync will exit with a 0 status (return code) if everything went good. 600Otherwise, it exits with a non-zero status. 601Here is the list of the exit code values (an integer between 0 and 255), 602the names reflects their meaning: 603 604=for comment 605egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _' 606 607 608 EX_OK => 0 ; #/* successful termination */ 609 EX_USAGE => 64 ; #/* command line usage error */ 610 EX_NOINPUT => 66 ; #/* cannot open input */ 611 EX_UNAVAILABLE => 69 ; #/* service unavailable */ 612 EX_SOFTWARE => 70 ; #/* internal software error */ 613 EXIT_CATCH_ALL => 1 ; # Any other error 614 EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num 615 EXIT_PID_FILE_ERROR => 8 ; 616 EXIT_CONNECTION_FAILURE => 10 ; 617 EXIT_TLS_FAILURE => 12 ; 618 EXIT_AUTHENTICATION_FAILURE => 16 ; 619 EXIT_SUBFOLDER1_NO_EXISTS => 21 ; 620 EXIT_WITH_ERRORS => 111 ; 621 EXIT_WITH_ERRORS_MAX => 112 ; 622 EXIT_TESTS_FAILED => 254 ; # Like Test::More API 623 624 625=head1 LICENSE AND COPYRIGHT 626 627Imapsync is free, open, public but not always gratis software 628cover by the NOLIMIT Public License. 629See the LICENSE file included in the distribution or just read this 630simple sentence as it IS the licence text: 631 632 "No limits to do anything with this work and this license." 633 634In case it is not long enough, I repeat: 635 636 "No limits to do anything with this work and this license." 637 638Look at https://imapsync.lamiral.info/LICENSE 639 640=head1 AUTHOR 641 642Gilles LAMIRAL <gilles@lamiral.info> 643 644Good feedback good is always welcome. 645Bad feedback is very often welcome. 646 647Gilles LAMIRAL earns his living by writing, installing, 648configuring and teaching free, open and often gratis 649software. Imapsync used to be "always gratis" but now it is 650only "often gratis" because imapsync is sold by its author, 651a good way to maintain and support free open public 652software over decades. 653 654=head1 BUGS AND LIMITATIONS 655 656See https://imapsync.lamiral.info/FAQ.d/FAQ.Reporting_Bugs.txt 657 658=head1 IMAP SERVERS supported 659 660See https://imapsync.lamiral.info/S/imapservers.shtml 661 662=head1 HUGE MIGRATION 663 664If you have many mailboxes to migrate think about a little 665shell program. Write a file called file.txt (for example) 666containing users and passwords. 667The separator used in this example is ';' 668 669The file.txt file contains: 670 671user001_1;password001_1;user001_2;password001_2 672user002_1;password002_1;user002_2;password002_2 673user003_1;password003_1;user003_2;password003_2 674user004_1;password004_1;user004_2;password004_2 675user005_1;password005_1;user005_2;password005_2 676... 677 678On Unix the shell program can be: 679 680 { while IFS=';' read u1 p1 u2 p2; do 681 imapsync --host1 imap.side1.org --user1 "$u1" --password1 "$p1" \ 682 --host2 imap.side2.org --user2 "$u2" --password2 "$p2" ... 683 done ; } < file.txt 684 685On Windows the batch program can be: 686 687 FOR /F "tokens=1,2,3,4 delims=; eol=#" %%G IN (file.txt) DO imapsync ^ 688 --host1 imap.side1.org --user1 %%G --password1 %%H ^ 689 --host2 imap.side2.org --user2 %%I --password2 %%J ... 690 691The ... have to be replaced by nothing or any imapsync option. 692Welcome in shell or batch programming ! 693 694You will find already written scripts at 695https://imapsync.lamiral.info/examples/ 696 697=head1 INSTALL 698 699 Imapsync works under any Unix with Perl. 700 701 Imapsync works under most Windows (2000, XP, Vista, Seven, Eight, Ten 702 and all Server releases 2000, 2003, 2008 and R2, 2012 and R2, 2016) 703 as a standalone binary software called imapsync.exe, 704 usually launched from a batch file in order to avoid always typing 705 the options. 706 707 Imapsync works under OS X as a standalone binary 708 software called imapsync_bin_Darwin 709 710 Purchase latest imapsync at 711 https://imapsync.lamiral.info/ 712 713 You'll receive a link to a compressed tarball called imapsync-x.xx.tgz 714 where x.xx is the version number. Untar the tarball where 715 you want (on Unix): 716 717 tar xzvf imapsync-x.xx.tgz 718 719 Go into the directory imapsync-x.xx and read the INSTALL file. 720 As mentioned at https://imapsync.lamiral.info/#install 721 the INSTALL file can also be found at 722 https://imapsync.lamiral.info/INSTALL.d/INSTALL.ANY.txt 723 It is now split in several files for each system 724 https://imapsync.lamiral.info/INSTALL.d/ 725 726=head1 CONFIGURATION 727 728There is no specific configuration file for imapsync, 729everything is specified by the command line parameters 730and the default behavior. 731 732 733=head1 HACKING 734 735Feel free to hack imapsync as the NOLIMIT license permits it. 736 737 738=head1 SIMILAR SOFTWARE 739 740 See also https://imapsync.lamiral.info/S/external.shtml 741 for a better up to date list. 742 743Last updated and verified on Thu Apr 11, 2019. 744 745 imapsync : https://github.com/imapsync/imapsync 746 (this is an imapsync copy, sometimes delayed, 747 with --noreleasecheck by default since release 1.592, 2014/05/22) 748 imap_tools : https://web.archive.org/web/20161228145952/http://www.athensfbc.com/imap_tools/ 749 The imap_tools code is now at 750 https://github.com/andrewnimmo/rick-sanders-imap-tools 751 imaputils : https://github.com/mtsatsenko/imaputils (very old imap_tools fork) 752 Doveadm-Sync : https://wiki2.dovecot.org/Tools/Doveadm/Sync ( Dovecot sync tool ) 753 davmail : http://davmail.sourceforge.net/ 754 offlineimap : http://offlineimap.org/ 755 mbsync : http://isync.sourceforge.net/ 756 mailsync : http://mailsync.sourceforge.net/ 757 mailutil : http://www.washington.edu/imap/ part of the UW IMAP tookit. 758 imaprepl : https://bl0rg.net/software/ http://freecode.com/projects/imap-repl/ 759 imapcopy (Pascal): http://www.ardiehl.de/imapcopy/ 760 imapcopy (Java) : https://code.google.com/archive/p/imapcopy/ 761 imapsize : http://www.broobles.com/imapsize/ 762 migrationtool : http://sourceforge.net/projects/migrationtool/ 763 imapmigrate : http://sourceforge.net/projects/cyrus-utils/ 764 larch : https://github.com/rgrove/larch (derived from wonko_imapsync, good at Gmail) 765 wonko_imapsync : http://wonko.com/article/554 (superseded by larch) 766 pop2imap : http://www.linux-france.org/prj/pop2imap/ (I wrote that too) 767 exchange-away : http://exchange-away.sourceforge.net/ 768 SyncBackPro : http://www.2brightsparks.com/syncback/sbpro.html 769 ImapSyncClient : https://github.com/ridaamirini/ImapSyncClient 770 MailStore : https://www.mailstore.com/en/products/mailstore-home/ 771 mnIMAPSync : https://github.com/manusa/mnIMAPSync 772 imap-upload : http://imap-upload.sourceforge.net/ 773 (a tool for uploading a local mbox file to IMAP4 server) 774 775=head1 HISTORY 776 777I initially wrote imapsync in July 2001 because an enterprise, 778basystemes, paid me to install a new imap server 779without losing huge old mailboxes located in a far 780away remote imap server, accessible by an 781often broken low-bandwidth ISDN link. 782 783I had to verify every mailbox was well transferred, all folders, all messages, 784without wasting bandwidth or creating duplicates upon resyncs. The design was 785made with the beautiful rsync command in mind. 786 787Imapsync started its life as a patch of the copy_folder.pl 788script. The script copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl 789module tarball source (more precisely in the examples/ directory of the 790Mail-IMAPClient tarball). 791 792So many happened since then that I wonder 793if it remains any lines of the original 794copy_folder.pl in imapsync source code. 795 796 797=cut 798 799 800# use pragmas 801# 802 803use strict ; 804use warnings ; 805use Carp ; 806use Data::Dumper ; 807use Digest::HMAC_SHA1 qw( hmac_sha1 hmac_sha1_hex ) ; 808use Digest::MD5 qw( md5 md5_hex md5_base64 ) ; 809use English qw( -no_match_vars ) ; 810use Errno qw(EAGAIN EPIPE ECONNRESET) ; 811use Fcntl ; 812use File::Basename ; 813use File::Copy::Recursive ; 814use File::Glob qw( :glob ) ; 815use File::Path qw( mkpath rmtree ) ; 816use File::Spec ; 817use File::stat ; 818use Getopt::Long ( ) ; 819use IO::File ; 820use IO::Socket qw( :crlf SOL_SOCKET SO_KEEPALIVE ) ; 821use IO::Socket::INET6 ; 822use IO::Socket::SSL ; 823use IO::Tee ; 824use IPC::Open3 'open3' ; 825use Mail::IMAPClient 3.30 ; 826use MIME::Base64 ; 827use Pod::Usage qw(pod2usage) ; 828use POSIX qw(uname SIGALRM) ; 829use Sys::Hostname ; 830use Term::ReadKey ; 831use Test::More ; 832use Time::HiRes qw( time sleep ) ; 833use Time::Local ; 834use Unicode::String ; 835use Cwd ; 836use Readonly ; 837use Sys::MemInfo ; 838use Regexp::Common ; 839use Text::ParseWords; 840use File::Tail ; 841 842local $OUTPUT_AUTOFLUSH = 1 ; 843 844# constants 845 846# Let us do like sysexits.h 847# /usr/include/sysexits.h 848# and https://www.tldp.org/LDP/abs/html/exitcodes.html 849 850# Should avoid 2 126 127 128..128+64=192 255 851# Should use 0 1 3..125 193..254 852 853Readonly my $EX_OK => 0 ; #/* successful termination */ 854Readonly my $EX_USAGE => 64 ; #/* command line usage error */ 855#Readonly my $EX_DATAERR => 65 ; #/* data format error */ 856Readonly my $EX_NOINPUT => 66 ; #/* cannot open input */ 857#Readonly my $EX_NOUSER => 67 ; #/* addressee unknown */ 858#Readonly my $EX_NOHOST => 68 ; #/* host name unknown */ 859Readonly my $EX_UNAVAILABLE => 69 ; #/* service unavailable */ 860Readonly my $EX_SOFTWARE => 70 ; #/* internal software error */ 861#Readonly my $EX_OSERR => 71 ; #/* system error (e.g., can't fork) */ 862#Readonly my $EX_OSFILE => 72 ; #/* critical OS file missing */ 863#Readonly my $EX_CANTCREAT => 73 ; #/* can't create (user) output file */ 864#Readonly my $EX_IOERR => 74 ; #/* input/output error */ 865#Readonly my $EX_TEMPFAIL => 75 ; #/* temp failure; user is invited to retry */ 866#Readonly my $EX_PROTOCOL => 76 ; #/* remote error in protocol */ 867#Readonly my $EX_NOPERM => 77 ; #/* permission denied */ 868#Readonly my $EX_CONFIG => 78 ; #/* configuration error */ 869 870# Mine 871Readonly my $EXIT_CATCH_ALL => 1 ; # Any other error 872Readonly my $EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num 873Readonly my $EXIT_PID_FILE_ERROR => 8 ; 874Readonly my $EXIT_CONNECTION_FAILURE => 10 ; 875Readonly my $EXIT_TLS_FAILURE => 12 ; 876Readonly my $EXIT_AUTHENTICATION_FAILURE => 16 ; 877Readonly my $EXIT_SUBFOLDER1_NO_EXISTS => 21 ; 878Readonly my $EXIT_WITH_ERRORS => 111 ; 879Readonly my $EXIT_WITH_ERRORS_MAX => 112 ; 880 881 882Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API 883 884 885Readonly my %EXIT_TXT => ( 886 $EX_OK => 'EX_OK: successful termination', 887 $EX_USAGE => 'EX_USAGE: command line usage error', 888 $EX_NOINPUT => 'EX_NOINPUT: cannot open input', 889 $EX_UNAVAILABLE => 'EX_UNAVAILABLE: service unavailable', 890 $EX_SOFTWARE => 'EX_SOFTWARE: internal software error', 891 892 $EXIT_CATCH_ALL => 'EXIT_CATCH_ALL', 893 $EXIT_BY_SIGNAL => 'EXIT_BY_SIGNAL', 894 $EXIT_PID_FILE_ERROR => 'EXIT_PID_FILE_ERROR' , 895 $EXIT_CONNECTION_FAILURE => 'EXIT_CONNECTION_FAILURE', 896 $EXIT_TLS_FAILURE => 'EXIT_TLS_FAILURE', 897 $EXIT_AUTHENTICATION_FAILURE => 'EXIT_AUTHENTICATION_FAILURE', 898 $EXIT_SUBFOLDER1_NO_EXISTS => 'EXIT_SUBFOLDER1_NO_EXISTS', 899 $EXIT_WITH_ERRORS => 'EXIT_WITH_ERRORS', 900 $EXIT_WITH_ERRORS_MAX => 'EXIT_WITH_ERRORS_MAX', 901 $EXIT_TESTS_FAILED => 'EXIT_TESTS_FAILED', 902) ; 903 904 905 906 907Readonly my $DEFAULT_LOGDIR => 'LOG_imapsync' ; 908 909Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors. 910Readonly my $ERRORS_MAX_CGI => 20 ; # exit after 20 errors in CGI context. 911 912 913 914Readonly my $INTERVAL_TO_EXIT => 2 ; # interval max to exit instead of reconnect 915 916Readonly my $SPLIT => 100 ; # By default, 100 at a time, not more. 917Readonly my $SPLIT_FACTOR => 10 ; # init_imap() calls Maxcommandlength( $SPLIT_FACTOR * $split ) 918 # which means default Maxcommandlength is 10*100 = 1000 characters ; 919 920Readonly my $IMAP_PORT => 143 ; # Well know port for IMAP 921Readonly my $IMAP_SSL_PORT => 993 ; # Well know port for IMAP over SSL 922 923Readonly my $LAST => -1 ; 924Readonly my $MINUS_ONE => -1 ; 925Readonly my $MINUS_TWO => -2 ; 926 927Readonly my $RELEASE_NUMBER_EXAMPLE_1 => '1.351' ; 928Readonly my $RELEASE_NUMBER_EXAMPLE_2 => 42.4242 ; 929 930Readonly my $TCP_PING_TIMEOUT => 5 ; 931Readonly my $DEFAULT_TIMEOUT => 120 ; 932Readonly my $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND => 3 ; 933Readonly my $DEFAULT_UIDNEXT => 999_999 ; 934Readonly my $DEFAULT_BUFFER_SIZE => 4096 ; 935 936Readonly my $MAX_SLEEP => 2 ; # 2 seconds max for limiting too long sleeps from --maxbytespersecond and --maxmessagespersecond 937 938Readonly my $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12 => 3600 ; 939 940Readonly my $PERMISSION_FILTER => 7777 ; 941 942Readonly my $KIBI => 1024 ; 943 944Readonly my $NUMBER_10 => 10 ; 945Readonly my $NUMBER_42 => 42 ; 946Readonly my $NUMBER_100 => 100 ; 947Readonly my $NUMBER_200 => 200 ; 948Readonly my $NUMBER_300 => 300 ; 949Readonly my $NUMBER_123456 => 123456 ; 950Readonly my $NUMBER_654321 => 654321 ; 951 952Readonly my $NUMBER_20_000 => 20_000 ; 953 954Readonly my $QUOTA_PERCENT_LIMIT => 90 ; 955 956Readonly my $NUMBER_104_857_600 => 104_857_600 ; 957 958Readonly my $SIZE_MAX_STR => 64 ; 959 960Readonly my $NB_SECONDS_IN_A_DAY => 86_400 ; 961 962Readonly my $STD_CHAR_PER_LINE => 80 ; 963 964Readonly my $TRUE => 1 ; 965Readonly my $FALSE => 0 ; 966 967Readonly my $LAST_RESSORT_SEPARATOR => q{/} ; 968 969Readonly my $CGI_TMPDIR_TOP => '/var/tmp/imapsync_cgi' ; 970Readonly my $CGI_HASHFILE => '/var/tmp/imapsync_hash' ; 971Readonly my $UMASK_PARANO => '0077' ; 972 973Readonly my $STR_use_releasecheck => q{Check if a new imapsync release is available by adding --releasecheck} ; 974 975Readonly my $GMAIL_MAXSIZE => 35_651_584 ; 976 977 978# if ( 'MSWin32' eq $OSNAME ) 979# if ( 'darwin' eq $OSNAME ) 980# if ( 'linux' eq $OSNAME ) 981 982 983 984# global variables 985# Currently working to finish with only $sync 986# Not finished yet... 987 988my( 989 $sync, 990 $debugimap, $debugimap1, $debugimap2, $debugcontent, $debugflags, 991 $debuglist, $debugdev, $debugmaxlinelength, $debugcgi, 992 $domain1, $domain2, 993 @include, @exclude, @folderrec, 994 @folderfirst, @folderlast, 995 $prefix1, $prefix2, 996 @regexmess, @regexflag, @skipmess, @pipemess, $pipemesscheck, 997 $flagscase, $filterflags, $syncflagsaftercopy, 998 $syncinternaldates, 999 $idatefromheader, 1000 $syncacls, 1001 $fastio1, $fastio2, 1002 $minsize, $maxage, $minage, 1003 $search, $search1, $search2, 1004 $skipheader, @useheader, 1005 $skipsize, $allowsizemismatch, $foldersizes, $foldersizesatend, $buffersize, 1006 1007 1008 $authmd5, $authmd51, $authmd52, 1009 $subscribed, $subscribe, $subscribeall, 1010 $help, 1011 $justbanner, 1012 $fast, 1013 1014 $nb_msg_skipped_dry_mode, 1015 $h1_nb_msg_duplicate, 1016 $h2_nb_msg_duplicate, 1017 $h2_nb_msg_noheader, 1018 1019 $h2_nb_msg_deleted, 1020 1021 $h1_bytes_processed, 1022 1023 $h1_nb_msg_start, $h1_bytes_start, 1024 $h2_nb_msg_start, $h2_bytes_start, 1025 $h1_nb_msg_end, $h1_bytes_end, 1026 $h2_nb_msg_end, $h2_bytes_end, 1027 1028 $timeout, 1029 $timestart_int, 1030 $timebefore, 1031 $uid1, $uid2, 1032 $authuser1, $authuser2, 1033 $proxyauth1, $proxyauth2, 1034 $authmech1, $authmech2, 1035 $split1, $split2, 1036 $reconnectretry1, $reconnectretry2, 1037 $max_msg_size_in_bytes, 1038 $modulesversion, 1039 $delete2folders, $delete2foldersonly, $delete2foldersbutnot, 1040 $usecache, $debugcache, $cacheaftercopy, 1041 $wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess, 1042 $checkmessageexists, 1043 $messageidnodomain, 1044 $fixInboxINBOX, 1045 $maxlinelength, $maxlinelengthcmd, 1046 $minmaxlinelength, 1047 $uidnext_default, 1048 $fixcolonbug, 1049 $create_folder_old, 1050 $skipcrossduplicates, $debugcrossduplicates, 1051 $disarmreadreceipts, 1052 $mixfolders, $skipemptyfolders, 1053 $fetch_hash_set, 1054) ; 1055 1056 1057# main program 1058# global variables initialization 1059 1060# I'm currently removing all global variables except $sync 1061# passing each of them under $sync->{variable_name} 1062 1063$sync->{timestart} = time ; # Is a float because of use Time::HiRres 1064 1065$sync->{rcs} = q{$Id: imapsync,v 1.945 2019/06/26 19:30:56 gilles Exp gilles $} ; 1066 1067$sync->{ memory_consumption_at_start } = memory_consumption( ) || 0 ; 1068 1069 1070my @loadavg = loadavg( ) ; 1071 1072$sync->{cpu_number} = cpu_number( ) ; 1073$sync->{loaddelay} = load_and_delay( $sync->{cpu_number}, @loadavg ) ; 1074$sync->{loadavg} = join( q{ }, $loadavg[ 0 ] ) 1075 . " on $sync->{cpu_number} cores and " 1076 . ram_memory_info( ) ; 1077 1078 1079 1080$sync->{ total_bytes_transferred } = 0 ; 1081$sync->{ total_bytes_skipped } = 0 ; 1082$sync->{ nb_msg_transferred } = 0 ; 1083$sync->{ nb_msg_skipped } = $nb_msg_skipped_dry_mode = 0 ; 1084$sync->{ h1_nb_msg_deleted } = 0 ; 1085$h2_nb_msg_deleted = 0 ; 1086$h1_nb_msg_duplicate = 0 ; 1087$h2_nb_msg_duplicate = 0 ; 1088$sync->{ h1_nb_msg_noheader } = 0 ; 1089$h2_nb_msg_noheader = 0 ; 1090 1091 1092$h1_nb_msg_start = $h1_bytes_start = 0 ; 1093$h2_nb_msg_start = $h2_bytes_start = 0 ; 1094$sync->{ h1_nb_msg_processed } = $h1_bytes_processed = 0 ; 1095 1096$sync->{ h2_nb_msg_crossdup } = 0 ; 1097 1098#$h1_nb_msg_end = $h1_bytes_end = 0 ; 1099#$h2_nb_msg_end = $h2_bytes_end = 0 ; 1100 1101$sync->{nb_errors} = 0; 1102$max_msg_size_in_bytes = 0; 1103 1104my %month_abrev = ( 1105 Jan => '00', 1106 Feb => '01', 1107 Mar => '02', 1108 Apr => '03', 1109 May => '04', 1110 Jun => '05', 1111 Jul => '06', 1112 Aug => '07', 1113 Sep => '08', 1114 Oct => '09', 1115 Nov => '10', 1116 Dec => '11', 1117); 1118 1119 1120my $cgidir ; 1121 1122# Just create a CGI object if under cgi context only. 1123# Needed for the get_options() call 1124cgibegin( $sync ) ; 1125 1126# In cgi context, printing must start by the header so we delay other prints by using output() storage 1127my $options_good = get_options( $sync, @ARGV ) ; 1128# Is it the first myprint? 1129docker_context( $sync ) ; 1130cgibuildheader( $sync ) ; 1131 1132myprint( output( $sync ) ) ; 1133output_reset_with( $sync ) ; 1134 1135# Old place for cgiload( $sync ) ; 1136 1137# don't go on if options are not all known. 1138if ( ! defined $options_good ) { exit $EX_USAGE ; } 1139 1140# If you want releasecheck not to be done by default (like the github maintainer), 1141# then just uncomment the first "$sync->{releasecheck} =" line, the line ending with "0 ;", 1142# the second line (ending with "1 ;") can then stay active or be commented, 1143# the result will be the same: no releasecheck by default (because 0 is then the defined value). 1144 1145#$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 0 ; 1146$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 1 ; 1147 1148# just the version 1149if ( $sync->{ version } ) { 1150 myprint( imapsync_version( $sync ), "\n" ) ; 1151 exit 0 ; 1152} 1153 1154$sync->{debugenv} and printenv( $sync ) ; # if option --debugenv 1155load_modules( ) ; 1156 1157# after_get_options call usage and exit if --help or options were not well got 1158after_get_options( $sync, $options_good ) ; 1159 1160 1161# Under CGI environment, fix caveat emptor potential issues 1162cgisetcontext( $sync ) ; 1163 1164# --gmail --gmail --exchange --office etc. 1165easyany( $sync ) ; 1166 1167$sync->{ sanitize } = defined $sync->{ sanitize } ? $sync->{ sanitize } : 1 ; 1168sanitize( $sync ) ; 1169 1170$sync->{ tmpdir } ||= File::Spec->tmpdir( ) ; 1171 1172# Unit tests 1173testsexit( $sync ) ; 1174 1175# init live varaiables 1176testslive( $sync ) if ( $sync->{testslive} ) ; 1177testslive6( $sync ) if ( $sync->{testslive6} ) ; 1178 1179# 1180 1181$sync->{pidfile} = defined $sync->{pidfile} ? $sync->{pidfile} : $sync->{ tmpdir } . '/imapsync.pid' ; 1182$sync->{pidfilelocking} = defined $sync->{pidfilelocking} ? $sync->{pidfilelocking} : 0 ; 1183 1184# old abort place 1185 1186# Unix signals 1187@{ $sync->{ sigexit } } = ( defined( $sync->{ sigexit } ) ) ? @{ $sync->{ sigexit } } : ( 'QUIT', 'TERM' ) ; 1188@{ $sync->{ sigreconnect } } = ( defined( $sync->{ sigreconnect } ) ) ? @{ $sync->{ sigreconnect } } : ( 'INT' ) ; 1189@{ $sync->{ sigprint } } = ( defined( $sync->{ sigprint } ) ) ? @{ $sync->{ sigprint } } : ( 'HUP' ) ; 1190@{ $sync->{ sigignore } } = ( defined( $sync->{ sigignore } ) ) ? @{ $sync->{ sigignore } } : ( ) ; 1191 1192local %SIG = %SIG ; 1193sig_install( $sync, 'catch_exit', @{ $sync->{ sigexit } } ) ; 1194sig_install( $sync, 'catch_reconnect', @{ $sync->{ sigreconnect } } ) ; 1195sig_install( $sync, 'catch_print', @{ $sync->{ sigprint } } ) ; 1196# --sigignore can override sigexit, sigreconnect and sigprint (for the same signals only) 1197sig_install( $sync, 'catch_ignore', @{ $sync->{ sigignore } } ) ; 1198 1199sig_install_toggle_sleep( $sync ) ; 1200 1201 1202$sync->{log} = defined $sync->{log} ? $sync->{log} : 1 ; 1203$sync->{errorsdump} = defined $sync->{errorsdump} ? $sync->{errorsdump} : 1 ; 1204$sync->{errorsmax} = defined $sync->{errorsmax} ? $sync->{errorsmax} : $ERRORS_MAX ; 1205 1206# log and output 1207if ( $sync->{log} ) { 1208 setlogfile( $sync ) ; 1209 teelaunch( $sync ) ; 1210 # now $sync->{tee} is a filehandle to STDOUT and the logfile 1211} 1212# STDERR goes to the same place: LOG and STDOUT (if logging is on) 1213$sync->{tee} and local *STDERR = *${$sync->{tee}}{IO} ; 1214 1215 1216 1217$timestart_int = int( $sync->{timestart} ) ; 1218$timebefore = $sync->{timestart} ; 1219 1220 1221my $timestart_str = localtime( $sync->{timestart} ) ; 1222 1223# The prints in the log starts here 1224 1225myprint( localhost_info( $sync ), "\n" ) ; 1226myprint( "Transfer started at $timestart_str\n" ) ; 1227myprint( "PID is $PROCESS_ID my PPID is ", mygetppid( ), "\n" ) ; 1228myprint( "Log file is $sync->{logfile} ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) if ( $sync->{log} ) ; 1229myprint( "Load is " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $sync->{cpu_number} cores\n" ) ; 1230#myprintf( "Memory consumption so far: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; 1231myprint( 'Current directory is ' . getcwd( ) . "\n" ) ; 1232myprint( 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ; 1233myprint( 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ; 1234 1235$modulesversion = defined $modulesversion ? $modulesversion : 1 ; 1236 1237my $warn_release = ( $sync->{releasecheck} ) ? check_last_release( ) : $STR_use_releasecheck ; 1238 1239 1240$wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1; 1241 1242# Activate --usecache if --useuid is set and no --nousecache 1243$usecache = 1 if ( $useuid and ( ! defined $usecache ) ) ; 1244$cacheaftercopy = 1 if ( $usecache and ( ! defined $cacheaftercopy ) ) ; 1245 1246$sync->{ checkselectable } = defined $sync->{ checkselectable } ? $sync->{ checkselectable } : 1 ; 1247$sync->{ checkfoldersexist } = defined $sync->{ checkfoldersexist } ? $sync->{ checkfoldersexist } : 1 ; 1248$checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ; 1249$sync->{ expungeaftereach } = defined $sync->{ expungeaftereach } ? $sync->{ expungeaftereach } : 1 ; 1250 1251# abletosearch is on by default 1252$sync->{abletosearch} = defined $sync->{abletosearch} ? $sync->{abletosearch} : 1 ; 1253$sync->{abletosearch1} = defined $sync->{abletosearch1} ? $sync->{abletosearch1} : $sync->{abletosearch} ; 1254$sync->{abletosearch2} = defined $sync->{abletosearch2} ? $sync->{abletosearch2} : $sync->{abletosearch} ; 1255$checkmessageexists = 0 if ( not $sync->{abletosearch1} ) ; 1256 1257 1258$sync->{showpasswords} = defined $sync->{showpasswords} ? $sync->{showpasswords} : 0 ; 1259$sync->{ fixslash2 } = defined $sync->{ fixslash2 } ? $sync->{ fixslash2 } : 1 ; 1260$fixInboxINBOX = defined $fixInboxINBOX ? $fixInboxINBOX : 1 ; 1261$create_folder_old = defined $create_folder_old ? $create_folder_old : 0 ; 1262$mixfolders = defined $mixfolders ? $mixfolders : 1 ; 1263$sync->{automap} = defined $sync->{automap} ? $sync->{automap} : 0 ; 1264 1265$sync->{ delete2duplicates } = 1 if ( $sync->{ delete2 } and ( ! defined $sync->{ delete2duplicates } ) ) ; 1266 1267$sync->{maxmessagespersecond} = defined $sync->{maxmessagespersecond} ? $sync->{maxmessagespersecond} : 0 ; 1268$sync->{maxbytespersecond} = defined $sync->{maxbytespersecond} ? $sync->{maxbytespersecond} : 0 ; 1269 1270$sync->{sslcheck} = defined $sync->{sslcheck} ? $sync->{sslcheck} : 1 ; 1271 1272myprint( banner_imapsync( $sync, @ARGV ) ) ; 1273 1274myprint( "Temp directory is $sync->{ tmpdir } ( to change it use --tmpdir dirpath )\n" ) ; 1275 1276myprint( output( $sync ) ) ; 1277output_reset_with( $sync ) ; 1278 1279do_valid_directory( $sync->{ tmpdir } ) || croak "Error creating tmpdir $sync->{ tmpdir } : $OS_ERROR" ; 1280 1281remove_pidfile_not_running( $sync->{pidfile} ) ; 1282 1283# if another imapsync is running then tail -f its logfile and exit 1284# useful in cgi context 1285if ( $sync->{tail} and tail( $sync ) ) 1286{ 1287 myprint( "Tail -f finished. Now finishing myself processus $PROCESS_ID\n" ) ; 1288 exit_clean( $sync, $EX_OK ) ; 1289 exit $EX_OK ; 1290} 1291 1292if ( ! write_pidfile( $sync ) ) { 1293 myprint( "Exiting with return value $EXIT_PID_FILE_ERROR ($EXIT_TXT{$EXIT_PID_FILE_ERROR})\n" ) ; 1294 exit $EXIT_PID_FILE_ERROR ; 1295} 1296 1297 1298# New place for abort 1299# abort before simulong in order to be able to abort a simulong sync 1300if ( $sync->{ abort } ) 1301{ 1302 abort( $sync ) ; 1303} 1304 1305# simulong is just a loop printing some lines for xx seconds with option "--simulong xx". 1306if ( $sync->{ simulong } ) 1307{ 1308 simulong( $sync->{ simulong } ) ; 1309} 1310 1311 1312# New place for cgiload 2019_03_03 1313# because I want to log it 1314# Can break here if load is too heavy 1315cgiload( $sync ) ; 1316 1317 1318$fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ; 1319 1320if ( $usecache and $fixcolonbug ) { tmpdir_fix_colon_bug( $sync ) } ; 1321 1322$modulesversion and myprint( "Modules version list:\n", modulesversion(), "( use --no-modulesversion to turn off printing this Perl modules list )\n" ) ; 1323 1324 1325check_lib_version( $sync ) or 1326 croak "imapsync needs perl lib Mail::IMAPClient release 3.30 or superior.\n"; 1327 1328 1329exit_clean( $sync, $EX_OK ) if ( $justbanner ) ; 1330 1331# turn on RFC standard flags correction like \SEEN -> \Seen 1332$flagscase = defined $flagscase ? $flagscase : 1 ; 1333 1334# Use PERMANENTFLAGS if available 1335$filterflags = defined $filterflags ? $filterflags : 1 ; 1336 1337# sync flags just after an APPEND, some servers ignore the flags given in the APPEND 1338# like MailEnable IMAP server. 1339# Off by default since it takes time. 1340$syncflagsaftercopy = defined $syncflagsaftercopy ? $syncflagsaftercopy : 0 ; 1341 1342# update flags on host2 for already transferred messages 1343$sync->{resyncflags} = defined $sync->{resyncflags} ? $sync->{resyncflags} : 1 ; 1344if ( $sync->{resyncflags} ) { 1345 myprint( "Info: will resync flags for already transferred messages. Use --noresyncflags to not resync flags.\n" ) ; 1346}else{ 1347 myprint( "Info: will not resync flags for already transferred messages. Use --resyncflags to resync flags.\n" ) ; 1348} 1349 1350 1351sslcheck( $sync ) ; 1352#print Data::Dumper->Dump( [ \$sync ] ) ; 1353 1354$split1 ||= $SPLIT ; 1355$split2 ||= $SPLIT ; 1356 1357#$sync->{host1} || missing_option( $sync, '--host1' ) ; 1358$sync->{port1} ||= ( $sync->{ssl1} ) ? $IMAP_SSL_PORT : $IMAP_PORT ; 1359 1360#$sync->{host2} || missing_option( $sync, '--host2' ) ; 1361$sync->{port2} ||= ( $sync->{ssl2} ) ? $IMAP_SSL_PORT : $IMAP_PORT ; 1362 1363$debugimap1 = $debugimap2 = 1 if ( $debugimap ) ; 1364$sync->{ debug } = 1 if ( $debugimap1 or $debugimap2 ) ; 1365 1366# By default, don't take size to compare 1367$skipsize = (defined $skipsize) ? $skipsize : 1; 1368 1369$uid1 = defined $uid1 ? $uid1 : 1; 1370$uid2 = defined $uid2 ? $uid2 : 1; 1371 1372$subscribe = defined $subscribe ? $subscribe : 1; 1373 1374# Allow size mismatch by default 1375$allowsizemismatch = defined $allowsizemismatch ? $allowsizemismatch : 1; 1376 1377 1378if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) { 1379 $delete2folders = 1 ; 1380} 1381 1382 1383my $SSL_VERIFY_POLICY ; 1384my %SSL_VERIFY_STR ; 1385 1386Readonly $SSL_VERIFY_POLICY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ; 1387Readonly %SSL_VERIFY_STR => ( 1388 IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE, ie, do not check the certificate server.' , 1389 IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER, ie, check the certificate server' , 1390) ; 1391 1392$IO::Socket::SSL::DEBUG = defined( $sync->{debugssl} ) ? $sync->{debugssl} : 1 ; 1393 1394 1395if ( $sync->{ssl1} or $sync->{ssl2} or $sync->{tls1} or $sync->{tls2}) { 1396 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" ) ; 1397} 1398 1399if ( $sync->{ssl1} ) { 1400 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} ) ; 1401 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" ) ; 1402} 1403 1404if ( $sync->{ssl2} ) { 1405 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} ) ; 1406 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" ) ; 1407} 1408 1409 1410if ( $sync->{justconnect} 1411 or not $sync->{user1} 1412 or not $sync->{user2} 1413 or not $sync->{host1} 1414 or not $sync->{host2} 1415 ) 1416{ 1417 my $justconnect = justconnect( $sync ) ; 1418 myprint( debugmemory( $sync, " after justconnect() call" ) ) ; 1419 exit_clean( $sync, $EX_OK, "Exiting after a justconnect on host(s): $justconnect\n" ) ; 1420} 1421 1422 1423#$sync->{user1} || missing_option( $sync, '--user1' ) ; 1424#$sync->{user2} || missing_option( $sync, '--user2' ) ; 1425 1426$syncinternaldates = defined $syncinternaldates ? $syncinternaldates : 1; 1427 1428# Turn on expunge if there is not explicit option --noexpunge1 and option 1429# --delete1 is given. 1430# Done because --delete1 --noexpunge1 is very dangerous on the second run: 1431# the Deleted flag is then synced to all previously transferred messages. 1432# So --delete1 implies --expunge1 is a better usability default behavior. 1433if ( $sync->{ delete1 } ) { 1434 if ( ! defined $sync->{ expunge1 } ) { 1435 myprint( "Info: turning on --expunge1 because --delete1 --noexpunge1 is very dangerous on the second run.\n" ) ; 1436 $sync->{ expunge1 } = 1 ; 1437 } 1438 myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ; 1439} 1440 1441if ( $sync->{ uidexpunge2 } and not Mail::IMAPClient->can( 'uidexpunge' ) ) { 1442 myprint( "Failure: uidexpunge not supported (IMAPClient release < 3.17), use nothing or --expunge2 instead\n" ) ; 1443 exit_clean( $sync, $EX_SOFTWARE ) ; 1444} 1445 1446if ( ( $sync->{ delete2 } or $sync->{ delete2duplicates } ) and not defined $sync->{ uidexpunge2 } ) { 1447 if ( Mail::IMAPClient->can( 'uidexpunge' ) ) { 1448 myprint( "Info: will act as --uidexpunge2\n" ) ; 1449 $sync->{ uidexpunge2 } = 1 ; 1450 }elsif ( not defined $sync->{ expunge2 } ) { 1451 myprint( "Info: will act as --expunge2 (no uidexpunge support)\n" ) ; 1452 $sync->{ expunge2 } = 1 ; 1453 } 1454} 1455 1456if ( $sync->{ delete1 } and $sync->{ delete2 } ) { 1457 myprint( "Warning: using --delete1 and --delete2 together is almost always a bad idea, exiting imapsync\n" ) ; 1458 exit_clean( $sync, $EX_USAGE ) ; 1459} 1460 1461if ( $idatefromheader ) { 1462 myprint( 'Turned ON idatefromheader, ', 1463 "will set the internal dates on host2 from the 'Date:' header line.\n" ) ; 1464 $syncinternaldates = 0 ; 1465} 1466 1467if ( $syncinternaldates ) { 1468 myprint( 'Info: turned ON syncinternaldates, ', 1469 "will set the internal dates (arrival dates) on host2 same as host1.\n" ) ; 1470}else{ 1471 myprint( "Info: turned OFF syncinternaldates\n" ) ; 1472} 1473 1474if ( defined $authmd5 and $authmd5 ) { 1475 $authmd51 = 1 ; 1476 $authmd52 = 1 ; 1477} 1478 1479if ( defined $authmd51 and $authmd51 ) { 1480 $authmech1 ||= 'CRAM-MD5'; 1481} 1482else{ 1483 $authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN'; 1484} 1485 1486if ( defined $authmd52 and $authmd52 ) { 1487 $authmech2 ||= 'CRAM-MD5'; 1488} 1489else{ 1490 $authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN'; 1491} 1492 1493$authmech1 = uc $authmech1; 1494$authmech2 = uc $authmech2; 1495 1496if (defined $proxyauth1 && !$authuser1) { 1497 missing_option( $sync, 'With --proxyauth1, --authuser1' ) ; 1498} 1499 1500if (defined $proxyauth2 && !$authuser2) { 1501 missing_option( $sync, 'With --proxyauth2, --authuser2' ) ; 1502} 1503 1504$authuser1 ||= $sync->{user1}; 1505$authuser2 ||= $sync->{user2}; 1506 1507myprint( "Host1: will try to use $authmech1 authentication on host1\n") ; 1508myprint( "Host2: will try to use $authmech2 authentication on host2\n") ; 1509 1510$timeout = defined $timeout ? $timeout : $DEFAULT_TIMEOUT ; 1511 1512$sync->{h1}->{timeout} = defined $sync->{h1}->{timeout} ? $sync->{h1}->{timeout} : $timeout ; 1513myprint( "Host1: imap connection timeout is $sync->{h1}->{timeout} seconds\n") ; 1514$sync->{h2}->{timeout} = defined $sync->{h2}->{timeout} ? $sync->{h2}->{timeout} : $timeout ; 1515myprint( "Host2: imap connection timeout is $sync->{h2}->{timeout} seconds\n" ) ; 1516 1517$syncacls = defined $syncacls ? $syncacls : 0 ; 1518 1519# No folders sizes if --justfolders, unless really wanted. 1520if ( $sync->{ justfolders } and not defined $foldersizes and not $sync->{ justfoldersizes } ) { $foldersizes = 0 ; $foldersizesatend = 1 ; } 1521 1522$foldersizes = ( defined $foldersizes ) ? $foldersizes : 1 ; 1523$foldersizesatend = ( defined $foldersizesatend ) ? $foldersizesatend : $foldersizes ; 1524 1525$fastio1 = defined $fastio1 ? $fastio1 : 0 ; 1526$fastio2 = defined $fastio2 ? $fastio2 : 0 ; 1527 1528$reconnectretry1 = defined $reconnectretry1 ? $reconnectretry1 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; 1529$reconnectretry2 = defined $reconnectretry2 ? $reconnectretry2 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; 1530 1531# Since select_msgs() returns no messages when uidnext does not return something 1532# then $uidnext_default is never used. So I have to remove it. 1533$uidnext_default = $DEFAULT_UIDNEXT ; 1534 1535if ( ! @useheader ) { @useheader = qw( Message-Id Received ) ; } 1536 1537my %useheader ; 1538 1539# Make a hash %useheader of each --useheader 'key' in uppercase 1540for ( @useheader ) { $useheader{ uc $_ } = undef } ; 1541 1542#myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ; 1543#exit ; 1544 1545myprint( "Host1: IMAP server [$sync->{host1}] port [$sync->{port1}] user [$sync->{user1}]\n" ) ; 1546myprint( "Host2: IMAP server [$sync->{host2}] port [$sync->{port2}] user [$sync->{user2}]\n" ) ; 1547 1548get_password1( $sync ) ; 1549get_password2( $sync ) ; 1550 1551 1552$sync->{dry_message} = q{} ; 1553if( $sync->{dry} ) { 1554 $sync->{dry_message} = "\t(not really since --dry mode)" ; 1555} 1556 1557$search1 ||= $search if ( $search ) ; 1558$search2 ||= $search if ( $search ) ; 1559 1560if ( $disarmreadreceipts ) { 1561 push @regexmess, q{s{\A((?:[^\n]+\r\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims} ; 1562} 1563 1564$pipemesscheck = ( defined $pipemesscheck ) ? $pipemesscheck : 1 ; 1565 1566if ( @pipemess and $pipemesscheck ) { 1567 myprint( 'Checking each --pipemess command, ' 1568 . join( q{, }, @pipemess ) 1569 . ", with an space string. ( Can avoid this check with --nopipemesscheck )\n" ) ; 1570 my $string = pipemess( q{ }, @pipemess ) ; 1571 # string undef means something was bad. 1572 if ( not ( defined $string ) ) { 1573 exit_clean( $sync, $EX_USAGE, "Error: one of --pipemess command is bad, check it\n" ) ; 1574 } 1575 myprint( "Ok with each --pipemess @pipemess\n" ) ; 1576} 1577 1578if ( $maxlinelengthcmd ) { 1579 myprint( "Checking --maxlinelengthcmd command, $maxlinelengthcmd, with an space string.\n" ) ; 1580 my $string = pipemess( q{ }, $maxlinelengthcmd ) ; 1581 # string undef means something was bad. 1582 if ( not ( defined $string ) ) { 1583 exit_clean( $sync, $EX_USAGE, "Error: --maxlinelengthcmd command is bad, check it\n" ) ; 1584 } 1585 myprint( "Ok with --maxlinelengthcmd $maxlinelengthcmd\n" ) ; 1586} 1587 1588if ( @regexmess ) { 1589 my $string = regexmess( q{ } ) ; 1590 myprint( "Checking each --regexmess command with an space string.\n" ) ; 1591 # string undef means one of the eval regex was bad. 1592 if ( not ( defined $string ) ) { 1593 exit_clean( $sync, $EX_USAGE, 'Error: one of --regexmess option is bad, check it' ) ; 1594 } 1595 myprint( "Ok with each --regexmess\n" ) ; 1596} 1597 1598if ( @skipmess ) { 1599 myprint( "Checking each --skipmess command with an space string.\n" ) ; 1600 my $match = skipmess( q{ } ) ; 1601 # match undef means one of the eval regex was bad. 1602 if ( not ( defined $match ) ) { 1603 exit_clean( $sync, $EX_USAGE, 'Error: one of --skipmess option is bad, check it' ) ; 1604 } 1605 myprint( "Ok with each --skipmess\n" ) ; 1606} 1607 1608if ( @regexflag ) { 1609 myprint( "Checking each --regexflag command with an space string.\n" ) ; 1610 my $string = flags_regex( q{ } ) ; 1611 # string undef means one of the eval regex was bad. 1612 if ( not ( defined $string ) ) { 1613 exit_clean( $sync, $EX_USAGE, 'Error: one of --regexflag option is bad, check it' ) ; 1614 } 1615 myprint( "Ok with each --regexflag\n" ) ; 1616} 1617 1618$sync->{imap1} = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $domain1, $sync->{password1}, 1619 $debugimap1, $sync->{h1}->{timeout}, $fastio1, $sync->{ssl1}, $sync->{tls1}, 1620 $authmech1, $authuser1, $reconnectretry1, 1621 $proxyauth1, $uid1, $split1, 'Host1', $sync->{h1}, $sync ) ; 1622 1623$sync->{imap2} = login_imap( $sync->{host2}, $sync->{port2}, $sync->{user2}, $domain2, $sync->{password2}, 1624 $debugimap2, $sync->{h2}->{timeout}, $fastio2, $sync->{ssl2}, $sync->{tls2}, 1625 $authmech2, $authuser2, $reconnectretry2, 1626 $proxyauth2, $uid2, $split2, 'Host2', $sync->{h2}, $sync ) ; 1627 1628 1629$sync->{ debug } and myprint( 'Host1 Buffer I/O: ', $sync->{imap1}->Buffer(), "\n" ) ; 1630$sync->{ debug } and myprint( 'Host2 Buffer I/O: ', $sync->{imap2}->Buffer(), "\n" ) ; 1631 1632 1633if ( ! $sync->{imap1}->IsAuthenticated( ) ) { exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, 'Not authenticated on host1' ) ; } 1634myprint( "Host1: state Authenticated\n" ) ; 1635if ( ! $sync->{imap2}->IsAuthenticated( ) ) { exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, 'Not authenticated on host2' ) ; } 1636myprint( "Host2: state Authenticated\n" ) ; 1637 1638myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $sync->{imap1}->capability() || [] }), "\n" ) ; 1639 1640#myprint( Data::Dumper->Dump( [ $sync->{imap1} ] ) ) ; 1641#myprint( "imap4rev1: " . $sync->{imap1}->imap4rev1() . "\n" ) ; 1642 1643myprint( 'Host2 capability once authenticated: ', join(q{ }, @{ $sync->{imap2}->capability() || [] }), "\n" ) ; 1644 1645 1646# ID on by default since 1.832 1647$sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ; 1648imap_id_stuff( $sync ) ; 1649 1650#quota( $sync, $sync->{imap1}, 'h1' ) ; # quota on host1 is useless and pollute host2 output. 1651quota( $sync, $sync->{imap2}, 'h2' ) ; 1652 1653maxsize_setting( $sync ) ; 1654 1655if ( $sync->{ justlogin } ) { 1656 $sync->{imap1}->logout( ) ; 1657 $sync->{imap2}->logout( ) ; 1658 myprint( "Exiting because of --justlogin\n" ) ; 1659 exit_clean( $sync, $EX_OK ) ; 1660} 1661 1662 1663# 1664# Folder stuff 1665# 1666 1667my ( 1668 @h1_folders_all , %h1_folders_all , @h1_folders_wanted , %requested_folder , 1669 %h1_subscribed_folder , %h2_subscribed_folder , 1670 @h2_folders_all , %h2_folders_all , %h2_folders_all_UPPER , 1671 @h2_folders_from_1_wanted , %h2_folders_from_1_wanted , 1672 %h2_folders_from_1_several , 1673 %h2_folders_from_1_all , 1674) ; 1675 1676my $h1_folders_wanted_nb = 0 ; 1677my $h1_folders_wanted_ct = 0 ; # counter of folders done. 1678 1679# All folders on host1 and host2 1680 1681@h1_folders_all = sort $sync->{imap1}->folders( ) ; 1682@h2_folders_all = sort $sync->{imap2}->folders( ) ; 1683 1684myprint( 'Host1: found ', scalar @h1_folders_all , " folders.\n" ) ; 1685myprint( 'Host2: found ', scalar @h2_folders_all , " folders.\n" ) ; 1686 1687foreach my $f ( @h1_folders_all ) { 1688 $h1_folders_all{ $f } = 1 1689} 1690foreach my $f ( @h2_folders_all ) { 1691 $h2_folders_all{ $f } = 1 ; 1692 $h2_folders_all_UPPER{ uc $f } = 1 ; 1693} 1694 1695$sync->{h1_folders_all} = \%h1_folders_all ; 1696$sync->{h2_folders_all} = \%h2_folders_all ; 1697$sync->{h2_folders_all_UPPER} = \%h2_folders_all_UPPER ; 1698 1699private_folders_separators_and_prefixes( ) ; 1700 1701 1702# Make a hash of subscribed folders in both servers. 1703 1704for ( $sync->{imap1}->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ; 1705for ( $sync->{imap2}->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ; 1706 1707 1708if ( defined $sync->{ subfolder1 } ) { 1709 subfolder1( $sync ) ; 1710} 1711 1712 1713 1714 1715if ( defined $sync->{ subfolder2 } ) { 1716 subfolder2( $sync ) ; 1717} 1718 1719if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) { 1720 push @{ $sync->{ regextrans2 } }, $reg ; 1721} 1722 1723 1724 1725if ( ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) 1726 or $subscribed 1727 or scalar @folderrec ) 1728{ 1729 # folders given by option --folder 1730 if ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) { 1731 add_to_requested_folders( @{ $sync->{ folder } } ) ; 1732 } 1733 1734 # option --subscribed 1735 if ( $subscribed ) { 1736 add_to_requested_folders( keys %h1_subscribed_folder ) ; 1737 } 1738 1739 # option --folderrec 1740 if ( scalar @folderrec ) { 1741 foreach my $folderrec ( @folderrec ) { 1742 add_to_requested_folders( $sync->{imap1}->folders( $folderrec ) ) ; 1743 } 1744 } 1745} 1746else 1747{ 1748 # no include, no folder/subscribed/folderrec options => all folders 1749 if ( not scalar @include ) { 1750 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" ) ; 1751 add_to_requested_folders( @h1_folders_all ) ; 1752 } 1753} 1754 1755 1756# consider (optional) includes and excludes 1757if ( scalar @include ) { 1758 foreach my $include ( @include ) { 1759 my @included_folders = grep { /$include/ } @h1_folders_all ; 1760 add_to_requested_folders( @included_folders ) ; 1761 myprint( "Including folders matching pattern $include\n" . jux_utf8_list( @included_folders ) . "\n" ) ; 1762 } 1763} 1764 1765if ( scalar @exclude ) { 1766 foreach my $exclude ( @exclude ) { 1767 my @requested_folder = sort keys %requested_folder ; 1768 my @excluded_folders = grep { /$exclude/ } @requested_folder ; 1769 remove_from_requested_folders( @excluded_folders ) ; 1770 myprint( "Excluding folders matching pattern $exclude\n" . jux_utf8_list( @excluded_folders ) . "\n" ) ; 1771 } 1772} 1773 1774 1775# sort before is not very powerful 1776# it adds --folderfirst and --folderlast even if they don't exist on host1 1777@h1_folders_wanted = sort_requested_folders( ) ; 1778 1779# Remove no selectable folders 1780 1781 1782if ( $sync->{ checkfoldersexist } ) { 1783 my @h1_folders_wanted_exist ; 1784 myprint( "Host1: Checking wanted folders exist. Use --nocheckfoldersexist to avoid this check (shared of public namespace targeted).\n" ) ; 1785 foreach my $folder ( @h1_folders_wanted ) { 1786 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ; 1787 if ( ! exists $h1_folders_all{ $folder } ) { 1788 myprint( "Host1: warning! ignoring folder $folder because it is not in host1 whole folders list.\n" ) ; 1789 next ; 1790 }else{ 1791 push @h1_folders_wanted_exist, $folder ; 1792 } 1793 } 1794 @h1_folders_wanted = @h1_folders_wanted_exist ; 1795}else{ 1796 myprint( "Host1: Not checking that wanted folders exist. Remove --nocheckfoldersexist to get this check.\n" ) ; 1797} 1798 1799 1800if ( $sync->{ checkselectable } ) { 1801 my @h1_folders_wanted_selectable ; 1802 myprint( "Host1: Checking wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ; 1803 foreach my $folder ( @h1_folders_wanted ) { 1804 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder is selectable on host1\n" ) ; 1805 # It does an imap command LIST "" $folder and then search for no \Noselect 1806 if ( ! $sync->{imap1}->selectable( $folder ) ) { 1807 myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ; 1808 }else{ 1809 push @h1_folders_wanted_selectable, $folder ; 1810 } 1811 } 1812 @h1_folders_wanted = @h1_folders_wanted_selectable ; 1813 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Host1: checking folders took ', timenext( ), " s\n" ) ; 1814}else{ 1815 myprint( "Host1: Not checking that wanted folders are selectable. Remove --nocheckselectable to get this check.\n" ) ; 1816} 1817 1818$sync->{h1_folders_wanted} = \@h1_folders_wanted ; 1819 1820 1821# Old place of private_folders_separators_and_prefixes( ) call. 1822#private_folders_separators_and_prefixes( ) ; 1823 1824 1825# this hack is because LWP post does not pass well a hash in the $form parameter 1826# but it does pass well an array 1827%{ $sync->{f1f2h} } = split_around_equal( @{ $sync->{f1f2} } ) ; 1828 1829automap( $sync ) ; 1830 1831 1832foreach my $h1_fold ( @h1_folders_wanted ) { 1833 my $h2_fold ; 1834 $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; 1835 $h2_folders_from_1_wanted{ $h2_fold }++ ; 1836 if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) { 1837 $h2_folders_from_1_several{ $h2_fold }++ ; 1838 } 1839} 1840@h2_folders_from_1_wanted = sort keys %h2_folders_from_1_wanted; 1841 1842foreach my $h1_fold ( @h1_folders_all ) { 1843 my $h2_fold ; 1844 $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; 1845 $h2_folders_from_1_all{ $h2_fold }++ ; 1846} 1847 1848 1849 1850myprint( << 'END_LISTING' ) ; 1851 1852++++ Listing folders 1853All foldernames are presented between brackets like [X] where X is the foldername. 1854When a foldername contains non-ASCII characters it is presented in the form 1855[X] = [Y] where 1856X is the imap foldername you have to use in command line options and 1857Y is the utf8 output just printed for convenience, to recognize it. 1858 1859END_LISTING 1860 1861myprint( 1862 "Host1: folders list (first the raw imap format then the [X] = [Y]):\n", 1863 $sync->{imap1}->list( ), 1864 "\n", 1865 jux_utf8_list( @h1_folders_all ), 1866 "\n", 1867 "Host2: folders list (first the raw imap format then the [X] = [Y]):\n", 1868 $sync->{imap2}->list( ), 1869 "\n", 1870 jux_utf8_list( @h2_folders_all ), 1871 "\n", 1872 q{} 1873) ; 1874 1875if ( $subscribed ) { 1876 myprint( 1877 'Host1 subscribed folders list: ', 1878 jux_utf8_list( sort keys %h1_subscribed_folder ), "\n", 1879 ) ; 1880} 1881 1882 1883my @h2_folders_not_in_1; 1884@h2_folders_not_in_1 = list_folders_in_2_not_in_1( ) ; 1885 1886if ( @h2_folders_not_in_1 ) { 1887 myprint( "Folders in host2 not in host1:\n", 1888 jux_utf8_list( @h2_folders_not_in_1 ), "\n" ) ; 1889} 1890 1891 1892if ( keys %{ $sync->{f1f2auto} } ) { 1893 myprint( "Folders mapping from --automap feature (use --f1f2 to override any mapping):\n" ) ; 1894 foreach my $h1_fold ( keys %{ $sync->{f1f2auto} } ) { 1895 my $h2_fold = $sync->{f1f2auto}{$h1_fold} ; 1896 myprintf( "%-40s -> %-40s\n", 1897 jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ; 1898 } 1899 myprint( "\n" ) ; 1900} 1901 1902if ( keys %{ $sync->{f1f2h} } ) { 1903 myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ; 1904 foreach my $h1_fold ( keys %{ $sync->{f1f2h} } ) { 1905 my $h2_fold = $sync->{f1f2h}{$h1_fold} ; 1906 my $warn = q{} ; 1907 if ( not exists $h1_folders_all{ $h1_fold } ) { 1908 $warn = "BUT $h1_fold does NOT exist on host1!" ; 1909 } 1910 myprintf( "%-40s -> %-40s %s\n", 1911 jux_utf8( $h1_fold ), jux_utf8( $h2_fold ), $warn ) ; 1912 } 1913 myprint( "\n" ) ; 1914} 1915 1916exit_clean( $sync, $EX_OK ) if ( $sync->{justfolderlists} ) ; 1917exit_clean( $sync, $EX_OK ) if ( $sync->{justautomap} ) ; 1918 1919debugsleep( $sync ) ; 1920 1921if ( $foldersizes ) { 1922 foldersizes_on_h1h2( $sync ) ; 1923} 1924 1925 1926 1927if ( $sync->{ justfoldersizes } ) 1928{ 1929 myprint( "Exiting because of --justfoldersizes\n" ) ; 1930 exit_clean( $sync, $EX_OK ) ; 1931} 1932 1933$sync->{stats} = 1 ; 1934 1935if ( $sync->{ delete1emptyfolders } ) { 1936 delete1emptyfolders( $sync ) ; 1937} 1938 1939delete_folders_in_2_not_in_1( ) if $delete2folders ; 1940 1941# folder loop 1942$h1_folders_wanted_nb = scalar @h1_folders_wanted ; 1943 1944myprint( "++++ Looping on each one of $h1_folders_wanted_nb folders to sync\n" ) ; 1945 1946$sync->{begin_transfer_time} = time ; 1947 1948my %uid_candidate_for_deletion ; 1949my %uid_candidate_no_deletion ; 1950 1951$sync->{ h2_folders_of_md5 } = { } ; 1952 1953FOLDER: foreach my $h1_fold ( @h1_folders_wanted ) { 1954 1955 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 1956 1957 my $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; 1958 1959 $h1_folders_wanted_ct++ ; 1960 myprintf( "Folder %7s %-35s -> %-35s\n", "$h1_folders_wanted_ct/$h1_folders_wanted_nb", 1961 jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ; 1962 myprint( debugmemory( $sync, " at folder loop" ) ) ; 1963 1964 # host1 can not be fetched read only, select is needed because of expunge. 1965 select_folder( $sync, $sync->{imap1}, $h1_fold, 'Host1' ) or next FOLDER ; 1966 1967 debugsleep( $sync ) ; 1968 1969 my $h1_fold_nb_messages = count_from_select( $sync->{imap1}->History ) ; 1970 myprint( "Host1: folder [$h1_fold] has $h1_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ; 1971 1972 if ( $skipemptyfolders and 0 == $h1_fold_nb_messages ) { 1973 myprint( "Host1: skipping empty host1 folder [$h1_fold]\n" ) ; 1974 next FOLDER ; 1975 } 1976 1977 # Code added from https://github.com/imapsync/imapsync/issues/95 1978 # Thanks jh1995 1979 if ( $skipemptyfolders ) { 1980 my $h1_msgs_all_hash_ref_tmp = { } ; 1981 my @h1_msgs_tmp = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref_tmp, $search1, $h1_fold ) ; 1982 my $h1_fold_nb_messages_tmp = scalar( @h1_msgs_tmp ) ; 1983 if ( 0 == $h1_fold_nb_messages_tmp ) { 1984 myprint( "Host1: skipping empty host1 folder [$h1_fold] (0 message found by SEARCH)\n" ) ; 1985 next FOLDER ; 1986 } 1987 } 1988 1989 if ( ! exists $h2_folders_all{ $h2_fold } ) { 1990 create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) or next FOLDER ; 1991 } 1992 1993 acls_sync( $h1_fold, $h2_fold ) ; 1994 1995 # Sometimes the folder on host2 is listed (it exists) but is 1996 # not selectable but becomes selectable by a create (Gmail) 1997 select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) 1998 or ( create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) 1999 and select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) ) 2000 or next FOLDER ; 2001 my @select_results = $sync->{imap2}->Results( ) ; 2002 2003 my $h2_fold_nb_messages = count_from_select( @select_results ) ; 2004 myprint( "Host2: folder [$h2_fold] has $h2_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ; 2005 2006 my $permanentflags2 = permanentflags( @select_results ) ; 2007 myprint( "Host2: folder [$h2_fold] permanentflags: $permanentflags2\n" ) ; 2008 2009 if ( $sync->{ expunge1 } ) 2010 { 2011 myprint( "Host1: Expunging $h1_fold $sync->{dry_message}\n" ) ; 2012 if ( ! $sync->{dry} ) { $sync->{imap1}->expunge( ) } ; 2013 } 2014 2015 if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribeall ) 2016 and not exists $h2_subscribed_folder{ $h2_fold } ) 2017 { 2018 myprint( "Host2: Subscribing to folder $h2_fold\n" ) ; 2019 if ( ! $sync->{dry} ) { $sync->{imap2}->subscribe( $h2_fold ) } ; 2020 } 2021 2022 next FOLDER if ( $sync->{ justfolders } ) ; 2023 2024 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2025 2026 my $h1_msgs_all_hash_ref = { } ; 2027 my @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $search1, $sync->{abletosearch1}, $h1_fold ); 2028 2029 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2030 2031 my $h1_msgs_nb = scalar @h1_msgs ; 2032 2033 myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ; 2034 ( $sync->{ debug } or $debuglist ) and myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ; 2035 $sync->{ debug } and myprint( "Host1: selecting messages of folder [$h1_fold] took ", timenext(), " s\n" ) ; 2036 2037 my $h2_msgs_all_hash_ref = { } ; 2038 my @h2_msgs = select_msgs( $sync->{imap2}, $h2_msgs_all_hash_ref, $search2, $sync->{abletosearch2}, $h2_fold ) ; 2039 2040 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2041 2042 my $h2_msgs_nb = scalar @h2_msgs ; 2043 2044 myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ; 2045 ( $sync->{ debug } or $debuglist ) and myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ; 2046 $sync->{ debug } and myprint( "Host2: selecting messages of folder [$h2_fold] took ", timenext(), " s\n" ) ; 2047 2048 my $cache_base = "$sync->{ tmpdir }/imapsync_cache/" ; 2049 my $cache_dir = cache_folder( $cache_base, "$sync->{host1}/$sync->{user1}/$sync->{host2}/$sync->{user2}", $h1_fold, $h2_fold ) ; 2050 my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ; 2051 2052 my $h1_uidvalidity = $sync->{imap1}->uidvalidity( ) || q{} ; 2053 my $h2_uidvalidity = $sync->{imap2}->uidvalidity( ) || q{} ; 2054 2055 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2056 2057 if ( $usecache ) { 2058 myprint( "Local cache directory: $cache_dir ( " . length( $cache_dir ) . " characters long )\n" ) ; 2059 mkpath( "$cache_dir" ) ; 2060 ( $cache_1_2_ref, $cache_2_1_ref ) 2061 = get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; 2062 myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ; 2063 $sync->{ debug } and myprint( '[', 2064 map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ; 2065 } 2066 2067 my %h1_hash = ( ) ; 2068 my %h2_hash = ( ) ; 2069 2070 my ( %h1_msgs, %h2_msgs ) ; 2071 @h1_msgs{ @h1_msgs } = ( ) ; 2072 @h2_msgs{ @h2_msgs } = ( ) ; 2073 2074 my @h1_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_1_2_ref } ; 2075 my @h2_msgs_in_cache = keys %{ $cache_2_1_ref } ; 2076 2077 my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ; 2078 %h1_msgs_not_in_cache = %h1_msgs ; 2079 %h2_msgs_not_in_cache = %h2_msgs ; 2080 delete @h1_msgs_not_in_cache{ @h1_msgs_in_cache } ; 2081 delete @h2_msgs_not_in_cache{ @h2_msgs_in_cache } ; 2082 2083 my @h1_msgs_not_in_cache = keys %h1_msgs_not_in_cache ; 2084 #myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ; 2085 my @h2_msgs_not_in_cache = keys %h2_msgs_not_in_cache ; 2086 2087 my @h2_msgs_delete2_not_in_cache = () ; 2088 %h1_msgs_copy_by_uid = ( ) ; 2089 2090 if ( $useuid ) { 2091 # use uid so we have to avoid getting header 2092 @h1_msgs_copy_by_uid{ @h1_msgs_not_in_cache } = ( ) ; 2093 @h2_msgs_delete2_not_in_cache = @h2_msgs_not_in_cache if $usecache ; 2094 @h1_msgs_not_in_cache = ( ) ; 2095 @h2_msgs_not_in_cache = ( ) ; 2096 2097 #myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ; 2098 } 2099 2100 $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold]\n" ) ; 2101 2102 my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); 2103 $h1_heads_ref = $sync->{imap1}->parse_headers([@h1_msgs_not_in_cache], @useheader) if (@h1_msgs_not_in_cache); 2104 $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold] took ", timenext(), " s\n" ) ; 2105 2106 @{ $h1_fir_ref }{@h1_msgs} = ( undef ) ; 2107 2108 $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold]\n" ) ; 2109 2110 my @h1_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ; 2111 if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h1_common_fetch_param, 'X-GM-LABELS' ; } 2112 2113 if ( $sync->{abletosearch1} ) 2114 { 2115 $h1_fir_ref = $sync->{imap1}->fetch_hash( \@h1_msgs, @h1_common_fetch_param, $h1_fir_ref ) 2116 if ( @h1_msgs ) ; 2117 } 2118 else 2119 { 2120 my $uidnext = $sync->{imap1}->uidnext( $h1_fold ) || $uidnext_default ; 2121 my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; 2122 $h1_fir_ref = $sync->{imap1}->fetch_hash( $fetch_hash_uids, @h1_common_fetch_param, $h1_fir_ref ) 2123 if ( @h1_msgs ) ; 2124 } 2125 2126 $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold] took ", timenext(), " s\n" ) ; 2127 if ( ! $h1_fir_ref ) 2128 { 2129 my $error = join( q{}, "Host1: folder $h1_fold : Could not fetch_hash ", 2130 scalar @h1_msgs, ' msgs: ', $sync->{imap1}->LastError || q{}, "\n" ) ; 2131 errors_incr( $sync, $error ) ; 2132 next FOLDER ; 2133 } 2134 2135 my @h1_msgs_duplicate; 2136 foreach my $m ( @h1_msgs_not_in_cache ) 2137 { 2138 my $rc = parse_header_msg( $sync, $sync->{imap1}, $m, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash ) ; 2139 if ( ! defined $rc ) 2140 { 2141 my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; 2142 myprint( "Host1: $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ) ; 2143 $sync->{ total_bytes_skipped } += $h1_size ; 2144 $sync->{ nb_msg_skipped } += 1 ; 2145 $sync->{ h1_nb_msg_noheader } +=1 ; 2146 $sync->{ h1_nb_msg_processed } +=1 ; 2147 } elsif(0 == $rc) 2148 { 2149 # duplicate 2150 push @h1_msgs_duplicate, $m; 2151 # duplicate, same id same size? 2152 my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; 2153 $sync->{ nb_msg_skipped } += 1; 2154 $h1_nb_msg_duplicate += 1; 2155 $sync->{ h1_nb_msg_processed } +=1 ; 2156 } 2157 } 2158 my $h1_msgs_duplicate_nb = scalar @h1_msgs_duplicate ; 2159 2160 myprint( "Host1: folder [$h1_fold] selected $h1_msgs_nb messages, duplicates $h1_msgs_duplicate_nb\n" ) ; 2161 2162 $sync->{ debug } and myprint( 'Host1: whole time parsing headers took ', timenext(), " s\n" ) ; 2163 # Getting headers and metada can be so long that host2 might be disconnected here 2164 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2165 2166 2167 $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold]\n" ) ; 2168 2169 my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} ); 2170 $h2_heads_ref = $sync->{imap2}->parse_headers([@h2_msgs_not_in_cache], @useheader) if (@h2_msgs_not_in_cache); 2171 $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold] took ", timenext(), " s\n" ) ; 2172 2173 $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold]\n" ) ; 2174 @{ $h2_fir_ref }{@h2_msgs} = ( ); # fetch_hash can select by uid with last arg as ref 2175 2176 2177 my @h2_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ; 2178 if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h2_common_fetch_param, 'X-GM-LABELS' ; } 2179 2180 if ( $sync->{abletosearch2} and scalar( @h2_msgs ) ) { 2181 $h2_fir_ref = $sync->{imap2}->fetch_hash( \@h2_msgs, @h2_common_fetch_param, $h2_fir_ref) ; 2182 }else{ 2183 my $uidnext = $sync->{imap2}->uidnext( $h2_fold ) || $uidnext_default ; 2184 my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; 2185 $h2_fir_ref = $sync->{imap2}->fetch_hash( $fetch_hash_uids, @h2_common_fetch_param, $h2_fir_ref ) 2186 if ( @h2_msgs ) ; 2187 } 2188 2189 $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold] took ", timenext(), " s\n" ) ; 2190 2191 my @h2_msgs_duplicate; 2192 foreach my $m (@h2_msgs_not_in_cache) { 2193 my $rc = parse_header_msg( $sync, $sync->{imap2}, $m, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash ) ; 2194 my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ; 2195 if (! defined $rc ) { 2196 myprint( "Host2: $h2_fold/$m size $h2_size ignored (no wanted headers so we ignore this message)\n" ) ; 2197 $h2_nb_msg_noheader += 1 ; 2198 } elsif( 0 == $rc ) { 2199 # duplicate 2200 $h2_nb_msg_duplicate += 1 ; 2201 push @h2_msgs_duplicate, $m ; 2202 } 2203 } 2204 2205 # %h2_folders_of_md5 2206 foreach my $md5 ( keys %h2_hash ) { 2207 $sync->{ h2_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ; 2208 } 2209 # %h1_folders_of_md5 2210 foreach my $md5 ( keys %h1_hash ) { 2211 $sync->{ h1_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ; 2212 } 2213 2214 2215 my $h2_msgs_duplicate_nb = scalar @h2_msgs_duplicate ; 2216 2217 myprint( "Host2: folder [$h2_fold] selected $h2_msgs_nb messages, duplicates $h2_msgs_duplicate_nb\n" ) ; 2218 2219 $sync->{ debug } and myprint( 'Host2 whole time parsing headers took ', timenext( ), " s\n" ) ; 2220 2221 $sync->{ debug } and myprint( "++++ Verifying [$h1_fold] -> [$h2_fold]\n" ) ; 2222 # messages in host1 that are not in host2 2223 2224 my @h1_hash_keys_sorted_by_uid 2225 = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys %h1_hash; 2226 2227 #myprint( map { $h1_hash{$_}{'m'} . q{ }} @h1_hash_keys_sorted_by_uid ) ; 2228 2229 my @h2_hash_keys_sorted_by_uid 2230 = sort {$h2_hash{$a}{'m'} <=> $h2_hash{$b}{'m'}} keys %h2_hash; 2231 2232 # Deletions on account2. 2233 2234 if( $sync->{ delete2duplicates } and not exists $h2_folders_from_1_several{ $h2_fold } ) { 2235 my @h2_expunge ; 2236 2237 foreach my $h2_msg ( @h2_msgs_duplicate ) { 2238 myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $sync->{dry_message}\n" ) ; 2239 push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ; 2240 if ( ! $sync->{dry} ) { 2241 $sync->{imap2}->delete_message( $h2_msg ) ; 2242 $h2_nb_msg_deleted += 1 ; 2243 } 2244 } 2245 my $cnt = scalar @h2_expunge ; 2246 if( @h2_expunge and not $sync->{ expunge2 } ) { 2247 myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; 2248 $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; 2249 } 2250 if ( $sync->{ expunge2 } ){ 2251 myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; 2252 $sync->{imap2}->expunge( ) if ! $sync->{dry} ; 2253 } 2254 } 2255 2256 if( $sync->{ delete2 } and not exists $h2_folders_from_1_several{ $h2_fold } ) { 2257 # No host1 folders f1a f1b ... going all to same f2 (via --regextrans2) 2258 my @h2_expunge; 2259 foreach my $m_id (@h2_hash_keys_sorted_by_uid) { 2260 #myprint( "$m_id " ) ; 2261 if ( ! exists $h1_hash{$m_id} ) { 2262 my $h2_msg = $h2_hash{$m_id}{'m'}; 2263 my $h2_flags = $h2_hash{$m_id}{'F'} || q{}; 2264 my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0; 2265 myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id] $sync->{dry_message}\n" ) 2266 if ! $isdel; 2267 push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 }; 2268 if ( ! ( $sync->{dry} or $isdel ) ) { 2269 $sync->{imap2}->delete_message($h2_msg); 2270 $h2_nb_msg_deleted += 1; 2271 } 2272 } 2273 } 2274 foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { 2275 myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $sync->{dry_message}\n" ) ; 2276 push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 }; 2277 if ( ! $sync->{dry} ) { 2278 $sync->{imap2}->delete_message($h2_msg); 2279 $h2_nb_msg_deleted += 1; 2280 } 2281 } 2282 my $cnt = scalar @h2_expunge ; 2283 2284 if( @h2_expunge and not $sync->{ expunge2 } ) { 2285 myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; 2286 $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; 2287 } 2288 if ( $sync->{ expunge2 } ) { 2289 myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; 2290 $sync->{imap2}->expunge( ) if ! $sync->{dry} ; 2291 } 2292 } 2293 2294 if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } ) { 2295 myprint( "Host2: folder $h2_fold $h2_folders_from_1_several{ $h2_fold } folders left to sync there\n" ) ; 2296 my @h2_expunge; 2297 foreach my $m_id ( @h2_hash_keys_sorted_by_uid ) { 2298 my $h2_msg = $h2_hash{ $m_id }{ 'm' } ; 2299 if ( ! exists $h1_hash{ $m_id } ) { 2300 my $h2_flags = $h2_hash{ $m_id }{ 'F' } || q{} ; 2301 my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ; 2302 if ( ! $isdel ) { 2303 $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ; 2304 $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; 2305 } 2306 }else{ 2307 $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [$m_id]\n" ) ; 2308 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; 2309 } 2310 } 2311 foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { 2312 myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [not in cache]\n" ) ; 2313 $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; 2314 } 2315 2316 foreach my $h2_msg ( @h2_msgs_in_cache ) { 2317 myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [in cache]\n" ) ; 2318 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; 2319 } 2320 2321 2322 if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) { 2323 # last host1 folder going to $h2_fold 2324 myprint( "Last host1 folder going to $h2_fold\n" ) ; 2325 foreach my $h2_msg ( keys %{ $uid_candidate_for_deletion{ $h2_fold } } ) { 2326 $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ; 2327 if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) { 2328 $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ; 2329 }else{ 2330 myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $sync->{dry_message}\n" ) ; 2331 push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ; 2332 if ( ! $sync->{dry} ) { 2333 $sync->{imap2}->delete_message( $h2_msg ) ; 2334 $h2_nb_msg_deleted += 1 ; 2335 } 2336 } 2337 } 2338 } 2339 2340 my $cnt = scalar @h2_expunge ; 2341 if( @h2_expunge and not $sync->{ expunge2 } ) { 2342 myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; 2343 $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; 2344 } 2345 if ( $sync->{ expunge2 } ) { 2346 myprint( "Host2: Expunging host2 folder $h2_fold $sync->{dry_message}\n" ) ; 2347 $sync->{imap2}->expunge( ) if ! $sync->{dry} ; 2348 } 2349 2350 $h2_folders_from_1_several{ $h2_fold }-- ; 2351 } 2352 2353 my $h2_uidnext = $sync->{imap2}->uidnext( $h2_fold ) ; 2354 $sync->{ debug } and myprint( "Host2: uidnext is $h2_uidnext\n" ) ; 2355 $h2_uidguess = $h2_uidnext ; 2356 2357 # Getting host2 headers, metada and delete2 stuff can be so long that host1 might be disconnected here 2358 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2359 2360 my @h1_msgs_to_delete ; 2361 MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) { 2362 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2363 2364 #myprint( "h1_nb_msg_processed: $sync->{ h1_nb_msg_processed }\n" ) ; 2365 my $h1_size = $h1_hash{$m_id}{'s'}; 2366 my $h1_msg = $h1_hash{$m_id}{'m'}; 2367 my $h1_idate = $h1_hash{$m_id}{'D'}; 2368 2369 #my $labels = labels( $sync->{imap1}, $h1_msg ) ; 2370 #print "LABELS: $labels\n" ; 2371 2372 if ( ( not exists $h2_hash{ $m_id } ) 2373 and ( not ( exists $sync->{ h2_folders_of_md5 }->{ $m_id } ) 2374 or not $skipcrossduplicates ) ) 2375 { 2376 # copy 2377 my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; 2378 if ( $h2_msg and $sync->{ delete1 } and not $sync->{ expungeaftereach } ) { 2379 # not expunged 2380 push @h1_msgs_to_delete, $h1_msg ; 2381 } 2382 2383 # A bug here with imapsync 1.920, fixed in 1.921 2384 # Added $h2_msg in the condition. Errors of APPEND were not counted as missing messages on host2! 2385 if ( $h2_msg and not $sync->{ dry } ) 2386 { 2387 $sync->{ h2_folders_of_md5 }->{ $m_id }->{ $h2_fold } ++ ; 2388 } 2389 2390 # 2391 if( $sync->{ delete2 } and ( exists $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) { 2392 myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ; 2393 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; 2394 } 2395 2396 if ( total_bytes_max_reached( $sync ) ) { 2397 # a bug when using --delete1 --noexpungeaftereach 2398 # same thing below on all total_bytes_max_reached! 2399 last FOLDER ; 2400 } 2401 next MESS; 2402 } 2403 else 2404 { 2405 # already on host2 2406 if ( exists $h2_hash{ $m_id } ) 2407 { 2408 my $h2_msg = $h2_hash{$m_id}{'m'} ; 2409 $sync->{ debug } and myprint( "Host1: found that msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ; 2410 if ( $usecache ) 2411 { 2412 $debugcache and myprint( "touch $cache_dir/${h1_msg}_$h2_msg\n" ) ; 2413 touch( "$cache_dir/${h1_msg}_$h2_msg" ) 2414 or croak( "Couldn't touch $cache_dir/${h1_msg}_$h2_msg" ) ; 2415 } 2416 } 2417 elsif( exists $sync->{ h2_folders_of_md5 }->{ $m_id } ) 2418 { 2419 my @folders_dup = keys %{ $sync->{ h2_folders_of_md5 }->{ $m_id } } ; 2420 ( $sync->{ debug } or $debugcrossduplicates ) and myprint( "Host1: found that msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ; 2421 $sync->{ h2_nb_msg_crossdup } +=1 ; 2422 } 2423 $sync->{ total_bytes_skipped } += $h1_size ; 2424 $sync->{ nb_msg_skipped } += 1 ; 2425 $sync->{ h1_nb_msg_processed } +=1 ; 2426 } 2427 2428 if ( exists $h2_hash{ $m_id } ) { 2429 #$debug and myprint( "MESSAGE $m_id\n" ) ; 2430 my $h2_msg = $h2_hash{$m_id}{'m'}; 2431 if ( $sync->{resyncflags} ) { 2432 sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; 2433 } 2434 # Good 2435 my $h2_size = $h2_hash{$m_id}{'s'}; 2436 $sync->{ debug } and myprint( 2437 "Host1: size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n" ) ; 2438 2439 if ( $sync->{ resynclabels } ) 2440 { 2441 resynclabels( $sync, $h1_msg, $h2_msg, $h1_fir_ref, $h2_fir_ref, $h1_fold ) 2442 } 2443 } 2444 2445 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2446 2447 if ( $sync->{ delete1 } ) { 2448 push @h1_msgs_to_delete, $h1_msg ; 2449 } 2450 } 2451 # END MESS: loop 2452 2453 delete_message_on_host1( $sync, $h1_fold, $sync->{ expunge1 }, @h1_msgs_to_delete, @h1_msgs_in_cache ) ; 2454 2455 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2456 2457 # MESS_IN_CACHE: 2458 if ( ! $sync->{ delete1 } ) 2459 { 2460 foreach my $h1_msg ( @h1_msgs_in_cache ) 2461 { 2462 my $h2_msg = $cache_1_2_ref->{ $h1_msg } ; 2463 $debugcache and myprint( "cache messages update flags $h1_msg->$h2_msg\n" ) ; 2464 if ( $sync->{resyncflags} ) 2465 { 2466 sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; 2467 } 2468 my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ; 2469 $sync->{ total_bytes_skipped } += $h1_size; 2470 $sync->{ nb_msg_skipped } += 1; 2471 $sync->{ h1_nb_msg_processed } +=1 ; 2472 } 2473 } 2474 2475 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2476 2477 @h1_msgs_to_delete = ( ) ; 2478 #myprint( "Messages by uid: ", map { "$_ " } keys %h1_msgs_copy_by_uid, "\n" ) ; 2479 # MESS_BY_UID: 2480 foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) 2481 { 2482 $sync->{ debug } and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ; 2483 if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } 2484 2485 my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; 2486 if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } and $h2_msg ) { 2487 myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ; 2488 $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; 2489 } 2490 last FOLDER if total_bytes_max_reached( $sync ) ; 2491 } 2492 2493 if ( $sync->{ expunge1 } ){ 2494 myprint( "Host1: Expunging folder $h1_fold $sync->{dry_message}\n" ) ; 2495 if ( ! $sync->{dry} ) { $sync->{imap1}->expunge( ) } ; 2496 } 2497 if ( $sync->{ expunge2 } ){ 2498 myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; 2499 if ( ! $sync->{dry} ) { $sync->{imap2}->expunge( ) } ; 2500 } 2501 $sync->{ debug } and myprint( 'Time: ', timenext( ), " s\n" ) ; 2502} 2503 2504 2505myprint( "++++ End looping on each folder\n" ) ; 2506 2507if ( $sync->{ delete1 } and $sync->{ delete1emptyfolders } ) { 2508 delete1emptyfolders( $sync ) ; 2509} 2510 2511( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Time: ', timenext( ), " s\n" ) ; 2512 2513 2514if ( $foldersizesatend ) { 2515 myprint( << 'END_SIZE' ) ; 2516 2517Folders sizes after the synchronization. 2518You can remove this foldersizes listing by using "--nofoldersizesatend" 2519END_SIZE 2520 2521 foldersizesatend( $sync ) ; 2522} 2523 2524if ( ! lost_connection( $sync, $sync->{imap1}, "for host1 [$sync->{host1}]" ) ) { $sync->{imap1}->logout( ) ; } 2525if ( ! lost_connection( $sync, $sync->{imap2}, "for host2 [$sync->{host2}]" ) ) { $sync->{imap2}->logout( ) ; } 2526 2527stats( $sync ) ; 2528myprint( errorsdump( $sync->{nb_errors}, errors_log( $sync ) ) ) if ( $sync->{errorsdump} ) ; 2529tests_live_result( $sync->{nb_errors} ) if ( $sync->{testslive} or $sync->{testslive6} ) ; 2530 2531 2532exit_clean( $sync, $EXIT_WITH_ERRORS ) if ( $sync->{nb_errors} ) ; 2533exit_clean( $sync, $EX_OK ) ; 2534 2535# END of main program 2536 2537 2538# subroutines 2539sub myprint 2540{ 2541 #print @ARG ; 2542 print { $sync->{ tee } || \*STDOUT } @ARG ; 2543 return ; 2544} 2545 2546sub myprintf 2547{ 2548 printf { $sync->{ tee } || \*STDOUT } @ARG ; 2549 return ; 2550} 2551 2552sub mysprintf 2553{ 2554 my( $format, @list ) = @ARG ; 2555 return sprintf $format, @list ; 2556} 2557 2558sub output_start 2559{ 2560 my $mysync = shift @ARG ; 2561 2562 if ( not $mysync ) { return ; } 2563 2564 my @output = @ARG ; 2565 $mysync->{ output } = join( q{}, @output ) . ( $mysync->{ output } || q{} ) ; 2566 return $mysync->{ output } ; 2567} 2568 2569 2570sub tests_output_start 2571{ 2572 note( 'Entering tests_output_start()' ) ; 2573 2574 my $mysync = { } ; 2575 2576 is( undef, output_start( ), 'output_start: no args => undef' ) ; 2577 is( q{}, output_start( $mysync ), 'output_start: one arg => ""' ) ; 2578 is( 'rrrr', output_start( $mysync, 'rrrr' ), 'output_start: rrrr => rrrr' ) ; 2579 is( 'aaaarrrr', output_start( $mysync, 'aaaa' ), 'output_start: aaaa => aaaarrrr' ) ; 2580 is( "\naaaarrrr", output_start( $mysync, "\n" ), 'output_start: \n => \naaaarrrr' ) ; 2581 is( "ABC\naaaarrrr", output_start( $mysync, 'A', 'B', 'C' ), 'output_start: A B C => ABC\naaaarrrr' ) ; 2582 2583 note( 'Leaving tests_output_start()' ) ; 2584 return ; 2585} 2586 2587sub tests_output 2588{ 2589 note( 'Entering tests_output()' ) ; 2590 2591 my $mysync = { } ; 2592 2593 is( undef, output( ), 'output: no args => undef' ) ; 2594 is( q{}, output( $mysync ), 'output: one arg => ""' ) ; 2595 is( 'rrrr', output( $mysync, 'rrrr' ), 'output: rrrr => rrrr' ) ; 2596 is( 'rrrraaaa', output( $mysync, 'aaaa' ), 'output: aaaa => rrrraaaa' ) ; 2597 is( "rrrraaaa\n", output( $mysync, "\n" ), 'output: \n => rrrraaaa\n' ) ; 2598 is( "rrrraaaa\nABC", output( $mysync, 'A', 'B', 'C' ), 'output: A B C => rrrraaaaABC\n' ) ; 2599 2600 note( 'Leaving tests_output()' ) ; 2601 return ; 2602} 2603 2604sub output 2605{ 2606 my $mysync = shift @ARG ; 2607 2608 if ( not $mysync ) { return ; } 2609 2610 my @output = @ARG ; 2611 $mysync->{ output } .= join( q{}, @output ) ; 2612 return $mysync->{ output } ; 2613} 2614 2615 2616 2617sub tests_output_reset_with 2618{ 2619 note( 'Entering tests_output_reset_with()' ) ; 2620 2621 my $mysync = { } ; 2622 2623 is( undef, output_reset_with( ), 'output_reset_with: no args => undef' ) ; 2624 is( q{}, output_reset_with( $mysync ), 'output_reset_with: one arg => ""' ) ; 2625 is( 'rrrr', output_reset_with( $mysync, 'rrrr' ), 'output_reset_with: rrrr => rrrr' ) ; 2626 is( 'aaaa', output_reset_with( $mysync, 'aaaa' ), 'output_reset_with: aaaa => aaaa' ) ; 2627 is( "\n", output_reset_with( $mysync, "\n" ), 'output_reset_with: \n => \n' ) ; 2628 2629 note( 'Leaving tests_output_reset_with()' ) ; 2630 return ; 2631} 2632 2633sub output_reset_with 2634{ 2635 my $mysync = shift @ARG ; 2636 2637 if ( not $mysync ) { return ; } 2638 2639 my @output = @ARG ; 2640 $mysync->{ output } = join( q{}, @output ) ; 2641 return $mysync->{ output } ; 2642} 2643 2644 2645 2646sub abort 2647{ 2648 my $mysync = shift @ARG ; 2649 if ( ! -r $mysync->{pidfile} ) { 2650 myprint( "Can not read pidfile $mysync->{pidfile}. Exiting.\n" ) ; 2651 exit $EX_OK ; 2652 } 2653 my $pidtokill = firstline( $mysync->{pidfile} ) ; 2654 if ( ! $pidtokill ) { 2655 myprint( "No process to abort. Exiting.\n" ) ; 2656 exit $EX_OK ; 2657 } 2658 # First ask for suicide 2659 if ( kill 'ZERO', $pidtokill ) { 2660 myprint( "Sending signal QUIT to PID $pidtokill \n" ) ; 2661 kill 'QUIT', $pidtokill ; 2662 sleep 1 ; 2663 }else{ 2664 myprint( "Can not send signal to PID $pidtokill. Exiting.\n" ) ; 2665 exit $EX_OK ; 2666 } 2667 # Then murder 2668 if ( kill 'ZERO', $pidtokill ) { 2669 myprint( "Sending signal KILL to PID $pidtokill \n" ) ; 2670 kill 'KILL', $pidtokill ; 2671 sleep 1 ; 2672 }else{ 2673 myprint( "Process PID $pidtokill ended. Exiting.\n" ) ; 2674 exit $EX_OK ; 2675 } 2676 # Well ... 2677 if ( kill 'ZERO', $pidtokill ) { 2678 myprint( "Process PID $pidtokill still there. Can not do much. Exiting.\n" ) ; 2679 exit $EX_OK ; 2680 }else{ 2681 myprint( "Process PID $pidtokill ended. Exiting.\n" ) ; 2682 exit $EX_OK ; 2683 } 2684 # well abort job done anyway 2685 2686 exit $EX_OK ; 2687} 2688 2689 2690 2691sub docker_context 2692{ 2693 my $mysync = shift ; 2694 -e '/.dockerenv' || return ; 2695 myprint( "Docker context detected with /.dockerenv\n" ) ; 2696 # No pidfile 2697 $mysync->{pidfile} = q{} ; 2698 # No log 2699 $mysync->{log} = 0 ; 2700 # In case 2701 myprint( "Changing current directory to /var/tmp/\n" ) ; 2702 chdir '/var/tmp/' ; 2703 2704 return ; 2705} 2706 2707sub cgibegin 2708{ 2709 my $mysync = shift ; 2710 if ( ! under_cgi_context( $mysync ) ) { return ; } 2711 require CGI ; 2712 CGI->import( qw( -no_debug ) ) ; 2713 require CGI::Carp ; 2714 CGI::Carp->import( qw( fatalsToBrowser ) ) ; 2715 $mysync->{cgi} = CGI->new( ) ; 2716 return ; 2717} 2718 2719sub tests_under_cgi_context 2720{ 2721 note( 'Entering tests_under_cgi_context()' ) ; 2722 2723 # $ENV{SERVER_SOFTWARE} = 'under imapsync' ; 2724 do { 2725 # Not in cgi context 2726 delete local $ENV{SERVER_SOFTWARE} ; 2727 is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ; 2728 } ; 2729 do { 2730 # In cgi context 2731 local $ENV{SERVER_SOFTWARE} = 'under imapsync' ; 2732 is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ; 2733 } ; 2734 do { 2735 # Not in cgi context 2736 delete local $ENV{SERVER_SOFTWARE} ; 2737 is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ; 2738 } ; 2739 do { 2740 # In cgi context 2741 local $ENV{SERVER_SOFTWARE} = 'under imapsync' ; 2742 is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ; 2743 } ; 2744 note( 'Leaving tests_under_cgi_context()' ) ; 2745 return ; 2746} 2747 2748 2749sub under_cgi_context 2750{ 2751 my $mysync = shift ; 2752 # Under cgi context 2753 if ( $ENV{SERVER_SOFTWARE} ) { 2754 return 1 ; 2755 } 2756 # Not in cgi context 2757 return ; 2758} 2759 2760sub cgibuildheader 2761{ 2762 my $mysync = shift ; 2763 if ( ! under_cgi_context( $mysync ) ) { return ; } 2764 2765 my $imapsync_runs = $mysync->{cgi}->cookie( 'imapsync_runs' ) || 0 ; 2766 my $cookie = $mysync->{cgi}->cookie( 2767 -name => 'imapsync_runs', 2768 -value => 1 + $imapsync_runs, 2769 -expires => '+20y', 2770 -path => '/cgi-bin/imapsync', 2771 ) ; 2772 my $httpheader ; 2773 if ( $mysync->{ abort } ) { 2774 $httpheader = $mysync->{cgi}->header( 2775 -type => 'text/plain', 2776 -status => '200 OK to abort syncing IMAP boxes' . ". Here is " . hostname(), 2777 ) ; 2778 }elsif( $mysync->{ loaddelay } ) { 2779# https://tools.ietf.org/html/rfc2616#section-10.5.4 2780# 503 Service Unavailable 2781# The server is currently unable to handle the request due to a temporary overloading or maintenance of the server. 2782 $httpheader = $mysync->{cgi}->header( 2783 -type => 'text/plain', 2784 -status => '503 Service Unavailable' . ". Be back in $mysync->{ loaddelay } min. Load on " . hostname() . " is $mysync->{ loadavg }", 2785 ) ; 2786 }else{ 2787 $httpheader = $mysync->{cgi}->header( 2788 -type => 'text/plain', 2789 -status => '200 OK to sync IMAP boxes' . ". Load on " . hostname() . " is $mysync->{ loadavg }", 2790 -cookie => $cookie, 2791 ) ; 2792 } 2793 output_start( $mysync, $httpheader ) ; 2794 2795 return ; 2796} 2797 2798sub cgiload 2799{ 2800 # Exit on heavy load in CGI context 2801 my $mysync = shift ; 2802 if ( ! under_cgi_context( $mysync ) ) { return ; } 2803 if ( $mysync->{ abort } ) { return ; } # keep going to abort since some ressources will be free soon 2804 if ( $mysync->{ loaddelay } ) 2805 { 2806 myprint( "Server is on heavy load. Be back in $mysync->{ loaddelay } min. Load is $mysync->{ loadavg }\n") ; 2807 exit_clean( $mysync, $EX_UNAVAILABLE ) ; 2808 } 2809 return ; 2810} 2811 2812sub tests_set_umask 2813{ 2814 note( 'Entering tests_set_umask()' ) ; 2815 2816 my $save_umask = umask ; 2817 2818 my $mysync = {} ; 2819 if ( 'MSWin32' eq $OSNAME ) { 2820 is( undef, set_umask( $mysync ), "set_umask: set failure to $UMASK_PARANO on MSWin32" ) ; 2821 }else{ 2822 is( 1, set_umask( $mysync ), "set_umask: set to $UMASK_PARANO" ) ; 2823 } 2824 2825 umask $save_umask ; 2826 note( 'Leaving tests_set_umask()' ) ; 2827 return ; 2828} 2829 2830sub set_umask 2831{ 2832 my $mysync = shift ; 2833 my $previous_umask = umask_str( ) ; 2834 my $new_umask = umask_str( $UMASK_PARANO ) ; 2835 output( $mysync, "Umask set with $new_umask (was $previous_umask)\n" ) ; 2836 if ( $new_umask eq $UMASK_PARANO ) { 2837 return 1 ; 2838 } 2839 return ; 2840} 2841 2842sub tests_umask_str 2843{ 2844 note( 'Entering tests_umask_str()' ) ; 2845 2846 my $save_umask = umask ; 2847 2848 is( umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent' ) ; 2849 is( my $save_umask_str = umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent + save' ) ; 2850 is( '0000', umask_str( q{ } ), 'umask_str: q{ } => 0000' ) ; 2851 is( '0000', umask_str( q{} ), 'umask_str: q{} => 0000' ) ; 2852 is( '0000', umask_str( '0000' ), 'umask_str: 0000 => 0000' ) ; 2853 is( '0000', umask_str( '0' ), 'umask_str: 0 => 0000' ) ; 2854 is( '0200', umask_str( '0200' ), 'umask_str: 0200 => 0200' ) ; 2855 is( '0400', umask_str( '0400' ), 'umask_str: 0400 => 0400' ) ; 2856 is( '0600', umask_str( '0600' ), 'umask_str: 0600 => 0600' ) ; 2857 2858 SKIP: { 2859 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 6 ) ; } 2860 is( '0100', umask_str( '0100' ), 'umask_str: 0100 => 0100' ) ; 2861 is( '0001', umask_str( '0001' ), 'umask_str: 0001 => 0001' ) ; 2862 is( '0777', umask_str( '0777' ), 'umask_str: 0777 => 0777' ) ; 2863 is( '0777', umask_str( '00777' ), 'umask_str: 00777 => 0777' ) ; 2864 is( '0777', umask_str( ' 777 ' ), 'umask_str: 777 => 0777' ) ; 2865 is( "$UMASK_PARANO", umask_str( $UMASK_PARANO ), "umask_str: UMASK_PARANO $UMASK_PARANO => $UMASK_PARANO" ) ; 2866 } 2867 2868 is( $save_umask_str, umask_str( $save_umask_str ), 'umask_str: restore with str' ) ; 2869 is( $save_umask, umask, 'umask_str: umask is restored, controlled by direct umask' ) ; 2870 is( $save_umask, umask $save_umask, 'umask_str: umask is restored by direct umask' ) ; 2871 is( $save_umask, umask, 'umask_str: umask initial controlled by direct umask' ) ; 2872 2873 note( 'Leaving tests_umask_str()' ) ; 2874 return ; 2875} 2876 2877sub umask_str 2878{ 2879 my $value = shift ; 2880 2881 if ( defined $value ) { 2882 umask oct( $value ) ; 2883 } 2884 my $current = umask ; 2885 2886 return( sprintf( '%#04o', $current ) ) ; 2887} 2888 2889sub tests_umask 2890{ 2891 note( 'Entering tests_umask()' ) ; 2892 2893 my $save_umask ; 2894 is( umask, umask, 'umask: umask is umask' ) ; 2895 is( $save_umask = umask, umask, "umask: umask is umask again + save it: $save_umask" ) ; 2896 is( $save_umask, umask oct(0000), 'umask: umask 0000' ) ; 2897 is( oct(0000), umask, 'umask: umask is now 0000' ) ; 2898 is( oct(0000), umask oct(777), 'umask: umask 0777 call, previous 0000' ) ; 2899 2900 SKIP: { 2901 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 2 ) ; } 2902 is( oct(777), umask, 'umask: umask is now 0777' ) ; 2903 is( oct(777), umask $save_umask, "umask: umask $save_umask restore inital value, previous 0777" ) ; 2904 } 2905 2906 ok( defined umask $save_umask, "umask: umask $save_umask restore inital value, previous defined" ) ; 2907 is( $save_umask, umask, 'umask: umask is umask restored' ) ; 2908 note( 'Leaving tests_umask()' ) ; 2909 2910 return ; 2911} 2912 2913sub cgisetcontext 2914{ 2915 my $mysync = shift ; 2916 if ( ! under_cgi_context( $mysync ) ) { return ; } 2917 2918 output( $mysync, "Under cgi context\n" ) ; 2919 set_umask( $mysync ) ; 2920 2921 # Remove all content in unsafe evaled options 2922 @{ $mysync->{ regextrans2 } } = ( ) ; 2923 @regexflag = ( ) ; 2924 @regexmess = ( ) ; 2925 @skipmess = ( ) ; 2926 @pipemess = ( ) ; 2927 $delete2foldersonly = undef ; 2928 $delete2foldersbutnot = undef ; 2929 $maxlinelengthcmd = undef ; 2930 2931 # Set safe default values (I hope...) 2932 2933 $mysync->{pidfile} = 'imapsync.pid' ; 2934 $mysync->{pidfilelocking} = 1 ; 2935 $mysync->{errorsmax} = $ERRORS_MAX_CGI ; 2936 $modulesversion = 0 ; 2937 $mysync->{releasecheck} = defined $mysync->{releasecheck} ? $mysync->{releasecheck} : 1 ; 2938 $usecache = 0 ; 2939 $mysync->{showpasswords} = 0 ; 2940 $debugimap1 = $debugimap2 = $debugimap = 0 ; 2941 $reconnectretry1 = $reconnectretry2 = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; 2942 $pipemesscheck = 0 ; 2943 2944 $mysync->{hashfile} = $CGI_HASHFILE ; 2945 my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ; 2946 $cgidir = $CGI_TMPDIR_TOP . '/' . $hashsynclocal ; 2947 2948 -d $cgidir or mkpath $cgidir or die "Can not create $cgidir: $OS_ERROR\n" ; 2949 chdir $cgidir or die "Can not cd to $cgidir: $OS_ERROR\n" ; 2950 $mysync->{ tmpdir } = $cgidir ; 2951 cgioutputenvcontext( $mysync ) ; 2952 $mysync->{ debug } and output( $mysync, 'Current directory is ' . getcwd( ) . "\n" ) ; 2953 $mysync->{ debug } and output( $mysync, 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ; 2954 $mysync->{ debug } and output( $mysync, 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ; 2955 2956 $skipemptyfolders = defined $skipemptyfolders ? $skipemptyfolders : 1 ; 2957 2958 # Out of memory with messages over 1 GB ? 2959 $mysync->{ maxsize } = defined $mysync->{ maxsize } ? $mysync->{ maxsize } : 1_000_000_000 ; 2960 2961 # tail -f behaviour on by default 2962 $mysync->{ tail } = defined $mysync->{ tail } ? $mysync->{ tail } : 1 ; 2963 2964 # not sure it's for good 2965 @useheader = qw( Message-Id ) ; 2966 2967 # addheader on by default 2968 $mysync->{ addheader } = defined $mysync->{ addheader } ? $mysync->{ addheader } : 1 ; 2969 2970 return ; 2971} 2972 2973sub cgioutputenvcontext 2974{ 2975 my $mysync = shift @ARG ; 2976 2977 for my $envvar ( qw( REMOTE_ADDR REMOTE_HOST HTTP_REFERER HTTP_USER_AGENT SERVER_SOFTWARE SERVER_PORT HTTP_COOKIE ) ) { 2978 2979 my $envval = $ENV{ $envvar } || q{} ; 2980 if ( $envval ) { output( $mysync, "$envvar is $envval\n" ) } ; 2981 } 2982 2983 return ; 2984} 2985 2986 2987 2988 2989 2990sub debugsleep 2991{ 2992 my $mysync = shift @ARG ; 2993 if ( defined $mysync->{debugsleep} ) { 2994 myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ; 2995 sleep $mysync->{debugsleep} ; 2996 } 2997 return ; 2998} 2999 3000sub foldersizes_on_h1h2 3001{ 3002 my $mysync = shift ; 3003 3004 myprint( << 'END_SIZE' ) ; 3005 3006Folders sizes before the synchronization. 3007You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend" 3008but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy. 3009END_SIZE 3010 3011 ( $h1_nb_msg_start, $h1_bytes_start ) = foldersizes( 'Host1', $mysync->{imap1}, $search1, $mysync->{abletosearch1}, @h1_folders_wanted ) ; 3012 ( $h2_nb_msg_start, $h2_bytes_start ) = foldersizes( 'Host2', $mysync->{imap2}, $search2, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; 3013 3014 if ( not all_defined( $h1_nb_msg_start, $h1_bytes_start, $h2_nb_msg_start, $h2_bytes_start ) ) { 3015 my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ; 3016 errors_incr( $mysync, $error ) ; 3017 $foldersizes = 0 ; 3018 $foldersizesatend = 0 ; 3019 return ; 3020 } 3021 3022 my $h2_bytes_limit = $mysync->{h2}->{quota_limit_bytes} || 0 ; 3023 if ( $h2_bytes_limit and ( $h2_bytes_limit < $h1_bytes_start ) ) { 3024 my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $h1_bytes_start / $h2_bytes_limit ) ; 3025 my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $h1_bytes_start bytes / $h2_bytes_limit bytes )\n" ; 3026 errors_incr( $mysync, $error ) ; 3027 } 3028 return ; 3029} 3030 3031 3032sub total_bytes_max_reached 3033{ 3034 my $mysync = shift ; 3035 3036 if ( ! $mysync->{ exitwhenover } ) { 3037 return( 0 ) ; 3038 } 3039 if ( $mysync->{ total_bytes_transferred } >= $mysync->{ exitwhenover } ) { 3040 myprint( "Maximum bytes transferred reached, $mysync->{total_bytes_transferred} >= $mysync->{ exitwhenover }, ending sync\n" ) ; 3041 return( 1 ) ; 3042 } 3043 return ; 3044} 3045 3046 3047sub tests_mock_capability 3048{ 3049 note( 'Entering tests_mock_capability()' ) ; 3050 3051 my $myimap ; 3052 ok( $myimap = mock_capability( ), 3053 'mock_capability: (1) no args => a Test::MockObject' 3054 ) ; 3055 ok( $myimap->isa( 'Test::MockObject' ), 3056 'mock_capability: (2) no args => a Test::MockObject' 3057 ) ; 3058 3059 is( undef, $myimap->capability( ), 3060 'mock_capability: (3) no args => capability undef' 3061 ) ; 3062 3063 ok( mock_capability( $myimap ), 3064 'mock_capability: (1) one arg => MockObject' 3065 ) ; 3066 3067 is( undef, $myimap->capability( ), 3068 'mock_capability: (2) one arg OO style => capability undef' 3069 ) ; 3070 3071 ok( mock_capability( $myimap, $NUMBER_123456 ), 3072 'mock_capability: (1) two args 123456 => capability 123456' 3073 ) ; 3074 3075 is( $NUMBER_123456, $myimap->capability( ), 3076 'mock_capability: (2) two args 123456 => capability 123456' 3077 ) ; 3078 3079 ok( mock_capability( $myimap, 'ABCD' ), 3080 'mock_capability: (1) two args ABCD => capability ABCD' 3081 ) ; 3082 is( 'ABCD', $myimap->capability( ), 3083 'mock_capability: (2) two args ABCD => capability ABCD' 3084 ) ; 3085 3086 ok( mock_capability( $myimap, [ 'ABCD' ] ), 3087 'mock_capability: (1) two args [ ABCD ] => capability [ ABCD ]' 3088 ) ; 3089 is_deeply( [ 'ABCD' ], $myimap->capability( ), 3090 'mock_capability: (2) two args [ ABCD ] => capability [ ABCD ]' 3091 ) ; 3092 3093 ok( mock_capability( $myimap, [ 'ABC', 'DEF' ] ), 3094 'mock_capability: (1) two args [ ABC, DEF ] => capability [ ABC, DEF ]' 3095 ) ; 3096 is_deeply( [ 'ABC', 'DEF' ], $myimap->capability( ), 3097 'mock_capability: (2) two args [ ABC, DEF ] => capability capability [ ABC, DEF ]' 3098 ) ; 3099 3100 ok( mock_capability( $myimap, 'ABC', 'DEF' ), 3101 'mock_capability: (1) two args ABC, DEF => capability [ ABC, DEF ]' 3102 ) ; 3103 is_deeply( [ 'ABC', 'DEF' ], [ $myimap->capability( ) ], 3104 'mock_capability: (2) two args ABC, DEF => capability capability [ ABC, DEF ]' 3105 ) ; 3106 3107 ok( mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ), 3108 'mock_capability: (1) two args IMAP4rev1, APPENDLIMIT=123456 => capability [ IMAP4rev1, APPENDLIMIT=123456 ]' 3109 ) ; 3110 is_deeply( [ 'IMAP4rev1', 'APPENDLIMIT=123456' ], [ $myimap->capability( ) ], 3111 'mock_capability: (2) two args IMAP4rev1, APPENDLIMIT=123456 => capability capability [ IMAP4rev1, APPENDLIMIT=123456 ]' 3112 ) ; 3113 3114 note( 'Leaving tests_mock_capability()' ) ; 3115 return ; 3116} 3117 3118sub sig_install_toggle_sleep 3119{ 3120 my $mysync = shift ; 3121 if ( 'MSWin32' ne $OSNAME ) { 3122 #myprint( "sig_install( $mysync, \&toggle_sleep, 'USR1' )\n" ) ; 3123 sig_install( $mysync, 'toggle_sleep', 'USR1' ) ; 3124 } 3125 #myprint( "Leaving sig_install_toggle_sleep\n" ) ; 3126 return ; 3127} 3128 3129 3130sub mock_capability 3131{ 3132 my $myimap = shift ; 3133 my @has_capability_value = @ARG ; 3134 my ( $has_capability_value ) = @has_capability_value ; 3135 3136 if ( ! $myimap ) 3137 { 3138 require_ok( "Test::MockObject" ) ; 3139 $myimap = Test::MockObject->new( ) ; 3140 } 3141 3142 $myimap->mock( 3143 'capability', 3144 sub { return wantarray ? 3145 @has_capability_value 3146 : $has_capability_value ; 3147 } 3148 ) ; 3149 3150 return $myimap ; 3151} 3152 3153 3154sub tests_capability_of 3155{ 3156 note( 'Entering tests_capability_of()' ) ; 3157 3158 is( undef, capability_of( ), 3159 'capability_of: no args => undef' ) ; 3160 3161 my $myimap ; 3162 is( undef, capability_of( $myimap ), 3163 'capability_of: undef => undef' ) ; 3164 3165 3166 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; 3167 3168 is( undef, capability_of( $myimap, 'CACA' ), 3169 'capability_of: two args unknown capability => undef' ) ; 3170 3171 3172 is( $NUMBER_123456, capability_of( $myimap, 'APPENDLIMIT' ), 3173 'capability_of: two args APPENDLIMIT 123456 => 123456 yeah!' ) ; 3174 3175 note( 'Leaving tests_capability_of()' ) ; 3176 return ; 3177} 3178 3179 3180sub capability_of 3181{ 3182 my $imap = shift || return ; 3183 my $capability_keyword = shift || return ; 3184 3185 my @capability = $imap->capability ; 3186 3187 if ( ! @capability ) { return ; } 3188 my $capability_value = search_in_array( $capability_keyword, @capability ) ; 3189 3190 return $capability_value ; 3191} 3192 3193 3194sub tests_search_in_array 3195{ 3196 note( 'Entering tests_search_in_array()' ) ; 3197 3198 is( undef, search_in_array( 'KA' ), 3199 'search_in_array: no array => undef ' ) ; 3200 3201 is( 'VA', search_in_array( 'KA', ( 'KA=VA' ) ), 3202 'search_in_array: KA KA=VA => VA ' ) ; 3203 3204 is( 'VA', search_in_array( 'KA', ( 'KA=VA', 'KB=VB' ) ), 3205 'search_in_array: KA KA=VA KB=VB => VA ' ) ; 3206 3207 is( 'VB', search_in_array( 'KB', ( 'KA=VA', 'KB=VB' ) ), 3208 'search_in_array: KA=VA KB=VB => VB ' ) ; 3209 3210 note( 'Leaving tests_search_in_array()' ) ; 3211 return ; 3212} 3213 3214sub search_in_array 3215{ 3216 my ( $key, @array ) = @ARG ; 3217 3218 foreach my $item ( @array ) 3219 { 3220 3221 if ( $item =~ /([^=]+)=(.*)/ ) 3222 { 3223 if ( $1 eq $key ) 3224 { 3225 return $2 ; 3226 } 3227 } 3228 } 3229 3230 return ; 3231} 3232 3233 3234 3235 3236sub tests_appendlimit_from_capability 3237{ 3238 note( 'Entering tests_appendlimit_from_capability()' ) ; 3239 3240 is( undef, appendlimit_from_capability( ), 3241 'appendlimit_from_capability: no args => undef' 3242 ) ; 3243 3244 my $myimap ; 3245 is( undef, appendlimit_from_capability( $myimap ), 3246 'appendlimit_from_capability: undef arg => undef' 3247 ) ; 3248 3249 3250 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; 3251 3252 # Normal behavior 3253 is( $NUMBER_123456, appendlimit_from_capability( $myimap ), 3254 'appendlimit_from_capability: APPENDLIMIT=123456 => 123456' 3255 ) ; 3256 3257 # Not a number 3258 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=ABC' ) ; 3259 3260 is( undef, appendlimit_from_capability( $myimap ), 3261 'appendlimit_from_capability: not a number => undef' 3262 ) ; 3263 3264 note( 'Leaving tests_appendlimit_from_capability()' ) ; 3265 return ; 3266} 3267 3268 3269sub appendlimit_from_capability 3270{ 3271 my $myimap = shift ; 3272 if ( ! $myimap ) 3273 { 3274 myprint( "Warn: no imap with call to appendlimit_from_capability\n" ) ; 3275 return ; 3276 } 3277 3278 #myprint( Data::Dumper->Dump( [ \$myimap ] ) ) ; 3279 my $appendlimit = capability_of( $myimap, 'APPENDLIMIT' ) ; 3280 #myprint( "has_capability APPENDLIMIT $appendlimit\n" ) ; 3281 if ( is_an_integer( $appendlimit ) ) 3282 { 3283 return $appendlimit ; 3284 } 3285 return ; 3286} 3287 3288 3289sub tests_appendlimit 3290{ 3291 note( 'Entering tests_appendlimit()' ) ; 3292 3293 is( undef, appendlimit( ), 3294 'appendlimit: no args => undef' 3295 ) ; 3296 3297 my $mysync = { } ; 3298 3299 is( undef, appendlimit( $mysync ), 3300 'appendlimit: no imap2 => undef' 3301 ) ; 3302 3303 my $myimap ; 3304 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; 3305 3306 $mysync->{ imap2 } = $myimap ; 3307 3308 is( 123456, appendlimit( $mysync ), 3309 'appendlimit: imap2 with APPENDLIMIT=123456 => 123456' 3310 ) ; 3311 3312 note( 'Leaving tests_appendlimit()' ) ; 3313 return ; 3314} 3315 3316sub appendlimit 3317{ 3318 my $mysync = shift || return ; 3319 my $myimap = $mysync->{ imap2 } ; 3320 3321 my $appendlimit = appendlimit_from_capability( $myimap ) ; 3322 if ( defined $appendlimit ) 3323 { 3324 myprint( "Host2: found APPENDLIMIT=$appendlimit in CAPABILITY (use --appendlimit xxxx to override this automatic setting)\n" ) ; 3325 return $appendlimit ; 3326 } 3327 return ; 3328 3329} 3330 3331 3332sub tests_maxsize_setting 3333{ 3334 note( 'Entering tests_maxsize_setting()' ) ; 3335 3336 is( undef, maxsize_setting( ), 3337 'maxsize_setting: no args => undef' 3338 ) ; 3339 3340 my $mysync ; 3341 3342 is( undef, maxsize_setting( $mysync ), 3343 'maxsize_setting: undef arg => undef' 3344 ) ; 3345 3346 $mysync = { } ; 3347 $mysync->{ maxsize } = $NUMBER_123456 ; 3348 3349 # --maxsize alone 3350 is( $NUMBER_123456, maxsize_setting( $mysync ), 3351 'maxsize_setting: --maxsize 123456 alone => 123456' 3352 ) ; 3353 3354 3355 $mysync = { } ; 3356 my $myimap ; 3357 3358 $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ; 3359 $mysync->{ imap2 } = $myimap ; 3360 3361 # APPENDLIMIT alone 3362 is( $NUMBER_654321, maxsize_setting( $mysync ), 3363 'maxsize_setting: APPENDLIMIT 654321 alone => 654321' 3364 ) ; 3365 3366 is( $NUMBER_654321, $mysync->{ maxsize }, 3367 'maxsize_setting: APPENDLIMIT 654321 alone => maxsize 654321' 3368 ) ; 3369 3370 # APPENDLIMIT with --appendlimit => --appendlimit wins 3371 $mysync->{ appendlimit } = $NUMBER_123456 ; 3372 3373 is( $NUMBER_123456, maxsize_setting( $mysync ), 3374 'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => 123456' 3375 ) ; 3376 3377 is( $NUMBER_123456, $mysync->{ maxsize }, 3378 'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => maxsize 123456' 3379 ) ; 3380 3381 # Fresh 3382 $mysync = { } ; 3383 $mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ; 3384 3385 # Case: "APPENDLIMIT >= --maxsize" => maxsize. 3386 $mysync->{ maxsize } = $NUMBER_123456 ; 3387 3388 is( $NUMBER_123456, maxsize_setting( $mysync ), 3389 'maxsize_setting: APPENDLIMIT 654321 --maxsize 123456 => 123456' 3390 ) ; 3391 3392 # Case: "APPENDLIMIT < --maxsize" => APPENDLIMIT. 3393 3394 3395 # Fresh 3396 $mysync = { } ; 3397 $mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; 3398 $mysync->{ maxsize } = $NUMBER_654321 ; 3399 3400 is( $NUMBER_123456, maxsize_setting( $mysync ), 3401 'maxsize_setting: APPENDLIMIT 123456 --maxsize 654321 => 123456 ' 3402 ) ; 3403 3404 # Now --truncmess stuff 3405 3406 3407 3408 note( 'Leaving tests_maxsize_setting()' ) ; 3409 3410 return ; 3411} 3412 3413# Three variables to take account of 3414# appendlimit (given by --appendlimit or CAPABILITY...) 3415# maxsize 3416# truncmess 3417 3418sub maxsize_setting 3419{ 3420 my $mysync = shift || return ; 3421 3422 if ( defined $mysync->{ appendlimit } ) 3423 { 3424 myprint( "Host2: Getting appendlimit from --appendlimit $mysync->{ appendlimit }\n" ) ; 3425 } 3426 else 3427 { 3428 $mysync->{ appendlimit } = appendlimit( $mysync ) ; 3429 } 3430 3431 3432 if ( all_defined( $mysync->{ appendlimit }, $mysync->{ maxsize } ) ) 3433 { 3434 my $min_maxsize_appendlimit = min( $mysync->{ maxsize }, $mysync->{ appendlimit } ) ; 3435 myprint( "Host2: Setting maxsize to $min_maxsize_appendlimit (min of --maxsize $mysync->{ maxsize } and appendlimit $mysync->{ appendlimit }\n" ) ; 3436 $mysync->{ maxsize } = $min_maxsize_appendlimit ; 3437 return $mysync->{ maxsize } ; 3438 } 3439 elsif ( defined $mysync->{ appendlimit } ) 3440 { 3441 myprint( "Host2: Setting maxsize to appendlimit $mysync->{ appendlimit }\n" ) ; 3442 $mysync->{ maxsize } = $mysync->{ appendlimit } ; 3443 return $mysync->{ maxsize } ; 3444 }elsif ( defined $mysync->{ maxsize } ) 3445 { 3446 return $mysync->{ maxsize } ; 3447 }else 3448 { 3449 return ; 3450 } 3451} 3452 3453 3454 3455 3456sub all_defined 3457{ 3458 if ( not @ARG ) { 3459 return 0 ; 3460 } 3461 foreach my $elem ( @ARG ) { 3462 if ( not defined $elem ) { 3463 return 0 ; 3464 } 3465 } 3466 return 1 ; 3467} 3468 3469sub tests_all_defined 3470{ 3471 note( 'Entering tests_all_defined()' ) ; 3472 3473 is( 0, all_defined( ), 'all_defined: no param => 0' ) ; 3474 is( 0, all_defined( () ), 'all_defined: void list => 0' ) ; 3475 is( 0, all_defined( undef ), 'all_defined: undef => 0' ) ; 3476 is( 0, all_defined( undef, undef ), 'all_defined: undef => 0' ) ; 3477 is( 0, all_defined( 1, undef ), 'all_defined: 1 undef => 0' ) ; 3478 is( 0, all_defined( undef, 1 ), 'all_defined: undef 1 => 0' ) ; 3479 is( 1, all_defined( 1, 1 ), 'all_defined: 1 1 => 1' ) ; 3480 is( 1, all_defined( (1, 1) ), 'all_defined: (1 1) => 1' ) ; 3481 3482 note( 'Leaving tests_all_defined()' ) ; 3483 return ; 3484} 3485 3486 3487sub tests_hashsynclocal 3488{ 3489 note( 'Entering tests_hashsynclocal()' ) ; 3490 3491 my $mysync = { 3492 host1 => '', 3493 user1 => '', 3494 password1 => '', 3495 host2 => '', 3496 user2 => '', 3497 password2 => '', 3498 } ; 3499 3500 is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no hashfile name' ) ; 3501 3502 $mysync->{ hashfile } = '' ; 3503 is( undef, hashsynclocal( $mysync ), 'hashsynclocal: empty hashfile name' ) ; 3504 3505 $mysync->{ hashfile } = './noexist/rrr' ; 3506 is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no exists hashfile dir' ) ; 3507 3508 SKIP: { 3509 if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) { skip( 'Tests only for non-root Unix', 1 ) ; } 3510 $mysync->{ hashfile } = '/rrr' ; 3511 is( undef, hashsynclocal( $mysync ), 'hashsynclocal: permission denied' ) ; 3512 } 3513 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'hashsynclocal: mkpath W/tmp/tests/' ) ; 3514 $mysync->{ hashfile } = 'W/tmp/tests/imapsync_hash' ; 3515 3516 ok( ! -e 'W/tmp/tests/imapsync_hash' || unlink 'W/tmp/tests/imapsync_hash', 'hashsynclocal: unlink W/tmp/tests/imapsync_hash' ) ; 3517 ok( ! -e 'W/tmp/tests/imapsync_hash', 'hashsynclocal: verify there is no W/tmp/tests/imapsync_hash' ) ; 3518 is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync, 'mukksyhpmbixkxkpjlqivmlqsulpictj' ), 'hashsynclocal: creating/reading W/tmp/tests/imapsync_hash' ) ; 3519 # A second time now 3520 is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync ), 'hashsynclocal: reading W/tmp/tests/imapsync_hash second time => same' ) ; 3521 3522 note( 'Leaving tests_hashsynclocal()' ) ; 3523 return ; 3524} 3525 3526sub hashsynclocal 3527{ 3528 my $mysync = shift ; 3529 my $hashkey = shift ; # Optional, only there for tests 3530 my $hashfile = $mysync->{ hashfile } ; 3531 $hashfile = createhashfileifneeded( $hashfile, $hashkey ) ; 3532 if ( ! $hashfile ) { 3533 return ; 3534 } 3535 $hashkey = firstline( $hashfile ) ; 3536 if ( ! $hashkey ) { 3537 myprint( "No hashkey!\n" ) ; 3538 return ; 3539 } 3540 my $hashsynclocal = hashsync( $mysync, $hashkey ) ; 3541 return( $hashsynclocal ) ; 3542 3543} 3544 3545sub tests_hashsync 3546{ 3547 note( 'Entering tests_hashsync()' ) ; 3548 3549 3550 is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( {}, q{} ), 'hashsync: empty args' ) ; 3551 my $mysync ; 3552 $mysync->{ host1 } = 'zzz' ; 3553 is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ; 3554 is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ; 3555 $mysync->{ host2 } = 'zzz' ; 3556 is( '15959573e4a86763253a7aedb1a2b0c60d133dc2', hashsync( $mysync, q{} ), 'hashsync: + host2 zzz => ' ) ; 3557 is( 'b8d4ab541b209c75928528020ca28ee43488bd8f', hashsync( $mysync, 'A' ), 'hashsync: + hashkey A => ' ) ; 3558 3559 note( 'Leaving tests_hashsync()' ) ; 3560 return ; 3561} 3562 3563sub hashsync 3564{ 3565 my $mysync = shift ; 3566 my $hashkey = shift ; 3567 3568 my $mystring = join( q{}, 3569 $mysync->{ host1 } || q{}, 3570 $mysync->{ user1 } || q{}, 3571 $mysync->{ password1 } || q{}, 3572 $mysync->{ host2 } || q{}, 3573 $mysync->{ user2 } || q{}, 3574 $mysync->{ password2 } || q{}, 3575 ) ; 3576 my $hashsync = hmac_sha1_hex( $mystring, $hashkey ) ; 3577 #myprint( "$hashsync\n" ) ; 3578 return( $hashsync ) ; 3579} 3580 3581 3582sub tests_createhashfileifneeded 3583{ 3584 note( 'Entering tests_createhashfileifneeded()' ) ; 3585 3586 is( undef, createhashfileifneeded( ), 'createhashfileifneeded: no parameters => undef' ) ; 3587 3588 note( 'Leaving tests_createhashfileifneeded()' ) ; 3589 return ; 3590} 3591 3592sub createhashfileifneeded 3593{ 3594 my $hashfile = shift ; 3595 my $hashkey = shift || rand32( ) ; 3596 3597 # no name 3598 if ( ! $hashfile ) { 3599 return ; 3600 } 3601 # already there 3602 if ( -e -r $hashfile ) { 3603 return $hashfile ; 3604 } 3605 # not creatable 3606 if ( ! -w dirname( $hashfile ) ) { 3607 return ; 3608 } 3609 # creatable 3610 open my $FILE_HANDLE, '>', $hashfile 3611 or do { 3612 myprint( "Could not open $hashfile for writing. Check permissions or disk space." ) ; 3613 return ; 3614 } ; 3615 myprint( "Writing random hashkey in $hashfile, once for all times\n" ) ; 3616 print $FILE_HANDLE $hashkey ; 3617 close $FILE_HANDLE ; 3618 # Should be there now 3619 if ( -e -r $hashfile ) { 3620 return $hashfile ; 3621 } 3622 # unknown failure 3623 return ; 3624} 3625 3626sub tests_rand32 3627{ 3628 note( 'Entering tests_rand32()' ) ; 3629 3630 my $string = rand32( ) ; 3631 myprint( "$string\n" ) ; 3632 is( 32, length( $string ), 'rand32: 32 characters long' ) ; 3633 is( 32, length( rand32( ) ), 'rand32: 32 characters long, another one' ) ; 3634 3635 note( 'Leaving tests_rand32()' ) ; 3636 return ; 3637} 3638 3639sub rand32 3640{ 3641 my @chars = ( "a".."z" ) ; 3642 my $string; 3643 $string .= $chars[rand @chars] for 1..32 ; 3644 return $string ; 3645} 3646 3647sub imap_id_stuff 3648{ 3649 my $mysync = shift ; 3650 3651 if ( not $mysync->{id} ) { return ; } ; 3652 3653 $mysync->{h1_imap_id} = imap_id( $mysync, $mysync->{imap1}, 'Host1' ) ; 3654 #myprint( 'Host1: ' . $mysync->{h1_imap_id} ) ; 3655 $mysync->{h2_imap_id} = imap_id( $mysync, $mysync->{imap2}, 'Host2' ) ; 3656 #myprint( 'Host2: ' . $mysync->{h2_imap_id} ) ; 3657 3658 return ; 3659} 3660 3661sub imap_id 3662{ 3663 my ( $mysync, $imap, $Side ) = @_ ; 3664 3665 $Side ||= q{} ; 3666 my $imap_id_response = q{} ; 3667 3668 if ( not $imap->has_capability( 'ID' ) ) { 3669 $imap_id_response = 'No ID capability' ; 3670 myprint( "$Side: No ID capability\n" ) ; 3671 }else{ 3672 my $id_inp = imapsync_id( $mysync, { side => lc $Side } ) ; 3673 myprint( "\n$Side: found ID capability. Sending/receiving ID, presented in raw IMAP for now.\n" 3674 . "In order to avoid sending/receiving ID, use option --noid\n" ) ; 3675 my $debug_before = $imap->Debug( ) ; 3676 $imap->Debug( 1 ) ; 3677 my $id_out = $imap->tag_and_run( 'ID ' . $id_inp ) ; 3678 #my $id_out = $imap->tag_and_run( 'ID NIL' ) ; 3679 myprint( "\n" ) ; 3680 $imap->Debug( $debug_before ) ; 3681 #$imap_id_response = Data::Dumper->Dump( [ $id_out ], [ 'IMAP_ID' ] ) ; 3682 } 3683 return( $imap_id_response ) ; 3684} 3685 3686sub imapsync_id 3687{ 3688 my $mysync = shift ; 3689 my $overhashref = shift ; 3690 # See http://tools.ietf.org/html/rfc2971.html 3691 3692 my $imapsync_id = { } ; 3693 3694 my $imapsync_id_lamiral = { 3695 name => 'imapsync', 3696 version => imapsync_version( $mysync ), 3697 os => $OSNAME, 3698 vendor => 'Gilles LAMIRAL', 3699 'support-url' => 'https://imapsync.lamiral.info/', 3700 # Example of date-time: 19-Sep-2015 08:56:07 3701 date => date_from_rcs( q{$Date: 2019/06/26 19:30:56 $ } ), 3702 } ; 3703 3704 my $imapsync_id_github = { 3705 name => 'imapsync', 3706 version => imapsync_version( $mysync ), 3707 os => $OSNAME, 3708 vendor => 'github', 3709 'support-url' => 'https://github.com/imapsync/imapsync', 3710 date => date_from_rcs( q{$Date: 2019/06/26 19:30:56 $ } ), 3711 } ; 3712 3713 $imapsync_id = $imapsync_id_lamiral ; 3714 #$imapsync_id = $imapsync_id_github ; 3715 my %mix = ( %{ $imapsync_id }, %{ $overhashref } ) ; 3716 my $imapsync_id_str = format_for_imap_arg( \%mix ) ; 3717 #myprint( "$imapsync_id_str\n" ) ; 3718 return( $imapsync_id_str ) ; 3719} 3720 3721sub tests_imapsync_id 3722{ 3723 note( 'Entering tests_imapsync_id()' ) ; 3724 3725 my $mysync ; 3726 ok( '("name" "imapsync" "version" "111" "os" "beurk" "vendor" "Gilles LAMIRAL" "support-url" "https://imapsync.lamiral.info/" "date" "22-12-1968" "side" "host1")' 3727 eq imapsync_id( $mysync, 3728 { 3729 version => 111, 3730 os => 'beurk', 3731 date => '22-12-1968', 3732 side => 'host1' 3733 } 3734 ), 3735 'tests_imapsync_id override' 3736 ) ; 3737 3738 note( 'Leaving tests_imapsync_id()' ) ; 3739 return ; 3740} 3741 3742sub format_for_imap_arg 3743{ 3744 my $ref = shift ; 3745 3746 my $string = q{} ; 3747 my %terms = %{ $ref } ; 3748 my @terms = ( ) ; 3749 if ( not ( %terms ) ) { return( 'NIL' ) } ; 3750 # sort like in RFC then add extra key/values 3751 foreach my $key ( qw( name version os os-version vendor support-url address date command arguments environment) ) { 3752 if ( $terms{ $key } ) { 3753 push @terms, $key, $terms{ $key } ; 3754 delete $terms{ $key } ; 3755 } 3756 } 3757 push @terms, %terms ; 3758 $string = '(' . ( join q{ }, map { '"' . $_ . '"' } @terms ) . ')' ; 3759 return( $string ) ; 3760} 3761 3762 3763 3764sub tests_format_for_imap_arg 3765{ 3766 note( 'Entering tests_format_for_imap_arg()' ) ; 3767 3768 ok( 'NIL' eq format_for_imap_arg( { } ), 'format_for_imap_arg empty hash ref' ) ; 3769 ok( '("name" "toto")' eq format_for_imap_arg( { name => 'toto' } ), 'format_for_imap_arg { name => toto }' ) ; 3770 ok( '("name" "toto" "key" "val")' eq format_for_imap_arg( { name => 'toto', key => 'val' } ), 'format_for_imap_arg 2 x key val' ) ; 3771 3772 note( 'Leaving tests_format_for_imap_arg()' ) ; 3773 return ; 3774} 3775 3776sub quota 3777{ 3778 my ( $mysync, $imap, $side ) = @_ ; 3779 3780 my %side = ( 3781 h1 => 'Host1', 3782 h2 => 'Host2', 3783 ) ; 3784 my $Side = $side{ $side } ; 3785 my $debug_before = $imap->Debug( ) ; 3786 $imap->Debug( 1 ) ; 3787 if ( not $imap->has_capability( 'QUOTA' ) ) { 3788 $imap->Debug( $debug_before ) ; 3789 return ; 3790 } ; 3791 myprint( "\n$Side: found quota, presented in raw IMAP\n" ) ; 3792 my $getquotaroot = $imap->getquotaroot( 'INBOX' ) ; 3793 # Gmail INBOX quotaroot is "" but with it Mail::IMAPClient does a literal GETQUOTA {2} \n "" 3794 #$imap->quota( 'ROOT' ) ; 3795 #$imap->quota( '""' ) ; 3796 myprint( "\n" ) ; 3797 $imap->Debug( $debug_before ) ; 3798 my $quota_limit_bytes = quota_extract_storage_limit_in_bytes( $mysync, $getquotaroot ) ; 3799 my $quota_current_bytes = quota_extract_storage_current_in_bytes( $mysync, $getquotaroot ) ; 3800 $mysync->{$side}->{quota_limit_bytes} = $quota_limit_bytes ; 3801 $mysync->{$side}->{quota_current_bytes} = $quota_current_bytes ; 3802 my $quota_percent ; 3803 if ( $quota_limit_bytes > 0 ) { 3804 $quota_percent = mysprintf( '%.2f', $NUMBER_100 * $quota_current_bytes / $quota_limit_bytes ) ; 3805 }else{ 3806 $quota_percent = 0 ; 3807 } 3808 myprint( "$Side: Quota current storage is $quota_current_bytes bytes. Limit is $quota_limit_bytes bytes. So $quota_percent % full\n" ) ; 3809 if ( $QUOTA_PERCENT_LIMIT < $quota_percent ) { 3810 my $error = "$Side: $quota_percent % full: it is time to find a bigger place! ( $quota_current_bytes bytes / $quota_limit_bytes bytes )\n" ; 3811 errors_incr( $mysync, $error ) ; 3812 } 3813 return ; 3814} 3815 3816sub tests_quota_extract_storage_limit_in_bytes 3817{ 3818 note( 'Entering tests_quota_extract_storage_limit_in_bytes()' ) ; 3819 3820 my $mysync = {} ; 3821 my $imap_output = [ 3822 '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', 3823 '* QUOTA "Storage quota" (STORAGE 1 104857600)', 3824 '* QUOTA "Messages quota" (MESSAGE 2 100000)', 3825 '5 OK Getquotaroot completed.' 3826 ] ; 3827 ok( $NUMBER_104_857_600 * $KIBI == quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes ') ; 3828 3829 note( 'Leaving tests_quota_extract_storage_limit_in_bytes()' ) ; 3830 return ; 3831} 3832 3833sub quota_extract_storage_limit_in_bytes 3834{ 3835 my $mysync = shift ; 3836 my $imap_output = shift ; 3837 3838 my $limit_kb ; 3839 $limit_kb = ( map { /.*\(\s*STORAGE\s+\d+\s+(\d+)\s*\)/x ? $1 : () } @{ $imap_output } )[0] ; 3840 $limit_kb ||= 0 ; 3841 $mysync->{ debug } and myprint( "storage_limit_kb = $limit_kb\n" ) ; 3842 return( $KIBI * $limit_kb ) ; 3843} 3844 3845 3846sub tests_quota_extract_storage_current_in_bytes 3847{ 3848 note( 'Entering tests_quota_extract_storage_current_in_bytes()' ) ; 3849 3850 my $mysync = {} ; 3851 my $imap_output = [ 3852 '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', 3853 '* QUOTA "Storage quota" (STORAGE 1 104857600)', 3854 '* QUOTA "Messages quota" (MESSAGE 2 100000)', 3855 '5 OK Getquotaroot completed.' 3856 ] ; 3857 ok( 1*$KIBI == quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ; 3858 3859 note( 'Leaving tests_quota_extract_storage_current_in_bytes()' ) ; 3860 return ; 3861} 3862 3863sub quota_extract_storage_current_in_bytes 3864{ 3865 my $mysync = shift ; 3866 my $imap_output = shift ; 3867 3868 my $current_kb ; 3869 $current_kb = ( map { /.*\(\s*STORAGE\s+(\d+)\s+\d+\s*\)/x ? $1 : () } @{ $imap_output } )[0] ; 3870 $current_kb ||= 0 ; 3871 $mysync->{ debug } and myprint( "storage_current_kb = $current_kb\n" ) ; 3872 return( $KIBI * $current_kb ) ; 3873 3874} 3875 3876 3877sub automap 3878{ 3879 my ( $mysync ) = @_ ; 3880 3881 if ( $mysync->{automap} ) { 3882 myprint( "Turned on automapping folders ( use --noautomap to turn off automapping )\n" ) ; 3883 }else{ 3884 myprint( "Turned off automapping folders ( use --automap to turn on automapping )\n" ) ; 3885 return ; 3886 } 3887 3888 $mysync->{h1_special} = special_from_folders_hash( $mysync, $mysync->{imap1}, 'Host1' ) ; 3889 $mysync->{h2_special} = special_from_folders_hash( $mysync, $mysync->{imap2}, 'Host2' ) ; 3890 3891 build_possible_special( $mysync ) ; 3892 build_guess_special( $mysync ) ; 3893 build_automap( $mysync ) ; 3894 3895 return ; 3896} 3897 3898 3899 3900 3901sub build_guess_special 3902{ 3903 my ( $mysync ) = shift ; 3904 3905 foreach my $h1_fold ( sort keys %{ $mysync->{h1_folders_all} } ) { 3906 my $special = guess_special( $h1_fold, $mysync->{possible_special}, $mysync->{h1_prefix} ) ; 3907 if ( $special ) { 3908 $mysync->{h1_special_guessed}{$h1_fold} = $special ; 3909 my $already_guessed = $mysync->{h1_special_guessed}{$special} ; 3910 if ( $already_guessed ) { 3911 myprint( "Host1: $h1_fold not $special because set to $already_guessed\n" ) ; 3912 }else{ 3913 $mysync->{h1_special_guessed}{$special} = $h1_fold ; 3914 } 3915 } 3916 } 3917 foreach my $h2_fold ( sort keys %{ $mysync->{h2_folders_all} } ) { 3918 my $special = guess_special( $h2_fold, $mysync->{possible_special}, $mysync->{h2_prefix} ) ; 3919 if ( $special ) { 3920 $mysync->{h2_special_guessed}{$h2_fold} = $special ; 3921 my $already_guessed = $mysync->{h2_special_guessed}{$special} ; 3922 if ( $already_guessed ) { 3923 myprint( "Host2: $h2_fold not $special because set to $already_guessed\n" ) ; 3924 }else{ 3925 $mysync->{h2_special_guessed}{$special} = $h2_fold ; 3926 } 3927 } 3928 } 3929 return ; 3930} 3931 3932sub guess_special 3933{ 3934 my( $folder, $possible_special_ref, $prefix ) = @_ ; 3935 3936 my $folder_no_prefix = $folder ; 3937 $folder_no_prefix =~ s/\Q${prefix}\E//xms ; 3938 #$debug and myprint( "folder_no_prefix: $folder_no_prefix\n" ) ; 3939 3940 my $guess_special = $possible_special_ref->{ $folder } 3941 || $possible_special_ref->{ $folder_no_prefix } 3942 || q{} ; 3943 3944 return( $guess_special ) ; 3945} 3946 3947sub tests_guess_special 3948{ 3949 note( 'Entering tests_guess_special()' ) ; 3950 3951 my $possible_special_ref = build_possible_special( my $mysync ) ; 3952 ok( '\Sent' eq guess_special( 'Sent', $possible_special_ref, q{} ) ,'guess_special: Sent => \Sent' ) ; 3953 ok( q{} eq guess_special( 'Blabla', $possible_special_ref, q{} ) ,'guess_special: Blabla => q{}' ) ; 3954 ok( '\Sent' eq guess_special( 'INBOX.Sent', $possible_special_ref, 'INBOX.' ) ,'guess_special: INBOX.Sent => \Sent' ) ; 3955 ok( '\Sent' eq guess_special( 'IN BOX.Sent', $possible_special_ref, 'IN BOX.' ) ,'guess_special: IN BOX.Sent => \Sent' ) ; 3956 3957 note( 'Leaving tests_guess_special()' ) ; 3958 return ; 3959} 3960 3961sub build_automap 3962{ 3963 my $mysync = shift ; 3964 $mysync->{ debug } and myprint( "Entering build_automap\n" ) ; 3965 foreach my $h1_fold ( @{ $mysync->{h1_folders_wanted} } ) { 3966 my $h2_fold ; 3967 my $h1_special = $mysync->{h1_special}{$h1_fold} ; 3968 my $h1_special_guessed = $mysync->{h1_special_guessed}{$h1_fold} ; 3969 3970 # Case 1: special on both sides. 3971 if ( $h1_special 3972 and exists $mysync->{h2_special}{$h1_special} ) { 3973 $h2_fold = $mysync->{h2_special}{$h1_special} ; 3974 $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; 3975 next ; 3976 } 3977 # Case 2: special on host1, not on host2 3978 if ( $h1_special 3979 and ( not exists $mysync->{h2_special}{$h1_special} ) 3980 and ( exists $mysync->{h2_special_guessed}{$h1_special} ) 3981 ) { 3982 # special_guessed on host2 3983 $h2_fold = $mysync->{h2_special_guessed}{$h1_special} ; 3984 $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; 3985 next ; 3986 } 3987 # Case 3: no special on host1, special on host2 3988 if ( ( not $h1_special ) 3989 and ( $h1_special_guessed ) 3990 and ( exists $mysync->{h2_special}{$h1_special_guessed} ) 3991 ) { 3992 $h2_fold = $mysync->{h2_special}{$h1_special_guessed} ; 3993 $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; 3994 next ; 3995 } 3996 # Case 4: no special on both sides. 3997 if ( ( not $h1_special ) 3998 and ( $h1_special_guessed ) 3999 and ( not exists $mysync->{h2_special}{$h1_special_guessed} ) 4000 and ( exists $mysync->{h2_special_guessed}{$h1_special_guessed} ) 4001 ) { 4002 $h2_fold = $mysync->{h2_special_guessed}{$h1_special_guessed} ; 4003 $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; 4004 next ; 4005 } 4006 } 4007 return( $mysync->{f1f2auto} ) ; 4008} 4009 4010# I will not add what there is at: 4011# http://stackoverflow.com/questions/2185391/localized-gmail-imap-folders/2185548#2185548 4012# because it works well without 4013sub build_possible_special 4014{ 4015 my $mysync = shift ; 4016 my $possible_special = { } ; 4017 # All|Archive|Drafts|Flagged|Junk|Sent|Trash 4018 4019 $possible_special->{'\All'} = [ 'All', 'All Messages', '&BBIEQQQ1-' ] ; 4020 $possible_special->{'\Archive'} = [ 'Archive', 'Archives', '&BBAEQARFBDgEMg-' ] ; 4021 $possible_special->{'\Drafts'} = [ 'Drafts', 'DRAFTS', '&BCcENQRABD0EPgQyBDgEOgQ4-', 'Szkice', 'Wersje robocze' ] ; 4022 $possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ; 4023 $possible_special->{'\Junk'} = [ 'Junk', 'junk', 'Spam', 'SPAM', '&BCEEPwQwBDw-', 4024 'Potwierdzony spam', 'Wiadomo&AVs-ci-&AVs-mieci', 4025 'Junk E-Mail', 'Junk Email'] ; 4026 $possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items', 4027 'Gesendete Elemente', 'Gesendete Objekte', 4028 '&AMk-l&AOk-ments envoy&AOk-s', 'Envoy&AOk-', 'Objets envoy&AOk-s', 4029 'Elementos enviados', 4030 '&kAFP4W4IMH8wojCkMMYw4A-', 4031 '&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-', 4032 'Elementy wys&AUI-ane'] ; 4033 $possible_special->{'\Trash'} = [ 'Trash', 'TRASH', 4034 '&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-', 4035 'Kosz', 4036 'Deleted Items', 'Deleted Messages' ] ; 4037 4038 4039 foreach my $special ( qw( \All \Archive \Drafts \Flagged \Junk \Sent \Trash ) ){ 4040 foreach my $possible_folder ( @{ $possible_special->{$special} } ) { 4041 $possible_special->{ $possible_folder } = $special ; 4042 } ; 4043 } 4044 $mysync->{possible_special} = $possible_special ; 4045 $mysync->{ debug } and myprint( Data::Dumper->Dump( [ $possible_special ], [ 'possible_special' ] ) ) ; 4046 return( $possible_special ) ; 4047} 4048 4049sub tests_special_from_folders_hash 4050{ 4051 note( 'Entering tests_special_from_folders_hash()' ) ; 4052 4053 my $mysync = {} ; 4054 require_ok( "Test::MockObject" ) ; 4055 my $imapT = Test::MockObject->new( ) ; 4056 4057 is( undef, special_from_folders_hash( ), 'special_from_folders_hash: no args' ) ; 4058 is( undef, special_from_folders_hash( $mysync ), 'special_from_folders_hash: undef args' ) ; 4059 is_deeply( {}, special_from_folders_hash( $mysync, $imapT ), 'special_from_folders_hash: $imap void' ) ; 4060 4061 $imapT->mock( 'folders_hash', sub { return( [ { name => 'Sent', attrs => [ '\Sent' ] } ] ) } ) ; 4062 4063 is_deeply( { Sent => '\Sent', '\Sent' => 'Sent' }, 4064 special_from_folders_hash( $mysync, $imapT ), 'special_from_folders_hash: $imap \Sent' ) ; 4065 4066 note( 'Leaving tests_special_from_folders_hash()' ) ; 4067 return( ) ; 4068} 4069 4070sub special_from_folders_hash 4071{ 4072 my ( $mysync, $imap, $side ) = @_ ; 4073 my %special = ( ) ; 4074 4075 if ( ! defined $imap ) { return ; } 4076 $side = defined $side ? $side : 'Host?' ; 4077 4078 if ( ! $imap->can( 'folders_hash' ) ) { 4079 my $error = "$side: To have automagic rfc6154 folder mapping, upgrade Mail::IMAPClient >= 3.34\n" ; 4080 errors_incr( $mysync, $error ) ; 4081 return( \%special ) ; # empty hash ref 4082 } 4083 my $folders_hash = $imap->folders_hash( ) ; 4084 foreach my $fhash (@{ $folders_hash } ) { 4085 my @special = grep { /\\(?:All|Archive|Drafts|Flagged|Junk|Sent|Trash)/x } @{ $fhash->{attrs} } ; 4086 if ( @special ) { 4087 my $special = $special[0] ; # keep first one. Could be not very good. 4088 if ( exists $special{ $special } ) { 4089 myprintf( "%s: special %-20s = %s already assigned to %s\n", 4090 $side, $fhash->{name}, join( q{ }, @special ), $special{ $special } ) ; 4091 }else{ 4092 myprintf( "%s: special %-20s = %s\n", 4093 $side, $fhash->{name}, join( q{ }, @special ) ) ; 4094 $special{ $special } = $fhash->{name} ; 4095 $special{ $fhash->{name} } = $special ; # double entry value => key 4096 } 4097 } 4098 } 4099 myprint( "\n" ) if ( %special ) ; 4100 return( \%special ) ; 4101} 4102 4103sub errors_incr 4104{ 4105 my ( $mysync, @error ) = @ARG ; 4106 $mysync->{nb_errors}++ ; 4107 4108 if ( @error ) { 4109 errors_log( $mysync, @error ) ; 4110 myprint( @error ) ; 4111 } 4112 4113 $mysync->{errorsmax} ||= $ERRORS_MAX ; 4114 if ( $mysync->{nb_errors} >= $mysync->{errorsmax} ) { 4115 myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). Exiting.\n" ) ; 4116 if ( $mysync->{errorsdump} ) { 4117 myprint( errorsdump( $mysync->{nb_errors}, errors_log( $mysync ) ) ) ; 4118 # again since errorsdump( ) can be very verbose and masquerade previous warning 4119 myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). Exiting.\n" ) ; 4120 } 4121 exit_clean( $mysync, $EXIT_WITH_ERRORS_MAX ) ; 4122 } 4123 return ; 4124} 4125 4126sub tests_errors_log 4127{ 4128 note( 'Entering tests_errors_log()' ) ; 4129 is( undef, errors_log( ), 'errors_log: no args => undef' ) ; 4130 my $mysync = {} ; 4131 is( undef, errors_log( $mysync ), 'errors_log: empty => undef' ) ; 4132 is_deeply( [ 'aieaie' ], [ errors_log( $mysync, 'aieaie' ) ], 'errors_log: aieaie => aieaie' ) ; 4133 # cumulative 4134 is_deeply( [ 'aieaie' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie' ) ; 4135 is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync, 'ouille' ) ], 'errors_log: ouille => aieaie ouille' ) ; 4136 is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie ouille' ) ; 4137 note( 'Leaving tests_errors_log()' ) ; 4138 return ; 4139} 4140 4141sub errors_log 4142{ 4143 my ( $mysync, @error ) = @ARG ; 4144 4145 if ( ! $mysync->{errors_log} ) { 4146 $mysync->{errors_log} = [] ; 4147 } 4148 4149 if ( @error ) { 4150 push @{ $mysync->{errors_log} }, join( q{}, @error ) ; 4151 } 4152 if ( @{ $mysync->{errors_log} } ) { 4153 return @{ $mysync->{errors_log} } ; 4154 } 4155 else { 4156 return ; 4157 } 4158} 4159 4160 4161sub errorsdump 4162{ 4163 my( $nb_errors, @errors_log ) = @ARG ; 4164 my $error_num = 0 ; 4165 my $errors_list = q{} ; 4166 if ( @errors_log ) { 4167 $errors_list = "++++ Listing $nb_errors errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n" ; 4168 foreach my $error ( @errors_log ) { 4169 $error_num++ ; 4170 $errors_list .= "Err $error_num/$nb_errors: $error" ; 4171 } 4172 } 4173 return( $errors_list ) ; 4174} 4175 4176 4177sub tests_live_result 4178{ 4179 note( 'Entering tests_live_result()' ) ; 4180 4181 my $nb_errors = shift ; 4182 if ( $nb_errors ) { 4183 myprint( "Live tests failed with $nb_errors errors\n" ) ; 4184 } else { 4185 myprint( "Live tests ended successfully\n" ) ; 4186 } 4187 note( 'Leaving tests_live_result()' ) ; 4188 return ; 4189} 4190 4191sub foldersizesatend 4192{ 4193 my $mysync = shift ; 4194 timenext( ) ; 4195 return if ( $mysync->{imap1}->IsUnconnected( ) ) ; 4196 return if ( $mysync->{imap2}->IsUnconnected( ) ) ; 4197 # Get all folders on host2 again since new were created 4198 @h2_folders_all = sort $mysync->{imap2}->folders(); 4199 for ( @h2_folders_all ) { 4200 $h2_folders_all{ $_ } = 1 ; 4201 $h2_folders_all_UPPER{ uc $_ } = 1 ; 4202 } ; 4203 ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( 'Host1', $mysync->{imap1}, $search1, $mysync->{abletosearch1}, @h1_folders_wanted ) ; 4204 ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( 'Host2', $mysync->{imap2}, $search2, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; 4205 if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) { 4206 my $error = "Failure getting foldersizes, final differences will not be calculated\n" ; 4207 errors_incr( $mysync, $error ) ; 4208 } 4209 return ; 4210} 4211 4212sub size_filtered_flag 4213{ 4214 my $mysync = shift ; 4215 my $h1_size = shift ; 4216 4217 if ( defined $mysync->{ maxsize } and $h1_size >= $mysync->{ maxsize } ) { 4218 return( 1 ) ; 4219 } 4220 if ( defined $minsize and $h1_size <= $minsize ) { 4221 return( 1 ) ; 4222 } 4223 return( 0 ) ; 4224} 4225 4226sub sync_flags_fir 4227{ 4228 my ( $mysync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ; 4229 4230 if ( not defined $h1_msg ) { return } ; 4231 if ( not defined $h2_msg ) { return } ; 4232 4233 my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} ; 4234 return if size_filtered_flag( $mysync, $h1_size ) ; 4235 4236 # used cached flag values for efficiency 4237 my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ 'FLAGS' } || q{} ; 4238 my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ 'FLAGS' } || q{} ; 4239 4240 sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ; 4241 4242 return ; 4243} 4244 4245sub sync_flags_after_copy 4246{ 4247 # Activated with option --syncflagsaftercopy 4248 my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $permanentflags2 ) = @_ ; 4249 4250 if ( my @h2_flags = $mysync->{imap2}->flags( $h2_msg ) ) { 4251 my $h2_flags = "@h2_flags" ; 4252 ( $mysync->{ debug } or $debugflags ) and myprint( "Host2: msg $h2_fold/$h2_msg flags before sync flags after copy ( $h2_flags )\n" ) ; 4253 sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ; 4254 }else{ 4255 myprint( "Host2: msg $h2_fold/$h2_msg could not get its flags for sync flags after copy\n" ) ; 4256 } 4257 return ; 4258} 4259 4260# Globals 4261# $debug 4262# $debugflags 4263# $permanentflags2 4264 4265 4266sub sync_flags 4267{ 4268 my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) = @_ ; 4269 4270 ( $mysync->{ debug } or $debugflags ) and 4271 myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ; 4272 4273 $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ; 4274 4275 $h2_flags = flagscase( $h2_flags ) ; 4276 4277 ( $mysync->{ debug } or $debugflags ) and 4278 myprint( "Host1: flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ; 4279 4280 4281 # compare flags - set flags if there a difference 4282 my @h1_flags = sort split(q{ }, $h1_flags ); 4283 my @h2_flags = sort split(q{ }, $h2_flags ); 4284 my $diff = compare_lists( \@h1_flags, \@h2_flags ); 4285 4286 $diff and ( $mysync->{ debug } or $debugflags ) 4287 and myprint( "Host2: flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ; 4288 4289 # This sets flags exactly. So flags can be removed with this. 4290 # When you remove a \Seen flag on host1 you want it 4291 # to be removed on host2. Just add flags is not what 4292 # we need most of the time, so no + like in "+FLAGS.SILENT". 4293 4294 if ( not $mysync->{dry} and $diff and not $mysync->{imap2}->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) { 4295 my $error_msg = join q{}, "Host2: flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ", 4296 $mysync->{imap2}->LastError || q{}, "\n" ; 4297 errors_incr( $mysync, $error_msg ) ; 4298 } 4299 4300 return ; 4301} 4302 4303 4304 4305sub _filter 4306{ 4307 my $mysync = shift ; 4308 my $str = shift or return q{} ; 4309 my $sz = $SIZE_MAX_STR ; 4310 my $len = length $str ; 4311 if ( not $mysync->{ debug } and $len > $sz*2 ) { 4312 my $beg = substr $str, 0, $sz ; 4313 my $end = substr $str, -$sz, $sz ; 4314 $str = $beg . '...' . $end ; 4315 } 4316 $str =~ s/\012?\015$//x ; 4317 return "(len=$len) " . $str ; 4318} 4319 4320 4321 4322sub lost_connection 4323{ 4324 my( $mysync, $imap, $error_message ) = @_; 4325 if ( $imap->IsUnconnected( ) ) { 4326 $mysync->{nb_errors}++ ; 4327 my $lcomm = $imap->LastIMAPCommand || q{} ; 4328 my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ; 4329 4330 # if string is long try reduce to a more reasonable size 4331 $lcomm = _filter( $mysync, $lcomm ) ; 4332 $einfo = _filter( $mysync, $einfo ) ; 4333 myprint( "Failure: last command: $lcomm\n") if ( $mysync->{ debug } && $lcomm) ; 4334 myprint( "Failure: lost connection $error_message: ", $einfo, "\n") ; 4335 return( 1 ) ; 4336 } 4337 else{ 4338 return( 0 ) ; 4339 } 4340} 4341 4342sub tests_max 4343{ 4344 note( 'Entering tests_max()' ) ; 4345 4346 is( 0, max( 0 ), 'max 0 => 0' ) ; 4347 is( 1, max( 1 ), 'max 1 => 1' ) ; 4348 is( $MINUS_ONE, max( $MINUS_ONE ), 'max -1 => -1') ; 4349 is( undef, max( ), 'max no arg => undef' ) ; 4350 is( $NUMBER_100, max( 1, $NUMBER_100 ), 'max 1 100 => 100' ) ; 4351 is( $NUMBER_100, max( $NUMBER_100, 1 ), 'max 100 1 => 100' ) ; 4352 is( $NUMBER_100, max( $NUMBER_100, $NUMBER_42, 1 ), 'max 100 42 1 => 100' ) ; 4353 is( $NUMBER_100, max( $NUMBER_100, '42', 1 ), 'max 100 42 1 => 100' ) ; 4354 is( $NUMBER_100, max( '100', '42', 1 ), 'max 100 42 1 => 100' ) ; 4355 is( $NUMBER_100, max( $NUMBER_100, 'haha', 1 ), 'max 100 haha 1 => 100') ; 4356 is( $NUMBER_100, max( 'bb', $NUMBER_100, 'haha' ), 'max bb 100 haha => 100') ; 4357 is( $MINUS_ONE, max( q{}, $MINUS_ONE, 'haha' ), 'max "" -1 haha => -1') ; 4358 is( $MINUS_ONE, max( q{}, $MINUS_ONE, $MINUS_TWO ), 'max "" -1 -2 => -1') ; 4359 is( $MINUS_ONE, max( 'haha', $MINUS_ONE, $MINUS_TWO ), 'max haha -1 -2 => -1') ; 4360 is( 1, max( $MINUS_ONE, 1 ), 'max -1 1 => 1') ; 4361 is( 1, max( undef, 1 ), 'max undef 1 => 1' ) ; 4362 is( 0, max( undef, 0 ), 'max undef 0 => 0' ) ; 4363 is( 'haha', max( 'haha' ), 'max haha => haha') ; 4364 is( 'bb', max( 'aa', 'bb' ), 'max aa bb => bb') ; 4365 is( 'bb', max( 'bb', 'aa' ), 'max bb aa => bb') ; 4366 is( 'bb', max( 'bb', 'aa', 'bb' ), 'max bb aa bb => bb') ; 4367 note( 'Leaving tests_max()' ) ; 4368 return ; 4369} 4370 4371sub max 4372{ 4373 my @list = @_ ; 4374 return( undef ) if ( 0 == scalar @list ) ; 4375 4376 my( @numbers, @notnumbers ) ; 4377 foreach my $item ( @list ) { 4378 if ( is_number( $item ) ) { 4379 push @numbers, $item ; 4380 }else{ 4381 push @notnumbers, $item ; 4382 } 4383 } 4384 4385 my @sorted ; 4386 if ( @numbers ) { 4387 @sorted = sort { $a <=> $b } @numbers ; 4388 }elsif( @notnumbers ) { 4389 @sorted = sort { $a cmp $b } @notnumbers ; 4390 }else{ 4391 return ; 4392 } 4393 4394 return( pop @sorted ) ; 4395} 4396 4397sub tests_is_number 4398{ 4399 note( 'Entering tests_is_number()' ) ; 4400 4401 ok( ! is_number( ), 'is_number: no args => undef ' ) ; 4402 ok( is_number( 1 ), 'is_number: 1 => 1' ) ; 4403 ok( is_number( 1.1 ), 'is_number: 1.1 => 1' ) ; 4404 ok( is_number( 0 ), 'is_number: 0 => 1' ) ; 4405 ok( is_number( -1 ), 'is_number: -1 => 1' ) ; 4406 ok( ! is_number( 1.1.1 ), 'is_number: 1.1.1 => no' ) ; 4407 ok( ! is_number( q{} ), 'is_number: q{} => no' ) ; 4408 ok( ! is_number( 'haha' ), 'is_number: haha => no' ) ; 4409 ok( ! is_number( '0haha' ), 'is_number: 0haha => no' ) ; 4410 ok( ! is_number( '2haha' ), 'is_number: 2haha => no' ) ; 4411 ok( ! is_number( 'haha2' ), 'is_number: haha2 => no' ) ; 4412 4413 note( 'Leaving tests_is_number()' ) ; 4414 return ; 4415} 4416 4417 4418 4419sub is_number 4420{ 4421 my $item = shift ; 4422 4423 if ( ! defined $item ) { return ; } 4424 4425 if ( $item =~ /\A$RE{num}{real}\Z/ ) { 4426 return 1 ; 4427 } 4428 return ; 4429} 4430 4431sub tests_min 4432{ 4433 note( 'Entering tests_min()' ) ; 4434 4435 is( 0, min( 0 ), 'min 0 => 0' ) ; 4436 is( 1, min( 1 ), 'min 1 => 1' ) ; 4437 is( $MINUS_ONE, min( $MINUS_ONE ), 'min -1 => -1' ) ; 4438 is( undef, min( ), 'min no arg => undef' ) ; 4439 is( 1, min( 1, $NUMBER_100 ), 'min 1 100 => 1' ) ; 4440 is( 1, min( $NUMBER_100, 1 ), 'min 100 1 => 1' ) ; 4441 is( 1, min( $NUMBER_100, $NUMBER_42, 1 ), 'min 100 42 1 => 1' ) ; 4442 is( 1, min( $NUMBER_100, '42', 1 ), 'min 100 42 1 => 1' ) ; 4443 is( 1, min( '100', '42', 1 ), 'min 100 42 1 => 1' ) ; 4444 is( 1, min( $NUMBER_100, 'haha', 1 ), 'min 100 haha 1 => 1') ; 4445 is( $MINUS_ONE, min( $MINUS_ONE, 1 ), 'min -1 1 => -1') ; 4446 4447 is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ; 4448 is( 0, min( undef, 0 ), 'min undef 0 => 0' ) ; 4449 is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ; 4450 is( 0, min( undef, 2, 0, 1 ), 'min undef, 2, 0, 1 => 0' ) ; 4451 4452 is( 'haha', min( 'haha' ), 'min haha => haha') ; 4453 is( 'aa', min( 'aa', 'bb' ), 'min aa bb => aa') ; 4454 is( 'aa', min( 'bb', 'aa' ), 'min bb aa bb => aa') ; 4455 is( 'aa', min( 'bb', 'aa', 'bb' ), 'min bb aa bb => aa') ; 4456 4457 note( 'Leaving tests_min()' ) ; 4458 return ; 4459} 4460 4461 4462sub min 4463{ 4464 my @list = @_ ; 4465 return( undef ) if ( 0 == scalar @list ) ; 4466 4467 my( @numbers, @notnumbers ) ; 4468 foreach my $item ( @list ) { 4469 if ( is_number( $item ) ) { 4470 push @numbers, $item ; 4471 }else{ 4472 push @notnumbers, $item ; 4473 } 4474 } 4475 4476 my @sorted ; 4477 if ( @numbers ) { 4478 @sorted = sort { $a <=> $b } @numbers ; 4479 }elsif( @notnumbers ) { 4480 @sorted = sort { $a cmp $b } @notnumbers ; 4481 }else{ 4482 return ; 4483 } 4484 4485 return( shift @sorted ) ; 4486} 4487 4488 4489sub check_lib_version 4490{ 4491 my $mysync = shift ; 4492 $mysync->{ debug } and myprint( "IMAPClient $Mail::IMAPClient::VERSION\n" ) ; 4493 if ( '2.2.9' eq $Mail::IMAPClient::VERSION ) { 4494 myprint( "imapsync no longer supports Mail::IMAPClient 2.2.9, upgrade it\n" ) ; 4495 return 0 ; 4496 } 4497 else{ 4498 # 3.x.x is no longer buggy with imapsync. 4499 # 3.30 or currently superior is imposed in the Perl "use Mail::IMAPClient line". 4500 return 1 ; 4501 } 4502 return ; 4503} 4504 4505sub module_version_str 4506{ 4507 my( $module_name, $module_version ) = @_ ; 4508 my $str = mysprintf( "%-20s %s\n", $module_name, $module_version ) ; 4509 return( $str ) ; 4510} 4511 4512sub modulesversion 4513{ 4514 4515 my @list_version; 4516 4517 my %modulesversion = ( 4518 'Authen::NTLM' => sub { $Authen::NTLM::VERSION }, 4519 'CGI' => sub { $CGI::VERSION }, 4520 'Compress::Zlib' => sub { $Compress::Zlib::VERSION }, 4521 'Crypt::OpenSSL::RSA' => sub { $Crypt::OpenSSL::RSA::VERSION }, 4522 'Data::Uniqid' => sub { $Data::Uniqid::VERSION }, 4523 'Digest::HMAC_MD5' => sub { $Digest::HMAC_MD5::VERSION }, 4524 'Digest::HMAC_SHA1' => sub { $Digest::HMAC_SHA1::VERSION }, 4525 'Digest::MD5' => sub { $Digest::MD5::VERSION }, 4526 'File::Copy::Recursive' => sub { $File::Copy::Recursive::VERSION }, 4527 'File::Spec' => sub { $File::Spec::VERSION }, 4528 'Getopt::Long' => sub { $Getopt::Long::VERSION }, 4529 'HTML::Entities' => sub { $HTML::Entities::VERSION }, 4530 'IO::Socket' => sub { $IO::Socket::VERSION }, 4531 'IO::Socket::INET' => sub { $IO::Socket::INET::VERSION }, 4532 'IO::Socket::INET6' => sub { $IO::Socket::INET6::VERSION }, 4533 'IO::Socket::IP' => sub { $IO::Socket::IP::VERSION }, 4534 'IO::Socket::SSL' => sub { $IO::Socket::SSL::VERSION }, 4535 'IO::Tee' => sub { $IO::Tee::VERSION }, 4536 'JSON' => sub { $JSON::VERSION }, 4537 'JSON::WebToken' => sub { $JSON::WebToken::VERSION }, 4538 'LWP' => sub { $LWP::VERSION }, 4539 'Mail::IMAPClient' => sub { $Mail::IMAPClient::VERSION }, 4540 'Net::Ping' => sub { $Net::Ping::VERSION }, 4541 'Net::SSLeay' => sub { $Net::SSLeay::VERSION }, 4542 'Term::ReadKey' => sub { $Term::ReadKey::VERSION }, 4543 'Test::MockObject' => sub { $Test::MockObject::VERSION }, 4544 'Time::HiRes' => sub { $Time::HiRes::VERSION }, 4545 'Unicode::String' => sub { $Unicode::String::VERSION }, 4546 'URI::Escape' => sub { $URI::Escape::VERSION }, 4547 #'Lalala' => sub { $Lalala::VERSION }, 4548 ) ; 4549 4550 foreach my $module_name ( sort keys %modulesversion ) { 4551 # trick from http://www.perlmonks.org/?node_id=152122 4552 my $file_name = $module_name . '.pm' ; 4553 $file_name =~s,::,/,xmgs; # Foo::Bar::Baz => Foo/Bar/Baz.pm 4554 my $v ; 4555 eval { 4556 require $file_name ; 4557 $v = defined $modulesversion{ $module_name } ? $modulesversion{ $module_name }->() : q{?} ; 4558 } or $v = q{Not installed} ; 4559 4560 push @list_version, module_version_str( $module_name, $v ) ; 4561 } 4562 return( @list_version ) ; 4563} 4564 4565 4566sub tests_command_line_nopassword 4567{ 4568 note( 'Entering tests_command_line_nopassword()' ) ; 4569 4570 ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' ); 4571 my $mysync = {} ; 4572 ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla' ), 'command_line_nopassword --blabla' ); 4573 #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ; 4574 ok( '--password1 MASKED' eq command_line_nopassword( $mysync, qw{ --password1 secret1}), 'command_line_nopassword --password1' ); 4575 ok( '--blabla --password1 MASKED --blibli' 4576 eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' ); 4577 $mysync->{showpasswords} = 1 ; 4578 ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' ); 4579 ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla'), 'command_line_nopassword --blabla' ); 4580 #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ; 4581 ok( '--password1 secret1' eq command_line_nopassword( $mysync, qw{ --password1 secret1} ), 'command_line_nopassword --password1' ); 4582 ok( '--blabla --password1 secret1 --blibli' 4583 eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' ); 4584 4585 note( 'Leaving tests_command_line_nopassword()' ) ; 4586 return ; 4587} 4588 4589# Construct a command line copy with passwords replaced by MASKED. 4590sub command_line_nopassword 4591{ 4592 my $mysync = shift @ARG ; 4593 my @argv = @ARG ; 4594 my @argv_nopassword ; 4595 4596 if ( $mysync->{ cmdcgi } ) { 4597 @argv_nopassword = mask_password_value( @{ $mysync->{ cmdcgi } } ) ; 4598 return( "@argv_nopassword" ) ; 4599 } 4600 4601 if ( $mysync->{showpasswords} ) 4602 { 4603 return( "@argv" ) ; 4604 } 4605 4606 @argv_nopassword = mask_password_value( @argv ) ; 4607 return("@argv_nopassword") ; 4608} 4609 4610sub mask_password_value 4611{ 4612 my @argv = @ARG ; 4613 my @argv_nopassword ; 4614 while ( @argv ) { 4615 my $arg = shift @argv ; # option name or value 4616 if ( $arg =~ m/-password[12]/x ) { 4617 shift @argv ; # password value 4618 push @argv_nopassword, $arg, 'MASKED' ; # option name and fake value 4619 }else{ 4620 push @argv_nopassword, $arg ; # same option or value 4621 } 4622 } 4623 return @argv_nopassword ; 4624} 4625 4626 4627sub tests_get_stdin_masked 4628{ 4629 note( 'Entering tests_get_stdin_masked()' ) ; 4630 4631 is( q{}, get_stdin_masked( ), 'get_stdin_masked: no args' ) ; 4632 is( q{}, get_stdin_masked( 'Please ENTER: ' ), 'get_stdin_masked: ENTER' ) ; 4633 4634 note( 'Leaving tests_get_stdin_masked()' ) ; 4635 return ; 4636} 4637 4638####################################################### 4639# The issue is that prompt() does not prompt the prompt 4640# when the program is used like 4641# { sleep 2 ; echo blablabla ; } | ./imapsync ...--host1 lo --user1 tata --host2 lo --user2 titi 4642 4643# use IO::Prompter ; 4644sub get_stdin_masked 4645{ 4646 my $prompt = shift || 'Say something: ' ; 4647 local @ARGV = () ; 4648 my $input = prompt( 4649 -prompt => $prompt, 4650 -echo => '*', 4651 ) ; 4652 #myprint( "You said: $input\n" ) ; 4653 return $input ; 4654} 4655 4656sub ask_for_password_new 4657{ 4658 my $prompt = shift ; 4659 my $password = get_stdin_masked( $prompt ) ; 4660 return $password ; 4661} 4662######################################################### 4663 4664 4665sub ask_for_password 4666{ 4667 my $prompt = shift ; 4668 myprint( $prompt ) ; 4669 Term::ReadKey::ReadMode( 2 ) ; 4670 ## no critic (InputOutput::ProhibitExplicitStdin) 4671 my $password = <STDIN> ; 4672 chomp $password ; 4673 myprint( "\nGot it\n" ) ; 4674 Term::ReadKey::ReadMode( 0 ) ; 4675 return $password ; 4676} 4677 4678# Have to refactor get_password1() get_password2() 4679# to have only get_password() and two calls 4680sub get_password1 4681{ 4682 4683 my $mysync = shift ; 4684 4685 $mysync->{password1} 4686 || $mysync->{ passfile1 } 4687 || 'PREAUTH' eq $authmech1 4688 || 'EXTERNAL' eq $authmech1 4689 || $ENV{IMAPSYNC_PASSWORD1} 4690 || do 4691 { 4692 myprint( << 'FIN_PASSFILE' ) ; 4693 4694If you are afraid of giving password on the command line arguments, you can put the 4695password of user1 in a file named file1 and use "--passfile1 file1" instead of typing it. 4696Then give this file restrictive permissions with the command "chmod 600 file1". 4697An other solution is to set the environment variable IMAPSYNC_PASSWORD1 4698FIN_PASSFILE 4699 my $user = $authuser1 || $mysync->{user1} ; 4700 my $host = $mysync->{host1} ; 4701 my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ; 4702 $mysync->{password1} = ask_for_password( $prompt ) ; 4703 } ; 4704 4705 if ( defined $mysync->{ passfile1 } ) { 4706 if ( ! -e -r $mysync->{ passfile1 } ) { 4707 myprint( "Failure: file from parameter --passfile1 $mysync->{ passfile1 } does not exist or is not readable\n" ) ; 4708 exit_clean( $mysync, $EX_NOINPUT ) ; 4709 } 4710 # passfile1 readable 4711 $mysync->{password1} = firstline ( $mysync->{ passfile1 } ) ; 4712 return ; 4713 } 4714 if ( $ENV{IMAPSYNC_PASSWORD1} ) { 4715 $mysync->{password1} = $ENV{IMAPSYNC_PASSWORD1} ; 4716 return ; 4717 } 4718 return ; 4719} 4720 4721sub get_password2 4722{ 4723 4724 my $mysync = shift ; 4725 4726 $mysync->{password2} 4727 || $mysync->{ passfile2 } 4728 || 'PREAUTH' eq $authmech2 4729 || 'EXTERNAL' eq $authmech2 4730 || $ENV{IMAPSYNC_PASSWORD2} 4731 || do 4732 { 4733 myprint( << 'FIN_PASSFILE' ) ; 4734 4735If you are afraid of giving password on the command line arguments, you can put the 4736password of user2 in a file named file2 and use "--passfile2 file2" instead of typing it. 4737Then give this file restrictive permissions with the command "chmod 600 file2". 4738An other solution is to set the environment variable IMAPSYNC_PASSWORD2 4739FIN_PASSFILE 4740 my $user = $authuser2 || $mysync->{user2} ; 4741 my $host = $mysync->{host2} ; 4742 my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ; 4743 $mysync->{password2} = ask_for_password( $prompt ) ; 4744 } ; 4745 4746 4747 if ( defined $mysync->{ passfile2 } ) { 4748 if ( ! -e -r $mysync->{ passfile2 } ) { 4749 myprint( "Failure: file from parameter --passfile2 $mysync->{ passfile2 } does not exist or is not readable\n" ) ; 4750 exit_clean( $mysync, $EX_NOINPUT ) ; 4751 } 4752 # passfile2 readable 4753 $mysync->{password2} = firstline ( $mysync->{ passfile2 } ) ; 4754 return ; 4755 } 4756 if ( $ENV{IMAPSYNC_PASSWORD2} ) { 4757 $mysync->{password2} = $ENV{IMAPSYNC_PASSWORD2} ; 4758 return ; 4759 } 4760 return ; 4761} 4762 4763 4764 4765 4766sub remove_tmp_files 4767{ 4768 my $mysync = shift or return ; 4769 $mysync->{pidfile} or return ; 4770 if ( -e $mysync->{pidfile} ) { 4771 unlink $mysync->{pidfile} ; 4772 } 4773 return ; 4774} 4775 4776sub cleanup_before_exit 4777{ 4778 my $mysync = shift ; 4779 remove_tmp_files( $mysync ) ; 4780 if ( $mysync->{imap1} and $mysync->{imap1}->IsConnected() ) 4781 { 4782 myprint( "Disconnecting from host1 $mysync->{ host1 } user1 $mysync->{ user1 }\n" ) ; 4783 $mysync->{imap1}->logout( ) ; 4784 } 4785 if ( $mysync->{imap2} and $mysync->{imap2}->IsConnected() ) 4786 { 4787 myprint( "Disconnecting from host2 $mysync->{ host2 } user2 $mysync->{ user2 }\n" ) ; 4788 $mysync->{imap2}->logout( ) ; 4789 } 4790 if ( $mysync->{log} ) { 4791 myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ; 4792 } 4793 if ( $mysync->{log} and $mysync->{logfile_handle} ) { 4794 #myprint( "Closing $mysync->{ logfile }\n" ) ; 4795 close $mysync->{logfile_handle} ; 4796 } 4797 return ; 4798} 4799 4800 4801 4802sub exit_clean 4803{ 4804 my $mysync = shift @ARG ; 4805 my $status = shift @ARG ; 4806 my @messages = @ARG ; 4807 if ( @messages ) 4808 { 4809 myprint( @messages ) ; 4810 } 4811 myprint( "Exiting with return value $status ($EXIT_TXT{$status})\n" ) ; 4812 cleanup_before_exit( $mysync ) ; 4813 4814 exit $status ; 4815} 4816 4817sub missing_option 4818{ 4819 my $mysync = shift ; 4820 my $option = shift ; 4821 exit_clean( $mysync, $EX_USAGE, "$option option is mandatory, for help run $PROGRAM_NAME --help\n" ) ; 4822 return ; 4823} 4824 4825 4826sub catch_ignore 4827{ 4828 my $mysync = shift ; 4829 my $signame = shift ; 4830 4831 my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; 4832 myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), 4833 "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; 4834 stats( $mysync ) ; 4835 return ; 4836} 4837 4838 4839sub catch_exit 4840{ 4841 my $mysync = shift ; 4842 my $signame = shift || q{} ; 4843 if ( $signame ) { 4844 myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), 4845 "). Asked to terminate\n" ) ; 4846 if ( $mysync->{stats} ) { 4847 myprint( "Here are the final stats of this sync not completely finished so far\n" ) ; 4848 stats( $mysync ) ; 4849 myprint( "Ended by a signal $signame (my PID is $PROCESS_ID my PPID is ", 4850 getppid( ), "). I am asked to terminate immediately.\n" ) ; 4851 myprint( "You should resynchronize those accounts by running a sync again,\n", 4852 "since some messages and entire folders might still be missing on host2.\n" ) ; 4853 } 4854 ## no critic (RequireLocalizedPunctuationVars) 4855 $SIG{ $signame } = 'DEFAULT'; # restore default action 4856 # kill myself with $signame 4857 # https://www.cons.org/cracauer/sigint.html 4858 myprint( "Killing myself with signal $signame\n" ) ; 4859 cleanup_before_exit( $mysync ) ; 4860 kill( $signame, $PROCESS_ID ) ; 4861 } 4862 else 4863 { 4864 exit_clean( $mysync, $EXIT_BY_SIGNAL ) ; 4865 } 4866 return ; 4867} 4868 4869 4870sub catch_print 4871{ 4872 my $mysync = shift ; 4873 my $signame = shift ; 4874 4875 my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; 4876 myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), 4877 "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; 4878 return ; 4879} 4880 4881 4882sub catch_reconnect 4883{ 4884 my $mysync = shift ; 4885 my $signame = shift ; 4886 if ( here_twice( $mysync ) ) { 4887 myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ; 4888 catch_exit( $mysync, $signame ) ; 4889 }else{ 4890 myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), ")\n", 4891 "Hit 2 ctr-c within 2 seconds to exit the program\n", 4892 "Hit only 1 ctr-c to reconnect to both imap servers\n", 4893 ) ; 4894 myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ; 4895 4896 if ( ! defined $mysync->{imap1} ) { return ; } 4897 if ( ! defined $mysync->{imap2} ) { return ; } 4898 4899 myprint( "Info: reconnecting to host1 imap server $mysync->{host1}\n" ) ; 4900 $mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ; 4901 $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT} += 1 ; 4902 if ( $mysync->{imap1}->reconnect( ) ) 4903 { 4904 myprint( "Info: reconnected to host1 imap server $mysync->{host1}\n" ) ; 4905 } 4906 else 4907 { 4908 exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ; 4909 } 4910 myprint( "Info: reconnecting to host2 imap server\n" ) ; 4911 $mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ; 4912 $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT} += 1 ; 4913 if ( $mysync->{imap2}->reconnect( ) ) 4914 { 4915 myprint( "Info: reconnected to host2 imap server $mysync->{host2}\n" ) ; 4916 } 4917 else 4918 { 4919 exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ; 4920 } 4921 myprint( "Info: reconnected to both imap servers\n" ) ; 4922 } 4923 return ; 4924} 4925 4926sub tests_reconnect_12_if_needed 4927{ 4928 note( 'Entering tests_reconnect_12_if_needed()' ) ; 4929 4930 my $mysync ; 4931 4932 $mysync->{imap1} = Mail::IMAPClient->new( ) ; 4933 $mysync->{imap2} = Mail::IMAPClient->new( ) ; 4934 $mysync->{imap1}->Server( 'test1.lamiral.info' ) ; 4935 $mysync->{imap2}->Server( 'test2.lamiral.info' ) ; 4936 is( 2, reconnect_12_if_needed( $mysync ), 'reconnect_12_if_needed: test1&test2 .lamiral.info => 1' ) ; 4937 is( 1, $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test1.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; 4938 is( 1, $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test2.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; 4939 4940 note( 'Leaving tests_reconnect_12_if_needed()' ) ; 4941 return ; 4942} 4943 4944sub reconnect_12_if_needed 4945{ 4946 my $mysync = shift ; 4947 #return 2 ; 4948 if ( ! reconnect_if_needed( $mysync->{imap1} ) ) { 4949 return ; 4950 } 4951 if ( ! reconnect_if_needed( $mysync->{imap2} ) ) { 4952 return ; 4953 } 4954 # both were good 4955 return 2 ; 4956} 4957 4958 4959sub tests_reconnect_if_needed 4960{ 4961 note( 'Entering tests_reconnect_if_needed()' ) ; 4962 4963 4964 my $myimap ; 4965 4966 is( undef, reconnect_if_needed( ), 'reconnect_if_needed: no args => undef' ) ; 4967 is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: undef arg => undef' ) ; 4968 4969 $myimap = Mail::IMAPClient->new( ) ; 4970 $myimap->Debug( 1 ) ; 4971 is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: empty new Mail::IMAPClient => undef' ) ; 4972 $myimap->Server( 'test.lamiral.info' ) ; 4973 is( 1, reconnect_if_needed( $myimap ), 'reconnect_if_needed: test.lamiral.info => 1' ) ; 4974 is( 1, $myimap->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_if_needed: test.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; 4975 4976 note( 'Leaving tests_reconnect_if_needed()' ) ; 4977 return ; 4978} 4979 4980sub reconnect_if_needed 4981{ 4982 # return undef upon failure. 4983 # return 1 upon connection success, with or without reconnection. 4984 4985 my $imap = shift ; 4986 4987 if ( ! defined $imap ) { return ; } 4988 if ( ! $imap->Server( ) ) { return ; } 4989 4990 if ( $imap->IsUnconnected( ) ) { 4991 $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ; 4992 if ( $imap->reconnect( ) ) { 4993 return 1 ; 4994 } 4995 }else{ 4996 return 1 ; 4997 } 4998 4999 # A last forced one 5000 $imap->State( Mail::IMAPClient::Unconnected ) ; 5001 $imap->reconnect( ) ; 5002 $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ; 5003 if ( $imap->noop ) { 5004 # NOOP is ok 5005 return 1 ; 5006 } 5007 5008 return ; 5009} 5010 5011 5012 5013sub here_twice 5014{ 5015 my $mysync = shift ; 5016 my $now = time ; 5017 my $previous = $mysync->{lastcatch} || 0 ; 5018 $mysync->{lastcatch} = $now ; 5019 5020 if ( $INTERVAL_TO_EXIT >= $now - $previous ) { 5021 return $TRUE ; 5022 }else{ 5023 return $FALSE ; 5024 } 5025} 5026 5027 5028sub justconnect 5029{ 5030 my $mysync = shift ; 5031 my $justconnect1 = justconnect1( $sync ) ; 5032 my $justconnect2 = justconnect2( $sync ) ; 5033 return "$justconnect1 $justconnect2"; 5034} 5035 5036sub justconnect1 5037{ 5038 my $mysync = shift ; 5039 if ( $mysync->{host1} ) 5040 { 5041 myprint( "Host1: Will just connect to $mysync->{host1} without login\n" ) ; 5042 $mysync->{imap1} = connect_imap( 5043 $mysync->{host1}, $mysync->{port1}, $debugimap1, 5044 $mysync->{ssl1}, $mysync->{tls1}, 'Host1', 5045 $mysync->{h1}->{timeout}, $mysync->{h1} ) ; 5046 5047 $mysync->{imap1}->logout( ) ; 5048 return $mysync->{host1} ; 5049 } 5050 5051 return '' ; 5052} 5053 5054sub justconnect2 5055{ 5056 my $mysync = shift ; 5057 if ( $mysync->{host2} ) 5058 { 5059 myprint( "Host2: Will just connect to $mysync->{host2} without login\n" ) ; 5060 $mysync->{imap2} = connect_imap( 5061 $mysync->{host2}, $mysync->{port2}, $debugimap2, 5062 $mysync->{ssl2}, $mysync->{tls2}, 'Host2', 5063 $mysync->{h2}->{timeout}, $mysync->{h2} ) ; 5064 5065 $mysync->{imap2}->logout( ) ; 5066 return $mysync->{host2} ; 5067 } 5068 5069 return '' ; 5070} 5071 5072sub skip_macosx 5073{ 5074 return ; 5075 # return( 'macosx.polarhome.com' eq hostname() ) ; 5076} 5077 5078sub tests_mailimapclient_connect 5079{ 5080 note( 'Entering tests_mailimapclient_connect()' ) ; 5081 5082 my $imap ; 5083 # ipv4 5084 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4: new' ) ; 5085 is( 'Mail::IMAPClient', ref( $imap ), 'mailimapclient_connect ipv4: ref is Mail::IMAPClient' ) ; 5086 5087 # Mail::IMAPClient 3.40 die on this... So we skip it, thanks to "mature" IO::Socket::IP 5088 # Mail::IMAPClient 3.42 is ok so this test is back. 5089 is( undef, $imap->connect( ), 'mailimapclient_connect ipv4: connect with no server => failure' ) ; 5090 5091 5092 is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4: setting Server(test.lamiral.info)' ) ; 5093 is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4: setting Debug( 1 )' ) ; 5094 is( 143, $imap->Port( 143 ), 'mailimapclient_connect ipv4: setting Port( 143 )' ) ; 5095 is( 3, $imap->Timeout( 3 ), 'mailimapclient_connect ipv4: setting Timout( 30 )' ) ; 5096 like( ref( $imap->connect( ) ), qr/IO::Socket::INET|IO::Socket::IP/, 'mailimapclient_connect ipv4: connect to test.lamiral.info' ) ; 5097 like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4: logout' ) ; 5098 is( undef, undef $imap, 'mailimapclient_connect ipv4: free variable' ) ; 5099 5100 # ipv4 + ssl 5101 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4 + ssl: new' ) ; 5102 is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4 + ssl: setting Server(test.lamiral.info)' ) ; 5103 is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ; 5104 ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE ] ), 'mailimapclient_connect ipv4 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; 5105 is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv4 + ssl: setting Port( 993 )' ) ; 5106 like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv4 + ssl: connect to test.lamiral.info' ) ; 5107 is( $imap->logout( ), undef, 'mailimapclient_connect ipv4 + ssl: logout in ssl causes failure' ) ; 5108 is( undef, undef $imap, 'mailimapclient_connect ipv4 + ssl: free variable' ) ; 5109 5110 # ipv6 + ssl 5111 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv6 + ssl: new' ) ; 5112 is( 'ks2ipv6.lamiral.info', $imap->Server( 'ks2ipv6.lamiral.info' ), 'mailimapclient_connect ipv6 + ssl: setting Server(ks2ipv6.lamiral.info)' ) ; 5113 ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE ] ), 'mailimapclient_connect ipv6 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; 5114 is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv6 + ssl: setting Port( 993 )' ) ; 5115 SKIP: { 5116 if ( 5117 'CUILLERE' eq hostname() 5118 or 5119 skip_macosx() 5120 or 5121 -e '/.dockerenv' 5122 ) 5123 { 5124 skip( 'Tests avoided on CUILLERE can not do ipv6', 2 ) ; 5125 } 5126 like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv6 + ssl: connect to ks2ipv6.lamiral.info' ) ; 5127 is( $imap->logout( ), undef, 'mailimapclient_connect ipv6 + ssl: logout in ssl causes failure' ) ; 5128 } 5129 is( undef, undef $imap, 'mailimapclient_connect ipv6 + ssl: free variable' ) ; 5130 5131 5132 note( 'Leaving tests_mailimapclient_connect()' ) ; 5133 return ; 5134} 5135 5136 5137sub tests_mailimapclient_connect_bug 5138{ 5139 note( 'Entering tests_mailimapclient_connect_bug()' ) ; 5140 5141 my $imap ; 5142 5143 # ipv6 5144 ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect_bug ipv6: new' ) ; 5145 is( 'ks2ipv6.lamiral.info', $imap->Server( 'ks2ipv6.lamiral.info' ), 'mailimapclient_connect_bug ipv6: setting Server(ks2ipv6.lamiral.info)' ) ; 5146 is( 143, $imap->Port( 143 ), 'mailimapclient_connect_bug ipv6: setting Port( 993 )' ) ; 5147 5148 SKIP: { 5149 if ( 5150 'CUILLERE' eq hostname() 5151 or 5152 skip_macosx() 5153 or 5154 -e '/.dockerenv' 5155 ) 5156 { 5157 skip( 'Tests avoided on CUILLERE can not do ipv6', 1 ) ; 5158 } 5159 like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'mailimapclient_connect_bug ipv6: connect to ks2ipv6.lamiral.info' ) 5160 or diag( 'mailimapclient_connect_bug ipv6: ', $imap->LastError( ), $!, ) ; 5161 } 5162 #is( $imap->logout( ), undef, 'mailimapclient_connect_bug ipv6: logout in ssl causes failure' ) ; 5163 is( undef, undef $imap, 'mailimapclient_connect_bug ipv6: free variable' ) ; 5164 5165 note( 'Leaving tests_mailimapclient_connect_bug()' ) ; 5166 return ; 5167} 5168 5169 5170 5171sub tests_connect_socket 5172{ 5173 note( 'Entering tests_connect_socket()' ) ; 5174 5175 is( undef, connect_socket( ), 'connect_socket: no args' ) ; 5176 5177 my $socket ; 5178 my $imap ; 5179 SKIP: { 5180 if ( 5181 'CUILLERE' eq hostname() 5182 or 5183 skip_macosx() 5184 or 5185 -e '/.dockerenv' 5186 ) 5187 { 5188 skip( 'Tests avoided on CUILLERE/macosx.polarhome.com/docker cannot do ipv6', 2 ) ; 5189 } 5190 5191 $socket = IO::Socket::INET6->new( 5192 PeerAddr => 'ks2ipv6.lamiral.info', 5193 PeerPort => 143, 5194 ) ; 5195 5196 5197 ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 143 IO::Socket::INET6' ) ; 5198 #$imap->Debug( 1 ) ; 5199 # myprint( $imap->capability( ) ) ; 5200 if ( $imap ) { 5201 $imap->logout( ) ; 5202 } 5203 5204 #$IO::Socket::SSL::DEBUG = 4 ; 5205 $socket = IO::Socket::SSL->new( 5206 PeerHost => 'ks2ipv6.lamiral.info', 5207 PeerPort => 993, 5208 SSL_verify_mode => SSL_VERIFY_NONE, 5209 ) ; 5210 # myprint( $socket ) ; 5211 ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 993 IO::Socket::SSL' ) ; 5212 #$imap->Debug( 1 ) ; 5213 # myprint( $imap->capability( ) ) ; 5214 # $socket->close( ) ; 5215 if ( $imap ) { 5216 $socket->close( ) ; 5217 } 5218 #$socket->close(SSL_no_shutdown => 1) ; 5219 #$imap->logout( ) ; 5220 #myprint( "\n" ) ; 5221 #$imap->logout( ) ; 5222 } 5223 note( 'Leaving tests_connect_socket()' ) ; 5224 return ; 5225} 5226 5227sub connect_socket 5228{ 5229 my( $socket ) = @ARG ; 5230 5231 if ( ! defined $socket ) { return ; } 5232 5233 my $host = $socket->peerhost( ) ; 5234 my $port = $socket->peerport( ) ; 5235 #print "socket->peerhost: ", $socket->peerhost( ), "\n" ; 5236 #print "socket->peerport: ", $socket->peerport( ), "\n" ; 5237 my $imap = Mail::IMAPClient->new( ) ; 5238 $imap->Socket( $socket ) ; 5239 my $banner = $imap->Results()->[0] ; 5240 #myprint( "banner: $banner" ) ; 5241 return $imap ; 5242} 5243 5244 5245sub tests_probe_imapssl 5246{ 5247 note( 'Entering tests_probe_imapssl()' ) ; 5248 5249 is( undef, probe_imapssl( ), 'probe_imapssl: no args => undef' ) ; 5250 is( undef, probe_imapssl( 'unknown' ), 'probe_imapssl: unknown => undef' ) ; 5251 5252 SKIP: { 5253 if ( 5254 'CUILLERE' eq hostname() 5255 or 5256 skip_macosx() 5257 or 5258 -e '/.dockerenv' 5259 ) 5260 { 5261 skip( 'Tests avoided on CUILLERE/macosx.polarhome.com/docker cannot do ipv6', 2 ) ; 5262 } 5263 like( probe_imapssl( 'ks2ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks2ipv6.lamiral.info matches "* OK"' ) ; 5264 like( probe_imapssl( 'imap.gmail.com' ), qr/^\* OK/, 'probe_imapssl: imap.gmail.com matches "* OK"' ) ; 5265 } ; 5266 5267 like( probe_imapssl( 'test1.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: test1.lamiral.info matches "* OK"' ) ; 5268 5269 note( 'Leaving tests_probe_imapssl()' ) ; 5270 return ; 5271} 5272 5273sub probe_imapssl 5274{ 5275 my $host = shift ; 5276 5277 if ( ! $host ) { return ; } 5278 5279 my $socket = IO::Socket::SSL->new( 5280 PeerHost => $host, 5281 PeerPort => $IMAP_SSL_PORT, 5282 SSL_verify_mode => SSL_VERIFY_NONE, 5283 ) ; 5284 #print "$socket\n" ; 5285 if ( ! $socket ) { return ; } 5286 5287 my $banner ; 5288 $socket->sysread( $banner, 65_536 ) ; 5289 #print "$banner" ; 5290 $socket->close( ) ; 5291 return $banner ; 5292 5293} 5294 5295sub connect_imap 5296{ 5297 my( $host, $port, $mydebugimap, $ssl, $tls, $Side, $mytimeout, $h ) = @_ ; 5298 my $imap = Mail::IMAPClient->new( ) ; 5299 if ( $ssl ) { set_ssl( $imap, $h ) } 5300 $imap->Server( $host ) ; 5301 $imap->Port( $port ) ; 5302 $imap->Debug( $mydebugimap ) ; 5303 $imap->Timeout( $mytimeout ) ; 5304 5305 my $side = lc $Side ; 5306 myprint( "$Side: connecting on $side [$host] port [$port]\n" ) ; 5307 5308 $imap->connect( ) 5309 or exit_clean( $sync, $EXIT_CONNECTION_FAILURE, "$Side: Can not open imap connection on [$host]: " . $imap->LastError . " $OS_ERROR\n" ) ; 5310 myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ; 5311 my $banner = $imap->Results()->[0] ; 5312 5313 myprint( "$Side banner: $banner" ) ; 5314 myprint( "$Side capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; 5315 5316 if ( $tls ) { 5317 set_tls( $imap, $h ) ; 5318 $imap->starttls( ) 5319 or exit_clean( $sync, $EXIT_TLS_FAILURE, "$Side: Can not go to tls encryption on $side [$host]:", $imap->LastError, "\n" ) ; 5320 myprint( "$Side: Socket successfuly converted to SSL\n" ) ; 5321 } 5322 return( $imap ) ; 5323} 5324 5325 5326sub login_imap 5327{ 5328 5329 my @allargs = @_ ; 5330 my( 5331 $host, $port, $user, $domain, $password, 5332 $mydebugimap, $mytimeout, $fastio, 5333 $ssl, $tls, $authmech, $authuser, $reconnectretry, 5334 $proxyauth, $uid, $split, $Side, $h, $mysync ) = @allargs ; 5335 5336 my $side = lc $Side ; 5337 myprint( "$Side: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ; 5338 5339 my $imap = init_imap( @allargs ) ; 5340 5341 $imap->connect() 5342 or exit_clean( $mysync, $EXIT_CONNECTION_FAILURE, "$Side failure: can not open imap connection on $side [$host] with user [$user]: " . $imap->LastError . " $OS_ERROR\n" ) ; 5343 myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ; 5344 my $banner = $imap->Results()->[0] ; 5345 5346 myprint( "$Side banner: $banner" ) ; 5347 myprint( "$Side capability before authentication: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; 5348 5349 if ( (! $ssl) and (! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) { 5350 myprint( "$Side: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ; 5351 $tls = 1 ; 5352 } 5353 5354 if ( $authmech eq 'PREAUTH' ) { 5355 if ( $imap->IsAuthenticated( ) ) { 5356 $imap->Socket ; 5357 myprintf("%s: Assuming PREAUTH for %s\n", $Side, $imap->Server ) ; 5358 }else{ 5359 exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, "$Side failure: error login on $side [$host] with user [$user] auth [PREAUTH]" ) ; 5360 } 5361 } 5362 5363 if ( $tls ) { 5364 set_tls( $imap, $h ) ; 5365 $imap->starttls( ) 5366 or exit_clean( $mysync, $EXIT_TLS_FAILURE, "$Side failure: Can not go to tls encryption on $side [$host]:", $imap->LastError, "\n" ) ; 5367 myprint( "$Side: Socket successfuly converted to SSL\n" ) ; 5368 } 5369 5370 authenticate_imap( $imap, @allargs ) ; 5371 5372 myprint( "$Side: success login on [$host] with user [$user] auth [$authmech]\n" ) ; 5373 return( $imap ) ; 5374} 5375 5376 5377sub authenticate_imap 5378{ 5379 my( $imap, 5380 $host, $port, $user, $domain, $password, 5381 $mydebugimap, $mytimeout, $fastio, 5382 $ssl, $tls, $authmech, $authuser, $reconnectretry, 5383 $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ; 5384 5385 check_capability( $imap, $authmech, $Side ) ; 5386 $imap->User( $user ) ; 5387 $imap->Domain( $domain ) if ( defined $domain ) ; 5388 $imap->Authuser( $authuser ) ; 5389 $imap->Password( $password ) ; 5390 5391 if ( 'X-MASTERAUTH' eq $authmech ) 5392 { 5393 xmasterauth( $imap ) ; 5394 return ; 5395 } 5396 5397 if ( $proxyauth ) { 5398 $imap->Authmechanism(q{}) ; 5399 $imap->User( $authuser ) ; 5400 } else { 5401 $imap->Authmechanism( $authmech ) unless ( $authmech eq 'LOGIN' or $authmech eq 'PREAUTH' ) ; 5402 } 5403 5404 $imap->Authcallback(\&xoauth) if ( 'XOAUTH' eq $authmech ) ; 5405 $imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $authmech ) ; 5406 $imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $authmech ) or ( 'EXTERNAL' eq $authmech ) ) ; 5407 5408 5409 unless ( $authmech eq 'PREAUTH' or $authmech eq 'X-MASTERAUTH' or $imap->login( ) ) { 5410 my $info = "$Side failure: Error login on [$host] with user [$user] auth" ; 5411 my $einfo = $imap->LastError || @{$imap->History}[$LAST] ; 5412 chomp $einfo ; 5413 my $error = "$info [$authmech]: $einfo\n" ; 5414 if ( $authmech eq 'LOGIN' or $imap->IsUnconnected( ) or $authuser ) { 5415 exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, $error ) ; 5416 }else{ 5417 myprint( $error ) ; 5418 } 5419 myprint( "$Side info: trying LOGIN Auth mechanism on [$host] with user [$user]\n" ) ; 5420 $imap->Authmechanism(q{}) ; 5421 $imap->login() or 5422 exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, "$info [LOGIN]: ", $imap->LastError, "\n") ; 5423 } 5424 5425 if ( $proxyauth ) { 5426 if ( ! $imap->proxyauth( $user ) ) { 5427 my $info = "$Side failure: Error doing proxyauth as user [$user] on [$host] using proxy-login as [$authuser]" ; 5428 my $einfo = $imap->LastError || @{$imap->History}[$LAST] ; 5429 chomp $einfo ; 5430 exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, "$info: $einfo\n" ) ; 5431 } 5432 } 5433 5434 return ; 5435} 5436 5437sub check_capability 5438{ 5439 5440 my( $imap, $authmech, $Side ) = @_ ; 5441 5442 5443 if ( $imap->has_capability( "AUTH=$authmech" ) 5444 or $imap->has_capability( $authmech ) ) 5445 { 5446 myprintf("%s: %s says it has CAPABILITY for AUTHENTICATE %s\n", 5447 $Side, $imap->Server, $authmech) ; 5448 return ; 5449 } 5450 5451 if ( $authmech eq 'LOGIN' ) 5452 { 5453 # Well, the warning is so common and useless that I prefer to remove it 5454 # No more "... says it has NO CAPABILITY for AUTHENTICATE LOGIN" 5455 return ; 5456 } 5457 5458 5459 myprintf( "%s: %s says it has NO CAPABILITY for AUTHENTICATE %s\n", 5460 $Side, $imap->Server, $authmech ) ; 5461 5462 if ( $authmech eq 'PLAIN' ) 5463 { 5464 myprint( "$Side: frequently PLAIN is only supported with SSL, try --ssl or --tls options\n" ) ; 5465 } 5466 5467 return ; 5468} 5469 5470sub set_ssl 5471{ 5472 my ( $imap, $h ) = @_ ; 5473 # SSL_version can be 5474 # SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953) 5475 # 5476 5477 my $sslargs_hash = $h->{sslargs} ; 5478 5479 my $sslargs_default = { 5480 SSL_verify_mode => $SSL_VERIFY_POLICY, 5481 SSL_verifycn_scheme => 'imap', 5482 SSL_cipher_list => 'DEFAULT:!DH', 5483 } ; 5484 5485 # initiate with default values 5486 my %sslargs_mix = %{ $sslargs_default } ; 5487 # now override with passed values 5488 @sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ; 5489 # remove keys with undef values 5490 foreach my $key ( keys %sslargs_mix ) { 5491 delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ; 5492 } 5493 # back to an ARRAY 5494 my @sslargs_mix = %sslargs_mix ; 5495 #myprint( Data::Dumper->Dump( [ $sslargs_hash, $sslargs_default, \%sslargs_mix, \@sslargs_mix ] ) ) ; 5496 $imap->Ssl( \@sslargs_mix ) ; 5497 return ; 5498} 5499 5500sub set_tls 5501{ 5502 my ( $imap, $h ) = @_ ; 5503 5504 my $sslargs_hash = $h->{sslargs} ; 5505 5506 my $sslargs_default = { 5507 SSL_verify_mode => $SSL_VERIFY_POLICY, 5508 SSL_cipher_list => 'DEFAULT:!DH', 5509 } ; 5510 5511 # initiate with default values 5512 my %sslargs_mix = %{ $sslargs_default } ; 5513 # now override with passed values 5514 @sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ; 5515 # remove keys with undef values 5516 foreach my $key ( keys %sslargs_mix ) { 5517 delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ; 5518 } 5519 # back to an ARRAY 5520 my @sslargs_mix = %sslargs_mix ; 5521 5522 $imap->Starttls( \@sslargs_mix ) ; 5523 return ; 5524} 5525 5526 5527 5528 5529sub init_imap 5530{ 5531 my( 5532 $host, $port, $user, $domain, $password, 5533 $mydebugimap, $mytimeout, $fastio, 5534 $ssl, $tls, $authmech, $authuser, $reconnectretry, 5535 $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ; 5536 5537 my ( $imap ) ; 5538 5539 $imap = Mail::IMAPClient->new() ; 5540 5541 if ( $ssl ) { set_ssl( $imap, $h ) } 5542 if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS 5543 $imap->Clear(1); 5544 $imap->Server($host); 5545 $imap->Port($port); 5546 $imap->Fast_io($fastio); 5547 $imap->Buffer($buffersize || $DEFAULT_BUFFER_SIZE); 5548 $imap->Uid($uid); 5549 5550 5551 $imap->Peek(1); 5552 $imap->Debug($mydebugimap); 5553 if ( $mysync->{ showpasswords } ) { 5554 $imap->Showcredentials( 1 ) ; 5555 } 5556 defined $mytimeout and $imap->Timeout( $mytimeout ) ; 5557 5558 $imap->Reconnectretry( $reconnectretry ) if ( $reconnectretry ) ; 5559 $imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ; 5560 $imap->Ignoresizeerrors( $allowsizemismatch ) ; 5561 $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ; 5562 5563 5564 return( $imap ) ; 5565 5566} 5567 5568sub plainauth 5569{ 5570 my $code = shift; 5571 my $imap = shift; 5572 5573 my $string = mysprintf("%s\x00%s\x00%s", $imap->User, 5574 $imap->Authuser, $imap->Password); 5575 return encode_base64("$string", q{}); 5576} 5577 5578# Copy from https://github.com/imapsync/imapsync/pull/25/files 5579# Changes "use" pragmas to "require". 5580# The openssl system call shall be replaced by pure Perl and 5581# https://metacpan.org/pod/Crypt::OpenSSL::PKCS12 5582 5583# Now the Joaquin Lopez code: 5584# 5585# Used this as an example: https://gist.github.com/gsainio/6322375 5586# 5587# And this as a reference: https://developers.google.com/accounts/docs/OAuth2ServiceAccount 5588# (note there is an http/rest tab, where the real info is hidden away... went on a witch hunt 5589# until I noticed that...) 5590# 5591# This is targeted at gmail to maintain compatibility after google's oauth1 service is deactivated 5592# on May 5th, 2015: https://developers.google.com/gmail/oauth_protocol 5593# If there are other oauth2 implementations out there, this would need to be modified to be 5594# compatible 5595# 5596# This is a good guide on setting up the google api/apps side of the equation: 5597# http://www.limilabs.com/blog/oauth2-gmail-imap-service-account 5598# 5599# 2016/05/27: Updated to support oauth/key data in the .json files Google now defaults to 5600# when creating gmail service accounts. They're easier to work with since they neither 5601# requiring decrypting nor specifying the oauth2 client id separately. 5602# 5603# If the password arg ends in .json, it will assume this new json method, otherwise it 5604# will fallback to the "oauth client id;.p12" format it was previously using. 5605sub xoauth2 5606{ 5607 require JSON::WebToken ; 5608 require LWP::UserAgent ; 5609 require HTML::Entities ; 5610 require JSON ; 5611 require JSON::WebToken::Crypt::RSA ; 5612 require Crypt::OpenSSL::RSA ; 5613 require Encode::Byte ; 5614 require IO::Socket::SSL ; 5615 5616 my $code = shift; 5617 my $imap = shift; 5618 5619 my ($iss,$key); 5620 5621 if( $imap->Password =~ /^(.*\.json)$/x ) { 5622 my $json = JSON->new( ) ; 5623 my $filename = $1; 5624 $sync->{ debug } and myprint( "XOAUTH2 json file: $filename\n" ) ; 5625 open( my $FILE, '<', $filename ) or exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "error [$filename]: $OS_ERROR " ) ; 5626 my $jsonfile = $json->decode( join q{}, <$FILE> ) ; 5627 close $FILE ; 5628 5629 $iss = $jsonfile->{client_id}; 5630 $key = $jsonfile->{private_key}; 5631 $sync->{ debug } and myprint( "Service account: $iss\n"); 5632 $sync->{ debug } and myprint( "Private key:\n$key\n"); 5633 } 5634 else { 5635 # Get iss (service account address), keyfile name, and keypassword if necessary 5636 ( $iss, my $keyfile, my $keypass ) = $imap->Password =~ /([\-\d\w\@\.]+);([a-zA-Z0-9 \_\-\.\/]+);?(.*)?/x ; 5637 5638 # Assume key password is google default if not provided 5639 $keypass = 'notasecret' if not $keypass; 5640 5641 $sync->{ debug } and myprint( "Service account: $iss\nKey file: $keyfile\nKey password: $keypass\n"); 5642 5643 # Get private key from p12 file (would be better in perl...) 5644 $key = `openssl pkcs12 -in "$keyfile" -nodes -nocerts -passin pass:$keypass -nomacver`; 5645 5646 $sync->{ debug } and myprint( "Private key:\n$key\n"); 5647 } 5648 5649 # Create jwt of oauth2 request 5650 my $time = time ; 5651 my $jwt = JSON::WebToken->encode( { 5652 'iss' => $iss, # service account 5653 'scope' => 'https://mail.google.com/', 5654 'aud' => 'https://www.googleapis.com/oauth2/v3/token', 5655 'exp' => $time + $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12, 5656 'iat' => $time, 5657 'prn' => $imap->User # user to auth as 5658 }, 5659 $key, 'RS256', {'typ' => 'JWT'} ); # Crypt::OpenSSL::RSA needed here. 5660 5661 # Post oauth2 request 5662 my $ua = LWP::UserAgent->new( ) ; 5663 $ua->env_proxy( ) ; 5664 5665 my $response = $ua->post('https://www.googleapis.com/oauth2/v3/token', 5666 { grant_type => HTML::Entities::encode_entities('urn:ietf:params:oauth:grant-type:jwt-bearer'), 5667 assertion => $jwt } ) ; 5668 5669 unless( $response->is_success( ) ) { 5670 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, $response->code, "\n", $response->content, "\n" ) ; 5671 }else{ 5672 $sync->{ debug } and myprint( $response->content ) ; 5673 } 5674 5675 # access_token in response is what we need 5676 my $data = JSON::decode_json( $response->content ) ; 5677 5678 # format as oauth2 auth data 5679 my $xoauth2_string = encode_base64( 'user=' . $imap->User . "\1auth=Bearer " . $data->{access_token} . "\1\1", q{} ) ; 5680 5681 $sync->{ debug } and myprint( "XOAUTH2 String: $xoauth2_string\n"); 5682 return($xoauth2_string); 5683} 5684 5685 5686 5687 5688# xoauth() thanks to Eduardo Bortoluzzi Junior 5689sub xoauth 5690{ 5691 require URI::Escape ; 5692 require Data::Uniqid ; 5693 5694 my $code = shift; 5695 my $imap = shift; 5696 5697 # The base information needed to construct the OAUTH authentication 5698 my $method = 'GET' ; 5699 my $url = mysprintf( 'https://mail.google.com/mail/b/%s/imap/', $imap->User ) ; 5700 my $urlparm = mysprintf( 'xoauth_requestor_id=%s', URI::Escape::uri_escape( $imap->User ) ) ; 5701 5702 # For Google Apps, the consumer key is the primary domain 5703 # TODO: create a command line argument to define the consumer key 5704 my @user_parts = split /@/x, $imap->User ; 5705 $sync->{ debug } and myprint( "XOAUTH: consumer key: $user_parts[1]\n" ) ; 5706 5707 # All the parameters needed to be signed on the XOAUTH 5708 my %hash = (); 5709 $hash { 'xoauth_requestor_id' } = URI::Escape::uri_escape($imap->User); 5710 $hash { 'oauth_consumer_key' } = $user_parts[1]; 5711 $hash { 'oauth_nonce' } = md5_hex(Data::Uniqid::uniqid(rand(), 1==1)); 5712 $hash { 'oauth_signature_method' } = 'HMAC-SHA1'; 5713 $hash { 'oauth_timestamp' } = time ; 5714 $hash { 'oauth_version' } = '1.0'; 5715 5716 # Base will hold the string to be signed 5717 my $base = "$method&" . URI::Escape::uri_escape( $url ) . q{&} ; 5718 5719 # The parameters must be in dictionary order before signing 5720 my $baseparms = q{} ; 5721 foreach my $key ( sort keys %hash ) { 5722 if ( length( $baseparms ) > 0 ) { 5723 $baseparms .= q{&} ; 5724 } 5725 5726 $baseparms .= "$key=$hash{$key}" ; 5727 } 5728 5729 $base .= URI::Escape::uri_escape($baseparms); 5730 $sync->{ debug } and myprint( "XOAUTH: base request to sign: $base\n" ) ; 5731 # Sign it with the consumer secret, informed on the command line (password) 5732 my $digest = hmac_sha1( $base, URI::Escape::uri_escape( $imap->Password ) . q{&} ) ; 5733 5734 # The parameters signed become a parameter and... 5735 $hash { 'oauth_signature' } = URI::Escape::uri_escape( substr encode_base64( $digest ), 0, $MINUS_ONE ) ; 5736 5737 # ... we don't need the requestor_id anymore. 5738 delete $hash{'xoauth_requestor_id'} ; 5739 5740 # Create the final authentication string 5741 my $string = $method . q{ } . $url . q{?} . $urlparm .q{ } ; 5742 5743 # All the parameters must be sorted 5744 $baseparms = q{}; 5745 foreach my $key (sort keys %hash) { 5746 if(length($baseparms)>0) { 5747 $baseparms .= q{,} ; 5748 } 5749 5750 $baseparms .= "$key=\"$hash{$key}\""; 5751 } 5752 5753 $string .= $baseparms; 5754 5755 $sync->{ debug } and myprint( "XOAUTH: authentication string: $string\n" ) ; 5756 5757 # It must be base64 encoded 5758 return encode_base64("$string", q{}); 5759} 5760 5761 5762sub xmasterauth 5763{ 5764 # This is Kerio auth admin 5765 # This code comes from 5766 # https://github.com/imapsync/imapsync/pull/53/files 5767 5768 my $imap = shift ; 5769 5770 my $user = $imap->User( ) ; 5771 my $password = $imap->Password( ) ; 5772 my $authmech = 'X-MASTERAUTH' ; 5773 5774 my @challenge = $imap->tag_and_run( $authmech, "+" ) ; 5775 if ( not defined $challenge[0] ) 5776 { 5777 exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Failure authenticate with $authmech: ", $imap->LastError, "\n") ; 5778 return ; # hahaha! 5779 } 5780 $sync->{ debug } and myprint( "X-MASTERAUTH challenge: [@challenge]\n" ) ; 5781 5782 $challenge[1] =~ s/^\+ |^\s+|\s+$//g ; 5783 $imap->_imap_command( { addcrlf => 1, addtag => 0, tag => $imap->Count }, md5_hex( $challenge[1] . $password ) ) 5784 or exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Failure authenticate with $authmech: ", $imap->LastError, "\n") ; 5785 5786 $imap->tag_and_run( 'X-SETUSER ' . $user ) 5787 or exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Failure authenticate with $authmech: ", "X-SETUSER ", $imap->LastError, "\n") ; 5788 5789 $imap->State( Mail::IMAPClient::Authenticated ) ; 5790 # I comment this state because "Selected" state is usually done by SELECT or EXAMINE imap commands 5791 # $imap->State( Mail::IMAPClient::Selected ) ; 5792 5793 return ; 5794} 5795 5796 5797sub tests_do_valid_directory 5798{ 5799 note( 'Entering tests_do_valid_directory()' ) ; 5800 5801 Readonly my $NB_UNIX_tests_do_valid_directory => 2 ; 5802 SKIP: { 5803 skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory ) if ( 'MSWin32' eq $OSNAME ) ; 5804 ok( 1 == do_valid_directory( '.'), 'do_valid_directory: . good' ) ; 5805 ok( 1 == do_valid_directory( './W/tmp/tests/valid/sub'), 'do_valid_directory: ./W/tmp/tests/valid/sub good' ) ; 5806 } 5807 Readonly my $NB_UNIX_tests_do_valid_directory_non_root => 2 ; 5808 SKIP: { 5809 skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory_non_root ) if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ; 5810 diag( 'Error / not writable is on purpose' ) ; 5811 ok( 0 == do_valid_directory( '/'), 'do_valid_directory: / bad' ) ; 5812 diag( 'Error permission denied on /noway is on purpose' ) ; 5813 ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ; 5814 } 5815 5816 5817 note( 'Leaving tests_do_valid_directory()' ) ; 5818 return ; 5819} 5820 5821sub banner_imapsync 5822{ 5823 my $mysync = shift @ARG ; 5824 my @argv = @ARG ; 5825 5826 my $banner_imapsync = join q{}, 5827 q{$RCSfile: imapsync,v $ }, 5828 q{$Revision: 1.945 $ }, 5829 q{$Date: 2019/06/26 19:30:56 $ }, 5830 "\n", 5831 "Command line used, run by $EXECUTABLE_NAME:\n", 5832 "$PROGRAM_NAME ", command_line_nopassword( $mysync, @argv ), "\n" ; 5833 5834 return( $banner_imapsync ) ; 5835} 5836 5837sub do_valid_directory 5838{ 5839 my $dir = shift @ARG ; 5840 5841 # all good => return ok. 5842 return( 1 ) if ( -d $dir and -r _ and -w _ ) ; 5843 5844 # exist but bad 5845 if ( -e $dir and not -d _ ) { 5846 myprint( "Error: $dir exists but is not a directory\n" ) ; 5847 return( 0 ) ; 5848 } 5849 if ( -e $dir and not -w _ ) { 5850 my $sb = stat $dir ; 5851 myprintf( "Error: directory %s is not writable for user %s, permissions are %04o and owner is %s ( uid %s )\n", 5852 $dir, getpwuid_any_os( $EFFECTIVE_USER_ID ), ($sb->mode & oct($PERMISSION_FILTER) ), getpwuid_any_os( $sb->uid ), $sb->uid( ) ) ; 5853 return( 0 ) ; 5854 } 5855 # Trying to create it 5856 myprint( "Creating directory $dir\n" ) ; 5857 if ( ! eval { mkpath( $dir ) } ) { 5858 myprint( "$EVAL_ERROR" ) if ( $EVAL_ERROR ) ; 5859 } 5860 return( 1 ) if ( -d $dir and -r _ and -w _ ) ; 5861 return( 0 ) ; 5862} 5863 5864 5865sub tests_match_a_pid_number 5866{ 5867 note( 'Entering tests_match_a_pid_number()' ) ; 5868 5869 is( undef, match_a_pid_number( ), 'match_a_pid_number: no args => undef' ) ; 5870 is( undef, match_a_pid_number( '' ), 'match_a_pid_number: "" => undef' ) ; 5871 is( undef, match_a_pid_number( 'lalala' ), 'match_a_pid_number: lalala => undef' ) ; 5872 is( 1, match_a_pid_number( 1 ), 'match_a_pid_number: 1 => 1' ) ; 5873 is( 1, match_a_pid_number( 123 ), 'match_a_pid_number: 123 => 1' ) ; 5874 is( 1, match_a_pid_number( '123' ), 'match_a_pid_number: "123" => 1' ) ; 5875 is( undef, match_a_pid_number( 'a123' ), 'match_a_pid_number: a123 => undef' ) ; 5876 is( 1, match_a_pid_number( 99999 ), 'match_a_pid_number: 99999 => 1' ) ; 5877 is( undef, match_a_pid_number( 0 ), 'match_a_pid_number: 0 => undef' ) ; 5878 is( undef, match_a_pid_number( 100000 ), 'match_a_pid_number: 100000 => undef' ) ; 5879 is( undef, match_a_pid_number( 123456 ), 'match_a_pid_number: 123456 => undef' ) ; 5880 5881 note( 'Leaving tests_match_a_pid_number()' ) ; 5882 return ; 5883} 5884 5885sub match_a_pid_number 5886{ 5887 my $pid = shift @ARG ; 5888 if ( ! $pid ) { return ; } 5889 if ( ! match( $pid, '^\d+$' ) ) { return ; } 5890 if ( 0 > $pid ) { return ; } 5891 #if ( 65535 < $pid ) { return ; } 5892 if ( 99999 < $pid ) { return ; } 5893 return 1 ; 5894} 5895 5896sub tests_remove_pidfile_not_running 5897{ 5898 note( 'Entering tests_remove_pidfile_not_running()' ) ; 5899 5900 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'remove_pidfile_not_running: mkpath W/tmp/tests/' ) ; 5901 is( undef, remove_pidfile_not_running( ), 'remove_pidfile_not_running: no args => undef' ) ; 5902 is( undef, remove_pidfile_not_running( './W' ), 'remove_pidfile_not_running: a dir => undef' ) ; 5903 is( undef, remove_pidfile_not_running( 'noexists' ), 'remove_pidfile_not_running: noexists => undef' ) ; 5904 is( 1, touch( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: prepa empty W/tmp/tests/empty.pid' ) ; 5905 is( undef, remove_pidfile_not_running( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: W/tmp/tests/empty.pid => undef' ) ; 5906 is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/lalala.pid' ) ; 5907 is( undef, remove_pidfile_not_running( 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: W/tmp/tests/lalala.pid => undef' ) ; 5908 is( '55555', string_to_file( '55555', 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/notrunning.pid' ) ; 5909 is( 1, remove_pidfile_not_running( 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: W/tmp/tests/notrunning.pid => 1' ) ; 5910 is( $PROCESS_ID, string_to_file( $PROCESS_ID, 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/running.pid' ) ; 5911 is( undef, remove_pidfile_not_running( 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: W/tmp/tests/running.pid => undef' ) ; 5912 5913 note( 'Leaving tests_remove_pidfile_not_running()' ) ; 5914 return ; 5915} 5916 5917sub remove_pidfile_not_running 5918{ 5919 # 5920 my $pid_filename = shift @ARG ; 5921 5922 if ( ! $pid_filename ) { myprint( "No variable pid_filename\n" ) ; return } ; 5923 if ( ! -e $pid_filename ) { myprint( "File $pid_filename does not exist\n" ) ; return } ; 5924 if ( ! -f $pid_filename ) { myprint( "File $pid_filename is not a file\n" ) ; return } ; 5925 5926 my $pid = firstline( $pid_filename ) ; 5927 if ( ! match_a_pid_number( $pid ) ) { myprint( "pid $pid in $pid_filename is not a number\n" ) ; return } ; 5928 # can't kill myself => do nothing 5929 if ( ! kill 'ZERO', $PROCESS_ID ) { myprint( "Can not kill ZERO myself $PROCESS_ID\n" ) ; return } ; 5930 5931 # can't kill ZERO the pid => it is gone or own by another user => remove pidfile 5932 if ( ! kill 'ZERO', $pid ) { 5933 myprint( "Removing old $pid_filename since its PID $pid is not running anymore (oo-killed?)\n" ) ; 5934 if ( unlink $pid_filename ) { 5935 myprint( "Removed old $pid_filename\n" ) ; 5936 return 1 ; 5937 }else{ 5938 myprint( "Could not remove old $pid_filename because $!\n" ) ; 5939 return ; 5940 } 5941 } 5942 myprint( "Another imapsync process $pid is running as says pidfile $pid_filename\n" ) ; 5943 return ; 5944} 5945 5946 5947sub tests_tail 5948{ 5949 note( 'Entering tests_tail()' ) ; 5950 5951 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'tail: mkpath W/tmp/tests/' ) ; 5952 ok( ( ! -e 'W/tmp/tests/tail.pid' || unlink 'W/tmp/tests/tail.pid' ), 'tail: unlink W/tmp/tests/tail.pid' ) ; 5953 ok( ( ! -e 'W/tmp/tests/tail.txt' || unlink 'W/tmp/tests/tail.txt' ), 'tail: unlink W/tmp/tests/tail.txt' ) ; 5954 5955 is( undef, tail( ), 'tail: no args => undef' ) ; 5956 my $mysync ; 5957 is( undef, tail( $mysync ), 'tail: no pidfile => undef' ) ; 5958 5959 $mysync->{pidfile} = 'W/tmp/tests/tail.pid' ; 5960 is( undef, tail( $mysync ), 'tail: no pidfilelocking => undef' ) ; 5961 5962 $mysync->{pidfilelocking} = 1 ; 5963 is( undef, tail( $mysync ), 'tail: pidfile no exists => undef' ) ; 5964 5965 5966 my $pidandlog = "33333\nW/tmp/tests/tail.txt\n" ; 5967 is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put pid 33333 and tail.txt in pidfile' ) ; 5968 is( undef, tail( $mysync ), 'tail: logfile to tail no exists => undef' ) ; 5969 5970 my $tailcontent = "L1\nL2\nL3\nL4\nL5\n" ; 5971 is( $tailcontent, string_to_file( $tailcontent, 'W/tmp/tests/tail.txt' ), 5972 'tail: put L1\nL2\nL3\nL4\nL5\n in W/tmp/tests/tail.txt' ) ; 5973 5974 is( undef, tail( $mysync ), 'tail: fake pid in pidfile + tail off => 1' ) ; 5975 5976 $mysync->{ tail } = 1 ; 5977 is( 1, tail( $mysync ), 'tail: fake pid in pidfile + tail on=> 1' ) ; 5978 5979 # put my own pid, won't do tail 5980 $pidandlog = "$PROCESS_ID\nW/tmp/tests/tail.txt\n" ; 5981 is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put my own PID in pidfile' ) ; 5982 is( undef, tail( $mysync ), 'tail: my own pid in pidfile => undef' ) ; 5983 5984 note( 'Leaving tests_tail()' ) ; 5985 return ; 5986} 5987 5988 5989 5990sub tail 5991{ 5992 # return undef on failures 5993 # return 1 on success 5994 5995 my $mysync = shift ; 5996 5997 # no tail when aborting! 5998 if ( $mysync->{ abort } ) { return ; } 5999 6000 my $pidfile = $mysync->{pidfile} ; 6001 my $lock = $mysync->{pidfilelocking} ; 6002 my $tail = $mysync->{tail} ; 6003 6004 if ( ! $pidfile ) { return ; } 6005 if ( ! $lock ) { return ; } 6006 if ( ! $tail ) { return ; } 6007 6008 my $pidtotail = firstline( $pidfile ) ; 6009 if ( ! $pidtotail ) { return ; } 6010 6011 6012 6013 # It should not happen but who knows... 6014 if ( $pidtotail eq $PROCESS_ID ) { return ; } 6015 6016 6017 my $filetotail = secondline( $pidfile ) ; 6018 if ( ! $filetotail ) { return ; } 6019 6020 if ( ! -r $filetotail ) 6021 { 6022 #myprint( "Error: can not read $filetotail\n" ) ; 6023 return ; 6024 } 6025 6026 myprint( "Doing a tail -f on $filetotail for processus pid $pidtotail until it is finished.\n" ) ; 6027 my $file = File::Tail->new( 6028 name => $filetotail, 6029 nowait => 1, 6030 interval => 1, 6031 tail => 1, 6032 adjustafter => 2 6033 ); 6034 6035 my $moretimes = 200 ; 6036 # print one line at least 6037 my $line = $file->read ; 6038 myprint( $line ) ; 6039 while ( isrunning( $pidtotail, \$moretimes ) and defined( $line = $file->read ) ) 6040 { 6041 myprint( $line ); 6042 sleep( 0.02 ) ; 6043 } 6044 6045 return 1 ; 6046} 6047 6048sub isrunning 6049{ 6050 my $pidtocheck = shift ; 6051 my $moretimes_ref = shift ; 6052 6053 if ( kill 'ZERO', $pidtocheck ) 6054 { 6055 #myprint( "$pidtocheck running\n" ) ; 6056 return 1 ; 6057 } 6058 elsif ( $$moretimes_ref >= 0 ) 6059 { 6060 # continue to consider it running 6061 $$moretimes_ref-- ; 6062 return 1 ; 6063 } 6064 else 6065 { 6066 myprint( "Tailed processus $pidtocheck ended\n" ) ; 6067 return ; 6068 } 6069} 6070 6071sub tests_write_pidfile 6072{ 6073 note( 'Entering tests_write_pidfile()' ) ; 6074 6075 my $mysync ; 6076 6077 is( 1, write_pidfile( ), 'write_pidfile: no args => 1' ) ; 6078 6079 # no pidfile => ok 6080 $mysync->{pidfile} = q{} ; 6081 is( 1, write_pidfile( $mysync ), 'write_pidfile: no pidfile => undef' ) ; 6082 6083 # The pidfile path is bad => failure 6084 $mysync->{pidfile} = '/no/no/no.pid' ; 6085 is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid, no lock => undef' ) ; 6086 6087 $mysync->{pidfilelocking} = 1 ; 6088 is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid + lock => undef' ) ; 6089 6090 $mysync->{pidfile} = 'W/tmp/tests/test.pid' ; 6091 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'write_pidfile: mkpath W/tmp/tests/' ) ; 6092 is( 1, touch( $mysync->{pidfile} ), 'write_pidfile: lock prepa' ) ; 6093 6094 $mysync->{pidfilelocking} = 0 ; 6095 is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock => 1' ) ; 6096 is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains $PROCESS_ID" ) ; 6097 is( q{}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains no second line" ) ; 6098 6099 $mysync->{pidfilelocking} = 1 ; 6100 is( undef, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + lock => undef' ) ; 6101 6102 6103 $mysync->{pidfilelocking} = 0 ; 6104 $mysync->{ logfile } = 'rrrr.txt' ; 6105 is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock + logfile => 1' ) ; 6106 is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains $PROCESS_ID" ) ; 6107 is( q{rrrr.txt}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains rrrr.txt" ) ; 6108 6109 6110 note( 'Leaving tests_write_pidfile()' ) ; 6111 return ; 6112} 6113 6114 6115 6116sub write_pidfile 6117{ 6118 # returns undef if something is considered fatal 6119 # returns 1 otherwise 6120 6121 if ( ! @ARG ) { return 1 ; } 6122 6123 my $mysync = shift @ARG ; 6124 6125 # Do not write the pid file if this process goal is to abort the process designed by the pid file 6126 if ( $mysync->{abort} ) { return 1 ; } 6127 6128 # 6129 my $pid_filename = $mysync->{ pidfile } ; 6130 my $lock = $mysync->{ pidfilelocking } ; 6131 6132 if ( ! $pid_filename ) 6133 { 6134 myprint( "PID file is unset ( to set it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ; 6135 return( 1 ) ; 6136 } 6137 6138 myprint( "PID file is $pid_filename ( to change it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ; 6139 if ( -e $pid_filename and $lock ) { 6140 myprint( "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ) ; 6141 return ; 6142 6143 } 6144 6145 if ( -e $pid_filename ) { 6146 myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ; 6147 } 6148 6149 my $pid_string = "$PROCESS_ID\n" ; 6150 my $pid_message = "Writing my PID $PROCESS_ID in $pid_filename\n" ; 6151 6152 if ( $mysync->{ logfile } ) 6153 { 6154 $pid_string .= "$mysync->{ logfile }\n" ; 6155 $pid_message .= "Writing also my logfile name in $pid_filename : $mysync->{ logfile }\n" ; 6156 } 6157 6158 if ( open my $FILE_HANDLE, '>', $pid_filename ) { 6159 myprint( $pid_message ) ; 6160 print $FILE_HANDLE $pid_string ; 6161 close $FILE_HANDLE ; 6162 return( 1 ) ; 6163 } 6164 else 6165 { 6166 myprint( "Could not open $pid_filename for writing. Check permissions or disk space: $OS_ERROR\n" ) ; 6167 return ; 6168 } 6169} 6170 6171 6172sub fix_Inbox_INBOX_mapping 6173{ 6174 my( $h1_all, $h2_all ) = @_ ; 6175 6176 my $regex = q{} ; 6177 SWITCH: { 6178 if ( exists $h1_all->{INBOX} and exists $h2_all->{INBOX} ) { $regex = q{} ; last SWITCH ; } ; 6179 if ( exists $h1_all->{Inbox} and exists $h2_all->{Inbox} ) { $regex = q{} ; last SWITCH ; } ; 6180 if ( exists $h1_all->{INBOX} and exists $h2_all->{Inbox} ) { $regex = q{s/^INBOX$/Inbox/x} ; last SWITCH ; } ; 6181 if ( exists $h1_all->{Inbox} and exists $h2_all->{INBOX} ) { $regex = q{s/^Inbox$/INBOX/x} ; last SWITCH ; } ; 6182 } ; 6183 return( $regex ) ; 6184} 6185 6186sub tests_fix_Inbox_INBOX_mapping 6187{ 6188 note( 'Entering tests_fix_Inbox_INBOX_mapping()' ) ; 6189 6190 6191 my( $h1_all, $h2_all ) ; 6192 6193 $h1_all = { 'INBOX' => q{} } ; 6194 $h2_all = { 'INBOX' => q{} } ; 6195 ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX INBOX' ) ; 6196 6197 $h1_all = { 'Inbox' => q{} } ; 6198 $h2_all = { 'Inbox' => q{} } ; 6199 ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox Inbox' ) ; 6200 6201 $h1_all = { 'INBOX' => q{} } ; 6202 $h2_all = { 'Inbox' => q{} } ; 6203 ok( q{s/^INBOX$/Inbox/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX Inbox' ) ; 6204 6205 $h1_all = { 'Inbox' => q{} } ; 6206 $h2_all = { 'INBOX' => q{} } ; 6207 ok( q{s/^Inbox$/INBOX/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox INBOX' ) ; 6208 6209 $h1_all = { 'INBOX' => q{} } ; 6210 $h2_all = { 'rrrrr' => q{} } ; 6211 ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX rrrrrr' ) ; 6212 6213 $h1_all = { 'rrrrr' => q{} } ; 6214 $h2_all = { 'Inbox' => q{} } ; 6215 ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: rrrrr Inbox' ) ; 6216 6217 note( 'Leaving tests_fix_Inbox_INBOX_mapping()' ) ; 6218 return ; 6219} 6220 6221 6222sub jux_utf8_list 6223{ 6224 my @s_inp = @_ ; 6225 my $s_out = q{} ; 6226 foreach my $s ( @s_inp ) { 6227 $s_out .= jux_utf8( $s ) . "\n" ; 6228 } 6229 return( $s_out ) ; 6230} 6231 6232sub tests_jux_utf8_list 6233{ 6234 note( 'Entering tests_jux_utf8_list()' ) ; 6235 6236 ok( q{} eq jux_utf8_list( ), 'jux_utf8_list: void' ) ; 6237 ok( "[]\n" eq jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ; 6238 ok( "[INBOX]\n" eq jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ; 6239 ok( "[&ANY-] = [Ö]\n" eq jux_utf8_list( '&ANY-' ), 'jux_utf8_list: &ANY-' ) ; 6240 6241 note( 'Leaving tests_jux_utf8_list()' ) ; 6242 return( 0 ) ; 6243} 6244 6245sub jux_utf8 6246{ 6247 # juxtapose utf8 at the right if different 6248 my ( $s_utf7 ) = shift ; 6249 my ( $s_utf8 ) = imap_utf7_decode( $s_utf7 ) ; 6250 6251 if ( $s_utf7 eq $s_utf8 ) { 6252 #myprint( "[$s_utf7]\n" ) ; 6253 return( "[$s_utf7]" ) ; 6254 }else{ 6255 #myprint( "[$s_utf7] = [$s_utf8]\n" ) ; 6256 return( "[$s_utf7] = [$s_utf8]" ) ; 6257 } 6258} 6259 6260# editing utf8 can be tricky without an utf8 editor 6261sub tests_jux_utf8 6262{ 6263 note( 'Entering tests_jux_utf8()' ) ; 6264 6265 ok( '[INBOX]' eq jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ; 6266 ok( '[&ZTZO9nux-] = [收件箱]' eq jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ; 6267 ok( '[&ANY-] = [Ö]' eq jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ; 6268 ok( '[]' eq jux_utf8( q{} ), 'jux_utf8: void => []' ) ; 6269 ok( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' eq jux_utf8( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ; 6270 ok( '[&BB8EQAQ+BDUEOgRC-] = [Проект]' eq jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; 6271 6272 note( 'Leaving tests_jux_utf8()' ) ; 6273 return ; 6274} 6275 6276# Copied from http://cpansearch.perl.org/src/FABPOT/Unicode-IMAPUtf7-2.01/lib/Unicode/IMAPUtf7.pm 6277# and then fixed with 6278# https://rt.cpan.org/Public/Bug/Display.html?id=11172 6279sub imap_utf7_decode 6280{ 6281 my ( $s ) = shift ; 6282 6283 # Algorithm 6284 # On remplace , par / dans les BASE 64 (, entre & et -) 6285 # On remplace les &, non suivi d'un - par + 6286 # On remplace les &- par & 6287 $s =~ s/&([^,&\-]*),([^,\-&]*)\-/&$1\/$2\-/xg ; 6288 $s =~ s/&(?!\-)/\+/xg ; 6289 $s =~ s/&\-/&/xg ; 6290 return( Unicode::String::utf7( $s )->utf8 ) ; 6291} 6292 6293sub imap_utf7_encode 6294{ 6295 my ( $s ) = @_ ; 6296 6297 $s = Unicode::String::utf8( $s )->utf7 ; 6298 6299 $s =~ s/\+([^\/&\-]*)\/([^\/\-&]*)\-/\+$1,$2\-/xg ; 6300 $s =~ s/&/&\-/xg ; 6301 $s =~ s/\+([^+\-]+)?\-/&$1\-/xg ; 6302 return( $s ) ; 6303} 6304 6305 6306 6307 6308sub select_folder 6309{ 6310 my ( $mysync, $imap, $folder, $hostside ) = @_ ; 6311 if ( ! $imap->select( $folder ) ) { 6312 my $error = join q{}, 6313 "$hostside folder $folder: Could not select: ", 6314 $imap->LastError, "\n" ; 6315 errors_incr( $mysync, $error ) ; 6316 return( 0 ) ; 6317 }else{ 6318 # ok select succeeded 6319 return( 1 ) ; 6320 } 6321} 6322 6323sub examine_folder 6324{ 6325 my ( $mysync, $imap, $folder, $hostside ) = @_ ; 6326 if ( ! $imap->examine( $folder ) ) { 6327 my $error = join q{}, 6328 "$hostside folder $folder: Could not examine: ", 6329 $imap->LastError, "\n" ; 6330 errors_incr( $mysync, $error ) ; 6331 return( 0 ) ; 6332 }else{ 6333 # ok select succeeded 6334 return( 1 ) ; 6335 } 6336} 6337 6338 6339sub count_from_select 6340{ 6341 my @lines = @ARG ; 6342 my $count ; 6343 foreach my $line ( @lines ) { 6344 #myprint( "line = [$line]\n" ) ; 6345 if ( $line =~ m/^\*\s+(\d+)\s+EXISTS/x ) { 6346 $count = $1 ; 6347 return( $count ) ; 6348 } 6349 } 6350 return( undef ) ; 6351} 6352 6353 6354 6355sub create_folder_old 6356{ 6357 my $mysync = shift @ARG ; 6358 my( $imap, $h2_fold, $h1_fold ) = @ARG ; 6359 6360 myprint( "Creating (old way) folder [$h2_fold] on host2\n" ) ; 6361 if ( ( 'INBOX' eq uc $h2_fold ) 6362 and ( $imap->exists( $h2_fold ) ) ) { 6363 myprint( "Folder [$h2_fold] already exists\n" ) ; 6364 return( 1 ) ; 6365 } 6366 if ( ! $mysync->{dry} ){ 6367 if ( ! $imap->create( $h2_fold ) ) { 6368 my $error = join q{}, 6369 "Could not create folder [$h2_fold] from [$h1_fold]: ", 6370 $imap->LastError( ), "\n" ; 6371 errors_incr( $mysync, $error ) ; 6372 # success if folder exists ("already exists" error) 6373 return( 1 ) if $imap->exists( $h2_fold ) ; 6374 # failure since create failed 6375 return( 0 ) ; 6376 }else{ 6377 #create succeeded 6378 myprint( "Created ( the old way ) folder [$h2_fold] on host2\n" ) ; 6379 return( 1 ) ; 6380 } 6381 }else{ 6382 # dry mode, no folder so many imap will fail, assuming failure 6383 myprint( "Created ( the old way ) folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ; 6384 return( 0 ) ; 6385 } 6386} 6387 6388 6389sub create_folder 6390{ 6391 my $mysync = shift @ARG ; 6392 my( $myimap2 , $h2_fold , $h1_fold ) = @ARG ; 6393 my( @parts , $parent ) ; 6394 6395 if ( $myimap2->IsUnconnected( ) ) { 6396 myprint( "Host2: Unconnected state\n" ) ; 6397 return( 0 ) ; 6398 } 6399 6400 if ( $create_folder_old ) { 6401 return( create_folder_old( $mysync, $myimap2 , $h2_fold , $h1_fold ) ) ; 6402 } 6403 myprint( "Creating folder [$h2_fold] on host2\n" ) ; 6404 if ( ( 'INBOX' eq uc $h2_fold ) 6405 and ( $myimap2->exists( $h2_fold ) ) ) { 6406 myprint( "Folder [$h2_fold] already exists\n" ) ; 6407 return( 1 ) ; 6408 } 6409 6410 if ( $mixfolders and $myimap2->exists( $h2_fold ) ) { 6411 myprint( "Folder [$h2_fold] already exists (--nomixfolders is not set)\n" ) ; 6412 return( 1 ) ; 6413 } 6414 6415 6416 if ( ( not $mixfolders ) and ( $myimap2->exists( $h2_fold ) ) ) { 6417 myprint( "Folder [$h2_fold] already exists and --nomixfolders is set\n" ) ; 6418 return( 0 ) ; 6419 } 6420 6421 @parts = split /\Q$mysync->{ h2_sep }\E/x, $h2_fold ; 6422 pop @parts ; 6423 $parent = join $mysync->{ h2_sep }, @parts ; 6424 $parent =~ s/^\s+|\s+$//xg ; 6425 if ( ( $parent ne q{} ) and ( ! $myimap2->exists( $parent ) ) ) { 6426 create_folder( $mysync, $myimap2 , $parent , $h1_fold ) ; 6427 } 6428 6429 if ( ! $mysync->{dry} ) { 6430 if ( ! $myimap2->create( $h2_fold ) ) { 6431 my $error = join q{}, 6432 "Could not create folder [$h2_fold] from [$h1_fold]: " , 6433 $myimap2->LastError( ), "\n" ; 6434 errors_incr( $mysync, $error ) ; 6435 # success if folder exists ("already exists" error) 6436 return( 1 ) if $myimap2->exists( $h2_fold ) ; 6437 # failure since create failed 6438 return( 0 ) ; 6439 }else{ 6440 #create succeeded 6441 myprint( "Created folder [$h2_fold] on host2\n" ) ; 6442 return( 1 ) ; 6443 } 6444 }else{ 6445 # dry mode, no folder so many imap will fail, assuming failure 6446 myprint( "Created folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ; 6447 if ( ! $mysync->{ justfolders } ) { 6448 myprint( "Since --dry mode is on and folder [$h2_fold] on host2 does not exist yet, syncing messages will not be simulated.\n" 6449 . "To simulate message syncing, use --justfolders without --dry to first create the missing folders then rerun the --dry sync.\n" ) ; 6450 } 6451 return( 0 ) ; 6452 } 6453} 6454 6455 6456 6457sub tests_folder_routines 6458{ 6459 note( 'Entering tests_folder_routines()' ) ; 6460 6461 ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 1' ); 6462 ok( add_to_requested_folders('folder_foo'), 'add_to_requested_folders folder_foo' ); 6463 ok( is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 2' ); 6464 ok( !is_requested_folder('folder_NO_EXIST'), 'is_requested_folder folder_NO_EXIST' ); 6465 6466 is_deeply( [ 'folder_foo' ], [ remove_from_requested_folders( 'folder_foo' ) ], 'removed folder_foo => folder_foo' ) ; 6467 ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 3' ); 6468 my @f ; 6469 ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f" ); 6470 ok( is_requested_folder('folder_bar'), 'is_requested_folder 4' ); 6471 ok( is_requested_folder('folder_toto'), 'is_requested_folder 5' ); 6472 ok( remove_from_requested_folders('folder_toto'), 'remove_from_requested_folders: ' ); 6473 ok( !is_requested_folder('folder_toto'), 'is_requested_folder 6' ); 6474 6475 is_deeply( [ 'folder_bar' ], [ remove_from_requested_folders('folder_bar') ], 'remove_from_requested_folders: empty' ) ; 6476 6477 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [] ), 'sort_requested_folders: all empty' ) ; 6478 ok( add_to_requested_folders( 'A_99', 'M_55', 'Z_11' ), 'add_to_requested_folders M_55 Z_11' ); 6479 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'A_99', 'M_55', 'Z_11' ] ), 'sort_requested_folders: middle' ) ; 6480 6481 6482 @folderfirst = ( 'Z_11' ) ; 6483 6484 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'A_99', 'M_55' ] ), 'sort_requested_folders: first+middle' ) ; 6485 6486 is_deeply( [ 'Z_11', 'A_99', 'M_55' ], [ sort_requested_folders( ) ], 'sort_requested_folders: first+middle is_deeply' ) ; 6487 6488 @folderlast = ( 'A_99' ) ; 6489 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_55', 'A_99' ] ), 'sort_requested_folders: first+middle+last 1' ) ; 6490 6491 ok( add_to_requested_folders('M_55', 'M_44',), 'add_to_requested_folders M_55 M_44' ) ; 6492 6493 ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_44', 'M_55', 'A_99'] ), 'sort_requested_folders: first+middle+last 2' ) ; 6494 6495 6496 ok( add_to_requested_folders('A_88', 'Z_22',), 'add_to_requested_folders A_88 Z_22' ) ; 6497 @folderfirst = qw( Z_22 Z_11 ) ; 6498 @folderlast = qw( A_99 A_88 ) ; 6499 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' ) ; 6500 undef @folderfirst ; 6501 undef @folderlast ; 6502 6503 note( 'Leaving tests_folder_routines()' ) ; 6504 return ; 6505} 6506 6507 6508sub sort_requested_folders 6509{ 6510 my @requested_folders_sorted = () ; 6511 6512 #myprint "folderfirst: @folderfirst\n" ; 6513 my @folderfirst_requested = remove_from_requested_folders( @folderfirst ) ; 6514 #myprint "folderfirst_requested: @folderfirst_requested\n" ; 6515 6516 my @folderlast_requested = remove_from_requested_folders( @folderlast ) ; 6517 6518 my @middle = sort keys %requested_folder ; 6519 6520 @requested_folders_sorted = ( @folderfirst_requested, @middle, @folderlast_requested ) ; 6521 #myprint "requested_folders_sorted: @requested_folders_sorted\n" ; 6522 add_to_requested_folders( @requested_folders_sorted ) ; 6523 6524 return( @requested_folders_sorted ) ; 6525} 6526 6527sub is_requested_folder 6528{ 6529 my ( $folder ) = @_; 6530 6531 return( defined $requested_folder{ $folder } ) ; 6532} 6533 6534 6535sub add_to_requested_folders 6536{ 6537 my @wanted_folders = @_ ; 6538 6539 foreach my $folder ( @wanted_folders ) { 6540 ++$requested_folder{ $folder } ; 6541 } 6542 return( keys %requested_folder ) ; 6543} 6544 6545sub tests_remove_from_requested_folders 6546{ 6547 note( 'Entering tests_remove_from_requested_folders()' ) ; 6548 6549 is( undef, undef, 'remove_from_requested_folders: undef is undef' ) ; 6550 is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: no args' ) ; 6551 %requested_folder = ( 6552 'F1' => 1, 6553 ) ; 6554 is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 => nothing' ) ; 6555 is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 => nothing' ) ; 6556 is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 => F1' ) ; 6557 is_deeply( { }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 => %requested_folder emptied' ) ; 6558 6559 %requested_folder = ( 6560 'F1' => 1, 6561 'F2' => 1, 6562 ) ; 6563 is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 F2 => nothing' ) ; 6564 is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 F2 => nothing' ) ; 6565 is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 F2 => F1' ) ; 6566 is_deeply( { 'F2' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ; 6567 6568 is_deeply( [], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F2 => nothing' ) ; 6569 is_deeply( [ 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F2 => F2' ) ; 6570 is_deeply( {}, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ; 6571 6572 %requested_folder = ( 6573 'F1' => 1, 6574 'F2' => 1, 6575 'F3' => 1, 6576 ) ; 6577 is_deeply( [ 'F1', 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => F1 F2' ) ; 6578 is_deeply( { 'F3' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => %requested_folder F3' ) ; 6579 6580 6581 6582 note( 'Leaving tests_remove_from_requested_folders()' ) ; 6583 return ; 6584} 6585 6586 6587sub remove_from_requested_folders 6588{ 6589 my @unwanted_folders = @_ ; 6590 6591 my @removed_folders = () ; 6592 foreach my $folder ( @unwanted_folders ) { 6593 if ( exists $requested_folder{ $folder } ) 6594 { 6595 delete $requested_folder{ $folder } ; 6596 push @removed_folders, $folder ; 6597 } 6598 } 6599 return( @removed_folders ) ; 6600} 6601 6602sub compare_lists 6603{ 6604 my ($list_1_ref, $list_2_ref) = @_; 6605 6606 return($MINUS_ONE) if ((not defined $list_1_ref) and defined $list_2_ref); 6607 return(0) if ((not defined $list_1_ref) and not defined $list_2_ref); # end if no list 6608 return(1) if (not defined $list_2_ref); # end if only one list 6609 6610 if (not ref $list_1_ref ) {$list_1_ref = [$list_1_ref]}; 6611 if (not ref $list_2_ref ) {$list_2_ref = [$list_2_ref]}; 6612 6613 6614 my $last_used_indice = $MINUS_ONE; 6615 6616 6617 ELEMENT: 6618 foreach my $indice ( 0 .. $#{ $list_1_ref } ) { 6619 $last_used_indice = $indice ; 6620 6621 # End of list_2 6622 return 1 if ($indice > $#{ $list_2_ref } ) ; 6623 6624 my $element_list_1 = $list_1_ref->[$indice] ; 6625 my $element_list_2 = $list_2_ref->[$indice] ; 6626 my $balance = $element_list_1 cmp $element_list_2 ; 6627 next ELEMENT if ($balance == 0) ; 6628 return $balance ; 6629 } 6630 # each element equal until last indice of list_1 6631 return $MINUS_ONE if ($last_used_indice < $#{ $list_2_ref } ) ; 6632 6633 # same size, each element equal 6634 return 0 ; 6635} 6636 6637sub tests_compare_lists 6638{ 6639 note( 'Entering tests_compare_lists()' ) ; 6640 6641 my $empty_list_ref = []; 6642 6643 ok( 0 == compare_lists() , 'compare_lists, no args'); 6644 ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing'); 6645 ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef'); 6646 ok($MINUS_ONE == compare_lists(undef , []) , 'compare_lists, undef < []'); 6647 ok($MINUS_ONE == compare_lists(undef , [1]) , 'compare_lists, undef < [1]'); 6648 ok($MINUS_ONE == compare_lists(undef , [0]) , 'compare_lists, undef < [0]'); 6649 ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing'); 6650 ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef'); 6651 ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []'); 6652 6653 ok($MINUS_ONE == compare_lists([] , [1]) , 'compare_lists, [] < [1]'); 6654 ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []'); 6655 6656 6657 ok( 0 == compare_lists([1], 1 ) , 'compare_lists, [1] = 1 ') ; 6658 ok( 0 == compare_lists( 1 , [1]) , 'compare_lists, 1 = [1]') ; 6659 ok( 0 == compare_lists( 1 , 1 ) , 'compare_lists, 1 = 1 ') ; 6660 ok($MINUS_ONE == compare_lists( 0 , 1 ) , 'compare_lists, 0 < 1 ') ; 6661 ok($MINUS_ONE == compare_lists($MINUS_ONE , 0 ) , 'compare_lists, -1 < 0 ') ; 6662 ok($MINUS_ONE == compare_lists( 1 , 2 ) , 'compare_lists, 1 < 2 ') ; 6663 ok(+1 == compare_lists( 2 , 1 ) , 'compare_lists, 2 > 1 ') ; 6664 6665 6666 ok( 0 == compare_lists([1,2], [1,2]) , 'compare_lists, [1,2] = [1,2]' ) ; 6667 ok($MINUS_ONE == compare_lists([1], [1,2]) , 'compare_lists, [1] < [1,2]' ) ; 6668 ok(+1 == compare_lists([2], [1,2]) , 'compare_lists, [2] > [1,2]' ) ; 6669 ok($MINUS_ONE == compare_lists([1], [1,1]) , 'compare_lists, [1] < [1,1]' ) ; 6670 ok(+1 == compare_lists([1, 1], [1]) , 'compare_lists, [1, 1] > [1]' ) ; 6671 ok( 0 == compare_lists([1 .. $NUMBER_20_000] , [1 .. $NUMBER_20_000]) 6672 , 'compare_lists, [1..20_000] = [1..20_000]' ) ; 6673 ok($MINUS_ONE == compare_lists([1], [2]) , 'compare_lists, [1] < [2]') ; 6674 ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ; 6675 ok(+1 == compare_lists([2], [1]) , 'compare_lists, [2] > [1]') ; 6676 6677 ok($MINUS_ONE == compare_lists(['a'], ['b']) , 'compare_lists, ["a"] < ["b"]') ; 6678 ok( 0 == compare_lists(['a'], ['a']) , 'compare_lists, ["a"] = ["a"]') ; 6679 ok( 0 == compare_lists(['ab'], ['ab']) , 'compare_lists, ["ab"] = ["ab"]') ; 6680 ok(+1 == compare_lists(['b'], ['a']) , 'compare_lists, ["b"] > ["a"]') ; 6681 ok($MINUS_ONE == compare_lists(['a'], ['aa']) , 'compare_lists, ["a"] < ["aa"]') ; 6682 ok($MINUS_ONE == compare_lists(['a'], ['a', 'a']), 'compare_lists, ["a"] < ["a", "a"]') ; 6683 ok( 0 == compare_lists([split q{ }, 'a b' ], ['a', 'b']), 'compare_lists, split') ; 6684 ok( 0 == compare_lists([sort split q{ }, 'b a' ], ['a', 'b']), 'compare_lists, sort split') ; 6685 6686 note( 'Leaving tests_compare_lists()' ) ; 6687 return ; 6688} 6689 6690 6691sub guess_prefix 6692{ 6693 my @foldernames = @_ ; 6694 6695 my $prefix_guessed = q{} ; 6696 foreach my $folder ( @foldernames ) { 6697 next if ( $folder =~ m{^INBOX$}xi ) ; # no guessing from INBOX 6698 if ( $folder !~ m{^INBOX}xi ) { 6699 $prefix_guessed = q{} ; # prefix empty guessed 6700 last ; 6701 } 6702 if ( $folder =~ m{^(INBOX(?:\.|\/))}xi ) { 6703 $prefix_guessed = $1 ; # prefix Inbox/ or INBOX. guessed 6704 } 6705 } 6706 return( $prefix_guessed ) ; 6707} 6708 6709sub tests_guess_prefix 6710{ 6711 note( 'Entering tests_guess_prefix()' ) ; 6712 6713 is( guess_prefix( ), q{}, 'guess_prefix: no args => empty string' ) ; 6714 is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ; 6715 is( q{} , guess_prefix( 'Inbox' ), 'guess_prefix: Inbox alone' ) ; 6716 is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ; 6717 is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk' ), 'guess_prefix: INBOX INBOX/Junk' ) ; 6718 is( 'INBOX.' , guess_prefix( 'INBOX', 'INBOX.Junk' ), 'guess_prefix: INBOX INBOX.Junk' ) ; 6719 is( 'Inbox/' , guess_prefix( 'Inbox', 'Inbox/Junk' ), 'guess_prefix: Inbox Inbox/Junk' ) ; 6720 is( 'Inbox.' , guess_prefix( 'Inbox', 'Inbox.Junk' ), 'guess_prefix: Inbox Inbox.Junk' ) ; 6721 is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr' ) ; 6722 is( q{} , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr', 'zzz' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr zzz' ) ; 6723 is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ; 6724 is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ; 6725 6726 note( 'Leaving tests_guess_prefix()' ) ; 6727 return ; 6728} 6729 6730sub get_prefix 6731{ 6732 my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @_ ; 6733 my( $prefix_out, $prefix_guessed ) ; 6734 6735 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting prefix\n" ) ; 6736 $prefix_guessed = guess_prefix( @{ $folders_ref } ) ; 6737 myprint( "$Side: guessing prefix from folder listing: [$prefix_guessed]\n" ) ; 6738 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Calling namespace capability\n" ) ; 6739 if ( $imap->has_capability( 'namespace' ) ) { 6740 my $r_namespace = $imap->namespace( ) ; 6741 $prefix_out = $r_namespace->[0][0][0] ; 6742 myprint( "$Side: prefix given by NAMESPACE: [$prefix_out]\n" ) ; 6743 if ( defined $prefix_in ) { 6744 myprint( "$Side: but using [$prefix_in] given by $prefix_opt\n" ) ; 6745 $prefix_out = $prefix_in ; 6746 return( $prefix_out ) ; 6747 }else{ 6748 # all good 6749 return( $prefix_out ) ; 6750 } 6751 } 6752 else{ 6753 if ( defined $prefix_in ) { 6754 myprint( "$Side: using [$prefix_in] given by $prefix_opt\n" ) ; 6755 $prefix_out = $prefix_in ; 6756 return( $prefix_out ) ; 6757 }else{ 6758 myprint( 6759 "$Side: No NAMESPACE capability so using guessed prefix [$prefix_guessed]\n", 6760 help_to_guess_prefix( $imap, $prefix_opt ) ) ; 6761 return( $prefix_guessed ) ; 6762 } 6763 } 6764 return ; 6765} 6766 6767 6768sub guess_separator 6769{ 6770 my @foldernames = @_ ; 6771 6772 #return( undef ) unless ( @foldernames ) ; 6773 6774 my $sep_guessed ; 6775 my %counter ; 6776 foreach my $folder ( @foldernames ) { 6777 $counter{'/'}++ while ( $folder =~ m{/}xg ) ; # count / 6778 $counter{'.'}++ while ( $folder =~ m{\.}xg ) ; # count . 6779 $counter{'\\\\'}++ while ( $folder =~ m{(\\){2}}xg ) ; # count \\ 6780 $counter{'\\'}++ while ( $folder =~ m{[^\\](\\){1}(?=[^\\])}xg ) ; # count \ 6781 } 6782 my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ; 6783 $sync->{ debug } and myprint( "@foldernames\n@race_sorted\n", %counter, "\n" ) ; 6784 $sep_guessed = shift @race_sorted || $LAST_RESSORT_SEPARATOR ; # / when nothing found. 6785 return( $sep_guessed ) ; 6786} 6787 6788sub tests_guess_separator 6789{ 6790 note( 'Entering tests_guess_separator()' ) ; 6791 6792 ok( '/' eq guess_separator( ), 'guess_separator: no args' ) ; 6793 ok( '/' eq guess_separator( 'abcd' ), 'guess_separator: abcd' ) ; 6794 ok( '/' eq guess_separator( 'a/b/c.d' ), 'guess_separator: a/b/c.d' ) ; 6795 ok( '.' eq guess_separator( 'a.b/c.d' ), 'guess_separator: a.b/c.d' ) ; 6796 ok( '\\\\' eq guess_separator( 'a\\\\b\\\\c.c\\\\d/e/f' ), 'guess_separator: a\\\\b\\\\c.c\\\\d/e/f' ) ; 6797 ok( '\\' eq guess_separator( 'a\\b\\c.c\\d/e/f' ), 'guess_separator: a\\b\\c.c\\d/e/f' ) ; 6798 ok( '\\' eq guess_separator( 'a\\b' ), 'guess_separator: a\\b' ) ; 6799 ok( '\\' eq guess_separator( 'a\\b\\c' ), 'guess_separator: a\\b\\c' ) ; 6800 6801 note( 'Leaving tests_guess_separator()' ) ; 6802 return ; 6803} 6804 6805sub get_separator 6806{ 6807 my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @_ ; 6808 my( $sep_out, $sep_guessed ) ; 6809 6810 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting separator\n" ) ; 6811 $sep_guessed = guess_separator( @{ $folders_ref } ) ; 6812 myprint( "$Side: guessing separator from folder listing: [$sep_guessed]\n" ) ; 6813 6814 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: calling namespace capability\n" ) ; 6815 if ( $imap->has_capability( 'namespace' ) ) 6816 { 6817 $sep_out = $imap->separator( ) ; 6818 if ( defined $sep_out ) { 6819 myprint( "$Side: separator given by NAMESPACE: [$sep_out]\n" ) ; 6820 if ( defined $sep_in ) { 6821 myprint( "$Side: but using [$sep_in] given by $sep_opt\n" ) ; 6822 $sep_out = $sep_in ; 6823 return( $sep_out ) ; 6824 }else{ 6825 return( $sep_out ) ; 6826 } 6827 }else{ 6828 if ( defined $sep_in ) { 6829 myprint( "$Side: NAMESPACE request failed but using [$sep_in] given by $sep_opt\n" ) ; 6830 $sep_out = $sep_in ; 6831 return( $sep_out ) ; 6832 }else{ 6833 myprint( 6834 "$Side: NAMESPACE request failed so using guessed separator [$sep_guessed]\n", 6835 help_to_guess_sep( $imap, $sep_opt ) ) ; 6836 return( $sep_guessed ) ; 6837 } 6838 } 6839 } 6840 else 6841 { 6842 if ( defined $sep_in ) { 6843 myprint( "$Side: No NAMESPACE capability but using [$sep_in] given by $sep_opt\n" ) ; 6844 $sep_out = $sep_in ; 6845 return( $sep_out ) ; 6846 }else{ 6847 myprint( 6848 "$Side: No NAMESPACE capability, so using guessed separator [$sep_guessed]\n", 6849 help_to_guess_sep( $imap, $sep_opt ) ) ; 6850 return( $sep_guessed ) ; 6851 } 6852 } 6853 return ; 6854} 6855 6856sub help_to_guess_sep 6857{ 6858 my( $imap, $sep_opt ) = @_ ; 6859 6860 my $help_to_guess_sep = "You can set the separator character with the $sep_opt option,\n" 6861 . "the complete listing of folders may help you to find it\n" 6862 . folders_list_to_help( $imap ) ; 6863 6864 return( $help_to_guess_sep ) ; 6865} 6866 6867sub help_to_guess_prefix 6868{ 6869 my( $imap, $prefix_opt ) = @_ ; 6870 6871 my $help_to_guess_prefix = "You can set the prefix namespace with the $prefix_opt option,\n" 6872 . "the folowing listing of folders may help you to find it:\n" 6873 . folders_list_to_help( $imap ) ; 6874 6875 return( $help_to_guess_prefix ) ; 6876} 6877 6878 6879sub folders_list_to_help 6880{ 6881 my( $imap ) = shift ; 6882 6883 my @folders = $imap->folders ; 6884 my $listing = join q{}, map { "[$_]\n" } @folders ; 6885 return( $listing ) ; 6886} 6887 6888sub private_folders_separators_and_prefixes 6889{ 6890# what are the private folders separators and prefixes for each server ? 6891 6892 ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Getting separators\n" ) ; 6893 $sync->{ h1_sep } = get_separator( $sync->{imap1}, $sync->{ sep1 }, '--sep1', 'Host1', \@h1_folders_all ) ; 6894 $sync->{ h2_sep } = get_separator( $sync->{imap2}, $sync->{ sep2 }, '--sep2', 'Host2', \@h2_folders_all ) ; 6895 6896 6897 $sync->{ h1_prefix } = get_prefix( $sync->{imap1}, $prefix1, '--prefix1', 'Host1', \@h1_folders_all ) ; 6898 $sync->{ h2_prefix } = get_prefix( $sync->{imap2}, $prefix2, '--prefix2', 'Host2', \@h2_folders_all ) ; 6899 6900 myprint( "Host1: separator and prefix: [$sync->{ h1_sep }][$sync->{ h1_prefix }]\n" ) ; 6901 myprint( "Host2: separator and prefix: [$sync->{ h2_sep }][$sync->{ h2_prefix }]\n" ) ; 6902 return ; 6903} 6904 6905 6906sub subfolder1 6907{ 6908 my $mysync = shift ; 6909 my $subfolder1 = sanitize_subfolder( $mysync->{ subfolder1 } ) ; 6910 6911 if ( $subfolder1 ) 6912 { 6913 # turns off automap 6914 myprint( "Turning off automapping folders because of --subfolder1\n" ) ; 6915 $mysync->{ automap } = undef ; 6916 myprint( "Sanitizing subfolder1: [$mysync->{ subfolder1 }] => [$subfolder1]\n" ) ; 6917 $mysync->{ subfolder1 } = $subfolder1 ; 6918 add_subfolder1_to_folderrec( $mysync ) || exit_clean( $mysync, $EXIT_SUBFOLDER1_NO_EXISTS ) ; 6919 } 6920 else 6921 { 6922 $mysync->{ subfolder1 } = undef ; 6923 } 6924 6925 return ; 6926} 6927 6928sub subfolder2 6929{ 6930 my $mysync = shift ; 6931 my $subfolder2 = sanitize_subfolder( $mysync->{ subfolder2 } ) ; 6932 if ( $subfolder2 ) 6933 { 6934 # turns off automap 6935 myprint( "Turning off automapping folders because of --subfolder2\n" ) ; 6936 $mysync->{ automap } = undef ; 6937 myprint( "Sanitizing subfolder2: [$mysync->{ subfolder2 }] => [$subfolder2]\n" ) ; 6938 $mysync->{ subfolder2 } = $subfolder2 ; 6939 set_regextrans2_for_subfolder2( $mysync ) ; 6940 } 6941 else 6942 { 6943 $mysync->{ subfolder2 } = undef ; 6944 } 6945 6946 return ; 6947} 6948 6949sub tests_sanitize_subfolder 6950{ 6951 note( 'Entering tests_sanitize_subfolder()' ) ; 6952 6953 is( undef, sanitize_subfolder( ), 'sanitize_subfolder: no args => undef' ) ; 6954 is( undef, sanitize_subfolder( '' ), 'sanitize_subfolder: empty => undef' ) ; 6955 is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blank => undef' ) ; 6956 is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blanks => undef' ) ; 6957 is( 'abcd', sanitize_subfolder( 'abcd' ), 'sanitize_subfolder: abcd => abcd' ) ; 6958 is( 'ab cd', sanitize_subfolder( ' ab cd ' ), 'sanitize_subfolder: " ab cd " => "ab cd"' ) ; 6959 is( 'abcd', sanitize_subfolder( q{a&~b#\\c[]=d;} ), 'sanitize_subfolder: "a&~b#\\c[]=d;" => "abcd"' ) ; 6960 is( 'aA.b-_ 8c/dD', sanitize_subfolder( 'aA.b-_ 8c/dD' ), 'sanitize_subfolder: aA.b-_ 8c/dD => aA.b-_ 8c/dD' ) ; 6961 note( 'Leaving tests_sanitize_subfolder()' ) ; 6962 return ; 6963} 6964 6965 6966sub sanitize_subfolder 6967{ 6968 my $subfolder = shift ; 6969 6970 if ( ! $subfolder ) 6971 { 6972 return ; 6973 } 6974 # Remove edging blanks 6975 $subfolder =~ s,^ +| +$,,g ; 6976 # Keep only abcd...ABCD...0123... and -_./ 6977 $subfolder =~ tr,-_a-zA-Z0-9./ ,,cd ; 6978 6979 # A blank subfolder is not a subfolder 6980 if ( ! $subfolder ) 6981 { 6982 return ; 6983 } 6984 else 6985 { 6986 return $subfolder ; 6987 } 6988} 6989 6990 6991 6992 6993 6994sub tests_add_subfolder1_to_folderrec 6995{ 6996 note( 'Entering tests_add_subfolder1_to_folderrec()' ) ; 6997 6998 is( undef, add_subfolder1_to_folderrec( ), 'add_subfolder1_to_folderrec: undef => undef' ) ; 6999 is_deeply( [], [ add_subfolder1_to_folderrec( ) ], 'add_subfolder1_to_folderrec: no args => empty array' ) ; 7000 @folderrec = () ; 7001 my $mysync = {} ; 7002 is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: empty => empty array' ) ; 7003 is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: empty => empty folderrec' ) ; 7004 $mysync->{ subfolder1 } = 'SUBI' ; 7005 $h1_folders_all{ 'SUBI' } = 1 ; 7006 $mysync->{ h1_prefix } = 'INBOX/' ; 7007 is_deeply( [ 'SUBI' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBI => SUBI' ) ; 7008 is_deeply( [ 'SUBI' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBI => folderrec SUBI ' ) ; 7009 7010 @folderrec = () ; 7011 $mysync->{ subfolder1 } = 'SUBO' ; 7012 is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO no exists => empty array' ) ; 7013 is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO no exists => empty folderrec' ) ; 7014 $h1_folders_all{ 'INBOX/SUBO' } = 1 ; 7015 is_deeply( [ 'INBOX/SUBO' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO' ) ; 7016 is_deeply( [ 'INBOX/SUBO' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO folderrec' ) ; 7017 7018 note( 'Leaving tests_add_subfolder1_to_folderrec()' ) ; 7019 return ; 7020} 7021 7022 7023sub add_subfolder1_to_folderrec 7024{ 7025 my $mysync = shift ; 7026 if ( ! $mysync || ! $mysync->{ subfolder1 } ) 7027 { 7028 return ; 7029 } 7030 7031 my $subfolder1 = $mysync->{ subfolder1 } ; 7032 my $subfolder1_extended = $mysync->{ h1_prefix } . $subfolder1 ; 7033 7034 if ( exists $h1_folders_all{ $subfolder1 } ) 7035 { 7036 myprint( qq{Acting like --folderrec "$subfolder1"\n} ) ; 7037 push @folderrec, $subfolder1 ; 7038 } 7039 elsif ( exists $h1_folders_all{ $subfolder1_extended } ) 7040 { 7041 myprint( qq{Acting like --folderrec "$subfolder1_extended"\n} ) ; 7042 push @folderrec, $subfolder1_extended ; 7043 } 7044 else 7045 { 7046 myprint( qq{Nor folder "$subfolder1" nor "$subfolder1_extended" exists on host1\n} ) ; 7047 } 7048 return @folderrec ; 7049} 7050 7051sub set_regextrans2_for_subfolder2 7052{ 7053 my $mysync = shift ; 7054 7055 7056 unshift @{ $mysync->{ regextrans2 } }, 7057 q(s,^$mysync->{ h2_prefix }(.*),$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }$1,), 7058 q(s,^INBOX$,$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }INBOX,), 7059 q(s,^($mysync->{ h2_prefix }){2},$mysync->{ h2_prefix },); 7060 7061 #myprint( "@{ $mysync->{ regextrans2 } }\n" ) ; 7062 return ; 7063} 7064 7065 7066 7067# Looks like no globals here 7068 7069sub tests_imap2_folder_name 7070{ 7071 note( 'Entering tests_imap2_folder_name()' ) ; 7072 7073 my $mysync = {} ; 7074 $mysync->{ h1_prefix } = q{} ; 7075 $mysync->{ h2_prefix } = q{} ; 7076 $mysync->{ h1_sep } = '/'; 7077 $mysync->{ h2_sep } = '.'; 7078 7079 $mysync->{ debug } and myprint( <<"EOS" 7080prefix1: [$mysync->{ h1_prefix }] 7081prefix2: [$mysync->{ h2_prefix }] 7082sep1: [$sync->{ h1_sep }] 7083sep2: [$sync->{ h2_sep }] 7084EOS 7085) ; 7086 7087 $mysync->{ fixslash2 } = 0 ; 7088 is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string' ) ; 7089 is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ; 7090 is('spam.spam', imap2_folder_name( $mysync, 'spam/spam' ), 'imap2_folder_name: spam/spam' ) ; 7091 7092 is( 'spam/spam', imap2_folder_name( $mysync, 'spam.spam' ), 'imap2_folder_name: spam.spam') ; 7093 is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam' ) ; 7094 is( 's pam.spam/sp am', imap2_folder_name( $mysync, 's pam/spam.sp am' ), 'imap2_folder_name: s pam/spam.sp am' ) ; 7095 7096 $mysync->{f1f2h}{ 'auto' } = 'moto' ; 7097 is( 'moto', imap2_folder_name( $mysync, 'auto' ), 'imap2_folder_name: auto' ) ; 7098 $mysync->{f1f2h}{ 'auto/auto' } = 'moto x 2' ; 7099 is( 'moto x 2', imap2_folder_name( $mysync, 'auto/auto' ), 'imap2_folder_name: auto/auto' ) ; 7100 7101 @{ $mysync->{ regextrans2 } } = ( 's,/,X,g' ) ; 7102 is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string [s,/,X,g]' ) ; 7103 is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla [s,/,X,g]' ) ; 7104 is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam [s,/,X,g]'); 7105 is('spamXspam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam [s,/,X,g]'); 7106 is('spam.spamXspam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam [s,/,X,g]'); 7107 7108 @{ $mysync->{ regextrans2 } } = ( 's, ,_,g' ) ; 7109 is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla [s, ,_,g]'); 7110 is('bla_bla', imap2_folder_name( $mysync, 'bla bla'), 'imap2_folder_name: blabla [s, ,_,g]'); 7111 7112 @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ; 7113 is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), q{imap2_folder_name: blabla [s,\U(.*)\E,$1,]} ) ; 7114 7115 $mysync->{ fixslash2 } = 1 ; 7116 @{ $mysync->{ regextrans2 } } = ( ) ; 7117 is(q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string'); 7118 is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla'); 7119 is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam'); 7120 is('spam_spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam_spam'); 7121 is('spam.spam_spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam_spam'); 7122 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'); 7123 7124 $mysync->{ h1_sep } = '.'; 7125 $mysync->{ h2_sep } = '/'; 7126 is( q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string'); 7127 is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla'); 7128 is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam'); 7129 is('spam/spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam/spam'); 7130 is('spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam'); 7131 7132 7133 7134 $mysync->{ fixslash2 } = 0 ; 7135 $mysync->{ h1_prefix } = q{ }; 7136 7137 is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ; 7138 is( 'spam.spam/spam', imap2_folder_name( $mysync, ' spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ; 7139 7140 $mysync->{ h1_sep } = '.' ; 7141 $mysync->{ h2_sep } = '/' ; 7142 $mysync->{ h1_prefix } = 'INBOX.' ; 7143 $mysync->{ h2_prefix } = q{} ; 7144 @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ; 7145 is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ; 7146 is( 'TEST/TEST/TEST/TEST', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ; 7147 @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\L$1,} ) ; 7148 is( 'test/test/test/test', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ; 7149 7150 # INBOX 7151 $mysync = {} ; 7152 $mysync->{ h1_prefix } = q{Pf1.} ; 7153 $mysync->{ h2_prefix } = q{Pf2/} ; 7154 $mysync->{ h1_sep } = '.'; 7155 $mysync->{ h2_sep } = '/'; 7156 7157 # 7158 #$mysync->{ debug } = 1 ; 7159 is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'F1.F2.F3' ), 'imap2_folder_name: F1.F2.F3 -> Pf2/F1/F2/F3' ) ; 7160 is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'F1.INBOX' ), 'imap2_folder_name: F1.INBOX -> Pf2/F1/INBOX' ) ; 7161 is( 'INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> INBOX' ) ; 7162 7163 is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.F1.F2.F3' ), 'imap2_folder_name: Pf1.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; 7164 is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'Pf1.F1.INBOX' ), 'imap2_folder_name: Pf1.F1.INBOX -> Pf2/F1/INBOX' ) ; 7165 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.INBOX' ), 'imap2_folder_name: Pf1.INBOX -> INBOX' ) ; # not Pf2/INBOX: Yes I can! 7166 7167 7168 7169 # subfolder2 7170 $mysync = {} ; 7171 $mysync->{ h1_prefix } = q{} ; 7172 $mysync->{ h2_prefix } = q{} ; 7173 $mysync->{ h1_sep } = '/'; 7174 $mysync->{ h2_sep } = '.'; 7175 7176 7177 set_regextrans2_for_subfolder2( $mysync ) ; 7178 $mysync->{ subfolder2 } = 'S1.S2' ; 7179 is( 'S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.F1.F2.F3' ) ; 7180 is( 'S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.INBOX' ) ; 7181 7182 $mysync = {} ; 7183 $mysync->{ h1_prefix } = q{Pf1/} ; 7184 $mysync->{ h2_prefix } = q{Pf2.} ; 7185 $mysync->{ h1_sep } = '/'; 7186 $mysync->{ h2_sep } = '.'; 7187 #$mysync->{ debug } = 1 ; 7188 7189 set_regextrans2_for_subfolder2( $mysync ) ; 7190 $mysync->{ subfolder2 } = 'Pf2.S1.S2' ; 7191 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' ) ; 7192 is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ; 7193 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' ) ; 7194 is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'Pf1/INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ; 7195 7196 # subfolder1 7197 # scenario as the reverse of the previous tests, separators point of vue 7198 $mysync = {} ; 7199 $mysync->{ h1_prefix } = q{Pf1.} ; 7200 $mysync->{ h2_prefix } = q{Pf2/} ; 7201 $mysync->{ h1_sep } = '.'; 7202 $mysync->{ h2_sep } = '/'; 7203 #$mysync->{ debug } = 1 ; 7204 7205 $mysync->{ subfolder1 } = 'S1.S2' ; 7206 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' ) ; 7207 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' ) ; 7208 7209 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ; 7210 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ; 7211 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ; 7212 7213 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ; 7214 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ; 7215 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ; 7216 7217 7218 $mysync->{ subfolder1 } = 'S1.S2.' ; 7219 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' ) ; 7220 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' ) ; 7221 7222 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ; 7223 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ; 7224 is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ; 7225 7226 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ; 7227 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ; 7228 is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ; 7229 7230 7231 # subfolder1 7232 # scenario as Gmail 7233 $mysync = {} ; 7234 $mysync->{ h1_prefix } = q{} ; 7235 $mysync->{ h2_prefix } = q{} ; 7236 $mysync->{ h1_sep } = '/'; 7237 $mysync->{ h2_sep } = '/'; 7238 #$mysync->{ debug } = 1 ; 7239 7240 $mysync->{ subfolder1 } = 'S1/S2' ; 7241 is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ; 7242 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ; 7243 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ; 7244 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ; 7245 7246 $mysync->{ subfolder1 } = 'S1/S2/' ; 7247 is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ; 7248 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ; 7249 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ; 7250 is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ; 7251 7252 7253 note( 'Leaving tests_imap2_folder_name()' ) ; 7254 return ; 7255} 7256 7257 7258# Global variables to remove: 7259# 7260 7261 7262sub imap2_folder_name 7263{ 7264 my $mysync = shift ; 7265 my ( $h1_fold ) = shift ; 7266 my ( $h2_fold ) ; 7267 if ( $mysync->{f1f2h}{ $h1_fold } ) { 7268 $h2_fold = $mysync->{f1f2h}{ $h1_fold } ; 7269 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "f1f2 [$h1_fold] -> [$h2_fold]\n" ) ; 7270 return( $h2_fold ) ; 7271 } 7272 if ( $mysync->{f1f2auto}{ $h1_fold } ) { 7273 $h2_fold = $mysync->{f1f2auto}{ $h1_fold } ; 7274 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "automap [$h1_fold] -> [$h2_fold]\n" ) ; 7275 return( $h2_fold ) ; 7276 } 7277 7278 if ( $mysync->{ subfolder1 } ) 7279 { 7280 my $esc_h1_sep = "\\" . $mysync->{ h1_sep } ; 7281 # case where subfolder1 has the sep1 at the end, then remove it 7282 my $part_to_removed = remove_last_char_if_is( $mysync->{ subfolder1 }, $mysync->{ h1_sep } ) ; 7283 # remove the subfolder1 part and the sep1 if present after 7284 $h1_fold =~ s{$part_to_removed($esc_h1_sep)?}{} ; 7285 #myprint( "h1_fold=$h1_fold\n" ) ; 7286 } 7287 7288 if ( ( '' eq $h1_fold ) or ( $mysync->{ h1_prefix } eq $h1_fold ) ) 7289 { 7290 $h1_fold = 'INBOX' ; 7291 } 7292 7293 $h2_fold = prefix_seperator_invertion( $mysync, $h1_fold ) ; 7294 $h2_fold = regextrans2( $mysync, $h2_fold ) ; 7295 return( $h2_fold ) ; 7296} 7297 7298 7299sub tests_remove_last_char_if_is 7300{ 7301 note( 'Entering tests_remove_last_char_if_is()' ) ; 7302 7303 is( undef, remove_last_char_if_is( ), 'remove_last_char_if_is: no args => undef' ) ; 7304 is( '', remove_last_char_if_is( '' ), 'remove_last_char_if_is: empty => empty' ) ; 7305 is( '', remove_last_char_if_is( '', 'Z' ), 'remove_last_char_if_is: empty Z => empty' ) ; 7306 is( '', remove_last_char_if_is( 'Z', 'Z' ), 'remove_last_char_if_is: Z Z => empty' ) ; 7307 is( 'abc', remove_last_char_if_is( 'abcZ', 'Z' ), 'remove_last_char_if_is: abcZ Z => abc' ) ; 7308 is( 'abcY', remove_last_char_if_is( 'abcY', 'Z' ), 'remove_last_char_if_is: abcY Z => abcY' ) ; 7309 note( 'Leaving tests_remove_last_char_if_is()' ) ; 7310 return ; 7311} 7312 7313 7314 7315 7316sub remove_last_char_if_is 7317{ 7318 my $string = shift ; 7319 my $char = shift ; 7320 7321 if ( ! defined $string ) 7322 { 7323 return ; 7324 } 7325 7326 if ( ! defined $char ) 7327 { 7328 return $string ; 7329 } 7330 7331 my $last_char = substr $string, -1 ; 7332 if ( $char eq $last_char ) 7333 { 7334 chop $string ; 7335 return $string ; 7336 } 7337 else 7338 { 7339 return $string ; 7340 } 7341} 7342 7343sub tests_prefix_seperator_invertion 7344{ 7345 note( 'Entering tests_prefix_seperator_invertion()' ) ; 7346 7347 is( undef, prefix_seperator_invertion( ), 'prefix_seperator_invertion: no args => undef' ) ; 7348 is( q{}, prefix_seperator_invertion( undef, q{} ), 'prefix_seperator_invertion: empty string => empty string' ) ; 7349 is( 'lalala', prefix_seperator_invertion( undef, 'lalala' ), 'prefix_seperator_invertion: lalala => lalala' ) ; 7350 is( 'lal/ala', prefix_seperator_invertion( undef, 'lal/ala' ), 'prefix_seperator_invertion: lal/ala => lal/ala' ) ; 7351 is( 'lal.ala', prefix_seperator_invertion( undef, 'lal.ala' ), 'prefix_seperator_invertion: lal.ala => lal.ala' ) ; 7352 is( '////', prefix_seperator_invertion( undef, '////' ), 'prefix_seperator_invertion: //// => ////' ) ; 7353 is( '.....', prefix_seperator_invertion( undef, '.....' ), 'prefix_seperator_invertion: ..... => .....' ) ; 7354 7355 my $mysync = { 7356 h1_prefix => '', 7357 h2_prefix => '', 7358 h1_sep => '/', 7359 h2_sep => '/', 7360 } ; 7361 7362 is( q{}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: $mysync empty string => empty string' ) ; 7363 is( 'lalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: $mysync lalala => lalala' ) ; 7364 is( 'lal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: $mysync lal/ala => lal/ala' ) ; 7365 is( 'lal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: $mysync lal.ala => lal.ala' ) ; 7366 is( '////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: $mysync //// => ////' ) ; 7367 is( '.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: $mysync ..... => .....' ) ; 7368 7369 $mysync = { 7370 h1_prefix => 'PPP', 7371 h2_prefix => 'QQQ', 7372 h1_sep => 's', 7373 h2_sep => 't', 7374 } ; 7375 7376 is( q{QQQ}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: PPPQQQst empty string => QQQ' ) ; 7377 is( 'QQQlalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: PPPQQQst lalala => QQQlalala' ) ; 7378 is( 'QQQlal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: PPPQQQst lal/ala => QQQlal/ala' ) ; 7379 is( 'QQQlal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: PPPQQQst lal.ala => QQQlal.ala' ) ; 7380 is( 'QQQ////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: PPPQQQst //// => QQQ////' ) ; 7381 is( 'QQQ.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: PPPQQQst ..... => QQQ.....' ) ; 7382 7383 is( 'QQQPlalala', prefix_seperator_invertion( $mysync, 'PPPPlalala' ), 'prefix_seperator_invertion: PPPQQQst PPPPlalala => QQQPlalala' ) ; 7384 is( 'QQQ', prefix_seperator_invertion( $mysync, 'PPP' ), 'prefix_seperator_invertion: PPPQQQst PPP => QQQ' ) ; 7385 is( 'QQQttt', prefix_seperator_invertion( $mysync, 'sss' ), 'prefix_seperator_invertion: PPPQQQst sss => QQQttt' ) ; 7386 is( 'QQQt', prefix_seperator_invertion( $mysync, 's' ), 'prefix_seperator_invertion: PPPQQQst s => QQQt' ) ; 7387 is( 'QQQtAAAtBBB', prefix_seperator_invertion( $mysync, 'PPPsAAAsBBB' ), 'prefix_seperator_invertion: PPPQQQst PPPsAAAsBBB => QQQtAAAtBBB' ) ; 7388 7389 note( 'Leaving tests_prefix_seperator_invertion()' ) ; 7390 return ; 7391} 7392 7393# Global variables to remove: 7394 7395 7396sub prefix_seperator_invertion 7397{ 7398 my $mysync = shift ; 7399 my $h1_fold = shift ; 7400 my $h2_fold ; 7401 7402 if ( not defined $h1_fold ) { return ; } 7403 7404 my $my_h1_prefix = $mysync->{ h1_prefix } || q{} ; 7405 my $my_h2_prefix = $mysync->{ h2_prefix } || q{} ; 7406 my $my_h1_sep = $mysync->{ h1_sep } || '/' ; 7407 my $my_h2_sep = $mysync->{ h2_sep } || '/' ; 7408 7409 # first we remove the prefix 7410 $h1_fold =~ s/^\Q$my_h1_prefix\E//x ; 7411 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ; 7412 $h2_fold = separator_invert( $mysync, $h1_fold, $my_h1_sep, $my_h2_sep ) ; 7413 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ; 7414 7415 # Adding the prefix supplied by namespace or the --prefix2 option 7416 # except for INBOX or Inbox 7417 if ( $h2_fold !~ m/^INBOX$/xi ) 7418 { 7419 $h2_fold = $my_h2_prefix . $h2_fold ; 7420 } 7421 7422 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ; 7423 return( $h2_fold ) ; 7424} 7425 7426sub tests_separator_invert 7427{ 7428 note( 'Entering tests_separator_invert()' ) ; 7429 7430 my $mysync = {} ; 7431 $mysync->{ fixslash2 } = 0 ; 7432 ok( not( defined separator_invert( ) ), 'separator_invert: no args' ) ; 7433 ok( not( defined separator_invert( q{} ) ), 'separator_invert: not enough args' ) ; 7434 ok( not( defined separator_invert( q{}, q{} ) ), 'separator_invert: not enough args' ) ; 7435 7436 ok( q{} eq separator_invert( $mysync, q{}, q{}, q{} ), 'separator_invert: 3 empty strings' ) ; 7437 ok( 'lalala' eq separator_invert( $mysync, 'lalala', q{}, q{} ), 'separator_invert: empty separator' ) ; 7438 ok( 'lalala' eq separator_invert( $mysync, 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ; 7439 ok( 'lal/ala' eq separator_invert( $mysync, 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ; 7440 ok( 'lal.ala' eq separator_invert( $mysync, 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ; 7441 ok( 'lal/ala' eq separator_invert( $mysync, 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ; 7442 ok( 'la.l/ala' eq separator_invert( $mysync, 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ; 7443 7444 ok( 'l/al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ; 7445 $mysync->{ fixslash2 } = 1 ; 7446 ok( 'l_al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ; 7447 7448 note( 'Leaving tests_separator_invert()' ) ; 7449 return ; 7450} 7451 7452# Global variables to remove: 7453# 7454sub separator_invert 7455{ 7456 my( $mysync, $h1_fold, $h1_separator, $h2_separator ) = @_ ; 7457 7458 return( undef ) if ( not all_defined( $mysync, $h1_fold, $h1_separator, $h2_separator ) ) ; 7459 # The separator we hope we'll never encounter: 00000000 == 0x00 7460 my $o_sep = "\000" ; 7461 7462 my $h2_fold = $h1_fold ; 7463 $h2_fold =~ s,\Q$h2_separator,$o_sep,xg ; 7464 $h2_fold =~ s,\Q$h1_separator,$h2_separator,xg ; 7465 $h2_fold =~ s,\Q$o_sep,$h1_separator,xg ; 7466 $h2_fold =~ s,/,_,xg if( $mysync->{ fixslash2 } and '/' ne $h2_separator and '/' eq $h1_separator ) ; 7467 return( $h2_fold ) ; 7468} 7469 7470 7471sub regextrans2 7472{ 7473 my( $mysync, $h2_fold ) = @_ ; 7474 # Transforming the folder name by the --regextrans2 option(s) 7475 foreach my $regextrans2 ( @{ $mysync->{ regextrans2 } } ) { 7476 my $h2_fold_before = $h2_fold ; 7477 my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ; 7478 ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ; 7479 if ( not ( defined $ret ) or $EVAL_ERROR ) { 7480 exit_clean( $mysync, $EX_USAGE, "error: eval regextrans2 '$regextrans2': $EVAL_ERROR\n" ) ; 7481 } 7482 } 7483 return( $h2_fold ) ; 7484} 7485 7486 7487sub tests_decompose_regex 7488{ 7489 note( 'Entering tests_decompose_regex()' ) ; 7490 7491 ok( 1, 'decompose_regex 1' ) ; 7492 ok( 0 == compare_lists( [ q{}, q{} ], [ decompose_regex( q{} ) ] ), 'decompose_regex empty string' ) ; 7493 ok( 0 == compare_lists( [ '.*', 'lala' ], [ decompose_regex( 's/.*/lala/' ) ] ), 'decompose_regex s/.*/lala/' ) ; 7494 7495 note( 'Leaving tests_decompose_regex()' ) ; 7496 return ; 7497} 7498 7499sub decompose_regex 7500{ 7501 my $regex = shift ; 7502 my( $left_part, $right_part ) ; 7503 7504 ( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x; 7505 return( q{}, q{} ) if not $left_part ; 7506 return( $left_part, $right_part ) ; 7507} 7508 7509 7510sub foldersizes 7511{ 7512 7513 my ( $side, $imap, $search_cmd, $abletosearch, @folders ) = @_ ; 7514 my $total_size = 0 ; 7515 my $total_nb = 0 ; 7516 my $biggest_in_all = 0 ; 7517 7518 my $nb_folders = scalar @folders ; 7519 my $ct_folders = 0 ; # folder counter. 7520 myprint( "++++ Calculating sizes of $nb_folders folders on $side\n" ) ; 7521 foreach my $folder ( @folders ) { 7522 my $stot = 0 ; 7523 my $nb_msgs = 0 ; 7524 $ct_folders++ ; 7525 myprintf( "$side folder %7s %-35s", "$ct_folders/$nb_folders", jux_utf8( $folder ) ) ; 7526 if ( 'Host2' eq $side and not exists $h2_folders_all_UPPER{ uc $folder } ) { 7527 myprint( " does not exist yet\n") ; 7528 next ; 7529 } 7530 if ( 'Host1' eq $side and not exists $h1_folders_all{ $folder } ) { 7531 myprint( " does not exist\n" ) ; 7532 next ; 7533 } 7534 7535 last if $imap->IsUnconnected( ) ; 7536 # FTGate is RFC buggy with EXAMINE it does not act as SELECT 7537 #unless ( $imap->examine( $folder ) ) { 7538 unless ( $imap->select( $folder ) ) { 7539 my $error = join q{}, 7540 "$side Folder $folder: Could not select: ", 7541 $imap->LastError, "\n" ; 7542 errors_incr( $sync, $error ) ; 7543 next ; 7544 } 7545 last if $imap->IsUnconnected( ) ; 7546 7547 my $hash_ref = { } ; 7548 my @msgs = select_msgs( $imap, undef, $search_cmd, $abletosearch, $folder ) ; 7549 $nb_msgs = scalar @msgs ; 7550 my $biggest_in_folder = 0 ; 7551 @{ $hash_ref }{ @msgs } = ( undef ) if @msgs ; 7552 7553 last if $imap->IsUnconnected( ) ; 7554 if ( $nb_msgs > 0 and @msgs ) { 7555 if ( $abletosearch ) { 7556 if ( ! $imap->fetch_hash( \@msgs, 'RFC822.SIZE', $hash_ref) ) { 7557 my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ; 7558 errors_incr( $sync, $error ) ; 7559 return ; 7560 } 7561 }else{ 7562 my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; 7563 my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; 7564 if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) { 7565 my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ; 7566 errors_incr( $sync, $error ) ; 7567 return ; 7568 } 7569 } 7570 for ( keys %{ $hash_ref } ) { 7571 my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ; 7572 $stot += $size ; 7573 $biggest_in_folder = max( $biggest_in_folder, $size ) ; 7574 } 7575 } 7576 7577 myprintf( ' Size: %9s', $stot ) ; 7578 myprintf( ' Messages: %5s', $nb_msgs ) ; 7579 myprintf( " Biggest: %9s\n", $biggest_in_folder ) ; 7580 $total_size += $stot ; 7581 $total_nb += $nb_msgs ; 7582 $biggest_in_all = max( $biggest_in_all, $biggest_in_folder ) ; 7583 } 7584 myprintf( "%s Nb folders: %11s folders\n", $side, $nb_folders ) ; 7585 myprintf( "%s Nb messages: %11s messages\n", $side, $total_nb ) ; 7586 myprintf( "%s Total size: %11s bytes (%s)\n", $side, $total_size, bytes_display_string( $total_size ) ) ; 7587 myprintf( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string( $biggest_in_all ) ) ; 7588 myprintf( "%s Time spent: %11.1f seconds\n", $side, timenext( ) ) ; 7589 return( $total_nb, $total_size ) ; 7590} 7591 7592sub timenext 7593{ 7594 my ( $timenow, $timediff ) ; 7595 # $timebefore is global, beurk ! 7596 $timenow = time ; 7597 $timediff = $timenow - $timebefore ; 7598 $timebefore = $timenow ; 7599 return( $timediff ) ; 7600} 7601 7602sub timesince 7603{ 7604 my $timeinit = shift || 0 ; 7605 my ( $timenow, $timediff ) ; 7606 $timenow = time ; 7607 $timediff = $timenow - $timeinit ; 7608 # Often used in a division so no 0 7609 return( max( 1, $timediff) ) ; 7610} 7611 7612 7613 7614 7615sub tests_flags_regex 7616{ 7617 note( 'Entering tests_flags_regex()' ) ; 7618 7619 ok( q{} eq flags_regex(q{} ), 'flags_regex, null string q{}' ) ; 7620 ok( q{\Seen NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, nothing to do} ) ; 7621 7622 @regexflag = ('I am BAD' ) ; 7623 ok( not ( defined flags_regex( q{} ) ), 'flags_regex, bad regex' ) ; 7624 7625 @regexflag = ( 's/NonJunk//g' ) ; 7626 ok( q{\Seen $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove NonJunk: 's/NonJunk//g'} ) ; 7627 @regexflag = ( q{s/\$Spam//g} ) ; 7628 ok( q{\Seen NonJunk } eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove $Spam: 's/\$Spam//g'} ) ; 7629 7630 @regexflag = ( 's/\\\\Seen//g' ) ; 7631 7632 ok( q{ NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove \Seen: 's/\\\\\\\\Seen//g'} ) ; 7633 7634 @regexflag = ( 's/(\s|^)[^\\\\]\w+//g' ) ; 7635 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} ) ; 7636 ok( q{ \Seen \Middle \End1} eq flags_regex( q{Begin \Seen NonJunk \Middle $Spam \End1 End} ), 7637 q{flags_regex: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ; 7638 7639 @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g} ) ; 7640 ok( 'Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), 'Keep only regex' ) ; 7641 7642 ok( 'Keep1 Keep2 ' eq flags_regex( 'REM REM Keep1 Keep2'), 'Keep only regex' ) ; 7643 ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 REM REM Keep2'), 'Keep only regex' ) ; 7644 ok( 'Keep1 Keep2 ' eq flags_regex( 'REM Keep1 REM REM Keep2'), 'Keep only regex' ) ; 7645 ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2'), 'Keep only regex' ) ; 7646 ok( 'Keep1 ' eq flags_regex( 'REM Keep1'), 'Keep only regex' ) ; 7647 7648 @regexflag = ( q{s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g} ) ; 7649 ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 ReB'), 'Keep only regex' ) ; 7650 ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 REM REM REM'), 'Keep only regex' ) ; 7651 ok( 'Keep2 ' eq flags_regex('Keep2 REM REM REM'), 'Keep only regex' ) ; 7652 7653 7654 @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g}, 7655 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ; 7656 ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), 'Keep only regex' ) ; 7657 ok( 'Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex' ) ; 7658 ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex' ) ; 7659 ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex' ) ; 7660 ok( 'Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex' ) ; 7661 ok( 'Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex' ) ; 7662 ok( 'Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex' ) ; 7663 7664 @regexflag = ( 's/(.*)/$1 jrdH8u/' ) ; 7665 ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), q{Add jrdH8u 's/(.*)/\$1 jrdH8u/'} ) ; 7666 @regexflag = ('s/jrdH8u *//'); 7667 ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), q{Remove jrdH8u s/jrdH8u *//} ) ; 7668 7669 @regexflag = ( 7670 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg' 7671 ); 7672 7673 ok( '\\Deleted \\Answered ' 7674 eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'), 7675 'Keep only regex: Exchange case (Phil)' ) ; 7676 7677 ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ; 7678 7679 ok( q{} 7680 eq flags_regex('Blabla $Junk machin truc'), 7681 'Keep only regex: Exchange case, no accepted flags (Phil)' ) ; 7682 7683 ok('\\Deleted \\Answered \\Draft \\Flagged ' 7684 eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), 7685 'Keep only regex: Exchange case (Phil)' ) ; 7686 7687 @regexflag = ( 's/\\\\Flagged//g' ) ; 7688 7689 is('\Deleted \Answered \Draft ', 7690 flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), 7691 'flags_regex: remove \Flagged 1' ) ; 7692 is('\\Deleted \\Answered \\Draft', 7693 flags_regex('\\Deleted \\Flagged \\Answered \\Draft'), 7694 'flags_regex: remove \Flagged 2' ) ; 7695 7696 # I didn't understand why it gives \F 7697 # https://perldoc.perl.org/perlrebackslash.html 7698 # \F Foldcase till \E. Not in []. 7699 # https://perldoc.perl.org/functions/fc.html 7700 7701 # \F Not available in old Perl so I comment the test 7702 7703 # @regexflag = ( 's/\\Flagged/X/g' ) ; 7704 #is('\Deleted FX \Answered \FX \Draft \FX', 7705 #flags_regex( '\Deleted Flagged \Answered \Flagged \Draft \Flagged' ), 7706 # 'flags_regex: remove \Flagged 3 mistery...' ) ; 7707 7708 note( 'Leaving tests_flags_regex()' ) ; 7709 return ; 7710} 7711 7712sub flags_regex 7713{ 7714 my ( $h1_flags ) = @_ ; 7715 foreach my $regexflag ( @regexflag ) { 7716 my $h1_flags_orig = $h1_flags ; 7717 $debugflags and myprint( "eval \$h1_flags =~ $regexflag\n" ) ; 7718 my $ret = eval "\$h1_flags =~ $regexflag ; 1 " ; 7719 $debugflags and myprint( "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n" ) ; 7720 if( not ( defined $ret ) or $EVAL_ERROR ) { 7721 myprint( "Error: eval regexflag '$regexflag': $EVAL_ERROR\n" ) ; 7722 return( undef ) ; 7723 } 7724 } 7725 return( $h1_flags ) ; 7726} 7727 7728sub acls_sync 7729{ 7730 my($h1_fold, $h2_fold) = @_ ; 7731 if ( $syncacls ) { 7732 my $h1_hash = $sync->{imap1}->getacl($h1_fold) 7733 or myprint( "Could not getacl for $h1_fold: $EVAL_ERROR\n" ) ; 7734 my $h2_hash = $sync->{imap2}->getacl($h2_fold) 7735 or myprint( "Could not getacl for $h2_fold: $EVAL_ERROR\n" ) ; 7736 my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ; 7737 foreach my $user (sort keys %users ) { 7738 my $acl = $h1_hash->{$user} || 'none' ; 7739 myprint( "acl $user: [$acl]\n" ) ; 7740 next if ($h1_hash->{$user} && $h2_hash->{$user} && 7741 $h1_hash->{$user} eq $h2_hash->{$user}); 7742 unless ($sync->{dry}) { 7743 myprint( "setting acl $h2_fold $user $acl\n" ) ; 7744 $sync->{imap2}->setacl($h2_fold, $user, $acl) 7745 or myprint( "Could not set acl: $EVAL_ERROR\n" ) ; 7746 } 7747 } 7748 } 7749 return ; 7750} 7751 7752 7753sub tests_permanentflags 7754{ 7755 note( 'Entering tests_permanentflags()' ) ; 7756 7757 my $string; 7758 ok(q{} eq permanentflags(' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited'), 7759 'permanentflags \*'); 7760 ok('\Draft \Answered' eq permanentflags(' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited'), 7761 'permanentflags \Draft \Answered'); 7762 ok('\Draft \Answered' 7763 eq permanentflags('Blabla', 7764 ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited', 7765 'Blabla'), 7766 'permanentflags \Draft \Answered' 7767 ); 7768 ok(q{} eq permanentflags('Blabla'), 'permanentflags nothing'); 7769 7770 note( 'Leaving tests_permanentflags()' ) ; 7771 return ; 7772} 7773 7774sub permanentflags 7775{ 7776 my @lines = @_ ; 7777 7778 foreach my $line (@lines) { 7779 if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) { 7780 ( $debugflags or $sync->{ debug } ) and myprint( "permanentflags: $line" ) ; 7781 my $permanentflags = $1 ; 7782 if ( $permanentflags =~ m{\\\*}x ) { 7783 $permanentflags = q{} ; 7784 } 7785 return($permanentflags) ; 7786 } ; 7787 } 7788 return( q{} ) ; 7789} 7790 7791sub tests_flags_filter 7792{ 7793 note( 'Entering tests_flags_filter()' ) ; 7794 7795 ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' ); 7796 ok( q{} eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' ); 7797 ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' ); 7798 ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' ); 7799 ok( '\Seen \Draft' 7800 eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' ); 7801 ok( '\Seen \Draft' 7802 eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' ); 7803 7804 note( 'Leaving tests_flags_filter()' ) ; 7805 return ; 7806} 7807 7808sub flags_filter 7809{ 7810 my( $flags, $allowed_flags ) = @_ ; 7811 7812 my @flags = split /\s+/x, $flags ; 7813 my %allowed_flags = map { $_ => 1 } split q{ }, $allowed_flags ; 7814 my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags ; 7815 7816 my $flags_out = join q{ }, @flags_out ; 7817 7818 return( $flags_out ) ; 7819} 7820 7821sub flagscase 7822{ 7823 my $flags = shift ; 7824 7825 my @flags = split /\s+/x, $flags ; 7826 my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ; 7827 my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ; 7828 7829 my $flags_out = join q{ }, @flags_out ; 7830 7831 return( $flags_out ) ; 7832} 7833 7834sub tests_flagscase 7835{ 7836 note( 'Entering tests_flagscase()' ) ; 7837 7838 ok( '\Seen' eq flagscase( '\Seen' ), 'flagscase: \Seen -> \Seen' ) ; 7839 ok( '\Seen' eq flagscase( '\SEEN' ), 'flagscase: \SEEN -> \Seen' ) ; 7840 7841 ok( '\Seen \Draft' eq flagscase( '\SEEN \DRAFT' ), 'flagscase: \SEEN \DRAFT -> \Seen \Draft' ) ; 7842 ok( '\Draft \Seen' eq flagscase( '\DRAFT \SEEN' ), 'flagscase: \DRAFT \SEEN -> \Draft \Seen' ) ; 7843 7844 ok( '\Draft LALA \Seen' eq flagscase( '\DRAFT LALA \SEEN' ), 'flagscase: \DRAFT LALA \SEEN -> \Draft LALA \Seen' ) ; 7845 ok( '\Draft lala \Seen' eq flagscase( '\DRAFT lala \SEEN' ), 'flagscase: \DRAFT lala \SEEN -> \Draft lala \Seen' ) ; 7846 7847 note( 'Leaving tests_flagscase()' ) ; 7848 return ; 7849} 7850 7851 7852 7853sub ucsecond 7854{ 7855 my $string = shift ; 7856 my $output ; 7857 7858 return( $string ) if ( 1 >= length $string ) ; 7859 7860 $output = ( substr( $string, 0, 1) ) . ( uc substr $string, 1, 1 ) . ( substr $string, 2 ) ; 7861 #myprint( "UUU $string -> $output\n" ) ; 7862 return( $output ) ; 7863} 7864 7865 7866sub tests_ucsecond 7867{ 7868 note( 'Entering tests_ucsecond()' ) ; 7869 7870 ok( 'aBcde' eq ucsecond( 'abcde' ), 'ucsecond: abcde -> aBcde' ) ; 7871 ok( 'ABCDE' eq ucsecond( 'ABCDE' ), 'ucsecond: ABCDE -> ABCDE' ) ; 7872 ok( 'ABCDE' eq ucsecond( 'AbCDE' ), 'ucsecond: AbCDE -> ABCDE' ) ; 7873 ok( 'ABCde' eq ucsecond( 'AbCde' ), 'ucsecond: AbCde -> ABCde' ) ; 7874 ok( 'A' eq ucsecond( 'A' ), 'ucsecond: A -> A' ) ; 7875 ok( 'AB' eq ucsecond( 'Ab' ), 'ucsecond: Ab -> AB' ) ; 7876 ok( '\B' eq ucsecond( '\b' ), 'ucsecond: \b -> \B' ) ; 7877 ok( '\Bcde' eq ucsecond( '\bcde' ), 'ucsecond: \bcde -> \Bcde' ) ; 7878 7879 note( 'Leaving tests_ucsecond()' ) ; 7880 return ; 7881} 7882 7883 7884sub select_msgs 7885{ 7886 my ( $imap, $msgs_all_hash_ref, $search_cmd, $abletosearch, $folder ) = @_ ; 7887 my ( @msgs ) ; 7888 7889 if ( $abletosearch ) { 7890 @msgs = select_msgs_by_search( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; 7891 }else{ 7892 @msgs = select_msgs_by_fetch( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; 7893 } 7894 return( @msgs ) ; 7895 7896} 7897 7898sub select_msgs_by_search 7899{ 7900 my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; 7901 my ( @msgs, @msgs_all ) ; 7902 7903 # Need to have the whole list in msgs_all_hash_ref 7904 # without calling messages() several times. 7905 # Need all messages list to avoid deleting useful cache part 7906 # in case of --search or --minage or --maxage 7907 7908 if ( ( defined $msgs_all_hash_ref and $usecache ) 7909 or ( not defined $maxage and not defined $minage and not defined $search_cmd ) 7910 ) { 7911 7912 $debugdev and myprint( "Calling messages()\n" ) ; 7913 @msgs_all = $imap->messages( ) ; 7914 7915 return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ; 7916 7917 if ( defined $msgs_all_hash_ref ) { 7918 @{ $msgs_all_hash_ref }{ @msgs_all } = () ; 7919 } 7920 # return all messages 7921 if ( not defined $maxage and not defined $minage and not defined $search_cmd ) { 7922 return( @msgs_all ) ; 7923 } 7924 } 7925 7926 if ( defined $search_cmd ) { 7927 @msgs = $imap->search( $search_cmd ) ; 7928 return( @msgs ) ; 7929 } 7930 7931 # we are here only if $maxage or $minage is defined 7932 @msgs = select_msgs_by_age( $imap ) ; 7933 return( @msgs ); 7934} 7935 7936 7937sub select_msgs_by_fetch 7938{ 7939 my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; 7940 my ( @msgs, @msgs_all, %fetch ) ; 7941 7942 # Need to have the whole list in msgs_all_hash_ref 7943 # without calling messages() several times. 7944 # Need all messages list to avoid deleting useful cache part 7945 # in case of --search or --minage or --maxage 7946 7947 7948 $debugdev and myprint( "Calling fetch_hash()\n" ) ; 7949 my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; 7950 my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; 7951 %fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ; 7952 7953 @msgs_all = sort { $a <=> $b } keys %fetch ; 7954 $debugdev and myprint( "Done fetch_hash()\n" ) ; 7955 7956 return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ; 7957 7958 if ( defined $msgs_all_hash_ref ) { 7959 @{ $msgs_all_hash_ref }{ @msgs_all } = () ; 7960 } 7961 # return all messages 7962 if ( not defined $maxage and not defined $minage and not defined $search_cmd ) { 7963 return( @msgs_all ) ; 7964 } 7965 7966 if ( defined $search_cmd ) { 7967 myprint( "Warning: strange to see --search with --noabletosearch, an error can happen\n" ) ; 7968 @msgs = $imap->search( $search_cmd ) ; 7969 return( @msgs ) ; 7970 } 7971 7972 # we are here only if $maxage or $minage is defined 7973 my( @max, @min, $maxage_epoch, $minage_epoch ) ; 7974 if ( defined $maxage ) { $maxage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ; } 7975 if ( defined $minage ) { $minage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ; } 7976 foreach my $msg ( @msgs_all ) { 7977 my $idate = $fetch{ $msg }->{'INTERNALDATE'} ; 7978 #myprint( "$idate\n" ) ; 7979 if ( defined $maxage and ( epoch( $idate ) >= $maxage_epoch ) ) { 7980 push @max, $msg ; 7981 } 7982 if ( defined $minage and ( epoch( $idate ) <= $minage_epoch ) ) { 7983 push @min, $msg ; 7984 } 7985 } 7986 @msgs = msgs_from_maxmin( \@max, \@min ) ; 7987 return( @msgs ) ; 7988} 7989 7990sub select_msgs_by_age 7991{ 7992 my( $imap ) = @_ ; 7993 7994 my( @max, @min, @msgs, @inter, @union ) ; 7995 7996 if ( defined $maxage ) { 7997 @max = $imap->sentsince( $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ) ; 7998 } 7999 if ( defined $minage ) { 8000 @min = $imap->sentbefore( $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ) ; 8001 } 8002 8003 @msgs = msgs_from_maxmin( \@max, \@min ) ; 8004 return( @msgs ) ; 8005} 8006 8007sub msgs_from_maxmin 8008{ 8009 my( $max_ref, $min_ref ) = @_ ; 8010 my( @max, @min, @msgs, @inter, @union ) ; 8011 8012 @max = @{ $max_ref } ; 8013 @min = @{ $min_ref } ; 8014 8015 SWITCH: { 8016 unless( defined $minage ) { @msgs = @max ; last SWITCH } ; 8017 unless( defined $maxage ) { @msgs = @min ; last SWITCH } ; 8018 my ( %union, %inter ) ; 8019 foreach my $m ( @min, @max ) { $union{ $m }++ && $inter{ $m }++ } 8020 @inter = sort { $a <=> $b } keys %inter ; 8021 @union = sort { $a <=> $b } keys %union ; 8022 # normal case 8023 if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ; 8024 # just exclude messages between 8025 if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ; 8026 8027 } 8028 return( @msgs ) ; 8029} 8030 8031sub tests_msgs_from_maxmin 8032{ 8033 note( 'Entering tests_msgs_from_maxmin()' ) ; 8034 8035 my @msgs ; 8036 $maxage = $NUMBER_200 ; 8037 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; 8038 ok( 0 == compare_lists( [ '1', '2' ], \@msgs ), 'msgs_from_maxmin: maxage++' ) ; 8039 $minage = $NUMBER_100 ; 8040 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; 8041 ok( 0 == compare_lists( [ '2' ], \@msgs ), 'msgs_from_maxmin: -maxage++minage-' ) ; 8042 $minage = $NUMBER_300 ; 8043 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; 8044 ok( 0 == compare_lists( [ '1', '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++maxage-minage++' ) ; 8045 $maxage = undef ; 8046 @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; 8047 ok( 0 == compare_lists( [ '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++minage-' ) ; 8048 8049 note( 'Leaving tests_msgs_from_maxmin()' ) ; 8050 return ; 8051} 8052 8053sub tests_info_date_from_uid 8054{ 8055 note( 'Entering tests_info_date_from_uid()' ) ; 8056 note( 'Leaving tests_info_date_from_uid()' ) ; 8057 8058 return ; 8059} 8060 8061sub info_date_from_uid 8062{ 8063 8064 #my $first_uid = $msgs_all[ 0 ] ; 8065 #my $first_idate = $fetch{ $first_uid }->{'INTERNALDATE'} ; 8066 #my $first_epoch = epoch( $first_idate ) ; 8067 #my $first_days = ( $timestart_int - $first_epoch ) / $NB_SECONDS_IN_A_DAY ; 8068 #myprint( "\nOldest msg has UID $first_uid INTERNALDATE $first_idate EPOCH $first_epoch DAYS AGO $first_days\n" ) ; 8069} 8070 8071 8072sub lastuid 8073{ 8074 my $imap = shift ; 8075 my $folder = shift ; 8076 my $lastuid_guess = shift ; 8077 my $lastuid ; 8078 8079 # rfc3501: The only reliable way to identify recent messages is to 8080 # look at message flags to see which have the \Recent flag 8081 # set, or to do a SEARCH RECENT. 8082 # SEARCH RECENT doesn't work this way on courrier. 8083 8084 my @recent_messages ; 8085 # SEARCH RECENT for each transfer can be expensive with a big folder 8086 # Call commented for now 8087 #@recent_messages = $imap->recent( ) ; 8088 #myprint( "Recent: @recent_messages\n" ) ; 8089 8090 my $max_recent ; 8091 $max_recent = max( @recent_messages ) ; 8092 8093 if ( defined $max_recent and ($lastuid_guess <= $max_recent ) ) { 8094 $lastuid = $max_recent ; 8095 }else{ 8096 $lastuid = $lastuid_guess 8097 } 8098 return( $lastuid ) ; 8099} 8100 8101sub size_filtered 8102{ 8103 my( $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @_ ; 8104 8105 $h1_size = 0 if ( ! $h1_size ) ; # null if empty or undef 8106 if ( defined $sync->{ maxsize } and $h1_size > $sync->{ maxsize } ) { 8107 myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $sync->{ maxsize } bytes)\n" ) ; 8108 $sync->{ total_bytes_skipped } += $h1_size; 8109 $sync->{ nb_msg_skipped } += 1; 8110 return( 1 ) ; 8111 } 8112 if ( defined $minsize and $h1_size <= $minsize ) { 8113 myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ; 8114 $sync->{ total_bytes_skipped } += $h1_size; 8115 $sync->{ nb_msg_skipped } += 1; 8116 return( 1 ) ; 8117 } 8118 return( 0 ) ; 8119} 8120 8121sub message_exists 8122{ 8123 my( $imap, $msg ) = @_ ; 8124 return( 1 ) if not $imap->Uid( ) ; 8125 8126 my $search_uid ; 8127 ( $search_uid ) = $imap->search( "UID $msg" ) ; 8128 #myprint( "$search ? $msg\n" ) ; 8129 return( 1 ) if ( $search_uid eq $msg ) ; 8130 return( 0 ) ; 8131} 8132 8133 8134# Globals 8135# $sync->{ total_bytes_skipped } 8136# $sync->{ nb_msg_skipped } 8137# $mysync->{ h1_nb_msg_processed } 8138sub stats_update_skip_message 8139{ 8140 my $mysync = shift ; # to be used 8141 my $h1_size = shift ; 8142 8143 $mysync->{ total_bytes_skipped } += $h1_size ; 8144 $mysync->{ nb_msg_skipped } += 1 ; 8145 $mysync->{ h1_nb_msg_processed } +=1 ; 8146 return ; 8147} 8148 8149sub copy_message 8150{ 8151 # copy 8152 8153 my ( $mysync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ; 8154 ( $mysync->{ debug } or $mysync->{dry}) and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $mysync->{dry_message}\n" ) ; 8155 8156 my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ; 8157 my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ; 8158 my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ; 8159 8160 8161 if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) { 8162 $mysync->{ h1_nb_msg_processed } +=1 ; 8163 return ; 8164 } 8165 8166 debugsleep( $mysync ) ; 8167 myprint( "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" ) if ( ! $h1_size ) ; 8168 8169 if ( $checkmessageexists and not message_exists( $mysync->{imap1}, $h1_msg ) ) { 8170 stats_update_skip_message( $mysync, $h1_size ) ; 8171 return ; 8172 } 8173 myprint( debugmemory( $mysync, " at C1" ) ) ; 8174 8175 my ( $string, $string_len ) ; 8176 ( $string_len ) = message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ; 8177 8178 myprint( debugmemory( $mysync, " at C2" ) ) ; 8179 8180 # not defined or empty $string 8181 if ( ( not $string ) or ( not $string_len ) ) { 8182 myprint( "- msg $h1_fold/$h1_msg skipped.\n" ) ; 8183 stats_update_skip_message( $mysync, $h1_size ) ; 8184 return ; 8185 } 8186 8187 # Lines too long (or not enough) => do no copy or fix 8188 if ( ( defined $maxlinelength ) or ( defined $minmaxlinelength ) ) { 8189 $string = linelengthstuff( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) ; 8190 if ( not defined $string ) { 8191 stats_update_skip_message( $mysync, $h1_size ) ; 8192 return ; 8193 } 8194 } 8195 8196 my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ; 8197 8198 ( $mysync->{ debug } or $debugflags ) and 8199 myprint( "Host1: flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; 8200 8201 $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ; 8202 8203 ( $mysync->{ debug } or $debugflags ) and 8204 myprint( "Host1: flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; 8205 8206 $h1_date = undef if ( $h1_date eq q{} ) ; 8207 8208 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 ) ; 8209 8210 8211 8212 if ( $new_id and $syncflagsaftercopy ) { 8213 sync_flags_after_copy( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id, $permanentflags2 ) ; 8214 } 8215 8216 myprint( debugmemory( $mysync, " at C3" ) ) ; 8217 8218 return $new_id ; 8219} 8220 8221 8222 8223sub linelengthstuff 8224{ 8225 my( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) = @_ ; 8226 my $maxlinelength_string = max_line_length( $string ) ; 8227 $debugmaxlinelength and myprint( "msg $h1_fold/$h1_msg maxlinelength: $maxlinelength_string\n" ) ; 8228 8229 if ( ( defined $minmaxlinelength ) and ( $maxlinelength_string <= $minmaxlinelength ) ) { 8230 my $subject = subject( $string ) ; 8231 $debugdev and myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " 8232 . "(Subject:[$subject]) (max line length under minmaxlinelength $minmaxlinelength bytes)\n" ) ; 8233 return ; 8234 } 8235 8236 if ( ( defined $maxlinelength ) and ( $maxlinelength_string > $maxlinelength ) ) { 8237 my $subject = subject( $string ) ; 8238 if ( $maxlinelengthcmd ) { 8239 $string = pipemess( $string, $maxlinelengthcmd ) ; 8240 # string undef means something was bad. 8241 if ( not ( defined $string ) ) { 8242 myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] " 8243 . "(Subject:[$subject]) could not be successfully transformed by --maxlinelengthcmd option\n" ) ; 8244 return ; 8245 }else{ 8246 return $string ; 8247 } 8248 } 8249 myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " 8250 . "(Subject:[$subject]) (line length exceeds maxlinelength $maxlinelength bytes)\n" ) ; 8251 return ; 8252 } 8253 return $string ; 8254} 8255 8256 8257sub message_for_host2 8258{ 8259 8260# global variable list: 8261# @skipmess 8262# @regexmess 8263# @pipemess 8264# $debugcontent 8265# $debug 8266# 8267# API current 8268# 8269# at failure: 8270# * return nothing ( will then be undef or () ) 8271# * $string_ref content is undef or empty 8272# at success: 8273# * return string length ($string_ref content length) 8274# * $string_ref content filled with message 8275 8276# API future 8277# 8278# 8279 my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) = @_ ; 8280 8281 # abort when missing a parameter 8282 if ( ( ! $mysync ) or ( ! $h1_msg ) or ( ! $h1_fold ) or ( ! defined $h1_size ) 8283 or ( ! defined $h1_flags) or ( ! defined $h1_idate ) 8284 or ( ! $h1_fir_ref) or ( ! $string_ref ) ) 8285 { 8286 return ; 8287 } 8288 8289 myprint( debugmemory( $mysync, " at M1" ) ) ; 8290 8291 8292 my $string_ok = $mysync->{imap1}->message_to_file( $string_ref, $h1_msg ) ; 8293 8294 myprint( debugmemory( $mysync, " at M2" ) ) ; 8295 8296 my $string_len = length_ref( $string_ref ) ; 8297 8298 8299 unless ( defined $string_ok and $string_len ) { 8300 # undef or 0 length 8301 my $error = join q{}, 8302 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] could not be fetched: ", 8303 $mysync->{imap1}->LastError || q{}, "\n" ; 8304 errors_incr( $mysync, $error ) ; 8305 $mysync->{ h1_nb_msg_processed } +=1 ; 8306 return ; 8307 } 8308 8309 if ( @skipmess ) { 8310 my $match = skipmess( ${ $string_ref } ) ; 8311 # string undef means the eval regex was bad. 8312 if ( not ( defined $match ) ) { 8313 myprint( 8314 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" 8315 . " could not be skipped by --skipmess option, bad regex\n" ) ; 8316 return ; 8317 } 8318 if ( $match ) { 8319 my $subject = subject( ${ $string_ref } ) ; 8320 myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" 8321 . " (Subject:[$subject]) skipped by --skipmess\n" ) ; 8322 return ; 8323 } 8324 } 8325 8326 if ( @regexmess ) { 8327 ${ $string_ref } = regexmess( ${ $string_ref } ) ; 8328 # string undef means the eval regex was bad. 8329 if ( not ( defined ${ $string_ref } ) ) { 8330 myprint( 8331 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" 8332 . " could not be transformed by --regexmess\n" ) ; 8333 return ; 8334 } 8335 } 8336 8337 if ( @pipemess ) { 8338 ${ $string_ref } = pipemess( ${ $string_ref }, @pipemess ) ; 8339 # string undef means something was bad. 8340 if ( not ( defined ${ $string_ref } ) ) { 8341 myprint( 8342 "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" 8343 . " could not be successfully transformed by --pipemess option\n" ) ; 8344 return ; 8345 } 8346 } 8347 8348 if ( $mysync->{addheader} and defined $h1_fir_ref->{$h1_msg}->{'NO_HEADER'} ) { 8349 my $header = add_header( $h1_msg ) ; 8350 $mysync->{ debug } and myprint( "msg $h1_fold/$h1_msg adding custom header [$header]\n" ) ; 8351 ${ $string_ref } = $header . "\r\n" . ${ $string_ref } ; 8352 } 8353 8354 if ( ( defined $mysync->{ truncmess } ) and is_an_integer( $mysync->{ truncmess } ) ) 8355 { 8356 ${ $string_ref } = truncmess( ${ $string_ref }, $mysync->{ truncmess } ) ; 8357 } 8358 8359 $string_len = length_ref( $string_ref ) ; 8360 8361 $debugcontent and myprint( 8362 q{=} x $STD_CHAR_PER_LINE, "\n", 8363 "F message content begin next line ($string_len characters long)\n", 8364 ${ $string_ref }, 8365 "\nF message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n" ) ; 8366 8367 myprint( debugmemory( $mysync, " at M3" ) ) ; 8368 8369 return $string_len ; 8370} 8371 8372sub tests_truncmess 8373{ 8374 note( 'Entering tests_truncmess()' ) ; 8375 8376 is( undef, truncmess( ), 'truncmess: no args => undef' ) ; 8377 is( 'abc', truncmess( 'abc' ), 'truncmess: abc => abc' ) ; 8378 is( 'ab', truncmess( 'abc', 2 ), 'truncmess: abc 2 => ab' ) ; 8379 is( 'abc', truncmess( 'abc', 3 ), 'truncmess: abc 3 => abc' ) ; 8380 is( 'abc', truncmess( 'abc', 4 ), 'truncmess: abc 4 => abc' ) ; 8381 is( '12345', truncmess( "123456789\n", 5 ), 'truncmess: "123456789\n", 5 => 12345' ) ; 8382 is( "123456789\n" x 5000, truncmess( "123456789\n" x 100000, 50000 ), 'truncmess: "123456789\n" x 100000, 50000 => "123456789\n" x 5000' ) ; 8383 note( 'Leaving tests_truncmess()' ) ; 8384 return ; 8385} 8386 8387sub truncmess 8388{ 8389 my $string = shift ; 8390 my $length = shift ; 8391 8392 if ( not defined $string ) { return ; } 8393 if ( not defined $length ) { return $string ; } 8394 8395 $string = substr $string, 0, $length ; 8396 return $string ; 8397} 8398 8399sub tests_message_for_host2 8400{ 8401 note( 'Entering tests_message_for_host2()' ) ; 8402 8403 8404 my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) ; 8405 8406 is( undef, message_for_host2( ), q{message_for_host2: no args} ) ; 8407 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} ) ; 8408 8409 require_ok( "Test::MockObject" ) ; 8410 my $imapT = Test::MockObject->new( ) ; 8411 $mysync->{imap1} = $imapT ; 8412 my $string ; 8413 8414 $h1_msg = 1 ; 8415 $h1_fold = 'FoldFoo'; 8416 $h1_size = 9 ; 8417 $h1_flags = '' ; 8418 $h1_idate = '10-Jul-2015 09:00:00 +0200' ; 8419 $h1_fir_ref = {} ; 8420 $string_ref = \$string ; 8421 $imapT->mock( 'message_to_file', 8422 sub { 8423 my ( $imap, $mystring_ref, $msg ) = @_ ; 8424 ${$mystring_ref} = 'blablabla' ; 8425 return length ${$mystring_ref} ; 8426 } 8427 ) ; 8428 is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), 8429 q{message_for_host2: msg 1 == "blablabla", length} ) ; 8430 is( 'blablabla', $string, q{message_for_host2: msg 1 == "blablabla", value} ) ; 8431 8432 # so far so good 8433 # now the --pipemess stuff 8434 8435 SKIP: { 8436 Readonly my $NB_WIN_tests_message_for_host2 => 0 ; 8437 skip( 'Not on MSWin32', $NB_WIN_tests_message_for_host2 ) if ('MSWin32' ne $OSNAME) ; 8438 # Windows 8439 # "type" command does not accept redirection of STDIN with < 8440 # "sort" does 8441 8442 } ; 8443 8444 SKIP: { 8445 Readonly my $NB_UNX_tests_message_for_host2 => 6 ; 8446 skip( 'Not on Unix', $NB_UNX_tests_message_for_host2 ) if ('MSWin32' eq $OSNAME) ; 8447 # Unix 8448 8449 # no change by cat 8450 @pipemess = ( 'cat' ) ; 8451 is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), 8452 q{message_for_host2: --pipemess 'cat', length} ) ; 8453 is( 'blablabla', $string, q{message_for_host2: --pipemess 'cat', value} ) ; 8454 8455 8456 # failure by false 8457 @pipemess = ( 'false' ) ; 8458 is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), 8459 q{message_for_host2: --pipemess 'false', length} ) ; 8460 is( undef, $string, q{message_for_host2: --pipemess 'false', value} ) ; 8461 8462 # failure by true since no output 8463 @pipemess = ( 'true' ) ; 8464 is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), 8465 q{message_for_host2: --pipemess 'true', length} ) ; 8466 is( undef, $string, q{message_for_host2: --pipemess 'true', value} ) ; 8467 } 8468 8469 note( 'Leaving tests_message_for_host2()' ) ; 8470 return ; 8471} 8472 8473sub tests_labels_remove_subfolder1 8474{ 8475 note( 'Entering tests_labels_remove_subfolder1()' ) ; 8476 is( undef, labels_remove_subfolder1( ), 'labels_remove_subfolder1: no parameters => undef' ) ; 8477 is( 'Blabla', labels_remove_subfolder1( 'Blabla' ), 'labels_remove_subfolder1: one parameter Blabla => Blabla' ) ; 8478 is( 'Blan blue', labels_remove_subfolder1( 'Blan blue' ), 'labels_remove_subfolder1: one parameter Blan blue => Blan blue' ) ; 8479 is( '\Bla "Blan blan" Blabla', labels_remove_subfolder1( '\Bla "Blan blan" Blabla' ), 8480 'labels_remove_subfolder1: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ; 8481 8482 is( 'Bla', labels_remove_subfolder1( 'Subf/Bla', 'Subf' ), 'labels_remove_subfolder1: Subf/Bla Subf => "Bla"' ) ; 8483 8484 8485 is( '"\\\\Bla"', labels_remove_subfolder1( '"\\\\Bla"', 'Subf' ), 'labels_remove_subfolder1: "\\\\Bla" Subf => "\\\\Bla"' ) ; 8486 8487 is( 'Bla Kii', labels_remove_subfolder1( 'Subf/Bla Subf/Kii', 'Subf' ), 8488 'labels_remove_subfolder1: Subf/Bla Subf/Kii, Subf => "Bla" "Kii"' ) ; 8489 8490 is( '"\\\\Bla" Kii', labels_remove_subfolder1( '"\\\\Bla" Subf/Kii', 'Subf' ), 8491 'labels_remove_subfolder1: "\\\\Bla" Subf/Kii Subf => "\\\\Bla" Kii' ) ; 8492 8493 is( '"Blan blan"', labels_remove_subfolder1( '"Subf/Blan blan"', 'Subf' ), 8494 'labels_remove_subfolder1: "Subf/Blan blan" Subf => "Blan blan"' ) ; 8495 8496 is( '"\\\\Loo" "Blan blan" Kii', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii', 'Subf' ), 8497 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii + Subf => "\\\\Loo" "Blan blan" Kii' ) ; 8498 8499 is( '"\\\\Inbox"', labels_remove_subfolder1( 'Subf/INBOX', 'Subf' ), 8500 'labels_remove_subfolder1: Subf/INBOX + Subf => "\\\\Inbox"' ) ; 8501 8502 is( '"\\\\Loo" "Blan blan" Kii "\\\\Inbox"', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX', 'Subf' ), 8503 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX + Subf => "\\\\Loo" "Blan blan" Kii "\\\\Inbox"' ) ; 8504 8505 8506 note( 'Leaving tests_labels_remove_subfolder1()' ) ; 8507 return ; 8508} 8509 8510 8511 8512sub labels_remove_subfolder1 8513{ 8514 my $labels = shift ; 8515 my $subfolder1 = shift ; 8516 8517 if ( not defined $labels ) { return ; } 8518 if ( not defined $subfolder1 ) { return $labels ; } 8519 8520 my @labels = quotewords('\s+', 1, $labels ) ; 8521 #myprint( "@labels\n" ) ; 8522 my @labels_subfolder2 ; 8523 8524 foreach my $label ( @labels ) 8525 { 8526 if ( $label =~ m{zzzzzzzzzz} ) 8527 { 8528 # \Seen \Deleted ... stay the same 8529 push @labels_subfolder2, $label ; 8530 } 8531 else 8532 { 8533 # Remove surrounding quotes if any, to add them again in case of space 8534 $label = join( '', quotewords('\s+', 0, $label ) ) ; 8535 $label =~ s{$subfolder1/?}{} ; 8536 if ( 'INBOX' eq $label ) 8537 { 8538 push @labels_subfolder2, q{"\\\\Inbox"} ; 8539 } 8540 elsif ( $label =~ m{\\} ) 8541 { 8542 push @labels_subfolder2, qq{"\\$label"} ; 8543 } 8544 elsif ( $label =~ m{ } ) 8545 { 8546 push @labels_subfolder2, qq{"$label"} ; 8547 } 8548 else 8549 { 8550 push @labels_subfolder2, $label ; 8551 } 8552 } 8553 } 8554 8555 my $labels_subfolder2 = join( ' ', sort uniq( @labels_subfolder2 ) ) ; 8556 8557 return $labels_subfolder2 ; 8558} 8559 8560sub tests_labels_remove_special 8561{ 8562 note( 'Entering tests_labels_remove_special()' ) ; 8563 8564 is( undef, labels_remove_special( ), 'labels_remove_special: no parameters => undef' ) ; 8565 is( '', labels_remove_special( '' ), 'labels_remove_special: empty string => empty string' ) ; 8566 is( '', labels_remove_special( '"\\\\Inbox"' ), 'labels_remove_special:"\\\\Inbox" => empty string' ) ; 8567 is( '', labels_remove_special( '"\\\\Inbox" "\\\\Starred"' ), 'labels_remove_special:"\\\\Inbox" "\\\\Starred" => empty string' ) ; 8568 is( 'Bar Foo', labels_remove_special( 'Foo Bar' ), 'labels_remove_special:Foo Bar => Bar Foo' ) ; 8569 is( 'Bar Foo', labels_remove_special( 'Foo Bar "\\\\Inbox"' ), 'labels_remove_special:Foo Bar "\\\\Inbox" => Bar Foo' ) ; 8570 note( 'Leaving tests_labels_remove_special()' ) ; 8571 return ; 8572} 8573 8574 8575 8576 8577sub labels_remove_special 8578{ 8579 my $labels = shift ; 8580 8581 if ( not defined $labels ) { return ; } 8582 8583 my @labels = quotewords('\s+', 1, $labels ) ; 8584 myprint( "labels before remove_non_folded: @labels\n" ) ; 8585 my @labels_remove_special ; 8586 8587 foreach my $label ( @labels ) 8588 { 8589 if ( $label =~ m{^\"\\\\} ) 8590 { 8591 # not kept 8592 } 8593 else 8594 { 8595 push @labels_remove_special, $label ; 8596 } 8597 } 8598 8599 my $labels_remove_special = join( ' ', sort @labels_remove_special ) ; 8600 8601 return $labels_remove_special ; 8602} 8603 8604 8605sub tests_labels_add_subfolder2 8606{ 8607 note( 'Entering tests_labels_add_subfolder2()' ) ; 8608 is( undef, labels_add_subfolder2( ), 'labels_add_subfolder2: no parameters => undef' ) ; 8609 is( 'Blabla', labels_add_subfolder2( 'Blabla' ), 'labels_add_subfolder2: one parameter Blabla => Blabla' ) ; 8610 is( 'Blan blue', labels_add_subfolder2( 'Blan blue' ), 'labels_add_subfolder2: one parameter Blan blue => Blan blue' ) ; 8611 is( '\Bla "Blan blan" Blabla', labels_add_subfolder2( '\Bla "Blan blan" Blabla' ), 8612 'labels_add_subfolder2: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ; 8613 8614 is( 'Subf/Bla', labels_add_subfolder2( 'Bla', 'Subf' ), 'labels_add_subfolder2: Bla Subf => "Subf/Bla"' ) ; 8615 8616 8617 is( 'Subf/\Bla', labels_add_subfolder2( '\\\\Bla', 'Subf' ), 'labels_add_subfolder2: \Bla Subf => \Bla' ) ; 8618 8619 is( 'Subf/Bla Subf/Kii', labels_add_subfolder2( 'Bla Kii', 'Subf' ), 8620 'labels_add_subfolder2: Bla Kii Subf => "Subf/Bla" "Subf/Kii"' ) ; 8621 8622 is( 'Subf/Kii Subf/\Bla', labels_add_subfolder2( '\\\\Bla Kii', 'Subf' ), 8623 'labels_add_subfolder2: \Bla Kii Subf => \Bla Subf/Kii' ) ; 8624 8625 is( '"Subf/Blan blan"', labels_add_subfolder2( '"Blan blan"', 'Subf' ), 8626 'labels_add_subfolder2: "Blan blan" Subf => "Subf/Blan blan"' ) ; 8627 8628 is( '"Subf/Blan blan" Subf/Kii Subf/\Loo', labels_add_subfolder2( '\\\\Loo "Blan blan" Kii', 'Subf' ), 8629 'labels_add_subfolder2: \Loo "Blan blan" Kii + Subf => "Subf/Blan blan" Subf/Kii Subf/\Loo' ) ; 8630 8631 # "\\Inbox" is special, add to subfolder INBOX also because Gmail will but ... 8632 is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox"', 'Subf' ), 8633 'labels_add_subfolder2: "\\\\Inbox" Subf => "Subf/\\\\Inbox" Subf/INBOX' ) ; 8634 8635 # but not with INBOX folder 8636 is( '"Subf/\\\\Inbox"', labels_add_subfolder2( '"\\\\Inbox"', 'Subf', 'INBOX' ), 8637 'labels_add_subfolder2: "\\\\Inbox" Subf INBOX => "Subf/\\\\Inbox"' ) ; 8638 8639 # two times => one time 8640 is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox" "\\\\Inbox"', 'Subf' ), 8641 'labels_add_subfolder2: "\\\\Inbox" "\\\\Inbox" Subf => "Subf/\\\\Inbox"' ) ; 8642 8643 is( '"Subf/\\\\Starred"', labels_add_subfolder2( '"\\\\Starred"', 'Subf' ), 8644 'labels_add_subfolder2: "\\\\Starred" Subf => "Subf/\\\\Starred"' ) ; 8645 8646 note( 'Leaving tests_labels_add_subfolder2()' ) ; 8647 return ; 8648} 8649 8650sub labels_add_subfolder2 8651{ 8652 my $labels = shift ; 8653 my $subfolder2 = shift ; 8654 my $h1_folder = shift || q{} ; 8655 8656 if ( not defined $labels ) { return ; } 8657 if ( not defined $subfolder2 ) { return $labels ; } 8658 8659 # Isn't it messy? 8660 if ( 'INBOX' eq $h1_folder ) 8661 { 8662 $labels .= ' "\\\\Inbox"' ; 8663 } 8664 8665 my @labels = uniq( quotewords('\s+', 1, $labels ) ) ; 8666 myprint( "labels before subfolder2: @labels\n" ) ; 8667 my @labels_subfolder2 ; 8668 8669 8670 foreach my $label ( @labels ) 8671 { 8672 # Isn't it more messy? 8673 if ( ( q{"\\\\Inbox"} eq $label ) and ( 'INBOX' ne $h1_folder ) ) 8674 { 8675 if ( $subfolder2 =~ m{ } ) 8676 { 8677 push @labels_subfolder2, qq{"$subfolder2/INBOX"} ; 8678 } 8679 else 8680 { 8681 push @labels_subfolder2, "$subfolder2/INBOX" ; 8682 } 8683 } 8684 if ( $label =~ m{^\"\\\\} ) 8685 { 8686 # \Seen \Deleted ... stay the same 8687 #push @labels_subfolder2, $label ; 8688 # Remove surrounding quotes if any, to add them again 8689 $label = join( '', quotewords('\s+', 0, $label ) ) ; 8690 push @labels_subfolder2, qq{"$subfolder2/\\$label"} ; 8691 8692 } 8693 else 8694 { 8695 # Remove surrounding quotes if any, to add them again in case of space 8696 $label = join( '', quotewords('\s+', 0, $label ) ) ; 8697 if ( $label =~ m{ } ) 8698 { 8699 push @labels_subfolder2, qq{"$subfolder2/$label"} ; 8700 } 8701 else 8702 { 8703 push @labels_subfolder2, "$subfolder2/$label" ; 8704 } 8705 } 8706 } 8707 8708 my $labels_subfolder2 = join( ' ', sort @labels_subfolder2 ) ; 8709 8710 return $labels_subfolder2 ; 8711} 8712 8713sub tests_labels 8714{ 8715 note( 'Entering tests_labels()' ) ; 8716 8717 is( undef, labels( ), 'labels: no parameters => undef' ) ; 8718 is( undef, labels( undef ), 'labels: undef => undef' ) ; 8719 require_ok( "Test::MockObject" ) ; 8720 my $myimap = Test::MockObject->new( ) ; 8721 8722 $myimap->mock( 'fetch_hash', 8723 sub { 8724 return( 8725 { '1' => { 8726 'X-GM-LABELS' => '\Seen Blabla' 8727 } 8728 } 8729 ) ; 8730 } 8731 ) ; 8732 $myimap->mock( 'Debug' , sub { } ) ; 8733 $myimap->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one 8734 8735 is( undef, labels( $myimap ), 'labels: one parameter => undef' ) ; 8736 is( '\Seen Blabla', labels( $myimap, '1' ), 'labels: $mysync UID_1 => \Seen Blabla' ) ; 8737 8738 note( 'Leaving tests_labels()' ) ; 8739 return ; 8740} 8741 8742sub labels 8743{ 8744 my ( $myimap, $uid ) = @ARG ; 8745 8746 if ( not all_defined( $myimap, $uid ) ) { 8747 return ; 8748 } 8749 8750 my $hash = $myimap->fetch_hash( [ $uid ], 'X-GM-LABELS' ) ; 8751 8752 my $labels = $hash->{ $uid }->{ 'X-GM-LABELS' } ; 8753 #$labels = $myimap->Unescape( $labels ) ; 8754 return $labels ; 8755} 8756 8757sub tests_synclabels 8758{ 8759 note( 'Entering tests_synclabels()' ) ; 8760 8761 is( undef, synclabels( ), 'synclabels: no parameters => undef' ) ; 8762 is( undef, synclabels( undef ), 'synclabels: undef => undef' ) ; 8763 my $mysync ; 8764 is( undef, synclabels( $mysync ), 'synclabels: var undef => undef' ) ; 8765 8766 require_ok( "Test::MockObject" ) ; 8767 $mysync = {} ; 8768 8769 my $myimap1 = Test::MockObject->new( ) ; 8770 $myimap1->mock( 'fetch_hash', 8771 sub { 8772 return( 8773 { '1' => { 8774 'X-GM-LABELS' => '\Seen Blabla' 8775 } 8776 } 8777 ) ; 8778 } 8779 ) ; 8780 $myimap1->mock( 'Debug', sub { } ) ; 8781 $myimap1->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one 8782 8783 my $myimap2 = Test::MockObject->new( ) ; 8784 8785 $myimap2->mock( 'store', 8786 sub { 8787 return 1 ; 8788 } 8789 ) ; 8790 8791 8792 $mysync->{imap1} = $myimap1 ; 8793 $mysync->{imap2} = $myimap2 ; 8794 8795 is( undef, synclabels( $mysync ), 'synclabels: fresh $mysync => undef' ) ; 8796 8797 is( undef, synclabels( $mysync, '1' ), 'synclabels: $mysync UID_1 alone => undef' ) ; 8798 is( 1, synclabels( $mysync, '1', '2' ), 'synclabels: $mysync UID_1 UID_2 => 1' ) ; 8799 8800 note( 'Leaving tests_synclabels()' ) ; 8801 return ; 8802} 8803 8804 8805sub synclabels 8806{ 8807 my( $mysync, $uid1, $uid2 ) = @ARG ; 8808 8809 if ( not all_defined( $mysync, $uid1, $uid2 ) ) { 8810 return ; 8811 } 8812 my $myimap1 = $mysync->{ 'imap1' } || return ; 8813 my $myimap2 = $mysync->{ 'imap2' } || return ; 8814 8815 $mysync->{debuglabels} and $myimap1->Debug( 1 ) ; 8816 my $labels1 = labels( $myimap1, $uid1 ) ; 8817 $mysync->{debuglabels} and $myimap1->Debug( 0 ) ; 8818 $mysync->{debuglabels} and myprint( "Host1 labels: $labels1\n" ) ; 8819 8820 8821 8822 if ( $mysync->{ subfolder1 } and $labels1 ) 8823 { 8824 $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ; 8825 $mysync->{debuglabels} and myprint( "Host1 labels with subfolder1: $labels1\n" ) ; 8826 } 8827 8828 if ( $mysync->{ subfolder2 } and $labels1 ) 8829 { 8830 $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 } ) ; 8831 $mysync->{debuglabels} and myprint( "Host1 labels with subfolder2: $labels1\n" ) ; 8832 } 8833 8834 my $store ; 8835 if ( $labels1 and not $mysync->{ dry } ) 8836 { 8837 $mysync->{ debuglabels } and $myimap2->Debug( 1 ) ; 8838 $store = $myimap2->store( $uid2, "X-GM-LABELS ($labels1)" ) ; 8839 $mysync->{ debuglabels } and $myimap2->Debug( 0 ) ; 8840 } 8841 return $store ; 8842} 8843 8844 8845sub tests_resynclabels 8846{ 8847 note( 'Entering tests_resynclabels()' ) ; 8848 8849 is( undef, resynclabels( ), 'resynclabels: no parameters => undef' ) ; 8850 is( undef, resynclabels( undef ), 'resynclabels: undef => undef' ) ; 8851 my $mysync ; 8852 is( undef, resynclabels( $mysync ), 'resynclabels: var undef => undef' ) ; 8853 8854 my ( $h1_fir_ref, $h2_fir_ref ) ; 8855 8856 $mysync->{ debuglabels } = 1 ; 8857 $h1_fir_ref->{ 11 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ; 8858 $h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ; 8859 8860 # labels are equal 8861 is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ), 8862 'resynclabels: $mysync UID_1 UID_2 labels are equal => 1' ) ; 8863 8864 # labels are different 8865 $h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Zuu' ; 8866 require_ok( "Test::MockObject" ) ; 8867 my $myimap2 = Test::MockObject->new( ) ; 8868 $myimap2->mock( 'store', 8869 sub { 8870 return 1 ; 8871 } 8872 ) ; 8873 $myimap2->mock( 'Debug', sub { } ) ; 8874 $mysync->{imap2} = $myimap2 ; 8875 8876 is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ), 8877 'resynclabels: $mysync UID_1 UID_2 labels are not equal => store => 1' ) ; 8878 8879 note( 'Leaving tests_resynclabels()' ) ; 8880 return ; 8881} 8882 8883 8884 8885sub resynclabels 8886{ 8887 my( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref, $h1_folder ) = @ARG ; 8888 8889 if ( not all_defined( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref ) ) { 8890 return ; 8891 } 8892 8893 my $labels1 = $h1_fir_ref->{ $uid1 }->{ 'X-GM-LABELS' } || q{} ; 8894 my $labels2 = $h2_fir_ref->{ $uid2 }->{ 'X-GM-LABELS' } || q{} ; 8895 8896 if ( $mysync->{ subfolder1 } and $labels1 ) 8897 { 8898 $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ; 8899 } 8900 8901 if ( $mysync->{ subfolder2 } and $labels1 ) 8902 { 8903 $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 }, $h1_folder ) ; 8904 $labels2 = labels_remove_special( $labels2 ) ; 8905 } 8906 $mysync->{ debuglabels } and myprint( "Host1 labels fixed: $labels1\n" ) ; 8907 $mysync->{ debuglabels } and myprint( "Host2 labels : $labels2\n" ) ; 8908 8909 my $store ; 8910 if ( $labels1 eq $labels2 ) 8911 { 8912 # no sync needed 8913 $mysync->{ debuglabels } and myprint( "Labels are already equal\n" ) ; 8914 return 1 ; 8915 } 8916 elsif ( not $mysync->{ dry } ) 8917 { 8918 # sync needed 8919 $mysync->{debuglabels} and $mysync->{imap2}->Debug( 1 ) ; 8920 $store = $mysync->{imap2}->store( $uid2, "X-GM-LABELS ($labels1)" ) ; 8921 $mysync->{debuglabels} and $mysync->{imap2}->Debug( 0 ) ; 8922 } 8923 8924 return $store ; 8925} 8926 8927sub tests_uniq 8928{ 8929 note( 'Entering tests_uniq()' ) ; 8930 8931 is( 0, uniq( ), 'uniq: undef => 0' ) ; 8932 is_deeply( [ 'one' ], [ uniq( 'one' ) ], 'uniq: one => one' ) ; 8933 is_deeply( [ 'one' ], [ uniq( 'one', 'one' ) ], 'uniq: one one => one' ) ; 8934 is_deeply( [ 'one', 'two' ], [ uniq( 'one', 'one', 'two', 'one', 'two' ) ], 'uniq: one one two one two => one two' ) ; 8935 note( 'Leaving tests_uniq()' ) ; 8936 return ; 8937} 8938 8939sub uniq 8940{ 8941 my @list = @ARG ; 8942 my %seen = ( ) ; 8943 my @uniq = ( ) ; 8944 foreach my $item ( @list ) { 8945 if ( ! $seen{ $item } ) { 8946 $seen{ $item } = 1 ; 8947 push( @uniq, $item ) ; 8948 } 8949 } 8950 return @uniq ; 8951} 8952 8953 8954sub length_ref 8955{ 8956 my $string_ref = shift ; 8957 my $string_len = defined ${ $string_ref } ? length( ${ $string_ref } ) : q{} ; # length or empty string 8958 return $string_len ; 8959} 8960 8961sub tests_length_ref 8962{ 8963 note( 'Entering tests_length_ref()' ) ; 8964 8965 my $notdefined ; 8966 is( q{}, length_ref( \$notdefined ), q{length_ref: value not defined} ) ; 8967 my $notref ; 8968 is( q{}, length_ref( $notref ), q{length_ref: param not a ref} ) ; 8969 8970 my $lala = 'lala' ; 8971 is( 4, length_ref( \$lala ), q{length_ref: lala length == 4} ) ; 8972 is( 4, length_ref( \'lili' ), q{length_ref: lili length == 4} ) ; 8973 8974 note( 'Leaving tests_length_ref()' ) ; 8975 return ; 8976} 8977 8978sub date_for_host2 8979{ 8980 my( $h1_msg, $h1_idate ) = @_ ; 8981 8982 my $h1_date = q{} ; 8983 8984 if ( $syncinternaldates ) { 8985 $h1_date = $h1_idate ; 8986 $sync->{ debug } and myprint( "internal date from host1: [$h1_date]\n" ) ; 8987 $h1_date = good_date( $h1_date ) ; 8988 $sync->{ debug } and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ; 8989 } 8990 8991 if ( $idatefromheader ) { 8992 $h1_date = $sync->{imap1}->get_header( $h1_msg, 'Date' ) ; 8993 $sync->{ debug } and myprint( "header date from host1: [$h1_date]\n" ) ; 8994 $h1_date = good_date( $h1_date ) ; 8995 $sync->{ debug } and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ; 8996 } 8997 8998 return( $h1_date ) ; 8999} 9000 9001sub flags_for_host2 9002{ 9003 my( $h1_flags, $permanentflags2 ) = @_ ; 9004 # RFC 2060: This flag can not be altered by any client 9005 $h1_flags =~ s@\\Recent\s?@@xgi ; 9006 my $h1_flags_re ; 9007 if ( @regexflag and defined( $h1_flags_re = flags_regex( $h1_flags ) ) ) { 9008 $h1_flags = $h1_flags_re ; 9009 } 9010 $h1_flags = flagscase( $h1_flags ) if $flagscase ; 9011 $h1_flags = flags_filter( $h1_flags, $permanentflags2) if ( $permanentflags2 and $filterflags ) ; 9012 9013 return( $h1_flags ) ; 9014} 9015 9016sub subject 9017{ 9018 my $string = shift ; 9019 my $subject = q{} ; 9020 9021 my $header = extract_header( $string ) ; 9022 9023 if( $header =~ m/^Subject:\s*([^\n\r]*)\r?$/msx ) { 9024 #myprint( "MMM[$1]\n" ) ; 9025 $subject = $1 ; 9026 } 9027 return( $subject ) ; 9028} 9029 9030sub tests_subject 9031{ 9032 note( 'Entering tests_subject()' ) ; 9033 9034 ok( q{} eq subject( q{} ), 'subject: null') ; 9035 ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'subject: toto le hero') ; 9036 ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'subject: toto le hero blank') ; 9037 ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'subject: toto le hero\r\n') ; 9038 9039 my $MESS ; 9040 $MESS = <<'EOF'; 9041From: lalala 9042Subject: toto le hero 9043Date: zzzzzz 9044 9045Boogie boogie 9046EOF 9047 ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 2') ; 9048 9049 $MESS = <<'EOF'; 9050Subject: toto le hero 9051From: lalala 9052Date: zzzzzz 9053 9054Boogie boogie 9055EOF 9056 ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 3') ; 9057 9058 9059 $MESS = <<'EOF'; 9060From: lalala 9061Subject: cuicui 9062Date: zzzzzz 9063 9064Subject: toto le hero 9065EOF 9066 ok( 'cuicui' eq subject( $MESS ), 'subject: cuicui') ; 9067 9068 $MESS = <<'EOF'; 9069From: lalala 9070Date: zzzzzz 9071 9072Subject: toto le hero 9073EOF 9074 ok( q{} eq subject( $MESS ), 'subject: null but body could') ; 9075 9076 note( 'Leaving tests_subject()' ) ; 9077 return ; 9078} 9079 9080 9081# GlobVar 9082# $max_msg_size_in_bytes 9083# $h2_uidguess 9084# ... 9085# 9086# 9087sub append_message_on_host2 9088{ 9089 my( $mysync, $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ; 9090 myprint( debugmemory( $mysync, " at A1" ) ) ; 9091 9092 my $new_id ; 9093 if ( ! $mysync->{dry} ) { 9094 $max_msg_size_in_bytes = max( $string_len, $max_msg_size_in_bytes ) ; 9095 $new_id = $mysync->{imap2}->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ; 9096 myprint( debugmemory( $mysync, " at A2" ) ) ; 9097 if ( ! $new_id){ 9098 my $subject = subject( ${ $string_ref } ) ; 9099 my $error_imap = $mysync->{imap2}->LastError || q{} ; 9100 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" ; 9101 errors_incr( $mysync, $error ) ; 9102 $mysync->{ h1_nb_msg_processed } +=1 ; 9103 return ; 9104 } 9105 else{ 9106 # good 9107 # $new_id is an id if the IMAP server has the 9108 # UIDPLUS capability else just a ref 9109 if ( $new_id !~ m{^\d+$}x ) { 9110 $new_id = lastuid( $mysync->{imap2}, $h2_fold, $h2_uidguess ) ; 9111 } 9112 if ( $mysync->{ synclabels } ) { synclabels( $mysync, $h1_msg, $new_id ) } 9113 $h2_uidguess += 1 ; 9114 $mysync->{total_bytes_transferred} += $string_len ; 9115 $mysync->{nb_msg_transferred} += 1 ; 9116 $mysync->{ h1_nb_msg_processed } +=1 ; 9117 9118 my $time_spent = timesince( $mysync->{begin_transfer_time} ) ; 9119 my $rate = bytes_display_string( $mysync->{total_bytes_transferred} / $time_spent ) ; 9120 my $eta = eta( $time_spent, 9121 $mysync->{ h1_nb_msg_processed }, $h1_nb_msg_start, $mysync->{nb_msg_transferred} ) ; 9122 my $amount_transferred = bytes_display_string( $mysync->{total_bytes_transferred} ) ; 9123 myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n", 9124 $h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $mysync->{nb_msg_transferred}/$time_spent, $rate, 9125 $amount_transferred, 9126 $eta ); 9127 sleep_if_needed( $mysync ) ; 9128 if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$}x ) { 9129 $debugcache and myprint( "touch $cache_dir/${h1_msg}_$new_id\n" ) ; 9130 touch( "$cache_dir/${h1_msg}_$new_id" ) 9131 or croak( "Couldn't touch $cache_dir/${h1_msg}_$new_id" ) ; 9132 } 9133 if ( $mysync->{ delete1 } ) { 9134 delete_message_on_host1( $mysync, $h1_fold, $mysync->{ expungeaftereach }, $h1_msg ) ; 9135 } 9136 #myprint( "PRESS ENTER" ) and my $a = <> ; 9137 9138 return( $new_id ) ; 9139 } 9140 } 9141 else{ 9142 $nb_msg_skipped_dry_mode += 1 ; 9143 $mysync->{ h1_nb_msg_processed } +=1 ; 9144 } 9145 9146 return ; 9147} 9148 9149sub tests_sleep_if_needed 9150{ 9151 note( 'Entering tests_sleep_if_needed()' ) ; 9152 9153 is( undef, sleep_if_needed( ), 'sleep_if_needed: no args => undef' ) ; 9154 my $mysync ; 9155 is( undef, sleep_if_needed( $mysync ), 'sleep_if_needed: arg undef => undef' ) ; 9156 9157 $mysync->{maxbytespersecond} = 1000 ; 9158 is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytespersecond only => no sleep => 0' ) ; 9159 $mysync->{begin_transfer_time} = time ; # now 9160 is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: begin_transfer_time now => no sleep => 0' ) ; 9161 $mysync->{begin_transfer_time} = time - 2 ; # 2 s before 9162 is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 0 => no sleep => 0' ) ; 9163 9164 $mysync->{total_bytes_transferred} = 2200 ; 9165 $mysync->{begin_transfer_time} = time - 2 ; # 2 s before 9166 is( '0.20', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2s => sleep 0.2s' ) ; 9167 is( '0', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2+2 == 4s => no sleep' ) ; 9168 9169 $mysync->{maxsleep} = 0.1 ; 9170 $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again 9171 is( '0.10', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 4000 since 2s but maxsleep 0.1s => sleep 0.1s' ) ; 9172 9173 $mysync->{maxbytesafter} = 4000 ; 9174 $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again 9175 is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytesafter == total_bytes_transferred => no sleep => 0' ) ; 9176 9177 note( 'Leaving tests_sleep_if_needed()' ) ; 9178 return ; 9179} 9180 9181 9182sub sleep_if_needed 9183{ 9184 my( $mysync ) = shift ; 9185 9186 if ( ! $mysync ) { 9187 return ; 9188 } 9189 # No need to go further if there is no limit set 9190 if ( not ( $mysync->{maxmessagespersecond} 9191 or $mysync->{maxbytespersecond} ) 9192 ) { 9193 return ; 9194 } 9195 9196 $mysync->{maxsleep} = defined $mysync->{maxsleep} ? $mysync->{maxsleep} : $MAX_SLEEP ; 9197 # Must be positive 9198 $mysync->{maxsleep} = max( 0, $mysync->{maxsleep} ) ; 9199 9200 my $time_spent = timesince( $mysync->{begin_transfer_time} ) ; 9201 my $sleep_max_messages = sleep_max_messages( $mysync->{nb_msg_transferred}, $time_spent, $mysync->{maxmessagespersecond} ) ; 9202 9203 my $maxbytesafter = $mysync->{maxbytesafter} || 0 ; 9204 my $total_bytes_transferred = $mysync->{total_bytes_transferred} || 0 ; 9205 my $total_bytes_to_consider = $total_bytes_transferred - $maxbytesafter ; 9206 9207 #myprint( "maxbytesafter:$maxbytesafter\n" ) ; 9208 #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ; 9209 9210 my $sleep_max_bytes = sleep_max_bytes( $total_bytes_to_consider, $time_spent, $mysync->{maxbytespersecond} ) ; 9211 my $sleep_max = min( $mysync->{maxsleep}, max( $sleep_max_messages, $sleep_max_bytes ) ) ; 9212 $sleep_max = mysprintf( "%.2f", $sleep_max ) ; # round with 2 decimals. 9213 if ( $sleep_max > 0 ) { 9214 myprint( "sleeping $sleep_max s\n" ) ; 9215 sleep $sleep_max ; 9216 # Slept 9217 return $sleep_max ; 9218 } 9219 # No sleep 9220 return 0 ; 9221} 9222 9223sub sleep_max_messages 9224{ 9225 # how long we have to sleep to go under max_messages_per_second 9226 my( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) = @_ ; 9227 if ( ( not defined $maxmessagespersecond ) or $maxmessagespersecond <= 0 ) { return( 0 ) } ; 9228 my $sleep = ( $nb_msg_transferred / $maxmessagespersecond ) - $time_spent ; 9229 # the sleep must be positive 9230 return( max( 0, $sleep ) ) ; 9231} 9232 9233 9234sub tests_sleep_max_messages 9235{ 9236 note( 'Entering tests_sleep_max_messages()' ) ; 9237 9238 ok( 0 == sleep_max_messages( 4, 2, undef ), 'sleep_max_messages: maxmessagespersecond = undef') ; 9239 ok( 0 == sleep_max_messages( 4, 2, 0 ), 'sleep_max_messages: maxmessagespersecond = 0') ; 9240 ok( 0 == sleep_max_messages( 4, 2, $MINUS_ONE ), 'sleep_max_messages: maxmessagespersecond = -1') ; 9241 ok( 0 == sleep_max_messages( 4, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max reached') ; 9242 ok( 2 == sleep_max_messages( 8, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max over') ; 9243 ok( 0 == sleep_max_messages( 2, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max not reached') ; 9244 9245 note( 'Leaving tests_sleep_max_messages()' ) ; 9246 return ; 9247} 9248 9249 9250sub sleep_max_bytes 9251{ 9252 # how long we have to sleep to go under max_bytes_per_second 9253 my( $total_bytes_to_consider, $time_spent, $maxbytespersecond ) = @_ ; 9254 $total_bytes_to_consider ||= 0 ; 9255 $time_spent ||= 0 ; 9256 9257 if ( ( not defined $maxbytespersecond ) or $maxbytespersecond <= 0 ) { return( 0 ) } ; 9258 #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ; 9259 my $sleep = ( $total_bytes_to_consider / $maxbytespersecond ) - $time_spent ; 9260 # the sleep must be positive 9261 return( max( 0, $sleep ) ) ; 9262} 9263 9264 9265sub tests_sleep_max_bytes 9266{ 9267 note( 'Entering tests_sleep_max_bytes()' ) ; 9268 9269 ok( 0 == sleep_max_bytes( 4000, 2, undef ), 'sleep_max_bytes: maxbytespersecond == undef => sleep 0' ) ; 9270 ok( 0 == sleep_max_bytes( 4000, 2, 0 ), 'sleep_max_bytes: maxbytespersecond = 0 => sleep 0') ; 9271 ok( 0 == sleep_max_bytes( 4000, 2, $MINUS_ONE ), 'sleep_max_bytes: maxbytespersecond = -1 => sleep 0') ; 9272 ok( 0 == sleep_max_bytes( 4000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max reached sharp => sleep 0') ; 9273 ok( 2 == sleep_max_bytes( 8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max over => sleep a little') ; 9274 ok( 0 == sleep_max_bytes( -8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ; 9275 ok( 0 == sleep_max_bytes( 2000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ; 9276 ok( 0 == sleep_max_bytes( -2000, 2, 1000 ), 'sleep_max_bytes: maxbytespersecond = 1k max not reached => sleep 0') ; 9277 9278 note( 'Leaving tests_sleep_max_bytes()' ) ; 9279 return ; 9280} 9281 9282 9283sub delete_message_on_host1 9284{ 9285 my( $mysync, $h1_fold, $expunge, @h1_msg ) = @_ ; 9286 if ( ! $mysync->{ delete1 } ) { return ; } 9287 if ( ! @h1_msg ) { return ; } 9288 delete_messages_on_any( 9289 $mysync, 9290 $mysync->{imap1}, 9291 "Host1: $h1_fold", 9292 $expunge, 9293 $split1, 9294 @h1_msg ) ; 9295 return ; 9296} 9297 9298sub tests_operators_and_exclam_precedence 9299{ 9300 note( 'Entering tests_operators_and_exclam_precedence()' ) ; 9301 9302 is( 1, ! 0, 'tests_operators_and_exclam_precedence: ! 0 => 1' ) ; 9303 is( "", ! 1, 'tests_operators_and_exclam_precedence: ! 1 => ""' ) ; 9304 is( 1, not( 0 ), 'tests_operators_and_exclam_precedence: not( 0 ) => 1' ) ; 9305 is( "", not( 1 ), 'tests_operators_and_exclam_precedence: not( 1 ) => ""' ) ; 9306 9307 # I wrote those tests to avoid perlcrit "Mixed high and low-precedence booleans" 9308 # and change sub delete_messages_on_any() but got 4 more warnings... So now commented. 9309 9310 #is( 0, ( ! 0 and 0 ), 'tests_operators_and_exclam_precedence: ! 0 and 0 ) => 0' ) ; 9311 #is( 1, ( ! 0 and 1 ), 'tests_operators_and_exclam_precedence: ! 0 and 1 ) => 1' ) ; 9312 #is( "", ( ! 1 and 0 ), 'tests_operators_and_exclam_precedence: ! 1 and 0 ) => ""' ) ; 9313 #is( "", ( ! 1 and 1 ), 'tests_operators_and_exclam_precedence: ! 1 and 1 ) => ""' ) ; 9314 9315 is( 0, ( ! 0 && 0 ), 'tests_operators_and_exclam_precedence: ! 0 && 0 ) => 0' ) ; 9316 is( 1, ( ! 0 && 1 ), 'tests_operators_and_exclam_precedence: ! 0 && 1 ) => 1' ) ; 9317 is( "", ( ! 1 && 0 ), 'tests_operators_and_exclam_precedence: ! 1 && 0 ) => ""' ) ; 9318 is( "", ( ! 1 && 1 ), 'tests_operators_and_exclam_precedence: ! 1 && 1 ) => ""' ) ; 9319 9320 is( 2, ( ! 0 && 2 ), 'tests_operators_and_exclam_precedence: ! 0 && 2 ) => 1' ) ; 9321 9322 note( 'Leaving tests_operators_and_exclam_precedence()' ) ; 9323 return ; 9324} 9325 9326sub delete_messages_on_any 9327{ 9328 my( $mysync, $imap, $hostX_folder, $expunge, $split, @messages ) = @_ ; 9329 my $expunge_message = q{} ; 9330 9331 my $dry_message = $mysync->{ dry_message } ; 9332 $expunge_message = 'and expunged' if ( $expunge ) ; 9333 # "Host1: msg " 9334 9335 $imap->Debug( 1 ) ; 9336 9337 while ( my @messages_part = splice @messages, 0, $split ) 9338 { 9339 foreach my $message ( @messages_part ) 9340 { 9341 myprint( "$hostX_folder/$message marking deleted $expunge_message $dry_message\n" ) ; 9342 } 9343 if ( ! $mysync->{dry} && @messages_part ) 9344 { 9345 my $nb_deleted = $imap->delete_message( $imap->Range( @messages_part ) ) ; 9346 if ( defined $nb_deleted ) 9347 { 9348 # $nb_deleted is not accurate 9349 $mysync->{ h1_nb_msg_deleted } += scalar @messages_part ; 9350 } 9351 else 9352 { 9353 my $error_imap = $imap->LastError || q{} ; 9354 my $error = join( q{}, "$hostX_folder folder, could not delete ", 9355 scalar @messages_part, ' messages: ', $error_imap, "\n" ) ; 9356 errors_incr( $mysync, $error ) ; 9357 } 9358 } 9359 } 9360 9361 if ( $expunge ) { 9362 uidexpunge_or_expunge( $mysync, $imap, @messages ) ; 9363 } 9364 9365 $imap->Debug( 0 ) ; 9366 9367 return ; 9368} 9369 9370 9371sub tests_uidexpunge_or_expunge 9372{ 9373 note( 'Entering tests_uidexpunge_or_expunge()' ) ; 9374 9375 9376 is( undef, uidexpunge_or_expunge( ), 'uidexpunge_or_expunge: no args => undef' ) ; 9377 my $mysync ; 9378 is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: undef args => undef' ) ; 9379 $mysync = {} ; 9380 is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: arg empty => undef' ) ; 9381 my $imap ; 9382 is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: undef Mail-IMAPClient instance => undef' ) ; 9383 9384 require_ok( "Test::MockObject" ) ; 9385 $imap = Test::MockObject->new( ) ; 9386 is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: no message (1) to uidexpunge => undef' ) ; 9387 9388 my @messages = ( ) ; 9389 is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: no message (2) to uidexpunge => undef' ) ; 9390 9391 @messages = ( '2', '1' ) ; 9392 $imap->mock( 'uidexpunge', sub { return ; } ) ; 9393 $imap->mock( 'expunge', sub { return ; } ) ; 9394 is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge failure => undef' ) ; 9395 9396 $imap->mock( 'expunge', sub { return 1 ; } ) ; 9397 is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge ok => 1' ) ; 9398 9399 $imap->mock( 'uidexpunge', sub { return 1 ; } ) ; 9400 is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: messages to uidexpunge ok => 1' ) ; 9401 9402 note( 'Leaving tests_uidexpunge_or_expunge()' ) ; 9403 return ; 9404} 9405 9406sub uidexpunge_or_expunge 9407{ 9408 my $mysync = shift ; 9409 my $imap = shift ; 9410 my @messages = @ARG ; 9411 9412 if ( ! $imap ) { return ; } ; 9413 if ( ! @messages ) { return ; } ; 9414 9415 # Doing uidexpunge 9416 my @uidexpunge_result = $imap->uidexpunge( @messages ) ; 9417 if ( @uidexpunge_result ) { 9418 return 1 ; 9419 } 9420 # Failure so doing expunge 9421 my $expunge_result = $imap->expunge( ) ; 9422 if ( $expunge_result ) { 9423 return 1 ; 9424 } 9425 # bad trip 9426 return ; 9427} 9428 9429 9430sub eta 9431{ 9432 my( $my_time_spent, $h1_nb_processed, $my_h1_nb_msg_start, $nb_transferred ) = @_ ; 9433 return( q{} ) if not $foldersizes ; 9434 9435 my $time_remaining = time_remaining( $my_time_spent, $h1_nb_processed, $my_h1_nb_msg_start, $nb_transferred ) ; 9436 my $nb_msg_remaining = $my_h1_nb_msg_start - $h1_nb_processed ; 9437 my $eta_date = localtime( time + $time_remaining ) ; 9438 return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left', $eta_date, $time_remaining, $nb_msg_remaining, $my_h1_nb_msg_start ) ) ; 9439} 9440 9441sub time_remaining 9442{ 9443 9444 my( $my_time_spent, $h1_nb_processed, $my_h1_nb_msg_start, $nb_transferred ) = @_ ; 9445 9446 my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $my_h1_nb_msg_start - $h1_nb_processed ) ; 9447 return( $time_remaining ) ; 9448} 9449 9450 9451sub tests_time_remaining 9452{ 9453 note( 'Entering tests_time_remaining()' ) ; 9454 9455 9456 ok( 1 == time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ; 9457 ok( 1 == time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ; 9458 ok( 9 == time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 1' ) ; 9459 9460 note( 'Leaving tests_time_remaining()' ) ; 9461 return ; 9462} 9463 9464 9465sub cache_map 9466{ 9467 my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_; 9468 my ( %map1_2, %map2_1, %done2 ) ; 9469 9470 my $h1_msgs_hash_ref = { } ; 9471 my $h2_msgs_hash_ref = { } ; 9472 9473 @{ $h1_msgs_hash_ref }{ @{ $h1_msgs_ref } } = ( ) ; 9474 @{ $h2_msgs_hash_ref }{ @{ $h2_msgs_ref } } = ( ) ; 9475 9476 foreach my $file ( sort @{ $cache_files_ref } ) { 9477 $debugcache and myprint( "C12: $file\n" ) ; 9478 ( $uid1, $uid2 ) = match_a_cache_file( $file ) ; 9479 9480 if ( exists( $h1_msgs_hash_ref->{ defined $uid1 ? $uid1 : q{} } ) 9481 and exists( $h2_msgs_hash_ref->{ defined $uid2 ? $uid2 : q{} } ) ) { 9482 # keep only the greatest uid2 9483 # 130_2301 and 9484 # 130_231 => keep only 130 -> 2301 9485 9486 # keep only the greatest uid1 9487 # 1601_260 and 9488 # 161_260 => keep only 1601 -> 260 9489 my $max_uid2 = max( $uid2, $map1_2{ $uid1 } || $MINUS_ONE ) ; 9490 if ( exists $done2{ $max_uid2 } ) { 9491 if ( $done2{ $max_uid2 } < $uid1 ) { 9492 $map1_2{ $uid1 } = $max_uid2 ; 9493 delete $map1_2{ $done2{ $max_uid2 } } ; 9494 $done2{ $max_uid2 } = $uid1 ; 9495 } 9496 }else{ 9497 $map1_2{ $uid1 } = $max_uid2 ; 9498 $done2{ $max_uid2 } = $uid1 ; 9499 } 9500 }; 9501 9502 } 9503 %map2_1 = reverse %map1_2 ; 9504 return( \%map1_2, \%map2_1) ; 9505} 9506 9507sub tests_cache_map 9508{ 9509 note( 'Entering tests_cache_map()' ) ; 9510 9511 #$debugcache = 1 ; 9512 my @cache_files = qw ( 9513 100_200 9514 101_201 9515 120_220 9516 142_242 9517 143_243 9518 177_277 9519 177_278 9520 177_279 9521 155_255 9522 180_280 9523 181_280 9524 182_280 9525 130_231 9526 130_2301 9527 161_260 9528 1601_260 9529 ) ; 9530 9531 my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ]; 9532 my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ]; 9533 9534 my( $c12, $c21 ) ; 9535 ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' ); 9536 my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; 9537 my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; 9538 ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' ); 9539 ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' ); 9540 ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' ); 9541 ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' ); 9542 ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' ); 9543 #myprint( $c12->{1601}, "\n" ) ; 9544 9545 note( 'Leaving tests_cache_map()' ) ; 9546 return ; 9547 9548} 9549 9550sub cache_dir_fix 9551{ 9552 my $cache_dir = shift ; 9553 $cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ; 9554 #myprint( "cache_dir_fix: $cache_dir\n" ) ; 9555 return( $cache_dir ) ; 9556} 9557 9558sub tests_cache_dir_fix 9559{ 9560 note( 'Entering tests_cache_dir_fix()' ) ; 9561 9562 ok( 'lalala' eq cache_dir_fix('lalala'), 'cache_dir_fix: lalala -> lalala' ); 9563 ok( 'ii\\\\ii' eq cache_dir_fix('ii\ii'), 'cache_dir_fix: ii\ii -> ii\\\\ii' ); 9564 ok( 'ii@ii' eq cache_dir_fix('ii@ii'), 'cache_dir_fix: ii@ii -> ii@ii' ); 9565 ok( 'ii@ii\\:ii' eq cache_dir_fix('ii@ii:ii'), 'cache_dir_fix: ii@ii:ii -> ii@ii\\:ii' ); 9566 ok( 'i\\\\i\\\\ii' eq cache_dir_fix('i\i\ii'), 'cache_dir_fix: i\i\ii -> i\\\\i\\\\ii' ); 9567 ok( 'i\\\\ii' eq cache_dir_fix('i\\ii'), 'cache_dir_fix: i\\ii -> i\\\\\\\\ii' ); 9568 ok( '\\\\ ' eq cache_dir_fix('\\ '), 'cache_dir_fix: \\ -> \\\\\ ' ); 9569 ok( '\\\\ ' eq cache_dir_fix('\ '), 'cache_dir_fix: \ -> \\\\\ ' ); 9570 ok( '\[bracket\]' eq cache_dir_fix('[bracket]'), 'cache_dir_fix: [bracket] -> \[bracket\]' ); 9571 9572 note( 'Leaving tests_cache_dir_fix()' ) ; 9573 return ; 9574} 9575 9576sub cache_dir_fix_win 9577{ 9578 my $cache_dir = shift ; 9579 $cache_dir =~ s/(\[|\])/[$1]/xg ; 9580 #myprint( "cache_dir_fix_win: $cache_dir\n" ) ; 9581 return( $cache_dir ) ; 9582} 9583 9584sub tests_cache_dir_fix_win 9585{ 9586 note( 'Entering tests_cache_dir_fix_win()' ) ; 9587 9588 ok( 'lalala' eq cache_dir_fix_win('lalala'), 'cache_dir_fix_win: lalala -> lalala' ); 9589 ok( '[[]bracket[]]' eq cache_dir_fix_win('[bracket]'), 'cache_dir_fix_win: [bracket] -> [[]bracket[]]' ); 9590 9591 note( 'Leaving tests_cache_dir_fix_win()' ) ; 9592 return ; 9593} 9594 9595 9596 9597 9598sub get_cache 9599{ 9600 my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_; 9601 9602 $debugcache and myprint( "Entering get_cache\n" ) ; 9603 9604 -d $cache_dir or return( undef ); # exit if cache directory doesn't exist 9605 $debugcache and myprint( "cache_dir : $cache_dir\n" ) ; 9606 9607 9608 if ( 'MSWin32' ne $OSNAME ) { 9609 $cache_dir = cache_dir_fix( $cache_dir ) ; 9610 }else{ 9611 $cache_dir = cache_dir_fix_win( $cache_dir ) ; 9612 } 9613 9614 $debugcache and myprint( "cache_dir_fix: $cache_dir\n" ) ; 9615 9616 my @cache_files = bsd_glob( "$cache_dir/*" ) ; 9617 #$debugcache and myprint( "cache_files: [@cache_files]\n" ) ; 9618 9619 $debugcache and myprint( 'cache_files: ', scalar @cache_files , " files found\n" ) ; 9620 9621 my( $cache_1_2_ref, $cache_2_1_ref ) 9622 = cache_map( \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ; 9623 9624 clean_cache( \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; 9625 9626 $debugcache and myprint( "Exiting get_cache\n" ) ; 9627 return( $cache_1_2_ref, $cache_2_1_ref ) ; 9628} 9629 9630 9631sub tests_get_cache 9632{ 9633 note( 'Entering tests_get_cache()' ) ; 9634 9635 ok( not( get_cache('/cache_no_exist') ), 'get_cache: /cache_no_exist' ); 9636 ok( ( not -d 'W/tmp/cache/F1/F2' or rmtree( 'W/tmp/cache/F1/F2' ) ), 'get_cache: rmtree W/tmp/cache/F1/F2' ) ; 9637 ok( mkpath( 'W/tmp/cache/F1/F2' ), 'get_cache: mkpath W/tmp/cache/F1/F2' ) ; 9638 9639 my @test_files_cache = ( qw( 9640 W/tmp/cache/F1/F2/100_200 9641 W/tmp/cache/F1/F2/101_201 9642 W/tmp/cache/F1/F2/120_220 9643 W/tmp/cache/F1/F2/142_242 9644 W/tmp/cache/F1/F2/143_243 9645 W/tmp/cache/F1/F2/177_277 9646 W/tmp/cache/F1/F2/177_377 9647 W/tmp/cache/F1/F2/177_777 9648 W/tmp/cache/F1/F2/155_255 9649 ) ) ; 9650 ok( touch( @test_files_cache ), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; 9651 9652 9653 # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 9654 # on live: 9655 my $msgs_1 = [120, 142, 143, 144, 177 ]; 9656 my $msgs_2 = [ 242, 243, 299, 377, 777, 255 ]; 9657 9658 my $msgs_all_1 = { 120 => 0, 142 => 0, 143 => 0, 144 => 0, 177 => 0 } ; 9659 my $msgs_all_2 = { 242 => 0, 243 => 0, 299 => 0, 377 => 0, 777 => 0, 255 => 0 } ; 9660 9661 my( $c12, $c21 ) ; 9662 ok( ( $c12, $c21 ) = get_cache( 'W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); 9663 my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; 9664 my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; 9665 ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: 03' ); 9666 ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: 04' ); 9667 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); 9668 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); 9669 ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file removed 100_200'); 9670 ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file removed 101_201'); 9671 9672 # test clean_cache executed 9673 $maxage = 2 ; 9674 ok( touch(@test_files_cache), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; 9675 ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); 9676 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); 9677 ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); 9678 ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file NOT removed 100_200'); 9679 ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file NOT removed 101_201'); 9680 9681 9682 # strange files 9683 #$debugcache = 1 ; 9684 $maxage = undef ; 9685 ok( ( not -d 'W/tmp/cache/rr\uee' or rmtree( 'W/tmp/cache/rr\uee' )), 'get_cache: rmtree W/tmp/cache/rr\uee' ) ; 9686 ok( mkpath( 'W/tmp/cache/rr\uee' ), 'get_cache: mkpath W/tmp/cache/rr\uee' ) ; 9687 9688 @test_files_cache = ( qw( 9689 W/tmp/cache/rr\uee/100_200 9690 W/tmp/cache/rr\uee/101_201 9691 W/tmp/cache/rr\uee/120_220 9692 W/tmp/cache/rr\uee/142_242 9693 W/tmp/cache/rr\uee/143_243 9694 W/tmp/cache/rr\uee/177_277 9695 W/tmp/cache/rr\uee/177_377 9696 W/tmp/cache/rr\uee/177_777 9697 W/tmp/cache/rr\uee/155_255 9698 ) ) ; 9699 ok( touch(@test_files_cache), 'get_cache: touch strange W/tmp/cache/...' ) ; 9700 9701 # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 9702 # on live: 9703 $msgs_1 = [120, 142, 143, 144, 177 ] ; 9704 $msgs_2 = [ 242, 243, 299, 377, 777, 255 ] ; 9705 9706 $msgs_all_1 = { 120 => q{}, 142 => q{}, 143 => q{}, 144 => q{}, 177 => q{} } ; 9707 $msgs_all_2 = { 242 => q{}, 243 => q{}, 299 => q{}, 377 => q{}, 777 => q{}, 255 => q{} } ; 9708 9709 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' ); 9710 $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; 9711 $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; 9712 ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: strange path 03' ); 9713 ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: strange path 04' ); 9714 ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 142_242'); 9715 ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 143_243'); 9716 ok( ! -f 'W/tmp/cache/rr\uee/100_200', 'get_cache: strange path file removed 100_200'); 9717 ok( ! -f 'W/tmp/cache/rr\uee/101_201', 'get_cache: strange path file removed 101_201'); 9718 9719 note( 'Leaving tests_get_cache()' ) ; 9720 return ; 9721} 9722 9723sub match_a_cache_file 9724{ 9725 my $file = shift ; 9726 my ( $cache_uid1, $cache_uid2 ) ; 9727 9728 return( ( undef, undef ) ) if ( ! $file ) ; 9729 if ( $file =~ m{(?:^|/)(\d+)_(\d+)$}x ) { 9730 $cache_uid1 = $1 ; 9731 $cache_uid2 = $2 ; 9732 } 9733 return( $cache_uid1, $cache_uid2 ) ; 9734} 9735 9736sub tests_match_a_cache_file 9737{ 9738 note( 'Entering tests_match_a_cache_file()' ) ; 9739 9740 my ( $tuid1, $tuid2 ) ; 9741 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ; 9742 ok( ! defined $tuid1 , 'match_a_cache_file: no arg 1' ) ; 9743 ok( ! defined $tuid2 , 'match_a_cache_file: no arg 2' ) ; 9744 9745 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( q{} ), 'match_a_cache_file: empty arg' ) ; 9746 ok( ! defined $tuid1 , 'match_a_cache_file: empty arg 1' ) ; 9747 ok( ! defined $tuid2 , 'match_a_cache_file: empty arg 2' ) ; 9748 9749 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ; 9750 ok( '000' eq $tuid1, 'match_a_cache_file: 000_000 1' ) ; 9751 ok( '000' eq $tuid2, 'match_a_cache_file: 000_000 2' ) ; 9752 9753 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ; 9754 ok( '123' eq $tuid1, 'match_a_cache_file: 123_456 1' ) ; 9755 ok( '456' eq $tuid2, 'match_a_cache_file: 123_456 2' ) ; 9756 9757 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ; 9758 ok( '123' eq $tuid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ; 9759 ok( '456' eq $tuid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ; 9760 9761 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ; 9762 ok( ! $tuid1, 'match_a_cache_file: /lala123_456 1' ) ; 9763 ok( ! $tuid2, 'match_a_cache_file: /lala123_456 2' ) ; 9764 9765 ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ; 9766 ok( ! $tuid1, 'match_a_cache_file: la123_456 1' ) ; 9767 ok( ! $tuid2, 'match_a_cache_file: la123_456 2' ) ; 9768 9769 note( 'Leaving tests_match_a_cache_file()' ) ; 9770 return ; 9771} 9772 9773sub clean_cache 9774{ 9775 my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ; 9776 9777 $debugcache and myprint( "Entering clean_cache\n" ) ; 9778 9779 $debugcache and myprint( map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %{ $cache_1_2_ref } ) ; 9780 foreach my $file ( @{ $cache_files_ref } ) { 9781 $debugcache and myprint( "$file\n" ) ; 9782 my ( $cache_uid1, $cache_uid2 ) = match_a_cache_file( $file ) ; 9783 $debugcache and myprint( "u1: $cache_uid1 u2: $cache_uid2 c12: ", $cache_1_2_ref->{ $cache_uid1 } || q{}, "\n") ; 9784# or ( ! exists( $cache_1_2_ref->{ $cache_uid1 } ) ) 9785# or ( ! ( $cache_uid2 == $cache_1_2_ref->{ $cache_uid1 } ) ) 9786 if ( ( not defined $cache_uid1 ) 9787 or ( not defined $cache_uid2 ) 9788 or ( not exists $h1_msgs_all_hash_ref->{ $cache_uid1 } ) 9789 or ( not exists $h2_msgs_all_hash_ref->{ $cache_uid2 } ) 9790 ) { 9791 $debugcache and myprint( "remove $file\n" ) ; 9792 unlink $file or myprint( "$OS_ERROR" ) ; 9793 } 9794 } 9795 9796 $debugcache and myprint( "Exiting clean_cache\n" ) ; 9797 return( 1 ) ; 9798} 9799 9800sub tests_clean_cache 9801{ 9802 note( 'Entering tests_clean_cache()' ) ; 9803 9804 ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache: rmtree W/tmp/cache/G1/G2' ) ; 9805 ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache: mkpath W/tmp/cache/G1/G2' ) ; 9806 9807 my @test_files_cache = ( qw( 9808 W/tmp/cache/G1/G2/100_200 9809 W/tmp/cache/G1/G2/101_201 9810 W/tmp/cache/G1/G2/120_220 9811 W/tmp/cache/G1/G2/142_242 9812 W/tmp/cache/G1/G2/143_243 9813 W/tmp/cache/G1/G2/177_277 9814 W/tmp/cache/G1/G2/177_377 9815 W/tmp/cache/G1/G2/177_777 9816 W/tmp/cache/G1/G2/155_255 9817 ) ) ; 9818 ok( touch(@test_files_cache), 'clean_cache: touch W/tmp/cache/G1/G2/...' ) ; 9819 9820 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' ); 9821 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' ); 9822 ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' ); 9823 ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' ); 9824 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' ); 9825 ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' ); 9826 9827 my $cache = { 9828 142 => 242, 9829 177 => 777, 9830 } ; 9831 9832 my $all_1 = { 9833 142 => q{}, 9834 177 => q{}, 9835 } ; 9836 9837 my $all_2 = { 9838 200 => q{}, 9839 242 => q{}, 9840 777 => q{}, 9841 } ; 9842 ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache: ' ) ; 9843 9844 ok( ! -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 after' ); 9845 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 after' ); 9846 ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 after' ); 9847 ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 after' ); 9848 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 after' ); 9849 ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 after' ); 9850 9851 note( 'Leaving tests_clean_cache()' ) ; 9852 return ; 9853} 9854 9855sub tests_clean_cache_2 9856{ 9857 note( 'Entering tests_clean_cache_2()' ) ; 9858 9859 ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ; 9860 ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ; 9861 9862 my @test_files_cache = ( qw( 9863 W/tmp/cache/G1/G2/100_200 9864 W/tmp/cache/G1/G2/101_201 9865 W/tmp/cache/G1/G2/120_220 9866 W/tmp/cache/G1/G2/142_242 9867 W/tmp/cache/G1/G2/143_243 9868 W/tmp/cache/G1/G2/177_277 9869 W/tmp/cache/G1/G2/177_377 9870 W/tmp/cache/G1/G2/177_777 9871 W/tmp/cache/G1/G2/155_255 9872 ) ) ; 9873 ok( touch(@test_files_cache), 'clean_cache_2: touch W/tmp/cache/G1/G2/...' ) ; 9874 9875 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' ); 9876 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' ); 9877 ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' ); 9878 ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' ); 9879 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' ); 9880 ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' ); 9881 9882 my $cache = { 9883 142 => 242, 9884 177 => 777, 9885 } ; 9886 9887 my $all_1 = { 9888 $NUMBER_100 => q{}, 9889 142 => q{}, 9890 177 => q{}, 9891 } ; 9892 9893 my $all_2 = { 9894 200 => q{}, 9895 242 => q{}, 9896 777 => q{}, 9897 } ; 9898 9899 9900 9901 ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache_2: ' ) ; 9902 9903 ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 after' ); 9904 ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 after' ); 9905 ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 after' ); 9906 ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 after' ); 9907 ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 after' ); 9908 ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 after' ); 9909 9910 note( 'Leaving tests_clean_cache_2()' ) ; 9911 return ; 9912} 9913 9914 9915 9916sub tests_mkpath 9917{ 9918 note( 'Entering tests_mkpath()' ) ; 9919 9920 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'mkpath: mkpath W/tmp/tests/' ) ; 9921 9922 SKIP: { 9923 skip( 'Tests only for Unix', 10 ) if ( 'MSWin32' eq $OSNAME ) ; 9924 my $long_path_unix = '123456789/' x 30 ; 9925 ok( ( -d "W/tmp/tests/long/$long_path_unix" or mkpath( "W/tmp/tests/long/$long_path_unix" ) ), 'mkpath: mkpath 300 char' ) ; 9926 ok( -d "W/tmp/tests/long/$long_path_unix", 'mkpath: mkpath > 300 char verified' ) ; 9927 ok( ( -d "W/tmp/tests/long/$long_path_unix" and rmtree( 'W/tmp/tests/long/' ) ), 'mkpath: rmtree 300 char' ) ; 9928 ok( ! -d "W/tmp/tests/long/$long_path_unix", 'mkpath: rmtree 300 char verified' ) ; 9929 9930 ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ; 9931 ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ; 9932 ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ; 9933 ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ; 9934 9935 eval { ok( 1 / 0, 'mkpath: divide by 0' ) ; } or ok( 1, 'mkpath: can not divide by 0' ) ; 9936 ok( 1, 'mkpath: still alive' ) ; 9937 } ; 9938 9939 SKIP: { 9940 skip( 'Tests only for MSWin32', 13 ) if ( 'MSWin32' ne $OSNAME ) ; 9941 my $long_path_2_prefix = ".\\imapsync_tests" || '\\\?\\E:\\TEMP\\imapsync_tests' ; 9942 myprint( "long_path_2_prefix: $long_path_2_prefix\n" ) ; 9943 9944 my $long_path_100 = $long_path_2_prefix . '\\' . '123456789\\' x 10 . 'END' ; 9945 my $long_path_300 = $long_path_2_prefix . '\\' . '123456789\\' x 30 . 'END' ; 9946 9947 #myprint( "$long_path_100\n" ) ; 9948 9949 ok( ( -d $long_path_2_prefix or mkpath( $long_path_2_prefix ) ), 'mkpath: -d mkpath small path' ) ; 9950 ok( ( -d $long_path_2_prefix ), 'mkpath: -d mkpath small path done' ) ; 9951 ok( ( -d $long_path_100 or mkpath( $long_path_100 ) ), 'mkpath: mkpath > 100 char' ) ; 9952 ok( ( -d $long_path_100 ), 'mkpath: -d mkpath > 200 char done' ) ; 9953 ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'mkpath: rmtree > 100 char' ) ; 9954 ok( (! -d $long_path_2_prefix ), 'mkpath: ! -d rmtree done' ) ; 9955 9956 # Without the eval the following mkpath 300 just kill the whole process without a whisper 9957 #myprint( "$long_path_300\n" ) ; 9958 eval { ok( ( -d $long_path_300 or mkpath( $long_path_300 ) ), 'mkpath: create a path with 300 characters' ) ; } 9959 or ok( 1, 'mkpath: can not create a path with 300 characters' ) ; 9960 ok( ( ( ! -d $long_path_300 ) or -d $long_path_300 and rmtree( $long_path_300 ) ), 'mkpath: rmtree the 300 character path' ) ; 9961 ok( 1, 'mkpath: still alive' ) ; 9962 9963 ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ; 9964 ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ; 9965 ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ; 9966 ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ; 9967 9968 9969 } ; 9970 9971 note( 'Leaving tests_mkpath()' ) ; 9972 # Keep this because of the eval used by the caller (failed badly?) 9973 return 1 ; 9974} 9975 9976sub tests_touch 9977{ 9978 note( 'Entering tests_touch()' ) ; 9979 9980 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'touch: mkpath W/tmp/tests/' ) ; 9981 ok( 1 == touch( 'W/tmp/tests/lala'), 'touch: W/tmp/tests/lala') ; 9982 ok( 1 == touch( 'W/tmp/tests/\y'), 'touch: W/tmp/tests/\y') ; 9983 ok( 0 == touch( '/no/no/no/aaa'), 'touch: not /aaa') ; 9984 ok( 1 == touch( 'W/tmp/tests/lili', 'W/tmp/tests/lolo'), 'touch: 2 files') ; 9985 ok( 0 == touch( 'W/tmp/tests/\y', '/no/no/aaa'), 'touch: 2 files, 1 fails' ) ; 9986 9987 note( 'Leaving tests_touch()' ) ; 9988 return ; 9989} 9990 9991 9992sub touch 9993{ 9994 my @files = @_ ; 9995 my $failures = 0 ; 9996 9997 foreach my $file ( @files ) { 9998 my $fh = IO::File->new ; 9999 if ( $fh->open(">> $file" ) ) { 10000 $fh->close ; 10001 }else{ 10002 myprint( "Could not open file $file in write/append mode\n" ) ; 10003 $failures++ ; 10004 } 10005 } 10006 return( ! $failures ); 10007} 10008 10009 10010sub tests_tmpdir_has_colon_bug 10011{ 10012 note( 'Entering tests_tmpdir_has_colon_bug()' ) ; 10013 10014 ok( 0 == tmpdir_has_colon_bug( q{} ), 'tmpdir_has_colon_bug: ' ) ; 10015 ok( 0 == tmpdir_has_colon_bug( '/tmp' ), 'tmpdir_has_colon_bug: /tmp' ) ; 10016 ok( 1 == tmpdir_has_colon_bug( 'C:' ), 'tmpdir_has_colon_bug: C:' ) ; 10017 ok( 1 == tmpdir_has_colon_bug( 'C:\temp' ), 'tmpdir_has_colon_bug: C:\temp' ) ; 10018 10019 note( 'Leaving tests_tmpdir_has_colon_bug()' ) ; 10020 return ; 10021} 10022 10023sub tmpdir_has_colon_bug 10024{ 10025 my $path = shift ; 10026 10027 my $path_filtered = filter_forbidden_characters( $path ) ; 10028 if ( $path_filtered ne $path ) { 10029 ( -d $path_filtered ) and myprint( "Path $path was previously mistakely changed to $path_filtered\n" ) ; 10030 return( 1 ) ; 10031 } 10032 return( 0 ) ; 10033} 10034 10035sub tmpdir_fix_colon_bug 10036{ 10037 my $mysync = shift ; 10038 my $err = 0 ; 10039 if ( not (-d $mysync->{ tmpdir } and -r _ and -w _) ) { 10040 myprint( "tmpdir $mysync->{ tmpdir } is not valid\n" ) ; 10041 return( 0 ) ; 10042 } 10043 my $cachedir_new = "$mysync->{ tmpdir }/imapsync_cache" ; 10044 10045 if ( not tmpdir_has_colon_bug( $cachedir_new ) ) { return( 0 ) } ; 10046 10047 # check if old cache directory already exists 10048 my $cachedir_old = filter_forbidden_characters( $cachedir_new ) ; 10049 if ( not ( -d $cachedir_old ) ) { 10050 myprint( "Old cache directory $cachedir_new no exists, nothing to do\n" ) ; 10051 return( 1 ) ; 10052 } 10053 # check if new cache directory already exists 10054 if ( -d $cachedir_new ) { 10055 myprint( "New fixed cache directory $cachedir_new already exists, not moving the old one $cachedir_old. Fix this manually.\n" ) ; 10056 return( 0 ) ; 10057 }else{ 10058 # move the old one to the new place 10059 myprint( "Moving $cachedir_old to $cachedir_new Do not interrupt this task.\n" ) ; 10060 File::Copy::Recursive::rmove( $cachedir_old, $cachedir_new ) 10061 or do { 10062 myprint( "Could not move $cachedir_old to $cachedir_new\n" ) ; 10063 $err++ ; 10064 } ; 10065 # check it succeeded 10066 if ( -d $cachedir_new and -r _ and -w _ ) { 10067 myprint( "New fixed cache directory $cachedir_new ok\n" ) ; 10068 }else{ 10069 myprint( "New fixed cache directory $cachedir_new does not exist\n" ) ; 10070 $err++ ; 10071 } 10072 if ( -d $cachedir_old ) { 10073 myprint( "Old cache directory $cachedir_old still exists\n" ) ; 10074 $err++ ; 10075 }else{ 10076 myprint( "Old cache directory $cachedir_old successfuly moved\n" ) ; 10077 } 10078 } 10079 return( not $err ) ; 10080} 10081 10082 10083sub tests_cache_folder 10084{ 10085 note( 'Entering tests_cache_folder()' ) ; 10086 10087 ok( '/path/fold1/fold2' eq cache_folder( q{}, '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ; 10088 ok( '/pa_th/fold1/fold2' eq cache_folder( q{}, '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ; 10089 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' ) ; 10090 10091 ok( 'D:/path/fold1/fold2' eq cache_folder( 'D:', '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ; 10092 ok( 'D:/pa_th/fold1/fold2' eq cache_folder( 'D:', '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ; 10093 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' ) ; 10094 ok( '//' eq cache_folder( q{}, q{}, q{}, q{}), 'cache_folder: -> //' ) ; 10095 ok( '//_______' eq cache_folder( q{}, q{}, q{}, '*|?:"<>'), 'cache_folder: *|?:"<> -> //_______' ) ; 10096 10097 note( 'Leaving tests_cache_folder()' ) ; 10098 return ; 10099} 10100 10101sub cache_folder 10102{ 10103 my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ; 10104 10105 my $sep_1 = $sync->{ h1_sep } || '/'; 10106 my $sep_2 = $sync->{ h2_sep } || '/'; 10107 10108 #myprint( "$cache_dir h1_fold $h1_fold sep1 $sep_1 h2_fold $h2_fold sep2 $sep_2\n" ) ; 10109 $h1_fold = convert_sep_to_slash( $h1_fold, $sep_1 ) ; 10110 $h2_fold = convert_sep_to_slash( $h2_fold, $sep_2 ) ; 10111 10112 my $cache_folder = "$cache_base" . filter_forbidden_characters( "$cache_dir/$h1_fold/$h2_fold" ) ; 10113 #myprint( "cache_folder [$cache_folder]\n" ) ; 10114 return( $cache_folder ) ; 10115} 10116 10117sub tests_filter_forbidden_characters 10118{ 10119 note( 'Entering tests_filter_forbidden_characters()' ) ; 10120 10121 ok( 'a_b' eq filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ; 10122 ok( 'a_b' eq filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ; 10123 ok( 'a_b' eq filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ; 10124 ok( 'a_b' eq filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ; 10125 ok( 'a_______b' eq filter_forbidden_characters( 'a*|?:"<>b' ), 'filter_forbidden_characters: a*|?:"<>b -> a_______b' ) ; 10126 10127 SKIP: { 10128 skip( 'Not on MSWin32', 1 ) if ( 'MSWin32' eq $OSNAME ) ; 10129 ok( ( 'a b ' eq filter_forbidden_characters( 'a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b "' ) ; 10130 } ; 10131 10132 SKIP: { 10133 skip( 'Only on MSWin32', 2 ) if ( 'MSWin32' ne $OSNAME ) ; 10134 ok( ( ' a b_' eq filter_forbidden_characters( ' a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b_"' ) ; 10135 ok( ( ' a b_/ c d_' eq filter_forbidden_characters( ' a b / c d ' ) ), 'filter_forbidden_characters: " a b / c d " -> "a b_/ c d_"' ) ; 10136 } ; 10137 10138 ok( 'a_b' eq filter_forbidden_characters( "a\tb" ), 'filter_forbidden_characters: a\tb -> a_b' ) ; 10139 ok( "a_b" eq filter_forbidden_characters( "a\rb" ), 'filter_forbidden_characters: a\rb -> a_b' ) ; 10140 ok( "a_b" eq filter_forbidden_characters( "a\nb" ), 'filter_forbidden_characters: a\nb -> a_b' ) ; 10141 ok( "a_b" eq filter_forbidden_characters( "a\\b" ), 'filter_forbidden_characters: a\b -> a_b' ) ; 10142 10143 note( 'Leaving tests_filter_forbidden_characters()' ) ; 10144 return ; 10145} 10146 10147sub filter_forbidden_characters 10148{ 10149 my $string = shift ; 10150 10151 if ( ! defined $string ) { return ; } 10152 10153 if ( 'MSWin32' eq $OSNAME ) { 10154 # Move trailing whitespace to _ " a b /c d " -> " a b_/c d_" 10155 $string =~ s{\ (/|$)}{_$1}xg ; 10156 } 10157 $string =~ s{[\Q*|?:"<>\E\t\r\n\\]}{_}xg ; 10158 #myprint( "[$string]\n" ) ; 10159 return( $string ) ; 10160} 10161 10162sub tests_convert_sep_to_slash 10163{ 10164 note( 'Entering tests_convert_sep_to_slash()' ) ; 10165 10166 10167 ok(q{} eq convert_sep_to_slash(q{}, '/'), 'convert_sep_to_slash: no folder'); 10168 ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX'); 10169 ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo'); 10170 ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo'); 10171 ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob'); 10172 ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo'); 10173 ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi'); 10174 10175 note( 'Leaving tests_convert_sep_to_slash()' ) ; 10176 return ; 10177} 10178 10179sub convert_sep_to_slash 10180{ 10181 my ( $folder, $sep ) = @_ ; 10182 10183 $folder =~ s{\Q$sep\E}{/}xg ; 10184 return( $folder ) ; 10185} 10186 10187 10188sub tests_regexmess 10189{ 10190 note( 'Entering tests_regexmess()' ) ; 10191 10192 ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess, no regexmess, nothing to do' ) ; 10193 10194 @regexmess = ( 'lalala' ) ; 10195 ok( not( defined regexmess( 'popopo' ) ), 'regexmess, bad regex lalala' ) ; 10196 10197 @regexmess = ( 's/p/Z/g' ) ; 10198 ok( 'ZoZoZo' eq regexmess( 'popopo' ), 'regexmess, s/p/Z/g' ) ; 10199 10200 @regexmess = ( 's{c}{C}gxms' ) ; 10201 ok("H1: abC\nH2: Cde\n\nBody abC" 10202 eq regexmess( "H1: abc\nH2: cde\n\nBody abc"), 10203 'regexmess, c->C'); 10204 10205 @regexmess = ( 's{\AFrom\ }{From:}gxms' ) ; 10206 ok( q{} 10207 eq regexmess(q{}), 10208 'From mbox 1 add colon blank'); 10209 10210 ok( 'From:<tartanpion@machin.truc>' 10211 eq regexmess('From <tartanpion@machin.truc>'), 10212 'From mbox 2 add colo'); 10213 10214 ok( "\n" . 'From <tartanpion@machin.truc>' 10215 eq regexmess("\n" . 'From <tartanpion@machin.truc>'), 10216 'From mbox 3 add colo') ; 10217 10218 ok( "From: zzz\n" . 'From <tartanpion@machin.truc>' 10219 eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), 10220 'From mbox 4 add colo') ; 10221 10222 @regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ; 10223 ok( q{} 10224 eq regexmess(q{}), 10225 'From mbox 1 remove, blank'); 10226 10227 ok( q{} 10228 eq regexmess('From <tartanpion@machin.truc>'), 10229 'From mbox 2 remove'); 10230 10231 ok( "\n" . 'From <tartanpion@machin.truc>' 10232 eq regexmess("\n" . 'From <tartanpion@machin.truc>'), 10233 'From mbox 3 remove'); 10234 10235 #myprint( "[", regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), "]" ) ; 10236 ok( q{} . 'From <tartanpion@machin.truc>' 10237 eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), 10238 'From mbox 4 remove'); 10239 10240 10241 ok( 10242<<'EOM' 10243Date: Sat, 10 Jul 2010 05:34:45 -0700 10244From:<tartanpion@machin.truc> 10245 10246Hello, 10247Bye. 10248EOM 10249 eq regexmess( 10250<<'EOM' 10251From zzz 10252Date: Sat, 10 Jul 2010 05:34:45 -0700 10253From:<tartanpion@machin.truc> 10254 10255Hello, 10256Bye. 10257EOM 10258), 'From mbox 5 remove'); 10259 10260 10261@regexmess = ( 's{\A((?:[^\n]+\n)+|)^Disposition-Notification-To:[^\n]*\n(\r?\n|.*\n\r?\n)}{$1$2}xms' ) ; # SUPER SUPER BEST! 10262 ok( 10263<<'EOM' 10264Date: Sat, 10 Jul 2010 05:34:45 -0700 10265From:<tartanpion@machin.truc> 10266 10267Hello, 10268Bye. 10269EOM 10270 eq regexmess( 10271<<'EOM' 10272Date: Sat, 10 Jul 2010 05:34:45 -0700 10273Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10274From:<tartanpion@machin.truc> 10275 10276Hello, 10277Bye. 10278EOM 10279 ), 10280 'regexmess: 1 Delete header Disposition-Notification-To:'); 10281 10282 ok( 10283<<'EOM' 10284Date: Sat, 10 Jul 2010 05:34:45 -0700 10285From:<tartanpion@machin.truc> 10286 10287Hello, 10288Bye. 10289EOM 10290 eq regexmess( 10291<<'EOM' 10292Date: Sat, 10 Jul 2010 05:34:45 -0700 10293From:<tartanpion@machin.truc> 10294Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10295 10296Hello, 10297Bye. 10298EOM 10299), 10300 'regexmess: 2 Delete header Disposition-Notification-To:'); 10301 10302 ok( 10303<<'EOM' 10304Date: Sat, 10 Jul 2010 05:34:45 -0700 10305From:<tartanpion@machin.truc> 10306 10307Hello, 10308Bye. 10309EOM 10310 eq regexmess( 10311<<'EOM' 10312Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10313Date: Sat, 10 Jul 2010 05:34:45 -0700 10314From:<tartanpion@machin.truc> 10315 10316Hello, 10317Bye. 10318EOM 10319), 10320 'regexmess: 3 Delete header Disposition-Notification-To:'); 10321 10322 ok( 10323<<'EOM' 10324Date: Sat, 10 Jul 2010 05:34:45 -0700 10325From:<tartanpion@machin.truc> 10326 10327Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10328Bye. 10329EOM 10330 eq regexmess( 10331<<'EOM' 10332Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10333Date: Sat, 10 Jul 2010 05:34:45 -0700 10334From:<tartanpion@machin.truc> 10335 10336Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10337Bye. 10338EOM 10339), 10340 'regexmess: 4 Delete header Disposition-Notification-To:'); 10341 10342 10343 ok( 10344<<'EOM' 10345Date: Sat, 10 Jul 2010 05:34:45 -0700 10346From:<tartanpion@machin.truc> 10347 10348Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10349Bye. 10350EOM 10351 eq regexmess( 10352<<'EOM' 10353Date: Sat, 10 Jul 2010 05:34:45 -0700 10354From:<tartanpion@machin.truc> 10355 10356Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10357Bye. 10358EOM 10359), 10360 'regexmess: 5 Delete header Disposition-Notification-To:'); 10361 10362 10363ok( 10364<<'EOM' 10365Date: Sat, 10 Jul 2010 05:34:45 -0700 10366From:<tartanpion@machin.truc> 10367 10368Hello, 10369Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10370Bye. 10371EOM 10372 eq regexmess( 10373<<'EOM' 10374Date: Sat, 10 Jul 2010 05:34:45 -0700 10375From:<tartanpion@machin.truc> 10376 10377Hello, 10378Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10379Bye. 10380EOM 10381), 10382 'regexmess: 6 Delete header Disposition-Notification-To:'); 10383 10384ok( 10385<<'EOM' 10386Date: Sat, 10 Jul 2010 05:34:45 -0700 10387From:<tartanpion@machin.truc> 10388 10389Hello, 10390Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10391 10392Bye. 10393EOM 10394 eq regexmess( 10395<<'EOM' 10396Date: Sat, 10 Jul 2010 05:34:45 -0700 10397From:<tartanpion@machin.truc> 10398 10399Hello, 10400Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10401 10402Bye. 10403EOM 10404), 10405 'regexmess: 7 Delete header Disposition-Notification-To:'); 10406 10407 10408ok( 10409<<'EOM' 10410Date: Sat, 10 Jul 2010 05:34:45 -0700 10411From:<tartanpion@machin.truc> 10412 10413Hello, 10414Bye. 10415EOM 10416 eq regexmess( 10417<<'EOM' 10418Date: Sat, 10 Jul 2010 05:34:45 -0700 10419From:<tartanpion@machin.truc> 10420 10421Hello, 10422Bye. 10423EOM 10424), 10425 'regexmess: 8 Delete header Disposition-Notification-To:'); 10426 10427 10428ok( 10429<<'EOM' 10430Date: Sat, 10 Jul 2010 05:34:45 -0700 10431From:<tartanpion@machin.truc> 10432 10433Hello, 10434Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10435Bye. 10436EOM 10437 eq regexmess( 10438<<'EOM' 10439Date: Sat, 10 Jul 2010 05:34:45 -0700 10440From:<tartanpion@machin.truc> 10441 10442Hello, 10443Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10444Bye. 10445EOM 10446), 10447 'regexmess: 9 Delete header Disposition-Notification-To:'); 10448 10449 10450 10451ok( 10452<<'EOM' 10453Date: Sat, 10 Jul 2010 05:34:45 -0700 10454From:<tartanpion@machin.truc> 10455 10456Hello, 10457Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10458 10459 10460Bye. 10461EOM 10462 eq regexmess( 10463<<'EOM' 10464Date: Sat, 10 Jul 2010 05:34:45 -0700 10465From:<tartanpion@machin.truc> 10466 10467Hello, 10468Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10469 10470 10471Bye. 10472EOM 10473), 10474 'regexmess: 10 Delete header Disposition-Notification-To:'); 10475 10476ok( 10477<<'EOM' 10478Date: Sat, 10 Jul 2010 05:34:45 -0700 10479From:<tartanpion@machin.truc> 10480 10481Hello, 10482 10483Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10484 10485Bye. 10486EOM 10487 eq regexmess( 10488<<'EOM' 10489Date: Sat, 10 Jul 2010 05:34:45 -0700 10490From:<tartanpion@machin.truc> 10491 10492Hello, 10493 10494Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10495 10496Bye. 10497EOM 10498), 10499 'regexmess: 11 Delete header Disposition-Notification-To:'); 10500 10501ok( 10502<<'EOM' 10503Date: Sat, 10 Jul 2010 05:34:45 -0700 10504From:<tartanpion@machin.truc> 10505 10506Hello, 10507 10508Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10509 10510Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10511 10512Bye. 10513EOM 10514 eq regexmess( 10515<<'EOM' 10516Date: Sat, 10 Jul 2010 05:34:45 -0700 10517From:<tartanpion@machin.truc> 10518 10519Hello, 10520 10521Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10522 10523Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10524 10525Bye. 10526EOM 10527), 10528 'regexmess: 12 Delete header Disposition-Notification-To:'); 10529 10530 10531@regexmess = ( 's{\A(.*?(?! ^$))^Disposition-Notification-To:(.*?)$}{$1X-Disposition-Notification-To:$2}igxms' ) ; # BAD! 10532@regexmess = ( 's{\A((?:[^\n]+\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims' ) ; 10533 10534 10535ok( 10536<<'EOM' 10537Date: Sat, 10 Jul 2010 05:34:45 -0700 10538From:<tartanpion@machin.truc> 10539 10540Hello, 10541 10542Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10543 10544Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10545 10546Bye. 10547EOM 10548 eq regexmess( 10549<<'EOM' 10550Date: Sat, 10 Jul 2010 05:34:45 -0700 10551From:<tartanpion@machin.truc> 10552 10553Hello, 10554 10555Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10556 10557Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10558 10559Bye. 10560EOM 10561), 10562 'regexmess: 13 Delete header Disposition-Notification-To:'); 10563 10564ok( 10565<<'EOM' 10566Date: Sat, 10 Jul 2010 05:34:45 -0700 10567X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10568From:<tartanpion@machin.truc> 10569 10570Hello, 10571 10572Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10573 10574Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10575 10576Bye. 10577EOM 10578 eq regexmess( 10579<<'EOM' 10580Date: Sat, 10 Jul 2010 05:34:45 -0700 10581Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10582From:<tartanpion@machin.truc> 10583 10584Hello, 10585 10586Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10587 10588Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10589 10590Bye. 10591EOM 10592), 10593 'regexmess: 14 Delete header Disposition-Notification-To:'); 10594 10595ok( 10596<<'EOM' 10597Date: Sat, 10 Jul 2010 05:34:45 -0700 10598X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10599From:<tartanpion@machin.truc> 10600 10601Hello, 10602 10603Bye. 10604EOM 10605 eq regexmess( 10606<<'EOM' 10607Date: Sat, 10 Jul 2010 05:34:45 -0700 10608Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10609From:<tartanpion@machin.truc> 10610 10611Hello, 10612 10613Bye. 10614EOM 10615), 10616 'regexmess: 15 Delete header Disposition-Notification-To:'); 10617 10618 10619ok( 10620<<'EOM' 10621Date: Sat, 10 Jul 2010 05:34:45 -0700 10622From:<tartanpion@machin.truc> 10623X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10624 10625Hello, 10626 10627Bye. 10628EOM 10629 eq regexmess( 10630<<'EOM' 10631Date: Sat, 10 Jul 2010 05:34:45 -0700 10632From:<tartanpion@machin.truc> 10633Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10634 10635Hello, 10636 10637Bye. 10638EOM 10639), 10640 'regexmess: 16 Delete header Disposition-Notification-To:'); 10641 10642ok( 10643<<'EOM' 10644X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10645Date: Sat, 10 Jul 2010 05:34:45 -0700 10646From:<tartanpion@machin.truc> 10647 10648Hello, 10649 10650Bye. 10651EOM 10652 eq regexmess( 10653<<'EOM' 10654Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> 10655Date: Sat, 10 Jul 2010 05:34:45 -0700 10656From:<tartanpion@machin.truc> 10657 10658Hello, 10659 10660Bye. 10661EOM 10662), 10663 'regexmess: 17 Delete header Disposition-Notification-To:'); 10664 10665 @regexmess = ( 's/.{11}\K.*//gs' ) ; 10666 is( "0123456789\n", regexmess( "0123456789\n" x 100 ), 'regexmess, truncate whole message after 11 characters' ) ; 10667 is( "0123456789\n", regexmess( "0123456789\n" x 100_000 ), 'regexmess, truncate whole message after 11 characters ~ 1MB' ) ; 10668 10669 @regexmess = ( 's/.{10000}\K.*//gs' ) ; 10670 is( "123456789\n" x 1000, regexmess( "123456789\n" x 100_000 ), 'regexmess, truncate whole message after 10000 characters ~ 1MB' ) ; 10671 10672 10673 10674# regex to play with Date: from the FAQ 10675#@regexmess = 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms' 10676 10677 note( 'Leaving tests_regexmess()' ) ; 10678 return ; 10679 10680} 10681 10682sub regexmess 10683{ 10684 my ( $string ) = @_ ; 10685 foreach my $regexmess ( @regexmess ) { 10686 $sync->{ debug } and myprint( "eval \$string =~ $regexmess\n" ) ; 10687 my $ret = eval "\$string =~ $regexmess ; 1" ; 10688 #myprint( "eval [$ret]\n" ) ; 10689 if ( ( not $ret ) or $EVAL_ERROR ) { 10690 myprint( "Error: eval regexmess '$regexmess': $EVAL_ERROR" ) ; 10691 return( undef ) ; 10692 } 10693 } 10694 $sync->{ debug } and myprint( "$string\n" ) ; 10695 return( $string ) ; 10696} 10697 10698 10699sub tests_skipmess 10700{ 10701 note( 'Entering tests_skipmess()' ) ; 10702 10703 ok( not( defined skipmess( 'blabla' ) ), 'skipmess, no skipmess, no skip' ) ; 10704 10705 @skipmess = ('[') ; 10706 ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex [' ) ; 10707 10708 @skipmess = ('lalala') ; 10709 ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex lalala' ) ; 10710 10711 @skipmess = ('/popopo/') ; 10712 ok( 1 == skipmess( 'popopo' ), 'skipmess, popopo match regex /popopo/' ) ; 10713 10714 @skipmess = ('/popopo/') ; 10715 ok( 0 == skipmess( 'rrrrrr' ), 'skipmess, rrrrrr does not match regex /popopo/' ) ; 10716 10717 @skipmess = ('m{^$}') ; 10718 ok( 1 == skipmess( q{} ), 'skipmess: empty string yes' ) ; 10719 ok( 0 == skipmess( 'Hi!' ), 'skipmess: empty string no' ) ; 10720 10721 @skipmess = ('m{i}') ; 10722 ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ; 10723 ok( 0 == skipmess( 'Bye!' ), 'skipmess: i string no' ) ; 10724 10725 @skipmess = ('m{[\x80-\xff]}') ; 10726 ok( 0 == skipmess( 'Hi!' ), 'skipmess: i 8bit no' ) ; 10727 ok( 1 == skipmess( "\xff" ), 'skipmess: \xff 8bit yes' ) ; 10728 10729 @skipmess = ('m{A}', 'm{B}') ; 10730 ok( 0 == skipmess( 'Hi!' ), 'skipmess: A or B no' ) ; 10731 ok( 0 == skipmess( 'lala' ), 'skipmess: A or B no' ) ; 10732 ok( 0 == skipmess( "\xff" ), 'skipmess: A or B no' ) ; 10733 ok( 1 == skipmess( 'AB' ), 'skipmess: A or B yes' ) ; 10734 ok( 1 == skipmess( 'BA' ), 'skipmess: A or B yes' ) ; 10735 ok( 1 == skipmess( 'AA' ), 'skipmess: A or B yes' ) ; 10736 ok( 1 == skipmess( 'Ok Bye' ), 'skipmess: A or B yes' ) ; 10737 10738 10739 @skipmess = ( 'm#\A((?:[^\n]+\n)+|)^Content-Type: Message/Partial;[^\n]*\n(?:\n|.*\n\n)#ism' ) ; # SUPER BEST! 10740 10741 10742 10743 ok( 1 == skipmess( 10744<<'EOM' 10745Date: Sat, 10 Jul 2010 05:34:45 -0700 10746Content-Type: Message/Partial; blabla 10747From:<tartanpion@machin.truc> 10748 10749Hello! 10750Bye. 10751EOM 10752), 10753 'skipmess: 1 match Content-Type: Message/Partial' ) ; 10754 10755 ok( 0 == skipmess( 10756<<'EOM' 10757Date: Sat, 10 Jul 2010 05:34:45 -0700 10758From:<tartanpion@machin.truc> 10759 10760Hello! 10761Bye. 10762EOM 10763), 10764 'skipmess: 2 not match Content-Type: Message/Partial' ) ; 10765 10766 10767 ok( 1 == skipmess( 10768<<'EOM' 10769Date: Sat, 10 Jul 2010 05:34:45 -0700 10770From:<tartanpion@machin.truc> 10771Content-Type: Message/Partial; blabla 10772 10773Hello! 10774Bye. 10775EOM 10776), 10777 'skipmess: 3 match Content-Type: Message/Partial' ) ; 10778 10779 ok( 0 == skipmess( 10780<<'EOM' 10781Date: Sat, 10 Jul 2010 05:34:45 -0700 10782From:<tartanpion@machin.truc> 10783 10784Hello! 10785Content-Type: Message/Partial; blabla 10786Bye. 10787EOM 10788), 10789 'skipmess: 4 not match Content-Type: Message/Partial' ) ; 10790 10791 10792 ok( 0 == skipmess( 10793<<'EOM' 10794Date: Sat, 10 Jul 2010 05:34:45 -0700 10795From:<tartanpion@machin.truc> 10796 10797Hello! 10798Content-Type: Message/Partial; blabla 10799 10800Bye. 10801EOM 10802), 10803 'skipmess: 5 not match Content-Type: Message/Partial' ) ; 10804 10805 10806 ok( 1 == skipmess( 10807<<'EOM' 10808Date: Sat, 10 Jul 2010 05:34:45 -0700 10809Content-Type: Message/Partial; blabla 10810From:<tartanpion@machin.truc> 10811 10812Hello! 10813 10814Content-Type: Message/Partial; blabla 10815 10816Bye. 10817EOM 10818), 10819 'skipmess: 6 match Content-Type: Message/Partial' ) ; 10820 10821 ok( 1 == skipmess( 10822<<'EOM' 10823Date: Sat, 10 Jul 2010 05:34:45 -0700 10824Content-Type: Message/Partial; 10825From:<tartanpion@machin.truc> 10826 10827Hello! 10828Bye. 10829EOM 10830), 10831 'skipmess: 7 match Content-Type: Message/Partial' ) ; 10832 10833 ok( 1 == skipmess( 10834<<'EOM' 10835Date: Wed, 2 Jul 2014 02:26:40 +0000 10836MIME-Version: 1.0 10837Content-Type: message/partial; 10838 id="TAN_U_P<1404267997.00007489ed17>"; 10839 number=3; 10840 total=3 10841 108426HQ6Hh3CdXj77qEGixerQ6zHx0OnQ/Cf5On4W0Y6vtU2crABZQtD46Hx1EOh8dDz4+OnTr1G 10843 10844 10845Hello! 10846Bye. 10847EOM 10848), 10849 'skipmess: 8 match Content-Type: Message/Partial' ) ; 10850 10851 10852ok( 1 == skipmess( 10853<<'EOM' 10854Return-Path: <gilles@lamiral.info> 10855Received: by lamiral.info (Postfix, from userid 1000) 10856 id 21EB12443BF; Mon, 2 Mar 2015 15:38:35 +0100 (CET) 10857Subject: test: aethaecohngiexao 10858To: <tata@petite.lamiral.info> 10859X-Mailer: mail (GNU Mailutils 2.2) 10860Message-Id: <20150302143835.21EB12443BF@lamiral.info> 10861Content-Type: message/partial; 10862 id="TAN_U_P<1404267997.00007489ed17>"; 10863 number=3; 10864 total=3 10865Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) 10866From: gilles@lamiral.info (Gilles LAMIRAL) 10867 10868test: aethaecohngiexao 10869EOM 10870), 10871 'skipmess: 9 match Content-Type: Message/Partial' ) ; 10872 10873ok( 1 == skipmess( 10874<<'EOM' 10875Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) 10876From: gilles@lamiral.info (Gilles LAMIRAL) 10877Content-Type: message/partial; 10878 id="TAN_U_P<1404267997.00007489ed17>"; 10879 number=3; 10880 total=3 10881 10882test: aethaecohngiexao 10883EOM 10884. "lalala\n" x 3_000_000 10885), 10886 'skipmess: 10 match Content-Type: Message/Partial' ) ; 10887 10888ok( 0 == skipmess( 10889<<'EOM' 10890Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) 10891From: gilles@lamiral.info (Gilles LAMIRAL) 10892 10893test: aethaecohngiexao 10894EOM 10895. "lalala\n" x 3_000_000 10896), 10897 'skipmess: 11 match Content-Type: Message/Partial' ) ; 10898 10899 10900ok( 0 == skipmess( 10901<<"EOM" 10902From: fff\r 10903To: fff\r 10904Subject: Testing imapsync --skipmess\r 10905Date: Mon, 22 Aug 2011 08:40:20 +0800\r 10906Mime-Version: 1.0\r 10907Content-Type: text/plain; charset=iso-8859-1\r 10908Content-Transfer-Encoding: 7bit\r 10909\r 10910EOM 10911. qq{!#"d%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefg\r\n } x 32_730 10912), 10913 'skipmess: 12 not match Content-Type: Message/Partial' ) ; 10914 # Complex regular subexpression recursion limit (32766) exceeded with more lines 10915 # exit; 10916 10917 note( 'Leaving tests_skipmess()' ) ; 10918 return ; 10919} 10920 10921sub skipmess 10922{ 10923 my ( $string ) = @_ ; 10924 my $match ; 10925 #myprint( "$string\n" ) ; 10926 foreach my $skipmess ( @skipmess ) { 10927 $sync->{ debug } and myprint( "eval \$match = \$string =~ $skipmess\n" ) ; 10928 my $ret = eval "\$match = \$string =~ $skipmess ; 1" ; 10929 #myprint( "eval [$ret]\n" ) ; 10930 $sync->{ debug } and myprint( "match [$match]\n" ) ; 10931 if ( ( not $ret ) or $EVAL_ERROR ) { 10932 myprint( "Error: eval skipmess '$skipmess': $EVAL_ERROR" ) ; 10933 return( undef ) ; 10934 } 10935 return( $match ) if ( $match ) ; 10936 } 10937 return( $match ) ; 10938} 10939 10940 10941 10942 10943sub tests_bytes_display_string 10944{ 10945 note( 'Entering tests_bytes_display_string()' ) ; 10946 10947 10948 is( 'NA', bytes_display_string( ), 'bytes_display_string: no args => NA' ) ; 10949 is( 'NA', bytes_display_string( undef ), 'bytes_display_string: undef => NA' ) ; 10950 is( 'NA', bytes_display_string( 'blabla' ), 'bytes_display_string: blabla => NA' ) ; 10951 10952 ok( '0.000 KiB' eq bytes_display_string( 0 ), 'bytes_display_string: 0' ) ; 10953 ok( '0.001 KiB' eq bytes_display_string( 1 ), 'bytes_display_string: 1' ) ; 10954 ok( '0.010 KiB' eq bytes_display_string( 10 ), 'bytes_display_string: 10' ) ; 10955 ok( '1.000 MiB' eq bytes_display_string( 1_048_575 ), 'bytes_display_string: 1_048_575' ) ; 10956 ok( '1.000 MiB' eq bytes_display_string( 1_048_576 ), 'bytes_display_string: 1_048_576' ) ; 10957 10958 ok( '1.000 GiB' eq bytes_display_string( 1_073_741_823 ), 'bytes_display_string: 1_073_741_823 ' ) ; 10959 ok( '1.000 GiB' eq bytes_display_string( 1_073_741_824 ), 'bytes_display_string: 1_073_741_824 ' ) ; 10960 10961 ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_775 ), 'bytes_display_string: 1_099_511_627_775' ) ; 10962 ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_776 ), 'bytes_display_string: 1_099_511_627_776' ) ; 10963 10964 ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_623 ), 'bytes_display_string: 1_125_899_906_842_623' ) ; 10965 ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_624 ), 'bytes_display_string: 1_125_899_906_842_624' ) ; 10966 10967 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' ) ; 10968 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' ) ; 10969 10970 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' ) ; 10971 10972 #myprint( bytes_display_string( 1_180_591_620_717_411_303_424 ), "\n" ) ; 10973 note( 'Leaving tests_bytes_display_string()' ) ; 10974 10975 return ; 10976} 10977 10978sub bytes_display_string 10979{ 10980 my ( $bytes ) = @_ ; 10981 10982 my $readable_value = q{} ; 10983 10984 if ( ! defined( $bytes ) ) { 10985 return( 'NA' ) ; 10986 } 10987 10988 if ( not match_number( $bytes ) ) { 10989 return( 'NA' ) ; 10990 } 10991 10992 10993 10994 SWITCH: { 10995 if ( abs( $bytes ) < ( 1000 * $KIBI ) ) { 10996 $readable_value = mysprintf( '%.3f KiB', $bytes / $KIBI) ; 10997 last SWITCH ; 10998 } 10999 if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI ) ) { 11000 $readable_value = mysprintf( '%.3f MiB', $bytes / ($KIBI * $KIBI) ) ; 11001 last SWITCH ; 11002 } 11003 if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI) ) { 11004 $readable_value = mysprintf( '%.3f GiB', $bytes / ($KIBI * $KIBI * $KIBI) ) ; 11005 last SWITCH ; 11006 } 11007 if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI * $KIBI) ) { 11008 $readable_value = mysprintf( '%.3f TiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI) ) ; 11009 last SWITCH ; 11010 } else { 11011 $readable_value = mysprintf( '%.3f PiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI * $KIBI) ) ; 11012 } 11013 # if you have exabytes (EiB) of email to transfer, you have too much email! 11014 } 11015 #myprint( "$bytes = $readable_value\n" ) ; 11016 return( $readable_value ) ; 11017} 11018 11019 11020sub tests_useheader_suggestion 11021{ 11022 note( 'Entering tests_useheader_suggestion()' ) ; 11023 11024 is( undef, useheader_suggestion( ), 'useheader_suggestion: no args => undef' ) ; 11025 my $mysync = {} ; 11026 11027 $mysync->{ h1_nb_msg_noheader } = 0 ; 11028 is( q{}, useheader_suggestion( $mysync ), 'useheader_suggestion: h1_nb_msg_noheader count null => no suggestion' ) ; 11029 $mysync->{ h1_nb_msg_noheader } = 2 ; 11030 is( q{in order to sync those 2 unidentified messages, add option --addheader}, useheader_suggestion( $mysync ), 11031 'useheader_suggestion: h1_nb_msg_noheader count 2 => suggestion of --addheader' ) ; 11032 11033 note( 'Leaving tests_useheader_suggestion()' ) ; 11034 return ; 11035} 11036 11037sub useheader_suggestion 11038{ 11039 my $mysync = shift ; 11040 if ( ! defined $mysync->{ h1_nb_msg_noheader } ) 11041 { 11042 return ; 11043 } 11044 elsif ( 1 <= $mysync->{ h1_nb_msg_noheader } ) 11045 { 11046 return qq{in order to sync those $mysync->{ h1_nb_msg_noheader } unidentified messages, add option --addheader} ; 11047 } 11048 else 11049 { 11050 return q{} ; 11051 } 11052 return ; 11053} 11054 11055sub stats 11056{ 11057 my $mysync = shift ; 11058 11059 if ( ! $mysync->{stats} ) { 11060 return ; 11061 } 11062 11063 my $timeend = time ; 11064 my $timediff = $timeend - $mysync->{timestart} ; 11065 11066 my $timeend_str = localtime $timeend ; 11067 11068 my $memory_consumption_at_end = memory_consumption( ) || 0 ; 11069 my $memory_consumption_at_start = $mysync->{ memory_consumption_at_start } || 0 ; 11070 my $memory_ratio = ($max_msg_size_in_bytes) ? 11071 mysprintf('%.1f', $memory_consumption_at_end / $max_msg_size_in_bytes) : 'NA' ; 11072 11073 # my $useheader_suggestion = useheader_suggestion( $mysync ) ; 11074 myprint( "++++ Statistics\n" ) ; 11075 myprint( "Transfer started on : $timestart_str\n" ) ; 11076 myprint( "Transfer ended on : $timeend_str\n" ) ; 11077 myprintf( "Transfer time : %.1f sec\n", $timediff ) ; 11078 myprint( "Folders synced : $h1_folders_wanted_ct/$h1_folders_wanted_nb synced\n" ) ; 11079 myprint( "Messages transferred : $mysync->{nb_msg_transferred} " ) ; 11080 myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $mysync->{dry} ) ; 11081 myprint( "\n" ) ; 11082 myprint( "Messages skipped : $mysync->{ nb_msg_skipped }\n" ) ; 11083 myprint( "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n" ) ; 11084 myprint( "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n" ) ; 11085 myprint( "Messages found crossduplicate on host2 : $mysync->{ h2_nb_msg_crossdup }\n" ) ; 11086 myprint( "Messages void (noheader) on host1 : $mysync->{ h1_nb_msg_noheader } ", useheader_suggestion( $mysync ), "\n" ) ; 11087 myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ; 11088 nb_messages_in_1_not_in_2( $mysync ) ; 11089 nb_messages_in_2_not_in_1( $mysync ) ; 11090 myprintf( "Messages found in host1 not in host2 : %s messages\n", $mysync->{ nb_messages_in_1_not_in_2 } ) ; 11091 myprintf( "Messages found in host2 not in host1 : %s messages\n", $mysync->{ nb_messages_in_2_not_in_1 } ) ; 11092 myprint( "Messages deleted on host1 : $mysync->{ h1_nb_msg_deleted }\n" ) ; 11093 myprint( "Messages deleted on host2 : $h2_nb_msg_deleted\n" ) ; 11094 myprintf( "Total bytes transferred : %s (%s)\n", 11095 $mysync->{total_bytes_transferred}, 11096 bytes_display_string( $mysync->{total_bytes_transferred} ) ) ; 11097 myprintf( "Total bytes skipped : %s (%s)\n", 11098 $mysync->{ total_bytes_skipped }, 11099 bytes_display_string( $mysync->{ total_bytes_skipped } ) ) ; 11100 $timediff ||= 1 ; # No division per 0 11101 myprintf("Message rate : %.1f messages/s\n", $mysync->{nb_msg_transferred} / $timediff ) ; 11102 myprintf("Average bandwidth rate : %.1f KiB/s\n", $mysync->{total_bytes_transferred} / $KIBI / $timediff ) ; 11103 myprint( "Reconnections to host1 : $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; 11104 myprint( "Reconnections to host2 : $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; 11105 myprintf("Memory consumption at the end : %.1f MiB (started with %.1f MiB)\n", 11106 $memory_consumption_at_end / $KIBI / $KIBI, 11107 $memory_consumption_at_start / $KIBI / $KIBI ) ; 11108 myprint( "Load end is : " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $mysync->{cpu_number} cores\n" ) ; 11109 11110 myprintf("Biggest message : %s bytes (%s)\n", 11111 $max_msg_size_in_bytes, 11112 bytes_display_string( $max_msg_size_in_bytes) ) ; 11113 myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ; 11114 if ( $foldersizesatend and $foldersizes ) { 11115 11116 11117 my $nb_msg_start_diff = diff_or_NA( $h2_nb_msg_start, $h1_nb_msg_start ) ; 11118 my $bytes_start_diff = diff_or_NA( $h2_bytes_start, $h1_bytes_start ) ; 11119 11120 myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff, 11121 $bytes_start_diff, 11122 bytes_display_string( $bytes_start_diff ) ) ; 11123 11124 my $nb_msg_end_diff = diff_or_NA( $h2_nb_msg_end, $h1_nb_msg_end ) ; 11125 my $bytes_end_diff = diff_or_NA( $h2_bytes_end, $h1_bytes_end ) ; 11126 11127 myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff, 11128 $bytes_end_diff, 11129 bytes_display_string( $bytes_end_diff ) ) ; 11130 } 11131 11132 comment_on_final_diff_in_1_not_in_2( $mysync ) ; 11133 comment_on_final_diff_in_2_not_in_1( $mysync ) ; 11134 myprint( "Detected $mysync->{nb_errors} errors\n\n" ) ; 11135 11136 myprint( $warn_release, "\n" ) ; 11137 myprint( homepage( ), "\n" ) ; 11138 return ; 11139} 11140 11141sub diff_or_NA 11142{ 11143 my( $n1, $n2 ) = @ARG ; 11144 11145 if ( not defined $n1 or not defined $n2 ) { 11146 return 'NA' ; 11147 } 11148 11149 if ( not match_number( $n1 ) 11150 or not match_number( $n2 ) ) { 11151 return 'NA' ; 11152 } 11153 11154 return( $n1 - $n2 ) ; 11155} 11156 11157sub match_number 11158{ 11159 my $n = shift @ARG ; 11160 11161 if ( not defined $n ) { 11162 return 0 ; 11163 } 11164 if ( $n =~ /[0-9]+\.?[0-9]?/x ) { 11165 return 1 ; 11166 } 11167 else { 11168 return 0 ; 11169 } 11170} 11171 11172 11173sub tests_match_number 11174{ 11175 note( 'Entering tests_match_number()' ) ; 11176 11177 11178 is( 0, match_number( ), 'match_number: no parameters => 0' ) ; 11179 is( 0, match_number( undef ), 'match_number: undef => 0' ) ; 11180 is( 0, match_number( 'blabla' ), 'match_number: blabla => 0' ) ; 11181 is( 1, match_number( 0 ), 'match_number: 0 => 1' ) ; 11182 is( 1, match_number( 1 ), 'match_number: 1 => 1' ) ; 11183 is( 1, match_number( 1.0 ), 'match_number: 1.0 => 1' ) ; 11184 is( 1, match_number( 0.0 ), 'match_number: 0.0 => 1' ) ; 11185 11186 note( 'Leaving tests_match_number()' ) ; 11187 return ; 11188} 11189 11190 11191 11192sub tests_diff_or_NA 11193{ 11194 note( 'Entering tests_diff_or_NA()' ) ; 11195 11196 11197 is( 'NA', diff_or_NA( ), 'diff_or_NA: no parameters => NA' ) ; 11198 is( 'NA', diff_or_NA( undef ), 'diff_or_NA: undef => NA' ) ; 11199 is( 'NA', diff_or_NA( undef, undef ), 'diff_or_NA: undef undef => NA' ) ; 11200 is( 'NA', diff_or_NA( undef, 1 ), 'diff_or_NA: undef 1 => NA' ) ; 11201 is( 'NA', diff_or_NA( 1, undef ), 'diff_or_NA: 1 undef => NA' ) ; 11202 is( 'NA', diff_or_NA( 'blabla', 1 ), 'diff_or_NA: blabla 1 => NA' ) ; 11203 is( 'NA', diff_or_NA( 1, 'blabla' ), 'diff_or_NA: 1 blabla => NA' ) ; 11204 is( 0, diff_or_NA( 1, 1 ), 'diff_or_NA: 1 1 => 0' ) ; 11205 is( 1, diff_or_NA( 1, 0 ), 'diff_or_NA: 1 0 => 1' ) ; 11206 is( -1, diff_or_NA( 0, 1 ), 'diff_or_NA: 0 1 => -1' ) ; 11207 is( 0, diff_or_NA( 1.0, 1 ), 'diff_or_NA: 1.0 1 => 0' ) ; 11208 is( 1, diff_or_NA( 1.0, 0 ), 'diff_or_NA: 1.0 0 => 1' ) ; 11209 is( -1, diff_or_NA( 0, 1.0 ), 'diff_or_NA: 0 1.0 => -1' ) ; 11210 11211 note( 'Leaving tests_diff_or_NA()' ) ; 11212 return ; 11213} 11214 11215sub homepage 11216{ 11217 return( 'Homepage: https://imapsync.lamiral.info/' ) ; 11218} 11219 11220 11221sub load_modules 11222{ 11223 if ( $sync->{ssl1} 11224 or $sync->{ssl2} 11225 or $sync->{tls1} 11226 or $sync->{tls2}) { 11227 if ( $sync->{inet4} ) { 11228 IO::Socket::SSL->import( 'inet4' ) ; 11229 } 11230 if ( $sync->{inet6} ) { 11231 IO::Socket::SSL->import( 'inet6' ) ; 11232 } 11233 } 11234 return ; 11235} 11236 11237 11238 11239sub parse_header_msg 11240{ 11241 my ( $mysync, $imap, $m_uid, $s_heads, $s_fir, $side, $s_hash ) = @_ ; 11242 11243 my $head = $s_heads->{$m_uid} ; 11244 my $headnum = scalar keys %{ $head } ; 11245 $mysync->{ debug } and myprint( "$side: uid $m_uid number of headers, pass one: ", $headnum, "\n" ) ; 11246 11247 if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){ 11248 $mysync->{ debug } and myprint( "$side: uid $m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ) ; 11249 $imap->fetch($m_uid, 'BODY.PEEK[HEADER]' ) ; 11250 my $whole_header = $imap->_transaction_literals ; 11251 11252 #myprint( $whole_header ) ; 11253 $head = decompose_header( $whole_header ) ; 11254 11255 $headnum = scalar keys %{ $head } ; 11256 $mysync->{ debug } and myprint( "$side: uid $m_uid number of headers, pass two: ", $headnum, "\n" ) ; 11257 } 11258 11259 #myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ; 11260 11261 my $headstr ; 11262 11263 $headstr = header_construct( $head, $side, $m_uid ) ; 11264 11265 if ( ( ! $headstr ) and ( $mysync->{addheader} ) and ( $side eq 'Host1' ) ) { 11266 my $header = add_header( $m_uid ) ; 11267 $mysync->{ debug } and myprint( "$side: uid $m_uid no header found so adding our own [$header]\n" ) ; 11268 $headstr .= uc $header ; 11269 $s_fir->{$m_uid}->{NO_HEADER} = 1; 11270 } 11271 11272 return if ( ! $headstr ) ; 11273 11274 my $size = $s_fir->{$m_uid}->{'RFC822.SIZE'} ; 11275 my $flags = $s_fir->{$m_uid}->{'FLAGS'} ; 11276 my $idate = $s_fir->{$m_uid}->{'INTERNALDATE'} ; 11277 $size = length $headstr unless ( $size ) ; 11278 my $m_md5 = md5_base64( $headstr ) ; 11279 $mysync->{ debug } and myprint( "$side: uid $m_uid sig $m_md5 size $size idate $idate\n" ) ; 11280 my $key ; 11281 if ($skipsize) { 11282 $key = "$m_md5"; 11283 } 11284 else { 11285 $key = "$m_md5:$size"; 11286 } 11287 # 0 return code is used to identify duplicate message hash 11288 return 0 if exists $s_hash->{"$key"}; 11289 $s_hash->{"$key"}{'5'} = $m_md5; 11290 $s_hash->{"$key"}{'s'} = $size; 11291 $s_hash->{"$key"}{'D'} = $idate; 11292 $s_hash->{"$key"}{'F'} = $flags; 11293 $s_hash->{"$key"}{'m'} = $m_uid; 11294 11295 return( 1 ) ; 11296} 11297 11298sub header_construct 11299{ 11300 11301 my( $head, $side, $m_uid ) = @_ ; 11302 11303 my $headstr ; 11304 foreach my $h ( sort keys %{ $head } ) { 11305 next if ( not ( exists $useheader{ uc $h } ) 11306 and ( not exists $useheader{ 'ALL' } ) 11307 ) ; 11308 foreach my $val ( sort @{$head->{$h}} ) { 11309 11310 my $H = header_line_normalize( $h, $val ) ; 11311 11312 # show stuff in debug mode 11313 $sync->{ debug } and myprint( "$side uid $m_uid header [$H]", "\n" ) ; 11314 11315 if ($skipheader and $H =~ m/$skipheader/xi) { 11316 $sync->{ debug } and myprint( "$side uid $m_uid skipping header [$H]\n" ) ; 11317 next ; 11318 } 11319 $headstr .= "$H" ; 11320 } 11321 } 11322 return( $headstr ) ; 11323} 11324 11325 11326sub header_line_normalize 11327{ 11328 my( $header_key, $header_val ) = @_ ; 11329 11330 # no 8-bit data in headers ! 11331 $header_val =~ s/[\x80-\xff]/X/xog; 11332 11333 # change tabulations to space (Gmail bug on with "Received:" on multilines) 11334 $header_val =~ s/\t/\ /xgo ; 11335 11336 # remove the first blanks ( dbmail bug? ) 11337 $header_val =~ s/^\s*//xo; 11338 11339 # remove the last blanks ( Gmail bug ) 11340 $header_val =~ s/\s*$//xo; 11341 11342 # remove successive blanks ( Mailenable does it ) 11343 $header_val =~ s/\s+/ /xgo; 11344 11345 # remove Message-Id value domain part ( Mailenable changes it ) 11346 if ( ( $messageidnodomain ) and ( 'MESSAGE-ID' eq uc $header_key ) ) { $header_val =~ s/^([^@]+).*$/$1/xo ; } 11347 11348 # and uppercase header line 11349 # (dbmail and dovecot) 11350 11351 my $header_line = uc "$header_key: $header_val" ; 11352 11353 return( $header_line ) ; 11354} 11355 11356sub tests_header_line_normalize 11357{ 11358 note( 'Entering tests_header_line_normalize()' ) ; 11359 11360 11361 ok( ': ' eq header_line_normalize( q{}, q{} ), 'header_line_normalize: empty args' ) ; 11362 ok( 'HHH: VVV' eq header_line_normalize( 'hhh', 'vvv' ), 'header_line_normalize: hhh vvv ' ) ; 11363 ok( 'HHH: VVV' eq header_line_normalize( 'hhh', ' vvv' ), 'header_line_normalize: remove first blancs' ) ; 11364 ok( 'HHH: AA BB CCC D' eq header_line_normalize( 'hhh', 'aa bb ccc d' ), 'header_line_normalize: remove succesive blanks' ) ; 11365 ok( 'HHH: AA BB CCC' eq header_line_normalize( 'hhh', 'aa bb ccc ' ), 'header_line_normalize: remove last blanks' ) ; 11366 ok( 'HHH: VVV XX YY' eq header_line_normalize( 'hhh', "vvv\t\txx\tyy" ), 'header_line_normalize: tabs' ) ; 11367 ok( 'HHH: XABX' eq header_line_normalize( 'hhh', "\x80AB\xff" ), 'header_line_normalize: 8bit' ) ; 11368 11369 note( 'Leaving tests_header_line_normalize()' ) ; 11370 return ; 11371} 11372 11373 11374sub tests_firstline 11375{ 11376 note( 'Entering tests_firstline()' ) ; 11377 11378 is( q{}, firstline( 'W/tmp/tests/noexist.txt' ), 'firstline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; 11379 11380 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'firstline: mkpath W/tmp/tests/' ) ; 11381 11382 is( "blabla\n" , string_to_file( "blabla\n", 'W/tmp/tests/firstline.txt' ), 'firstline: put blabla in W/tmp/tests/firstline.txt' ) ; 11383 is( 'blabla' , firstline( 'W/tmp/tests/firstline.txt' ), 'firstline: get blabla from W/tmp/tests/firstline.txt' ) ; 11384 11385 is( q{} , string_to_file( q{}, 'W/tmp/tests/firstline2.txt' ), 'firstline: put empty string in W/tmp/tests/firstline2.txt' ) ; 11386 is( q{} , firstline( 'W/tmp/tests/firstline2.txt' ), 'firstline: get empty string from W/tmp/tests/firstline2.txt' ) ; 11387 11388 is( "\n" , string_to_file( "\n", 'W/tmp/tests/firstline3.txt' ), 'firstline: put CR in W/tmp/tests/firstline3.txt' ) ; 11389 is( q{} , firstline( 'W/tmp/tests/firstline3.txt' ), 'firstline: get empty string from W/tmp/tests/firstline3.txt' ) ; 11390 11391 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' ) ; 11392 is( 'blabla' , firstline( 'W/tmp/tests/firstline4.txt' ), 'firstline: get blabla from W/tmp/tests/firstline4.txt' ) ; 11393 11394 note( 'Leaving tests_firstline()' ) ; 11395 return ; 11396} 11397 11398sub firstline 11399{ 11400 # extract the first line of a file (without \n) 11401 # return empty string if error or empty string 11402 11403 my $file = shift ; 11404 my $line ; 11405 11406 $line = nthline( $file, 1 ) ; 11407 return $line ; 11408} 11409 11410 11411 11412sub tests_secondline 11413{ 11414 note( 'Entering tests_secondline()' ) ; 11415 11416 is( q{}, secondline( 'W/tmp/tests/noexist.txt' ), 'secondline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; 11417 is( q{}, secondline( 'W/tmp/tests/noexist.txt', 2 ), 'secondline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; 11418 11419 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'secondline: mkpath W/tmp/tests/' ) ; 11420 11421 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' ) ; 11422 is( 'L2' , secondline( 'W/tmp/tests/secondline.txt' ), 'secondline: get L2 from W/tmp/tests/secondline.txt' ) ; 11423 11424 11425 note( 'Leaving tests_secondline()' ) ; 11426 return ; 11427} 11428 11429 11430sub secondline 11431{ 11432 # extract the second line of a file (without \n) 11433 # return empty string if error or empty string 11434 11435 my $file = shift ; 11436 my $line ; 11437 11438 $line = nthline( $file, 2 ) ; 11439 return $line ; 11440} 11441 11442 11443 11444 11445sub tests_nthline 11446{ 11447 note( 'Entering tests_nthline()' ) ; 11448 11449 is( q{}, nthline( 'W/tmp/tests/noexist.txt' ), 'nthline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; 11450 is( q{}, nthline( 'W/tmp/tests/noexist.txt', 2 ), 'nthline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; 11451 11452 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'nthline: mkpath W/tmp/tests/' ) ; 11453 11454 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' ) ; 11455 is( 'L3' , nthline( 'W/tmp/tests/nthline.txt', 3 ), 'nthline: get L3 from W/tmp/tests/nthline.txt' ) ; 11456 11457 11458 note( 'Leaving tests_nthline()' ) ; 11459 return ; 11460} 11461 11462 11463sub nthline 11464{ 11465 # extract the nth line of a file (without \n) 11466 # return empty string if error or empty string 11467 11468 my $file = shift ; 11469 my $num = shift ; 11470 11471 if ( ! all_defined( $file, $num ) ) { return q{} ; } 11472 11473 my $line ; 11474 11475 $line = ( file_to_array( $file ) )[$num - 1] ; 11476 if ( ! defined $line ) 11477 { 11478 return q{} ; 11479 } 11480 else 11481 { 11482 chomp $line ; 11483 return $line ; 11484 } 11485} 11486 11487 11488# Should be unit tested and then be used by file_to_string, refactoring file_to_string 11489sub file_to_array 11490{ 11491 11492 my( $file ) = shift ; 11493 my @string ; 11494 11495 open my $FILE, '<', $file or do { 11496 myprint( "Error reading file $file : $OS_ERROR\n" ) ; 11497 return ; 11498 } ; 11499 @string = <$FILE> ; 11500 close $FILE ; 11501 return( @string ) ; 11502} 11503 11504 11505sub tests_file_to_string 11506{ 11507 note( 'Entering tests_file_to_string()' ) ; 11508 11509 is( undef, file_to_string( ), 'file_to_string: no args => undef' ) ; 11510 is( undef, file_to_string( '/noexist' ), 'file_to_string: /noexist => undef' ) ; 11511 is( undef, file_to_string( '/' ), 'file_to_string: reading a directory => undef' ) ; 11512 ok( file_to_string( $PROGRAM_NAME ), 'file_to_string: reading myself' ) ; 11513 11514 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'file_to_string: mkpath W/tmp/tests/' ) ; 11515 11516 is( 'lilili', string_to_file( 'lilili', 'W/tmp/tests/canbewritten' ), 'file_to_string: string_to_file filling W/tmp/tests/canbewritten with lilili' ) ; 11517 is( 'lilili', file_to_string( 'W/tmp/tests/canbewritten' ), 'file_to_string: reading W/tmp/tests/canbewritten is lilili' ) ; 11518 11519 is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'file_to_string: string_to_file filling W/tmp/tests/empty with empty string' ) ; 11520 is( q{}, file_to_string( 'W/tmp/tests/empty' ), 'file_to_string: reading W/tmp/tests/empty is empty' ) ; 11521 11522 note( 'Leaving tests_file_to_string()' ) ; 11523 return ; 11524} 11525 11526sub file_to_string 11527{ 11528 my $file = shift ; 11529 if ( ! $file ) { return ; } 11530 if ( ! -e $file ) { return ; } 11531 if ( ! -f $file ) { return ; } 11532 if ( ! -r $file ) { return ; } 11533 my @string ; 11534 if ( open my $FILE, '<', $file ) { 11535 @string = <$FILE> ; 11536 close $FILE ; 11537 return( join q{}, @string ) ; 11538 }else{ 11539 myprint( "Error reading file $file : $OS_ERROR\n" ) ; 11540 return ; 11541 } 11542} 11543 11544 11545sub tests_string_to_file 11546{ 11547 note( 'Entering tests_string_to_file()' ) ; 11548 11549 is( undef, string_to_file( ), 'string_to_file: no args => undef' ) ; 11550 is( undef, string_to_file( 'lalala' ), 'string_to_file: one arg => undef' ) ; 11551 is( undef, string_to_file( 'lalala', '.' ), 'string_to_file: writing a directory => undef' ) ; 11552 ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'string_to_file: mkpath W/tmp/tests/' ) ; 11553 is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/canbewritten' ), 'string_to_file: W/tmp/tests/canbewritten with lalala' ) ; 11554 is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'string_to_file: W/tmp/tests/empty with empty string' ) ; 11555 11556 SKIP: { 11557 Readonly my $NB_UNX_tests_string_to_file => 1 ; 11558 skip( 'Not on Unix non-root', $NB_UNX_tests_string_to_file ) if ('MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ; 11559 is( undef, string_to_file( 'lalala', '/cantouch' ), 'string_to_file: /cantouch denied => undef' ) ; 11560 } 11561 11562 note( 'Leaving tests_string_to_file()' ) ; 11563 return ; 11564} 11565 11566sub string_to_file 11567{ 11568 my( $string, $file ) = @_ ; 11569 if( ! defined $string ) { return ; } 11570 if( ! defined $file ) { return ; } 11571 11572 if ( ! -e $file && ! -w dirname( $file ) ) { 11573 myprint( "string_to_file: directory of $file is not writable\n" ) ; 11574 return ; 11575 } 11576 11577 if ( ! sysopen( FILE, $file, O_WRONLY|O_TRUNC|O_CREAT, 0600) ) { 11578 myprint( "string_to_file: failure writing to $file with error: $OS_ERROR\n" ) ; 11579 return ; 11580 } 11581 print FILE $string ; 11582 close FILE ; 11583 return $string ; 11584} 11585 115860 and <<'MULTILINE_COMMENT' ; 11587This is a multiline comment. 11588Based on David Carter discussion, to do: 11589* Call parameters stay the same. 11590* Now always "return( $string, $error )". Descriptions below. 11591OK * Still capture STDOUT via "1> $output_tmpfile" to finish in $string and "return( $string, $error )" 11592OK * Now also capture STDERR via "2> $error_tmpfile" to finish in $error and "return( $string, $error )" 11593OK * in case of CHILD_ERROR, return( undef, $error ) 11594 and print $error, with folder/UID/maybeSubject context, 11595 on console and at the end with the final error listing. Count this as a sync error. 11596* in case of good command, take final $string as is, unless void. In case $error with value then print it. 11597* in case of good command and final $string empty, consider it like CHILD_ERROR => 11598 return( undef, $error ) and print $error, with folder/UID/maybeSubject context, 11599 on console and at the end with the final error listing. Count this as a sync error. 11600MULTILINE_COMMENT 11601# End of multiline comment. 11602 11603sub pipemess 11604{ 11605 my ( $string, @commands ) = @_ ; 11606 my $error = q{} ; 11607 foreach my $command ( @commands ) { 11608 my $input_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.inp.txt" ; 11609 my $output_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.out.txt" ; 11610 my $error_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.err.txt" ; 11611 string_to_file( $string, $input_tmpfile ) ; 11612 ` $command < $input_tmpfile 1> $output_tmpfile 2> $error_tmpfile ` ; 11613 my $is_command_ko = $CHILD_ERROR ; 11614 my $error_cmd = file_to_string( $error_tmpfile ) ; 11615 chomp( $error_cmd ) ; 11616 $string = file_to_string( $output_tmpfile ) ; 11617 my $string_len = length( $string ) ; 11618 unlink $input_tmpfile, $output_tmpfile, $error_tmpfile ; 11619 11620 if ( $is_command_ko or ( ! $string_len ) ) { 11621 my $cmd_exit_value = $CHILD_ERROR >> 8 ; 11622 my $cmd_end_signal = $CHILD_ERROR & 127 ; 11623 my $signal_log = ( $cmd_end_signal ) ? " signal $cmd_end_signal and" : q{} ; 11624 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} ; 11625 myprint( $error_log ) ; 11626 if ( wantarray ) { 11627 return @{ [ undef, $error_log ] } 11628 }else{ 11629 return ; 11630 } 11631 } 11632 if ( $error_cmd ) { 11633 $error .= qq{STDERR of --pipemess "$command": $error_cmd\n} ; 11634 myprint( qq{STDERR of --pipemess "$command": $error_cmd\n} ) ; 11635 } 11636 } 11637 #myprint( "[$string]\n" ) ; 11638 if ( wantarray ) { 11639 return ( $string, $error ) ; 11640 }else{ 11641 return $string ; 11642 } 11643} 11644 11645 11646 11647sub tests_pipemess 11648{ 11649 note( 'Entering tests_pipemess()' ) ; 11650 11651 11652 SKIP: { 11653 Readonly my $NB_WIN_tests_pipemess => 3 ; 11654 skip( 'Not on MSWin32', $NB_WIN_tests_pipemess ) if ('MSWin32' ne $OSNAME) ; 11655 # Windows 11656 # "type" command does not accept redirection of STDIN with < 11657 # "sort" does 11658 ok( "nochange\n" eq pipemess( 'nochange', 'sort' ), 'pipemess: nearly no change by sort' ) ; 11659 ok( "nochange2\n" eq pipemess( 'nochange2', qw( sort sort ) ), 'pipemess: nearly no change by sort,sort' ) ; 11660 # command not found 11661 #diag( 'Warning and failure about cacaprout are on purpose' ) ; 11662 ok( ! defined( pipemess( q{}, 'cacaprout' ) ), 'pipemess: command not found' ) ; 11663 11664 } ; 11665 11666 my ( $stringT, $errorT ) ; 11667 11668 SKIP: { 11669 Readonly my $NB_UNX_tests_pipemess => 25 ; 11670 skip( 'Not on Unix', $NB_UNX_tests_pipemess ) if ('MSWin32' eq $OSNAME) ; 11671 # Unix 11672 ok( 'nochange' eq pipemess( 'nochange', 'cat' ), 'pipemess: no change by cat' ) ; 11673 11674 ok( 'nochange2' eq pipemess( 'nochange2', 'cat', 'cat' ), 'pipemess: no change by cat,cat' ) ; 11675 11676 ok( " 1\tnumberize\n" eq pipemess( "numberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ; 11677 ok( " 1\tnumberize\n 2\tnumberize\n" eq pipemess( "numberize\nnumberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ; 11678 11679 ok( "A\nB\nC\n" eq pipemess( "A\nC\nB\n", 'sort' ), 'pipemess: sort' ) ; 11680 11681 # command not found 11682 #diag( 'Warning and failure about cacaprout are on purpose' ) ; 11683 is( undef, pipemess( q{}, 'cacaprout' ), 'pipemess: command not found' ) ; 11684 11685 # success with true but no output at all 11686 is( undef, pipemess( q{blabla}, 'true' ), 'pipemess: true but no output' ) ; 11687 11688 # failure with false and no output at all 11689 is( undef, pipemess( q{blabla}, 'false' ), 'pipemess: false and no output' ) ; 11690 11691 # Failure since pipemess is not a real pipe, so first cat wait for standard input 11692 is( q{blabla}, pipemess( q{blabla}, '( cat|cat ) ' ), 'pipemess: ok by ( cat|cat )' ) ; 11693 11694 11695 ( $stringT, $errorT ) = pipemess( 'nochange', 'cat' ) ; 11696 is( $stringT, 'nochange', 'pipemess: list context, no change by cat, string' ) ; 11697 is( $errorT, q{}, 'pipemess: list context, no change by cat, no error' ) ; 11698 11699 ( $stringT, $errorT ) = pipemess( 'dontcare', 'true' ) ; 11700 is( $stringT, undef, 'pipemess: list context, true but no output, string' ) ; 11701 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' ) ; 11702 11703 ( $stringT, $errorT ) = pipemess( 'dontcare', 'false' ) ; 11704 is( $stringT, undef, 'pipemess: list context, false and no output, string' ) ; 11705 like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm, 11706 'pipemess: list context, false and no output, error' ) ; 11707 11708 ( $stringT, $errorT ) = pipemess( 'dontcare', '/bin/echo -n blablabla' ) ; 11709 is( $stringT, q{blablabla}, 'pipemess: list context, "echo -n blablabla", string' ) ; 11710 is( $errorT, q{}, 'pipemess: list context, "echo blablabla", error' ) ; 11711 11712 11713 ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ; 11714 is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla", string' ) ; 11715 like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla", error' ) ; 11716 11717 11718 ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )', 'false' ) ; 11719 is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla then false", string' ) ; 11720 like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla then false", error' ) ; 11721 11722 ( $stringT, $errorT ) = pipemess( 'dontcare', 'false', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ; 11723 is( $stringT, undef, 'pipemess: list context, "false then STDERR blablabla", string' ) ; 11724 like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm, 11725 'pipemess: list context, "false then STDERR blablabla", error' ) ; 11726 11727 ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo rrrrr ; echo -n error_blablabla 3>&1 1>&2 2>&3 )' ) ; 11728 like( $stringT, qr{rrrrr}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", string' ) ; 11729 like( $errorT, qr{STDERR.*error_blablabla}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", error' ) ; 11730 11731 } 11732 11733 ( $stringT, $errorT ) = pipemess( 'dontcare', 'cacaprout' ) ; 11734 is( $stringT, undef, 'pipemess: list context, cacaprout not found, string' ) ; 11735 like( $errorT, qr{\QFailure: --pipemess command "cacaprout" ended with "0" characters exit value\E}xm, 11736 'pipemess: list context, cacaprout not found, error' ) ; 11737 11738 note( 'Leaving tests_pipemess()' ) ; 11739 return ; 11740} 11741 11742 11743 11744sub tests_is_a_release_number 11745{ 11746 note( 'Entering tests_is_a_release_number()' ) ; 11747 11748 is( undef, is_a_release_number( ), 'is_a_release_number: no args => undef' ) ; 11749 ok( is_a_release_number( $RELEASE_NUMBER_EXAMPLE_1 ), 'is_a_release_number 1.351' ) ; 11750 ok( is_a_release_number( $RELEASE_NUMBER_EXAMPLE_2 ), 'is_a_release_number 42.4242' ) ; 11751 ok( is_a_release_number( imapsync_version( $sync ) ), 'is_a_release_number imapsync_version( )' ) ; 11752 ok( ! is_a_release_number( 'blabla' ), '! is_a_release_number blabla' ) ; 11753 11754 note( 'Leaving tests_is_a_release_number()' ) ; 11755 return ; 11756} 11757 11758sub is_a_release_number 11759{ 11760 my $number = shift ; 11761 if ( ! defined $number ) { return ; } 11762 return( $number =~ m{^\d+\.\d+$}xo ) ; 11763} 11764 11765 11766 11767sub imapsync_version_public 11768{ 11769 11770 my $local_version = imapsync_version( $sync ) ; 11771 my $imapsync_basename = imapsync_basename( ) ; 11772 my $agent_info = "$OSNAME system, perl " 11773 . mysprintf( '%vd', $PERL_VERSION) 11774 . ", Mail::IMAPClient $Mail::IMAPClient::VERSION" 11775 . " $imapsync_basename" ; 11776 my $sock = IO::Socket::INET->new( 11777 PeerAddr => 'imapsync.lamiral.info', 11778 PeerPort => 80, 11779 Proto => 'tcp', 11780 ) ; 11781 return( 'unknown' ) if not $sock ; 11782 print $sock 11783 "GET /prj/imapsync/VERSION HTTP/1.0\r\n", 11784 "User-Agent: imapsync/$local_version ($agent_info)\r\n", 11785 "Host: ks.lamiral.info\r\n\r\n" ; 11786 my @line = <$sock> ; 11787 close $sock ; 11788 my $last_release = $line[$LAST] ; 11789 chomp $last_release ; 11790 return( $last_release ) ; 11791} 11792 11793sub not_long_imapsync_version_public 11794{ 11795 #myprint( "Entering not_long_imapsync_version_public\n" ) ; 11796 11797 my $fake = shift ; 11798 if ( $fake ) { return $fake } 11799 11800 my $val ; 11801 11802 # Doesn't work with gethostbyname (see perlipc) 11803 #local $SIG{ALRM} = sub { die "alarm\n" } ; 11804 11805 if ('MSWin32' eq $OSNAME) { 11806 local $SIG{ALRM} = sub { die "alarm\n" } ; 11807 }else{ 11808 11809 POSIX::sigaction(SIGALRM, 11810 POSIX::SigAction->new(sub { croak 'alarm' } ) ) 11811 or myprint( "Error setting SIGALRM handler: $OS_ERROR\n" ) ; 11812 } 11813 11814 my $ret = eval { 11815 alarm 3 ; 11816 { 11817 $val = imapsync_version_public( ) ; 11818 #sleep 4 ; 11819 #myprint( "End of imapsync_version_public\n" ) ; 11820 } 11821 alarm 0 ; 11822 1 ; 11823 } ; 11824 #myprint( "eval [$ret]\n" ) ; 11825 if ( ( not $ret ) or $EVAL_ERROR ) { 11826 #myprint( "$EVAL_ERROR" ) ; 11827 if ($EVAL_ERROR =~ /alarm/) { 11828 # timed out 11829 return('timeout') ; 11830 }else{ 11831 alarm 0 ; 11832 return( 'unknown' ) ; # propagate unexpected errors 11833 } 11834 }else { 11835 # Good! 11836 return( $val ) ; 11837 } 11838} 11839 11840sub tests_not_long_imapsync_version_public 11841{ 11842 note( 'Entering tests_not_long_imapsync_version_public()' ) ; 11843 11844 11845 is( 1, is_a_release_number( not_long_imapsync_version_public( ) ), 11846 'not_long_imapsync_version_public: public release is a number' ) ; 11847 11848 note( 'Leaving tests_not_long_imapsync_version_public()' ) ; 11849 return ; 11850} 11851 11852sub check_last_release 11853{ 11854 my $fake = shift ; 11855 my $public_release = not_long_imapsync_version_public( $fake ) ; 11856 $sync->{ debug } and myprint( "check_last_release: [$public_release]\n" ) ; 11857 my $inline_help_when_on = '( Use --noreleasecheck to avoid this release check. )' ; 11858 11859 if ( $public_release eq 'unknown' ) { 11860 return( 'Imapsync public release is unknown.' . $inline_help_when_on ) ; 11861 } 11862 11863 if ( $public_release eq 'timeout' ) { 11864 return( 'Imapsync public release is unknown (timeout).' . $inline_help_when_on ) ; 11865 } 11866 11867 if ( ! is_a_release_number( $public_release ) ) { 11868 return( "Imapsync public release is unknown ($public_release)." . $inline_help_when_on ) ; 11869 } 11870 11871 my $imapsync_here = imapsync_version( $sync ) ; 11872 11873 if ( $public_release > $imapsync_here ) { 11874 return( 'This imapsync is not up to date. ' . "( local $imapsync_here < official $public_release )" . $inline_help_when_on ) ; 11875 }else{ 11876 return( 'This imapsync is up to date. ' . "( local $imapsync_here >= official $public_release )" . $inline_help_when_on ) ; 11877 } 11878 11879 return( 'really unknown' ) ; # Should never arrive here 11880} 11881 11882sub tests_check_last_release 11883{ 11884 note( 'Entering tests_check_last_release()' ) ; 11885 11886 diag( check_last_release( 1.1 ) ) ; 11887 # \Q \E here to avoid putting \ before each space 11888 like( check_last_release( 1.1 ), qr/\Qis up to date\E/mxs, 'check_last_release: up to date' ) ; 11889 like( check_last_release( 1.1 ), qr/1\.1/mxs, 'check_last_release: up to date, include number' ) ; 11890 diag( check_last_release( 999.999 ) ) ; 11891 like( check_last_release( 999.999 ), qr/\Qnot up to date\E/mxs, 'check_last_release: not up to date' ) ; 11892 like( check_last_release( 999.999 ), qr/999\.999/mxs, 'check_last_release: not up to date, include number' ) ; 11893 like( check_last_release( 'unknown' ), qr/\QImapsync public release is unknown\E/mxs, 'check_last_release: unknown' ) ; 11894 like( check_last_release( 'timeout' ), qr/\QImapsync public release is unknown (timeout)\E/mxs, 'check_last_release: timeout' ) ; 11895 like( check_last_release( 'lalala' ), qr/\QImapsync public release is unknown (lalala)\E/mxs, 'check_last_release: lalala' ) ; 11896 diag( check_last_release( ) ) ; 11897 11898 note( 'Leaving tests_check_last_release()' ) ; 11899 return ; 11900} 11901 11902sub imapsync_version 11903{ 11904 my $mysync = shift ; 11905 my $rcs = $mysync->{rcs} ; 11906 my $version ; 11907 11908 $version = version_from_rcs( $rcs ) ; 11909 return( $version ) ; 11910} 11911 11912 11913sub tests_version_from_rcs 11914{ 11915 note( 'Entering tests_version_from_rcs()' ) ; 11916 11917 is( undef, version_from_rcs( ), 'version_from_rcs: no args => UNKNOWN' ) ; 11918 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' ) ; 11919 is( 'UNKNOWN', version_from_rcs( 1.831 ), 'version_from_rcs: 1.831 => UNKNOWN' ) ; 11920 11921 note( 'Leaving tests_version_from_rcs()' ) ; 11922 return ; 11923} 11924 11925 11926sub version_from_rcs 11927{ 11928 11929 my $rcs = shift ; 11930 if ( ! $rcs ) { return ; } 11931 11932 my $version = 'UNKNOWN' ; 11933 11934 if ( $rcs =~ m{,v\s+(\d+\.\d+)}mxso ) { 11935 $version = $1 11936 } 11937 11938 return( $version ) ; 11939} 11940 11941 11942sub tests_imapsync_basename 11943{ 11944 note( 'Entering tests_imapsync_basename()' ) ; 11945 11946 ok( imapsync_basename() =~ m/imapsync/, 'imapsync_basename: match imapsync'); 11947 ok( 'blabla' ne imapsync_basename(), 'imapsync_basename: do not equal blabla'); 11948 11949 note( 'Leaving tests_imapsync_basename()' ) ; 11950 return ; 11951} 11952 11953sub imapsync_basename 11954{ 11955 11956 return basename( $PROGRAM_NAME ) ; 11957 11958} 11959 11960 11961sub localhost_info 11962{ 11963 my $mysync = shift ; 11964 my( $infos ) = join( q{}, 11965 "Here is imapsync ", imapsync_version( $mysync ), 11966 " on host " . hostname(), 11967 ", a $OSNAME system with ", 11968 ram_memory_info( ), 11969 "\n", 11970 'with Perl ', 11971 mysprintf( '%vd ', $PERL_VERSION), 11972 "and Mail::IMAPClient $Mail::IMAPClient::VERSION", 11973 ) ; 11974 return( $infos ) ; 11975} 11976 11977sub tests_cpu_number 11978{ 11979 note( 'Entering tests_cpu_number()' ) ; 11980 11981 is( 1, is_an_integer( cpu_number( ) ), "cpu_number: is_an_integer" ) ; 11982 ok( 1 <= cpu_number( ), "cpu_number: 1 or more" ) ; 11983 is( 1, cpu_number( 1 ), "cpu_number: 1 => 1" ) ; 11984 is( 1, cpu_number( $MINUS_ONE ), "cpu_number: -1 => 1" ) ; 11985 is( 1, cpu_number( 'lalala' ), "cpu_number: lalala => 1" ) ; 11986 is( $NUMBER_42, cpu_number( $NUMBER_42 ), "cpu_number: $NUMBER_42 => $NUMBER_42" ) ; 11987 note( 'Leaving tests_cpu_number()' ) ; 11988 return ; 11989} 11990 11991sub cpu_number 11992{ 11993 11994 my $cpu_number_forced = shift ; 11995 # Well, here 1 is better than 0 or undef 11996 my $cpu_number = 1 ; # Default value, erased if better found 11997 11998 my @cpuinfo ; 11999 if ( $ENV{"NUMBER_OF_PROCESSORS"} ) { 12000 # might be under a Windows system 12001 $cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ; 12002 $sync->{ debug } and myprint( "Number of processors found by env var NUMBER_OF_PROCESSORS: $cpu_number\n" ) ; 12003 }elsif ( 'darwin' eq $OSNAME or 'freebsd' eq $OSNAME ) { 12004 $cpu_number = backtick( "sysctl -n hw.ncpu" ) ; 12005 chomp( $cpu_number ) ; 12006 $sync->{ debug } and myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ; 12007 }elsif ( ! -e '/proc/cpuinfo' ) { 12008 $sync->{ debug } and myprint( "Number of processors not found so I might assume there is only 1\n" ) ; 12009 $cpu_number = 1 ; 12010 }elsif( @cpuinfo = file_to_array( '/proc/cpuinfo' ) ) { 12011 $cpu_number = grep { /^processor/mxs } @cpuinfo ; 12012 $sync->{ debug } and myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ; 12013 } 12014 12015 if ( defined $cpu_number_forced ) { 12016 $cpu_number = $cpu_number_forced ; 12017 } 12018 return( integer_or_1( $cpu_number ) ) ; 12019} 12020 12021 12022sub tests_integer_or_1 12023{ 12024 note( 'Entering tests_integer_or_1()' ) ; 12025 12026 is( 1, integer_or_1( ), 'integer_or_1: no args => 1' ) ; 12027 is( 1, integer_or_1( undef ), 'integer_or_1: undef => 1' ) ; 12028 is( $NUMBER_10, integer_or_1( $NUMBER_10 ), 'integer_or_1: 10 => 10' ) ; 12029 is( 1, integer_or_1( q{} ), 'integer_or_1: empty string => 1' ) ; 12030 is( 1, integer_or_1( 'lalala' ), 'integer_or_1: lalala => 1' ) ; 12031 12032 note( 'Leaving tests_integer_or_1()' ) ; 12033 return ; 12034} 12035 12036sub integer_or_1 12037{ 12038 my $number = shift ; 12039 if ( is_an_integer( $number ) ) { 12040 return $number ; 12041 } 12042 # else 12043 return 1 ; 12044} 12045 12046sub tests_is_an_integer 12047{ 12048 note( 'Entering tests_is_an_integer()' ) ; 12049 12050 is( undef, is_an_integer( ), 'is_an_integer: no args => undef ' ) ; 12051 ok( is_an_integer( 1 ), 'is_an_integer: 1 => yes ') ; 12052 ok( is_an_integer( $NUMBER_42 ), 'is_an_integer: 42 => yes ') ; 12053 ok( is_an_integer( "$NUMBER_42" ), 'is_an_integer: "$NUMBER_42" => yes ') ; 12054 ok( is_an_integer( '42' ), 'is_an_integer: "42" => yes ') ; 12055 ok( is_an_integer( $NUMBER_104_857_600 ), 'is_an_integer: 104_857_600 => yes') ; 12056 ok( is_an_integer( "$NUMBER_104_857_600" ), 'is_an_integer: "$NUMBER_104_857_600" => yes') ; 12057 ok( is_an_integer( '104857600' ), 'is_an_integer: 104857600 => yes') ; 12058 ok( ! is_an_integer( 'blabla' ), 'is_an_integer: blabla => no' ) ; 12059 ok( ! is_an_integer( q{} ), 'is_an_integer: empty string => no' ) ; 12060 12061 note( 'Leaving tests_is_an_integer()' ) ; 12062 return ; 12063} 12064 12065sub is_an_integer 12066{ 12067 my $number = shift ; 12068 if ( ! defined $number ) { return ; } 12069 return( $number =~ m{^\d+$}xo ) ; 12070} 12071 12072 12073 12074 12075sub tests_loadavg 12076{ 12077 note( 'Entering tests_loadavg()' ) ; 12078 12079 12080 SKIP: { 12081 skip( 'Tests for darwin', 2 ) if ('darwin' ne $OSNAME) ; 12082 is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ; 12083 is_deeply( [ '0.11', '0.22', '0.33' ], 12084 [ loadavg( 'W/t/loadavg.out' ) ], 12085 'loadavg W/t/loadavg.out => 0.11 0.22 0.33' ) ; 12086 } ; 12087 12088 SKIP: { 12089 skip( 'Tests for linux', 3 ) if ('linux' ne $OSNAME) ; 12090 is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ; 12091 ok( loadavg( ), 'loadavg: no args' ) ; 12092 12093 is_deeply( [ '0.39', '0.30', '0.37', '1/602' ], 12094 [ loadavg( '0.39 0.30 0.37 1/602 6073' ) ], 12095 'loadavg 0.39 0.30 0.37 1/602 6073 => [0.39, 0.30, 0.37, 1/602]' ) ; 12096 } ; 12097 12098 SKIP: { 12099 skip( 'Tests for Windows', 1 ) if ('MSWin32' ne $OSNAME) ; 12100 is_deeply( [ 0 ], 12101 [ loadavg( ) ], 12102 'loadavg on MSWin32 => 0' ) ; 12103 12104 } ; 12105 12106 note( 'Leaving tests_loadavg()' ) ; 12107 return ; 12108} 12109 12110 12111sub loadavg 12112{ 12113 if ( 'linux' eq $OSNAME ) { 12114 return ( loadavg_linux( @ARG ) ) ; 12115 } 12116 if ( 'freebsd' eq $OSNAME ) { 12117 return ( loadavg_freebsd( @ARG ) ) ; 12118 } 12119 if ( 'darwin' eq $OSNAME ) { 12120 return ( loadavg_darwin( @ARG ) ) ; 12121 } 12122 if ( 'MSWin32' eq $OSNAME ) { 12123 return ( loadavg_windows( @ARG ) ) ; 12124 } 12125 return( 'unknown' ) ; 12126 12127} 12128 12129sub loadavg_linux 12130{ 12131 my $line = shift ; 12132 12133 if ( ! $line ) { 12134 $line = firstline( '/proc/loadavg' ) or return ; 12135 } 12136 12137 my ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) = split /\s/mxs, $line ; 12138 if ( all_defined( $avg_1_min, $avg_5_min, $avg_15_min ) ) { 12139 $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min $current_runs\n" ) ; 12140 return ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) ; 12141 } 12142 return ; 12143} 12144 12145sub loadavg_freebsd 12146{ 12147 my $file = shift ; 12148 # Example of output of command "sysctl vm.loadavg": 12149 # vm.loadavg: { 0.15 0.08 0.08 } 12150 my $loadavg ; 12151 12152 if ( ! defined $file ) { 12153 eval { 12154 $loadavg = `/sbin/sysctl vm.loadavg` ; 12155 #myprint( "LOADAVG FREEBSD: $loadavg\n" ) ; 12156 } ; 12157 if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } 12158 }else{ 12159 $loadavg = firstline( $file ) or return ; 12160 } 12161 12162 my ( $avg_1_min, $avg_5_min, $avg_15_min ) 12163 = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ; 12164 $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ; 12165 return ( $avg_1_min, $avg_5_min, $avg_15_min ) ; 12166} 12167 12168sub loadavg_darwin 12169{ 12170 my $file = shift ; 12171 # Example of output of command "sysctl vm.loadavg": 12172 # vm.loadavg: { 0.15 0.08 0.08 } 12173 my $loadavg ; 12174 12175 if ( ! defined $file ) { 12176 eval { 12177 $loadavg = `/usr/sbin/sysctl vm.loadavg` ; 12178 #myprint( "LOADAVG DARWIN: $loadavg\n" ) ; 12179 } ; 12180 if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } 12181 }else{ 12182 $loadavg = firstline( $file ) or return ; 12183 } 12184 12185 my ( $avg_1_min, $avg_5_min, $avg_15_min ) 12186 = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ; 12187 $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ; 12188 return ( $avg_1_min, $avg_5_min, $avg_15_min ) ; 12189} 12190 12191sub loadavg_windows 12192{ 12193 my $file = shift ; 12194 # Example of output of command "wmic cpu get loadpercentage": 12195 # LoadPercentage 12196 # 12 12197 my $loadavg ; 12198 12199 if ( ! defined $file ) { 12200 eval { 12201 #$loadavg = `CMD wmic cpu get loadpercentage` ; 12202 $loadavg = "LoadPercentage\n0\n" ; 12203 #myprint( "LOADAVG WIN: $loadavg\n" ) ; 12204 } ; 12205 if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } 12206 }else{ 12207 $loadavg = file_to_string( $file ) or return ; 12208 #myprint( "$loadavg" ) ; 12209 } 12210 $loadavg =~ /LoadPercentage\n(\d+)/xms ; 12211 my $num = $1 ; 12212 $num /= 100 ; 12213 12214 $sync->{ debug } and myprint( "System load: $num\n" ) ; 12215 return ( $num ) ; 12216} 12217 12218 12219 12220 12221 12222 12223sub tests_load_and_delay 12224{ 12225 note( 'Entering tests_load_and_delay()' ) ; 12226 12227 is( undef, load_and_delay( ), 'load_and_delay: no args => undef ' ) ; 12228 is( undef, load_and_delay( 1 ), 'load_and_delay: not 4 args => undef ' ) ; 12229 is( undef, load_and_delay( 0, 1, 1, 1 ), 'load_and_delay: division per 0 => undef ' ) ; 12230 is( 0, load_and_delay( 1, 1, 1, 1 ), 'load_and_delay: one core, loads are all 1 => ok ' ) ; 12231 is( 0, load_and_delay( 1, 1, 1, 1, 'lalala' ), 'load_and_delay: five arguments is ok' ) ; 12232 is( 0, load_and_delay( 2, 2, 2, 2 ), 'load_and_delay: two core, loads are all 2 => ok ' ) ; 12233 is( 0, load_and_delay( 2, 2, 4, 5 ), 'load_and_delay: two core, load1m is 2 => ok ' ) ; 12234 12235# Old behavior, rather strict 12236 # is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; 12237 # is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; 12238 # is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; 12239 # is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; 12240 # is( 1, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; 12241 # is( 1, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; 12242 # is( 5, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; 12243 # is( 15, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; 12244 12245 # is( 0, load_and_delay( 4, 0, 2, 2 ), 'load_and_delay: four core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; 12246 # is( 1, load_and_delay( 4, 8, 0, 0 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; 12247 # is( 1, load_and_delay( 4, 8, 0, 2 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; 12248 # is( 5, load_and_delay( 4, 8, 8, 0 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; 12249 # is( 15, load_and_delay( 4, 8, 8, 8 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; 12250 12251# New behavior, tolerate more load 12252 12253 is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; 12254 is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; 12255 is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; 12256 is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; 12257 is( 0, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; 12258 is( 0, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; 12259 is( 0, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; 12260 is( 0, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; 12261 12262 is( 1, load_and_delay( 1, 4, 0, 0 ), 'load_and_delay: one core, load1m=4 load5m=0 load15m=0 => 1 ' ) ; 12263 is( 1, load_and_delay( 1, 4, 0, 4 ), 'load_and_delay: one core, load1m=4 load5m=0 load15m=4 => 1 ' ) ; 12264 is( 5, load_and_delay( 1, 4, 4, 0 ), 'load_and_delay: one core, load1m=4 load5m=4 load15m=0 => 5 ' ) ; 12265 is( 15, load_and_delay( 1, 4, 4, 4 ), 'load_and_delay: one core, load1m=4 load5m=4 load15m=4 => 15 ' ) ; 12266 12267 is( 0, load_and_delay( 4, 0, 9, 9 ), 'load_and_delay: four core, load1m=0 load5m=9 load15m=9 => 0 ' ) ; 12268 is( 1, load_and_delay( 4, 9, 0, 0 ), 'load_and_delay: four core, load1m=9 load5m=0 load15m=0 => 1 ' ) ; 12269 is( 1, load_and_delay( 4, 9, 0, 9 ), 'load_and_delay: four core, load1m=9 load5m=0 load15m=9 => 1 ' ) ; 12270 is( 5, load_and_delay( 4, 9, 9, 0 ), 'load_and_delay: four core, load1m=9 load5m=9 load15m=0 => 5 ' ) ; 12271 is( 15, load_and_delay( 4, 9, 9, 9 ), 'load_and_delay: four core, load1m=9 load5m=9 load15m=9 => 15 ' ) ; 12272 12273 note( 'Leaving tests_load_and_delay()' ) ; 12274 return ; 12275} 12276 12277sub load_and_delay 12278{ 12279 # Basically return 0 if load is not heavy, ie <= 1 per processor 12280 12281 # Not enough arguments 12282 if ( 4 > scalar @ARG ) { return ; } 12283 12284 my ( $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ; 12285 12286 if ( 0 == $cpu_num ) { return ; } 12287 12288 # Let divide by number of cores 12289 ( $avg_1_min, $avg_5_min, $avg_15_min ) = map { $_ / $cpu_num } ( $avg_1_min, $avg_5_min, $avg_15_min ) ; 12290 # One of avg ok => ok, for now it is a OR 12291 if ( $avg_1_min <= 2 ) { return 0 ; } 12292 if ( $avg_5_min <= 2 ) { return 1 ; } # Retry in 1 minute 12293 if ( $avg_15_min <= 2 ) { return 5 ; } # Retry in 5 minutes 12294 return 15 ; # Retry in 15 minutes 12295} 12296 12297sub ram_memory_info 12298{ 12299 # In GigaBytes so division by 1024 * 1024 * 1024 12300 # 12301 return( 12302 sprintf( "%.1f/%.1f free GiB of RAM", 12303 Sys::MemInfo::get("freemem") / ( $KIBI ** 3 ), 12304 Sys::MemInfo::get("totalmem") / ( $KIBI ** 3 ), 12305 ) 12306 ) ; 12307} 12308 12309 12310 12311sub tests_memory_stress 12312{ 12313 note( 'Entering tests_memory_stress()' ) ; 12314 12315 is( undef, memory_stress( ), 'memory_stress: => undef' ) ; 12316 12317 note( 'Leaving tests_memory_stress()' ) ; 12318 return ; 12319} 12320 12321sub memory_stress 12322{ 12323 12324 my $total_ram_in_MB = Sys::MemInfo::get("totalmem") / ( $KIBI * $KIBI ) ; 12325 my $i = 1 ; 12326 12327 myprintf("Stress memory consumption before: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; 12328 while ( $i < $total_ram_in_MB / 1.7 ) { $a .= "A" x 1000_000; $i++ } ; 12329 myprintf("Stress memory consumption after: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; 12330 return ; 12331 12332} 12333 12334sub tests_memory_consumption 12335{ 12336 note( 'Entering tests_memory_consumption()' ) ; 12337 12338 like( memory_consumption( ), qr{\d+}xms,'memory_consumption no args') ; 12339 like( memory_consumption( 1 ), qr{\d+}xms,'memory_consumption 1') ; 12340 like( memory_consumption( $PROCESS_ID ), qr{\d+}xms,"memory_consumption_of_pids $PROCESS_ID") ; 12341 12342 like( memory_consumption_ratio(), qr{\d+}xms, 'memory_consumption_ratio' ) ; 12343 like( memory_consumption_ratio(1), qr{\d+}xms, 'memory_consumption_ratio 1' ) ; 12344 like( memory_consumption_ratio(10), qr{\d+}xms, 'memory_consumption_ratio 10' ) ; 12345 12346 like( memory_consumption(), qr{\d+}xms, "memory_consumption\n" ) ; 12347 12348 note( 'Leaving tests_memory_consumption()' ) ; 12349 return ; 12350} 12351 12352sub memory_consumption 12353{ 12354 # memory consumed by imapsync until now in bytes 12355 return( ( memory_consumption_of_pids( ) )[0] ); 12356} 12357 12358sub debugmemory 12359{ 12360 my $mysync = shift ; 12361 if ( ! $mysync->{debugmemory} ) { return q{} ; } 12362 12363 my $precision = shift ; 12364 return( mysprintf( "Memory consumption$precision: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ) ; 12365} 12366 12367sub memory_consumption_of_pids 12368{ 12369 12370 my @pid = @_; 12371 @pid = ( @pid ) ? @pid : ( $PROCESS_ID ) ; 12372 12373 $sync->{ debug } and myprint( "memory_consumption_of_pids PIDs: @pid\n" ) ; 12374 my @val ; 12375 if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) { 12376 @val = memory_consumption_of_pids_win32( @pid ) ; 12377 }else{ 12378 # Unix 12379 my @ps = qx{ ps -o vsz -p @pid } ; 12380 #myprint( "ps: @ps" ) ; 12381 12382 # Use IPC::Open3 from perlcrit -3 12383 # It stalls on Darwin, don't understand why! 12384 #my @ps = backtick( "ps -o vsz -p @pid" ) ; 12385 #myprint( "ps: @ps" ) ; 12386 12387 shift @ps; # First line is column name "VSZ" 12388 chomp @ps; 12389 # convert to octets 12390 12391 @val = map { $_ * $KIBI } @ps ; 12392 } 12393 $sync->{ debug } and myprint( "@val\n" ) ; 12394 return( @val ) ; 12395} 12396 12397sub memory_consumption_of_pids_win32 12398{ 12399 # Windows 12400 my @PID = @_; 12401 my %PID; 12402 # hash of pids as key values 12403 map { $PID{$_}++ } @PID; 12404 12405 # Does not work but should work reading the tasklist documentation 12406 #@ps = qx{ tasklist /FI "PID eq @PID" }; 12407 12408 my @ps = qx{ tasklist /NH /FO CSV } ; 12409 #my @ps = backtick( 'tasklist /NH /FO CSV' ) ; 12410 #myprint( "-" x $STD_CHAR_PER_LINE, "\n", @ps, "-" x $STD_CHAR_PER_LINE, "\n" ) ; 12411 my @val; 12412 foreach my $line (@ps) { 12413 my($name, $pid, $mem) = (split ',', $line )[0,1,4]; 12414 next if (! $pid); 12415 #myprint( "[$name][$pid][$mem]" ) ; 12416 if ($PID{remove_qq($pid)}) { 12417 #myprint( "MATCH !\n" ) ; 12418 chomp $mem ; 12419 $mem = remove_qq($mem); 12420 $mem = remove_Ko($mem); 12421 $mem = remove_not_num($mem); 12422 #myprint( "[$mem]\n" ) ; 12423 push @val, $mem * $KIBI; 12424 } 12425 } 12426 return(@val); 12427} 12428 12429 12430sub tests_backtick 12431{ 12432 note( 'Entering tests_backtick()' ) ; 12433 12434 is( undef, backtick( ), 'backtick: no args' ) ; 12435 is( undef, backtick( q{} ), 'backtick: empty command' ) ; 12436 12437 SKIP: { 12438 skip( 'test for MSWin32', 5 ) if ('MSWin32' ne $OSNAME) ; 12439 my @output ; 12440 @output = backtick( 'echo Hello World!' ) ; 12441 # Add \r on Windows. 12442 ok( "Hello World!\r\n" eq $output[0], 'backtick: echo Hello World!' ) ; 12443 $sync->{ debug } and myprint( "[@output]" ) ; 12444 @output = backtick( 'echo Hello & echo World!' ) ; 12445 ok( "Hello \r\n" eq $output[0], 'backtick: echo Hello & echo World! line 1' ) ; 12446 ok( "World!\r\n" eq $output[1], 'backtick: echo Hello & echo World! line 2' ) ; 12447 $sync->{ debug } and myprint( "[@output][$output[0]][$output[1]]" ) ; 12448 # Scalar context 12449 ok( "Hello World!\r\n" eq backtick( 'echo Hello World!' ), 12450 'backtick: echo Hello World! scalar' ) ; 12451 ok( "Hello \r\nWorld!\r\n" eq backtick( 'echo Hello & echo World!' ), 12452 'backtick: echo Hello & echo World! scalar 2 lines' ) ; 12453 } ; 12454 SKIP: { 12455 skip( 'test for Unix', 7 ) if ('MSWin32' eq $OSNAME) ; 12456 is( undef, backtick( 'aaaarrrg' ), 'backtick: aaaarrrg command not found' ) ; 12457 # Array context 12458 my @output ; 12459 @output = backtick( 'echo Hello World!' ) ; 12460 ok( "Hello World!\n" eq $output[0], 'backtick: echo Hello World!' ) ; 12461 $sync->{ debug } and myprint( "[@output]" ) ; 12462 @output = backtick( "echo Hello\necho World!" ) ; 12463 ok( "Hello\n" eq $output[0], 'backtick: echo Hello; echo World! line 1' ) ; 12464 ok( "World!\n" eq $output[1], 'backtick: echo Hello; echo World! line 2' ) ; 12465 $sync->{ debug } and myprint( "[@output]" ) ; 12466 # Scalar context 12467 ok( "Hello World!\n" eq backtick( 'echo Hello World!' ), 12468 'backtick: echo Hello World! scalar' ) ; 12469 ok( "Hello\nWorld!\n" eq backtick( "echo Hello\necho World!" ), 12470 'backtick: echo Hello; echo World! scalar 2 lines' ) ; 12471 # Return error positive value, that's ok 12472 is( undef, backtick( 'false' ), 'backtick: false returns no output' ) ; 12473 my $mem = backtick( "ps -o vsz -p $PROCESS_ID" ) ; 12474 $sync->{ debug } and myprint( "MEM=$mem\n" ) ; 12475 12476 } 12477 12478 note( 'Leaving tests_backtick()' ) ; 12479 return ; 12480} 12481 12482 12483sub backtick 12484{ 12485 my $command = shift ; 12486 12487 if ( ! $command ) { return ; } 12488 12489 my ( $writer, $reader, $err ) ; 12490 my @output ; 12491 my $pid ; 12492 my $eval = eval { 12493 $pid = IPC::Open3::open3( $writer, $reader, $err, $command ) ; 12494 } ; 12495 if ( $EVAL_ERROR ) { 12496 myprint( $EVAL_ERROR ) ; 12497 return ; 12498 } 12499 if ( ! $eval ) { return ; } 12500 if ( ! $pid ) { return ; } 12501 waitpid( $pid, 0 ) ; 12502 @output = <$reader>; # Output here 12503 # 12504 #my @errors = <$err>; #Errors here, instead of the console 12505 if ( not @output ) { return ; } 12506 #myprint( @output ) ; 12507 12508 if ( $output[0] =~ /\Qopen3: exec of $command failed\E/mxs ) { return ; } 12509 if ( wantarray ) { 12510 return( @output ) ; 12511 } else { 12512 return( join( q{}, @output) ) ; 12513 } 12514} 12515 12516 12517 12518sub tests_check_binary_embed_all_dyn_libs 12519{ 12520 note( 'Entering tests_check_binary_embed_all_dyn_libs()' ) ; 12521 12522 is( 1, check_binary_embed_all_dyn_libs( ), 'check_binary_embed_all_dyn_libs: no args => 1' ) ; 12523 12524 note( 'Leaving tests_check_binary_embed_all_dyn_libs()' ) ; 12525 12526 return ; 12527} 12528 12529 12530sub check_binary_embed_all_dyn_libs 12531{ 12532 my @search_dyn_lib_locale = search_dyn_lib_locale( ) ; 12533 12534 if ( @search_dyn_lib_locale ) 12535 { 12536 myprint( "Found myself $PROGRAM_NAME pid $PROCESS_ID using locale dynamic libraries that seems out of myself:\n" ) ; 12537 myprint( @search_dyn_lib_locale ) ; 12538 if ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} ) 12539 { 12540 return 0 ; 12541 } 12542 elsif ( $PROGRAM_NAME =~ m{imapsync.*\.exe} ) 12543 { 12544 return 0 ; 12545 } 12546 else 12547 { 12548 # is always ok for non binary 12549 return 1 ; 12550 } 12551 } 12552 else 12553 { 12554 # Found only embedded dynamic lib 12555 myprint( "Found nothing\n" ) ; 12556 return 1 ; 12557 } 12558} 12559 12560sub search_dyn_lib_locale 12561{ 12562 if ( 'darwin' eq $OSNAME ) 12563 { 12564 return search_dyn_lib_locale_darwin( ) ; 12565 } 12566 if ( 'linux' eq $OSNAME ) 12567 { 12568 return search_dyn_lib_locale_linux( ) ; 12569 } 12570 if ( 'MSWin32' eq $OSNAME ) 12571 { 12572 return search_dyn_lib_locale_MSWin32( ) ; 12573 } 12574} 12575 12576sub search_dyn_lib_locale_darwin 12577{ 12578 my $command = qq{ lsof -p $PID | grep ' REG ' | grep .dylib | grep -v '/par-' } ; 12579 myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; 12580 return backtick( $command ) ; 12581} 12582 12583sub search_dyn_lib_locale_linux 12584{ 12585 my $command = qq{ lsof -p $PID | grep ' REG ' | grep -v '/tmp/par-' | grep '\.so' } ; 12586 myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; 12587 return backtick( $command ) ; 12588} 12589 12590sub search_dyn_lib_locale_MSWin32 12591{ 12592 my $command = qq{ Listdlls.exe $PID|findstr Strawberry } ; 12593 # $command = qq{ Listdlls.exe $PID|findstr Strawberry } ; 12594 myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; 12595 return qx( $command ) ; 12596} 12597 12598 12599 12600sub remove_not_num 12601{ 12602 12603 my $string = shift ; 12604 $string =~ tr/0-9//cd ; 12605 #myprint( "tr [$string]\n" ) ; 12606 return( $string ) ; 12607} 12608 12609sub tests_remove_not_num 12610{ 12611 note( 'Entering tests_remove_not_num()' ) ; 12612 12613 ok( '123' eq remove_not_num( 123 ), 'remove_not_num( 123 )' ) ; 12614 ok( '123' eq remove_not_num( '123' ), q{remove_not_num( '123' )} ) ; 12615 ok( '123' eq remove_not_num( '12 3' ), q{remove_not_num( '12 3' )} ) ; 12616 ok( '123' eq remove_not_num( 'a 12 3 Ko' ), q{remove_not_num( 'a 12 3 Ko' )} ) ; 12617 12618 note( 'Leaving tests_remove_not_num()' ) ; 12619 return ; 12620} 12621 12622sub remove_Ko 12623{ 12624 my $string = shift; 12625 if ($string =~ /^(.*)\sKo$/xo) { 12626 return($1); 12627 }else{ 12628 return($string); 12629 } 12630} 12631 12632sub remove_qq 12633{ 12634 my $string = shift; 12635 if ($string =~ /^"(.*)"$/xo) { 12636 return($1); 12637 }else{ 12638 return($string); 12639 } 12640} 12641 12642sub memory_consumption_ratio 12643{ 12644 12645 my ($base) = @_; 12646 $base ||= 1; 12647 my $consu = memory_consumption(); 12648 return($consu / $base); 12649} 12650 12651 12652sub date_from_rcs 12653{ 12654 my $d = shift ; 12655 12656 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 ) ; 12657 if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { 12658 # Handles the following format 12659 # 2015/07/10 11:05:59 -- Generated by RCS Date tag. 12660 #myprint( "$d\n" ) ; 12661 #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; 12662 my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ; 12663 $month = $num2mon{$month} ; 12664 $d = "$day-$month-$year $hour:$min:$sec +0000" ; 12665 #myprint( "$d\n" ) ; 12666 } 12667 return( $d ) ; 12668} 12669 12670sub tests_date_from_rcs 12671{ 12672 note( 'Entering tests_date_from_rcs()' ) ; 12673 12674 ok('19-Sep-2015 16:11:07 +0000' 12675 eq date_from_rcs('Date: 2015/09/19 16:11:07 '), 'date_from_rcs from RCS date' ) ; 12676 12677 note( 'Leaving tests_date_from_rcs()' ) ; 12678 return ; 12679} 12680 12681sub good_date 12682{ 12683 # two incoming formats: 12684 # header Tue, 24 Aug 2010 16:00:00 +0200 12685 # internal 24-Aug-2010 16:00:00 +0200 12686 12687 # outgoing format: internal date format 12688 # 24-Aug-2010 16:00:00 +0200 12689 12690 my $d = shift ; 12691 return(q{}) if not defined $d; 12692 12693 SWITCH: { 12694 if ( $d =~ m{(\d?)(\d-...-\d{4})(\s\d{2}:\d{2}:\d{2})(\s(?:\+|-)\d{4})?}xo ) { 12695 #myprint( "internal: [$1][$2][$3][$4]\n" ) ; 12696 my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4) ; 12697 $day_1 = '0' if ($day_1 eq q{}) ; 12698 $zone = ' +0000' if not defined $zone ; 12699 $d = $day_1 . $date_rest . $hour . $zone ; 12700 last SWITCH ; 12701 } 12702 12703 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 ) { 12704 # Handles any combination of following formats 12705 # Tue, 24 Aug 2010 16:00:00 +0200 -- Standard 12706 # 24 Aug 2010 16:00:00 +0200 -- Missing Day of Week 12707 # Tue, 24 Aug 97 16:00:00 +0200 -- Two digit year 12708 # Tue, 24 Aug 1997 16.00.00 +0200 -- Periods instead of colons 12709 # Tue, 24 Aug 1997 16:00:00 +0200 -- Extra whitespace between year and hour 12710 # Tue, 24 Aug 1997 6:5:2 +0200 -- Single digit hour, min, or second 12711 # Tue, 24, Aug 1997 16:00:00 +0200 -- Extra comma 12712 12713 #myprint( "header: [$1][$2][$3][$4][$5][$6][$7][$8]\n" ) ; 12714 my ($day, $month, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7,$8); 12715 $year = '19' . $year if length($year) == 2 && $year =~ m/^[789]/xo; 12716 $year = '20' . $year if length($year) == 2; 12717 12718 $month = substr $month, 0, 3 if length($month) > 4; 12719 $day = mysprintf( '%02d', $day); 12720 $hour = mysprintf( '%02d', $hour); 12721 $min = mysprintf( '%02d', $min); 12722 $sec = '00' if not defined $sec ; 12723 $sec = mysprintf( '%02d', $sec ) ; 12724 $zone = '+0000' if not defined $zone ; 12725 $d = "$day-$month-$year $hour:$min:$sec $zone" ; 12726 last SWITCH ; 12727 } 12728 12729 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 ) { 12730 # Handles any combination of following formats 12731 # Sun Aug 20 11:55:09 2006 12732 # Wed Jan 24 11:58:38 MST 2007 12733 # Wed Jan 2 08:40:57 2008 12734 12735 #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; 12736 my ($month, $day, $hour, $min, $sec, $year) = ($1,$2,$3,$4,$5,$6); 12737 $day = mysprintf( '%02d', $day ) ; 12738 $hour = mysprintf( '%02d', $hour ) ; 12739 $min = mysprintf( '%02d', $min ) ; 12740 $sec = mysprintf( '%02d', $sec ) ; 12741 $d = "$day-$month-$year $hour:$min:$sec +0000" ; 12742 last SWITCH ; 12743 } 12744 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 ) ; 12745 12746 if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { 12747 # Handles the following format 12748 # 2015/07/10 11:05:59 -- Generated by RCS Date tag. 12749 #myprint( "$d\n" ) ; 12750 #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; 12751 my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ; 12752 $month = $num2mon{$month} ; 12753 $d = "$day-$month-$year $hour:$min:$sec +0000" ; 12754 #myprint( "$d\n" ) ; 12755 last SWITCH ; 12756 } 12757 12758 if ($d =~ m{(\d{2})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { 12759 # Handles the following format 12760 # 02/06/09 22:18:08 -- Generated by AVTECH TemPageR devices 12761 12762 #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; 12763 my ($month, $day, $year, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6); 12764 $year = '20' . $year; 12765 $month = $num2mon{$month}; 12766 $d = "$day-$month-$year $hour:$min:$sec +0000"; 12767 last SWITCH ; 12768 } 12769 12770 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 ) { 12771 # Handles the following format 12772 # Saturday, December 14, 2002 05:00 PM - KBtoys.com order confirmations 12773 12774 my ($month, $day, $year, $hour, $min, $apm) = ($1,$2,$3,$4,$5,$6); 12775 12776 $hour += 12 if $apm eq 'PM' ; 12777 $day = mysprintf( '%02d', $day ) ; 12778 $d = "$day-$month-$year $hour:$min:00 +0000" ; 12779 last SWITCH ; 12780 } 12781 12782 if ($d =~ m{(\w{3})\s(\d{1,2})\s(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-)\d{4})}xo ) { 12783 # Handles the following format 12784 # Saturday, December 14, 2002 05:00 PM - jr.com order confirmations 12785 12786 my ($month, $day, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7); 12787 12788 $day = mysprintf( '%02d', $day ) ; 12789 $d = "$day-$month-$year $hour:$min:$sec $zone"; 12790 last SWITCH ; 12791 } 12792 12793 if ($d =~ m{(\d{1,2})-(\w{3})-(\d{4})}xo ) { 12794 # Handles the following format 12795 # 21-Jun-2001 - register.com domain transfer email circa 2001 12796 12797 my ($day, $month, $year) = ($1,$2,$3); 12798 $day = mysprintf( '%02d', $day); 12799 $d = "$day-$month-$year 11:11:11 +0000"; 12800 last SWITCH ; 12801 } 12802 12803 # unknown or unmatch => return same string 12804 return($d); 12805 } 12806 12807 $d = qq("$d") ; 12808 return( $d ) ; 12809} 12810 12811 12812sub tests_good_date 12813{ 12814 note( 'Entering tests_good_date()' ) ; 12815 12816 ok(q{} eq good_date(), 'good_date no arg'); 12817 ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24-Aug-2010 16:00:00 +0200'), 'good_date internal 2digit zone'); 12818 ok('"24-Aug-2010 16:00:00 +0000"' eq good_date('24-Aug-2010 16:00:00'), 'good_date internal 2digit no zone'); 12819 ok('"01-Sep-2010 16:00:00 +0200"' eq good_date( '1-Sep-2010 16:00:00 +0200'), 'good_date internal SP 1digit'); 12820 ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('Tue, 24 Aug 2010 16:00:00 +0200'), 'good_date header 2digit zone'); 12821 ok('"01-Sep-2010 16:00:00 +0000"' eq good_date('Wed, 1 Sep 2010 16:00:00'), 'good_date header SP 1digit zone'); 12822 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'); 12823 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'); 12824 ok('"06-Feb-2009 22:18:08 +0000"' eq good_date('02/06/09 22:18:08'), 'good_date header TemPageR'); 12825 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'); 12826 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'); 12827 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'); 12828 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'); 12829 ok('"24-Aug-2067 16:00:00 +0200"' eq good_date('Tue, 24 Aug 67 16:00:00 +0200'), 'good_date header 2digit year'); 12830 ok('"24-Aug-1977 16:00:00 +0200"' eq good_date('Tue, 24 Aug 77 16:00:00 +0200'), 'good_date header 2digit year'); 12831 ok('"24-Aug-1987 16:00:00 +0200"' eq good_date('Tue, 24 Aug 87 16:00:00 +0200'), 'good_date header 2digit year'); 12832 ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 97 16:00:00 +0200'), 'good_date header 2digit year'); 12833 ok('"24-Aug-2004 16:00:00 +0200"' eq good_date('Tue, 24 Aug 04 16:00:00 +0200'), 'good_date header 2digit year'); 12834 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'); 12835 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'); 12836 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'); 12837 ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24, Aug 1997 05:06:02 +0200'), 'good_date header extra commas'); 12838 ok('"01-Oct-2003 12:45:24 +0000"' eq good_date('Wednesday, 01 October 2003 12:45:24 CDT'), 'good_date header no abbrev'); 12839 ok('"11-Jan-2005 17:58:27 -0500"' eq good_date('Tue, 11 Jan 2005 17:58:27 -0500'), 'good_date extra white space'); 12840 ok('"18-Dec-2002 15:07:00 +0000"' eq good_date('Wednesday, December 18, 2002 03:07 PM'), 'good_date kbtoys.com orders'); 12841 ok('"16-Dec-2004 02:01:49 -0500"' eq good_date('Dec 16 2004 02:01:49 -0500'), 'good_date jr.com orders'); 12842 ok('"21-Jun-2001 11:11:11 +0000"' eq good_date('21-Jun-2001'), 'good_date register.com domain transfer'); 12843 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)'); 12844 ok('"19-Sep-2015 16:11:07 +0000"' eq good_date('Date: 2015/09/19 16:11:07 '), 'good_date from RCS date' ) ; 12845 12846 note( 'Leaving tests_good_date()' ) ; 12847 return ; 12848} 12849 12850 12851sub tests_list_keys_in_2_not_in_1 12852{ 12853 note( 'Entering tests_list_keys_in_2_not_in_1()' ) ; 12854 12855 12856 my @list; 12857 ok( ! list_keys_in_2_not_in_1( {}, {}), 'list_keys_in_2_not_in_1: {} {}'); 12858 ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {}, {} ) ] ), 'list_keys_in_2_not_in_1: {} {}'); 12859 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}'); 12860 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}'); 12861 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}'); 12862 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}'); 12863 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}'); 12864 12865 note( 'Leaving tests_list_keys_in_2_not_in_1()' ) ; 12866 return ; 12867} 12868 12869sub list_keys_in_2_not_in_1 12870{ 12871 my $hash_1_ref = shift; 12872 my $hash_2_ref = shift; 12873 my @list; 12874 12875 foreach my $key ( sort keys %{ $hash_2_ref } ) { 12876 #$debug and print "$folder\n" ; 12877 next if exists $hash_1_ref->{$key} ; 12878 push @list, $key ; 12879 } 12880 #$debug and print "@list\n" ; 12881 return( @list ) ; 12882} 12883 12884 12885sub list_folders_in_2_not_in_1 12886{ 12887 12888 my ( @h2_folders_not_in_h1, %h2_folders_not_in_h1 ) ; 12889 @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all ) ; 12890 map { $h2_folders_not_in_h1{$_} = 1} @h2_folders_not_in_h1 ; 12891 @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_h1 ) ; 12892 12893 return( reverse @h2_folders_not_in_h1 ) ; 12894} 12895 12896sub tests_nb_messages_in_2_not_in_1 12897{ 12898 note( 'Entering tests_stats_across_folders()' ) ; 12899 is( undef, nb_messages_in_2_not_in_1( ), 'nb_messages_in_2_not_in_1: no args => undef' ) ; 12900 12901 my $mysync->{ h1_folders_of_md5 }->{ 'some_id_01' }->{ 'some_folder_01' } = 1 ; 12902 is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: no messages in 2 => 0' ) ; 12903 12904 $mysync->{ h1_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_01' } = 2 ; 12905 $mysync->{ h2_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_02' } = 4 ; 12906 12907 is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: a common message => 0' ) ; 12908 12909 $mysync->{ h2_folders_of_md5 }->{ 'some_id_in_2_not_in_1' }->{ 'some_folder_02' } = 1 ; 12910 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' ) ; 12911 12912 $mysync->{ h2_folders_of_md5 }->{ 'some_other_id_in_2_not_in_1' }->{ 'some_folder_02' } = 3 ; 12913 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' ) ; 12914 12915 note( 'Leaving tests_stats_across_folders()' ) ; 12916 return ; 12917} 12918 12919sub nb_messages_in_2_not_in_1 12920{ 12921 my $mysync = shift ; 12922 if ( not defined $mysync ) { return ; } 12923 12924 $mysync->{ nb_messages_in_2_not_in_1 } = scalar( 12925 list_keys_in_2_not_in_1( 12926 $mysync->{ h1_folders_of_md5 }, 12927 $mysync->{ h2_folders_of_md5 } ) ) ; 12928 12929 return $mysync->{ nb_messages_in_2_not_in_1 } ; 12930} 12931 12932 12933sub nb_messages_in_1_not_in_2 12934{ 12935 my $mysync = shift ; 12936 if ( not defined $mysync ) { return ; } 12937 12938 $mysync->{ nb_messages_in_1_not_in_2 } = scalar( 12939 list_keys_in_2_not_in_1( 12940 $mysync->{ h2_folders_of_md5 }, 12941 $mysync->{ h1_folders_of_md5 } ) ) ; 12942 12943 return $mysync->{ nb_messages_in_1_not_in_2 } ; 12944} 12945 12946 12947 12948sub comment_on_final_diff_in_1_not_in_2 12949{ 12950 my $mysync = shift ; 12951 12952 if ( not defined $mysync 12953 or $mysync->{ justfolders } 12954 or $mysync->{ useuid } 12955 ) 12956 { 12957 return ; 12958 } 12959 12960 my $nb_identified_h1_messages = scalar( keys %{ $mysync->{ h1_folders_of_md5 } } ) ; 12961 my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ; 12962 $mysync->{ debug } and myprint( "nb_keys h1_folders_of_md5 $nb_identified_h1_messages\n" ) ; 12963 $mysync->{ debug } and myprint( "nb_keys h2_folders_of_md5 $nb_identified_h2_messages\n" ) ; 12964 12965 if ( 0 == $nb_identified_h1_messages ) { return ; } 12966 12967 # Calculate if not yet done 12968 if ( not defined $mysync->{ nb_messages_in_1_not_in_2 } ) 12969 { 12970 nb_messages_in_1_not_in_2( $mysync ) ; 12971 } 12972 12973 12974 if ( 0 == $mysync->{ nb_messages_in_1_not_in_2 } ) 12975 { 12976 myprint( "The sync looks good, all $nb_identified_h1_messages identified messages in host1 are on host2.\n" ) ; 12977 } 12978 else 12979 { 12980 myprint( "The sync is not finished, there are $mysync->{ nb_messages_in_1_not_in_2 } identified messages in host1 that are not on host2.\n" ) ; 12981 } 12982 12983 if ( 1 <= $mysync->{ h1_nb_msg_noheader } ) 12984 { 12985 myprint( "There are $mysync->{ h1_nb_msg_noheader } unidentified messages (usually Sent or Draft messages). To sync them add option --addheader\n" ) ; 12986 } 12987 12988 return ; 12989} 12990 12991sub comment_on_final_diff_in_2_not_in_1 12992{ 12993 my $mysync = shift ; 12994 12995 if ( not defined $mysync 12996 or $mysync->{ justfolders } 12997 or $mysync->{ useuid } 12998 ) 12999 { 13000 return ; 13001 } 13002 13003 my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ; 13004 # Calculate if not yet done 13005 if ( not defined $mysync->{ nb_messages_in_2_not_in_1 } ) 13006 { 13007 nb_messages_in_2_not_in_1( $mysync ) ; 13008 } 13009 13010 if ( 0 == $mysync->{ nb_messages_in_2_not_in_1 } ) 13011 { 13012 myprint( "The sync is strict, all $nb_identified_h2_messages identified messages in host2 are on host1.\n" ) ; 13013 } 13014 else 13015 { 13016 myprint( "The sync is not strict, there are ", 13017 $mysync->{ nb_messages_in_2_not_in_1 }, 13018 " messages in host2 that are not on host1.", 13019 " Use --delete2 to delete them and have a strict sync.\n" ) ; 13020 } 13021 return ; 13022} 13023 13024 13025sub tests_match 13026{ 13027 note( 'Entering tests_match()' ) ; 13028 13029 # undef serie 13030 is( undef, match( ), 'match: no args => undef' ) ; 13031 is( undef, match( 'lalala' ), 'match: one args => undef' ) ; 13032 13033 # This one gives 0 under a binary made by pp 13034 # but 1 under "normal" Perl interpreter. So a PAR bug? 13035 #is( 1, match( q{}, q{} ), 'match: q{} =~ q{} => 1' ) ; 13036 13037 is( 'lalala', match( 'lalala', 'lalala' ), 'match: lalala =~ lalala => lalala' ) ; 13038 is( 'lalala', match( 'lalala', '^lalala' ), 'match: lalala =~ ^lalala => lalala' ) ; 13039 is( 'lalala', match( 'lalala', 'lalala$' ), 'match: lalala =~ lalala$ => lalala' ) ; 13040 is( 'lalala', match( 'lalala', '^lalala$' ), 'match: lalala =~ ^lalala$ => lalala' ) ; 13041 is( '_lalala_', match( '_lalala_', 'lalala' ), 'match: _lalala_ =~ lalala => _lalala_' ) ; 13042 is( 'lalala', match( 'lalala', '.*' ), 'match: lalala =~ .* => lalala' ) ; 13043 is( 'lalala', match( 'lalala', '.' ), 'match: lalala =~ . => lalala' ) ; 13044 is( '/lalala/', match( '/lalala/', '/lalala/' ), 'match: /lalala/ =~ /lalala/ => /lalala/' ) ; 13045 13046 is( 0, match( 'foo', 's/foo/bar/g' ), 'match: foo =~ s/foo/bar/g => 0' ) ; 13047 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' ) ; 13048 13049 13050 is( 0, match( 'lalala', 'ooo' ), 'match: lalala =~ ooo => 0' ) ; 13051 is( 0, match( 'lalala', 'lal_ala' ), 'match: lalala =~ lal_ala => 0' ) ; 13052 is( 0, match( 'lalala', '\.' ), 'match: lalala =~ \. => 0' ) ; 13053 is( 0, match( 'lalalaX', '^lalala$' ), 'match: lalalaX =~ ^lalala$ => 0' ) ; 13054 is( 0, match( 'lalala', '/lalala/' ), 'match: lalala =~ /lalala/ => 0' ) ; 13055 13056 is( 'LALALA', match( 'LALALA', '(?i:lalala)' ), 'match: LALALA =~ (?i:lalala) => 1' ) ; 13057 13058 is( undef, match( 'LALALA', '(?{`ls /`})' ), 'match: LALALA =~ (?{`ls /`}) => undef' ) ; 13059 is( undef, match( 'LALALA', '(?{print "CACA"})' ), 'match: LALALA =~ (?{print "CACA"}) => undef' ) ; 13060 is( undef, match( 'CACA', '(??{print "CACA"})' ), 'match: CACA =~ (??{print "CACA"}) => undef' ) ; 13061 13062 note( 'Leaving tests_match()' ) ; 13063 13064 return ; 13065} 13066 13067sub match 13068{ 13069 my( $var, $regex ) = @ARG ; 13070 13071 # undef cases 13072 if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; } 13073 13074 # normal cases 13075 if ( eval { $var =~ qr{$regex} } ) { 13076 return $var ; 13077 }elsif ( $EVAL_ERROR ) { 13078 myprint( "Fatal regex $regex\n" ) ; 13079 return ; 13080 } else { 13081 return 0 ; 13082 } 13083 return ; 13084} 13085 13086 13087sub tests_notmatch 13088{ 13089 note( 'Entering tests_notmatch()' ) ; 13090 13091 # undef serie 13092 is( undef, notmatch( ), 'notmatch: no args => undef' ) ; 13093 is( undef, notmatch( 'lalala' ), 'notmatch: one args => undef' ) ; 13094 13095 is( 1, notmatch( 'lalala', '/lalala/' ), 'notmatch: lalala !~ /lalala/ => 1' ) ; 13096 is( 0, notmatch( '/lalala/', '/lalala/' ), 'notmatch: /lalala/ !~ /lalala/ => 0' ) ; 13097 is( 1, notmatch( 'lalala', '/ooo/' ), 'notmatch: lalala !~ /ooo/ => 1' ) ; 13098 13099 # This one gives 1 under a binary made by pp 13100 # but 0 under "normal" Perl interpreter. So a PAR bug, same in tests_match . 13101 #is( 0, notmatch( q{}, q{} ), 'notmatch: q{} !~ q{} => 0' ) ; 13102 13103 is( 0, notmatch( 'lalala', 'lalala' ), 'notmatch: lalala !~ lalala => 0' ) ; 13104 is( 0, notmatch( 'lalala', '^lalala' ), 'notmatch: lalala !~ ^lalala => 0' ) ; 13105 is( 0, notmatch( 'lalala', 'lalala$' ), 'notmatch: lalala !~ lalala$ => 0' ) ; 13106 is( 0, notmatch( 'lalala', '^lalala$' ), 'notmatch: lalala !~ ^lalala$ => 0' ) ; 13107 is( 0, notmatch( '_lalala_', 'lalala' ), 'notmatch: _lalala_ !~ lalala => 0' ) ; 13108 is( 0, notmatch( 'lalala', '.*' ), 'notmatch: lalala !~ .* => 0' ) ; 13109 is( 0, notmatch( 'lalala', '.' ), 'notmatch: lalala !~ . => 0' ) ; 13110 13111 13112 is( 1, notmatch( 'lalala', 'ooo' ), 'notmatch: does not match regex => 1' ) ; 13113 is( 1, notmatch( 'lalala', 'lal_ala' ), 'notmatch: does not match regex => 1' ) ; 13114 is( 1, notmatch( 'lalala', '\.' ), 'notmatch: matches regex => 0' ) ; 13115 is( 1, notmatch( 'lalalaX', '^lalala$' ), 'notmatch: does not match regex => 1' ) ; 13116 13117 note( 'Leaving tests_notmatch()' ) ; 13118 13119 return ; 13120} 13121 13122sub notmatch 13123{ 13124 my( $var, $regex ) = @ARG ; 13125 13126 # undef cases 13127 if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; } 13128 13129 # normal cases 13130 if ( eval { $var !~ $regex } ) { 13131 return 1 ; 13132 }elsif ( $EVAL_ERROR ) { 13133 myprint( "Fatal regex $regex\n" ) ; 13134 return ; 13135 }else{ 13136 return 0 ; 13137 } 13138 return ; 13139} 13140 13141 13142sub delete_folders_in_2_not_in_1 13143{ 13144 13145 foreach my $folder (@h2_folders_not_in_1) { 13146 if ( defined $delete2foldersonly and eval "\$folder !~ $delete2foldersonly" ) { 13147 myprint( "Not deleting $folder because of --delete2foldersonly $delete2foldersonly\n" ) ; 13148 next ; 13149 } 13150 if ( defined $delete2foldersbutnot and eval "\$folder =~ $delete2foldersbutnot" ) { 13151 myprint( "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n" ) ; 13152 next ; 13153 } 13154 my $res = $sync->{dry} ; # always success in dry mode! 13155 $sync->{imap2}->unsubscribe( $folder ) if ( ! $sync->{dry} ) ; 13156 $res = $sync->{imap2}->delete( $folder ) if ( ! $sync->{dry} ) ; 13157 if ( $res ) { 13158 myprint( "Deleted $folder", "$sync->{dry_message}", "\n" ) ; 13159 }else{ 13160 myprint( "Deleting $folder failed", "\n" ) ; 13161 } 13162 } 13163 return ; 13164} 13165 13166sub delete_folder 13167{ 13168 my ( $mysync, $imap, $folder, $Side ) = @_ ; 13169 if ( ! $mysync ) { return ; } 13170 if ( ! $imap ) { return ; } 13171 if ( ! $folder ) { return ; } 13172 $Side ||= 'HostX' ; 13173 13174 my $res = $mysync->{dry} ; # always success in dry mode! 13175 if ( ! $mysync->{dry} ) { 13176 $imap->unsubscribe( $folder ) ; 13177 $res = $imap->delete( $folder ) ; 13178 } 13179 if ( $res ) { 13180 myprint( "$Side deleted $folder", $mysync->{dry_message}, "\n" ) ; 13181 return 1 ; 13182 }else{ 13183 myprint( "$Side deleting $folder failed", "\n" ) ; 13184 return ; 13185 } 13186} 13187 13188sub delete1emptyfolders 13189{ 13190 my $mysync = shift ; 13191 if ( ! $mysync ) { return ; } # abort if no parameter 13192 if ( ! $mysync->{delete1emptyfolders} ) { return ; } # abort if --delete1emptyfolders off 13193 my $imap = $mysync->{imap1} ; 13194 if ( ! $imap ) { return ; } # abort if no imap 13195 if ( $imap->IsUnconnected( ) ) { return ; } # abort if disconnected 13196 13197 my %folders_kept ; 13198 myprint( qq{Host1 deleting empty folders\n} ) ; 13199 foreach my $folder ( reverse sort @{ $mysync->{h1_folders_wanted} } ) { 13200 my $parenthood = $imap->is_parent( $folder ) ; 13201 if ( defined $parenthood and $parenthood ) { 13202 myprint( "Host1: folder $folder has subfolders\n" ) ; 13203 $folders_kept{ $folder }++ ; 13204 next ; 13205 } 13206 my $nb_messages_select = examine_folder_and_count( $mysync, $imap, $folder, 'Host1' ) ; 13207 if ( ! defined $nb_messages_select ) { next ; } # Select failed => Neither continue nor keep this folder } 13208 my $nb_messages_search = scalar( @{ $imap->messages( ) } ) ; 13209 if ( 0 != $nb_messages_select and 0 != $nb_messages_search ) { 13210 myprint( "Host1: folder $folder has messages: $nb_messages_search (search) $nb_messages_select (select)\n" ) ; 13211 $folders_kept{ $folder }++ ; 13212 next ; 13213 } 13214 if ( 0 != $nb_messages_select + $nb_messages_search ) { 13215 myprint( "Host1: folder $folder odd messages count: $nb_messages_search (search) $nb_messages_select (select)\n" ) ; 13216 $folders_kept{ $folder }++ ; 13217 next ; 13218 } 13219 # Here we must have 0 messages by messages() aka "SEARCH ALL" and also "EXAMINE" 13220 if ( uc $folder eq 'INBOX' ) { 13221 myprint( "Host1: Not deleting $folder\n" ) ; 13222 $folders_kept{ $folder }++ ; 13223 next ; 13224 } 13225 myprint( "Host1: deleting empty folder $folder\n" ) ; 13226 # can not delete a SELECTed or EXAMINEd folder so closing it 13227 # could changed be SELECT INBOX 13228 $imap->close( ) ; # close after examine does not expunge; anyway expunging an empty folder... 13229 if ( delete_folder( $mysync, $imap, $folder, 'Host1' ) ) { 13230 next ; # Deleted, good! 13231 }else{ 13232 $folders_kept{ $folder }++ ; 13233 next ; # Not deleted, bad! 13234 } 13235 } 13236 remove_deleted_folders_from_wanted_list( $mysync, %folders_kept ) ; 13237 myprint( qq{Host1 ended deleting empty folders\n} ) ; 13238 return ; 13239} 13240 13241sub remove_deleted_folders_from_wanted_list 13242{ 13243 my ( $mysync, %folders_kept ) = @ARG ; 13244 13245 my @h1_folders_wanted_init = @{ $mysync->{h1_folders_wanted} } ; 13246 my @h1_folders_wanted_last ; 13247 foreach my $folder ( @h1_folders_wanted_init ) { 13248 if ( $folders_kept{ $folder } ) { 13249 push @h1_folders_wanted_last, $folder ; 13250 } 13251 } 13252 @{ $mysync->{h1_folders_wanted} } = @h1_folders_wanted_last ; 13253 return ; 13254} 13255 13256 13257sub examine_folder_and_count 13258{ 13259 my ( $mysync, $imap, $folder, $Side ) = @_ ; 13260 $Side ||= 'HostX' ; 13261 13262 if ( ! examine_folder( $mysync, $imap, $folder, $Side ) ) { 13263 return ; 13264 } 13265 my $nb_messages_select = count_from_select( $imap->History ) ; 13266 return $nb_messages_select ; 13267} 13268 13269 13270sub tests_delete1emptyfolders 13271{ 13272 note( 'Entering tests_delete1emptyfolders()' ) ; 13273 13274 13275 is( undef, delete1emptyfolders( ), q{delete1emptyfolders: undef} ) ; 13276 my $syncT ; 13277 is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef 2} ) ; 13278 my $imapT ; 13279 $syncT->{imap1} = $imapT ; 13280 is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef imap} ) ; 13281 13282 require_ok( "Test::MockObject" ) ; 13283 $imapT = Test::MockObject->new( ) ; 13284 $syncT->{imap1} = $imapT ; 13285 13286 $imapT->set_true( 'IsUnconnected' ) ; 13287 is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: Unconnected imap} ) ; 13288 13289 # Now connected tests 13290 $imapT->set_false( 'IsUnconnected' ) ; 13291 $imapT->mock( 'LastError', sub { q{LastError mocked} } ) ; 13292 13293 $syncT->{delete1emptyfolders} = 0 ; 13294 tests_delete1emptyfolders_unit( 13295 $syncT, 13296 [ qw{ INBOX DELME1 DELME2 } ], 13297 [ qw{ INBOX DELME1 DELME2 } ], 13298 q{tests_delete1emptyfolders: --delete1emptyfolders OFF} 13299 ) ; 13300 13301 # All are parents => no deletion at all 13302 $imapT->set_true( 'is_parent' ) ; 13303 $syncT->{delete1emptyfolders} = 1 ; 13304 tests_delete1emptyfolders_unit( 13305 $syncT, 13306 [ qw{ INBOX DELME1 DELME2 } ], 13307 [ qw{ INBOX DELME1 DELME2 } ], 13308 q{tests_delete1emptyfolders: --delete1emptyfolders ON} 13309 ) ; 13310 13311 # No parents but examine false for all => skip all 13312 $imapT->set_false( 'is_parent', 'examine' ) ; 13313 13314 tests_delete1emptyfolders_unit( 13315 $syncT, 13316 [ qw{ INBOX DELME1 DELME2 } ], 13317 [ ], 13318 q{tests_delete1emptyfolders: EXAMINE fails} 13319 ) ; 13320 13321 # examine ok for all but History bad => skip all 13322 $imapT->set_true( 'examine' ) ; 13323 $imapT->mock( 'History', sub { ( q{History badly mocked} ) } ) ; 13324 tests_delete1emptyfolders_unit( 13325 $syncT, 13326 [ qw{ INBOX DELME1 DELME2 } ], 13327 [ ], 13328 q{tests_delete1emptyfolders: examine ok but History badly mocked so count messages fails} 13329 ) ; 13330 13331 # History good but some messages EXISTS == messages() => no deletion 13332 $imapT->mock( 'History', sub { ( q{* 2 EXISTS} ) } ) ; 13333 $imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ; 13334 tests_delete1emptyfolders_unit( 13335 $syncT, 13336 [ qw{ INBOX DELME1 DELME2 } ], 13337 [ qw{ INBOX DELME1 DELME2 } ], 13338 q{tests_delete1emptyfolders: History EXAMINE ok, several messages} 13339 ) ; 13340 13341 # 0 EXISTS but != messages() => no deletion 13342 $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ; 13343 $imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ; 13344 tests_delete1emptyfolders_unit( 13345 $syncT, 13346 [ qw{ INBOX DELME1 DELME2 } ], 13347 [ qw{ INBOX DELME1 DELME2 } ], 13348 q{tests_delete1emptyfolders: 0 EXISTS but 2 by messages()} 13349 ) ; 13350 13351 # 1 EXISTS but != 0 == messages() => no deletion 13352 $imapT->mock( 'History', sub { ( q{* 1 EXISTS} ) } ) ; 13353 $imapT->mock( 'messages', sub { [ ] } ) ; 13354 tests_delete1emptyfolders_unit( 13355 $syncT, 13356 [ qw{ INBOX DELME1 DELME2 } ], 13357 [ qw{ INBOX DELME1 DELME2 } ], 13358 q{tests_delete1emptyfolders: 1 EXISTS but 0 by messages()} 13359 ) ; 13360 13361 # 0 EXISTS and 0 == messages() => deletion except INBOX 13362 $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ; 13363 $imapT->mock( 'messages', sub { [ ] } ) ; 13364 $imapT->set_true( qw{ delete close unsubscribe } ) ; 13365 $syncT->{dry_message} = q{ (not really since in a mocked test)} ; 13366 tests_delete1emptyfolders_unit( 13367 $syncT, 13368 [ qw{ INBOX DELME1 DELME2 } ], 13369 [ qw{ INBOX } ], 13370 q{tests_delete1emptyfolders: 0 EXISTS 0 by messages() delete folders, keep INBOX} 13371 ) ; 13372 13373 note( 'Leaving tests_delete1emptyfolders()' ) ; 13374 return ; 13375} 13376 13377sub tests_delete1emptyfolders_unit 13378{ 13379 note( 'Entering tests_delete1emptyfolders_unit()' ) ; 13380 13381 my $syncT = shift ; 13382 my $folders1wanted_init_ref = shift ; 13383 my $folders1wanted_after_ref = shift ; 13384 my $comment = shift || q{delete1emptyfolders:} ; 13385 13386 my @folders1wanted_init = @{ $folders1wanted_init_ref } ; 13387 my @folders1wanted_after = @{ $folders1wanted_after_ref } ; 13388 13389 @{ $syncT->{h1_folders_wanted} } = @folders1wanted_init ; 13390 13391 is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_init, qq{$comment, init check} ) ; 13392 delete1emptyfolders( $syncT ) ; 13393 is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_after, qq{$comment, after check} ) ; 13394 13395 note( 'Leaving tests_delete1emptyfolders_unit()' ) ; 13396 return ; 13397} 13398 13399sub extract_header 13400{ 13401 my $string = shift ; 13402 13403 my ( $header ) = split /\n\n/x, $string ; 13404 if ( ! $header ) { return( q{} ) ; } 13405 #myprint( "[$header]\n" ) ; 13406 return( $header ) ; 13407} 13408 13409sub tests_extract_header 13410{ 13411 note( 'Entering tests_extract_header()' ) ; 13412 13413my $h = <<'EOM'; 13414Message-Id: <20100428101817.A66CB162474E@plume.est.belle> 13415Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) 13416From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) 13417EOM 13418chomp $h ; 13419ok( $h eq extract_header( 13420<<'EOM' 13421Message-Id: <20100428101817.A66CB162474E@plume.est.belle> 13422Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) 13423From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) 13424 13425body 13426lalala 13427EOM 13428), 'extract_header: 1') ; 13429 13430 13431 13432 note( 'Leaving tests_extract_header()' ) ; 13433 return ; 13434} 13435 13436sub decompose_header{ 13437 my $string = shift ; 13438 13439 # a hash, for a keyword header KEY value are list of strings [VAL1, VAL1_other, etc] 13440 # Think of multiple "Received:" header lines. 13441 my $header = { } ; 13442 13443 my ($key, $val ) ; 13444 my @line = split /\n|\r\n/x, $string ; 13445 foreach my $line ( @line ) { 13446 #myprint( "DDD $line\n" ) ; 13447 # End of header 13448 last if ( $line =~ m{^$}xo ) ; 13449 # Key: value 13450 if ( $line =~ m/(^[^:]+):\s(.*)/xo ) { 13451 $key = $1 ; 13452 $val = $2 ; 13453 $debugdev and myprint( "DDD KV [$key] [$val]\n" ) ; 13454 push @{ $header->{ $key } }, $val ; 13455 # blanc and value => value from previous line continues 13456 }elsif( $line =~ m/^(\s+)(.*)/xo ) { 13457 $val = $2 ; 13458 $debugdev and myprint( "DDD V [$val]\n" ) ; 13459 @{ $header->{ $key } }[ $LAST ] .= " $val" if $key ; 13460 # dirty line? 13461 }else{ 13462 next ; 13463 } 13464 } 13465 13466 #myprint( Data::Dumper->Dump( [ $header ] ) ) ; 13467 13468 return( $header ) ; 13469} 13470 13471 13472sub tests_decompose_header{ 13473 note( 'Entering tests_decompose_header()' ) ; 13474 13475 13476 my $header_dec ; 13477 13478 $header_dec = decompose_header( 13479<<'EOH' 13480KEY_1: VAL_1 13481KEY_2: VAL_2 13482 VAL_2_+ 13483 VAL_2_++ 13484KEY_3: VAL_3 13485KEY_1: VAL_1_other 13486KEY_4: VAL_4 13487 VAL_4_+ 13488KEY_5 BLANC: VAL_5 13489 13490KEY_6_BAD_BODY: VAL_6 13491EOH 13492 ) ; 13493 13494 ok( 'VAL_3' 13495 eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: VAL_3' ) ; 13496 13497 ok( 'VAL_1' 13498 eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: VAL_1' ) ; 13499 13500 ok( 'VAL_1_other' 13501 eq $header_dec->{ 'KEY_1' }[1], 'decompose_header: VAL_1_other' ) ; 13502 13503 ok( 'VAL_2 VAL_2_+ VAL_2_++' 13504 eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: VAL_2 VAL_2_+ VAL_2_++' ) ; 13505 13506 ok( 'VAL_4 VAL_4_+' 13507 eq $header_dec->{ 'KEY_4' }[0], 'decompose_header: VAL_4 VAL_4_+' ) ; 13508 13509 ok( ' VAL_5' 13510 eq $header_dec->{ 'KEY_5 BLANC' }[0], 'decompose_header: KEY_5 BLANC' ) ; 13511 13512 ok( not( defined $header_dec->{ 'KEY_6_BAD_BODY' }[0] ), 'decompose_header: KEY_6_BAD_BODY' ) ; 13513 13514 13515 $header_dec = decompose_header( 13516<<'EOH' 13517Message-Id: <20100428101817.A66CB162474E@plume.est.belle> 13518Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) 13519From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) 13520EOH 13521 ) ; 13522 13523 ok( '<20100428101817.A66CB162474E@plume.est.belle>' 13524 eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ; 13525 13526 $header_dec = decompose_header( 13527<<'EOH' 13528Return-Path: <gilles@louloutte.dyndns.org> 13529Received: by plume.est.belle (Postfix, from userid 1000) 13530 id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST) 13531Subject: test:eekahceishukohpe 13532EOH 13533) ; 13534 ok( 13535'by plume.est.belle (Postfix, from userid 1000) id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)' 13536 eq $header_dec->{ 'Received' }[0], 'decompose_header: 2' ) ; 13537 13538 $header_dec = decompose_header( 13539<<'EOH' 13540Received: from plume (localhost [127.0.0.1]) 13541 by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 13542 for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET) 13543Received: from plume [192.168.68.7] 13544 by plume with POP3 (fetchmail-6.3.6) 13545 for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET) 13546EOH 13547 ) ; 13548 ok( 13549 '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)' 13550 eq $header_dec->{ 'Received' }[0], 'decompose_header: 3' ) ; 13551 ok( 13552 '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)' 13553 eq $header_dec->{ 'Received' }[1], 'decompose_header: 3' ) ; 13554 13555# Bad header beginning with a blank character 13556 $header_dec = decompose_header( 13557<<'EOH' 13558 KEY_1: VAL_1 13559KEY_2: VAL_2 13560 VAL_2_+ 13561 VAL_2_++ 13562KEY_3: VAL_3 13563KEY_1: VAL_1_other 13564EOH 13565 ) ; 13566 13567 ok( 'VAL_3' 13568 eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: Bad header VAL_3' ) ; 13569 13570 ok( 'VAL_1_other' 13571 eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: Bad header VAL_1_other' ) ; 13572 13573 ok( 'VAL_2 VAL_2_+ VAL_2_++' 13574 eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: Bad header VAL_2 VAL_2_+ VAL_2_++' ) ; 13575 13576 note( 'Leaving tests_decompose_header()' ) ; 13577 return ; 13578} 13579 13580sub tests_epoch 13581{ 13582 note( 'Entering tests_epoch()' ) ; 13583 13584 ok( '1282658400' eq epoch( '24-Aug-2010 16:00:00 +0200' ), 'epoch 24-Aug-2010 16:00:00 +0200 -> 1282658400' ) ; 13585 ok( '1282658400' eq epoch( '24-Aug-2010 14:00:00 +0000' ), 'epoch 24-Aug-2010 14:00:00 +0000 -> 1282658400' ) ; 13586 ok( '1282658400' eq epoch( '24-Aug-2010 12:00:00 -0200' ), 'epoch 24-Aug-2010 12:00:00 -0200 -> 1282658400' ) ; 13587 ok( '1282658400' eq epoch( '24-Aug-2010 16:01:00 +0201' ), 'epoch 24-Aug-2010 16:01:00 +0201 -> 1282658400' ) ; 13588 ok( '1282658400' eq epoch( '24-Aug-2010 14:01:00 +0001' ), 'epoch 24-Aug-2010 14:01:00 +0001 -> 1282658400' ) ; 13589 13590 ok( '1280671200' eq epoch( '1-Aug-2010 16:00:00 +0200' ), 'epoch 1-Aug-2010 16:00:00 +0200 -> 1280671200' ) ; 13591 ok( '1280671200' eq epoch( '1-Aug-2010 14:00:00 +0000' ), 'epoch 1-Aug-2010 14:00:00 +0000 -> 1280671200' ) ; 13592 ok( '1280671200' eq epoch( '1-Aug-2010 12:00:00 -0200' ), 'epoch 1-Aug-2010 12:00:00 -0200 -> 1280671200' ) ; 13593 ok( '1280671200' eq epoch( '1-Aug-2010 16:01:00 +0201' ), 'epoch 1-Aug-2010 16:01:00 +0201 -> 1280671200' ) ; 13594 ok( '1280671200' eq epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; 13595 13596 is( '1280671200', epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; 13597 is( '946684800', epoch( '00-Jan-0000 00:00:00 +0000' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; 13598 13599 note( 'Leaving tests_epoch()' ) ; 13600 return ; 13601} 13602 13603sub epoch 13604{ 13605 # incoming format: 13606 # internal date 24-Aug-2010 16:00:00 +0200 13607 13608 # outgoing format: epoch 13609 13610 13611 my $d = shift ; 13612 return(q{}) if not defined $d; 13613 13614 my ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) ; 13615 my $time ; 13616 13617 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 ) { 13618 #myprint( "internal: [$1][$2][$3][$4][$5][$6][$7][$8][$9]\n" ) ; 13619 ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) 13620 = ( $1, $2, $3, $4, $5, $6, $7, $8, $9 ) ; 13621 #myprint( "( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )\n" ) ; 13622 13623 $sign = +1 if ( '+' eq $sign ) ; 13624 $sign = $MINUS_ONE if ( '-' eq $sign ) ; 13625 13626 if ( 0 == $mday ) { 13627 myprint( "buggy day in $d. Fixed to 01\n" ) ; 13628 $mday = '01' ; 13629 } 13630 $time = timegm( $sec, $min, $hour, $mday, $month_abrev{$month}, $year ) 13631 - $sign * ( 3600 * $zone_h + 60 * $zone_m ) ; 13632 13633 #myprint( "$time ", scalar localtime($time), "\n"); 13634 } 13635 return( $time ) ; 13636} 13637 13638sub tests_add_header 13639{ 13640 note( 'Entering tests_add_header()' ) ; 13641 13642 ok( 'Message-Id: <mistake@imapsync>' eq add_header(), 'add_header no arg' ) ; 13643 ok( 'Message-Id: <123456789@imapsync>' eq add_header( '123456789' ), 'add_header 123456789' ) ; 13644 13645 note( 'Leaving tests_add_header()' ) ; 13646 return ; 13647} 13648 13649sub add_header 13650{ 13651 my $header_uid = shift || 'mistake' ; 13652 my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ; 13653 return( $header_Message_Id ) ; 13654} 13655 13656 13657 13658 13659sub tests_max_line_length 13660{ 13661 note( 'Entering tests_max_line_length()' ) ; 13662 13663 ok( 0 == max_line_length( q{} ), 'max_line_length: 0 == null string' ) ; 13664 ok( 1 == max_line_length( "\n" ), 'max_line_length: 1 == \n' ) ; 13665 ok( 1 == max_line_length( "\n\n" ), 'max_line_length: 1 == \n\n' ) ; 13666 ok( 1 == max_line_length( "\n" x 500 ), 'max_line_length: 1 == 500 \n' ) ; 13667 ok( 1 == max_line_length( 'a' ), 'max_line_length: 1 == a' ) ; 13668 ok( 2 == max_line_length( "a\na" ), 'max_line_length: 2 == a\na' ) ; 13669 ok( 2 == max_line_length( "a\na\n" ), 'max_line_length: 2 == a\na\n' ) ; 13670 ok( 3 == max_line_length( "a\nab\n" ), 'max_line_length: 3 == a\nab\n' ) ; 13671 ok( 3 == max_line_length( "a\nab\n" x 1_000 ), 'max_line_length: 3 == 1_000 a\nab\n' ) ; 13672 ok( 3 == max_line_length( "a\nab\nabc" ), 'max_line_length: 3 == a\nab\nabc' ) ; 13673 13674 ok( 4 == max_line_length( "a\nab\nabc\n" ), 'max_line_length: 4 == a\nab\nabc\n' ) ; 13675 ok( 5 == max_line_length( "a\nabcd\nabc\n" ), 'max_line_length: 5 == a\nabcd\nabc\n' ) ; 13676 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' ) ; 13677 13678 note( 'Leaving tests_max_line_length()' ) ; 13679 return ; 13680} 13681 13682sub max_line_length 13683{ 13684 my $string = shift ; 13685 my $max = 0 ; 13686 13687 while ( $string =~ m/([^\n]*\n?)/msxg ) { 13688 $max = max( $max, length $1 ) ; 13689 } 13690 return( $max ) ; 13691} 13692 13693 13694sub tests_setlogfile 13695{ 13696 note( 'Entering tests_setlogfile()' ) ; 13697 13698 my $mysync = {} ; 13699 $mysync->{logdir} = 'vallogdir' ; 13700 $mysync->{logfile} = 'vallogfile.txt' ; 13701 is( 'vallogdir/vallogfile.txt', setlogfile( $mysync ), 13702 'setlogfile: logdir vallogdir, logfile vallogfile.txt, vallogdir/vallogfile.txt' ) ; 13703 13704 SKIP: { 13705 skip( 'Too hard to have a well known timezone on Windows', 9 ) if ( 'MSWin32' eq $OSNAME ) ; 13706 13707 local $ENV{TZ} = 'GMT' ; 13708 13709 $mysync = { 13710 timestart => 2, 13711 } ; 13712 13713 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000__.txt", setlogfile( $mysync ), 13714 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000__.txt" ) ; 13715 13716 $mysync = { 13717 timestart => 2, 13718 user1 => 'user1', 13719 user2 => 'user2', 13720 abort => 1, 13721 } ; 13722 13723 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_abort.txt", setlogfile( $mysync ), 13724 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_abort.txt" ) ; 13725 13726 $mysync = { 13727 timestart => 2, 13728 user1 => 'user1', 13729 user2 => 'user2', 13730 remote => 'zzz', 13731 } ; 13732 13733 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote.txt", setlogfile( $mysync ), 13734 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote.txt" ) ; 13735 13736 $mysync = { 13737 timestart => 2, 13738 user1 => 'user1', 13739 user2 => 'user2', 13740 remote => 'zzz', 13741 abort => 1, 13742 } ; 13743 13744 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote_abort.txt", setlogfile( $mysync ), 13745 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote_abort.txt" ) ; 13746 13747 13748 $mysync = { 13749 timestart => 2, 13750 user1 => 'user1', 13751 user2 => 'user2', 13752 } ; 13753 13754 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt", setlogfile( $mysync ), 13755 "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt" ) ; 13756 13757 $mysync->{logdir} = undef ; 13758 $mysync->{logfile} = undef ; 13759 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt", setlogfile( $mysync ), 13760 "setlogfile: logdir undef, $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt" ) ; 13761 13762 $mysync->{logdir} = q{} ; 13763 $mysync->{logfile} = undef ; 13764 is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), 13765 'setlogfile: logdir empty, 1970_01_01_00_00_02_000_user1_user2.txt' ) ; 13766 13767 $mysync->{logdir} = 'vallogdir' ; 13768 $mysync->{logfile} = undef ; 13769 is( 'vallogdir/1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), 13770 'setlogfile: logdir vallogdir, vallogdir/1970_01_01_00_00_02_000_user1_user2.txt' ) ; 13771 13772 $mysync = { 13773 user1 => 'us/er1a*|?:"<>b', 13774 user2 => 'u/ser2a*|?:"<>b', 13775 } ; 13776 13777 is( "$DEFAULT_LOGDIR/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt", setlogfile( $mysync ), 13778 "setlogfile: logdir undef, $DEFAULT_LOGDIR/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt" ) ; 13779 13780 13781 13782 } ; 13783 13784 note( 'Leaving tests_setlogfile()' ) ; 13785 return ; 13786} 13787 13788sub setlogfile 13789{ 13790 my( $mysync ) = shift ; 13791 13792 # When aborting another process the log file name finishes with "_abort.txt" 13793 my $abort_suffix = ( $mysync->{abort} ) ? '_abort' : q{} ; 13794 # When acting as a proxy the log file name finishes with "_remote.txt" 13795 # proxy mode is not done yet 13796 my $remote_suffix = ( $mysync->{remote} ) ? '_remote' : q{} ; 13797 13798 my $suffix = ( filter_forbidden_characters( move_slash( $mysync->{user1} ) ) || q{} ) 13799 . '_' 13800 . ( filter_forbidden_characters( move_slash( $mysync->{user2} ) ) || q{} ) 13801 . $remote_suffix . $abort_suffix ; 13802 13803 $mysync->{logdir} = defined $mysync->{logdir} ? $mysync->{logdir} : $DEFAULT_LOGDIR ; 13804 13805 $mysync->{logfile} = defined $mysync->{logfile} 13806 ? "$mysync->{logdir}/$mysync->{logfile}" 13807 : logfile( $mysync->{timestart}, $suffix, $mysync->{logdir} ) ; 13808 13809 return( $mysync->{logfile} ) ; 13810} 13811 13812sub tests_logfile 13813{ 13814 note( 'Entering tests_logfile()' ) ; 13815 13816 SKIP: { 13817 # Too hard to have a well known timezone on Windows 13818 skip( 'Too hard to have a well known timezone on Windows', 10 ) if ( 'MSWin32' eq $OSNAME ) ; 13819 13820 local $ENV{TZ} = 'GMT' ; 13821 { POSIX::tzset unless ('MSWin32' eq $OSNAME) ; 13822 is( '1970_01_01_00_00_00_000.txt', logfile( ), 'logfile: no args => 1970_01_01_00_00_00.txt' ) ; 13823 is( '1970_01_01_00_00_00_000.txt', logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00.txt' ) ; 13824 is( '1970_01_01_00_01_01_000.txt', logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ; 13825 is( '1970_01_01_00_01_01_234.txt', logfile( 61.234 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ; 13826 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' ) ; 13827 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' ) ; 13828 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' ) ; 13829 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' ) ; 13830 13831 is( '2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup' ), 13832 'logfile: 1_282_658_461.2347 poup => 2010_08_24_14_01_01_234_poup.txt' ) ; 13833 13834 is( 'dirdir/2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup', 'dirdir' ), 13835 'logfile: 1_282_658_461.2347 poup dirdir => dirdir/2010_08_24_14_01_01_234_poup.txt' ) ; 13836 13837 13838 13839 } 13840 POSIX::tzset unless ('MSWin32' eq $OSNAME) ; 13841 } ; 13842 13843 note( 'Leaving tests_logfile()' ) ; 13844 return ; 13845} 13846 13847 13848sub logfile 13849{ 13850 my ( $time, $suffix, $dir ) = @_ ; 13851 13852 $time ||= 0 ; 13853 $suffix ||= q{} ; 13854 $suffix =~ tr/ //ds ; 13855 my $sep_suffix = ( $suffix ) ? '_' : q{} ; 13856 $dir ||= q{} ; 13857 my $sep_dir = ( $dir ) ? '/' : q{} ; 13858 13859 my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ; 13860 # Because of ab tests or web access, more than one sync withing one second is possible 13861 # so we add also milliseconds 13862 $date_str .= sprintf "_%03d", ($time - int( $time ) ) * 1000 ; # without rounding 13863 my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ; 13864 return( $logfile ) ; 13865} 13866 13867 13868 13869sub tests_move_slash 13870{ 13871 note( 'Entering tests_move_slash()' ) ; 13872 13873 is( undef, move_slash( ), 'move_slash: no parameters => undef' ) ; 13874 is( '_', move_slash( '/' ), 'move_slash: / => _' ) ; 13875 is( '_abc_def_', move_slash( '/abc/def/' ), 'move_slash: /abc/def/ => _abc_def_' ) ; 13876 note( 'Leaving tests_move_slash()' ) ; 13877 return ; 13878} 13879 13880sub move_slash 13881{ 13882 my $string = shift ; 13883 13884 if ( ! defined $string ) { return ; } 13885 13886 $string =~ tr{/}{_} ; 13887 13888 return( $string ) ; 13889} 13890 13891 13892 13893 13894sub tests_million_folders_baby_2 13895{ 13896 note( 'Entering tests_million_folders_baby_2()' ) ; 13897 13898 my %long ; 13899 @long{ 1 .. 900_000 } = (1) x 900_000 ; 13900 #myprint( %long, "\n" ) ; 13901 my $pasglop = 0 ; 13902 foreach my $elem ( 1 .. 900_000 ) { 13903 #$debug and myprint( "$elem " ) ; 13904 if ( not exists $long{ $elem } ) { 13905 $pasglop++ ; 13906 } 13907 } 13908 ok( 0 == $pasglop, 'tests_million_folders_baby_2: search among 900_000' ) ; 13909 # myprint( "$pasglop\n" ) ; 13910 13911 note( 'Leaving tests_million_folders_baby_2()' ) ; 13912 return ; 13913} 13914 13915 13916 13917sub tests_always_fail 13918{ 13919 note( 'Entering tests_always_fail()' ) ; 13920 13921 is( 0, 1, 'always_fail: 0 is 1' ) ; 13922 13923 note( 'Leaving tests_always_fail()' ) ; 13924 return ; 13925} 13926 13927 13928sub tests_logfileprepa 13929{ 13930 note( 'Entering tests_logfileprepa()' ) ; 13931 13932 is( undef, logfileprepa( ), 'logfileprepa: no args => undef' ) ; 13933 my $logfile = 'W/tmp/tests/tests_logfileprepa.txt' ; 13934 is( 1, logfileprepa( $logfile ), 'logfileprepa: W/tmp/tests/tests_logfileprepa.txt => 1' ) ; 13935 13936 note( 'Leaving tests_logfileprepa()' ) ; 13937 return ; 13938} 13939 13940sub logfileprepa 13941{ 13942 my $logfile = shift ; 13943 13944 if ( ! defined( $logfile ) ) 13945 { 13946 return ; 13947 }else 13948 { 13949 #myprint( "[$logfile]\n" ) ; 13950 my $dirname = dirname( $logfile ) ; 13951 do_valid_directory( $dirname ) || return( 0 ) ; 13952 return( 1 ) ; 13953 } 13954} 13955 13956 13957sub tests_teelaunch 13958{ 13959 note( 'Entering tests_teelaunch()' ) ; 13960 13961 is( undef, teelaunch( ), 'teelaunch: no args => undef' ) ; 13962 my $mysync = {} ; 13963 is( undef, teelaunch( $mysync ), 'teelaunch: arg empty {} => undef' ) ; 13964 $mysync->{logfile} = '' ; 13965 is( undef, teelaunch( $mysync ), 'teelaunch: logfile empty string => undef' ) ; 13966 $mysync->{logfile} = 'W/tmp/tests/tests_teelaunch.txt' ; 13967 isa_ok( my $tee = teelaunch( $mysync ), 'IO::Tee' , 'teelaunch: logfile W/tmp/tests/tests_teelaunch.txt' ) ; 13968 is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ; 13969 is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\n' ) ; 13970 is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ; 13971 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' ) ; 13972 13973 note( 'Leaving tests_teelaunch()' ) ; 13974 return ; 13975} 13976 13977sub teelaunch 13978{ 13979 my $mysync = shift ; 13980 13981 if ( ! defined( $mysync ) ) 13982 { 13983 return ; 13984 } 13985 13986 my $logfile = $mysync->{logfile} ; 13987 13988 if ( ! $logfile ) 13989 { 13990 return ; 13991 } 13992 13993 logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $OS_ERROR" ; 13994 13995 # This is a log file opened during the whole sync 13996 ## no critic (InputOutput::RequireBriefOpen) 13997 open my $logfile_handle, '>', $logfile 13998 or croak( "Can not open $logfile for write: $OS_ERROR" ) ; 13999 my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ; 14000 $tee->autoflush( 1 ) ; 14001 $mysync->{logfile_handle} = $logfile_handle ; 14002 $mysync->{tee} = $tee ; 14003 return $tee ; 14004} 14005 14006sub getpwuid_any_os 14007{ 14008 my $uid = shift ; 14009 14010 return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system 14011 return( scalar getpwuid $uid ) ; # Unix system 14012 14013 14014} 14015 14016sub simulong 14017{ 14018 my $max_seconds = shift ; 14019 my $division = 5 ; 14020 my $last_count = $division * $max_seconds ; 14021 foreach my $i ( 1 .. ( $last_count ) ) { 14022 myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" ) ; 14023 #myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" . ( "Ah" x 40 . "\n") x 4000 ) ; 14024 sleep( 1 / $division ) ; 14025 } 14026 14027 return ; 14028} 14029 14030 14031 14032sub printenv 14033{ 14034 myprint( "Environment variables listing:\n", 14035 ( map { "$_ => $ENV{$_}\n" } sort keys %ENV), 14036 "Environment variables listing end\n" ) ; 14037 return ; 14038} 14039 14040sub testsexit 14041{ 14042 my $mysync = shift ; 14043 if ( ! ( $mysync->{ tests } or $mysync->{ testsdebug } or $mysync->{ testsunit } ) ) { 14044 return ; 14045 } 14046 my $test_builder = Test::More->builder ; 14047 tests( $mysync ) ; 14048 testsdebug( $mysync ) ; 14049 testunitsession( $mysync ) ; 14050 14051 my @summary = $test_builder->summary() ; 14052 my @details = $test_builder->details() ; 14053 my $nb_tests_run = scalar( @summary ) ; 14054 my $nb_tests_expected = $test_builder->expected_tests() ; 14055 my $nb_tests_failed = count_0s( @summary ) ; 14056 my $tests_failed = report_failures( @details ) ; 14057 if ( $nb_tests_failed or ( $nb_tests_run != $nb_tests_expected ) ) { 14058 #$test_builder->reset( ) ; 14059 myprint( "Summary of tests: failed $nb_tests_failed tests, run $nb_tests_run tests, expected to run $nb_tests_expected tests.\n", 14060 "List of failed tests:\n", $tests_failed ) ; 14061 exit $EXIT_TESTS_FAILED ; 14062 } 14063 14064 cleanup_mess_from_tests( ) ; 14065 # Cover is larger with --tests --testslive 14066 if ( ! $mysync->{ testslive } ) 14067 { 14068 exit ; 14069 } 14070 # $eeee ; 14071 return ; 14072} 14073 14074sub cleanup_mess_from_tests 14075{ 14076 undef @pipemess ; 14077 return ; 14078} 14079 14080sub after_get_options 14081{ 14082 my $mysync = shift ; 14083 my $numopt = shift ; 14084 14085 14086 # exit with --help option or no option at all 14087 $mysync->{ debug } and myprint( "numopt:$numopt\n" ) ; 14088 14089 if ( $help or not $numopt ) { 14090 myprint( usage( $mysync ) ) ; 14091 exit ; 14092 } 14093 14094 return ; 14095} 14096 14097sub tests_remove_edging_blanks 14098{ 14099 note( 'Entering tests_remove_edging_blanks()' ) ; 14100 14101 is( undef, remove_edging_blanks( ), 'remove_edging_blanks: no args => undef' ) ; 14102 is( 'abcd', remove_edging_blanks( 'abcd' ), 'remove_edging_blanks: abcd => abcd' ) ; 14103 is( 'ab cd', remove_edging_blanks( ' ab cd ' ), 'remove_edging_blanks: " ab cd " => "ab cd"' ) ; 14104 14105 note( 'Leaving tests_remove_edging_blanks()' ) ; 14106 return ; 14107} 14108 14109 14110 14111sub remove_edging_blanks 14112{ 14113 my $string = shift ; 14114 if ( ! defined $string ) 14115 { 14116 return ; 14117 } 14118 $string =~ s,^ +| +$,,g ; 14119 return $string ; 14120} 14121 14122 14123sub tests_sanitize 14124{ 14125 note( 'Entering tests_remove_edging_blanks()' ) ; 14126 14127 is( undef, sanitize( ), 'sanitize: no args => undef' ) ; 14128 my $mysync = {} ; 14129 14130 $mysync->{ host1 } = ' example.com ' ; 14131 $mysync->{ user1 } = ' to to ' ; 14132 $mysync->{ password1 } = ' sex is good! ' ; 14133 is( undef, sanitize( $mysync ), 'sanitize: => undef' ) ; 14134 is( 'example.com', $mysync->{ host1 }, 'sanitize: host1 " example.com " => "example.com"' ) ; 14135 is( 'to to', $mysync->{ user1 }, 'sanitize: user1 " to to " => "to to"' ) ; 14136 is( 'sex is good!', $mysync->{ password1 }, 'sanitize: password1 " sex is good! " => "sex is good!"' ) ; 14137 note( 'Leaving tests_remove_edging_blanks()' ) ; 14138 return ; 14139} 14140 14141 14142sub sanitize 14143{ 14144 my $mysync = shift ; 14145 if ( ! defined $mysync ) 14146 { 14147 return ; 14148 } 14149 14150 foreach my $parameter ( qw( host1 host2 user1 user2 password1 password2 ) ) 14151 { 14152 $mysync->{ $parameter } = remove_edging_blanks( $mysync->{ $parameter } ) ; 14153 } 14154 return ; 14155} 14156 14157sub easyany 14158{ 14159 my $mysync = shift ; 14160 14161 # Gmail 14162 if ( $mysync->{gmail1} and $mysync->{gmail2} ) { 14163 $mysync->{ debug } and myprint( "gmail1 gmail2\n") ; 14164 gmail12( $mysync ) ; 14165 return ; 14166 } 14167 if ( $mysync->{gmail1} ) { 14168 $mysync->{ debug } and myprint( "gmail1\n" ) ; 14169 gmail1( $mysync ) ; 14170 } 14171 if ( $mysync->{gmail2} ) { 14172 $mysync->{ debug } and myprint( "gmail2\n" ) ; 14173 gmail2( $mysync ) ; 14174 } 14175 # Office 365 14176 if ( $mysync->{office1} ) { 14177 office1( $mysync ) ; 14178 } 14179 14180 if ( $mysync->{office2} ) { 14181 office2( $mysync ) ; 14182 } 14183 14184 # Exchange 14185 if ( $mysync->{exchange1} ) { 14186 exchange1( $mysync ) ; 14187 } 14188 14189 if ( $mysync->{exchange2} ) { 14190 exchange2( $mysync ) ; 14191 } 14192 14193 14194 # Domino 14195 if ( $mysync->{domino1} ) { 14196 domino1( $mysync ) ; 14197 } 14198 14199 if ( $mysync->{domino2} ) { 14200 domino2( $mysync ) ; 14201 } 14202 14203 return ; 14204} 14205 14206# From https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt 14207sub gmail12 14208{ 14209 my $mysync = shift ; 14210 # Gmail at host1 and host2 14211 $mysync->{host1} ||= 'imap.gmail.com' ; 14212 $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; 14213 $mysync->{host2} ||= 'imap.gmail.com' ; 14214 $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; 14215 $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 when computed from Gmail documentation 14216 $mysync->{maxbytesafter} ||= 1_000_000_000 ; 14217 $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; 14218 $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; 14219 $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 0 ; 14220 $mysync->{ synclabels } = ( defined $mysync->{ synclabels } ) ? $mysync->{ synclabels } : 1 ; 14221 $mysync->{ reynclabels } = ( defined $mysync->{ reynclabels } ) ? $mysync->{ reynclabels } : 1 ; 14222 push @exclude, '\[Gmail\]$' ; 14223 push @folderlast, '[Gmail]/All Mail' ; 14224 return ; 14225} 14226 14227 14228sub gmail1 14229{ 14230 my $mysync = shift ; 14231 # Gmail at host2 14232 $mysync->{host1} ||= 'imap.gmail.com' ; 14233 $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; 14234 $mysync->{maxbytespersecond} ||= 40_000 ; # should be 20_000 computed from by Gmail documentation 14235 $mysync->{maxbytesafter} ||= 2_500_000_000 ; 14236 $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; 14237 $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; 14238 $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ; 14239 14240 push @useheader, 'X-Gmail-Received', 'Message-Id' ; 14241 push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ; 14242 push @folderlast, '[Gmail]/All Mail' ; 14243 return ; 14244} 14245 14246sub gmail2 14247{ 14248 my $mysync = shift ; 14249 # Gmail at host2 14250 $mysync->{host2} ||= 'imap.gmail.com' ; 14251 $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; 14252 $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 computed from by Gmail documentation 14253 $mysync->{maxbytesafter} ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000 14254 #$mysync->{ maxsize } ||= 25_000_000 ; 14255 $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; 14256 #$skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ; 14257 $mysync->{ expunge1 } = ( defined $mysync->{ expunge1 } ) ? $mysync->{ expunge1 } : 1 ; 14258 $mysync->{addheader} = ( defined $mysync->{addheader} ) ? $mysync->{addheader} : 1 ; 14259 $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; 14260 14261 $mysync->{maxsize} = ( defined $mysync->{maxsize} ) ? $mysync->{maxsize} : $GMAIL_MAXSIZE ; 14262 14263 if ( ! $mysync->{noexclude} ) { 14264 push @exclude, '\[Gmail\]$' ; 14265 } 14266 push @useheader, 'Message-Id' ; 14267 push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ; 14268 14269 # push @{ $mysync->{ regextrans2 } }, 's/[ ]+/_/g' ; # is now replaced 14270 # by the two more specific following regexes, 14271 # they remove just the beginning and trailing blanks, not all. 14272 push @{ $mysync->{ regextrans2 } }, 's,^ +| +$,,g' ; 14273 push @{ $mysync->{ regextrans2 } }, 's,/ +| +/,/,g' ; 14274 # 14275 push @{ $mysync->{ regextrans2 } }, q{s/['\\^"]/_/g} ; # Verified this 14276 push @folderlast, '[Gmail]/All Mail' ; 14277 return ; 14278} 14279 14280 14281# From https://imapsync.lamiral.info/FAQ.d/FAQ.Exchange.txt 14282sub office1 14283{ 14284 # Office 365 at host1 14285 my $mysync = shift ; 14286 14287 output( $mysync, q{Option --office1 is like: --host1 outlook.office365.com --ssl1 --exclude "^Files$"} . "\n" ) ; 14288 output( $mysync, "Option --office1 (cont) : unless overrided with --host1 otherhost --nossl1 --noexclude\n" ) ; 14289 $mysync->{host1} ||= 'outlook.office365.com' ; 14290 $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; 14291 if ( ! $mysync->{noexclude} ) { 14292 push @exclude, '^Files$' ; 14293 } 14294 return ; 14295} 14296 14297 14298sub office2 14299{ 14300 # Office 365 at host2 14301 my $mysync = shift ; 14302 output( $mysync, qq{Option --office2 is like: --host2 outlook.office365.com --ssl2 --maxsize 45_000_000 --maxmessagespersecond 4\n} ) ; 14303 output( $mysync, qq{Option --office2 (cont) : --disarmreadreceipts --regexmess "wrap 10500" --f1f2 "Files=Files_renamed_by_imapsync"\n} ) ; 14304 output( $mysync, qq{Option --office2 (cont) : unless overrided with --host2 otherhost --nossl2 ... --nodisarmreadreceipts --noregexmess\n} ) ; 14305 output( $mysync, qq{Option --office2 (cont) : and --nof1f2 to avoid Files folder renamed to Files_renamed_by_imapsync\n} ) ; 14306 $mysync->{host2} ||= 'outlook.office365.com' ; 14307 $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; 14308 $mysync->{ maxsize } ||= 45_000_000 ; 14309 $mysync->{maxmessagespersecond} ||= 4 ; 14310 #push @regexflag, 's/\\\\Flagged//g' ; # No problem without! tested 2018_09_10 14311 $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; 14312 # I dislike double negation but here is one 14313 if ( ! $mysync->{noregexmess} ) 14314 { 14315 push @regexmess, 's,(.{10239}),$1\r\n,g' ; 14316 } 14317 # and another... 14318 if ( ! $mysync->{nof1f2} ) 14319 { 14320 push @{ $mysync->{f1f2} }, 'Files=Files_renamed_by_imapsync' ; 14321 } 14322 return ; 14323} 14324 14325sub exchange1 14326{ 14327 # Exchange 2010/2013 at host1 14328 my $mysync = shift ; 14329 output( $mysync, "Option --exchange1 does nothing (except printing this line...)\n" ) ; 14330 # Well nothing to do so far 14331 return ; 14332} 14333 14334sub exchange2 14335{ 14336 # Exchange 2010/2013 at host2 14337 my $mysync = shift ; 14338 output( $mysync, "Option --exchange2 is like: --maxsize 10_000_000 --maxmessagespersecond 4 --disarmreadreceipts\n" ) ; 14339 output( $mysync, "Option --exchange2 (cont) : --regexflag del Flagged --regexmess wrap 10500\n" ) ; 14340 output( $mysync, "Option --exchange2 (cont) : unless overrided with --maxsize xxx --nodisarmreadreceipts --noregexflag --noregexmess\n" ) ; 14341 $mysync->{ maxsize } ||= 10_000_000 ; 14342 $mysync->{maxmessagespersecond} ||= 4 ; 14343 $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; 14344 # I dislike double negation but here are two 14345 if ( ! $mysync->{noregexflag} ) { 14346 push @regexflag, 's/\\\\Flagged//g' ; 14347 } 14348 if ( ! $mysync->{noregexmess} ) { 14349 push @regexmess, 's,(.{10239}),$1\r\n,g' ; 14350 } 14351 return ; 14352} 14353 14354sub domino1 14355{ 14356 # Domino at host1 14357 my $mysync = shift ; 14358 14359 $mysync->{ sep1 } = q{\\} ; 14360 $prefix1 = q{} ; 14361 $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ; 14362 return ; 14363} 14364 14365sub domino2 14366{ 14367 # Domino at host1 14368 my $mysync = shift ; 14369 14370 $mysync->{ sep2 } = q{\\} ; 14371 $prefix2 = q{} ; 14372 $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ; 14373 push @{ $mysync->{ regextrans2 } }, 's,^Inbox\\\\(.*),$1,i' ; 14374 return ; 14375} 14376 14377 14378sub tests_resolv 14379{ 14380 note( 'Entering tests_resolv()' ) ; 14381 14382 # is( , resolv( ), 'resolv: => ' ) ; 14383 is( undef, resolv( ), 'resolv: no args => undef' ) ; 14384 is( undef, resolv( '' ), 'resolv: empty string => undef' ) ; 14385 is( undef, resolv( 'hostnotexist' ), 'resolv: hostnotexist => undef' ) ; 14386 is( '127.0.0.1', resolv( '127.0.0.1' ), 'resolv: 127.0.0.1 => 127.0.0.1' ) ; 14387 is( '127.0.0.1', resolv( 'localhost' ), 'resolv: localhost => 127.0.0.1' ) ; 14388 is( '5.135.158.182', resolv( 'imapsync.lamiral.info' ), 'resolv: imapsync.lamiral.info => 5.135.158.182' ) ; 14389 14390 # ip6-localhost ( in /etc/hosts ) 14391 is( '::1', resolv( 'ip6-localhost' ), 'resolv: ip6-localhost => ::1' ) ; 14392 is( '::1', resolv( '::1' ), 'resolv: ::1 => ::1' ) ; 14393 # ks2 14394 is( '2001:41d0:8:d8b6::1', resolv( '2001:41d0:8:d8b6::1' ), 'resolv: 2001:41d0:8:d8b6::1 => 2001:41d0:8:d8b6::1' ) ; 14395 is( '2001:41d0:8:d8b6::1', resolv( 'ks2ipv6.lamiral.info' ), 'resolv: ks2ipv6.lamiral.info => 2001:41d0:8:d8b6::1' ) ; 14396 # ks3 14397 is( '2001:41d0:8:bebd::1', resolv( '2001:41d0:8:bebd::1' ), 'resolv: 2001:41d0:8:bebd::1 => 2001:41d0:8:bebd::1' ) ; 14398 is( '2001:41d0:8:bebd::1', resolv( 'ks3ipv6.lamiral.info' ), 'resolv: ks3ipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ; 14399 14400 14401 note( 'Leaving tests_resolv()' ) ; 14402 return ; 14403} 14404 14405 14406 14407sub resolv 14408{ 14409 my $host = shift @ARG ; 14410 14411 if ( ! $host ) { return ; } 14412 my $addr ; 14413 if ( defined &Socket::getaddrinfo ) { 14414 $addr = resolv_with_getaddrinfo( $host ) ; 14415 return( $addr ) ; 14416 } 14417 14418 14419 14420 my $iaddr = inet_aton( $host ) ; 14421 if ( ! $iaddr ) { return ; } 14422 $addr = inet_ntoa( $iaddr ) ; 14423 14424 return $addr ; 14425} 14426 14427sub resolv_with_getaddrinfo 14428{ 14429 my $host = shift @ARG ; 14430 14431 if ( ! $host ) { return ; } 14432 14433 my ( $err_getaddrinfo, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; 14434 if ( $err_getaddrinfo ) { 14435 myprint( "Cannot getaddrinfo of $host: $err_getaddrinfo\n" ) ; 14436 return ; 14437 } 14438 14439 my @addr ; 14440 while( my $ai = shift @res ) { 14441 my ( $err_getnameinfo, $ipaddr ) = Socket::getnameinfo( $ai->{addr}, Socket::NI_NUMERICHOST(), Socket::NIx_NOSERV() ) ; 14442 if ( $err_getnameinfo ) { 14443 myprint( "Cannot getnameinfo of $host: $err_getnameinfo\n" ) ; 14444 return ; 14445 } 14446 $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ; 14447 push @addr, $ipaddr ; 14448 my $reverse ; 14449 ( $err_getnameinfo, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; 14450 $sync->{ debug } and myprint( "$host => $ipaddr => $reverse\n" ) ; 14451 } 14452 14453 return $addr[0] ; 14454} 14455 14456sub tests_resolvrev 14457{ 14458 note( 'Entering tests_resolvrev()' ) ; 14459 14460 # is( , resolvrev( ), 'resolvrev: => ' ) ; 14461 is( undef, resolvrev( ), 'resolvrev: no args => undef' ) ; 14462 is( undef, resolvrev( '' ), 'resolvrev: empty string => undef' ) ; 14463 is( undef, resolvrev( 'hostnotexist' ), 'resolvrev: hostnotexist => undef' ) ; 14464 is( 'localhost', resolvrev( '127.0.0.1' ), 'resolvrev: 127.0.0.1 => localhost' ) ; 14465 is( 'localhost', resolvrev( 'localhost' ), 'resolvrev: localhost => localhost' ) ; 14466 is( 'ks.lamiral.info', resolvrev( 'imapsync.lamiral.info' ), 'resolvrev: imapsync.lamiral.info => ks.lamiral.info' ) ; 14467 14468 # ip6-localhost ( in /etc/hosts ) 14469 is( 'ip6-localhost', resolvrev( 'ip6-localhost' ), 'resolvrev: ip6-localhost => ip6-localhost' ) ; 14470 is( 'ip6-localhost', resolvrev( '::1' ), 'resolvrev: ::1 => ip6-localhost' ) ; 14471 # ks2 14472 is( 'ks2ipv6.lamiral.info', resolvrev( '2001:41d0:8:d8b6::1' ), 'resolvrev: 2001:41d0:8:d8b6::1 => ks2ipv6.lamiral.info' ) ; 14473 is( 'ks2ipv6.lamiral.info', resolvrev( 'ks2ipv6.lamiral.info' ), 'resolvrev: ks2ipv6.lamiral.info => ks2ipv6.lamiral.info' ) ; 14474 # ks3 14475 is( 'ks3ipv6.lamiral.info', resolvrev( '2001:41d0:8:bebd::1' ), 'resolvrev: 2001:41d0:8:bebd::1 => ks3ipv6.lamiral.info' ) ; 14476 is( 'ks3ipv6.lamiral.info', resolvrev( 'ks3ipv6.lamiral.info' ), 'resolvrev: ks3ipv6.lamiral.info => ks3ipv6.lamiral.info' ) ; 14477 14478 14479 note( 'Leaving tests_resolvrev()' ) ; 14480 return ; 14481} 14482 14483sub resolvrev 14484{ 14485 my $host = shift @ARG ; 14486 14487 if ( ! $host ) { return ; } 14488 14489 if ( defined &Socket::getaddrinfo ) { 14490 my $name = resolvrev_with_getaddrinfo( $host ) ; 14491 return( $name ) ; 14492 } 14493 14494 return ; 14495} 14496 14497sub resolvrev_with_getaddrinfo 14498{ 14499 my $host = shift @ARG ; 14500 14501 if ( ! $host ) { return ; } 14502 14503 my ( $err, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; 14504 if ( $err ) { 14505 myprint( "Cannot getaddrinfo of $host: $err\n" ) ; 14506 return ; 14507 } 14508 14509 my @name ; 14510 while( my $ai = shift @res ) { 14511 my ( $err, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; 14512 if ( $err ) { 14513 myprint( "Cannot getnameinfo of $host: $err\n" ) ; 14514 return ; 14515 } 14516 $sync->{ debug } and myprint( "$host => $reverse\n" ) ; 14517 push @name, $reverse ; 14518 } 14519 14520 return $name[0] ; 14521} 14522 14523 14524 14525sub tests_imapsping 14526{ 14527 note( 'Entering tests_imapsping()' ) ; 14528 14529 is( undef, imapsping( ), 'imapsping: no args => undef' ) ; 14530 is( undef, imapsping( 'hostnotexist' ), 'imapsping: hostnotexist => undef' ) ; 14531 is( 1, imapsping( 'imapsync.lamiral.info' ), 'imapsping: imapsync.lamiral.info => 1' ) ; 14532 is( 1, imapsping( 'ks2ipv6.lamiral.info' ), 'imapsping: ks2ipv6.lamiral.info => 1' ) ; 14533 note( 'Leaving tests_imapsping()' ) ; 14534 return ; 14535} 14536 14537sub imapsping 14538{ 14539 my $host = shift ; 14540 return tcpping( $host, $IMAP_SSL_PORT ) ; 14541} 14542 14543sub tests_tcpping 14544{ 14545 note( 'Entering tests_tcpping()' ) ; 14546 14547 is( undef, tcpping( ), 'tcpping: no args => undef' ) ; 14548 is( undef, tcpping( 'hostnotexist' ), 'tcpping: one arg => undef' ) ; 14549 is( undef, tcpping( undef, 888 ), 'tcpping: arg undef, port => undef' ) ; 14550 is( undef, tcpping( 'hostnotexist', 993 ), 'tcpping: hostnotexist 993 => undef' ) ; 14551 is( undef, tcpping( 'hostnotexist', 888 ), 'tcpping: hostnotexist 888 => undef' ) ; 14552 is( 1, tcpping( 'imapsync.lamiral.info', 993 ), 'tcpping: imapsync.lamiral.info 993 => 1' ) ; 14553 is( 0, tcpping( 'imapsync.lamiral.info', 888 ), 'tcpping: imapsync.lamiral.info 888 => 0' ) ; 14554 is( 1, tcpping( '5.135.158.182', 993 ), 'tcpping: 5.135.158.182 993 => 1' ) ; 14555 is( 0, tcpping( '5.135.158.182', 888 ), 'tcpping: 5.135.158.182 888 => 0' ) ; 14556 14557 # Net::Ping supports ipv6 only after release 1.50 14558 # http://cpansearch.perl.org/src/RURBAN/Net-Ping-2.59/Changes 14559 # Anyway I plan to avoid Net-Ping for that too long standing feature 14560 # Net-Ping is integrated in Perl itself, who knows ipv6 for a long time 14561 is( 1, tcpping( '2001:41d0:8:d8b6::1', 993 ), 'tcpping: 2001:41d0:8:d8b6::1 993 => 1' ) ; 14562 is( 0, tcpping( '2001:41d0:8:d8b6::1', 888 ), 'tcpping: 2001:41d0:8:d8b6::1 888 => 0' ) ; 14563 14564 note( 'Leaving tests_tcpping()' ) ; 14565 return ; 14566} 14567 14568sub tcpping 14569{ 14570 if ( 2 != scalar( @ARG ) ) { 14571 return ; 14572 } 14573 my ( $host, $port ) = @ARG ; 14574 if ( ! $host ) { return ; } 14575 if ( ! $port ) { return ; } 14576 14577 my $mytimeout = $TCP_PING_TIMEOUT ; 14578 require Net::Ping ; 14579 #my $p = Net::Ping->new( 'tcp' ) ; 14580 my $p = Net::Ping->new( ) ; 14581 $p->{port_num} = $port ; 14582 $p->service_check( 1 ) ; 14583 $p->hires( 1 ) ; 14584 my ($ping_ok, $rtt, $ip ) = $p->ping( $host, $mytimeout ) ; 14585 if ( ! defined $ping_ok ) { return ; } 14586 my $rtt_approx = sprintf( "%.3f", $rtt ) ; 14587 $sync->{ debug } and myprint( "Host $host timeout $mytimeout port $port ok $ping_ok ip $ip acked in $rtt_approx s\n" ) ; 14588 $p->close( ) ; 14589 if( $ping_ok ) { 14590 return 1 ; 14591 }else{ 14592 return 0 ; 14593 } 14594} 14595 14596sub tests_sslcheck 14597{ 14598 note( 'Entering tests_sslcheck()' ) ; 14599 14600 my $mysync ; 14601 14602 is( undef, sslcheck( $mysync ), 'sslcheck: no sslcheck => undef' ) ; 14603 14604 $mysync = { 14605 sslcheck => 1, 14606 } ; 14607 14608 is( 0, sslcheck( $mysync ), 'sslcheck: no host => 0' ) ; 14609 14610 $mysync = { 14611 sslcheck => 1, 14612 host1 => 'imapsync.lamiral.info', 14613 tls1 => 1, 14614 } ; 14615 14616 is( 0, sslcheck( $mysync ), 'sslcheck: tls1 => 0' ) ; 14617 14618 $mysync = { 14619 sslcheck => 1, 14620 host1 => 'imapsync.lamiral.info', 14621 } ; 14622 14623 14624 is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info => 1' ) ; 14625 is( 1, $mysync->{ssl1}, 'sslcheck: imapsync.lamiral.info => ssl1 1' ) ; 14626 14627 $mysync->{sslcheck} = 0 ; 14628 is( undef, sslcheck( $mysync ), 'sslcheck: sslcheck off => undef' ) ; 14629 14630 $mysync = { 14631 sslcheck => 1, 14632 host1 => 'imapsync.lamiral.info', 14633 host2 => 'test2.lamiral.info', 14634 } ; 14635 14636 is( 2, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info + test2.lamiral.info => 2' ) ; 14637 14638 $mysync = { 14639 sslcheck => 1, 14640 host1 => 'imapsync.lamiral.info', 14641 host2 => 'test2.lamiral.info', 14642 tls1 => 1, 14643 } ; 14644 14645 is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info + test2.lamiral.info + tls1 => 1' ) ; 14646 14647 note( 'Leaving tests_sslcheck()' ) ; 14648 return ; 14649} 14650 14651sub sslcheck 14652{ 14653 my $mysync = shift ; 14654 14655 if ( ! $mysync->{sslcheck} ) { 14656 return ; 14657 } 14658 my $nb_on = 0 ; 14659 $mysync->{ debug } and myprint( "sslcheck\n" ) ; 14660 if ( 14661 ( ! defined $mysync->{port1} ) 14662 and 14663 ( ! defined $mysync->{tls1} ) 14664 and 14665 ( ! defined $mysync->{ssl1} ) 14666 and 14667 ( defined $mysync->{host1} ) 14668 ) { 14669 myprint( "Host1: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ; 14670 if ( probe_imapssl( $mysync->{host1} ) ) { 14671 $mysync->{ssl1} = 1 ; 14672 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" ) ; 14673 $nb_on++ ; 14674 }else{ 14675 myprint( "Host1: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ; 14676 } 14677 } 14678 14679 if ( 14680 ( ! defined $mysync->{port2} ) 14681 and 14682 ( ! defined $mysync->{tls2} ) 14683 and 14684 ( ! defined $mysync->{ssl2} ) 14685 and 14686 ( defined $mysync->{host2} ) 14687 ) { 14688 myprint( "Host2: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ; 14689 if ( probe_imapssl( $mysync->{host2} ) ) { 14690 $mysync->{ssl2} = 1 ; 14691 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" ) ; 14692 $nb_on++ ; 14693 }else{ 14694 myprint( "Host2: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ; 14695 } 14696 } 14697 return $nb_on ; 14698} 14699 14700 14701sub testslive 14702{ 14703 my $mysync = shift ; 14704 $mysync->{host1} ||= 'test1.lamiral.info' ; 14705 $mysync->{user1} ||= 'test1' ; 14706 $mysync->{password1} ||= 'secret1' ; 14707 $mysync->{host2} ||= 'test2.lamiral.info' ; 14708 $mysync->{user2} ||= 'test2' ; 14709 $mysync->{password2} ||= 'secret2' ; 14710 return ; 14711} 14712 14713sub testslive6 14714{ 14715 my $mysync = shift ; 14716 $mysync->{host1} ||= 'ks2ipv6.lamiral.info' ; 14717 $mysync->{user1} ||= 'test1' ; 14718 $mysync->{password1} ||= 'secret1' ; 14719 $mysync->{host2} ||= 'ks2ipv6.lamiral.info' ; 14720 $mysync->{user2} ||= 'test2' ; 14721 $mysync->{password2} ||= 'secret2' ; 14722 return ; 14723} 14724 14725 14726sub tests_backslash_caret 14727{ 14728 note( 'Entering tests_backslash_caret()' ) ; 14729 14730 is( "lalala", backslash_caret( "lalala" ), 'backslash_caret: lalala => lalala' ) ; 14731 is( "lalala\n", backslash_caret( "lalala\n" ), 'backslash_caret: lalala => lalala 2nd' ) ; 14732 is( '^', backslash_caret( '\\' ), 'backslash_caret: \\ => ^' ) ; 14733 is( "^\n", backslash_caret( "\\\n" ), 'backslash_caret: \\ => ^' ) ; 14734 is( "\\lalala", backslash_caret( "\\lalala" ), 'backslash_caret: \\lalala => \\lalala' ) ; 14735 is( "\\lal\\ala", backslash_caret( "\\lal\\ala" ), 'backslash_caret: \\lal\\ala => \\lal\\ala' ) ; 14736 is( "\\lalala\n", backslash_caret( "\\lalala\n" ), 'backslash_caret: \\lalala => \\lalala 2nd' ) ; 14737 is( "lalala^\n", backslash_caret( "lalala\\\n" ), 'backslash_caret: lalala\\\n => lalala^\n' ) ; 14738 is( "lalala^\nlalala^\n", backslash_caret( "lalala\\\nlalala\\\n" ), 'backslash_caret: lalala\\\nlalala\\\n => lalala^\nlalala^\n' ) ; 14739 is( "lal\\ala^\nlalala^\n", backslash_caret( "lal\\ala\\\nlalala\\\n" ), 'backslash_caret: lal\\ala\\\nlalala\\\n => lal\\ala^\nlalala^\n' ) ; 14740 14741 note( 'Leaving tests_backslash_caret()' ) ; 14742 return ; 14743} 14744 14745sub backslash_caret 14746{ 14747 my $string = shift ; 14748 14749 $string =~ s{\\ $ }{^}gxms ; 14750 14751 return $string ; 14752} 14753 14754sub tests_split_around_equal 14755{ 14756 note( 'Entering tests_split_around_equal()' ) ; 14757 14758 is( undef, split_around_equal( ), 'split_around_equal: no args => undef' ) ; 14759 is_deeply( { toto => 'titi' }, { split_around_equal( 'toto=titi' ) }, 'split_around_equal: toto=titi => toto => titi' ) ; 14760 is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B=C=D' ) }, 'split_around_equal: toto=titi => toto => titi' ) ; 14761 is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B', 'C=D' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ; 14762 14763 note( 'Leaving tests_split_around_equal()' ) ; 14764 return ; 14765} 14766 14767sub split_around_equal 14768{ 14769 if ( ! @ARG ) { return ; } ; 14770 return map { split /=/mxs, $_ } @ARG ; 14771 14772} 14773 14774 14775 14776sub tests_sig_install 14777{ 14778 note( 'Entering tests_sig_install()' ) ; 14779 14780 my $mysync ; 14781 is( undef, sig_install( ), 'sig_install: no args => undef' ) ; 14782 is( undef, sig_install( $mysync ), 'sig_install: arg undef => undef' ) ; 14783 $mysync = { } ; 14784 is( undef, sig_install( $mysync ), 'sig_install: empty hash => undef' ) ; 14785 14786 SKIP: { 14787 Readonly my $SKIP_15 => 15 ; 14788 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_15 ) ; } 14789 # Default to ignore USR1 USR2 in case future install fails 14790 local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ; 14791 kill( 'USR1', $PROCESS_ID ) ; 14792 14793 $mysync->{ debugsig } = 1 ; 14794 # Assign USR1 to call sub tototo 14795 # Surely a better value than undef should be returned when doing real signal stuff 14796 is( undef, sig_install( $mysync, 'tototo', 'USR1' ), 'sig_install: USR1 tototo' ) ; 14797 14798 is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 1' ) ; 14799 is( 1, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 1' ) ; 14800 14801 #return ; 14802 # Assign USR2 to call sub tototo 14803 is( undef, sig_install( $mysync, 'tototo', 'USR2' ), 'sig_install: USR2 tototo' ) ; 14804 14805 is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR2 myself 1' ) ; 14806 is( 2, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 2' ) ; 14807 14808 is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ; 14809 is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 3' ) ; 14810 14811 14812 local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ; 14813 is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 3' ) ; 14814 is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call still nb 3' ) ; 14815 14816 # Assign USR1 + USR2 to call sub tototo 14817 is( undef, sig_install( $mysync, 'tototo', 'USR1', 'USR2' ), 'sig_install: USR1 USR2 tototo' ) ; 14818 is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 4' ) ; 14819 is( 4, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 4' ) ; 14820 14821 is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ; 14822 is( 5, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 5' ) ; 14823 } 14824 14825 14826 note( 'Leaving tests_sig_install()' ) ; 14827 return ; 14828} 14829 14830 14831# 14832sub sig_install 14833{ 14834 my $mysync = shift ; 14835 if ( ! $mysync ) { return ; } 14836 my $mysubname = shift ; 14837 if ( ! $mysubname ) { return ; } 14838 14839 if ( ! @ARG ) { return ; } 14840 14841 my @signals = @ARG ; 14842 14843 my $mysub = \&$mysubname ; 14844 #$mysync->{ debugsig } = 1 ; 14845 $mysync->{ debugsig } and myprint( "In sig_install with sub $mysubname and signal @ARG\n" ) ; 14846 14847 my $subsignal = sub { 14848 my $signame = shift ; 14849 $mysync->{ debugsig } and myprint( "In subsignal with $signame and $mysubname\n" ) ; 14850 &$mysub( $mysync, $signame ) ; 14851 } ; 14852 14853 foreach my $signal ( @signals ) { 14854 $mysync->{ debugsig } and myprint( "Installing signal $signal to call sub $mysubname\n") ; 14855 output( $mysync, "kill -$signal $PROCESS_ID # special behavior: call to sub $mysubname\n" ) ; 14856 ## no critic (RequireLocalizedPunctuationVars) 14857 $SIG{ $signal } = $subsignal ; 14858 } 14859 return ; 14860} 14861 14862 14863sub tototo 14864{ 14865 my $mysync = shift ; 14866 myprint("In tototo with @ARG\n" ) ; 14867 $mysync->{ tototo_calls } += 1 ; 14868 return ; 14869} 14870 14871sub mygetppid 14872{ 14873 if ( 'MSWin32' eq $OSNAME ) { 14874 return( 'unknown under MSWin32 (too complicated)' ) ; 14875 } else { 14876 # Unix 14877 return( getppid( ) ) ; 14878 } 14879} 14880 14881 14882 14883sub tests_toggle_sleep 14884{ 14885 note( 'Entering tests_toggle_sleep()' ) ; 14886 14887 is( undef, toggle_sleep( ), 'toggle_sleep: no args => undef' ) ; 14888 my $mysync ; 14889 is( undef, toggle_sleep( $mysync ), 'toggle_sleep: undef => undef' ) ; 14890 $mysync = { } ; 14891 is( undef, toggle_sleep( $mysync ), 'toggle_sleep: no maxsleep => undef' ) ; 14892 14893 $mysync->{maxsleep} = 3 ; 14894 is( 0, toggle_sleep( $mysync ), 'toggle_sleep: 3 => 0' ) ; 14895 14896 is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ; 14897 is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ; 14898 is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ; 14899 is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ; 14900 14901 SKIP: { 14902 Readonly my $SKIP_9 => 9 ; 14903 if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_9 ) ; } 14904 # Default to ignore USR1 USR2 in case future install fails 14905 local $SIG{ USR1 } = sub { } ; 14906 kill( 'USR1', $PROCESS_ID ) ; 14907 14908 $mysync->{ debugsig } = 1 ; 14909 # Assign USR1 to call sub toggle_sleep 14910 is( undef, sig_install( $mysync, \&toggle_sleep, 'USR1' ), 'toggle_sleep: install USR1 toggle_sleep' ) ; 14911 14912 14913 $mysync->{maxsleep} = 4 ; 14914 is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ; 14915 is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ; 14916 14917 is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ; 14918 is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ; 14919 14920 is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ; 14921 is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ; 14922 14923 is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ; 14924 is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ; 14925 } 14926 14927 note( 'Leaving tests_toggle_sleep()' ) ; 14928 return ; 14929} 14930 14931 14932sub toggle_sleep 14933{ 14934 my $mysync = shift ; 14935 14936 myprint("In toggle_sleep with @ARG\n" ) ; 14937 14938 if ( !defined( $mysync ) ) { return ; } 14939 if ( !defined( $mysync->{maxsleep} ) ) { return ; } 14940 14941 $mysync->{ maxsleep } = max( 0, $MAX_SLEEP - $mysync->{maxsleep} ) ; 14942 myprint("Resetting maxsleep to ", $mysync->{maxsleep}, "s\n" ) ; 14943 return $mysync->{maxsleep} ; 14944} 14945 14946sub mypod2usage 14947{ 14948 my $fh_pod2usage = shift ; 14949 14950 pod2usage( 14951 -exitval => 'NOEXIT', 14952 -noperldoc => 1, 14953 -verbose => 99, 14954 -sections => [ qw(NAME VERSION USAGE OPTIONS) ], 14955 -indent => 1, 14956 -loose => 1, 14957 -output => $fh_pod2usage, 14958 ) ; 14959 14960 return ; 14961} 14962 14963sub usage 14964{ 14965 my $mysync = shift ; 14966 14967 if ( ! defined $mysync ) { return ; } 14968 14969 my $usage = q{} ; 14970 my $usage_from_pod ; 14971 my $usage_footer = usage_footer( $mysync ) ; 14972 14973 # pod2usage writes on a filehandle only and I want a variable 14974 open my $fh_pod2usage, ">", \$usage_from_pod 14975 or do { warn $OS_ERROR ; return ; } ; 14976 mypod2usage( $fh_pod2usage ) ; 14977 close $fh_pod2usage ; 14978 14979 if ( 'MSWin32' eq $OSNAME ) { 14980 $usage_from_pod = backslash_caret( $usage_from_pod ) ; 14981 } 14982 $usage = join( q{}, $usage_from_pod, $usage_footer ) ; 14983 14984 return( $usage ) ; 14985} 14986 14987sub tests_usage 14988{ 14989 note( 'Entering tests_usage()' ) ; 14990 14991 my $usage ; 14992 like( $usage = usage( $sync ), qr/Name:/, 'usage: contains Name:' ) ; 14993 myprint( $usage ) ; 14994 like( $usage, qr/Version:/, 'usage: contains Version:' ) ; 14995 like( $usage, qr/Usage:/, 'usage: contains Usage:' ) ; 14996 like( $usage, qr/imapsync/, 'usage: contains imapsync' ) ; 14997 14998 is( undef, usage( ), 'usage: no args => undef' ) ; 14999 15000 note( 'Leaving tests_usage()' ) ; 15001 return ; 15002} 15003 15004 15005sub usage_footer 15006{ 15007 my $mysync = shift ; 15008 15009 my $footer = q{} ; 15010 15011 my $localhost_info = localhost_info( $mysync ) ; 15012 my $rcs = $mysync->{rcs} ; 15013 my $homepage = homepage( ) ; 15014 15015 my $imapsync_release = $STR_use_releasecheck ; 15016 15017 if ( $mysync->{releasecheck} ) { 15018 $imapsync_release = check_last_release( ) ; 15019 } 15020 15021 $footer = qq{$localhost_info 15022$rcs 15023$imapsync_release 15024$homepage 15025} ; 15026 return( $footer ) ; 15027} 15028 15029 15030 15031sub usage_complete 15032{ 15033 # Unused, I guess this function could be deleted 15034 my $usage = <<'EOF' ; 15035--skipheader reg : Don't take into account header keyword 15036 matching reg ex: --skipheader 'X.*' 15037 15038--skipsize : Don't take message size into account to compare 15039 messages on both sides. On by default. 15040 Use --no-skipsize for using size comparaison. 15041--allowsizemismatch : allow RFC822.SIZE != fetched msg size 15042 consider also --skipsize to avoid duplicate messages 15043 when running syncs more than one time per mailbox 15044 15045--reconnectretry1 int : reconnect to host1 if connection is lost up to 15046 int times per imap command (default is 3) 15047--reconnectretry2 int : same as --reconnectretry1 but for host2 15048--split1 int : split the requests in several parts on host1. 15049 int is the number of messages handled per request. 15050 default is like --split1 100. 15051--split2 int : same thing on host2. 15052--nofixInboxINBOX : Don't fix Inbox INBOX mapping. 15053EOF 15054 return( $usage ) ; 15055} 15056 15057sub myGetOptions 15058{ 15059 15060 # Started as a copy of Luke Ross Getopt::Long::CGI 15061 # https://metacpan.org/release/Getopt-Long-CGI 15062 # So this sub function is under the same license as Getopt-Long-CGI Luke Ross wants it, 15063 # which was Perl 5.6 or later licenses at the date of the copy. 15064 15065 my $mysync = shift @ARG ; 15066 my $arguments_ref = shift @ARG ; 15067 my %options = @ARG ; 15068 15069 my $mycgi = $mysync->{cgi} ; 15070 15071 if ( not under_cgi_context() ) { 15072 15073 # Not CGI - pass upstream for normal command line handling 15074 return Getopt::Long::GetOptionsFromArray( $arguments_ref, %options ) ; 15075 } 15076 15077 # We must be in CGI context now 15078 if ( ! defined( $mycgi ) ) { return ; } 15079 15080 my $badthings = 0 ; 15081 foreach my $key ( sort keys %options ) { 15082 my $val = $options{$key} ; 15083 15084 if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) { 15085 $badthings++ ; 15086 next ; # Unknown item 15087 } 15088 15089 my $name = [ split '|', $1, 1 ]->[0] ; 15090 15091 if ( ( $3 || q{} ) eq '+' ) { 15092 ${$val} = $mycgi->param( $name ) ; # "Incremental" integer 15093 } 15094 elsif ( $2 ) { 15095 my @values = $mycgi->multi_param( $name ) ; 15096 my $type = $2 ; 15097 15098 #myprint( "type[$type]values[@values]\$3[", $3 || q{}, "]val[$val]ref(val)[", ref($val), "]\n" ) ; 15099 if ( ( $3 || q{} ) eq '%' or ref( $val ) eq 'HASH' ) { 15100 my %values = map { split /=/mxs, $_ } @values ; 15101 15102 if ( $type =~ m/i$/mxs ) { 15103 foreach my $k ( keys %values ) { 15104 $values{$k} = int $values{$k} ; 15105 } 15106 } 15107 elsif ( $type =~ m/f$/mxs ) { 15108 foreach my $k ( keys %values ) { 15109 $values{$k} = 0 + $values{$k}; 15110 } 15111 } 15112 if ( 'REF' eq ref $val ) { 15113 %{ ${$val} } = %values ; 15114 } 15115 else { 15116 %{$val} = %values ; 15117 } 15118 } 15119 else { 15120 if ( $type =~ m/i$/mxs ) { 15121 @values = map { q{} ne $_ ? int $_ : undef } @values ; 15122 } 15123 elsif ( $type =~ m/f$/mxs ) { 15124 @values = map { 0 + $_ } @values ; 15125 } 15126 if ( ( $3 || q{} ) eq '@' ) { 15127 @{ ${$val} } = @values ; 15128 my @option = map { +( "--$name", "$_" ) } @values ; 15129 push @{ $mysync->{ cmdcgi } }, @option ; 15130 } 15131 elsif ( ref( $val ) eq 'ARRAY' ) { 15132 @{$val} = @values ; 15133 } 15134 elsif ( my $value = $values[0] ) 15135 { 15136 ${$val} = $value ; 15137 push @{ $mysync->{ cmdcgi } }, "--$name", $value ; 15138 } 15139 else 15140 { 15141 15142 } 15143 } 15144 } 15145 else 15146 { 15147 # Checkbox 15148 # Considers only --name 15149 # Should consider also --no-name and --noname 15150 my $value = $mycgi->param( $name ) ; 15151 if ( $value ) 15152 { 15153 ${$val} = 1 ; 15154 push @{ $mysync->{ cmdcgi } }, "--$name" ; 15155 } 15156 else 15157 { 15158 ${$val} = undef ; 15159 } 15160 } 15161 } 15162 if ( $badthings ) { 15163 return ; # undef or () 15164 } 15165 else { 15166 return ( 1 ) ; 15167 } 15168} 15169 15170 15171my @blabla ; # just used to check get_options_cgi() with an array 15172 15173sub tests_get_options_cgi_context 15174{ 15175 note( 'Entering tests_get_options_cgi()' ) ; 15176 15177# Temporary, have to think harder about testing CGI context in command line --tests 15178 # API: 15179 # * input arguments: two ways, command line or CGI 15180 # * the program arguments 15181 # * QUERY_STRING env variable 15182 # * return 15183 # * QUERY_STRING length 15184 15185 # CGI context 15186 local $ENV{SERVER_SOFTWARE} = 'Votre serviteur' ; 15187 15188 # Real full test 15189 # = 'host1=test1.lamiral.info&user1=test1&password1=secret1&host2=test2.lamiral.info&user2=test2&password2=secret2&debugenv=on' 15190 my $mysync ; 15191 is( undef, get_options( $mysync ), 'get_options cgi context: no CGI module => undef' ) ; 15192 15193 require CGI ; 15194 CGI->import( qw( -no_debug ) ) ; 15195 15196 is( undef, get_options( $mysync ), 'get_options cgi context: no CGI param => undef' ) ; 15197 # Testing boolean 15198 $mysync->{cgi} = CGI->new( 'version=on&debugenv=on' ) ; 15199 local $ENV{'QUERY_STRING'} = 'version=on&debugenv=on' ; 15200 is( 22, get_options( $mysync ), 'get_options cgi context: QUERY_STRING => 22' ) ; 15201 is( 1, $mysync->{ version }, 'get_options cgi context: --version => 1' ) ; 15202 # debugenv is not allowed in cgi context 15203 is( undef, $mysync->{debugenv}, 'get_options cgi context: $mysync->{debugenv} => undef' ) ; 15204 15205 # QUERY_STRING in this test is only for return value of get_options 15206 # Have to think harder, GET/POST context, is this return value a good thing? 15207 local $ENV{'QUERY_STRING'} = 'host1=test1.lamiral.info&user1=test1' ; 15208 $mysync->{cgi} = CGI->new( 'host1=test1.lamiral.info&user1=test1' ) ; 15209 is( 36, get_options( $mysync, ), 'get_options cgi context: QUERY_STRING => 36' ) ; 15210 is( 'test1', $mysync->{user1}, 'get_options cgi context: $mysync->{user1} => test1' ) ; 15211 #local $ENV{'QUERY_STRING'} = undef ; 15212 15213 # Testing @ 15214 $mysync->{cgi} = CGI->new( 'blabla=fd1' ) ; 15215 get_options( $mysync ) ; 15216 is_deeply( [ 'fd1' ], [ @blabla ], 'get_options cgi context: @blabla => fd1' ) ; 15217 $mysync->{cgi} = CGI->new( 'blabla=fd1&blabla=fd2' ) ; 15218 get_options( $mysync ) ; 15219 is_deeply( [ 'fd1', 'fd2' ], [ @blabla ], 'get_options cgi context: @blabla => fd1, fd2' ) ; 15220 15221 # Testing s@ as ref 15222 $mysync->{cgi} = CGI->new( 'folder=fd1' ) ; 15223 get_options( $mysync ) ; 15224 is_deeply( [ 'fd1' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1' ) ; 15225 $mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ; 15226 get_options( $mysync ) ; 15227 is_deeply( [ 'fd1', 'fd2' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1, fd2' ) ; 15228 15229 # Testing % 15230 $mysync->{cgi} = CGI->new( 'f1f2h=s1=d1&f1f2h=s2=d2&f1f2h=s3=d3' ) ; 15231 get_options( $mysync ) ; 15232 15233 is_deeply( { 's1' => 'd1', 's2' => 'd2', 's3' => 'd3' }, 15234 $mysync->{f1f2h}, 'get_options cgi context: f1f2h => s1=d1 s2=d2 s3=d3' ) ; 15235 15236 # Testing boolean ! with --noxxx, doesnot work 15237 $mysync->{cgi} = CGI->new( 'nodry=on' ) ; 15238 get_options( $mysync ) ; 15239 is( undef, $mysync->{dry}, 'get_options cgi context: --nodry => $mysync->{dry} => undef' ) ; 15240 15241 $mysync->{cgi} = CGI->new( 'host1=example.com' ) ; 15242 get_options( $mysync ) ; 15243 is( 'example.com', $mysync->{host1}, 'get_options cgi context: --host1=example.com => $mysync->{host1} => example.com' ) ; 15244 15245 #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; 15246 $mysync->{cgi} = CGI->new( 'simulong=' ) ; 15247 get_options( $mysync ) ; 15248 is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong= => $mysync->{simulong} => undef' ) ; 15249 15250 $mysync->{cgi} = CGI->new( 'simulong' ) ; 15251 get_options( $mysync ) ; 15252 is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong => $mysync->{simulong} => undef' ) ; 15253 15254 $mysync->{cgi} = CGI->new( 'simulong=4' ) ; 15255 get_options( $mysync ) ; 15256 is( 4, $mysync->{simulong}, 'get_options cgi context: --simulong=4 => $mysync->{simulong} => 4' ) ; 15257 is( undef, $mysync->{ folder }, 'get_options cgi context: --simulong=4 => $mysync->{ folder } => undef' ) ; 15258 #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; 15259 15260 $mysync ={} ; 15261 $mysync->{cgi} = CGI->new( 'justfoldersizes=on' ) ; 15262 get_options( $mysync ) ; 15263 is( 1, $mysync->{ justfoldersizes }, 'get_options cgi context: --justfoldersizes=1 => justfoldersizes => 1' ) ; 15264 myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; 15265 15266 note( 'Leaving tests_get_options_cgi_context()' ) ; 15267 return ; 15268} 15269 15270 15271 15272sub get_options_cgi 15273{ 15274 # In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET). 15275 my $mysync = shift @ARG ; 15276 $mysync->{cgi} || return ; 15277 my @arguments = @ARG ; 15278 # final 0 is used to print usage when no option is given 15279 my $numopt = length $ENV{'QUERY_STRING'} || 1 ; 15280 $mysync->{f1f2h} = {} ; 15281 my $opt_ret = myGetOptions( 15282 $mysync, 15283 \@arguments, 15284 'abort' => \$mysync->{abort}, 15285 'host1=s' => \$mysync->{host1}, 15286 'host2=s' => \$mysync->{host2}, 15287 'user1=s' => \$mysync->{user1}, 15288 'user2=s' => \$mysync->{user2}, 15289 'password1=s' => \$mysync->{password1}, 15290 'password2=s' => \$mysync->{password2}, 15291 'dry!' => \$mysync->{dry}, 15292 'version' => \$mysync->{version}, 15293 'ssl1!' => \$mysync->{ssl1}, 15294 'ssl2!' => \$mysync->{ssl2}, 15295 'tls1!' => \$mysync->{tls1}, 15296 'tls2!' => \$mysync->{tls2}, 15297 'justlogin!' => \$mysync->{justlogin}, 15298 'justconnect!' => \$mysync->{justconnect}, 15299 'addheader!' => \$mysync->{addheader}, 15300 'automap!' => \$mysync->{automap}, 15301 'justautomap!' => \$mysync->{justautomap}, 15302 'gmail1' => \$mysync->{gmail1}, 15303 'gmail2' => \$mysync->{gmail2}, 15304 'office1' => \$mysync->{office1}, 15305 'office2' => \$mysync->{office2}, 15306 'exchange1' => \$mysync->{exchange1}, 15307 'exchange2' => \$mysync->{exchange2}, 15308 'domino1' => \$mysync->{domino1}, 15309 'domino2' => \$mysync->{domino2}, 15310 'f1f2=s@' => \$mysync->{f1f2}, 15311 'f1f2h=s%' => \$mysync->{f1f2h}, 15312 'folder=s@' => \$mysync->{ folder }, 15313 'blabla=s' => \@blabla, 15314 'testslive!' => \$mysync->{testslive}, 15315 'testslive6!' => \$mysync->{testslive6}, 15316 'releasecheck!' => \$mysync->{releasecheck}, 15317 'simulong=i' => \$mysync->{simulong}, 15318 'debugsleep=f' => \$mysync->{debugsleep}, 15319 'subfolder1=s' => \$mysync->{ subfolder1 }, 15320 'subfolder2=s' => \$mysync->{ subfolder2 }, 15321 'justfolders!' => \$mysync->{ justfolders }, 15322 'justfoldersizes!' => \$mysync->{ justfoldersizes }, 15323 'delete1!' => \$mysync->{ delete1 }, 15324 'delete2!' => \$mysync->{ delete2 }, 15325 'delete2duplicates!' => \$mysync->{ delete2duplicates }, 15326 'tail!' => \$mysync->{tail}, 15327 15328# blabla and f1f2h=s% could be removed but 15329# tests_get_options_cgi() should be split before 15330# with a sub tests_myGetOptions() 15331 ) ; 15332 15333 $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ; 15334 15335 if ( ! $opt_ret ) { 15336 return ; 15337 } 15338 return $numopt ; 15339} 15340 15341sub get_options_cmd 15342{ 15343 my $mysync = shift @ARG ; 15344 my @arguments = @ARG ; 15345 my $mycgi = $mysync->{cgi} ; 15346 # final 0 is used to print usage when no option is given on command line 15347 my $numopt = scalar @arguments || 0 ; 15348 my $argv = join "\x00", @arguments ; 15349 15350 if ( $argv =~ m/-delete\x002/x ) { 15351 output( $mysync, "May be you mean --delete2 instead of --delete 2\n" ) ; 15352 return ; 15353 } 15354 $mysync->{f1f2h} = {} ; 15355 my $opt_ret = myGetOptions( 15356 $mysync, 15357 \@arguments, 15358 'debug!' => \$mysync->{ debug }, 15359 'debuglist!' => \$debuglist, 15360 'debugcontent!' => \$debugcontent, 15361 'debugsleep=f' => \$mysync->{debugsleep}, 15362 'debugflags!' => \$debugflags, 15363 'debugimap!' => \$debugimap, 15364 'debugimap1!' => \$debugimap1, 15365 'debugimap2!' => \$debugimap2, 15366 'debugdev!' => \$debugdev, 15367 'debugmemory!' => \$mysync->{debugmemory}, 15368 'debugfolders!' => \$mysync->{debugfolders}, 15369 'debugssl=i' => \$mysync->{debugssl}, 15370 'debugcgi!' => \$debugcgi, 15371 'debugenv!' => \$mysync->{debugenv}, 15372 'debugsig!' => \$mysync->{debugsig}, 15373 'debuglabels!' => \$mysync->{debuglabels}, 15374 'simulong=i' => \$mysync->{simulong}, 15375 'abort' => \$mysync->{abort}, 15376 'host1=s' => \$mysync->{host1}, 15377 'host2=s' => \$mysync->{host2}, 15378 'port1=i' => \$mysync->{port1}, 15379 'port2=i' => \$mysync->{port2}, 15380 'inet4|ipv4' => \$mysync->{inet4}, 15381 'inet6|ipv6' => \$mysync->{inet6}, 15382 'user1=s' => \$mysync->{user1}, 15383 'user2=s' => \$mysync->{user2}, 15384 'gmail1' => \$mysync->{gmail1}, 15385 'gmail2' => \$mysync->{gmail2}, 15386 'office1' => \$mysync->{office1}, 15387 'office2' => \$mysync->{office2}, 15388 'exchange1' => \$mysync->{exchange1}, 15389 'exchange2' => \$mysync->{exchange2}, 15390 'domino1' => \$mysync->{domino1}, 15391 'domino2' => \$mysync->{domino2}, 15392 'domain1=s' => \$domain1, 15393 'domain2=s' => \$domain2, 15394 'password1=s' => \$mysync->{password1}, 15395 'password2=s' => \$mysync->{password2}, 15396 'passfile1=s' => \$mysync->{ passfile1 }, 15397 'passfile2=s' => \$mysync->{ passfile2 }, 15398 'authmd5!' => \$authmd5, 15399 'authmd51!' => \$authmd51, 15400 'authmd52!' => \$authmd52, 15401 'sep1=s' => \$mysync->{ sep1 }, 15402 'sep2=s' => \$mysync->{ sep2 }, 15403 'sanitize!' => \$mysync->{ sanitize }, 15404 'folder=s@' => \$mysync->{ folder }, 15405 'folderrec=s' => \@folderrec, 15406 'include=s' => \@include, 15407 'exclude=s' => \@exclude, 15408 'noexclude' => \$mysync->{noexclude}, 15409 'folderfirst=s' => \@folderfirst, 15410 'folderlast=s' => \@folderlast, 15411 'prefix1=s' => \$prefix1, 15412 'prefix2=s' => \$prefix2, 15413 'subfolder1=s' => \$mysync->{ subfolder1 }, 15414 'subfolder2=s' => \$mysync->{ subfolder2 }, 15415 'fixslash2!' => \$mysync->{ fixslash2 }, 15416 'fixInboxINBOX!' => \$fixInboxINBOX, 15417 'regextrans2=s@' => \$mysync->{ regextrans2 }, 15418 'mixfolders!' => \$mixfolders, 15419 'skipemptyfolders!' => \$skipemptyfolders, 15420 'regexmess=s' => \@regexmess, 15421 'noregexmess' => \$mysync->{noregexmess}, 15422 'skipmess=s' => \@skipmess, 15423 'pipemess=s' => \@pipemess, 15424 'pipemesscheck!' => \$pipemesscheck, 15425 'disarmreadreceipts!' => \$disarmreadreceipts, 15426 'regexflag=s' => \@regexflag, 15427 'noregexflag' => \$mysync->{noregexflag}, 15428 'filterflags!' => \$filterflags, 15429 'flagscase!' => \$flagscase, 15430 'syncflagsaftercopy!' => \$syncflagsaftercopy, 15431 'resyncflags!' => \$mysync->{ resyncflags }, 15432 'synclabels!' => \$mysync->{ synclabels }, 15433 'resynclabels!' => \$mysync->{ resynclabels }, 15434 'delete|delete1!' => \$mysync->{ delete1 }, 15435 'delete2!' => \$mysync->{ delete2 }, 15436 'delete2duplicates!' => \$mysync->{ delete2duplicates }, 15437 'delete2folders!' => \$delete2folders, 15438 'delete2foldersonly=s' => \$delete2foldersonly, 15439 'delete2foldersbutnot=s' => \$delete2foldersbutnot, 15440 'syncinternaldates!' => \$syncinternaldates, 15441 'idatefromheader!' => \$idatefromheader, 15442 'syncacls!' => \$syncacls, 15443 'maxsize=i' => \$mysync->{ maxsize }, 15444 'appendlimit=i' => \$mysync->{ appendlimit }, 15445 'truncmess=i' => \$mysync->{ truncmess }, 15446 'minsize=i' => \$minsize, 15447 'maxage=f' => \$maxage, 15448 'minage=f' => \$minage, 15449 'search=s' => \$search, 15450 'search1=s' => \$search1, 15451 'search2=s' => \$search2, 15452 'foldersizes!' => \$foldersizes, 15453 'foldersizesatend!' => \$foldersizesatend, 15454 'dry!' => \$mysync->{dry}, 15455 'expunge1|expunge!' => \$mysync->{ expunge1 }, 15456 'expunge2!' => \$mysync->{ expunge2 }, 15457 'uidexpunge2!' => \$mysync->{ uidexpunge2 }, 15458 'subscribed' => \$subscribed, 15459 'subscribe!' => \$subscribe, 15460 'subscribeall|subscribe_all!' => \$subscribeall, 15461 'justbanner!' => \$justbanner, 15462 'justfolders!'=> \$mysync->{ justfolders }, 15463 'justfoldersizes!' => \$mysync->{ justfoldersizes }, 15464 'fast!' => \$fast, 15465 'version' => \$mysync->{version}, 15466 'help' => \$help, 15467 'timeout=i' => \$timeout, 15468 'timeout1=i' => \$mysync->{h1}->{timeout}, 15469 'timeout2=i' => \$mysync->{h2}->{timeout}, 15470 'skipheader=s' => \$skipheader, 15471 'useheader=s' => \@useheader, 15472 'wholeheaderifneeded!' => \$wholeheaderifneeded, 15473 'messageidnodomain!' => \$messageidnodomain, 15474 'skipsize!' => \$skipsize, 15475 'allowsizemismatch!' => \$allowsizemismatch, 15476 'fastio1!' => \$fastio1, 15477 'fastio2!' => \$fastio2, 15478 'sslcheck!' => \$mysync->{sslcheck}, 15479 'ssl1!' => \$mysync->{ssl1}, 15480 'ssl2!' => \$mysync->{ssl2}, 15481 'ssl1_ssl_version=s' => \$mysync->{h1}->{sslargs}->{SSL_version}, 15482 'ssl2_ssl_version=s' => \$mysync->{h2}->{sslargs}->{SSL_version}, 15483 'sslargs1=s%' => \$mysync->{h1}->{sslargs}, 15484 'sslargs2=s%' => \$mysync->{h2}->{sslargs}, 15485 'tls1!' => \$mysync->{tls1}, 15486 'tls2!' => \$mysync->{tls2}, 15487 'uid1!' => \$uid1, 15488 'uid2!' => \$uid2, 15489 'authmech1=s' => \$authmech1, 15490 'authmech2=s' => \$authmech2, 15491 'authuser1=s' => \$authuser1, 15492 'authuser2=s' => \$authuser2, 15493 'proxyauth1' => \$proxyauth1, 15494 'proxyauth2' => \$proxyauth2, 15495 'split1=i' => \$split1, 15496 'split2=i' => \$split2, 15497 'buffersize=i' => \$buffersize, 15498 'reconnectretry1=i' => \$reconnectretry1, 15499 'reconnectretry2=i' => \$reconnectretry2, 15500 'tests!' => \$mysync->{ tests }, 15501 'testsdebug|tests_debug!' => \$mysync->{ testsdebug }, 15502 'testsunit=s@' => \$mysync->{testsunit}, 15503 'testslive!' => \$mysync->{testslive}, 15504 'testslive6!' => \$mysync->{testslive6}, 15505 'justlogin!' => \$mysync->{justlogin}, 15506 'justconnect!' => \$mysync->{justconnect}, 15507 'tmpdir=s' => \$mysync->{ tmpdir }, 15508 'pidfile=s' => \$mysync->{pidfile}, 15509 'pidfilelocking!' => \$mysync->{pidfilelocking}, 15510 'sigexit=s@' => \$mysync->{ sigexit }, 15511 'sigreconnect=s@' => \$mysync->{ sigreconnect }, 15512 'sigignore=s@' => \$mysync->{ sigignore }, 15513 'releasecheck!' => \$mysync->{releasecheck}, 15514 'modulesversion|modules_version!' => \$modulesversion, 15515 'usecache!' => \$usecache, 15516 'cacheaftercopy!' => \$cacheaftercopy, 15517 'debugcache!' => \$debugcache, 15518 'useuid!' => \$useuid, 15519 'addheader!' => \$mysync->{addheader}, 15520 'exitwhenover=i' => \$mysync->{ exitwhenover }, 15521 'checkselectable!' => \$mysync->{ checkselectable }, 15522 'checkfoldersexist!' => \$mysync->{ checkfoldersexist }, 15523 'checkmessageexists!' => \$checkmessageexists, 15524 'expungeaftereach!' => \$mysync->{ expungeaftereach }, 15525 'abletosearch!' => \$mysync->{abletosearch}, 15526 'abletosearch1!' => \$mysync->{abletosearch1}, 15527 'abletosearch2!' => \$mysync->{abletosearch2}, 15528 'showpasswords!' => \$mysync->{showpasswords}, 15529 'maxlinelength=i' => \$maxlinelength, 15530 'maxlinelengthcmd=s' => \$maxlinelengthcmd, 15531 'minmaxlinelength=i' => \$minmaxlinelength, 15532 'debugmaxlinelength!' => \$debugmaxlinelength, 15533 'fixcolonbug!' => \$fixcolonbug, 15534 'create_folder_old!' => \$create_folder_old, 15535 'maxmessagespersecond=f' => \$mysync->{maxmessagespersecond}, 15536 'maxbytespersecond=i' => \$mysync->{maxbytespersecond}, 15537 'maxbytesafter=i' => \$mysync->{maxbytesafter}, 15538 'maxsleep=f' => \$mysync->{maxsleep}, 15539 'skipcrossduplicates!' => \$skipcrossduplicates, 15540 'debugcrossduplicates!' => \$debugcrossduplicates, 15541 'log!' => \$mysync->{log}, 15542 'tail!' => \$mysync->{tail}, 15543 'logfile=s' => \$mysync->{logfile}, 15544 'logdir=s' => \$mysync->{logdir}, 15545 'errorsmax=i' => \$mysync->{errorsmax}, 15546 'errorsdump!' => \$mysync->{errorsdump}, 15547 'fetch_hash_set=s' => \$fetch_hash_set, 15548 'automap!' => \$mysync->{automap}, 15549 'justautomap!' => \$mysync->{justautomap}, 15550 'id!' => \$mysync->{id}, 15551 'f1f2=s@' => \$mysync->{f1f2}, 15552 'nof1f2' => \$mysync->{nof1f2}, 15553 'f1f2h=s%' => \$mysync->{f1f2h}, 15554 'justfolderlists!' => \$mysync->{justfolderlists}, 15555 'delete1emptyfolders' => \$mysync->{delete1emptyfolders}, 15556 ) ; 15557 #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; 15558 $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ; 15559 my $numopt_after = scalar @arguments ; 15560 #myprint( "get options: [$opt_ret][$numopt][$numopt_after]\n" ) ; 15561 if ( $numopt_after ) { 15562 myprint( 15563 "Extra arguments found: @arguments\n", 15564 "It usually means a quoting issue in the command line ", 15565 "or some misspelling options.\n", 15566 ) ; 15567 return ; 15568 } 15569 if ( ! $opt_ret ) { 15570 return ; 15571 } 15572 return $numopt ; 15573} 15574 15575 15576 15577sub tests_get_options 15578{ 15579 note( 'Entering tests_get_options()' ) ; 15580 15581 # CAVEAT: still setting global variables, be careful 15582 # with tests, the context increases! $debug stays on for example. 15583 # API: 15584 # * input arguments: two ways, command line or CGI 15585 # * the program arguments 15586 # * QUERY_STRING env variable 15587 # * return 15588 # * undef if bad things happened like 15589 # * options not known 15590 # * --delete 2 input 15591 # * number of arguments or QUERY_STRING length 15592 my $mysync = { } ; 15593 is( undef, get_options( $mysync, qw( --noexist ) ), 'get_options: --noexist => undef' ) ; 15594 is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ; 15595 $mysync = { } ; 15596 is( undef, get_options( $mysync, qw( --lalala --noexist --version ) ), 'get_options: --lalala --noexist --version => undef' ) ; 15597 is( 1, $mysync->{ version }, 'get_options: --version => 1' ) ; 15598 is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ; 15599 $mysync = { } ; 15600 is( 1, get_options( $mysync, qw( --delete2 ) ), 'get_options: --delete2 => 1' ) ; 15601 is( 1, $mysync->{ delete2 }, 'get_options: --delete2 => var delete2 = 1' ) ; 15602 $mysync = { } ; 15603 is( undef, get_options( $mysync, qw( --delete 2 ) ), 'get_options: --delete 2 => var undef' ) ; 15604 is( undef, $mysync->{ delete1 }, 'get_options: --delete 2 => var still undef ; good!' ) ; 15605 $mysync = { } ; 15606 is( undef, get_options( $mysync, "--delete 2" ), 'get_options: --delete 2 => undef' ) ; 15607 15608 is( 1, get_options( $mysync, "--version" ), 'get_options: --version => 1' ) ; 15609 is( 1, get_options( $mysync, "--help" ), 'get_options: --help => 1' ) ; 15610 15611 is( undef, get_options( $mysync, qw( --noexist --version ) ), 'get_options: --debug --noexist --version => undef' ) ; 15612 is( 1, get_options( $mysync, qw( --version ) ), 'get_options: --version => 1' ) ; 15613 is( undef, get_options( $mysync, qw( extra ) ), 'get_options: extra => undef' ) ; 15614 is( undef, get_options( $mysync, qw( extra1 --version extra2 ) ), 'get_options: extra1 --version extra2 => undef' ) ; 15615 15616 $mysync = { } ; 15617 is( 2, get_options( $mysync, qw( --host1 HOST_01) ), 'get_options: --host1 HOST_01 => 1' ) ; 15618 is( 'HOST_01', $mysync->{ host1 }, 'get_options: --host1 HOST_01 => HOST_01' ) ; 15619 #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; 15620 15621 note( 'Leaving tests_get_options()' ) ; 15622 return ; 15623} 15624 15625 15626 15627sub get_options 15628{ 15629 my $mysync = shift @ARG ; 15630 my @arguments = @ARG ; 15631 #myprint( "1 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ; 15632 my $ret ; 15633 if ( under_cgi_context( ) ) { 15634 # CGI context 15635 $ret = get_options_cgi( $mysync, @arguments ) ; 15636 }else{ 15637 # Command line context ; 15638 $ret = get_options_cmd( $mysync, @arguments ) ; 15639 } ; 15640 #myprint( "2 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ; 15641 foreach my $key ( sort keys %{ $mysync } ) { 15642 if ( ! defined $mysync->{$key} ) { 15643 delete $mysync->{$key} ; 15644 next ; 15645 } 15646 if ( 'ARRAY' eq ref( $mysync->{$key} ) 15647 and 0 == scalar( @{ $mysync->{$key} } ) ) { 15648 delete $mysync->{$key} ; 15649 } 15650 } 15651 return $ret ; 15652} 15653 15654sub testunitsession 15655{ 15656 my $mysync = shift ; 15657 15658 if ( ! $mysync ) { return ; } 15659 if ( ! $mysync->{ testsunit } ) { return ; } 15660 15661 my @functions = @{ $mysync->{ testsunit } } ; 15662 15663 if ( ! @functions ) { return ; } 15664 15665 SKIP: { 15666 if ( ! @functions ) { skip 'No test in normal run' ; } 15667 testsunit( @functions ) ; 15668 done_testing( ) ; 15669 } 15670 return ; 15671} 15672 15673sub tests_count_0s 15674{ 15675 note( 'Entering tests_count_zeros()' ) ; 15676 is( 0, count_0s( ), 'count_0s: no parameters => 0' ) ; 15677 is( 1, count_0s( 0 ), 'count_0s: 0 => 1' ) ; 15678 is( 0, count_0s( 1 ), 'count_0s: 1 => 0' ) ; 15679 is( 1, count_0s( 1, 0, 1 ), 'count_0s: 1, 0, 1 => 1' ) ; 15680 is( 2, count_0s( 1, 0, 1, 0 ), 'count_0s: 1, 0, 1, 0 => 2' ) ; 15681 note( 'Leaving tests_count_zeros()' ) ; 15682 return ; 15683} 15684sub count_0s 15685{ 15686 my @array = @ARG ; 15687 15688 if ( ! @array ) { return 0 ; } 15689 my $nb_zeros = 0 ; 15690 map { $_ == 0 and $nb_zeros += 1 } @array ; 15691 return $nb_zeros ; 15692} 15693 15694sub tests_report_failures 15695{ 15696 note( 'Entering tests_report_failures()' ) ; 15697 15698 is( undef, report_failures( ), 'report_failures: no parameters => undef' ) ; 15699 is( "nb 1 - first\n", report_failures( ({'ok' => 0, name => 'first'}) ), 'report_failures: "first" failed => nb 1 - first' ) ; 15700 is( q{}, report_failures( ( {'ok' => 1, name => 'first'} ) ), 'report_failures: "first" success =>' ) ; 15701 is( "nb 2 - second\n", report_failures( ( {'ok' => 1, name => 'second'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: "second" failed => nb 2 - second' ) ; 15702 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' ) ; 15703 note( 'Leaving tests_report_failures()' ) ; 15704 return ; 15705} 15706 15707sub report_failures 15708{ 15709 my @details = @ARG ; 15710 15711 if ( ! @details ) { return ; } 15712 15713 my $counter = 1 ; 15714 my $report = q{} ; 15715 foreach my $details ( @details ) { 15716 if ( ! $details->{ 'ok' } ) { 15717 my $name = $details->{ 'name' } || 'NONAME' ; 15718 $report .= "nb $counter - $name\n" ; 15719 } 15720 $counter += 1 ; 15721 } 15722 return $report ; 15723 15724} 15725 15726sub tests_true 15727{ 15728 note( 'Entering tests_true()' ) ; 15729 15730 is( 1, 1, 'true: 1 is 1' ) ; 15731 note( 'Leaving tests_true()' ) ; 15732 return ; 15733} 15734 15735sub tests_testsunit 15736{ 15737 note( 'Entering tests_testunit()' ) ; 15738 15739 is( undef, testsunit( ), 'testsunit: no parameters => undef' ) ; 15740 is( undef, testsunit( undef ), 'testsunit: an undef parameter => undef' ) ; 15741 is( undef, testsunit( q{} ), 'testsunit: an empty parameter => undef' ) ; 15742 is( undef, testsunit( 'idonotexist' ), 'testsunit: a do not exist function as parameter => undef' ) ; 15743 is( undef, testsunit( 'tests_true' ), 'testsunit: tests_true => undef' ) ; 15744 note( 'Leaving tests_testunit()' ) ; 15745 return ; 15746} 15747 15748sub testsunit 15749{ 15750 my @functions = @ARG ; 15751 15752 if ( ! @functions ) { # 15753 myprint( "testsunit warning: no argument given\n" ) ; 15754 return ; 15755 } 15756 15757 foreach my $function ( @functions ) { 15758 if ( ! $function ) { 15759 myprint( "testsunit warning: argument is empty\n" ) ; 15760 next ; 15761 } 15762 if ( ! exists &$function ) { 15763 myprint( "testsunit warning: function $function does not exist\n" ) ; 15764 next ; 15765 } 15766 if ( ! defined &$function ) { 15767 myprint( "testsunit warning: function $function is not defined\n" ) ; 15768 next ; 15769 } 15770 my $function_ref = \&{ $function } ; 15771 &$function_ref() ; 15772 } 15773 return ; 15774} 15775 15776sub testsdebug 15777{ 15778 # Now a little obsolete since there is 15779 # imapsync ... --testsunit "anyfunction" 15780 my $mysync = shift ; 15781 if ( ! $mysync->{ testsdebug } ) { return ; } 15782 SKIP: { 15783 if ( ! $mysync->{ testsdebug } ) { 15784 skip 'No test in normal run' ; 15785 } 15786 15787 note( 'Entering testsdebug()' ) ; 15788 ok( ( ( not -d 'W/tmp/tests' ) or rmtree( 'W/tmp/tests/' ) ), 'testsdebug: rmtree W/tmp/tests' ) ; 15789 tests_check_binary_embed_all_dyn_libs( ) ; 15790 note( 'Leaving testsdebug()' ) ; 15791 done_testing( ) ; 15792 } 15793 return ; 15794} 15795 15796 15797sub tests 15798{ 15799 my $mysync = shift ; 15800 if ( ! $mysync->{ tests } ) { return ; } 15801 15802 SKIP: { 15803 skip 'No test in normal run' if ( ! $mysync->{ tests } ) ; 15804 note( 'Entering tests()' ) ; 15805 tests_folder_routines( ) ; 15806 tests_compare_lists( ) ; 15807 tests_regexmess( ) ; 15808 tests_skipmess( ) ; 15809 tests_flags_regex(); 15810 tests_ucsecond( ) ; 15811 tests_permanentflags(); 15812 tests_flags_filter( ) ; 15813 tests_separator_invert( ) ; 15814 tests_imap2_folder_name( ) ; 15815 tests_command_line_nopassword( ) ; 15816 tests_good_date( ) ; 15817 tests_max( ) ; 15818 tests_remove_not_num(); 15819 tests_memory_consumption( ) ; 15820 tests_is_a_release_number(); 15821 tests_imapsync_basename(); 15822 tests_list_keys_in_2_not_in_1(); 15823 tests_convert_sep_to_slash( ) ; 15824 tests_match_a_cache_file( ) ; 15825 tests_cache_map( ) ; 15826 tests_get_cache( ) ; 15827 tests_clean_cache( ) ; 15828 tests_clean_cache_2( ) ; 15829 tests_touch( ) ; 15830 tests_flagscase( ) ; 15831 tests_mkpath( ) ; 15832 tests_extract_header( ) ; 15833 tests_decompose_header( ) ; 15834 tests_epoch( ) ; 15835 tests_add_header( ) ; 15836 tests_cache_dir_fix( ) ; 15837 tests_cache_dir_fix_win( ) ; 15838 tests_filter_forbidden_characters( ) ; 15839 tests_cache_folder( ) ; 15840 tests_time_remaining( ) ; 15841 tests_decompose_regex( ) ; 15842 tests_backtick( ) ; 15843 tests_bytes_display_string( ) ; 15844 tests_header_line_normalize( ) ; 15845 tests_fix_Inbox_INBOX_mapping( ) ; 15846 tests_max_line_length( ) ; 15847 tests_subject( ) ; 15848 tests_msgs_from_maxmin( ) ; 15849 tests_tmpdir_has_colon_bug( ) ; 15850 tests_sleep_max_messages( ) ; 15851 tests_sleep_max_bytes( ) ; 15852 tests_logfile( ) ; 15853 tests_setlogfile( ) ; 15854 tests_jux_utf8( ) ; 15855 tests_pipemess( ) ; 15856 tests_jux_utf8_list( ) ; 15857 tests_guess_prefix( ) ; 15858 tests_guess_separator( ) ; 15859 tests_format_for_imap_arg( ) ; 15860 tests_imapsync_id( ) ; 15861 tests_date_from_rcs( ) ; 15862 tests_quota_extract_storage_limit_in_bytes( ) ; 15863 tests_quota_extract_storage_current_in_bytes( ) ; 15864 tests_guess_special( ) ; 15865 tests_do_valid_directory( ) ; 15866 tests_delete1emptyfolders( ) ; 15867 tests_message_for_host2( ) ; 15868 tests_length_ref( ) ; 15869 tests_firstline( ) ; 15870 tests_diff_or_NA( ) ; 15871 tests_match_number( ) ; 15872 tests_all_defined( ) ; 15873 tests_special_from_folders_hash( ) ; 15874 tests_notmatch( ) ; 15875 tests_match( ) ; 15876 tests_get_options( ) ; 15877 tests_get_options_cgi_context( ) ; 15878 tests_rand32( ) ; 15879 tests_hashsynclocal( ) ; 15880 tests_hashsync( ) ; 15881 tests_output( ) ; 15882 tests_output_reset_with( ) ; 15883 tests_output_start( ) ; 15884 tests_check_last_release( ) ; 15885 tests_loadavg( ) ; 15886 tests_cpu_number( ) ; 15887 tests_load_and_delay( ) ; 15888 #tests_imapsping( ) ; 15889 #tests_tcpping( ) ; 15890 tests_sslcheck( ) ; 15891 tests_not_long_imapsync_version_public( ) ; 15892 tests_reconnect_if_needed( ) ; 15893 tests_reconnect_12_if_needed( ) ; 15894 tests_sleep_if_needed( ) ; 15895 tests_string_to_file( ) ; 15896 tests_file_to_string( ) ; 15897 tests_under_cgi_context( ) ; 15898 tests_umask( ) ; 15899 tests_umask_str( ) ; 15900 tests_set_umask( ) ; 15901 tests_createhashfileifneeded( ) ; 15902 tests_move_slash( ) ; 15903 tests_testsunit( ) ; 15904 tests_count_0s( ) ; 15905 tests_report_failures( ) ; 15906 tests_min( ) ; 15907 #tests_resolv( ) ; 15908 #tests_resolvrev( ) ; 15909 tests_connect_socket( ) ; 15910 tests_probe_imapssl( ) ; 15911 tests_mailimapclient_connect( ) ; 15912 tests_usage( ) ; 15913 tests_version_from_rcs( ) ; 15914 tests_backslash_caret( ) ; 15915 #tests_mailimapclient_connect_bug( ) ; # it fails with Mail-IMAPClient <= 3.39 15916 tests_write_pidfile( ) ; 15917 tests_remove_pidfile_not_running( ) ; 15918 tests_match_a_pid_number( ) ; 15919 tests_prefix_seperator_invertion( ) ; 15920 tests_is_an_integer( ) ; 15921 tests_integer_or_1( ) ; 15922 tests_is_number( ) ; 15923 tests_sig_install( ) ; 15924 tests_template( ) ; 15925 tests_split_around_equal( ) ; 15926 tests_toggle_sleep( ) ; 15927 tests_labels( ) ; 15928 tests_synclabels( ) ; 15929 tests_uidexpunge_or_expunge( ) ; 15930 tests_appendlimit_from_capability( ) ; 15931 tests_maxsize_setting( ) ; 15932 tests_mock_capability( ) ; 15933 tests_appendlimit( ) ; 15934 tests_capability_of( ) ; 15935 tests_search_in_array( ) ; 15936 tests_operators_and_exclam_precedence( ) ; 15937 tests_teelaunch( ) ; 15938 tests_logfileprepa( ) ; 15939 tests_useheader_suggestion( ) ; 15940 tests_nb_messages_in_2_not_in_1( ) ; 15941 tests_labels_add_subfolder2( ) ; 15942 tests_labels_remove_subfolder1( ) ; 15943 tests_resynclabels( ) ; 15944 tests_labels_remove_special( ) ; 15945 tests_uniq( ) ; 15946 tests_remove_from_requested_folders( ) ; 15947 tests_errors_log( ) ; 15948 tests_add_subfolder1_to_folderrec( ) ; 15949 tests_sanitize_subfolder( ) ; 15950 tests_remove_edging_blanks( ) ; 15951 tests_sanitize( ) ; 15952 tests_remove_last_char_if_is( ) ; 15953 tests_check_binary_embed_all_dyn_libs( ) ; 15954 tests_nthline( ) ; 15955 tests_secondline( ) ; 15956 tests_tail( ) ; 15957 tests_truncmess( ) ; 15958 #tests_always_fail( ) ; 15959 done_testing( 1454 ) ; 15960 note( 'Leaving tests()' ) ; 15961 } 15962 return ; 15963} 15964 15965sub tests_template 15966{ 15967 note( 'Entering tests_template()' ) ; 15968 15969 is( undef, undef, 'template: undef is undef' ) ; 15970 is_deeply( {}, {}, 'template: a hash is a hash' ) ; 15971 is_deeply( [], [], 'template: an array is an array' ) ; 15972 note( 'Leaving tests_template()' ) ; 15973 return ; 15974} 15975 15976 15977 15978 15979