Matthias Andreas Benkard | b382b10 | 2021-01-02 15:32:21 +0100 | [diff] [blame] | 1 | #!/usr/bin/env perl |
| 2 | |
| 3 | # $Id: imapsync,v 1.977 2019/12/23 20:18:02 gilles Exp gilles $ |
| 4 | # structure |
| 5 | # pod documentation |
| 6 | # use pragmas |
| 7 | # main program |
| 8 | # global variables initialization |
| 9 | # get_options( ) ; |
| 10 | # default values |
| 11 | # folder loop |
| 12 | # subroutines |
| 13 | # sub usage |
| 14 | |
| 15 | |
| 16 | # pod documentation |
| 17 | |
| 18 | =pod |
| 19 | |
| 20 | =head1 NAME |
| 21 | |
| 22 | imapsync - Email IMAP tool for syncing, copying, migrating |
| 23 | and archiving email mailboxes between two imap servers, one way, |
| 24 | and without duplicates. |
| 25 | |
| 26 | =head1 VERSION |
| 27 | |
| 28 | This documentation refers to Imapsync $Revision: 1.977 $ |
| 29 | |
| 30 | =head1 USAGE |
| 31 | |
| 32 | To synchronize the source imap account |
| 33 | "test1" on server "test1.lamiral.info" with password "secret1" |
| 34 | to the destination imap account |
| 35 | "test2" on server "test2.lamiral.info" with password "secret2" |
| 36 | do: |
| 37 | |
| 38 | imapsync \ |
| 39 | --host1 test1.lamiral.info --user1 test1 --password1 secret1 \ |
| 40 | --host2 test2.lamiral.info --user2 test2 --password2 secret2 |
| 41 | |
| 42 | =head1 DESCRIPTION |
| 43 | |
| 44 | We sometimes need to transfer mailboxes from one imap server to |
| 45 | one another. |
| 46 | |
| 47 | Imapsync command is a tool allowing incremental and |
| 48 | recursive imap transfers from one mailbox to another. |
| 49 | If you don't understand the previous sentence, it's normal, |
| 50 | it's pedantic computer oriented jargon. |
| 51 | |
| 52 | All folders are transferred, recursively, meaning |
| 53 | the whole folder hierarchy is taken, all messages in them, |
| 54 | and all messages flags (\Seen \Answered \Flagged etc.) |
| 55 | are synced too. |
| 56 | |
| 57 | Imapsync reduces the amount of data transferred by not transferring |
| 58 | a given message if it already resides on the destination side. |
| 59 | Messages that are on the destination side but not on the |
| 60 | source side stay as they are (see the --delete2 |
| 61 | option to have a strict sync). |
| 62 | |
| 63 | How imapsync knows a message is already on both sides? |
| 64 | Same specific headers and the transfer is done only once. |
| 65 | By default, the identification headers are |
| 66 | "Message-Id:" and "Received:" lines |
| 67 | but this choice can be changed with the --useheader option. |
| 68 | |
| 69 | All flags are preserved, unread messages will stay unread, |
| 70 | read ones will stay read, deleted will stay deleted. |
| 71 | |
| 72 | You can abort the transfer at any time and restart it later, |
| 73 | imapsync works well with bad connections and interruptions, |
| 74 | by design. On a terminal hit Ctr-c twice within two seconds |
| 75 | in order to abort the program. Hit Ctr-c just once makes |
| 76 | imapsync reconnect to both imap servers. |
| 77 | |
| 78 | A classical scenario is synchronizing a mailbox B from another mailbox A |
| 79 | where you just want to keep a strict copy of A in B. Strict meaning |
| 80 | all messages in A will be in B but no more. |
| 81 | |
| 82 | For this, option --delete2 has to be used, it deletes messages in host2 |
| 83 | folder B that are not in host1 folder A. If you also need to destroy |
| 84 | host2 folders that are not in host1 then use --delete2folders. See also |
| 85 | --delete2foldersonly and --delete2foldersbutnot to set up exceptions |
| 86 | on folders to destroy. INBOX will never be destroy, it's a mandatory |
| 87 | folder in IMAP. |
| 88 | |
| 89 | A different scenario is to delete the messages from the source mailbox |
| 90 | after a successful transfer, it can be a good feature when migrating |
| 91 | mailboxes since messages will be only on one side. The source account |
| 92 | will only have messages that are not on the destination yet, ie, |
| 93 | messages that arrived after a sync or that failed to be copied. |
| 94 | |
| 95 | In that case, use the --delete1 option. Option --delete1 implies also |
| 96 | option --expunge1 so all messages marked deleted on host1 will be really |
| 97 | deleted. In IMAP protocol deleting a message does not really delete it, |
| 98 | it marks it with the flag \Deleted, allowing an undelete. Expunging |
| 99 | a folder removes, definitively, all the messages marked as \Deleted |
| 100 | in this folder. |
| 101 | |
| 102 | You can also decide to remove empty folders once all of their messages |
| 103 | have been transferred. Add --delete1emptyfolders to obtain this |
| 104 | behavior. |
| 105 | |
| 106 | |
| 107 | Imapsync is not adequate for maintaining two active imap accounts |
| 108 | in synchronization when the user plays independently on both sides. |
| 109 | Use offlineimap (written by John Goerzen) or mbsync (written by |
| 110 | Michael R. Elkins) for a 2 ways synchronization. |
| 111 | |
| 112 | |
| 113 | =head1 OPTIONS |
| 114 | |
| 115 | usage: imapsync [options] |
| 116 | |
| 117 | The standard options are the six values forming the credentials. |
| 118 | Three values on each side are needed in order to log in into the IMAP |
| 119 | servers. These six values are a host, a username, and a password, two times. |
| 120 | |
| 121 | Conventions used in the following descriptions of the options: |
| 122 | |
| 123 | str means string |
| 124 | int means integer |
| 125 | reg means regular expression |
| 126 | cmd means command |
| 127 | |
| 128 | --dry : Makes imapsync doing nothing for real, just print what |
| 129 | would be done without --dry. |
| 130 | |
| 131 | =head2 OPTIONS/credentials |
| 132 | |
| 133 | |
| 134 | --host1 str : Source or "from" imap server. |
| 135 | --port1 int : Port to connect on host1. |
| 136 | Optional since default ports are the |
| 137 | well known ports imap/143 or imaps/993. |
| 138 | --user1 str : User to login on host1. |
| 139 | --password1 str : Password for the user1. |
| 140 | |
| 141 | --host2 str : "destination" imap server. |
| 142 | --port2 int : Port to connect on host2. Optional |
| 143 | --user2 str : User to login on host2. |
| 144 | --password2 str : Password for the user2. |
| 145 | |
| 146 | --showpasswords : Shows passwords on output instead of "MASKED". |
| 147 | Useful to restart a complete run by just reading |
| 148 | the command line used in the log, |
| 149 | or to debug passwords. |
| 150 | It's not a secure practice at all. |
| 151 | |
| 152 | --passfile1 str : Password file for the user1. It must contain the |
| 153 | password on the first line. This option avoids showing |
| 154 | the password on the command line like --password1 does. |
| 155 | --passfile2 str : Password file for the user2. |
| 156 | |
| 157 | You can also pass the passwords in the environment variables |
| 158 | IMAPSYNC_PASSWORD1 and IMAPSYNC_PASSWORD2 |
| 159 | |
| 160 | =head2 OPTIONS/encryption |
| 161 | |
| 162 | --nossl1 : Do not use a SSL connection on host1. |
| 163 | --ssl1 : Use a SSL connection on host1. On by default if possible. |
| 164 | |
| 165 | --nossl2 : Do not use a SSL connection on host2. |
| 166 | --ssl2 : Use a SSL connection on host2. On by default if possible. |
| 167 | |
| 168 | --notls1 : Do not use a TLS connection on host1. |
| 169 | --tls1 : Use a TLS connection on host1. On by default if possible. |
| 170 | |
| 171 | --notls2 : Do not use a TLS connection on host2. |
| 172 | --tls2 : Use a TLS connection on host2. On by default if possible. |
| 173 | |
| 174 | --debugssl int : SSL debug mode from 0 to 4. |
| 175 | |
| 176 | --sslargs1 str : Pass any ssl parameter for host1 ssl or tls connection. Example: |
| 177 | --sslargs1 SSL_verify_mode=1 --sslargs1 SSL_version=SSLv3 |
| 178 | See all possibilities in the new() method of IO::Socket::SSL |
| 179 | http://search.cpan.org/perldoc?IO::Socket::SSL#Description_Of_Methods |
| 180 | --sslargs2 str : Pass any ssl parameter for host2 ssl or tls connection. |
| 181 | See --sslargs1 |
| 182 | |
| 183 | --timeout1 int : Connection timeout in seconds for host1. |
| 184 | Default is 120 and 0 means no timeout at all. |
| 185 | --timeout2 int : Connection timeout in seconds for host2. |
| 186 | Default is 120 and 0 means no timeout at all. |
| 187 | |
| 188 | |
| 189 | =head2 OPTIONS/authentication |
| 190 | |
| 191 | --authmech1 str : Auth mechanism to use with host1: |
| 192 | PLAIN, LOGIN, CRAM-MD5 etc. Use UPPERCASE. |
| 193 | --authmech2 str : Auth mechanism to use with host2. See --authmech1 |
| 194 | |
| 195 | --authuser1 str : User to auth with on host1 (admin user). |
| 196 | Avoid using --authmech1 SOMETHING with --authuser1. |
| 197 | --authuser2 str : User to auth with on host2 (admin user). |
| 198 | --proxyauth1 : Use proxyauth on host1. Requires --authuser1. |
| 199 | Required by Sun/iPlanet/Netscape IMAP servers to |
| 200 | be able to use an administrative user. |
| 201 | --proxyauth2 : Use proxyauth on host2. Requires --authuser2. |
| 202 | |
| 203 | --authmd51 : Use MD5 authentication for host1. |
| 204 | --authmd52 : Use MD5 authentication for host2. |
| 205 | --domain1 str : Domain on host1 (NTLM authentication). |
| 206 | --domain2 str : Domain on host2 (NTLM authentication). |
| 207 | |
| 208 | |
| 209 | =head2 OPTIONS/folders |
| 210 | |
| 211 | |
| 212 | --folder str : Sync this folder. |
| 213 | --folder str : and this one, etc. |
| 214 | --folderrec str : Sync this folder recursively. |
| 215 | --folderrec str : and this one, etc. |
| 216 | |
| 217 | --folderfirst str : Sync this folder first. Ex. --folderfirst "INBOX" |
| 218 | --folderfirst str : then this one, etc. |
| 219 | --folderlast str : Sync this folder last. --folderlast "[Gmail]/All Mail" |
| 220 | --folderlast str : then this one, etc. |
| 221 | |
| 222 | --nomixfolders : Do not merge folders when host1 is case-sensitive |
| 223 | while host2 is not (like Exchange). Only the first |
| 224 | similar folder is synced (example: with folders |
| 225 | "Sent", "SENT" and "sent" |
| 226 | on host1 only "Sent" will be synced to host2). |
| 227 | |
| 228 | --skipemptyfolders : Empty host1 folders are not created on host2. |
| 229 | |
| 230 | --include reg : Sync folders matching this regular expression |
| 231 | --include reg : or this one, etc. |
| 232 | If both --include --exclude options are used, then |
| 233 | include is done before. |
| 234 | --exclude reg : Skips folders matching this regular expression |
| 235 | Several folders to avoid: |
| 236 | --exclude 'fold1|fold2|f3' skips fold1, fold2 and f3. |
| 237 | --exclude reg : or this one, etc. |
| 238 | |
| 239 | --automap : guesses folders mapping, for folders well known as |
| 240 | "Sent", "Junk", "Drafts", "All", "Archive", "Flagged". |
| 241 | |
| 242 | --f1f2 str1=str2 : Force folder str1 to be synced to str2, |
| 243 | --f1f2 overrides --automap and --regextrans2. |
| 244 | |
| 245 | --subfolder2 str : Syncs the whole host1 folders hierarchy under the |
| 246 | host2 folder named str. |
| 247 | It does it internally by adding three |
| 248 | --regextrans2 options before all others. |
| 249 | Add --debug to see what's really going on. |
| 250 | |
| 251 | --subfolder1 str : Syncs the host1 folders hierarchy which is under folder |
| 252 | str to the root hierarchy of host2. |
| 253 | It's the couterpart of a sync done by --subfolder2 |
| 254 | when doing it in the reverse order. |
| 255 | Backup/Restore scenario: |
| 256 | Use --subfolder2 str for a backup to the folder str |
| 257 | on host2. Then use --subfolder1 str for restoring |
| 258 | from the folder str, after inverting |
| 259 | host1/host2 user1/user2 values. |
| 260 | |
| 261 | |
| 262 | --subscribed : Transfers subscribed folders. |
| 263 | --subscribe : Subscribe to the folders transferred on the |
| 264 | host2 that are subscribed on host1. On by default. |
| 265 | --subscribeall : Subscribe to the folders transferred on the |
| 266 | host2 even if they are not subscribed on host1. |
| 267 | |
| 268 | --prefix1 str : Remove prefix str to all destination folders, |
| 269 | usually "INBOX." or "INBOX/" or an empty string "". |
| 270 | imapsync guesses the prefix if host1 imap server |
| 271 | does not have NAMESPACE capability. So this option |
| 272 | should not be used most of the time. |
| 273 | --prefix2 str : Add prefix to all host2 folders. See --prefix1 |
| 274 | |
| 275 | --sep1 str : Host1 separator. This option should not be used |
| 276 | most of the time. |
| 277 | Imapsync gets the separator from the server itself, |
| 278 | by using NAMESPACE, or it tries to guess it |
| 279 | from the folders listing (it counts |
| 280 | characters / . \\ \ in folder names and choose the |
| 281 | more frequent, or finally / if nothing is found. |
| 282 | --sep2 str : Host2 separator. See --sep1 |
| 283 | |
| 284 | --regextrans2 reg : Apply the whole regex to each destination folders. |
| 285 | --regextrans2 reg : and this one. etc. |
| 286 | When you play with the --regextrans2 option, first |
| 287 | add also the safe options --dry --justfolders |
| 288 | Then, when happy, remove --dry for a run, then |
| 289 | remove --justfolders for the next ones. |
| 290 | Have in mind that --regextrans2 is applied after |
| 291 | the automatic prefix and separator inversion. |
| 292 | For examples see: |
| 293 | https://imapsync.lamiral.info/FAQ.d/FAQ.Folders_Mapping.txt |
| 294 | |
| 295 | =head2 OPTIONS/folders sizes |
| 296 | |
| 297 | --nofoldersizes : Do not calculate the size of each folder at the |
| 298 | beginning of the sync. Default is to calculate them. |
| 299 | --nofoldersizesatend: Do not calculate the size of each folder at the |
| 300 | end of the sync. Default is to calculate them. |
| 301 | --justfoldersizes : Exit after having printed the initial folder sizes. |
| 302 | |
| 303 | |
| 304 | =head2 OPTIONS/tmp |
| 305 | |
| 306 | |
| 307 | --tmpdir str : Where to store temporary files and subdirectories. |
| 308 | Will be created if it doesn't exist. |
| 309 | Default is system specific, Unix is /tmp but |
| 310 | /tmp is often too small and deleted at reboot. |
| 311 | --tmpdir /var/tmp should be better. |
| 312 | --pidfile str : The file where imapsync pid is written, |
| 313 | it can be dirname/filename. |
| 314 | Default name is imapsync.pid in tmpdir. |
| 315 | --pidfilelocking : Abort if pidfile already exists. Useful to avoid |
| 316 | concurrent transfers on the same mailbox. |
| 317 | |
| 318 | |
| 319 | =head2 OPTIONS/log |
| 320 | |
| 321 | --nolog : Turn off logging on file |
| 322 | --logfile str : Change the default log filename (can be dirname/filename). |
| 323 | --logdir str : Change the default log directory. Default is LOG_imapsync/ |
| 324 | |
| 325 | The default logfile name is for example |
| 326 | |
| 327 | LOG_imapsync/2019_12_22_23_57_59_532_user1_user2.txt |
| 328 | |
| 329 | where: |
| 330 | |
| 331 | 2019_12_22_23_57_59_532 is nearly the date of the start |
| 332 | YYYY_MM_DD_HH_MM_SS_mmm |
| 333 | year_month_day_hour_minute_seconde_millisecond |
| 334 | |
| 335 | and user1 user2 are the --user1 --user2 values. |
| 336 | |
| 337 | =head2 OPTIONS/messages |
| 338 | |
| 339 | --skipmess reg : Skips messages matching the regex. |
| 340 | Example: 'm/[\x80-ff]/' # to avoid 8bits messages. |
| 341 | --skipmess is applied before --regexmess |
| 342 | --skipmess reg : or this one, etc. |
| 343 | |
| 344 | --skipcrossduplicates : Avoid copying messages that are already copied |
| 345 | in another folder, good from Gmail to X when |
| 346 | X is not also Gmail. |
| 347 | Activated with --gmail1 unless --noskipcrossduplicates |
| 348 | |
| 349 | --debugcrossduplicates : Prints which messages (UIDs) are skipped with |
| 350 | --skipcrossduplicates (and in what other folders |
| 351 | they are). |
| 352 | |
| 353 | --pipemess cmd : Apply this cmd command to each message content |
| 354 | before the copy. |
| 355 | --pipemess cmd : and this one, etc. |
| 356 | With several --pipemess, the output of each cmd |
| 357 | command (STDOUT) is given to the input (STDIN) |
| 358 | of the next command. |
| 359 | For example, |
| 360 | --pipemess cmd1 --pipemess cmd2 --pipemess cmd3 |
| 361 | is like a Unix pipe: |
| 362 | "cat message | cmd1 | cmd2 | cmd3" |
| 363 | |
| 364 | --disarmreadreceipts : Disarms read receipts (host2 Exchange issue) |
| 365 | |
| 366 | --regexmess reg : Apply the whole regex to each message before transfer. |
| 367 | Example: 's/\000/ /g' # to replace null by space. |
| 368 | --regexmess reg : and this one, etc. |
| 369 | |
| 370 | =head2 OPTIONS/labels |
| 371 | |
| 372 | Gmail present labels as folders in imap. Imapsync can accelerate the sync |
| 373 | by syncing X-GM-LABELS, it will avoid to transfer messages when they are |
| 374 | already on host2. |
| 375 | |
| 376 | |
| 377 | --synclabels : Syncs also Gmail labels when a message is copied to host2. |
| 378 | Activated by default with --gmail1 --gmail2 unless |
| 379 | --nosynclabels is added. |
| 380 | |
| 381 | --resynclabels : Resyncs Gmail labels when a message is already on host2. |
| 382 | Activated by default with --gmail1 --gmail2 unless |
| 383 | --noresynclabels is added. |
| 384 | |
| 385 | For Gmail syncs, see also: |
| 386 | https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt |
| 387 | |
| 388 | =head2 OPTIONS/flags |
| 389 | |
| 390 | If you encounter flag problems see also: |
| 391 | https://imapsync.lamiral.info/FAQ.d/FAQ.Flags.txt |
| 392 | |
| 393 | --regexflag reg : Apply the whole regex to each flags list. |
| 394 | Example: 's/"Junk"//g' # to remove "Junk" flag. |
| 395 | --regexflag reg : then this one, etc. |
| 396 | |
| 397 | --resyncflags : Resync flags for already transferred messages. |
| 398 | On by default. |
| 399 | --noresyncflags : Do not resync flags for already transferred messages. |
| 400 | May be useful when a user has already started to play |
| 401 | with its host2 account. |
| 402 | |
| 403 | =head2 OPTIONS/deletions |
| 404 | |
| 405 | --delete1 : Deletes messages on host1 server after a successful |
| 406 | transfer. Option --delete1 has the following behavior: |
| 407 | it marks messages as deleted with the IMAP flag |
| 408 | \Deleted, then messages are really deleted with an |
| 409 | EXPUNGE IMAP command. If expunging after each message |
| 410 | slows down too much the sync then use |
| 411 | --noexpungeaftereach to speed up, expunging will then be |
| 412 | done only twice per folder, one at the beginning and |
| 413 | one at the end of a folder sync. |
| 414 | |
| 415 | --expunge1 : Expunge messages on host1 just before syncing a folder. |
| 416 | Expunge is done per folder. |
| 417 | Expunge aims is to really delete messages marked deleted. |
| 418 | An expunge is also done after each message copied |
| 419 | if option --delete1 is set (unless --noexpungeaftereach). |
| 420 | |
| 421 | --noexpunge1 : Do not expunge messages on host1. |
| 422 | |
| 423 | --delete1emptyfolders : Deletes empty folders on host1, INBOX excepted. |
| 424 | Useful with --delete1 since what remains on host1 |
| 425 | is only what failed to be synced. |
| 426 | |
| 427 | --delete2 : Delete messages in host2 that are not in |
| 428 | host1 server. Useful for backup or pre-sync. |
| 429 | --delete2 implies --uidexpunge2 |
| 430 | |
| 431 | --delete2duplicates : Delete messages in host2 that are duplicates. |
| 432 | Works only without --useuid since duplicates are |
| 433 | detected with an header part of each message. |
| 434 | |
| 435 | --delete2folders : Delete folders in host2 that are not in host1 server. |
| 436 | For safety, first try it like this (it is safe): |
| 437 | --delete2folders --dry --justfolders --nofoldersizes |
| 438 | and see what folders will be deleted. |
| 439 | |
| 440 | --delete2foldersonly reg : Delete only folders matching the regex reg. |
| 441 | Example: --delete2foldersonly "/^Junk$|^INBOX.Junk$/" |
| 442 | This option activates --delete2folders |
| 443 | |
| 444 | --delete2foldersbutnot reg : Do not delete folders matching the regex rex. |
| 445 | Example: --delete2foldersbutnot "/Tasks$|Contacts$|Foo$/" |
| 446 | This option activates --delete2folders |
| 447 | |
| 448 | --noexpunge2 : Do not expunge messages on host2. |
| 449 | --nouidexpunge2 : Do not uidexpunge messages on the host2 account |
| 450 | that are not on the host1 account. |
| 451 | |
| 452 | |
| 453 | =head2 OPTIONS/dates |
| 454 | |
| 455 | If you encounter problems with dates, see also: |
| 456 | https://imapsync.lamiral.info/FAQ.d/FAQ.Dates.txt |
| 457 | |
| 458 | --syncinternaldates : Sets the internal dates on host2 same as host1. |
| 459 | Turned on by default. Internal date is the date |
| 460 | a message arrived on a host (Unix mtime). |
| 461 | --idatefromheader : Sets the internal dates on host2 same as the |
| 462 | ones in "Date:" headers. |
| 463 | |
| 464 | |
| 465 | |
| 466 | =head2 OPTIONS/message selection |
| 467 | |
| 468 | --maxsize int : Skip messages larger (or equal) than int bytes |
| 469 | --minsize int : Skip messages smaller (or equal) than int bytes |
| 470 | --maxage int : Skip messages older than int days. |
| 471 | final stats (skipped) don't count older messages |
| 472 | see also --minage |
| 473 | --minage int : Skip messages newer than int days. |
| 474 | final stats (skipped) don't count newer messages |
| 475 | You can do (+ zone are the messages selected): |
| 476 | past|----maxage+++++++++++++++>now |
| 477 | past|+++++++++++++++minage---->now |
| 478 | past|----maxage+++++minage---->now (intersection) |
| 479 | past|++++minage-----maxage++++>now (union) |
| 480 | |
| 481 | --search str : Selects only messages returned by this IMAP SEARCH |
| 482 | command. Applied on both sides. |
| 483 | For a complete set of what can be search see |
| 484 | https://imapsync.lamiral.info/FAQ.d/FAQ.Messages_Selection.txt |
| 485 | |
| 486 | --search1 str : Same as --search but for selecting host1 messages only. |
| 487 | --search2 str : Same as --search but for selecting host2 messages only. |
| 488 | So --search CRIT equals --search1 CRIT --search2 CRIT |
| 489 | |
| 490 | --maxlinelength int : skip messages with a line length longer than int bytes. |
| 491 | RFC 2822 says it must be no more than 1000 bytes but |
| 492 | real life servers and email clients do more. |
| 493 | |
| 494 | |
| 495 | --useheader str : Use this header to compare messages on both sides. |
| 496 | Ex: Message-ID or Subject or Date. |
| 497 | --useheader str and this one, etc. |
| 498 | |
| 499 | --usecache : Use cache to speed up next syncs. Not set by default. |
| 500 | --nousecache : Do not use cache. Caveat: --useuid --nousecache creates |
| 501 | duplicates on multiple runs. |
| 502 | --useuid : Use UIDs instead of headers as a criterion to recognize |
| 503 | messages. Option --usecache is then implied unless |
| 504 | --nousecache is used. |
| 505 | |
| 506 | |
| 507 | =head2 OPTIONS/miscellaneous |
| 508 | |
| 509 | --syncacls : Synchronizes acls (Access Control Lists). |
| 510 | Acls in IMAP are not standardized, be careful |
| 511 | since one acl code on one side may signify something |
| 512 | else on the other one. |
| 513 | --nosyncacls : Does not synchronize acls. This is the default. |
| 514 | |
| 515 | --addheader : When a message has no headers to be identified, |
| 516 | --addheader adds a "Message-Id" header, |
| 517 | like "Message-Id: 12345@imapsync", where 12345 |
| 518 | is the imap UID of the message on the host1 folder. |
| 519 | |
| 520 | |
| 521 | =head2 OPTIONS/debugging |
| 522 | |
| 523 | --debug : Debug mode. |
| 524 | --debugfolders : Debug mode for the folders part only. |
| 525 | --debugcontent : Debug content of the messages transferred. Huge output. |
| 526 | --debugflags : Debug mode for flags. |
| 527 | --debugimap1 : IMAP debug mode for host1. Very verbose. |
| 528 | --debugimap2 : IMAP debug mode for host2. Very verbose. |
| 529 | --debugimap : IMAP debug mode for host1 and host2. Twice very verbose. |
| 530 | --debugmemory : Debug mode showing memory consumption after each copy. |
| 531 | |
| 532 | --errorsmax int : Exit when int number of errors is reached. Default is 50. |
| 533 | |
| 534 | --tests : Run local non-regression tests. Exit code 0 means all ok. |
| 535 | --testslive : Run a live test with test1.lamiral.info imap server. |
| 536 | Useful to check the basics. Needs internet connection. |
| 537 | --testslive6 : Run a live test with ks2ipv6.lamiral.info imap server. |
| 538 | Useful to check the ipv6 connectivity. Needs internet. |
| 539 | |
| 540 | |
| 541 | =head2 OPTIONS/specific |
| 542 | |
| 543 | --gmail1 : sets --host1 to Gmail and other options. See FAQ.Gmail.txt |
| 544 | --gmail2 : sets --host2 to Gmail and other options. See FAQ.Gmail.txt |
| 545 | |
| 546 | --office1 : sets --host1 to Office365 and other options. See FAQ.Exchange.txt |
| 547 | --office2 : sets --host2 to Office365 and other options. See FAQ.Exchange.txt |
| 548 | |
| 549 | --exchange1 : sets options for Exchange. See FAQ.Exchange.txt |
| 550 | --exchange2 : sets options for Exchange. See FAQ.Exchange.txt |
| 551 | |
| 552 | --domino1 : sets options for Domino. See FAQ.Domino.txt |
| 553 | --domino2 : sets options for Domino. See FAQ.Domino.txt |
| 554 | |
| 555 | |
| 556 | =head2 OPTIONS/behavior |
| 557 | |
| 558 | --maxmessagespersecond int : limits the number of messages transferred per second. |
| 559 | |
| 560 | --maxbytespersecond int : limits the average transfer rate per second. |
| 561 | --maxbytesafter int : starts --maxbytespersecond limitation only after |
| 562 | --maxbytesafter amount of data transferred. |
| 563 | |
| 564 | --maxsleep int : do not sleep more than int seconds. |
| 565 | On by default, 2 seconds max, like --maxsleep 2 |
| 566 | |
| 567 | --abort : terminates a previous call still running. |
| 568 | It uses the pidfile to know what process to abort. |
| 569 | |
| 570 | --exitwhenover int : Stop syncing and exits when int total bytes |
| 571 | transferred is reached. |
| 572 | |
| 573 | --version : Print only software version. |
| 574 | --noreleasecheck : Do not check for any new imapsync release. |
| 575 | --releasecheck : Check for new imapsync release. |
| 576 | it's an http request to |
| 577 | http://imapsync.lamiral.info/prj/imapsync/VERSION |
| 578 | |
| 579 | --noid : Do not send/receive ID command to imap servers. |
| 580 | |
| 581 | --justconnect : Just connect to both servers and print useful |
| 582 | information. Need only --host1 and --host2 options. |
| 583 | Obsolete since "imapsync --host1 imaphost" alone |
| 584 | implies --justconnect |
| 585 | |
| 586 | --justlogin : Just login to both host1 and host2 with users |
| 587 | credentials, then exit. |
| 588 | |
| 589 | --justfolders : Do only things about folders (ignore messages). |
| 590 | |
| 591 | --help : print this help. |
| 592 | |
| 593 | Example: to synchronize imap account "test1" on "test1.lamiral.info" |
| 594 | to imap account "test2" on "test2.lamiral.info" |
| 595 | with test1 password "secret1" |
| 596 | and test2 password "secret2" |
| 597 | |
| 598 | imapsync \ |
| 599 | --host1 test1.lamiral.info --user1 test1 --password1 secret1 \ |
| 600 | --host2 test2.lamiral.info --user2 test2 --password2 secret2 |
| 601 | |
| 602 | |
| 603 | =cut |
| 604 | # comment |
| 605 | |
| 606 | =pod |
| 607 | |
| 608 | |
| 609 | |
| 610 | =head1 SECURITY |
| 611 | |
| 612 | You can use --passfile1 instead of --password1 to give the |
| 613 | password since it is safer. With --password1 option, on Linux, |
| 614 | any user on your host can see the password by using the 'ps auxwwww' |
| 615 | command. Using a variable (like IMAPSYNC_PASSWORD1) is also |
| 616 | dangerous because of the 'ps auxwwwwe' command. So, saving |
| 617 | the password in a well protected file (600 or rw-------) is |
| 618 | the best solution. |
| 619 | |
| 620 | Imapsync activates ssl or tls encryption by default, if possible. |
| 621 | |
| 622 | What detailed behavior is under this "if possible"? |
| 623 | |
| 624 | Imapsync activates ssl if the well known port imaps port (993) is open |
| 625 | on the imap servers. If the imaps port is closed then it open a |
| 626 | normal (clear) connection on port 143 but it looks for TLS support |
| 627 | in the CAPABILITY list of the servers. If TLS is supported |
| 628 | then imapsync goes to encryption. |
| 629 | |
| 630 | If the automatic ssl and the tls detections fail then imapsync will |
| 631 | not protect against sniffing activities on the network, especially |
| 632 | for passwords. |
| 633 | |
| 634 | If you want to force ssl or tls just use --ssl1 --ssl2 or --tls1 --tls2 |
| 635 | |
| 636 | See also the document FAQ.Security.txt in the FAQ.d/ directory |
| 637 | or at https://imapsync.lamiral.info/FAQ.d/FAQ.Security.txt |
| 638 | |
| 639 | =head1 EXIT STATUS |
| 640 | |
| 641 | Imapsync will exit with a 0 status (return code) if everything went good. |
| 642 | Otherwise, it exits with a non-zero status. That's classical Unix behavior. |
| 643 | Here is the list of the exit code values (an integer between 0 and 255). |
| 644 | The names reflect their meaning: |
| 645 | |
| 646 | =for comment |
| 647 | egrep '^Readonly my.*\$EX' imapsync | egrep -o 'EX.*' | sed 's_^_ _' |
| 648 | |
| 649 | |
| 650 | EX_OK => 0 ; #/* successful termination */ |
| 651 | EX_USAGE => 64 ; #/* command line usage error */ |
| 652 | EX_NOINPUT => 66 ; #/* cannot open input */ |
| 653 | EX_UNAVAILABLE => 69 ; #/* service unavailable */ |
| 654 | EX_SOFTWARE => 70 ; #/* internal software error */ |
| 655 | EXIT_CATCH_ALL => 1 ; # Any other error |
| 656 | EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num |
| 657 | EXIT_PID_FILE_ERROR => 8 ; |
| 658 | EXIT_CONNECTION_FAILURE => 10 ; |
| 659 | EXIT_TLS_FAILURE => 12 ; |
| 660 | EXIT_AUTHENTICATION_FAILURE => 16 ; |
| 661 | EXIT_SUBFOLDER1_NO_EXISTS => 21 ; |
| 662 | EXIT_WITH_ERRORS => 111 ; |
| 663 | EXIT_WITH_ERRORS_MAX => 112 ; |
| 664 | EXIT_TESTS_FAILED => 254 ; # Like Test::More API |
| 665 | |
| 666 | |
| 667 | |
| 668 | =head1 LICENSE AND COPYRIGHT |
| 669 | |
| 670 | Imapsync is free, open, public but not always gratis software |
| 671 | cover by the NOLIMIT Public License, now called NLPL. |
| 672 | See the LICENSE file included in the distribution or just read this |
| 673 | simple sentence as it IS the licence text: |
| 674 | |
| 675 | "No limits to do anything with this work and this license." |
| 676 | |
| 677 | In case it is not long enough, I repeat: |
| 678 | |
| 679 | "No limits to do anything with this work and this license." |
| 680 | |
| 681 | Look at https://imapsync.lamiral.info/LICENSE |
| 682 | |
| 683 | =head1 AUTHOR |
| 684 | |
| 685 | Gilles LAMIRAL <gilles@lamiral.info> |
| 686 | |
| 687 | Good feedback is always welcome. |
| 688 | Bad feedback is very often welcome. |
| 689 | |
| 690 | Gilles LAMIRAL earns his living by writing, installing, |
| 691 | configuring and teaching free, open and often gratis |
| 692 | software. Imapsync used to be "always gratis" but now it is |
| 693 | only "often gratis" because imapsync is sold by its author, |
| 694 | a good way to maintain and support free open public |
| 695 | software over decades. |
| 696 | |
| 697 | =head1 BUGS AND LIMITATIONS |
| 698 | |
| 699 | See https://imapsync.lamiral.info/FAQ.d/FAQ.Reporting_Bugs.txt |
| 700 | |
| 701 | =head1 IMAP SERVERS supported |
| 702 | |
| 703 | See https://imapsync.lamiral.info/S/imapservers.shtml |
| 704 | |
| 705 | =head1 HUGE MIGRATION |
| 706 | |
| 707 | If you have many mailboxes to migrate think about a little |
| 708 | shell program. Write a file called file.txt (for example) |
| 709 | containing users and passwords. |
| 710 | The separator used in this example is ';' |
| 711 | |
| 712 | The file.txt file contains: |
| 713 | |
| 714 | user001_1;password001_1;user001_2;password001_2 |
| 715 | user002_1;password002_1;user002_2;password002_2 |
| 716 | user003_1;password003_1;user003_2;password003_2 |
| 717 | user004_1;password004_1;user004_2;password004_2 |
| 718 | user005_1;password005_1;user005_2;password005_2 |
| 719 | ... |
| 720 | |
| 721 | On Unix the shell program can be: |
| 722 | |
| 723 | { while IFS=';' read u1 p1 u2 p2; do |
| 724 | imapsync --host1 imap.side1.org --user1 "$u1" --password1 "$p1" \ |
| 725 | --host2 imap.side2.org --user2 "$u2" --password2 "$p2" ... |
| 726 | done ; } < file.txt |
| 727 | |
| 728 | On Windows the batch program can be: |
| 729 | |
| 730 | FOR /F "tokens=1,2,3,4 delims=; eol=#" %%G IN (file.txt) DO imapsync ^ |
| 731 | --host1 imap.side1.org --user1 %%G --password1 %%H ^ |
| 732 | --host2 imap.side2.org --user2 %%I --password2 %%J ... |
| 733 | |
| 734 | The ... have to be replaced by nothing or any imapsync option. |
| 735 | Welcome in shell or batch programming ! |
| 736 | |
| 737 | You will find already written scripts at |
| 738 | https://imapsync.lamiral.info/examples/ |
| 739 | |
| 740 | =head1 INSTALL |
| 741 | |
| 742 | Imapsync works under any Unix with Perl. |
| 743 | |
| 744 | Imapsync works under most Windows (2000, XP, Vista, Seven, Eight, Ten |
| 745 | and all Server releases 2000, 2003, 2008 and R2, 2012 and R2, 2016) |
| 746 | as a standalone binary software called imapsync.exe, |
| 747 | usually launched from a batch file in order to avoid always typing |
| 748 | the options. There is also a 64bit binary called imapsync_64bit.exe |
| 749 | |
| 750 | Imapsync works under OS X as a standalone binary |
| 751 | software called imapsync_bin_Darwin |
| 752 | |
| 753 | Purchase latest imapsync at |
| 754 | https://imapsync.lamiral.info/ |
| 755 | |
| 756 | You'll receive a link to a compressed tarball called imapsync-x.xx.tgz |
| 757 | where x.xx is the version number. Untar the tarball where |
| 758 | you want (on Unix): |
| 759 | |
| 760 | tar xzvf imapsync-x.xx.tgz |
| 761 | |
| 762 | Go into the directory imapsync-x.xx and read the INSTALL file. |
| 763 | As mentioned at https://imapsync.lamiral.info/#install |
| 764 | the INSTALL file can also be found at |
| 765 | https://imapsync.lamiral.info/INSTALL.d/INSTALL.ANY.txt |
| 766 | It is now split in several files for each system |
| 767 | https://imapsync.lamiral.info/INSTALL.d/ |
| 768 | |
| 769 | =head1 CONFIGURATION |
| 770 | |
| 771 | There is no specific configuration file for imapsync, |
| 772 | everything is specified by the command line parameters |
| 773 | and the default behavior. |
| 774 | |
| 775 | |
| 776 | =head1 HACKING |
| 777 | |
| 778 | Feel free to hack imapsync as the NOLIMIT license permits it. |
| 779 | |
| 780 | |
| 781 | =head1 SIMILAR SOFTWARE |
| 782 | |
| 783 | See also https://imapsync.lamiral.info/S/external.shtml |
| 784 | for a better up to date list. |
| 785 | |
| 786 | Last updated and verified on Sun Dec 8, 2019. |
| 787 | |
| 788 | |
| 789 | imapsync: https://github.com/imapsync/imapsync (this is an imapsync copy, sometimes delayed, with --noreleasecheck by default since release 1.592, 2014/05/22) |
| 790 | imap_tools: https://web.archive.org/web/20161228145952/http://www.athensfbc.com/imap_tools/. The imap_tools code is now at https://github.com/andrewnimmo/rick-sanders-imap-tools |
| 791 | imaputils: https://github.com/mtsatsenko/imaputils (very old imap_tools fork) |
| 792 | Doveadm-Sync: https://wiki2.dovecot.org/Tools/Doveadm/Sync ( Dovecot sync tool ) |
| 793 | davmail: http://davmail.sourceforge.net/ |
| 794 | offlineimap: http://offlineimap.org/ |
| 795 | mbsync: http://isync.sourceforge.net/ |
| 796 | mailsync: http://mailsync.sourceforge.net/ |
| 797 | mailutil: https://www.washington.edu/imap/ part of the UW IMAP toolkit. (well, seems abandoned now) |
| 798 | imaprepl: https://bl0rg.net/software/ http://freecode.com/projects/imap-repl/ |
| 799 | imapcopy (Pascal): http://www.ardiehl.de/imapcopy/ |
| 800 | imapcopy (Java): https://code.google.com/archive/p/imapcopy/ |
| 801 | imapsize: http://www.broobles.com/imapsize/ |
| 802 | migrationtool: http://sourceforge.net/projects/migrationtool/ |
| 803 | imapmigrate: http://sourceforge.net/projects/cyrus-utils/ |
| 804 | larch: https://github.com/rgrove/larch (derived from wonko_imapsync, good at Gmail) |
| 805 | wonko_imapsync: http://wonko.com/article/554 (superseded by larch) |
| 806 | pop2imap: http://www.linux-france.org/prj/pop2imap/ (I wrote that too) |
| 807 | exchange-away: http://exchange-away.sourceforge.net/ |
| 808 | SyncBackPro: http://www.2brightsparks.com/syncback/sbpro.html |
| 809 | ImapSyncClient: https://github.com/ridaamirini/ImapSyncClient |
| 810 | MailStore: https://www.mailstore.com/en/products/mailstore-home/ |
| 811 | mnIMAPSync: https://github.com/manusa/mnIMAPSync |
| 812 | imap-upload: http://imap-upload.sourceforge.net/ (A tool for uploading a local mbox file to IMAP4 server) |
| 813 | imapbackup: https://github.com/rcarmo/imapbackup (A Python script for incremental backups of IMAP mailboxes) |
| 814 | BitRecover email-backup 99 USD, 299 USD https://www.bitrecover.com/email-backup/. |
| 815 | ImportExportTools: https://addons.thunderbird.net/en-us/thunderbird/addon/importexporttools/ ImportExportTools for Mozilla Thunderbird by Paolo Kaosmos. ImportExportTools does not do IMAP. |
| 816 | |
| 817 | |
| 818 | |
| 819 | =head1 HISTORY |
| 820 | |
| 821 | I initially wrote imapsync in July 2001 because an enterprise, |
| 822 | called BaSystemes, paid me to install a new imap server |
| 823 | without losing huge old mailboxes located in a far |
| 824 | away remote imap server, accessible by an |
| 825 | often broken low-bandwidth ISDN link. |
| 826 | |
| 827 | I had to verify every mailbox was well transferred, all folders, all messages, |
| 828 | without wasting bandwidth or creating duplicates upon resyncs. The imapsync |
| 829 | design was made with the beautiful rsync command in mind. |
| 830 | |
| 831 | Imapsync started its life as a patch of the copy_folder.pl |
| 832 | script. The script copy_folder.pl comes from the Mail-IMAPClient-2.1.3 perl |
| 833 | module tarball source (more precisely in the examples/ directory of the |
| 834 | Mail-IMAPClient tarball). |
| 835 | |
| 836 | So many happened since then that I wonder |
| 837 | if it remains any lines of the original |
| 838 | copy_folder.pl in imapsync source code. |
| 839 | |
| 840 | |
| 841 | =cut |
| 842 | |
| 843 | |
| 844 | # use pragmas |
| 845 | # |
| 846 | |
| 847 | use strict ; |
| 848 | use warnings ; |
| 849 | use Carp ; |
| 850 | use Data::Dumper ; |
| 851 | use Digest::HMAC_SHA1 qw( hmac_sha1 hmac_sha1_hex ) ; |
| 852 | use Digest::MD5 qw( md5 md5_hex md5_base64 ) ; |
| 853 | use English qw( -no_match_vars ) ; |
| 854 | use Errno qw(EAGAIN EPIPE ECONNRESET) ; |
| 855 | use Fcntl ; |
| 856 | use File::Basename ; |
| 857 | use File::Copy::Recursive ; |
| 858 | use File::Glob qw( :glob ) ; |
| 859 | use File::Path qw( mkpath rmtree ) ; |
| 860 | use File::Spec ; |
| 861 | use File::stat ; |
| 862 | use Getopt::Long ( ) ; |
| 863 | use IO::File ; |
| 864 | use IO::Socket qw( :crlf SOL_SOCKET SO_KEEPALIVE ) ; |
| 865 | use IO::Socket::INET6 ; |
| 866 | use IO::Socket::SSL ; |
| 867 | use IO::Tee ; |
| 868 | use IPC::Open3 'open3' ; |
| 869 | use Mail::IMAPClient 3.30 ; |
| 870 | use MIME::Base64 ; |
| 871 | use Pod::Usage qw(pod2usage) ; |
| 872 | use POSIX qw(uname SIGALRM :sys_wait_h) ; |
| 873 | use Sys::Hostname ; |
| 874 | use Term::ReadKey ; |
| 875 | use Test::More ; |
| 876 | use Time::HiRes qw( time sleep ) ; |
| 877 | use Time::Local ; |
| 878 | use Unicode::String ; |
| 879 | use Cwd ; |
| 880 | use Readonly ; |
| 881 | use Sys::MemInfo ; |
| 882 | use Regexp::Common ; |
| 883 | use Text::ParseWords ; # for quotewords() |
| 884 | use File::Tail ; |
| 885 | |
| 886 | use Encode ; |
| 887 | use Encode::IMAPUTF7 ; |
| 888 | |
| 889 | |
| 890 | local $OUTPUT_AUTOFLUSH = 1 ; |
| 891 | |
| 892 | # constants |
| 893 | |
| 894 | # Let us do like sysexits.h |
| 895 | # /usr/include/sysexits.h |
| 896 | # and https://www.tldp.org/LDP/abs/html/exitcodes.html |
| 897 | |
| 898 | # Should avoid 2 126 127 128..128+64=192 255 |
| 899 | # Should use 0 1 3..125 193..254 |
| 900 | |
| 901 | Readonly my $EX_OK => 0 ; #/* successful termination */ |
| 902 | Readonly my $EX_USAGE => 64 ; #/* command line usage error */ |
| 903 | #Readonly my $EX_DATAERR => 65 ; #/* data format error */ |
| 904 | Readonly my $EX_NOINPUT => 66 ; #/* cannot open input */ |
| 905 | #Readonly my $EX_NOUSER => 67 ; #/* addressee unknown */ |
| 906 | #Readonly my $EX_NOHOST => 68 ; #/* host name unknown */ |
| 907 | Readonly my $EX_UNAVAILABLE => 69 ; #/* service unavailable */ |
| 908 | Readonly my $EX_SOFTWARE => 70 ; #/* internal software error */ |
| 909 | #Readonly my $EX_OSERR => 71 ; #/* system error (e.g., can't fork) */ |
| 910 | #Readonly my $EX_OSFILE => 72 ; #/* critical OS file missing */ |
| 911 | #Readonly my $EX_CANTCREAT => 73 ; #/* can't create (user) output file */ |
| 912 | #Readonly my $EX_IOERR => 74 ; #/* input/output error */ |
| 913 | #Readonly my $EX_TEMPFAIL => 75 ; #/* temp failure; user is invited to retry */ |
| 914 | #Readonly my $EX_PROTOCOL => 76 ; #/* remote error in protocol */ |
| 915 | #Readonly my $EX_NOPERM => 77 ; #/* permission denied */ |
| 916 | #Readonly my $EX_CONFIG => 78 ; #/* configuration error */ |
| 917 | |
| 918 | # Mine |
| 919 | Readonly my $EXIT_CATCH_ALL => 1 ; # Any other error |
| 920 | Readonly my $EXIT_BY_SIGNAL => 6 ; # Should be 128+n where n is the sig_num |
| 921 | Readonly my $EXIT_PID_FILE_ERROR => 8 ; |
| 922 | Readonly my $EXIT_CONNECTION_FAILURE => 10 ; |
| 923 | Readonly my $EXIT_TLS_FAILURE => 12 ; |
| 924 | Readonly my $EXIT_AUTHENTICATION_FAILURE => 16 ; |
| 925 | Readonly my $EXIT_SUBFOLDER1_NO_EXISTS => 21 ; |
| 926 | Readonly my $EXIT_WITH_ERRORS => 111 ; |
| 927 | Readonly my $EXIT_WITH_ERRORS_MAX => 112 ; |
| 928 | |
| 929 | |
| 930 | Readonly my $EXIT_TESTS_FAILED => 254 ; # Like Test::More API |
| 931 | |
| 932 | |
| 933 | Readonly my %EXIT_TXT => ( |
| 934 | $EX_OK => 'EX_OK: successful termination', |
| 935 | $EX_USAGE => 'EX_USAGE: command line usage error', |
| 936 | $EX_NOINPUT => 'EX_NOINPUT: cannot open input', |
| 937 | $EX_UNAVAILABLE => 'EX_UNAVAILABLE: service unavailable', |
| 938 | $EX_SOFTWARE => 'EX_SOFTWARE: internal software error', |
| 939 | |
| 940 | $EXIT_CATCH_ALL => 'EXIT_CATCH_ALL', |
| 941 | $EXIT_BY_SIGNAL => 'EXIT_BY_SIGNAL', |
| 942 | $EXIT_PID_FILE_ERROR => 'EXIT_PID_FILE_ERROR' , |
| 943 | $EXIT_CONNECTION_FAILURE => 'EXIT_CONNECTION_FAILURE', |
| 944 | $EXIT_TLS_FAILURE => 'EXIT_TLS_FAILURE', |
| 945 | $EXIT_AUTHENTICATION_FAILURE => 'EXIT_AUTHENTICATION_FAILURE', |
| 946 | $EXIT_SUBFOLDER1_NO_EXISTS => 'EXIT_SUBFOLDER1_NO_EXISTS', |
| 947 | $EXIT_WITH_ERRORS => 'EXIT_WITH_ERRORS', |
| 948 | $EXIT_WITH_ERRORS_MAX => 'EXIT_WITH_ERRORS_MAX', |
| 949 | $EXIT_TESTS_FAILED => 'EXIT_TESTS_FAILED', |
| 950 | ) ; |
| 951 | |
| 952 | |
| 953 | Readonly my $DEFAULT_LOGDIR => 'LOG_imapsync' ; |
| 954 | |
| 955 | Readonly my $ERRORS_MAX => 50 ; # exit after 50 errors. |
| 956 | Readonly my $ERRORS_MAX_CGI => 20 ; # exit after 20 errors in CGI context. |
| 957 | |
| 958 | |
| 959 | |
| 960 | Readonly my $INTERVAL_TO_EXIT => 2 ; # interval max to exit instead of reconnect |
| 961 | |
| 962 | Readonly my $SPLIT => 100 ; # By default, 100 at a time, not more. |
| 963 | Readonly my $SPLIT_FACTOR => 10 ; # init_imap() calls Maxcommandlength( $SPLIT_FACTOR * $split ) |
| 964 | # which means default Maxcommandlength is 10*100 = 1000 characters ; |
| 965 | |
| 966 | Readonly my $IMAP_PORT => 143 ; # Well know port for IMAP |
| 967 | Readonly my $IMAP_SSL_PORT => 993 ; # Well know port for IMAP over SSL |
| 968 | |
| 969 | Readonly my $LAST => -1 ; |
| 970 | Readonly my $MINUS_ONE => -1 ; |
| 971 | Readonly my $MINUS_TWO => -2 ; |
| 972 | |
| 973 | Readonly my $RELEASE_NUMBER_EXAMPLE_1 => '1.351' ; |
| 974 | Readonly my $RELEASE_NUMBER_EXAMPLE_2 => 42.4242 ; |
| 975 | |
| 976 | Readonly my $TCP_PING_TIMEOUT => 5 ; |
| 977 | Readonly my $DEFAULT_TIMEOUT => 120 ; |
| 978 | Readonly my $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND => 3 ; |
| 979 | Readonly my $DEFAULT_UIDNEXT => 999_999 ; |
| 980 | Readonly my $DEFAULT_BUFFER_SIZE => 4096 ; |
| 981 | |
| 982 | Readonly my $MAX_SLEEP => 2 ; # 2 seconds max for limiting too long sleeps from --maxbytespersecond and --maxmessagespersecond |
| 983 | |
| 984 | Readonly my $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12 => 3600 ; |
| 985 | |
| 986 | Readonly my $PERMISSION_FILTER => 7777 ; |
| 987 | |
| 988 | Readonly my $KIBI => 1024 ; |
| 989 | |
| 990 | Readonly my $NUMBER_10 => 10 ; |
| 991 | Readonly my $NUMBER_42 => 42 ; |
| 992 | Readonly my $NUMBER_100 => 100 ; |
| 993 | Readonly my $NUMBER_200 => 200 ; |
| 994 | Readonly my $NUMBER_300 => 300 ; |
| 995 | Readonly my $NUMBER_123456 => 123_456 ; |
| 996 | Readonly my $NUMBER_654321 => 654_321 ; |
| 997 | |
| 998 | Readonly my $NUMBER_20_000 => 20_000 ; |
| 999 | |
| 1000 | Readonly my $QUOTA_PERCENT_LIMIT => 90 ; |
| 1001 | |
| 1002 | Readonly my $NUMBER_104_857_600 => 104_857_600 ; |
| 1003 | |
| 1004 | Readonly my $SIZE_MAX_STR => 64 ; |
| 1005 | |
| 1006 | Readonly my $NB_SECONDS_IN_A_DAY => 86_400 ; |
| 1007 | |
| 1008 | Readonly my $STD_CHAR_PER_LINE => 80 ; |
| 1009 | |
| 1010 | Readonly my $TRUE => 1 ; |
| 1011 | Readonly my $FALSE => 0 ; |
| 1012 | |
| 1013 | Readonly my $LAST_RESSORT_SEPARATOR => q{/} ; |
| 1014 | |
| 1015 | Readonly my $CGI_TMPDIR_TOP => '/var/tmp/imapsync_cgi' ; |
| 1016 | Readonly my $CGI_HASHFILE => '/var/tmp/imapsync_hash' ; |
| 1017 | Readonly my $UMASK_PARANO => '0077' ; |
| 1018 | |
| 1019 | Readonly my $STR_use_releasecheck => q{Check if a new imapsync release is available by adding --releasecheck} ; |
| 1020 | |
| 1021 | Readonly my $GMAIL_MAXSIZE => 35_651_584 ; |
| 1022 | |
| 1023 | Readonly my $FORCE => 1 ; |
| 1024 | |
| 1025 | # if ( 'MSWin32' eq $OSNAME ) |
| 1026 | # if ( 'darwin' eq $OSNAME ) |
| 1027 | # if ( 'linux' eq $OSNAME ) |
| 1028 | |
| 1029 | |
| 1030 | |
| 1031 | # global variables |
| 1032 | # Currently working to finish with only $sync |
| 1033 | # Not finished yet... |
| 1034 | |
| 1035 | my( |
| 1036 | $sync, |
| 1037 | $timestart_str, |
| 1038 | $debugimap, $debugimap1, $debugimap2, $debugcontent, $debugflags, |
| 1039 | $debuglist, $debugdev, $debugmaxlinelength, $debugcgi, |
| 1040 | $domain1, $domain2, |
| 1041 | |
| 1042 | @include, @exclude, @folderrec, |
| 1043 | @folderfirst, @folderlast, |
| 1044 | @h1_folders_all, %h1_folders_all, |
| 1045 | @h2_folders_all, %h2_folders_all, |
| 1046 | @h2_folders_from_1_wanted, %h2_folders_from_1_all, |
| 1047 | %requested_folder, |
| 1048 | $h1_folders_wanted_nb, $h1_folders_wanted_ct, |
| 1049 | @h2_folders_not_in_1, |
| 1050 | %h1_subscribed_folder, %h2_subscribed_folder, |
| 1051 | %h2_folders_from_1_wanted, |
| 1052 | %h2_folders_from_1_several, |
| 1053 | |
| 1054 | $prefix1, $prefix2, |
| 1055 | @regexmess, @regexflag, @skipmess, @pipemess, $pipemesscheck, |
| 1056 | $flagscase, $filterflags, $syncflagsaftercopy, |
| 1057 | $syncinternaldates, |
| 1058 | $idatefromheader, |
| 1059 | $syncacls, |
| 1060 | $fastio1, $fastio2, |
| 1061 | $minsize, $maxage, $minage, |
| 1062 | $search, |
| 1063 | $skipheader, @useheader, %useheader, |
| 1064 | $skipsize, $allowsizemismatch, $buffersize, |
| 1065 | |
| 1066 | |
| 1067 | $authmd5, $authmd51, $authmd52, |
| 1068 | $subscribed, $subscribe, $subscribeall, |
| 1069 | $help, |
| 1070 | $justbanner, |
| 1071 | $fast, |
| 1072 | |
| 1073 | $nb_msg_skipped_dry_mode, |
| 1074 | $h1_nb_msg_duplicate, |
| 1075 | $h2_nb_msg_duplicate, |
| 1076 | $h2_nb_msg_noheader, |
| 1077 | |
| 1078 | $h2_nb_msg_deleted, |
| 1079 | |
| 1080 | $h1_bytes_processed, |
| 1081 | |
| 1082 | $h1_nb_msg_end, $h1_bytes_end, |
| 1083 | $h2_nb_msg_end, $h2_bytes_end, |
| 1084 | |
| 1085 | $timeout, |
| 1086 | $timestart_int, |
| 1087 | |
| 1088 | $uid1, $uid2, |
| 1089 | $authuser1, $authuser2, |
| 1090 | $proxyauth1, $proxyauth2, |
| 1091 | $authmech1, $authmech2, |
| 1092 | $split1, $split2, |
| 1093 | $reconnectretry1, $reconnectretry2, |
| 1094 | $max_msg_size_in_bytes, |
| 1095 | $modulesversion, |
| 1096 | $delete2folders, $delete2foldersonly, $delete2foldersbutnot, |
| 1097 | $usecache, $debugcache, $cacheaftercopy, |
| 1098 | $wholeheaderifneeded, %h1_msgs_copy_by_uid, $useuid, $h2_uidguess, |
| 1099 | $checkmessageexists, |
| 1100 | $messageidnodomain, |
| 1101 | $fixInboxINBOX, |
| 1102 | $maxlinelength, $maxlinelengthcmd, |
| 1103 | $minmaxlinelength, |
| 1104 | $uidnext_default, |
| 1105 | $fixcolonbug, |
| 1106 | $create_folder_old, |
| 1107 | $skipcrossduplicates, $debugcrossduplicates, |
| 1108 | $disarmreadreceipts, |
| 1109 | $mixfolders, |
| 1110 | $fetch_hash_set, |
| 1111 | $cgidir, |
| 1112 | %month_abrev, |
| 1113 | $SSL_VERIFY_POLICY, |
| 1114 | $warn_release, |
| 1115 | ) ; |
| 1116 | |
| 1117 | single_sync( ) ; |
| 1118 | |
| 1119 | sub single_sync |
| 1120 | { |
| 1121 | |
| 1122 | # main program |
| 1123 | # global variables initialization |
| 1124 | |
| 1125 | # I'm currently removing all global variables except $sync |
| 1126 | # passing each of them under $sync->{variable_name} |
| 1127 | |
| 1128 | $sync->{timestart} = time ; # Is a float because of use Time::HiRres |
| 1129 | |
| 1130 | $sync->{rcs} = q{$Id: imapsync,v 1.977 2019/12/23 20:18:02 gilles Exp gilles $} ; |
| 1131 | |
| 1132 | $sync->{ memory_consumption_at_start } = memory_consumption( ) || 0 ; |
| 1133 | |
| 1134 | |
| 1135 | my @loadavg = loadavg( ) ; |
| 1136 | |
| 1137 | $sync->{cpu_number} = cpu_number( ) ; |
| 1138 | $sync->{loaddelay} = load_and_delay( $sync->{cpu_number}, @loadavg ) ; |
| 1139 | $sync->{loadavg} = join( q{ }, $loadavg[ 0 ] ) |
| 1140 | . " on $sync->{cpu_number} cores and " |
| 1141 | . ram_memory_info( ) ; |
| 1142 | |
| 1143 | |
| 1144 | |
| 1145 | $sync->{ total_bytes_transferred } = 0 ; |
| 1146 | $sync->{ total_bytes_skipped } = 0 ; |
| 1147 | $sync->{ nb_msg_transferred } = 0 ; |
| 1148 | $sync->{ nb_msg_skipped } = $nb_msg_skipped_dry_mode = 0 ; |
| 1149 | $sync->{ h1_nb_msg_deleted } = 0 ; |
| 1150 | $h2_nb_msg_deleted = 0 ; |
| 1151 | $h1_nb_msg_duplicate = 0 ; |
| 1152 | $h2_nb_msg_duplicate = 0 ; |
| 1153 | $sync->{ h1_nb_msg_noheader } = 0 ; |
| 1154 | $h2_nb_msg_noheader = 0 ; |
| 1155 | |
| 1156 | |
| 1157 | $sync->{ h1_nb_msg_start } = 0 ; |
| 1158 | $sync->{ h1_bytes_start } = 0 ; |
| 1159 | $sync->{ h2_nb_msg_start } = 0 ; |
| 1160 | $sync->{ h2_bytes_start } = 0 ; |
| 1161 | $sync->{ h1_nb_msg_processed } = $h1_bytes_processed = 0 ; |
| 1162 | |
| 1163 | $sync->{ h2_nb_msg_crossdup } = 0 ; |
| 1164 | |
| 1165 | #$h1_nb_msg_end = $h1_bytes_end = 0 ; |
| 1166 | #$h2_nb_msg_end = $h2_bytes_end = 0 ; |
| 1167 | |
| 1168 | $sync->{nb_errors} = 0; |
| 1169 | $max_msg_size_in_bytes = 0; |
| 1170 | |
| 1171 | %month_abrev = ( |
| 1172 | Jan => '00', |
| 1173 | Feb => '01', |
| 1174 | Mar => '02', |
| 1175 | Apr => '03', |
| 1176 | May => '04', |
| 1177 | Jun => '05', |
| 1178 | Jul => '06', |
| 1179 | Aug => '07', |
| 1180 | Sep => '08', |
| 1181 | Oct => '09', |
| 1182 | Nov => '10', |
| 1183 | Dec => '11', |
| 1184 | ); |
| 1185 | |
| 1186 | |
| 1187 | |
| 1188 | # Just create a CGI object if under cgi context only. |
| 1189 | # Needed for the get_options() call |
| 1190 | cgibegin( $sync ) ; |
| 1191 | |
| 1192 | # In cgi context, printing must start by the header so we delay other prints by using output() storage |
| 1193 | my $options_good = get_options( $sync, @ARGV ) ; |
| 1194 | # Is it the first myprint? |
| 1195 | docker_context( $sync ) ; |
| 1196 | cgibuildheader( $sync ) ; |
| 1197 | |
| 1198 | myprint( output( $sync ) ) ; |
| 1199 | output_reset_with( $sync ) ; |
| 1200 | |
| 1201 | # Old place for cgiload( $sync ) ; |
| 1202 | |
| 1203 | # don't go on if options are not all known. |
| 1204 | if ( ! defined $options_good ) { exit $EX_USAGE ; } |
| 1205 | |
| 1206 | # If you want releasecheck not to be done by default (like the github maintainer), |
| 1207 | # then just uncomment the first "$sync->{releasecheck} =" line, the line ending with "0 ;", |
| 1208 | # the second line (ending with "1 ;") can then stay active or be commented, |
| 1209 | # the result will be the same: no releasecheck by default (because 0 is then the defined value). |
| 1210 | |
| 1211 | #$sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 0 ; |
| 1212 | $sync->{releasecheck} = defined $sync->{releasecheck} ? $sync->{releasecheck} : 1 ; |
| 1213 | |
| 1214 | # just the version |
| 1215 | if ( $sync->{ version } ) { |
| 1216 | myprint( imapsync_version( $sync ), "\n" ) ; |
| 1217 | exit 0 ; |
| 1218 | } |
| 1219 | |
| 1220 | #$sync->{debugenv} = 1 ; |
| 1221 | $sync->{debugenv} and printenv( $sync ) ; # if option --debugenv |
| 1222 | load_modules( ) ; |
| 1223 | |
| 1224 | # after_get_options call usage and exit if --help or options were not well got |
| 1225 | after_get_options( $sync, $options_good ) ; |
| 1226 | |
| 1227 | |
| 1228 | # Under CGI environment, fix caveat emptor potential issues |
| 1229 | cgisetcontext( $sync ) ; |
| 1230 | |
| 1231 | # --gmail --gmail --exchange --office etc. |
| 1232 | easyany( $sync ) ; |
| 1233 | |
| 1234 | $sync->{ sanitize } = defined $sync->{ sanitize } ? $sync->{ sanitize } : 1 ; |
| 1235 | sanitize( $sync ) ; |
| 1236 | |
| 1237 | $sync->{ tmpdir } ||= File::Spec->tmpdir( ) ; |
| 1238 | |
| 1239 | # Unit tests |
| 1240 | testsexit( $sync ) ; |
| 1241 | |
| 1242 | # init live varaiables |
| 1243 | testslive_init( $sync ) if ( $sync->{testslive} ) ; |
| 1244 | testslive6_init( $sync ) if ( $sync->{testslive6} ) ; |
| 1245 | |
| 1246 | # |
| 1247 | |
| 1248 | pidfile( $sync ) ; |
| 1249 | |
| 1250 | # old abort place |
| 1251 | |
| 1252 | install_signals( $sync ) ; |
| 1253 | |
| 1254 | $sync->{log} = defined $sync->{log} ? $sync->{log} : 1 ; |
| 1255 | $sync->{errorsdump} = defined $sync->{errorsdump} ? $sync->{errorsdump} : 1 ; |
| 1256 | $sync->{errorsmax} = defined $sync->{errorsmax} ? $sync->{errorsmax} : $ERRORS_MAX ; |
| 1257 | |
| 1258 | # log and output |
| 1259 | binmode STDOUT, ":encoding(UTF-8)" ; |
| 1260 | |
| 1261 | if ( $sync->{log} ) { |
| 1262 | setlogfile( $sync ) ; |
| 1263 | teelaunch( $sync ) ; |
| 1264 | # now $sync->{tee} is a filehandle to STDOUT and the logfile |
| 1265 | } |
| 1266 | |
| 1267 | #binmode STDERR, ":encoding(UTF-8)" ; |
| 1268 | # STDERR goes to the same place: LOG and STDOUT (if logging is on) |
| 1269 | # Useful only for --debugssl |
| 1270 | $sync->{tee} and local *STDERR = *${$sync->{tee}}{IO} ; |
| 1271 | |
| 1272 | |
| 1273 | |
| 1274 | $timestart_int = int( $sync->{timestart} ) ; |
| 1275 | $sync->{timebefore} = $sync->{timestart} ; |
| 1276 | |
| 1277 | |
| 1278 | $timestart_str = localtime( $sync->{timestart} ) ; |
| 1279 | |
| 1280 | # The prints in the log starts here |
| 1281 | |
| 1282 | myprint( localhost_info( $sync ), "\n" ) ; |
| 1283 | myprint( "Transfer started at $timestart_str\n" ) ; |
| 1284 | myprint( "PID is $PROCESS_ID my PPID is ", mygetppid( ), "\n" ) ; |
| 1285 | myprint( "Log file is $sync->{logfile} ( to change it, use --logfile path ; or use --nolog to turn off logging )\n" ) if ( $sync->{log} ) ; |
| 1286 | myprint( "Load is " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $sync->{cpu_number} cores\n" ) ; |
| 1287 | #myprintf( "Memory consumption so far: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; |
| 1288 | myprint( 'Current directory is ' . getcwd( ) . "\n" ) ; |
| 1289 | myprint( 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ; |
| 1290 | myprint( 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ; |
| 1291 | |
| 1292 | $modulesversion = defined $modulesversion ? $modulesversion : 1 ; |
| 1293 | |
| 1294 | $warn_release = ( $sync->{releasecheck} ) ? check_last_release( ) : $STR_use_releasecheck ; |
| 1295 | |
| 1296 | |
| 1297 | $wholeheaderifneeded = defined $wholeheaderifneeded ? $wholeheaderifneeded : 1; |
| 1298 | |
| 1299 | # Activate --usecache if --useuid is set and no --nousecache |
| 1300 | $usecache = 1 if ( $useuid and ( ! defined $usecache ) ) ; |
| 1301 | $cacheaftercopy = 1 if ( $usecache and ( ! defined $cacheaftercopy ) ) ; |
| 1302 | |
| 1303 | $sync->{ checkselectable } = defined $sync->{ checkselectable } ? $sync->{ checkselectable } : 1 ; |
| 1304 | $sync->{ checkfoldersexist } = defined $sync->{ checkfoldersexist } ? $sync->{ checkfoldersexist } : 1 ; |
| 1305 | $checkmessageexists = defined $checkmessageexists ? $checkmessageexists : 0 ; |
| 1306 | $sync->{ expungeaftereach } = defined $sync->{ expungeaftereach } ? $sync->{ expungeaftereach } : 1 ; |
| 1307 | |
| 1308 | # abletosearch is on by default |
| 1309 | $sync->{abletosearch} = defined $sync->{abletosearch} ? $sync->{abletosearch} : 1 ; |
| 1310 | $sync->{abletosearch1} = defined $sync->{abletosearch1} ? $sync->{abletosearch1} : $sync->{abletosearch} ; |
| 1311 | $sync->{abletosearch2} = defined $sync->{abletosearch2} ? $sync->{abletosearch2} : $sync->{abletosearch} ; |
| 1312 | $checkmessageexists = 0 if ( not $sync->{abletosearch1} ) ; |
| 1313 | |
| 1314 | |
| 1315 | $sync->{showpasswords} = defined $sync->{showpasswords} ? $sync->{showpasswords} : 0 ; |
| 1316 | $sync->{ fixslash2 } = defined $sync->{ fixslash2 } ? $sync->{ fixslash2 } : 1 ; |
| 1317 | $fixInboxINBOX = defined $fixInboxINBOX ? $fixInboxINBOX : 1 ; |
| 1318 | $create_folder_old = defined $create_folder_old ? $create_folder_old : 0 ; |
| 1319 | $mixfolders = defined $mixfolders ? $mixfolders : 1 ; |
| 1320 | $sync->{automap} = defined $sync->{automap} ? $sync->{automap} : 0 ; |
| 1321 | |
| 1322 | $sync->{ delete2duplicates } = 1 if ( $sync->{ delete2 } and ( ! defined $sync->{ delete2duplicates } ) ) ; |
| 1323 | |
| 1324 | $sync->{maxmessagespersecond} = defined $sync->{maxmessagespersecond} ? $sync->{maxmessagespersecond} : 0 ; |
| 1325 | $sync->{maxbytespersecond} = defined $sync->{maxbytespersecond} ? $sync->{maxbytespersecond} : 0 ; |
| 1326 | |
| 1327 | $sync->{sslcheck} = defined $sync->{sslcheck} ? $sync->{sslcheck} : 1 ; |
| 1328 | |
| 1329 | myprint( banner_imapsync( $sync, @ARGV ) ) ; |
| 1330 | |
| 1331 | myprint( "Temp directory is $sync->{ tmpdir } ( to change it use --tmpdir dirpath )\n" ) ; |
| 1332 | |
| 1333 | myprint( output( $sync ) ) ; |
| 1334 | output_reset_with( $sync ) ; |
| 1335 | |
| 1336 | do_valid_directory( $sync->{ tmpdir } ) || croak "Error creating tmpdir $sync->{ tmpdir } : $OS_ERROR" ; |
| 1337 | |
| 1338 | remove_pidfile_not_running( $sync->{pidfile} ) ; |
| 1339 | |
| 1340 | # if another imapsync is running then tail -f its logfile and exit |
| 1341 | # useful in cgi context |
| 1342 | if ( $sync->{ tail } and tail( $sync ) ) |
| 1343 | { |
| 1344 | $sync->{nb_errors}++ ; |
| 1345 | exit_clean( $sync, $EX_OK, "Tail -f finished. Now finishing myself processus $PROCESS_ID\n" ) ; |
| 1346 | exit $EX_OK ; |
| 1347 | } |
| 1348 | |
| 1349 | if ( ! write_pidfile( $sync ) ) { |
| 1350 | myprint( "Exiting with return value $EXIT_PID_FILE_ERROR ($EXIT_TXT{$EXIT_PID_FILE_ERROR}) $sync->{nb_errors}/$sync->{errorsmax} nb_errors/max_errors\n" ) ; |
| 1351 | exit $EXIT_PID_FILE_ERROR ; |
| 1352 | } |
| 1353 | |
| 1354 | |
| 1355 | # New place for abort |
| 1356 | # abort before simulong in order to be able to abort a simulong sync |
| 1357 | if ( $sync->{ abort } ) |
| 1358 | { |
| 1359 | abort( $sync ) ; |
| 1360 | } |
| 1361 | |
| 1362 | # simulong is just a loop printing some lines for xx seconds with option "--simulong xx". |
| 1363 | if ( $sync->{ simulong } ) |
| 1364 | { |
| 1365 | simulong( $sync->{ simulong } ) ; |
| 1366 | } |
| 1367 | |
| 1368 | |
| 1369 | # New place for cgiload 2019_03_03 |
| 1370 | # because I want to log it |
| 1371 | # Can break here if load is too heavy |
| 1372 | cgiload( $sync ) ; |
| 1373 | |
| 1374 | |
| 1375 | $fixcolonbug = defined $fixcolonbug ? $fixcolonbug : 1 ; |
| 1376 | |
| 1377 | if ( $usecache and $fixcolonbug ) { tmpdir_fix_colon_bug( $sync ) } ; |
| 1378 | |
| 1379 | $modulesversion and myprint( "Modules version list:\n", modulesversion(), "( use --no-modulesversion to turn off printing this Perl modules list )\n" ) ; |
| 1380 | |
| 1381 | |
| 1382 | check_lib_version( $sync ) or |
| 1383 | croak "imapsync needs perl lib Mail::IMAPClient release 3.30 or superior.\n"; |
| 1384 | |
| 1385 | |
| 1386 | exit_clean( $sync, $EX_OK ) if ( $justbanner ) ; |
| 1387 | |
| 1388 | # turn on RFC standard flags correction like \SEEN -> \Seen |
| 1389 | $flagscase = defined $flagscase ? $flagscase : 1 ; |
| 1390 | |
| 1391 | # Use PERMANENTFLAGS if available |
| 1392 | $filterflags = defined $filterflags ? $filterflags : 1 ; |
| 1393 | |
| 1394 | # sync flags just after an APPEND, some servers ignore the flags given in the APPEND |
| 1395 | # like MailEnable IMAP server. |
| 1396 | # Off by default since it takes time. |
| 1397 | $syncflagsaftercopy = defined $syncflagsaftercopy ? $syncflagsaftercopy : 0 ; |
| 1398 | |
| 1399 | # update flags on host2 for already transferred messages |
| 1400 | $sync->{resyncflags} = defined $sync->{resyncflags} ? $sync->{resyncflags} : 1 ; |
| 1401 | if ( $sync->{resyncflags} ) { |
| 1402 | myprint( "Info: will resync flags for already transferred messages. Use --noresyncflags to not resync flags.\n" ) ; |
| 1403 | }else{ |
| 1404 | myprint( "Info: will not resync flags for already transferred messages. Use --resyncflags to resync flags.\n" ) ; |
| 1405 | } |
| 1406 | |
| 1407 | |
| 1408 | sslcheck( $sync ) ; |
| 1409 | #print Data::Dumper->Dump( [ \$sync ] ) ; |
| 1410 | |
| 1411 | $split1 ||= $SPLIT ; |
| 1412 | $split2 ||= $SPLIT ; |
| 1413 | |
| 1414 | #$sync->{host1} || missing_option( $sync, '--host1' ) ; |
| 1415 | $sync->{port1} ||= ( $sync->{ssl1} ) ? $IMAP_SSL_PORT : $IMAP_PORT ; |
| 1416 | |
| 1417 | #$sync->{host2} || missing_option( $sync, '--host2' ) ; |
| 1418 | $sync->{port2} ||= ( $sync->{ssl2} ) ? $IMAP_SSL_PORT : $IMAP_PORT ; |
| 1419 | |
| 1420 | $debugimap1 = $debugimap2 = 1 if ( $debugimap ) ; |
| 1421 | $sync->{ debug } = 1 if ( $debugimap1 or $debugimap2 ) ; |
| 1422 | |
| 1423 | # By default, don't take size to compare |
| 1424 | $skipsize = (defined $skipsize) ? $skipsize : 1; |
| 1425 | |
| 1426 | $uid1 = defined $uid1 ? $uid1 : 1; |
| 1427 | $uid2 = defined $uid2 ? $uid2 : 1; |
| 1428 | |
| 1429 | $subscribe = defined $subscribe ? $subscribe : 1; |
| 1430 | |
| 1431 | # Allow size mismatch by default |
| 1432 | $allowsizemismatch = defined $allowsizemismatch ? $allowsizemismatch : 1; |
| 1433 | |
| 1434 | |
| 1435 | if ( defined $delete2foldersbutnot or defined $delete2foldersonly ) { |
| 1436 | $delete2folders = 1 ; |
| 1437 | } |
| 1438 | |
| 1439 | |
| 1440 | my %SSL_VERIFY_STR ; |
| 1441 | |
| 1442 | Readonly $SSL_VERIFY_POLICY => IO::Socket::SSL::SSL_VERIFY_NONE( ) ; |
| 1443 | Readonly %SSL_VERIFY_STR => ( |
| 1444 | IO::Socket::SSL::SSL_VERIFY_NONE( ) => 'SSL_VERIFY_NONE, ie, do not check the certificate server.' , |
| 1445 | IO::Socket::SSL::SSL_VERIFY_PEER( ) => 'SSL_VERIFY_PEER, ie, check the certificate server' , |
| 1446 | ) ; |
| 1447 | |
| 1448 | $IO::Socket::SSL::DEBUG = defined( $sync->{debugssl} ) ? $sync->{debugssl} : 1 ; |
| 1449 | |
| 1450 | |
| 1451 | if ( $sync->{ssl1} or $sync->{ssl2} or $sync->{tls1} or $sync->{tls2}) { |
| 1452 | myprint( "SSL debug mode level is --debugssl $IO::Socket::SSL::DEBUG (can be set from 0 meaning no debug to 4 meaning max debug)\n" ) ; |
| 1453 | } |
| 1454 | |
| 1455 | if ( $sync->{ssl1} ) { |
| 1456 | myprint( qq{Host1: SSL default mode is like --sslargs1 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host1 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ; |
| 1457 | myprint( 'Host1: Use --sslargs1 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host1\n" ) ; |
| 1458 | } |
| 1459 | |
| 1460 | if ( $sync->{ssl2} ) { |
| 1461 | myprint( qq{Host2: SSL default mode is like --sslargs2 "SSL_verify_mode=$SSL_VERIFY_POLICY", meaning for host2 $SSL_VERIFY_STR{$SSL_VERIFY_POLICY}\n} ) ; |
| 1462 | myprint( 'Host2: Use --sslargs2 SSL_verify_mode=' . IO::Socket::SSL::SSL_VERIFY_PEER( ) . " to have $SSL_VERIFY_STR{IO::Socket::SSL::SSL_VERIFY_PEER( )} of host2\n" ) ; |
| 1463 | } |
| 1464 | |
| 1465 | # ID on by default since 1.832 |
| 1466 | $sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ; |
| 1467 | |
| 1468 | if ( $sync->{justconnect} |
| 1469 | or not $sync->{user1} |
| 1470 | or not $sync->{user2} |
| 1471 | or not $sync->{host1} |
| 1472 | or not $sync->{host2} |
| 1473 | ) |
| 1474 | { |
| 1475 | my $justconnect = justconnect( $sync ) ; |
| 1476 | |
| 1477 | myprint( debugmemory( $sync, " after justconnect() call" ) ) ; |
| 1478 | exit_clean( $sync, $EX_OK, |
| 1479 | "Exiting after a justconnect on host(s): $justconnect\n" |
| 1480 | ) ; |
| 1481 | } |
| 1482 | |
| 1483 | |
| 1484 | #$sync->{user1} || missing_option( $sync, '--user1' ) ; |
| 1485 | #$sync->{user2} || missing_option( $sync, '--user2' ) ; |
| 1486 | |
| 1487 | $syncinternaldates = defined $syncinternaldates ? $syncinternaldates : 1; |
| 1488 | |
| 1489 | # Turn on expunge if there is not explicit option --noexpunge1 and option |
| 1490 | # --delete1 is given. |
| 1491 | # Done because --delete1 --noexpunge1 is very dangerous on the second run: |
| 1492 | # the Deleted flag is then synced to all previously transferred messages. |
| 1493 | # So --delete1 implies --expunge1 is a better usability default behavior. |
| 1494 | if ( $sync->{ delete1 } ) { |
| 1495 | if ( ! defined $sync->{ expunge1 } ) { |
| 1496 | myprint( "Info: turning on --expunge1 because --delete1 --noexpunge1 is very dangerous on the second run.\n" ) ; |
| 1497 | $sync->{ expunge1 } = 1 ; |
| 1498 | } |
| 1499 | myprint( "Info: if expunging after each message slows down too much the sync then use --noexpungeaftereach to speed up\n" ) ; |
| 1500 | } |
| 1501 | |
| 1502 | if ( $sync->{ uidexpunge2 } and not Mail::IMAPClient->can( 'uidexpunge' ) ) { |
| 1503 | myprint( "Failure: uidexpunge not supported (IMAPClient release < 3.17), use nothing or --expunge2 instead\n" ) ; |
| 1504 | $sync->{nb_errors}++ ; |
| 1505 | exit_clean( $sync, $EX_SOFTWARE ) ; |
| 1506 | } |
| 1507 | |
| 1508 | if ( ( $sync->{ delete2 } or $sync->{ delete2duplicates } ) and not defined $sync->{ uidexpunge2 } ) { |
| 1509 | if ( Mail::IMAPClient->can( 'uidexpunge' ) ) { |
| 1510 | myprint( "Info: will act as --uidexpunge2\n" ) ; |
| 1511 | $sync->{ uidexpunge2 } = 1 ; |
| 1512 | }elsif ( not defined $sync->{ expunge2 } ) { |
| 1513 | myprint( "Info: will act as --expunge2 (no uidexpunge support)\n" ) ; |
| 1514 | $sync->{ expunge2 } = 1 ; |
| 1515 | } |
| 1516 | } |
| 1517 | |
| 1518 | if ( $sync->{ delete1 } and $sync->{ delete2 } ) { |
| 1519 | myprint( "Warning: using --delete1 and --delete2 together is almost always a bad idea, exiting imapsync\n" ) ; |
| 1520 | $sync->{nb_errors}++ ; |
| 1521 | exit_clean( $sync, $EX_USAGE ) ; |
| 1522 | } |
| 1523 | |
| 1524 | if ( $idatefromheader ) { |
| 1525 | myprint( 'Turned ON idatefromheader, ', |
| 1526 | "will set the internal dates on host2 from the 'Date:' header line.\n" ) ; |
| 1527 | $syncinternaldates = 0 ; |
| 1528 | } |
| 1529 | |
| 1530 | if ( $syncinternaldates ) { |
| 1531 | myprint( 'Info: turned ON syncinternaldates, ', |
| 1532 | "will set the internal dates (arrival dates) on host2 same as host1.\n" ) ; |
| 1533 | }else{ |
| 1534 | myprint( "Info: turned OFF syncinternaldates\n" ) ; |
| 1535 | } |
| 1536 | |
| 1537 | if ( defined $authmd5 and $authmd5 ) { |
| 1538 | $authmd51 = 1 ; |
| 1539 | $authmd52 = 1 ; |
| 1540 | } |
| 1541 | |
| 1542 | if ( defined $authmd51 and $authmd51 ) { |
| 1543 | $authmech1 ||= 'CRAM-MD5'; |
| 1544 | } |
| 1545 | else{ |
| 1546 | $authmech1 ||= $authuser1 ? 'PLAIN' : 'LOGIN'; |
| 1547 | } |
| 1548 | |
| 1549 | if ( defined $authmd52 and $authmd52 ) { |
| 1550 | $authmech2 ||= 'CRAM-MD5'; |
| 1551 | } |
| 1552 | else{ |
| 1553 | $authmech2 ||= $authuser2 ? 'PLAIN' : 'LOGIN'; |
| 1554 | } |
| 1555 | |
| 1556 | $authmech1 = uc $authmech1; |
| 1557 | $authmech2 = uc $authmech2; |
| 1558 | |
| 1559 | if (defined $proxyauth1 && !$authuser1) { |
| 1560 | missing_option( $sync, 'With --proxyauth1, --authuser1' ) ; |
| 1561 | } |
| 1562 | |
| 1563 | if (defined $proxyauth2 && !$authuser2) { |
| 1564 | missing_option( $sync, 'With --proxyauth2, --authuser2' ) ; |
| 1565 | } |
| 1566 | |
| 1567 | #$authuser1 ||= $sync->{user1}; |
| 1568 | #$authuser2 ||= $sync->{user2}; |
| 1569 | |
| 1570 | myprint( "Host1: will try to use $authmech1 authentication on host1\n") ; |
| 1571 | myprint( "Host2: will try to use $authmech2 authentication on host2\n") ; |
| 1572 | |
| 1573 | $timeout = defined $timeout ? $timeout : $DEFAULT_TIMEOUT ; |
| 1574 | |
| 1575 | $sync->{h1}->{timeout} = defined $sync->{h1}->{timeout} ? $sync->{h1}->{timeout} : $timeout ; |
| 1576 | myprint( "Host1: imap connection timeout is $sync->{h1}->{timeout} seconds\n") ; |
| 1577 | $sync->{h2}->{timeout} = defined $sync->{h2}->{timeout} ? $sync->{h2}->{timeout} : $timeout ; |
| 1578 | myprint( "Host2: imap connection timeout is $sync->{h2}->{timeout} seconds\n" ) ; |
| 1579 | |
| 1580 | $syncacls = defined $syncacls ? $syncacls : 0 ; |
| 1581 | |
| 1582 | # No folders sizes if --justfolders, unless really wanted. |
| 1583 | if ( |
| 1584 | $sync->{ justfolders } |
| 1585 | and not defined $sync->{ foldersizes } |
| 1586 | and not $sync->{ justfoldersizes } ) |
| 1587 | { |
| 1588 | $sync->{ foldersizes } = 0 ; |
| 1589 | $sync->{ foldersizesatend } = 1 ; |
| 1590 | } |
| 1591 | |
| 1592 | $sync->{ foldersizes } = ( defined $sync->{ foldersizes } ) ? $sync->{ foldersizes } : 1 ; |
| 1593 | $sync->{ foldersizesatend } = ( defined $sync->{ foldersizesatend } ) ? $sync->{ foldersizesatend } : $sync->{ foldersizes } ; |
| 1594 | |
| 1595 | |
| 1596 | $fastio1 = defined $fastio1 ? $fastio1 : 0 ; |
| 1597 | $fastio2 = defined $fastio2 ? $fastio2 : 0 ; |
| 1598 | |
| 1599 | $reconnectretry1 = defined $reconnectretry1 ? $reconnectretry1 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; |
| 1600 | $reconnectretry2 = defined $reconnectretry2 ? $reconnectretry2 : $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; |
| 1601 | |
| 1602 | # Since select_msgs() returns no messages when uidnext does not return something |
| 1603 | # then $uidnext_default is never used. So I have to remove it. |
| 1604 | $uidnext_default = $DEFAULT_UIDNEXT ; |
| 1605 | |
| 1606 | if ( ! @useheader ) { @useheader = qw( Message-Id Received ) ; } |
| 1607 | |
| 1608 | # Make a hash %useheader of each --useheader 'key' in uppercase |
| 1609 | for ( @useheader ) { $useheader{ uc $_ } = undef } ; |
| 1610 | |
| 1611 | #myprint( Data::Dumper->Dump( [ \%useheader ] ) ) ; |
| 1612 | #exit ; |
| 1613 | |
| 1614 | myprint( "Host1: IMAP server [$sync->{host1}] port [$sync->{port1}] user [$sync->{user1}]\n" ) ; |
| 1615 | myprint( "Host2: IMAP server [$sync->{host2}] port [$sync->{port2}] user [$sync->{user2}]\n" ) ; |
| 1616 | |
| 1617 | get_password1( $sync ) ; |
| 1618 | get_password2( $sync ) ; |
| 1619 | |
| 1620 | |
| 1621 | $sync->{dry_message} = q{} ; |
| 1622 | if( $sync->{dry} ) { |
| 1623 | $sync->{dry_message} = "\t(not really since --dry mode)" ; |
| 1624 | } |
| 1625 | |
| 1626 | $sync->{ search1 } ||= $search if ( $search ) ; |
| 1627 | $sync->{ search2 } ||= $search if ( $search ) ; |
| 1628 | |
| 1629 | if ( $disarmreadreceipts ) { |
| 1630 | push @regexmess, q{s{\A((?:[^\n]+\r\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims} ; |
| 1631 | } |
| 1632 | |
| 1633 | $pipemesscheck = ( defined $pipemesscheck ) ? $pipemesscheck : 1 ; |
| 1634 | |
| 1635 | if ( @pipemess and $pipemesscheck ) { |
| 1636 | myprint( 'Checking each --pipemess command, ' |
| 1637 | . join( q{, }, @pipemess ) |
| 1638 | . ", with an space string. ( Can avoid this check with --nopipemesscheck )\n" ) ; |
| 1639 | my $string = pipemess( q{ }, @pipemess ) ; |
| 1640 | # string undef means something was bad. |
| 1641 | if ( not ( defined $string ) ) { |
| 1642 | $sync->{nb_errors}++ ; |
| 1643 | exit_clean( $sync, $EX_USAGE, |
| 1644 | "Error: one of --pipemess command is bad, check it\n" |
| 1645 | ) ; |
| 1646 | } |
| 1647 | myprint( "Ok with each --pipemess @pipemess\n" ) ; |
| 1648 | } |
| 1649 | |
| 1650 | if ( $maxlinelengthcmd ) { |
| 1651 | myprint( "Checking --maxlinelengthcmd command, |
| 1652 | $maxlinelengthcmd, with an space string.\n" |
| 1653 | ) ; |
| 1654 | my $string = pipemess( q{ }, $maxlinelengthcmd ) ; |
| 1655 | # string undef means something was bad. |
| 1656 | if ( not ( defined $string ) ) { |
| 1657 | $sync->{nb_errors}++ ; |
| 1658 | exit_clean( $sync, $EX_USAGE, |
| 1659 | "Error: --maxlinelengthcmd command is bad, check it\n" |
| 1660 | ) ; |
| 1661 | } |
| 1662 | myprint( "Ok with --maxlinelengthcmd $maxlinelengthcmd\n" ) ; |
| 1663 | } |
| 1664 | |
| 1665 | if ( @regexmess ) { |
| 1666 | my $string = regexmess( q{ } ) ; |
| 1667 | myprint( "Checking each --regexmess command with an space string.\n" ) ; |
| 1668 | # string undef means one of the eval regex was bad. |
| 1669 | if ( not ( defined $string ) ) { |
| 1670 | #errors_incr( $sync, 'Warning: one of --regexmess option may be bad, check them' ) ; |
| 1671 | exit_clean( $sync, $EX_USAGE, |
| 1672 | "Error: one of --regexmess option is bad, check it\n" |
| 1673 | ) ; |
| 1674 | } |
| 1675 | myprint( "Ok with each --regexmess\n" ) ; |
| 1676 | } |
| 1677 | |
| 1678 | if ( @skipmess ) { |
| 1679 | myprint( "Checking each --skipmess command with an space string.\n" ) ; |
| 1680 | my $match = skipmess( q{ } ) ; |
| 1681 | # match undef means one of the eval regex was bad. |
| 1682 | if ( not ( defined $match ) ) { |
| 1683 | $sync->{nb_errors}++ ; |
| 1684 | exit_clean( $sync, $EX_USAGE, |
| 1685 | "Error: one of --skipmess option is bad, check it\n" |
| 1686 | ) ; |
| 1687 | } |
| 1688 | myprint( "Ok with each --skipmess\n" ) ; |
| 1689 | } |
| 1690 | |
| 1691 | if ( @regexflag ) { |
| 1692 | myprint( "Checking each --regexflag command with an space string.\n" ) ; |
| 1693 | my $string = flags_regex( q{ } ) ; |
| 1694 | # string undef means one of the eval regex was bad. |
| 1695 | if ( not ( defined $string ) ) { |
| 1696 | $sync->{nb_errors}++ ; |
| 1697 | exit_clean( $sync, $EX_USAGE, |
| 1698 | "Error: one of --regexflag option is bad, check it\n" |
| 1699 | ) ; |
| 1700 | } |
| 1701 | myprint( "Ok with each --regexflag\n" ) ; |
| 1702 | } |
| 1703 | |
| 1704 | $sync->{imap1} = login_imap( $sync->{host1}, $sync->{port1}, $sync->{user1}, $domain1, $sync->{password1}, |
| 1705 | $debugimap1, $sync->{h1}->{timeout}, $fastio1, $sync->{ssl1}, $sync->{tls1}, |
| 1706 | $authmech1, $authuser1, $reconnectretry1, |
| 1707 | $proxyauth1, $uid1, $split1, 'Host1', $sync->{h1}, $sync ) ; |
| 1708 | |
| 1709 | $sync->{imap2} = login_imap( $sync->{host2}, $sync->{port2}, $sync->{user2}, $domain2, $sync->{password2}, |
| 1710 | $debugimap2, $sync->{h2}->{timeout}, $fastio2, $sync->{ssl2}, $sync->{tls2}, |
| 1711 | $authmech2, $authuser2, $reconnectretry2, |
| 1712 | $proxyauth2, $uid2, $split2, 'Host2', $sync->{h2}, $sync ) ; |
| 1713 | |
| 1714 | |
| 1715 | $sync->{ debug } and myprint( 'Host1 Buffer I/O: ', $sync->{imap1}->Buffer(), "\n" ) ; |
| 1716 | $sync->{ debug } and myprint( 'Host2 Buffer I/O: ', $sync->{imap2}->Buffer(), "\n" ) ; |
| 1717 | |
| 1718 | |
| 1719 | if ( ! $sync->{imap1}->IsAuthenticated( ) ) |
| 1720 | { |
| 1721 | $sync->{nb_errors}++ ; |
| 1722 | exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Not authenticated on host1\n" ) ; |
| 1723 | } |
| 1724 | myprint( "Host1: state Authenticated\n" ) ; |
| 1725 | |
| 1726 | if ( ! $sync->{imap2}->IsAuthenticated( ) ) |
| 1727 | { |
| 1728 | $sync->{nb_errors}++ ; |
| 1729 | exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, "Not authenticated on host2\n" ) ; |
| 1730 | } |
| 1731 | myprint( "Host2: state Authenticated\n" ) ; |
| 1732 | |
| 1733 | myprint( 'Host1 capability once authenticated: ', join(q{ }, @{ $sync->{imap1}->capability() || [] }), "\n" ) ; |
| 1734 | |
| 1735 | #myprint( Data::Dumper->Dump( [ $sync->{imap1} ] ) ) ; |
| 1736 | #myprint( "imap4rev1: " . $sync->{imap1}->imap4rev1() . "\n" ) ; |
| 1737 | |
| 1738 | myprint( 'Host2 capability once authenticated: ', join(q{ }, @{ $sync->{imap2}->capability() || [] }), "\n" ) ; |
| 1739 | |
| 1740 | imap_id_stuff( $sync ) ; |
| 1741 | |
| 1742 | #quota( $sync, $sync->{imap1}, 'h1' ) ; # quota on host1 is useless and pollute host2 output. |
| 1743 | quota( $sync, $sync->{imap2}, 'h2' ) ; |
| 1744 | |
| 1745 | maxsize_setting( $sync ) ; |
| 1746 | |
| 1747 | if ( $sync->{ justlogin } ) { |
| 1748 | $sync->{imap1}->logout( ) ; |
| 1749 | $sync->{imap2}->logout( ) ; |
| 1750 | exit_clean( $sync, $EX_OK, "Exiting because of --justlogin\n" ) ; |
| 1751 | } |
| 1752 | |
| 1753 | |
| 1754 | # |
| 1755 | # Folder stuff |
| 1756 | # |
| 1757 | |
| 1758 | $h1_folders_wanted_nb = 0 ; # counter of folders to be done. |
| 1759 | $h1_folders_wanted_ct = 0 ; # counter of folders done. |
| 1760 | |
| 1761 | # All folders on host1 and host2 |
| 1762 | |
| 1763 | @h1_folders_all = sort $sync->{imap1}->folders( ) ; |
| 1764 | @h2_folders_all = sort $sync->{imap2}->folders( ) ; |
| 1765 | |
| 1766 | myprint( 'Host1: found ', scalar @h1_folders_all , " folders.\n" ) ; |
| 1767 | myprint( 'Host2: found ', scalar @h2_folders_all , " folders.\n" ) ; |
| 1768 | |
| 1769 | foreach my $f ( @h1_folders_all ) |
| 1770 | { |
| 1771 | $h1_folders_all{ $f } = 1 |
| 1772 | } |
| 1773 | |
| 1774 | foreach my $f ( @h2_folders_all ) |
| 1775 | { |
| 1776 | $h2_folders_all{ $f } = 1 ; |
| 1777 | $sync->{h2_folders_all_UPPER}{ uc $f } = 1 ; |
| 1778 | } |
| 1779 | |
| 1780 | $sync->{h1_folders_all} = \%h1_folders_all ; |
| 1781 | $sync->{h2_folders_all} = \%h2_folders_all ; |
| 1782 | |
| 1783 | |
| 1784 | private_folders_separators_and_prefixes( ) ; |
| 1785 | |
| 1786 | |
| 1787 | # Make a hash of subscribed folders in both servers. |
| 1788 | |
| 1789 | for ( $sync->{imap1}->subscribed( ) ) { $h1_subscribed_folder{ $_ } = 1 } ; |
| 1790 | for ( $sync->{imap2}->subscribed( ) ) { $h2_subscribed_folder{ $_ } = 1 } ; |
| 1791 | |
| 1792 | |
| 1793 | if ( defined $sync->{ subfolder1 } ) { |
| 1794 | subfolder1( $sync ) ; |
| 1795 | } |
| 1796 | |
| 1797 | |
| 1798 | |
| 1799 | |
| 1800 | if ( defined $sync->{ subfolder2 } ) { |
| 1801 | subfolder2( $sync ) ; |
| 1802 | } |
| 1803 | |
| 1804 | if ( $fixInboxINBOX and ( my $reg = fix_Inbox_INBOX_mapping( \%h1_folders_all, \%h2_folders_all ) ) ) { |
| 1805 | push @{ $sync->{ regextrans2 } }, $reg ; |
| 1806 | } |
| 1807 | |
| 1808 | |
| 1809 | |
| 1810 | if ( ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) |
| 1811 | or $subscribed |
| 1812 | or scalar @folderrec ) |
| 1813 | { |
| 1814 | # folders given by option --folder |
| 1815 | if ( $sync->{ folder } and scalar @{ $sync->{ folder } } ) { |
| 1816 | add_to_requested_folders( @{ $sync->{ folder } } ) ; |
| 1817 | } |
| 1818 | |
| 1819 | # option --subscribed |
| 1820 | if ( $subscribed ) { |
| 1821 | add_to_requested_folders( keys %h1_subscribed_folder ) ; |
| 1822 | } |
| 1823 | |
| 1824 | # option --folderrec |
| 1825 | if ( scalar @folderrec ) { |
| 1826 | foreach my $folderrec ( @folderrec ) { |
| 1827 | add_to_requested_folders( $sync->{imap1}->folders( $folderrec ) ) ; |
| 1828 | } |
| 1829 | } |
| 1830 | } |
| 1831 | else |
| 1832 | { |
| 1833 | # no include, no folder/subscribed/folderrec options => all folders |
| 1834 | if ( not scalar @include ) { |
| 1835 | myprint( "Including all folders found by default. Use --subscribed or --folder or --folderrec or --include to select specific folders. Use --exclude to unselect specific folders.\n" ) ; |
| 1836 | add_to_requested_folders( @h1_folders_all ) ; |
| 1837 | } |
| 1838 | } |
| 1839 | |
| 1840 | |
| 1841 | # consider (optional) includes and excludes |
| 1842 | if ( scalar @include ) { |
| 1843 | foreach my $include ( @include ) { |
| 1844 | # No, do not add /x after the regex, never. |
| 1845 | # Users would kill you! |
| 1846 | my @included_folders = grep { /$include/ } @h1_folders_all ; |
| 1847 | add_to_requested_folders( @included_folders ) ; |
| 1848 | myprint( "Including folders matching pattern $include\n" . jux_utf8_list( @included_folders ) . "\n" ) ; |
| 1849 | } |
| 1850 | } |
| 1851 | |
| 1852 | if ( scalar @exclude ) { |
| 1853 | foreach my $exclude ( @exclude ) { |
| 1854 | my @requested_folder = sort keys %requested_folder ; |
| 1855 | # No, do not add /x after the regex, never. |
| 1856 | # Users would kill you! |
| 1857 | my @excluded_folders = grep { /$exclude/ } @requested_folder ; |
| 1858 | remove_from_requested_folders( @excluded_folders ) ; |
| 1859 | myprint( "Excluding folders matching pattern $exclude\n" . jux_utf8_list( @excluded_folders ) . "\n" ) ; |
| 1860 | } |
| 1861 | } |
| 1862 | |
| 1863 | |
| 1864 | # sort before is not very powerful |
| 1865 | # it adds --folderfirst and --folderlast even if they don't exist on host1 |
| 1866 | #@h1_folders_wanted = sort_requested_folders( ) ; |
| 1867 | $sync->{h1_folders_wanted} = [ sort_requested_folders( ) ] ; |
| 1868 | |
| 1869 | # Remove no selectable folders |
| 1870 | |
| 1871 | |
| 1872 | if ( $sync->{ checkfoldersexist } ) { |
| 1873 | my @h1_folders_wanted_exist ; |
| 1874 | myprint( "Host1: Checking wanted folders exist. Use --nocheckfoldersexist to avoid this check (shared of public namespace targeted).\n" ) ; |
| 1875 | foreach my $folder ( @{ $sync->{h1_folders_wanted} } ) { |
| 1876 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder exists on host1\n" ) ; |
| 1877 | if ( ! exists $h1_folders_all{ $folder } ) { |
| 1878 | myprint( "Host1: warning! ignoring folder $folder because it is not in host1 whole folders list.\n" ) ; |
| 1879 | next ; |
| 1880 | }else{ |
| 1881 | push @h1_folders_wanted_exist, $folder ; |
| 1882 | } |
| 1883 | } |
| 1884 | @{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_exist ; |
| 1885 | }else{ |
| 1886 | myprint( "Host1: Not checking that wanted folders exist. Remove --nocheckfoldersexist to get this check.\n" ) ; |
| 1887 | } |
| 1888 | |
| 1889 | |
| 1890 | if ( $sync->{ checkselectable } ) { |
| 1891 | my @h1_folders_wanted_selectable ; |
| 1892 | myprint( "Host1: Checking wanted folders are selectable. Use --nocheckselectable to avoid this check.\n" ) ; |
| 1893 | foreach my $folder ( @{ $sync->{h1_folders_wanted} } ) { |
| 1894 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Checking $folder is selectable on host1\n" ) ; |
| 1895 | # It does an imap command LIST "" $folder and then search for no \Noselect |
| 1896 | if ( ! $sync->{imap1}->selectable( $folder ) ) { |
| 1897 | myprint( "Host1: warning! ignoring folder $folder because it is not selectable\n" ) ; |
| 1898 | }else{ |
| 1899 | push @h1_folders_wanted_selectable, $folder ; |
| 1900 | } |
| 1901 | } |
| 1902 | @{ $sync->{h1_folders_wanted} } = @h1_folders_wanted_selectable ; |
| 1903 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Host1: checking folders took ', timenext( $sync ), " s\n" ) ; |
| 1904 | }else{ |
| 1905 | myprint( "Host1: Not checking that wanted folders are selectable. Remove --nocheckselectable to get this check.\n" ) ; |
| 1906 | } |
| 1907 | |
| 1908 | |
| 1909 | |
| 1910 | # Old place of private_folders_separators_and_prefixes( ) call. |
| 1911 | #private_folders_separators_and_prefixes( ) ; |
| 1912 | |
| 1913 | |
| 1914 | # this hack is because LWP post does not pass well a hash in the $form parameter |
| 1915 | # but it does pass well an array |
| 1916 | %{ $sync->{f1f2h} } = split_around_equal( @{ $sync->{f1f2} } ) ; |
| 1917 | |
| 1918 | automap( $sync ) ; |
| 1919 | |
| 1920 | |
| 1921 | foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) { |
| 1922 | my $h2_fold ; |
| 1923 | $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; |
| 1924 | $h2_folders_from_1_wanted{ $h2_fold }++ ; |
| 1925 | if ( 1 < $h2_folders_from_1_wanted{ $h2_fold } ) { |
| 1926 | $h2_folders_from_1_several{ $h2_fold }++ ; |
| 1927 | } |
| 1928 | } |
| 1929 | |
| 1930 | @h2_folders_from_1_wanted = sort keys %h2_folders_from_1_wanted; |
| 1931 | |
| 1932 | |
| 1933 | foreach my $h1_fold ( @h1_folders_all ) { |
| 1934 | my $h2_fold ; |
| 1935 | $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; |
| 1936 | $h2_folders_from_1_all{ $h2_fold }++ ; |
| 1937 | # Follows a fix to avoid deleting folder $sync->{ subfolder2 } |
| 1938 | # because it usually does not exist on host1. |
| 1939 | if ( $sync->{ subfolder2 } ) |
| 1940 | { |
| 1941 | $h2_folders_from_1_all{ $sync->{ h2_prefix } . $sync->{ subfolder2 } }++ ; |
| 1942 | $h2_folders_from_1_all{ $sync->{ subfolder2 } }++ ; |
| 1943 | } |
| 1944 | } |
| 1945 | |
| 1946 | |
| 1947 | |
| 1948 | myprint( << 'END_LISTING' ) ; |
| 1949 | |
| 1950 | ++++ Listing folders |
| 1951 | All foldernames are presented between brackets like [X] where X is the foldername. |
| 1952 | When a foldername contains non-ASCII characters it is presented in the form |
| 1953 | [X] = [Y] where |
| 1954 | X is the imap foldername you have to use in command line options and |
| 1955 | Y is the utf8 output just printed for convenience, to recognize it. |
| 1956 | |
| 1957 | END_LISTING |
| 1958 | |
| 1959 | myprint( |
| 1960 | "Host1: folders list (first the raw imap format then the [X] = [Y]):\n", |
| 1961 | $sync->{imap1}->list( ), |
| 1962 | "\n", |
| 1963 | jux_utf8_list( @h1_folders_all ), |
| 1964 | "\n", |
| 1965 | "Host2: folders list (first the raw imap format then the [X] = [Y]):\n", |
| 1966 | $sync->{imap2}->list( ), |
| 1967 | "\n", |
| 1968 | jux_utf8_list( @h2_folders_all ), |
| 1969 | "\n", |
| 1970 | q{} |
| 1971 | ) ; |
| 1972 | |
| 1973 | if ( $subscribed ) { |
| 1974 | myprint( |
| 1975 | 'Host1 subscribed folders list: ', |
| 1976 | jux_utf8_list( sort keys %h1_subscribed_folder ), "\n", |
| 1977 | ) ; |
| 1978 | } |
| 1979 | |
| 1980 | |
| 1981 | |
| 1982 | @h2_folders_not_in_1 = list_folders_in_2_not_in_1( ) ; |
| 1983 | |
| 1984 | if ( @h2_folders_not_in_1 ) { |
| 1985 | myprint( "Folders in host2 not in host1:\n", |
| 1986 | jux_utf8_list( @h2_folders_not_in_1 ), "\n" ) ; |
| 1987 | } |
| 1988 | |
| 1989 | |
| 1990 | if ( keys %{ $sync->{f1f2auto} } ) { |
| 1991 | myprint( "Folders mapping from --automap feature (use --f1f2 to override any mapping):\n" ) ; |
| 1992 | foreach my $h1_fold ( keys %{ $sync->{f1f2auto} } ) { |
| 1993 | my $h2_fold = $sync->{f1f2auto}{$h1_fold} ; |
| 1994 | myprintf( "%-40s -> %-40s\n", |
| 1995 | jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ; |
| 1996 | } |
| 1997 | myprint( "\n" ) ; |
| 1998 | } |
| 1999 | |
| 2000 | if ( keys %{ $sync->{f1f2h} } ) { |
| 2001 | myprint( "Folders mapping from --f1f2 options, it overrides --automap:\n" ) ; |
| 2002 | foreach my $h1_fold ( keys %{ $sync->{f1f2h} } ) { |
| 2003 | my $h2_fold = $sync->{f1f2h}{$h1_fold} ; |
| 2004 | my $warn = q{} ; |
| 2005 | if ( not exists $h1_folders_all{ $h1_fold } ) { |
| 2006 | $warn = "BUT $h1_fold does NOT exist on host1!" ; |
| 2007 | } |
| 2008 | myprintf( "%-40s -> %-40s %s\n", |
| 2009 | jux_utf8( $h1_fold ), jux_utf8( $h2_fold ), $warn ) ; |
| 2010 | } |
| 2011 | myprint( "\n" ) ; |
| 2012 | } |
| 2013 | |
| 2014 | exit_clean( $sync, $EX_OK, "Exiting because of --justfolderlists\n" ) if ( $sync->{ justfolderlists } ) ; |
| 2015 | exit_clean( $sync, $EX_OK, "Exiting because of --justautomap\n" ) if ( $sync->{ justautomap } ) ; |
| 2016 | |
| 2017 | debugsleep( $sync ) ; |
| 2018 | |
| 2019 | if ( $sync->{ skipemptyfolders } ) |
| 2020 | { |
| 2021 | myprint( "Host1: will not syncing empty folders on host1. Use --noskipemptyfolders to create them anyway on host2\n") ; |
| 2022 | } |
| 2023 | |
| 2024 | |
| 2025 | if ( $sync->{ foldersizes } ) { |
| 2026 | |
| 2027 | foldersizes_at_the_beggining( $sync ) ; |
| 2028 | #foldersizes_at_the_beggining_old( $sync ) ; |
| 2029 | } |
| 2030 | |
| 2031 | |
| 2032 | |
| 2033 | if ( $sync->{ justfoldersizes } ) |
| 2034 | { |
| 2035 | exit_clean( $sync, $EX_OK, "Exiting because of --justfoldersizes\n" ) ; |
| 2036 | } |
| 2037 | |
| 2038 | $sync->{stats} = 1 ; |
| 2039 | |
| 2040 | if ( $sync->{ delete1emptyfolders } ) { |
| 2041 | delete1emptyfolders( $sync ) ; |
| 2042 | } |
| 2043 | |
| 2044 | delete_folders_in_2_not_in_1( ) if $delete2folders ; |
| 2045 | |
| 2046 | # folder loop |
| 2047 | $h1_folders_wanted_nb = scalar @{ $sync->{h1_folders_wanted} } ; |
| 2048 | |
| 2049 | myprint( "++++ Looping on each one of $h1_folders_wanted_nb folders to sync\n" ) ; |
| 2050 | |
| 2051 | $sync->{begin_transfer_time} = time ; |
| 2052 | |
| 2053 | my %uid_candidate_for_deletion ; |
| 2054 | my %uid_candidate_no_deletion ; |
| 2055 | |
| 2056 | $sync->{ h2_folders_of_md5 } = { } ; |
| 2057 | |
| 2058 | |
| 2059 | FOLDER: foreach my $h1_fold ( @{ $sync->{h1_folders_wanted} } ) |
| 2060 | { |
| 2061 | $sync->{ h1_current_folder } = $h1_fold ; |
| 2062 | eta_print( $sync ) ; |
| 2063 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2064 | |
| 2065 | my $h2_fold = imap2_folder_name( $sync, $h1_fold ) ; |
| 2066 | $sync->{ h2_current_folder } = $h2_fold ; |
| 2067 | |
| 2068 | $h1_folders_wanted_ct++ ; |
| 2069 | myprintf( "Folder %7s %-35s -> %-35s\n", "$h1_folders_wanted_ct/$h1_folders_wanted_nb", |
| 2070 | jux_utf8( $h1_fold ), jux_utf8( $h2_fold ) ) ; |
| 2071 | myprint( debugmemory( $sync, " at folder loop" ) ) ; |
| 2072 | |
| 2073 | # host1 can not be fetched read only, select is needed because of expunge. |
| 2074 | select_folder( $sync, $sync->{imap1}, $h1_fold, 'Host1' ) or next FOLDER ; |
| 2075 | |
| 2076 | debugsleep( $sync ) ; |
| 2077 | |
| 2078 | my $h1_fold_nb_messages = count_from_select( $sync->{imap1}->History ) ; |
| 2079 | myprint( "Host1: folder [$h1_fold] has $h1_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ; |
| 2080 | |
| 2081 | if ( $sync->{ skipemptyfolders } and 0 == $h1_fold_nb_messages ) { |
| 2082 | myprint( "Host1: skipping empty host1 folder [$h1_fold]\n" ) ; |
| 2083 | next FOLDER ; |
| 2084 | } |
| 2085 | |
| 2086 | # Code added from https://github.com/imapsync/imapsync/issues/95 |
| 2087 | # Thanks jh1995 |
| 2088 | # Goal: do not create folder if --search or --max/minage return 0 message. |
| 2089 | # even if there are messages by SELECT (no not real empty, empty for the user point of vue). |
| 2090 | if ( $sync->{ skipemptyfolders } ) |
| 2091 | { |
| 2092 | my $h1_msgs_all_hash_ref_tmp = { } ; |
| 2093 | my @h1_msgs_tmp = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref_tmp, $sync->{ search1 }, $h1_fold ) ; |
| 2094 | my $h1_fold_nb_messages_tmp = scalar( @h1_msgs_tmp ) ; |
| 2095 | if ( 0 == $h1_fold_nb_messages_tmp ) { |
| 2096 | myprint( "Host1: skipping empty host1 folder [$h1_fold] (0 message found by SEARCH)\n" ) ; |
| 2097 | next FOLDER ; |
| 2098 | } |
| 2099 | } |
| 2100 | |
| 2101 | if ( ! exists $h2_folders_all{ $h2_fold } ) { |
| 2102 | create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) or next FOLDER ; |
| 2103 | } |
| 2104 | |
| 2105 | acls_sync( $h1_fold, $h2_fold ) ; |
| 2106 | |
| 2107 | # Sometimes the folder on host2 is listed (it exists) but is |
| 2108 | # not selectable but becomes selectable by a create (Gmail) |
| 2109 | select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) |
| 2110 | or ( create_folder( $sync, $sync->{imap2}, $h2_fold, $h1_fold ) |
| 2111 | and select_folder( $sync, $sync->{imap2}, $h2_fold, 'Host2' ) ) |
| 2112 | or next FOLDER ; |
| 2113 | my @select_results = $sync->{imap2}->Results( ) ; |
| 2114 | |
| 2115 | my $h2_fold_nb_messages = count_from_select( @select_results ) ; |
| 2116 | myprint( "Host2: folder [$h2_fold] has $h2_fold_nb_messages messages in total (mentioned by SELECT)\n" ) ; |
| 2117 | |
| 2118 | my $permanentflags2 = permanentflags( @select_results ) ; |
| 2119 | myprint( "Host2: folder [$h2_fold] permanentflags: $permanentflags2\n" ) ; |
| 2120 | |
| 2121 | if ( $sync->{ expunge1 } ) |
| 2122 | { |
| 2123 | myprint( "Host1: Expunging $h1_fold $sync->{dry_message}\n" ) ; |
| 2124 | if ( ! $sync->{dry} ) |
| 2125 | { |
| 2126 | $sync->{imap1}->expunge( ) ; |
| 2127 | } |
| 2128 | } |
| 2129 | |
| 2130 | if ( ( ( $subscribe and exists $h1_subscribed_folder{ $h1_fold } ) or $subscribeall ) |
| 2131 | and not exists $h2_subscribed_folder{ $h2_fold } ) |
| 2132 | { |
| 2133 | myprint( "Host2: Subscribing to folder $h2_fold\n" ) ; |
| 2134 | if ( ! $sync->{dry} ) { $sync->{imap2}->subscribe( $h2_fold ) } ; |
| 2135 | } |
| 2136 | |
| 2137 | next FOLDER if ( $sync->{ justfolders } ) ; |
| 2138 | |
| 2139 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2140 | |
| 2141 | my $h1_msgs_all_hash_ref = { } ; |
| 2142 | my @h1_msgs = select_msgs( $sync->{imap1}, $h1_msgs_all_hash_ref, $sync->{ search1 }, $sync->{abletosearch1}, $h1_fold ); |
| 2143 | |
| 2144 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2145 | |
| 2146 | my $h1_msgs_nb = scalar @h1_msgs ; |
| 2147 | |
| 2148 | myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages\n" ) ; |
| 2149 | ( $sync->{ debug } or $debuglist ) and myprint( "Host1: folder [$h1_fold] considering $h1_msgs_nb messages, LIST gives: @h1_msgs\n" ) ; |
| 2150 | $sync->{ debug } and myprint( "Host1: selecting messages of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ; |
| 2151 | |
| 2152 | my $h2_msgs_all_hash_ref = { } ; |
| 2153 | my @h2_msgs = select_msgs( $sync->{imap2}, $h2_msgs_all_hash_ref, $sync->{ search2 }, $sync->{abletosearch2}, $h2_fold ) ; |
| 2154 | |
| 2155 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2156 | |
| 2157 | my $h2_msgs_nb = scalar @h2_msgs ; |
| 2158 | |
| 2159 | myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages\n" ) ; |
| 2160 | ( $sync->{ debug } or $debuglist ) and myprint( "Host2: folder [$h2_fold] considering $h2_msgs_nb messages, LIST gives: @h2_msgs\n" ) ; |
| 2161 | $sync->{ debug } and myprint( "Host2: selecting messages of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ; |
| 2162 | |
| 2163 | my $cache_base = "$sync->{ tmpdir }/imapsync_cache/" ; |
| 2164 | my $cache_dir = cache_folder( $cache_base, |
| 2165 | "$sync->{host1}/$sync->{user1}/$sync->{host2}/$sync->{user2}", $h1_fold, $h2_fold ) ; |
| 2166 | my ( $cache_1_2_ref, $cache_2_1_ref ) = ( {}, {} ) ; |
| 2167 | |
| 2168 | my $h1_uidvalidity = $sync->{imap1}->uidvalidity( ) || q{} ; |
| 2169 | my $h2_uidvalidity = $sync->{imap2}->uidvalidity( ) || q{} ; |
| 2170 | |
| 2171 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2172 | |
| 2173 | if ( $usecache ) { |
| 2174 | myprint( "Local cache directory: $cache_dir ( " . length( $cache_dir ) . " characters long )\n" ) ; |
| 2175 | mkpath( "$cache_dir" ) ; |
| 2176 | ( $cache_1_2_ref, $cache_2_1_ref ) |
| 2177 | = get_cache( $cache_dir, \@h1_msgs, \@h2_msgs, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; |
| 2178 | myprint( 'CACHE h1 h2: ', scalar keys %{ $cache_1_2_ref } , " files\n" ) ; |
| 2179 | $sync->{ debug } and myprint( '[', |
| 2180 | map ( { "$_->$cache_1_2_ref->{$_} " } keys %{ $cache_1_2_ref } ), " ]\n" ) ; |
| 2181 | } |
| 2182 | |
| 2183 | my %h1_hash = ( ) ; |
| 2184 | my %h2_hash = ( ) ; |
| 2185 | |
| 2186 | my ( %h1_msgs, %h2_msgs ) ; |
| 2187 | @h1_msgs{ @h1_msgs } = ( ) ; |
| 2188 | @h2_msgs{ @h2_msgs } = ( ) ; |
| 2189 | |
| 2190 | my @h1_msgs_in_cache = sort { $a <=> $b } keys %{ $cache_1_2_ref } ; |
| 2191 | my @h2_msgs_in_cache = keys %{ $cache_2_1_ref } ; |
| 2192 | |
| 2193 | my ( %h1_msgs_not_in_cache, %h2_msgs_not_in_cache ) ; |
| 2194 | %h1_msgs_not_in_cache = %h1_msgs ; |
| 2195 | %h2_msgs_not_in_cache = %h2_msgs ; |
| 2196 | delete @h1_msgs_not_in_cache{ @h1_msgs_in_cache } ; |
| 2197 | delete @h2_msgs_not_in_cache{ @h2_msgs_in_cache } ; |
| 2198 | |
| 2199 | my @h1_msgs_not_in_cache = keys %h1_msgs_not_in_cache ; |
| 2200 | #myprint( "h1_msgs_not_in_cache: [@h1_msgs_not_in_cache]\n" ) ; |
| 2201 | my @h2_msgs_not_in_cache = keys %h2_msgs_not_in_cache ; |
| 2202 | |
| 2203 | my @h2_msgs_delete2_not_in_cache = () ; |
| 2204 | %h1_msgs_copy_by_uid = ( ) ; |
| 2205 | |
| 2206 | if ( $useuid ) { |
| 2207 | # use uid so we have to avoid getting header |
| 2208 | @h1_msgs_copy_by_uid{ @h1_msgs_not_in_cache } = ( ) ; |
| 2209 | @h2_msgs_delete2_not_in_cache = @h2_msgs_not_in_cache if $usecache ; |
| 2210 | @h1_msgs_not_in_cache = ( ) ; |
| 2211 | @h2_msgs_not_in_cache = ( ) ; |
| 2212 | |
| 2213 | #myprint( "delete2: @h2_msgs_delete2_not_in_cache\n" ) ; |
| 2214 | } |
| 2215 | |
| 2216 | $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold]\n" ) ; |
| 2217 | |
| 2218 | my ($h1_heads_ref, $h1_fir_ref) = ({}, {}); |
| 2219 | $h1_heads_ref = $sync->{imap1}->parse_headers([@h1_msgs_not_in_cache], @useheader) if (@h1_msgs_not_in_cache); |
| 2220 | $sync->{ debug } and myprint( "Host1: parsing headers of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ; |
| 2221 | |
| 2222 | @{ $h1_fir_ref }{@h1_msgs} = ( undef ) ; |
| 2223 | |
| 2224 | $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold]\n" ) ; |
| 2225 | |
| 2226 | my @h1_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ; |
| 2227 | if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h1_common_fetch_param, 'X-GM-LABELS' ; } |
| 2228 | |
| 2229 | if ( $sync->{abletosearch1} ) |
| 2230 | { |
| 2231 | $h1_fir_ref = $sync->{imap1}->fetch_hash( \@h1_msgs, @h1_common_fetch_param, $h1_fir_ref ) |
| 2232 | if ( @h1_msgs ) ; |
| 2233 | } |
| 2234 | else |
| 2235 | { |
| 2236 | my $uidnext = $sync->{imap1}->uidnext( $h1_fold ) || $uidnext_default ; |
| 2237 | my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; |
| 2238 | $h1_fir_ref = $sync->{imap1}->fetch_hash( $fetch_hash_uids, @h1_common_fetch_param, $h1_fir_ref ) |
| 2239 | if ( @h1_msgs ) ; |
| 2240 | } |
| 2241 | |
| 2242 | $sync->{ debug } and myprint( "Host1: getting flags idate and sizes of folder [$h1_fold] took ", timenext( $sync ), " s\n" ) ; |
| 2243 | if ( ! $h1_fir_ref ) |
| 2244 | { |
| 2245 | my $error = join( q{}, "Host1: folder $h1_fold : Could not fetch_hash ", |
| 2246 | scalar @h1_msgs, ' msgs: ', $sync->{imap1}->LastError || q{}, "\n" ) ; |
| 2247 | errors_incr( $sync, $error ) ; |
| 2248 | next FOLDER ; |
| 2249 | } |
| 2250 | |
| 2251 | my @h1_msgs_duplicate; |
| 2252 | foreach my $m ( @h1_msgs_not_in_cache ) |
| 2253 | { |
| 2254 | my $rc = parse_header_msg( $sync, $sync->{imap1}, $m, $h1_heads_ref, $h1_fir_ref, 'Host1', \%h1_hash ) ; |
| 2255 | if ( ! defined $rc ) |
| 2256 | { |
| 2257 | my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; |
| 2258 | myprint( "Host1: $h1_fold/$m size $h1_size ignored (no wanted headers so we ignore this message. To solve this: use --addheader)\n" ) ; |
| 2259 | $sync->{ total_bytes_skipped } += $h1_size ; |
| 2260 | $sync->{ nb_msg_skipped } += 1 ; |
| 2261 | $sync->{ h1_nb_msg_noheader } +=1 ; |
| 2262 | $sync->{ h1_nb_msg_processed } +=1 ; |
| 2263 | } elsif(0 == $rc) |
| 2264 | { |
| 2265 | # duplicate |
| 2266 | push @h1_msgs_duplicate, $m; |
| 2267 | # duplicate, same id same size? |
| 2268 | my $h1_size = $h1_fir_ref->{$m}->{'RFC822.SIZE'} || 0; |
| 2269 | $sync->{ nb_msg_skipped } += 1; |
| 2270 | $h1_nb_msg_duplicate += 1; |
| 2271 | $sync->{ h1_nb_msg_processed } +=1 ; |
| 2272 | } |
| 2273 | } |
| 2274 | my $h1_msgs_duplicate_nb = scalar @h1_msgs_duplicate ; |
| 2275 | |
| 2276 | myprint( "Host1: folder [$h1_fold] selected $h1_msgs_nb messages, duplicates $h1_msgs_duplicate_nb\n" ) ; |
| 2277 | |
| 2278 | $sync->{ debug } and myprint( 'Host1: whole time parsing headers took ', timenext( $sync ), " s\n" ) ; |
| 2279 | # Getting headers and metada can be so long that host2 might be disconnected here |
| 2280 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2281 | |
| 2282 | |
| 2283 | $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold]\n" ) ; |
| 2284 | |
| 2285 | my ($h2_heads_ref, $h2_fir_ref) = ( {}, {} ); |
| 2286 | $h2_heads_ref = $sync->{imap2}->parse_headers([@h2_msgs_not_in_cache], @useheader) if (@h2_msgs_not_in_cache); |
| 2287 | $sync->{ debug } and myprint( "Host2: parsing headers of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ; |
| 2288 | |
| 2289 | $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold]\n" ) ; |
| 2290 | @{ $h2_fir_ref }{@h2_msgs} = ( ); # fetch_hash can select by uid with last arg as ref |
| 2291 | |
| 2292 | |
| 2293 | my @h2_common_fetch_param = ( 'FLAGS', 'INTERNALDATE', 'RFC822.SIZE' ) ; |
| 2294 | if ( $sync->{ synclabels } or $sync->{ resynclabels } ) { push @h2_common_fetch_param, 'X-GM-LABELS' ; } |
| 2295 | |
| 2296 | if ( $sync->{abletosearch2} and scalar( @h2_msgs ) ) { |
| 2297 | $h2_fir_ref = $sync->{imap2}->fetch_hash( \@h2_msgs, @h2_common_fetch_param, $h2_fir_ref) ; |
| 2298 | }else{ |
| 2299 | my $uidnext = $sync->{imap2}->uidnext( $h2_fold ) || $uidnext_default ; |
| 2300 | my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; |
| 2301 | $h2_fir_ref = $sync->{imap2}->fetch_hash( $fetch_hash_uids, @h2_common_fetch_param, $h2_fir_ref ) |
| 2302 | if ( @h2_msgs ) ; |
| 2303 | } |
| 2304 | |
| 2305 | $sync->{ debug } and myprint( "Host2: getting flags idate and sizes of folder [$h2_fold] took ", timenext( $sync ), " s\n" ) ; |
| 2306 | |
| 2307 | my @h2_msgs_duplicate; |
| 2308 | foreach my $m (@h2_msgs_not_in_cache) { |
| 2309 | my $rc = parse_header_msg( $sync, $sync->{imap2}, $m, $h2_heads_ref, $h2_fir_ref, 'Host2', \%h2_hash ) ; |
| 2310 | my $h2_size = $h2_fir_ref->{$m}->{'RFC822.SIZE'} || 0 ; |
| 2311 | if (! defined $rc ) { |
| 2312 | myprint( "Host2: $h2_fold/$m size $h2_size ignored (no wanted headers so we ignore this message)\n" ) ; |
| 2313 | $h2_nb_msg_noheader += 1 ; |
| 2314 | } elsif( 0 == $rc ) { |
| 2315 | # duplicate |
| 2316 | $h2_nb_msg_duplicate += 1 ; |
| 2317 | push @h2_msgs_duplicate, $m ; |
| 2318 | } |
| 2319 | } |
| 2320 | |
| 2321 | # %h2_folders_of_md5 |
| 2322 | foreach my $md5 ( keys %h2_hash ) { |
| 2323 | $sync->{ h2_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ; |
| 2324 | } |
| 2325 | # %h1_folders_of_md5 |
| 2326 | foreach my $md5 ( keys %h1_hash ) { |
| 2327 | $sync->{ h1_folders_of_md5 }->{ $md5 }->{ $h2_fold } ++ ; |
| 2328 | } |
| 2329 | |
| 2330 | |
| 2331 | my $h2_msgs_duplicate_nb = scalar @h2_msgs_duplicate ; |
| 2332 | |
| 2333 | myprint( "Host2: folder [$h2_fold] selected $h2_msgs_nb messages, duplicates $h2_msgs_duplicate_nb\n" ) ; |
| 2334 | |
| 2335 | $sync->{ debug } and myprint( 'Host2 whole time parsing headers took ', timenext( $sync ), " s\n" ) ; |
| 2336 | |
| 2337 | $sync->{ debug } and myprint( "++++ Verifying [$h1_fold] -> [$h2_fold]\n" ) ; |
| 2338 | # messages in host1 that are not in host2 |
| 2339 | |
| 2340 | my @h1_hash_keys_sorted_by_uid |
| 2341 | = sort {$h1_hash{$a}{'m'} <=> $h1_hash{$b}{'m'}} keys %h1_hash; |
| 2342 | |
| 2343 | #myprint( map { $h1_hash{$_}{'m'} . q{ }} @h1_hash_keys_sorted_by_uid ) ; |
| 2344 | |
| 2345 | my @h2_hash_keys_sorted_by_uid |
| 2346 | = sort {$h2_hash{$a}{'m'} <=> $h2_hash{$b}{'m'}} keys %h2_hash; |
| 2347 | |
| 2348 | # Deletions on account2. |
| 2349 | |
| 2350 | if( $sync->{ delete2duplicates } and not exists $h2_folders_from_1_several{ $h2_fold } ) { |
| 2351 | my @h2_expunge ; |
| 2352 | |
| 2353 | foreach my $h2_msg ( @h2_msgs_duplicate ) { |
| 2354 | myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [duplicate] on host2 $sync->{dry_message}\n" ) ; |
| 2355 | push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ; |
| 2356 | if ( ! $sync->{dry} ) { |
| 2357 | $sync->{imap2}->delete_message( $h2_msg ) ; |
| 2358 | $h2_nb_msg_deleted += 1 ; |
| 2359 | } |
| 2360 | } |
| 2361 | my $cnt = scalar @h2_expunge ; |
| 2362 | if( @h2_expunge and not $sync->{ expunge2 } ) { |
| 2363 | myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; |
| 2364 | $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; |
| 2365 | } |
| 2366 | if ( $sync->{ expunge2 } ){ |
| 2367 | myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; |
| 2368 | $sync->{imap2}->expunge( ) if ! $sync->{dry} ; |
| 2369 | } |
| 2370 | } |
| 2371 | |
| 2372 | if( $sync->{ delete2 } and not exists $h2_folders_from_1_several{ $h2_fold } ) { |
| 2373 | # No host1 folders f1a f1b ... going all to same f2 (via --regextrans2) |
| 2374 | my @h2_expunge; |
| 2375 | foreach my $m_id (@h2_hash_keys_sorted_by_uid) { |
| 2376 | #myprint( "$m_id " ) ; |
| 2377 | if ( ! exists $h1_hash{$m_id} ) { |
| 2378 | my $h2_msg = $h2_hash{$m_id}{'m'}; |
| 2379 | my $h2_flags = $h2_hash{$m_id}{'F'} || q{}; |
| 2380 | my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0; |
| 2381 | myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted on host2 [$m_id] $sync->{dry_message}\n" ) |
| 2382 | if ! $isdel; |
| 2383 | push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 }; |
| 2384 | if ( ! ( $sync->{dry} or $isdel ) ) { |
| 2385 | $sync->{imap2}->delete_message($h2_msg); |
| 2386 | $h2_nb_msg_deleted += 1; |
| 2387 | } |
| 2388 | } |
| 2389 | } |
| 2390 | foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { |
| 2391 | myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted [not in cache] on host2 $sync->{dry_message}\n" ) ; |
| 2392 | push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 }; |
| 2393 | if ( ! $sync->{dry} ) { |
| 2394 | $sync->{imap2}->delete_message($h2_msg); |
| 2395 | $h2_nb_msg_deleted += 1; |
| 2396 | } |
| 2397 | } |
| 2398 | my $cnt = scalar @h2_expunge ; |
| 2399 | |
| 2400 | if( @h2_expunge and not $sync->{ expunge2 } ) { |
| 2401 | myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; |
| 2402 | $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; |
| 2403 | } |
| 2404 | if ( $sync->{ expunge2 } ) { |
| 2405 | myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; |
| 2406 | $sync->{imap2}->expunge( ) if ! $sync->{dry} ; |
| 2407 | } |
| 2408 | } |
| 2409 | |
| 2410 | if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } ) { |
| 2411 | myprint( "Host2: folder $h2_fold $h2_folders_from_1_several{ $h2_fold } folders left to sync there\n" ) ; |
| 2412 | my @h2_expunge; |
| 2413 | foreach my $m_id ( @h2_hash_keys_sorted_by_uid ) { |
| 2414 | my $h2_msg = $h2_hash{ $m_id }{ 'm' } ; |
| 2415 | if ( ! exists $h1_hash{ $m_id } ) { |
| 2416 | my $h2_flags = $h2_hash{ $m_id }{ 'F' } || q{} ; |
| 2417 | my $isdel = $h2_flags =~ /\B\\Deleted\b/x ? 1 : 0 ; |
| 2418 | if ( ! $isdel ) { |
| 2419 | $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [$m_id]\n" ) ; |
| 2420 | $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; |
| 2421 | } |
| 2422 | }else{ |
| 2423 | $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [$m_id]\n" ) ; |
| 2424 | $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; |
| 2425 | } |
| 2426 | } |
| 2427 | foreach my $h2_msg ( @h2_msgs_delete2_not_in_cache ) { |
| 2428 | myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion [not in cache]\n" ) ; |
| 2429 | $uid_candidate_for_deletion{ $h2_fold }{ $h2_msg }++ ; |
| 2430 | } |
| 2431 | |
| 2432 | foreach my $h2_msg ( @h2_msgs_in_cache ) { |
| 2433 | myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [in cache]\n" ) ; |
| 2434 | $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; |
| 2435 | } |
| 2436 | |
| 2437 | |
| 2438 | if ( 0 == $h2_folders_from_1_several{ $h2_fold } ) { |
| 2439 | # last host1 folder going to $h2_fold |
| 2440 | myprint( "Last host1 folder going to $h2_fold\n" ) ; |
| 2441 | foreach my $h2_msg ( keys %{ $uid_candidate_for_deletion{ $h2_fold } } ) { |
| 2442 | $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg candidate for deletion\n" ) ; |
| 2443 | if ( exists $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg } ) { |
| 2444 | $sync->{ debug } and myprint( "Host2: msg $h2_fold/$h2_msg canceled deletion\n" ) ; |
| 2445 | }else{ |
| 2446 | myprint( "Host2: msg $h2_fold/$h2_msg marked \\Deleted $sync->{dry_message}\n" ) ; |
| 2447 | push @h2_expunge, $h2_msg if $sync->{ uidexpunge2 } ; |
| 2448 | if ( ! $sync->{dry} ) { |
| 2449 | $sync->{imap2}->delete_message( $h2_msg ) ; |
| 2450 | $h2_nb_msg_deleted += 1 ; |
| 2451 | } |
| 2452 | } |
| 2453 | } |
| 2454 | } |
| 2455 | |
| 2456 | my $cnt = scalar @h2_expunge ; |
| 2457 | if( @h2_expunge and not $sync->{ expunge2 } ) { |
| 2458 | myprint( "Host2: UidExpunging $cnt message(s) in folder $h2_fold $sync->{dry_message}\n" ) ; |
| 2459 | $sync->{imap2}->uidexpunge( \@h2_expunge ) if ! $sync->{dry} ; |
| 2460 | } |
| 2461 | if ( $sync->{ expunge2 } ) { |
| 2462 | myprint( "Host2: Expunging host2 folder $h2_fold $sync->{dry_message}\n" ) ; |
| 2463 | $sync->{imap2}->expunge( ) if ! $sync->{dry} ; |
| 2464 | } |
| 2465 | |
| 2466 | $h2_folders_from_1_several{ $h2_fold }-- ; |
| 2467 | } |
| 2468 | |
| 2469 | my $h2_uidnext = $sync->{imap2}->uidnext( $h2_fold ) ; |
| 2470 | $sync->{ debug } and myprint( "Host2: uidnext is $h2_uidnext\n" ) ; |
| 2471 | $h2_uidguess = $h2_uidnext ; |
| 2472 | |
| 2473 | # Getting host2 headers, metada and delete2 stuff can be so long that host1 might be disconnected here |
| 2474 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2475 | |
| 2476 | my @h1_msgs_to_delete ; |
| 2477 | MESS: foreach my $m_id (@h1_hash_keys_sorted_by_uid) { |
| 2478 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2479 | |
| 2480 | #myprint( "h1_nb_msg_processed: $sync->{ h1_nb_msg_processed }\n" ) ; |
| 2481 | my $h1_size = $h1_hash{$m_id}{'s'}; |
| 2482 | my $h1_msg = $h1_hash{$m_id}{'m'}; |
| 2483 | my $h1_idate = $h1_hash{$m_id}{'D'}; |
| 2484 | |
| 2485 | #my $labels = labels( $sync->{imap1}, $h1_msg ) ; |
| 2486 | #print "LABELS: $labels\n" ; |
| 2487 | |
| 2488 | if ( ( not exists $h2_hash{ $m_id } ) |
| 2489 | and ( not ( exists $sync->{ h2_folders_of_md5 }->{ $m_id } ) |
| 2490 | or not $skipcrossduplicates ) ) |
| 2491 | { |
| 2492 | # copy |
| 2493 | my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; |
| 2494 | if ( $h2_msg and $sync->{ delete1 } and not $sync->{ expungeaftereach } ) { |
| 2495 | # not expunged |
| 2496 | push @h1_msgs_to_delete, $h1_msg ; |
| 2497 | } |
| 2498 | |
| 2499 | # A bug here with imapsync 1.920, fixed in 1.921 |
| 2500 | # Added $h2_msg in the condition. Errors of APPEND were not counted as missing messages on host2! |
| 2501 | if ( $h2_msg and not $sync->{ dry } ) |
| 2502 | { |
| 2503 | $sync->{ h2_folders_of_md5 }->{ $m_id }->{ $h2_fold } ++ ; |
| 2504 | } |
| 2505 | |
| 2506 | # |
| 2507 | if( $sync->{ delete2 } and ( exists $h2_folders_from_1_several{ $h2_fold } ) and $h2_msg ) { |
| 2508 | myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ; |
| 2509 | $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; |
| 2510 | } |
| 2511 | |
| 2512 | if ( total_bytes_max_reached( $sync ) ) { |
| 2513 | # a bug when using --delete1 --noexpungeaftereach |
| 2514 | # same thing below on all total_bytes_max_reached! |
| 2515 | last FOLDER ; |
| 2516 | } |
| 2517 | next MESS; |
| 2518 | } |
| 2519 | else |
| 2520 | { |
| 2521 | # already on host2 |
| 2522 | if ( exists $h2_hash{ $m_id } ) |
| 2523 | { |
| 2524 | my $h2_msg = $h2_hash{$m_id}{'m'} ; |
| 2525 | $sync->{ debug } and myprint( "Host1: found that msg $h1_fold/$h1_msg equals Host2 $h2_fold/$h2_msg\n" ) ; |
| 2526 | if ( $usecache ) |
| 2527 | { |
| 2528 | $debugcache and myprint( "touch $cache_dir/${h1_msg}_$h2_msg\n" ) ; |
| 2529 | touch( "$cache_dir/${h1_msg}_$h2_msg" ) |
| 2530 | or croak( "Couldn't touch $cache_dir/${h1_msg}_$h2_msg" ) ; |
| 2531 | } |
| 2532 | } |
| 2533 | elsif( exists $sync->{ h2_folders_of_md5 }->{ $m_id } ) |
| 2534 | { |
| 2535 | my @folders_dup = keys %{ $sync->{ h2_folders_of_md5 }->{ $m_id } } ; |
| 2536 | ( $sync->{ debug } or $debugcrossduplicates ) and myprint( "Host1: found that msg $h1_fold/$h1_msg is also in Host2 folders @folders_dup\n" ) ; |
| 2537 | $sync->{ h2_nb_msg_crossdup } +=1 ; |
| 2538 | } |
| 2539 | $sync->{ total_bytes_skipped } += $h1_size ; |
| 2540 | $sync->{ nb_msg_skipped } += 1 ; |
| 2541 | $sync->{ h1_nb_msg_processed } +=1 ; |
| 2542 | } |
| 2543 | |
| 2544 | if ( exists $h2_hash{ $m_id } ) { |
| 2545 | #$debug and myprint( "MESSAGE $m_id\n" ) ; |
| 2546 | my $h2_msg = $h2_hash{$m_id}{'m'}; |
| 2547 | if ( $sync->{resyncflags} ) { |
| 2548 | sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; |
| 2549 | } |
| 2550 | # Good |
| 2551 | my $h2_size = $h2_hash{$m_id}{'s'}; |
| 2552 | $sync->{ debug } and myprint( |
| 2553 | "Host1: size msg $h1_fold/$h1_msg = $h1_size <> $h2_size = Host2 $h2_fold/$h2_msg\n" ) ; |
| 2554 | |
| 2555 | if ( $sync->{ resynclabels } ) |
| 2556 | { |
| 2557 | resynclabels( $sync, $h1_msg, $h2_msg, $h1_fir_ref, $h2_fir_ref, $h1_fold ) |
| 2558 | } |
| 2559 | } |
| 2560 | |
| 2561 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2562 | |
| 2563 | if ( $sync->{ delete1 } ) { |
| 2564 | push @h1_msgs_to_delete, $h1_msg ; |
| 2565 | } |
| 2566 | } |
| 2567 | # END MESS: loop |
| 2568 | |
| 2569 | delete_message_on_host1( $sync, $h1_fold, $sync->{ expunge1 }, @h1_msgs_to_delete, @h1_msgs_in_cache ) ; |
| 2570 | |
| 2571 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2572 | |
| 2573 | # MESS_IN_CACHE: |
| 2574 | if ( ! $sync->{ delete1 } ) |
| 2575 | { |
| 2576 | foreach my $h1_msg ( @h1_msgs_in_cache ) |
| 2577 | { |
| 2578 | my $h2_msg = $cache_1_2_ref->{ $h1_msg } ; |
| 2579 | $debugcache and myprint( "cache messages update flags $h1_msg->$h2_msg\n" ) ; |
| 2580 | if ( $sync->{resyncflags} ) |
| 2581 | { |
| 2582 | sync_flags_fir( $sync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) ; |
| 2583 | } |
| 2584 | my $h1_size = $h1_fir_ref->{ $h1_msg }->{ 'RFC822.SIZE' } || 0 ; |
| 2585 | $sync->{ total_bytes_skipped } += $h1_size; |
| 2586 | $sync->{ nb_msg_skipped } += 1; |
| 2587 | $sync->{ h1_nb_msg_processed } +=1 ; |
| 2588 | } |
| 2589 | } |
| 2590 | |
| 2591 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2592 | |
| 2593 | @h1_msgs_to_delete = ( ) ; |
| 2594 | #myprint( "Messages by uid: ", map { "$_ " } keys %h1_msgs_copy_by_uid, "\n" ) ; |
| 2595 | # MESS_BY_UID: |
| 2596 | foreach my $h1_msg ( sort { $a <=> $b } keys %h1_msgs_copy_by_uid ) |
| 2597 | { |
| 2598 | $sync->{ debug } and myprint( "Copy by uid $h1_fold/$h1_msg\n" ) ; |
| 2599 | if ( ! reconnect_12_if_needed( $sync ) ) { last FOLDER ; } |
| 2600 | |
| 2601 | my $h2_msg = copy_message( $sync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) ; |
| 2602 | if( $sync->{ delete2 } and exists $h2_folders_from_1_several{ $h2_fold } and $h2_msg ) { |
| 2603 | myprint( "Host2: msg $h2_fold/$h2_msg will cancel deletion [fresh copy] on host2\n" ) ; |
| 2604 | $uid_candidate_no_deletion{ $h2_fold }{ $h2_msg }++ ; |
| 2605 | } |
| 2606 | last FOLDER if total_bytes_max_reached( $sync ) ; |
| 2607 | } |
| 2608 | |
| 2609 | if ( $sync->{ expunge1 } ){ |
| 2610 | myprint( "Host1: Expunging folder $h1_fold $sync->{dry_message}\n" ) ; |
| 2611 | if ( ! $sync->{dry} ) { $sync->{imap1}->expunge( ) } ; |
| 2612 | } |
| 2613 | if ( $sync->{ expunge2 } ){ |
| 2614 | myprint( "Host2: Expunging folder $h2_fold $sync->{dry_message}\n" ) ; |
| 2615 | if ( ! $sync->{dry} ) { $sync->{imap2}->expunge( ) } ; |
| 2616 | } |
| 2617 | $sync->{ debug } and myprint( 'Time: ', timenext( $sync ), " s\n" ) ; |
| 2618 | } |
| 2619 | |
| 2620 | eta_print( $sync ) ; |
| 2621 | |
| 2622 | myprint( "++++ End looping on each folder\n" ) ; |
| 2623 | |
| 2624 | if ( $sync->{ delete1 } and $sync->{ delete1emptyfolders } ) { |
| 2625 | delete1emptyfolders( $sync ) ; |
| 2626 | } |
| 2627 | |
| 2628 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( 'Time: ', timenext( $sync ), " s\n" ) ; |
| 2629 | |
| 2630 | |
| 2631 | if ( $sync->{ foldersizesatend } ) { |
| 2632 | myprint( << 'END_SIZE' ) ; |
| 2633 | |
| 2634 | Folders sizes after the synchronization. |
| 2635 | You can remove this foldersizes listing by using "--nofoldersizesatend" |
| 2636 | END_SIZE |
| 2637 | |
| 2638 | foldersizesatend( $sync ) ; |
| 2639 | } |
| 2640 | |
| 2641 | if ( ! lost_connection( $sync, $sync->{imap1}, "for host1 [$sync->{host1}]" ) ) { $sync->{imap1}->logout( ) ; } |
| 2642 | if ( ! lost_connection( $sync, $sync->{imap2}, "for host2 [$sync->{host2}]" ) ) { $sync->{imap2}->logout( ) ; } |
| 2643 | |
| 2644 | stats( $sync ) ; |
| 2645 | myprint( errorsdump( $sync->{nb_errors}, errors_log( $sync ) ) ) if ( $sync->{errorsdump} ) ; |
| 2646 | tests_live_result( $sync->{nb_errors} ) if ( $sync->{testslive} or $sync->{testslive6} ) ; |
| 2647 | |
| 2648 | |
| 2649 | |
| 2650 | if ( $sync->{nb_errors} ) |
| 2651 | { |
| 2652 | exit_clean( $sync, $EXIT_WITH_ERRORS ) ; |
| 2653 | } |
| 2654 | else |
| 2655 | { |
| 2656 | exit_clean( $sync, $EX_OK ) ; |
| 2657 | } |
| 2658 | |
| 2659 | return ; |
| 2660 | } |
| 2661 | |
| 2662 | # END of sub single_sync |
| 2663 | |
| 2664 | |
| 2665 | # subroutines |
| 2666 | sub myprint |
| 2667 | { |
| 2668 | #print @ARG ; |
| 2669 | print { $sync->{ tee } || \*STDOUT } @ARG ; |
| 2670 | return ; |
| 2671 | } |
| 2672 | |
| 2673 | sub myprintf |
| 2674 | { |
| 2675 | printf { $sync->{ tee } || \*STDOUT } @ARG ; |
| 2676 | return ; |
| 2677 | } |
| 2678 | |
| 2679 | sub mysprintf |
| 2680 | { |
| 2681 | my( $format, @list ) = @ARG ; |
| 2682 | return sprintf $format, @list ; |
| 2683 | } |
| 2684 | |
| 2685 | sub output_start |
| 2686 | { |
| 2687 | my $mysync = shift @ARG ; |
| 2688 | |
| 2689 | if ( not $mysync ) { return ; } |
| 2690 | |
| 2691 | my @output = @ARG ; |
| 2692 | $mysync->{ output } = join( q{}, @output ) . ( $mysync->{ output } || q{} ) ; |
| 2693 | return $mysync->{ output } ; |
| 2694 | } |
| 2695 | |
| 2696 | |
| 2697 | sub tests_output_start |
| 2698 | { |
| 2699 | note( 'Entering tests_output_start()' ) ; |
| 2700 | |
| 2701 | my $mysync = { } ; |
| 2702 | |
| 2703 | is( undef, output_start( ), 'output_start: no args => undef' ) ; |
| 2704 | is( q{}, output_start( $mysync ), 'output_start: one arg => ""' ) ; |
| 2705 | is( 'rrrr', output_start( $mysync, 'rrrr' ), 'output_start: rrrr => rrrr' ) ; |
| 2706 | is( 'aaaarrrr', output_start( $mysync, 'aaaa' ), 'output_start: aaaa => aaaarrrr' ) ; |
| 2707 | is( "\naaaarrrr", output_start( $mysync, "\n" ), 'output_start: \n => \naaaarrrr' ) ; |
| 2708 | is( "ABC\naaaarrrr", output_start( $mysync, 'A', 'B', 'C' ), 'output_start: A B C => ABC\naaaarrrr' ) ; |
| 2709 | |
| 2710 | note( 'Leaving tests_output_start()' ) ; |
| 2711 | return ; |
| 2712 | } |
| 2713 | |
| 2714 | sub tests_output |
| 2715 | { |
| 2716 | note( 'Entering tests_output()' ) ; |
| 2717 | |
| 2718 | my $mysync = { } ; |
| 2719 | |
| 2720 | is( undef, output( ), 'output: no args => undef' ) ; |
| 2721 | is( q{}, output( $mysync ), 'output: one arg => ""' ) ; |
| 2722 | is( 'rrrr', output( $mysync, 'rrrr' ), 'output: rrrr => rrrr' ) ; |
| 2723 | is( 'rrrraaaa', output( $mysync, 'aaaa' ), 'output: aaaa => rrrraaaa' ) ; |
| 2724 | is( "rrrraaaa\n", output( $mysync, "\n" ), 'output: \n => rrrraaaa\n' ) ; |
| 2725 | is( "rrrraaaa\nABC", output( $mysync, 'A', 'B', 'C' ), 'output: A B C => rrrraaaaABC\n' ) ; |
| 2726 | |
| 2727 | note( 'Leaving tests_output()' ) ; |
| 2728 | return ; |
| 2729 | } |
| 2730 | |
| 2731 | sub output |
| 2732 | { |
| 2733 | my $mysync = shift @ARG ; |
| 2734 | |
| 2735 | if ( not $mysync ) { return ; } |
| 2736 | |
| 2737 | my @output = @ARG ; |
| 2738 | $mysync->{ output } .= join( q{}, @output ) ; |
| 2739 | return $mysync->{ output } ; |
| 2740 | } |
| 2741 | |
| 2742 | |
| 2743 | |
| 2744 | sub tests_output_reset_with |
| 2745 | { |
| 2746 | note( 'Entering tests_output_reset_with()' ) ; |
| 2747 | |
| 2748 | my $mysync = { } ; |
| 2749 | |
| 2750 | is( undef, output_reset_with( ), 'output_reset_with: no args => undef' ) ; |
| 2751 | is( q{}, output_reset_with( $mysync ), 'output_reset_with: one arg => ""' ) ; |
| 2752 | is( 'rrrr', output_reset_with( $mysync, 'rrrr' ), 'output_reset_with: rrrr => rrrr' ) ; |
| 2753 | is( 'aaaa', output_reset_with( $mysync, 'aaaa' ), 'output_reset_with: aaaa => aaaa' ) ; |
| 2754 | is( "\n", output_reset_with( $mysync, "\n" ), 'output_reset_with: \n => \n' ) ; |
| 2755 | |
| 2756 | note( 'Leaving tests_output_reset_with()' ) ; |
| 2757 | return ; |
| 2758 | } |
| 2759 | |
| 2760 | sub output_reset_with |
| 2761 | { |
| 2762 | my $mysync = shift @ARG ; |
| 2763 | |
| 2764 | if ( not $mysync ) { return ; } |
| 2765 | |
| 2766 | my @output = @ARG ; |
| 2767 | $mysync->{ output } = join( q{}, @output ) ; |
| 2768 | return $mysync->{ output } ; |
| 2769 | } |
| 2770 | |
| 2771 | sub pidfile |
| 2772 | { |
| 2773 | my $mysync = shift ; |
| 2774 | |
| 2775 | $mysync->{ pidfilelocking } = defined $mysync->{ pidfilelocking } ? $mysync->{ pidfilelocking } : 0 ; |
| 2776 | |
| 2777 | my $host1 = $mysync->{ host1 } || q{} ; |
| 2778 | my $user1 = $mysync->{ user1 } || q{} ; |
| 2779 | my $host2 = $mysync->{ host2 } || q{} ; |
| 2780 | my $user2 = $mysync->{ user2 } || q{} ; |
| 2781 | |
| 2782 | my $account1_filtered = filter_forbidden_characters( slash_to_underscore( $host1 . '_' . $user1 ) ) || q{} ; |
| 2783 | my $account2_filtered = filter_forbidden_characters( slash_to_underscore( $host2 . '_' . $user2 ) ) || q{} ; |
| 2784 | |
| 2785 | my $pidfile_basename ; |
| 2786 | |
| 2787 | if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) ) |
| 2788 | { |
| 2789 | # under local webserver |
| 2790 | $pidfile_basename = 'imapsync' . '_' . $account1_filtered . '_' . $account2_filtered . '.pid' ; |
| 2791 | } |
| 2792 | else |
| 2793 | { |
| 2794 | $pidfile_basename = 'imapsync.pid' ; |
| 2795 | } |
| 2796 | |
| 2797 | $mysync->{ pidfile } = defined $mysync->{ pidfile } ? $mysync-> { pidfile } : $mysync->{ tmpdir } . "/$pidfile_basename" ; |
| 2798 | return ; |
| 2799 | } |
| 2800 | |
| 2801 | |
| 2802 | sub tests_kill_zero |
| 2803 | { |
| 2804 | note( 'Entering tests_kill_zero()' ) ; |
| 2805 | |
| 2806 | |
| 2807 | |
| 2808 | SKIP: { |
| 2809 | if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_kill_zero avoided on Windows', 8 ) ; } |
| 2810 | |
| 2811 | |
| 2812 | is( 1, kill( 'ZERO', $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID => 1" ) ; |
| 2813 | is( 2, kill( 'ZERO', $PROCESS_ID, $PROCESS_ID ), "kill ZERO : myself $PROCESS_ID $PROCESS_ID => 2" ) ; |
| 2814 | |
| 2815 | if ( (-e '/.dockerenv' ) or ( 0 == $EFFECTIVE_USER_ID) ) |
| 2816 | { |
| 2817 | is( 1, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 1 (docker context or root)" ) ; |
| 2818 | is( 2, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 2 (docker context or root)" ) ; |
| 2819 | } |
| 2820 | else |
| 2821 | { |
| 2822 | is( 0, kill( 'ZERO', 1 ), "kill ZERO : pid 1 => 0 (non root)" ) ; |
| 2823 | is( 1, kill( 'ZERO', $PROCESS_ID, 1 ), "kill ZERO : myself + pid 1, $PROCESS_ID 1 => 1 (one is non root)" ) ; |
| 2824 | |
| 2825 | } |
| 2826 | |
| 2827 | |
| 2828 | my $pid_1 = fork( ) ; |
| 2829 | if ( $pid_1 ) |
| 2830 | { |
| 2831 | # parent |
| 2832 | } |
| 2833 | else |
| 2834 | { |
| 2835 | # child |
| 2836 | sleep 3 ; |
| 2837 | exit ; |
| 2838 | } |
| 2839 | |
| 2840 | my $pid_2 ; |
| 2841 | $pid_2 = fork( ) ; |
| 2842 | if ( $pid_2 ) |
| 2843 | { |
| 2844 | # I am the parent |
| 2845 | ok( defined( $pid_2 ), "kill_zero: initial fork ok. I am the parent $PROCESS_ID" ) ; |
| 2846 | ok( $pid_2 , "kill_zero: initial fork ok, child pid is $pid_2" ) ; |
| 2847 | is( 3, kill( 'ZERO', $PROCESS_ID, $pid_2, $pid_1 ), "kill ZERO : myself $PROCESS_ID and child $pid_2 and brother $pid_1 => 3" ) ; |
| 2848 | |
| 2849 | is( $pid_2, waitpid( $pid_2, 0 ), "kill_zero: child $pid_2 no more there => waitpid return $pid_2" ) ; |
| 2850 | } |
| 2851 | else |
| 2852 | { |
| 2853 | # I am the child |
| 2854 | note( 'This one fails under Windows, kill ZERO returns 0 instead of 2' ) ; |
| 2855 | is( 2, kill( 'ZERO', $PROCESS_ID, $pid_1 ), "kill ZERO : myself child $PROCESS_ID brother $pid_1 => 2" ) ; |
| 2856 | myprint( "I am the child pid $PROCESS_ID, Exiting\n" ) ; |
| 2857 | exit ; |
| 2858 | } |
| 2859 | wait( ) ; |
| 2860 | |
| 2861 | # End of SKIP block |
| 2862 | } |
| 2863 | |
| 2864 | note( 'Leaving tests_kill_zero()' ) ; |
| 2865 | return ; |
| 2866 | } |
| 2867 | |
| 2868 | |
| 2869 | |
| 2870 | |
| 2871 | sub tests_killpid_by_parent |
| 2872 | { |
| 2873 | note( 'Entering tests_killpid_by_parent()' ) ; |
| 2874 | |
| 2875 | SKIP: { |
| 2876 | if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_killpid_by_parent avoided on Windows', 7 ) ; } |
| 2877 | |
| 2878 | is( undef, killpid( ), 'killpid: no args => undef' ) ; |
| 2879 | note( "killpid: trying to kill myself pid $PROCESS_ID, hope I will not succeed" ) ; |
| 2880 | is( undef, killpid( $PROCESS_ID ), 'killpid: myself => undef' ) ; |
| 2881 | |
| 2882 | local $SIG{'QUIT'} = sub { myprint "GOT SIG QUIT! I am PID $PROCESS_ID. Exiting\n" ; exit ; } ; |
| 2883 | |
| 2884 | my $pid ; |
| 2885 | $pid = fork( ) ; |
| 2886 | if ( $pid ) |
| 2887 | { |
| 2888 | # I am the parent |
| 2889 | ok( defined( $pid ), "killpid: initial fork ok. I am the parent $PROCESS_ID" ) ; |
| 2890 | ok( $pid , "killpid: initial fork ok, child pid is $pid" ) ; |
| 2891 | |
| 2892 | is( 2, kill( 'ZERO', $PROCESS_ID, $pid ), "kill ZERO : myself $PROCESS_ID and child $pid => 2" ) ; |
| 2893 | is( 1, killpid( $pid ), "killpid: child $pid killed => 1" ) ; |
| 2894 | is( -1, waitpid( $pid, 0 ), "killpid: child $pid no more there => waitpid return -1" ) ; |
| 2895 | } |
| 2896 | else |
| 2897 | { |
| 2898 | # I am the child |
| 2899 | myprint( "I am the child pid $PROCESS_ID, sleeping 1 + 3 seconds then kill myself\n" ) ; |
| 2900 | sleep 1 ; |
| 2901 | myprint( "I am the child pid $PROCESS_ID, slept 1 second, should be killed by my parent now, PPID " . mygetppid( ) . "\n" ) ; |
| 2902 | sleep 3 ; |
| 2903 | # this test should not be run. If it happens => failure. |
| 2904 | ok( 0 == 1, "killpid: child pid $PROCESS_ID not dead => failure" ) ; |
| 2905 | myprint( "I am the child pid $PROCESS_ID, killing myself failure... Exiting\n" ) ; |
| 2906 | exit ; |
| 2907 | } |
| 2908 | |
| 2909 | # End of SKIP block |
| 2910 | } |
| 2911 | note( 'Leaving tests_killpid_by_parent()' ) ; |
| 2912 | return ; |
| 2913 | } |
| 2914 | |
| 2915 | sub tests_killpid_by_brother |
| 2916 | { |
| 2917 | note( 'Entering tests_killpid_by_brother()' ) ; |
| 2918 | |
| 2919 | |
| 2920 | SKIP: { |
| 2921 | if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests tests_killpid_by_brother avoided on Windows', 2 ) ; } |
| 2922 | |
| 2923 | local $SIG{'QUIT'} = sub { myprint "GOT SIG QUIT! I am PID $PROCESS_ID. Exiting\n" ; exit ; } ; |
| 2924 | |
| 2925 | my $pid_parent = $PROCESS_ID ; |
| 2926 | myprint( "I am the parent pid $pid_parent\n" ) ; |
| 2927 | my $pid_1 = fork( ) ; |
| 2928 | if ( $pid_1 ) |
| 2929 | { |
| 2930 | # parent |
| 2931 | } |
| 2932 | else |
| 2933 | { |
| 2934 | # child |
| 2935 | #while ( 1 ) { } ; |
| 2936 | sleep 2 ; |
| 2937 | sleep 2 ; |
| 2938 | # this test should not be run. If it happens => failure. |
| 2939 | # Well under Windows this always fails, shit! |
| 2940 | ok( 0 == 1 or ( 'MSWin32' eq $OSNAME ) , "killpid: child pid $PROCESS_ID killing by brother but not dead => failure" ) ; |
| 2941 | myprint( "I am the child pid $PROCESS_ID, killing by brother failed... Exiting\n" ) ; |
| 2942 | exit ; |
| 2943 | } |
| 2944 | |
| 2945 | my $pid_2 ; |
| 2946 | $pid_2 = fork( ) ; |
| 2947 | if ( $pid_2 ) |
| 2948 | { |
| 2949 | # parent |
| 2950 | } |
| 2951 | else |
| 2952 | { |
| 2953 | # I am the child |
| 2954 | myprint( "I am the child pid $PROCESS_ID, my brother has pid $pid_1\n" ) ; |
| 2955 | is( 1, killpid( $pid_1 ), "killpid: brother $pid_1 killed => 1" ) ; |
| 2956 | sleep 2 ; |
| 2957 | exit ; |
| 2958 | } |
| 2959 | |
| 2960 | #sleep 1 ; |
| 2961 | is( $pid_1, waitpid( $pid_1, 0), "I am the parent $PROCESS_ID waitpid _1( $pid_1 )" ) ; |
| 2962 | is( $pid_2, waitpid( $pid_2, 0 ), "I am the parent $PROCESS_ID waitpid _2( $pid_2 )" ) ; |
| 2963 | |
| 2964 | |
| 2965 | # End of SKIP block |
| 2966 | } |
| 2967 | |
| 2968 | note( 'Leaving tests_killpid_by_brother()' ) ; |
| 2969 | return ; |
| 2970 | } |
| 2971 | |
| 2972 | |
| 2973 | sub killpid |
| 2974 | { |
| 2975 | my $pidtokill = shift ; |
| 2976 | |
| 2977 | if ( ! $pidtokill ) { |
| 2978 | myprint( "No process to abort.\n" ) ; |
| 2979 | return ; |
| 2980 | } |
| 2981 | |
| 2982 | if ( $PROCESS_ID == $pidtokill ) { |
| 2983 | myprint( "I will not kill myself pid $PROCESS_ID via killpid. Sractch it!\n" ) ; |
| 2984 | return ; |
| 2985 | } |
| 2986 | |
| 2987 | |
| 2988 | # First ask for suicide |
| 2989 | if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) { |
| 2990 | myprint( "Sending signal QUIT to PID $pidtokill \n" ) ; |
| 2991 | kill 'QUIT', $pidtokill ; |
| 2992 | sleep 2 ; |
| 2993 | waitpid( $pidtokill, WNOHANG) ; |
| 2994 | }else{ |
| 2995 | myprint( "Can not send signal kill ZERO to PID $pidtokill.\n" ) ; |
| 2996 | return ; |
| 2997 | } |
| 2998 | |
| 2999 | #while ( waitpid( $pidtokill, WNOHANG) > 0 ) { } ; |
| 3000 | |
| 3001 | # Then murder |
| 3002 | if ( kill( 'ZERO', $pidtokill ) or ( 'MSWin32' eq $OSNAME ) ) { |
| 3003 | myprint( "Sending signal KILL to PID $pidtokill \n" ) ; |
| 3004 | kill 'KILL', $pidtokill ; |
| 3005 | sleep 1 ; |
| 3006 | waitpid( $pidtokill, WNOHANG) ; |
| 3007 | }else{ |
| 3008 | myprint( "Process PID $pidtokill ended.\n" ) ; |
| 3009 | return 1; |
| 3010 | } |
| 3011 | # Well ... |
| 3012 | if ( kill( 'ZERO', $pidtokill ) or ( 'xMSWin32' eq $OSNAME ) ) { |
| 3013 | myprint( "Process PID $pidtokill seems still there. Can not do much.\n" ) ; |
| 3014 | return ; |
| 3015 | }else{ |
| 3016 | myprint( "Process PID $pidtokill ended.\n" ) ; |
| 3017 | return 1; |
| 3018 | } |
| 3019 | |
| 3020 | return ; |
| 3021 | } |
| 3022 | |
| 3023 | sub tests_abort |
| 3024 | { |
| 3025 | note( 'Entering tests_abort()' ) ; |
| 3026 | |
| 3027 | is( undef, abort( ), 'abort: no args => undef' ) ; |
| 3028 | note( 'Leaving tests_abort()' ) ; |
| 3029 | return ; |
| 3030 | } |
| 3031 | |
| 3032 | |
| 3033 | |
| 3034 | |
| 3035 | sub abort |
| 3036 | { |
| 3037 | my $mysync = shift @ARG ; |
| 3038 | |
| 3039 | if ( not $mysync ) { return ; } |
| 3040 | |
| 3041 | if ( ! -r $mysync->{pidfile} ) { |
| 3042 | myprint( "Can not read pidfile $mysync->{pidfile}. Exiting.\n" ) ; |
| 3043 | exit $EX_OK ; |
| 3044 | } |
| 3045 | my $pidtokill = firstline( $mysync->{pidfile} ) ; |
| 3046 | if ( ! $pidtokill ) { |
| 3047 | myprint( "No process to abort. Exiting.\n" ) ; |
| 3048 | exit $EX_OK ; |
| 3049 | } |
| 3050 | |
| 3051 | killpid( $pidtokill ) ; |
| 3052 | |
| 3053 | # well, the abort job is done anyway, because even when not succeeded |
| 3054 | # in aborting another run, this run has to end without doing any |
| 3055 | # thing else |
| 3056 | |
| 3057 | exit $EX_OK ; |
| 3058 | } |
| 3059 | |
| 3060 | |
| 3061 | sub under_docker_context |
| 3062 | { |
| 3063 | my $mysync = shift ; |
| 3064 | |
| 3065 | if ( -e '/.dockerenv' ) |
| 3066 | { |
| 3067 | return 1 ; |
| 3068 | } |
| 3069 | else |
| 3070 | { |
| 3071 | return 0 ; |
| 3072 | } |
| 3073 | |
| 3074 | return ; |
| 3075 | } |
| 3076 | |
| 3077 | |
| 3078 | sub docker_context |
| 3079 | { |
| 3080 | my $mysync = shift ; |
| 3081 | |
| 3082 | #-e '/.dockerenv' || return ; |
| 3083 | |
| 3084 | if ( ! under_docker_context( $mysync ) ) |
| 3085 | { |
| 3086 | return ; |
| 3087 | } |
| 3088 | |
| 3089 | $mysync->{ debug } and myprint( "Docker context detected with /.dockerenv\n" ) ; |
| 3090 | # No pidfile |
| 3091 | $mysync->{pidfile} = q{} ; |
| 3092 | # No log |
| 3093 | $mysync->{log} = 0 ; |
| 3094 | # In case |
| 3095 | $mysync->{ debug } and myprint( "Changing current directory to /var/tmp/\n" ) ; |
| 3096 | chdir '/var/tmp/' ; |
| 3097 | |
| 3098 | return ; |
| 3099 | } |
| 3100 | |
| 3101 | sub cgibegin |
| 3102 | { |
| 3103 | my $mysync = shift ; |
| 3104 | if ( ! under_cgi_context( $mysync ) ) { return ; } |
| 3105 | require CGI ; |
| 3106 | CGI->import( qw( -no_debug -utf8 ) ) ; |
| 3107 | require CGI::Carp ; |
| 3108 | CGI::Carp->import( qw( fatalsToBrowser ) ) ; |
| 3109 | $mysync->{cgi} = CGI->new( ) ; |
| 3110 | return ; |
| 3111 | } |
| 3112 | |
| 3113 | sub tests_under_cgi_context |
| 3114 | { |
| 3115 | note( 'Entering tests_under_cgi_context()' ) ; |
| 3116 | |
| 3117 | # $ENV{SERVER_SOFTWARE} = 'under imapsync' ; |
| 3118 | do { |
| 3119 | # Not in cgi context |
| 3120 | delete local $ENV{SERVER_SOFTWARE} ; |
| 3121 | is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ; |
| 3122 | } ; |
| 3123 | do { |
| 3124 | # In cgi context |
| 3125 | local $ENV{SERVER_SOFTWARE} = 'under imapsync' ; |
| 3126 | is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ; |
| 3127 | } ; |
| 3128 | do { |
| 3129 | # Not in cgi context |
| 3130 | delete local $ENV{SERVER_SOFTWARE} ; |
| 3131 | is( undef, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE unset => not in cgi context' ) ; |
| 3132 | } ; |
| 3133 | do { |
| 3134 | # In cgi context |
| 3135 | local $ENV{SERVER_SOFTWARE} = 'under imapsync' ; |
| 3136 | is( 1, under_cgi_context( ), 'under_cgi_context: SERVER_SOFTWARE set => in cgi context' ) ; |
| 3137 | } ; |
| 3138 | note( 'Leaving tests_under_cgi_context()' ) ; |
| 3139 | return ; |
| 3140 | } |
| 3141 | |
| 3142 | |
| 3143 | sub under_cgi_context |
| 3144 | { |
| 3145 | my $mysync = shift ; |
| 3146 | # Under cgi context |
| 3147 | if ( $ENV{SERVER_SOFTWARE} ) { |
| 3148 | return 1 ; |
| 3149 | } |
| 3150 | # Not in cgi context |
| 3151 | return ; |
| 3152 | } |
| 3153 | |
| 3154 | sub cgibuildheader |
| 3155 | { |
| 3156 | my $mysync = shift ; |
| 3157 | if ( ! under_cgi_context( $mysync ) ) { return ; } |
| 3158 | |
| 3159 | my $imapsync_runs = $mysync->{cgi}->cookie( 'imapsync_runs' ) || 0 ; |
| 3160 | my $cookie = $mysync->{cgi}->cookie( |
| 3161 | -name => 'imapsync_runs', |
| 3162 | -value => 1 + $imapsync_runs, |
| 3163 | -expires => '+20y', |
| 3164 | -path => '/cgi-bin/imapsync', |
| 3165 | ) ; |
| 3166 | my $httpheader ; |
| 3167 | if ( $mysync->{ abort } ) { |
| 3168 | $httpheader = $mysync->{cgi}->header( |
| 3169 | -type => 'text/plain', |
| 3170 | -status => '200 OK to abort syncing IMAP boxes' . ". Here is " . hostname(), |
| 3171 | ) ; |
| 3172 | }elsif( $mysync->{ loaddelay } ) { |
| 3173 | # https://tools.ietf.org/html/rfc2616#section-10.5.4 |
| 3174 | # 503 Service Unavailable |
| 3175 | # The server is currently unable to handle the request due to a temporary overloading or maintenance of the server. |
| 3176 | $httpheader = $mysync->{cgi}->header( |
| 3177 | -type => 'text/plain', |
| 3178 | -status => '503 Service Unavailable' . ". Be back in $mysync->{ loaddelay } min. Load on " . hostname() . " is $mysync->{ loadavg }", |
| 3179 | ) ; |
| 3180 | }else{ |
| 3181 | $httpheader = $mysync->{cgi}->header( |
| 3182 | -type => 'text/plain; charset=UTF-8', |
| 3183 | -status => '200 OK to sync IMAP boxes' . ". Load on " . hostname() . " is $mysync->{ loadavg }", |
| 3184 | -cookie => $cookie, |
| 3185 | ) ; |
| 3186 | } |
| 3187 | output_start( $mysync, $httpheader ) ; |
| 3188 | |
| 3189 | return ; |
| 3190 | } |
| 3191 | |
| 3192 | sub cgiload |
| 3193 | { |
| 3194 | # Exit on heavy load in CGI context |
| 3195 | my $mysync = shift ; |
| 3196 | if ( ! under_cgi_context( $mysync ) ) { return ; } |
| 3197 | if ( $mysync->{ abort } ) { return ; } # keep going to abort since some ressources will be free soon |
| 3198 | if ( $mysync->{ loaddelay } ) |
| 3199 | { |
| 3200 | $mysync->{nb_errors}++ ; |
| 3201 | exit_clean( $mysync, $EX_UNAVAILABLE, |
| 3202 | "Server is on heavy load. Be back in $mysync->{ loaddelay } min. Load is $mysync->{ loadavg }\n" |
| 3203 | ) ; |
| 3204 | } |
| 3205 | return ; |
| 3206 | } |
| 3207 | |
| 3208 | sub tests_set_umask |
| 3209 | { |
| 3210 | note( 'Entering tests_set_umask()' ) ; |
| 3211 | |
| 3212 | my $save_umask = umask ; |
| 3213 | |
| 3214 | my $mysync = {} ; |
| 3215 | if ( 'MSWin32' eq $OSNAME ) { |
| 3216 | is( undef, set_umask( $mysync ), "set_umask: set failure to $UMASK_PARANO on MSWin32" ) ; |
| 3217 | }else{ |
| 3218 | is( 1, set_umask( $mysync ), "set_umask: set to $UMASK_PARANO" ) ; |
| 3219 | } |
| 3220 | |
| 3221 | umask $save_umask ; |
| 3222 | note( 'Leaving tests_set_umask()' ) ; |
| 3223 | return ; |
| 3224 | } |
| 3225 | |
| 3226 | sub set_umask |
| 3227 | { |
| 3228 | my $mysync = shift ; |
| 3229 | my $previous_umask = umask_str( ) ; |
| 3230 | my $new_umask = umask_str( $UMASK_PARANO ) ; |
| 3231 | output( $mysync, "Umask set with $new_umask (was $previous_umask)\n" ) ; |
| 3232 | if ( $new_umask eq $UMASK_PARANO ) { |
| 3233 | return 1 ; |
| 3234 | } |
| 3235 | return ; |
| 3236 | } |
| 3237 | |
| 3238 | sub tests_umask_str |
| 3239 | { |
| 3240 | note( 'Entering tests_umask_str()' ) ; |
| 3241 | |
| 3242 | my $save_umask = umask ; |
| 3243 | |
| 3244 | is( umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent' ) ; |
| 3245 | is( my $save_umask_str = umask_str( ), umask_str( ), 'umask_str: no parameters => idopotent + save' ) ; |
| 3246 | is( '0000', umask_str( q{ } ), 'umask_str: q{ } => 0000' ) ; |
| 3247 | is( '0000', umask_str( q{} ), 'umask_str: q{} => 0000' ) ; |
| 3248 | is( '0000', umask_str( '0000' ), 'umask_str: 0000 => 0000' ) ; |
| 3249 | is( '0000', umask_str( '0' ), 'umask_str: 0 => 0000' ) ; |
| 3250 | is( '0200', umask_str( '0200' ), 'umask_str: 0200 => 0200' ) ; |
| 3251 | is( '0400', umask_str( '0400' ), 'umask_str: 0400 => 0400' ) ; |
| 3252 | is( '0600', umask_str( '0600' ), 'umask_str: 0600 => 0600' ) ; |
| 3253 | |
| 3254 | SKIP: { |
| 3255 | if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 6 ) ; } |
| 3256 | is( '0100', umask_str( '0100' ), 'umask_str: 0100 => 0100' ) ; |
| 3257 | is( '0001', umask_str( '0001' ), 'umask_str: 0001 => 0001' ) ; |
| 3258 | is( '0777', umask_str( '0777' ), 'umask_str: 0777 => 0777' ) ; |
| 3259 | is( '0777', umask_str( '00777' ), 'umask_str: 00777 => 0777' ) ; |
| 3260 | is( '0777', umask_str( ' 777 ' ), 'umask_str: 777 => 0777' ) ; |
| 3261 | is( "$UMASK_PARANO", umask_str( $UMASK_PARANO ), "umask_str: UMASK_PARANO $UMASK_PARANO => $UMASK_PARANO" ) ; |
| 3262 | } |
| 3263 | |
| 3264 | is( $save_umask_str, umask_str( $save_umask_str ), 'umask_str: restore with str' ) ; |
| 3265 | is( $save_umask, umask, 'umask_str: umask is restored, controlled by direct umask' ) ; |
| 3266 | is( $save_umask, umask $save_umask, 'umask_str: umask is restored by direct umask' ) ; |
| 3267 | is( $save_umask, umask, 'umask_str: umask initial controlled by direct umask' ) ; |
| 3268 | |
| 3269 | note( 'Leaving tests_umask_str()' ) ; |
| 3270 | return ; |
| 3271 | } |
| 3272 | |
| 3273 | sub umask_str |
| 3274 | { |
| 3275 | my $value = shift ; |
| 3276 | |
| 3277 | if ( defined $value ) { |
| 3278 | umask oct( $value ) ; |
| 3279 | } |
| 3280 | my $current = umask ; |
| 3281 | |
| 3282 | return( sprintf( '%#04o', $current ) ) ; |
| 3283 | } |
| 3284 | |
| 3285 | sub tests_umask |
| 3286 | { |
| 3287 | note( 'Entering tests_umask()' ) ; |
| 3288 | |
| 3289 | my $save_umask ; |
| 3290 | is( umask, umask, 'umask: umask is umask' ) ; |
| 3291 | is( $save_umask = umask, umask, "umask: umask is umask again + save it: $save_umask" ) ; |
| 3292 | is( $save_umask, umask oct(0000), 'umask: umask 0000' ) ; |
| 3293 | is( oct(0000), umask, 'umask: umask is now 0000' ) ; |
| 3294 | is( oct(0000), umask oct(777), 'umask: umask 0777 call, previous 0000' ) ; |
| 3295 | |
| 3296 | SKIP: { |
| 3297 | if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests success only for Unix', 2 ) ; } |
| 3298 | is( oct(777), umask, 'umask: umask is now 0777' ) ; |
| 3299 | is( oct(777), umask $save_umask, "umask: umask $save_umask restore inital value, previous 0777" ) ; |
| 3300 | } |
| 3301 | |
| 3302 | ok( defined umask $save_umask, "umask: umask $save_umask restore inital value, previous defined" ) ; |
| 3303 | is( $save_umask, umask, 'umask: umask is umask restored' ) ; |
| 3304 | note( 'Leaving tests_umask()' ) ; |
| 3305 | |
| 3306 | return ; |
| 3307 | } |
| 3308 | |
| 3309 | sub cgisetcontext |
| 3310 | { |
| 3311 | my $mysync = shift ; |
| 3312 | if ( ! under_cgi_context( $mysync ) ) { return ; } |
| 3313 | |
| 3314 | output( $mysync, "Under cgi context\n" ) ; |
| 3315 | set_umask( $mysync ) ; |
| 3316 | |
| 3317 | # Remove all content in unsafe evaled options |
| 3318 | @{ $mysync->{ regextrans2 } } = ( ) ; |
| 3319 | @regexflag = ( ) ; |
| 3320 | @regexmess = ( ) ; |
| 3321 | @skipmess = ( ) ; |
| 3322 | @pipemess = ( ) ; |
| 3323 | $delete2foldersonly = undef ; |
| 3324 | $delete2foldersbutnot = undef ; |
| 3325 | $maxlinelengthcmd = undef ; |
| 3326 | |
| 3327 | # Set safe default values (I hope...) |
| 3328 | |
| 3329 | |
| 3330 | #$mysync->{pidfile} = 'imapsync.pid' ; |
| 3331 | $mysync->{pidfilelocking} = 1 ; |
| 3332 | $mysync->{errorsmax} = $ERRORS_MAX_CGI ; |
| 3333 | $modulesversion = 0 ; |
| 3334 | $mysync->{releasecheck} = defined $mysync->{releasecheck} ? $mysync->{releasecheck} : 1 ; |
| 3335 | $usecache = 0 ; |
| 3336 | $mysync->{showpasswords} = 0 ; |
| 3337 | $debugimap1 = $debugimap2 = $debugimap = 0 ; |
| 3338 | $reconnectretry1 = $reconnectretry2 = $DEFAULT_NB_RECONNECT_PER_IMAP_COMMAND ; |
| 3339 | $pipemesscheck = 0 ; |
| 3340 | |
| 3341 | $mysync->{hashfile} = $CGI_HASHFILE ; |
| 3342 | my $hashsynclocal = hashsynclocal( $mysync ) || die "Can not get hashsynclocal. Exiting\n" ; |
| 3343 | |
| 3344 | if ( $ENV{ 'NET_SERVER_SOFTWARE' } and ( $ENV{ 'NET_SERVER_SOFTWARE' } =~ /Net::Server::HTTP/ ) ) |
| 3345 | { |
| 3346 | # under local webserver |
| 3347 | $cgidir = q{.} ; |
| 3348 | } |
| 3349 | else |
| 3350 | { |
| 3351 | $cgidir = $CGI_TMPDIR_TOP . '/' . $hashsynclocal ; |
| 3352 | } |
| 3353 | -d $cgidir or mkpath $cgidir or die "Can not create $cgidir: $OS_ERROR\n" ; |
| 3354 | $mysync->{ tmpdir } = $cgidir ; |
| 3355 | |
| 3356 | chdir $cgidir or die "Can not cd to $cgidir: $OS_ERROR\n" ; |
| 3357 | cgioutputenvcontext( $mysync ) ; |
| 3358 | $mysync->{ debug } and output( $mysync, 'Current directory is ' . getcwd( ) . "\n" ) ; |
| 3359 | $mysync->{ debug } and output( $mysync, 'Real user id is ' . getpwuid_any_os( $REAL_USER_ID ) . " (uid $REAL_USER_ID)\n" ) ; |
| 3360 | $mysync->{ debug } and output( $mysync, 'Effective user id is ' . getpwuid_any_os( $EFFECTIVE_USER_ID ). " (euid $EFFECTIVE_USER_ID)\n" ) ; |
| 3361 | |
| 3362 | $mysync->{ skipemptyfolders } = defined $mysync->{ skipemptyfolders } ? $mysync->{ skipemptyfolders } : 1 ; |
| 3363 | |
| 3364 | # Out of memory with messages over 1 GB ? |
| 3365 | $mysync->{ maxsize } = defined $mysync->{ maxsize } ? $mysync->{ maxsize } : 1_000_000_000 ; |
| 3366 | |
| 3367 | # tail -f behaviour on by default |
| 3368 | $mysync->{ tail } = defined $mysync->{ tail } ? $mysync->{ tail } : 1 ; |
| 3369 | |
| 3370 | # not sure it's for good |
| 3371 | @useheader = qw( Message-Id ) ; |
| 3372 | |
| 3373 | # addheader on by default |
| 3374 | $mysync->{ addheader } = defined $mysync->{ addheader } ? $mysync->{ addheader } : 1 ; |
| 3375 | |
| 3376 | return ; |
| 3377 | } |
| 3378 | |
| 3379 | sub cgioutputenvcontext |
| 3380 | { |
| 3381 | my $mysync = shift @ARG ; |
| 3382 | |
| 3383 | for my $envvar ( qw( REMOTE_ADDR REMOTE_HOST HTTP_REFERER HTTP_USER_AGENT SERVER_SOFTWARE SERVER_PORT HTTP_COOKIE ) ) { |
| 3384 | |
| 3385 | my $envval = $ENV{ $envvar } || q{} ; |
| 3386 | if ( $envval ) { output( $mysync, "$envvar is $envval\n" ) } ; |
| 3387 | } |
| 3388 | |
| 3389 | return ; |
| 3390 | } |
| 3391 | |
| 3392 | |
| 3393 | sub debugsleep |
| 3394 | { |
| 3395 | my $mysync = shift @ARG ; |
| 3396 | if ( defined $mysync->{debugsleep} ) { |
| 3397 | myprint( "Info: sleeping $mysync->{debugsleep}s\n" ) ; |
| 3398 | sleep $mysync->{debugsleep} ; |
| 3399 | } |
| 3400 | return ; |
| 3401 | } |
| 3402 | |
| 3403 | sub tests_foldersize |
| 3404 | { |
| 3405 | note( 'Entering tests_foldersize()' ) ; |
| 3406 | |
| 3407 | is( undef, foldersize( ), 'foldersize: no args => undef' ) ; |
| 3408 | |
| 3409 | |
| 3410 | #is_deeply( {}, {}, 'foldersize: a hash is a hash' ) ; |
| 3411 | #is_deeply( [], [], 'foldersize: an array is an array' ) ; |
| 3412 | note( 'Leaving tests_foldersize()' ) ; |
| 3413 | return ; |
| 3414 | } |
| 3415 | |
| 3416 | |
| 3417 | |
| 3418 | # Globals: |
| 3419 | # $uidnext_default |
| 3420 | # $fetch_hash_set |
| 3421 | # |
| 3422 | sub foldersize |
| 3423 | { |
| 3424 | # size of one folder |
| 3425 | my ( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) = @ARG ; |
| 3426 | |
| 3427 | if ( ! all_defined( $mysync, $side, $imap, $folder ) ) |
| 3428 | { |
| 3429 | return ; |
| 3430 | } |
| 3431 | |
| 3432 | # FTGate is RFC buggy with EXAMINE it does not act as SELECT |
| 3433 | #if ( ! $imap->examine( $folder ) ) { |
| 3434 | if ( ! $imap->select( $folder ) ) { |
| 3435 | my $error = join q{}, |
| 3436 | "$side Folder $folder: Could not select: ", |
| 3437 | $imap->LastError, "\n" ; |
| 3438 | errors_incr( $mysync, $error ) ; |
| 3439 | return ; |
| 3440 | } |
| 3441 | |
| 3442 | if ( $imap->IsUnconnected( ) ) |
| 3443 | { |
| 3444 | return ; |
| 3445 | } |
| 3446 | |
| 3447 | my $hash_ref = { } ; |
| 3448 | my @msgs = select_msgs( $imap, undef, $search_cmd, $abletosearch, $folder ) ; |
| 3449 | my $nb_msgs = scalar @msgs ; |
| 3450 | my $biggest_in_folder = 0 ; |
| 3451 | @{ $hash_ref }{ @msgs } = ( undef ) if @msgs ; |
| 3452 | |
| 3453 | my $stot = 0 ; |
| 3454 | |
| 3455 | if ( $imap->IsUnconnected( ) ) |
| 3456 | { |
| 3457 | return ; |
| 3458 | } |
| 3459 | |
| 3460 | if ( $nb_msgs > 0 and @msgs ) { |
| 3461 | if ( $abletosearch ) { |
| 3462 | if ( ! $imap->fetch_hash( \@msgs, 'RFC822.SIZE', $hash_ref) ) { |
| 3463 | my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ; |
| 3464 | errors_incr( $mysync, $error ) ; |
| 3465 | return ; |
| 3466 | } |
| 3467 | } |
| 3468 | else |
| 3469 | { |
| 3470 | my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; |
| 3471 | my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; |
| 3472 | if ( ! $imap->fetch_hash( $fetch_hash_uids, 'RFC822.SIZE', $hash_ref ) ) { |
| 3473 | my $error = "$side failure with fetch_hash: $EVAL_ERROR\n" ; |
| 3474 | errors_incr( $mysync, $error ) ; |
| 3475 | return ; |
| 3476 | } |
| 3477 | } |
| 3478 | for ( keys %{ $hash_ref } ) { |
| 3479 | my $size = $hash_ref->{ $_ }->{ 'RFC822.SIZE' } ; |
| 3480 | $stot += $size ; |
| 3481 | $biggest_in_folder = max( $biggest_in_folder, $size ) ; |
| 3482 | } |
| 3483 | } |
| 3484 | return( $stot, $nb_msgs, $biggest_in_folder ) ; |
| 3485 | |
| 3486 | } |
| 3487 | |
| 3488 | |
| 3489 | # The old subroutine that performed just one side at a time. |
| 3490 | # Still here for a while, until confident with sub foldersize_diff_compute() |
| 3491 | sub foldersizes |
| 3492 | { |
| 3493 | my ( $mysync, $side, $imap, $search_cmd, $abletosearch, @folders ) = @_ ; |
| 3494 | my $total_size = 0 ; |
| 3495 | my $total_nb = 0 ; |
| 3496 | my $biggest_in_all = 0 ; |
| 3497 | |
| 3498 | my $nb_folders = scalar @folders ; |
| 3499 | my $ct_folders = 0 ; # folder counter. |
| 3500 | myprint( "++++ Calculating sizes of $nb_folders folders on $side\n" ) ; |
| 3501 | foreach my $folder ( @folders ) { |
| 3502 | my $stot = 0 ; |
| 3503 | my $nb_msgs = 0 ; |
| 3504 | my $biggest_in_folder = 0 ; |
| 3505 | |
| 3506 | $ct_folders++ ; |
| 3507 | myprintf( "$side folder %7s %-35s", "$ct_folders/$nb_folders", jux_utf8( $folder ) ) ; |
| 3508 | if ( 'Host2' eq $side and not exists $mysync->{h2_folders_all_UPPER}{ uc $folder } ) { |
| 3509 | myprint( " does not exist yet\n") ; |
| 3510 | next ; |
| 3511 | } |
| 3512 | if ( 'Host1' eq $side and not exists $h1_folders_all{ $folder } ) { |
| 3513 | myprint( " does not exist\n" ) ; |
| 3514 | next ; |
| 3515 | } |
| 3516 | |
| 3517 | last if $imap->IsUnconnected( ) ; |
| 3518 | |
| 3519 | ( $stot, $nb_msgs, $biggest_in_folder ) = foldersize( $mysync, $side, $imap, $search_cmd, $abletosearch, $folder ) ; |
| 3520 | |
| 3521 | myprintf( ' Size: %9s', $stot ) ; |
| 3522 | myprintf( ' Messages: %5s', $nb_msgs ) ; |
| 3523 | myprintf( " Biggest: %9s\n", $biggest_in_folder ) ; |
| 3524 | $total_size += $stot ; |
| 3525 | $total_nb += $nb_msgs ; |
| 3526 | $biggest_in_all = max( $biggest_in_all, $biggest_in_folder ) ; |
| 3527 | } |
| 3528 | myprintf( "%s Nb folders: %11s folders\n", $side, $nb_folders ) ; |
| 3529 | myprintf( "%s Nb messages: %11s messages\n", $side, $total_nb ) ; |
| 3530 | myprintf( "%s Total size: %11s bytes (%s)\n", $side, $total_size, bytes_display_string( $total_size ) ) ; |
| 3531 | myprintf( "%s Biggest message: %11s bytes (%s)\n", $side, $biggest_in_all, bytes_display_string( $biggest_in_all ) ) ; |
| 3532 | myprintf( "%s Time spent on sizing: %11.1f seconds\n", $side, timenext( $mysync ) ) ; |
| 3533 | return( $total_nb, $total_size ) ; |
| 3534 | } |
| 3535 | |
| 3536 | |
| 3537 | sub foldersize_diff_present |
| 3538 | { |
| 3539 | my $mysync = shift ; |
| 3540 | my $folder1 = shift ; |
| 3541 | my $folder2 = shift ; |
| 3542 | my $counter_str = shift ; |
| 3543 | my $force = shift ; |
| 3544 | |
| 3545 | my $values1_str ; |
| 3546 | my $values2_str ; |
| 3547 | |
| 3548 | if ( ! defined $mysync->{ folder1 }->{ $folder1 }->{ size } || $force ) |
| 3549 | { |
| 3550 | foldersize_diff_compute( $mysync, $folder1, $folder2, $force ) ; |
| 3551 | } |
| 3552 | |
| 3553 | # again, but this time it means no availaible data. |
| 3554 | if ( defined $mysync->{ folder1 }->{ $folder1 }->{ size } ) |
| 3555 | { |
| 3556 | $values1_str = sprintf( "Size: %9s Messages: %5s Biggest: %9s\n", |
| 3557 | $mysync->{ folder1 }->{ $folder1 }->{ size }, |
| 3558 | $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs }, |
| 3559 | $mysync->{ folder1 }->{ $folder1 }->{ biggest }, |
| 3560 | ) ; |
| 3561 | } |
| 3562 | else |
| 3563 | { |
| 3564 | $values1_str = " does not exist\n" ; |
| 3565 | } |
| 3566 | |
| 3567 | if ( defined $mysync->{ folder2 }->{ $folder2 }->{ size } ) |
| 3568 | { |
| 3569 | $values2_str = sprintf( "Size: %9s Messages: %5s Biggest: %9s\n", |
| 3570 | $mysync->{ folder2 }->{ $folder2 }->{ size }, |
| 3571 | $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs }, |
| 3572 | $mysync->{ folder2 }->{ $folder2 }->{ biggest }, |
| 3573 | ) ; |
| 3574 | } |
| 3575 | else |
| 3576 | { |
| 3577 | $values2_str = " does not exist yet\n" ; |
| 3578 | } |
| 3579 | |
| 3580 | myprintf( "Host1 folder %7s %-35s %s", |
| 3581 | "$counter_str", |
| 3582 | jux_utf8( $folder1 ), |
| 3583 | $values1_str |
| 3584 | ) ; |
| 3585 | |
| 3586 | myprintf( "Host2 folder %7s %-35s %s", |
| 3587 | "$counter_str", |
| 3588 | jux_utf8( $folder2 ), |
| 3589 | $values2_str |
| 3590 | ) ; |
| 3591 | |
| 3592 | myprintf( "Host2-Host1 %7s %-35s %9s %5s %9s\n\n", |
| 3593 | "", |
| 3594 | "", |
| 3595 | $mysync->{ folder1 }->{ $folder1 }->{ size_diff }, |
| 3596 | $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs_diff }, |
| 3597 | $mysync->{ folder1 }->{ $folder1 }->{ biggest_diff }, |
| 3598 | |
| 3599 | ) ; |
| 3600 | |
| 3601 | |
| 3602 | |
| 3603 | |
| 3604 | return ; |
| 3605 | } |
| 3606 | |
| 3607 | sub foldersize_diff_compute |
| 3608 | { |
| 3609 | my $mysync = shift ; |
| 3610 | my $folder1 = shift ; |
| 3611 | my $folder2 = shift ; |
| 3612 | my $force = shift ; |
| 3613 | |
| 3614 | |
| 3615 | |
| 3616 | my ( $size_1, $nb_msgs_1, $biggest_1 ) ; |
| 3617 | # memoization |
| 3618 | if ( |
| 3619 | exists $h1_folders_all{ $folder1 } |
| 3620 | && |
| 3621 | ( |
| 3622 | ! defined $mysync->{ folder1 }->{ $folder1 }->{ size } |
| 3623 | || $force |
| 3624 | ) |
| 3625 | ) |
| 3626 | { |
| 3627 | #myprint( "foldersize folder1 $h1_folders_all{ $folder1 }\n" ) ; |
| 3628 | ( $size_1, $nb_msgs_1, $biggest_1 ) = |
| 3629 | foldersize( $mysync, |
| 3630 | 'Host1', |
| 3631 | $mysync->{ imap1 }, |
| 3632 | $mysync->{ search1 }, |
| 3633 | $mysync->{ abletosearch1 }, |
| 3634 | $folder1 |
| 3635 | ) ; |
| 3636 | $mysync->{ folder1 }->{ $folder1 }->{ size } = $size_1 ; |
| 3637 | $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } = $nb_msgs_1 ; |
| 3638 | $mysync->{ folder1 }->{ $folder1 }->{ biggest } = $biggest_1 ; |
| 3639 | } |
| 3640 | else |
| 3641 | { |
| 3642 | $size_1 = $mysync->{ folder1 }->{ $folder1 }->{ size } ; |
| 3643 | $nb_msgs_1 = $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } ; |
| 3644 | $biggest_1 = $mysync->{ folder1 }->{ $folder1 }->{ biggest } ; |
| 3645 | |
| 3646 | } |
| 3647 | |
| 3648 | |
| 3649 | my ( $size_2, $nb_msgs_2, $biggest_2 ) ; |
| 3650 | if ( |
| 3651 | exists $mysync->{ h2_folders_all_UPPER }{ uc $folder2 } |
| 3652 | && |
| 3653 | ( |
| 3654 | ! defined $mysync->{ folder2 }->{ $folder2 }->{ size } |
| 3655 | || $force |
| 3656 | ) |
| 3657 | ) |
| 3658 | { |
| 3659 | #myprint( "foldersize folder2\n" ) ; |
| 3660 | ( $size_2, $nb_msgs_2, $biggest_2 ) = |
| 3661 | foldersize( $mysync, |
| 3662 | 'Host2', |
| 3663 | $mysync->{ imap2 }, |
| 3664 | $mysync->{ search2 }, |
| 3665 | $mysync->{ abletosearch2 }, |
| 3666 | $folder2 |
| 3667 | ) ; |
| 3668 | |
| 3669 | $mysync->{ folder2 }->{ $folder2 }->{ size } = $size_2 ; |
| 3670 | $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } = $nb_msgs_2 ; |
| 3671 | $mysync->{ folder2 }->{ $folder2 }->{ biggest } = $biggest_2 ; |
| 3672 | } |
| 3673 | else |
| 3674 | { |
| 3675 | $size_2 = $mysync->{ folder2 }->{ $folder2 }->{ size } ; |
| 3676 | $nb_msgs_2 = $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } ; |
| 3677 | $biggest_2 = $mysync->{ folder2 }->{ $folder2 }->{ biggest } ; |
| 3678 | |
| 3679 | } |
| 3680 | |
| 3681 | |
| 3682 | my $size_diff = diff( $size_2, $size_1 ) ; |
| 3683 | my $nb_msgs_diff = diff( $nb_msgs_2, $nb_msgs_1 ) ; |
| 3684 | my $biggest_diff = diff( $biggest_2, $biggest_1 ) ; |
| 3685 | |
| 3686 | $mysync->{ folder1 }->{ $folder1 }->{ size_diff } = $size_diff ; |
| 3687 | $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs_diff } = $nb_msgs_diff ; |
| 3688 | $mysync->{ folder1 }->{ $folder1 }->{ biggest_diff } = $biggest_diff ; |
| 3689 | |
| 3690 | # It's redundant but easier to access later |
| 3691 | $mysync->{ folder2 }->{ $folder2 }->{ size_diff } = $size_diff ; |
| 3692 | $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs_diff } = $nb_msgs_diff ; |
| 3693 | $mysync->{ folder2 }->{ $folder2 }->{ biggest_diff } = $biggest_diff ; |
| 3694 | |
| 3695 | return ; |
| 3696 | } |
| 3697 | |
| 3698 | sub diff |
| 3699 | { |
| 3700 | my $x = shift ; |
| 3701 | my $y = shift ; |
| 3702 | |
| 3703 | $x ||= 0 ; |
| 3704 | $y ||= 0 ; |
| 3705 | |
| 3706 | return $x - $y ; |
| 3707 | } |
| 3708 | |
| 3709 | sub add |
| 3710 | { |
| 3711 | my $x = shift ; |
| 3712 | my $y = shift ; |
| 3713 | |
| 3714 | $x ||= 0 ; |
| 3715 | $y ||= 0 ; |
| 3716 | |
| 3717 | return $x + $y ; |
| 3718 | } |
| 3719 | |
| 3720 | |
| 3721 | sub foldersizes_diff_list |
| 3722 | { |
| 3723 | my $mysync = shift ; |
| 3724 | my $force = shift ; |
| 3725 | |
| 3726 | my @folders = @{ $mysync->{h1_folders_wanted} } ; |
| 3727 | my $nb_folders = scalar @folders ; |
| 3728 | my $ct_folders = 0 ; # folder counter. |
| 3729 | |
| 3730 | foreach my $folder1 ( @folders ) |
| 3731 | { |
| 3732 | $ct_folders++ ; |
| 3733 | my $counter_str = "$ct_folders/$nb_folders" ; |
| 3734 | my $folder2 = imap2_folder_name( $mysync, $folder1 ) ; |
| 3735 | foldersize_diff_present( $mysync, $folder1, $folder2, $counter_str, $force ) ; |
| 3736 | } |
| 3737 | |
| 3738 | return ; |
| 3739 | } |
| 3740 | |
| 3741 | sub foldersizes_total |
| 3742 | { |
| 3743 | my $mysync = shift ; |
| 3744 | |
| 3745 | my @folders_1 = @{ $mysync->{h1_folders_wanted} } ; |
| 3746 | my @folders_2 = @h2_folders_from_1_wanted ; |
| 3747 | |
| 3748 | my $nb_folders_1 = scalar( @folders_1 ) ; |
| 3749 | my $nb_folders_2 = scalar( @folders_2 ) ; |
| 3750 | |
| 3751 | my ( $total_size_1, $total_nb_1, $biggest_in_all_1 ) = ( 0, 0, 0 ) ; |
| 3752 | my ( $total_size_2, $total_nb_2, $biggest_in_all_2 ) = ( 0, 0, 0 ) ; |
| 3753 | |
| 3754 | foreach my $folder1 ( @folders_1 ) |
| 3755 | { |
| 3756 | $total_size_1 = add( $total_size_1, $mysync->{ folder1 }->{ $folder1 }->{ size } ) ; |
| 3757 | $total_nb_1 = add( $total_nb_1, $mysync->{ folder1 }->{ $folder1 }->{ nb_msgs } ) ; |
| 3758 | $biggest_in_all_1 = max( $biggest_in_all_1 , $mysync->{ folder1 }->{ $folder1 }->{ biggest } ) ; |
| 3759 | } |
| 3760 | |
| 3761 | foreach my $folder2 ( @folders_2 ) |
| 3762 | { |
| 3763 | $total_size_2 = add( $total_size_2, $mysync->{ folder2 }->{ $folder2 }->{ size } ) ; |
| 3764 | $total_nb_2 = add( $total_nb_2, $mysync->{ folder2 }->{ $folder2 }->{ nb_msgs } ) ; |
| 3765 | $biggest_in_all_2 = max( $biggest_in_all_2 , $mysync->{ folder2 }->{ $folder2 }->{ biggest } ) ; |
| 3766 | |
| 3767 | } |
| 3768 | |
| 3769 | myprintf( "Host1 Nb folders: %11s folders\n", $nb_folders_1 ) ; |
| 3770 | myprintf( "Host2 Nb folders: %11s folders\n", $nb_folders_2 ) ; |
| 3771 | myprint( "\n" ) ; |
| 3772 | myprintf( "Host1 Nb messages: %11s messages\n", $total_nb_1 ) ; |
| 3773 | myprintf( "Host2 Nb messages: %11s messages\n", $total_nb_2 ) ; |
| 3774 | myprint( "\n" ) ; |
| 3775 | myprintf( "Host1 Total size: %11s bytes (%s)\n", $total_size_1, bytes_display_string( $total_size_1 ) ) ; |
| 3776 | myprintf( "Host2 Total size: %11s bytes (%s)\n", $total_size_2, bytes_display_string( $total_size_2 ) ) ; |
| 3777 | myprint( "\n" ) ; |
| 3778 | myprintf( "Host1 Biggest message: %11s bytes (%s)\n", $biggest_in_all_1, bytes_display_string( $biggest_in_all_1 ) ) ; |
| 3779 | myprintf( "Host2 Biggest message: %11s bytes (%s)\n", $biggest_in_all_2, bytes_display_string( $biggest_in_all_2 ) ) ; |
| 3780 | myprint( "\n" ) ; |
| 3781 | myprintf( "Time spent on sizing: %11.1f seconds\n", timenext( $mysync ) ) ; |
| 3782 | |
| 3783 | my @total_1_2 = ( $total_nb_1, $total_size_1, $total_nb_2, $total_size_2 ) ; |
| 3784 | return @total_1_2 ; |
| 3785 | } |
| 3786 | |
| 3787 | sub foldersizesatend_old |
| 3788 | { |
| 3789 | my $mysync = shift ; |
| 3790 | timenext( $mysync ) ; |
| 3791 | return if ( $mysync->{imap1}->IsUnconnected( ) ) ; |
| 3792 | return if ( $mysync->{imap2}->IsUnconnected( ) ) ; |
| 3793 | # Get all folders on host2 again since new were created |
| 3794 | @h2_folders_all = sort $mysync->{imap2}->folders(); |
| 3795 | for ( @h2_folders_all ) { |
| 3796 | $h2_folders_all{ $_ } = 1 ; |
| 3797 | $mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ; |
| 3798 | } ; |
| 3799 | ( $h1_nb_msg_end, $h1_bytes_end ) = foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 }, $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ; |
| 3800 | ( $h2_nb_msg_end, $h2_bytes_end ) = foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 }, $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; |
| 3801 | if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) { |
| 3802 | my $error = "Failure getting foldersizes, final differences will not be calculated\n" ; |
| 3803 | errors_incr( $mysync, $error ) ; |
| 3804 | } |
| 3805 | return ; |
| 3806 | } |
| 3807 | |
| 3808 | sub foldersizesatend |
| 3809 | { |
| 3810 | my $mysync = shift ; |
| 3811 | timenext( $mysync ) ; |
| 3812 | return if ( $mysync->{imap1}->IsUnconnected( ) ) ; |
| 3813 | return if ( $mysync->{imap2}->IsUnconnected( ) ) ; |
| 3814 | # Get all folders on host2 again since new were created |
| 3815 | @h2_folders_all = sort $mysync->{imap2}->folders(); |
| 3816 | for ( @h2_folders_all ) { |
| 3817 | $h2_folders_all{ $_ } = 1 ; |
| 3818 | $mysync->{h2_folders_all_UPPER}{ uc $_ } = 1 ; |
| 3819 | } ; |
| 3820 | |
| 3821 | |
| 3822 | foldersizes_diff_list( $mysync, $FORCE ) ; |
| 3823 | |
| 3824 | ( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) |
| 3825 | = foldersizes_total( $mysync ) ; |
| 3826 | |
| 3827 | |
| 3828 | if ( not all_defined( $h1_nb_msg_end, $h1_bytes_end, $h2_nb_msg_end, $h2_bytes_end ) ) { |
| 3829 | my $error = "Failure getting foldersizes, final differences will not be calculated\n" ; |
| 3830 | errors_incr( $mysync, $error ) ; |
| 3831 | } |
| 3832 | return ; |
| 3833 | } |
| 3834 | |
| 3835 | |
| 3836 | sub foldersizes_at_the_beggining |
| 3837 | { |
| 3838 | my $mysync = shift ; |
| 3839 | |
| 3840 | myprint( << 'END_SIZE' ) ; |
| 3841 | |
| 3842 | Folders sizes before the synchronization. |
| 3843 | You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend" |
| 3844 | but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy. |
| 3845 | END_SIZE |
| 3846 | |
| 3847 | foldersizes_diff_list( $mysync ) ; |
| 3848 | |
| 3849 | ( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start }, |
| 3850 | $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) |
| 3851 | = foldersizes_total( $mysync ) ; |
| 3852 | |
| 3853 | |
| 3854 | if ( not all_defined( |
| 3855 | $mysync->{ h1_nb_msg_start }, |
| 3856 | $mysync->{ h1_bytes_start }, |
| 3857 | $mysync->{ h2_nb_msg_start }, |
| 3858 | $mysync->{ h2_bytes_start } ) ) |
| 3859 | { |
| 3860 | my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ; |
| 3861 | errors_incr( $mysync, $error ) ; |
| 3862 | $mysync->{ foldersizes } = 0 ; |
| 3863 | $mysync->{ foldersizesatend } = 0 ; |
| 3864 | return ; |
| 3865 | } |
| 3866 | |
| 3867 | my $h2_bytes_limit = $mysync->{h2}->{quota_limit_bytes} || 0 ; |
| 3868 | if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) ) |
| 3869 | { |
| 3870 | my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ; |
| 3871 | my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $mysync->{ h1_bytes_start } bytes / $h2_bytes_limit bytes )\n" ; |
| 3872 | errors_incr( $mysync, $error ) ; |
| 3873 | } |
| 3874 | return ; |
| 3875 | } |
| 3876 | |
| 3877 | |
| 3878 | # Globals: |
| 3879 | # @h2_folders_from_1_wanted |
| 3880 | |
| 3881 | sub foldersizes_at_the_beggining_old |
| 3882 | { |
| 3883 | my $mysync = shift ; |
| 3884 | |
| 3885 | myprint( << 'END_SIZE' ) ; |
| 3886 | |
| 3887 | Folders sizes before the synchronization. |
| 3888 | You can remove foldersizes listings by using "--nofoldersizes" and "--nofoldersizesatend" |
| 3889 | but then you will also lose the ETA (Estimation Time of Arrival) given after each message copy. |
| 3890 | END_SIZE |
| 3891 | |
| 3892 | ( $mysync->{ h1_nb_msg_start }, $mysync->{ h1_bytes_start } ) = |
| 3893 | foldersizes( $mysync, 'Host1', $mysync->{imap1}, $mysync->{ search1 }, |
| 3894 | $mysync->{abletosearch1}, @{ $mysync->{h1_folders_wanted} } ) ; |
| 3895 | ( $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) = |
| 3896 | foldersizes( $mysync, 'Host2', $mysync->{imap2}, $mysync->{ search2 }, |
| 3897 | $mysync->{abletosearch2}, @h2_folders_from_1_wanted ) ; |
| 3898 | |
| 3899 | if ( not all_defined( $mysync->{ h1_nb_msg_start }, |
| 3900 | $mysync->{ h1_bytes_start }, $mysync->{ h2_nb_msg_start }, $mysync->{ h2_bytes_start } ) ) |
| 3901 | { |
| 3902 | my $error = "Failure getting foldersizes, ETA and final diff will not be displayed\n" ; |
| 3903 | errors_incr( $mysync, $error ) ; |
| 3904 | $mysync->{ foldersizes } = 0 ; |
| 3905 | $mysync->{ foldersizesatend } = 0 ; |
| 3906 | return ; |
| 3907 | } |
| 3908 | |
| 3909 | my $h2_bytes_limit = $mysync->{h2}->{quota_limit_bytes} || 0 ; |
| 3910 | if ( $h2_bytes_limit and ( $h2_bytes_limit < $mysync->{ h1_bytes_start } ) ) |
| 3911 | { |
| 3912 | my $quota_percent = mysprintf( '%.0f', $NUMBER_100 * $mysync->{ h1_bytes_start } / $h2_bytes_limit ) ; |
| 3913 | my $error = "Host2: Quota limit will be exceeded! Over $quota_percent % ( $mysync->{ h1_bytes_start } bytes / $h2_bytes_limit bytes )\n" ; |
| 3914 | errors_incr( $mysync, $error ) ; |
| 3915 | } |
| 3916 | return ; |
| 3917 | } |
| 3918 | |
| 3919 | |
| 3920 | sub total_bytes_max_reached |
| 3921 | { |
| 3922 | my $mysync = shift ; |
| 3923 | |
| 3924 | if ( ! $mysync->{ exitwhenover } ) { |
| 3925 | return( 0 ) ; |
| 3926 | } |
| 3927 | if ( $mysync->{ total_bytes_transferred } >= $mysync->{ exitwhenover } ) { |
| 3928 | myprint( "Maximum bytes transferred reached, $mysync->{total_bytes_transferred} >= $mysync->{ exitwhenover }, ending sync\n" ) ; |
| 3929 | return( 1 ) ; |
| 3930 | } |
| 3931 | return ; |
| 3932 | } |
| 3933 | |
| 3934 | |
| 3935 | sub tests_mock_capability |
| 3936 | { |
| 3937 | note( 'Entering tests_mock_capability()' ) ; |
| 3938 | |
| 3939 | my $myimap ; |
| 3940 | ok( $myimap = mock_capability( ), |
| 3941 | 'mock_capability: (1) no args => a Test::MockObject' |
| 3942 | ) ; |
| 3943 | ok( $myimap->isa( 'Test::MockObject' ), |
| 3944 | 'mock_capability: (2) no args => a Test::MockObject' |
| 3945 | ) ; |
| 3946 | |
| 3947 | is( undef, $myimap->capability( ), |
| 3948 | 'mock_capability: (3) no args => capability undef' |
| 3949 | ) ; |
| 3950 | |
| 3951 | ok( mock_capability( $myimap ), |
| 3952 | 'mock_capability: (1) one arg => MockObject' |
| 3953 | ) ; |
| 3954 | |
| 3955 | is( undef, $myimap->capability( ), |
| 3956 | 'mock_capability: (2) one arg OO style => capability undef' |
| 3957 | ) ; |
| 3958 | |
| 3959 | ok( mock_capability( $myimap, $NUMBER_123456 ), |
| 3960 | 'mock_capability: (1) two args 123456 => capability 123456' |
| 3961 | ) ; |
| 3962 | |
| 3963 | is( $NUMBER_123456, $myimap->capability( ), |
| 3964 | 'mock_capability: (2) two args 123456 => capability 123456' |
| 3965 | ) ; |
| 3966 | |
| 3967 | ok( mock_capability( $myimap, 'ABCD' ), |
| 3968 | 'mock_capability: (1) two args ABCD => capability ABCD' |
| 3969 | ) ; |
| 3970 | is( 'ABCD', $myimap->capability( ), |
| 3971 | 'mock_capability: (2) two args ABCD => capability ABCD' |
| 3972 | ) ; |
| 3973 | |
| 3974 | ok( mock_capability( $myimap, [ 'ABCD' ] ), |
| 3975 | 'mock_capability: (1) two args [ ABCD ] => capability [ ABCD ]' |
| 3976 | ) ; |
| 3977 | is_deeply( [ 'ABCD' ], $myimap->capability( ), |
| 3978 | 'mock_capability: (2) two args [ ABCD ] => capability [ ABCD ]' |
| 3979 | ) ; |
| 3980 | |
| 3981 | ok( mock_capability( $myimap, [ 'ABC', 'DEF' ] ), |
| 3982 | 'mock_capability: (1) two args [ ABC, DEF ] => capability [ ABC, DEF ]' |
| 3983 | ) ; |
| 3984 | is_deeply( [ 'ABC', 'DEF' ], $myimap->capability( ), |
| 3985 | 'mock_capability: (2) two args [ ABC, DEF ] => capability capability [ ABC, DEF ]' |
| 3986 | ) ; |
| 3987 | |
| 3988 | ok( mock_capability( $myimap, 'ABC', 'DEF' ), |
| 3989 | 'mock_capability: (1) two args ABC, DEF => capability [ ABC, DEF ]' |
| 3990 | ) ; |
| 3991 | is_deeply( [ 'ABC', 'DEF' ], [ $myimap->capability( ) ], |
| 3992 | 'mock_capability: (2) two args ABC, DEF => capability capability [ ABC, DEF ]' |
| 3993 | ) ; |
| 3994 | |
| 3995 | ok( mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ), |
| 3996 | 'mock_capability: (1) two args IMAP4rev1, APPENDLIMIT=123456 => capability [ IMAP4rev1, APPENDLIMIT=123456 ]' |
| 3997 | ) ; |
| 3998 | is_deeply( [ 'IMAP4rev1', 'APPENDLIMIT=123456' ], [ $myimap->capability( ) ], |
| 3999 | 'mock_capability: (2) two args IMAP4rev1, APPENDLIMIT=123456 => capability capability [ IMAP4rev1, APPENDLIMIT=123456 ]' |
| 4000 | ) ; |
| 4001 | |
| 4002 | note( 'Leaving tests_mock_capability()' ) ; |
| 4003 | return ; |
| 4004 | } |
| 4005 | |
| 4006 | sub sig_install_toggle_sleep |
| 4007 | { |
| 4008 | my $mysync = shift ; |
| 4009 | if ( 'MSWin32' ne $OSNAME ) { |
| 4010 | #myprint( "sig_install( $mysync, \&toggle_sleep, 'USR1' )\n" ) ; |
| 4011 | sig_install( $mysync, 'toggle_sleep', 'USR1' ) ; |
| 4012 | } |
| 4013 | #myprint( "Leaving sig_install_toggle_sleep\n" ) ; |
| 4014 | return ; |
| 4015 | } |
| 4016 | |
| 4017 | |
| 4018 | sub mock_capability |
| 4019 | { |
| 4020 | my $myimap = shift ; |
| 4021 | my @has_capability_value = @ARG ; |
| 4022 | my ( $has_capability_value ) = @has_capability_value ; |
| 4023 | |
| 4024 | if ( ! $myimap ) |
| 4025 | { |
| 4026 | require_ok( "Test::MockObject" ) ; |
| 4027 | $myimap = Test::MockObject->new( ) ; |
| 4028 | } |
| 4029 | |
| 4030 | $myimap->mock( |
| 4031 | 'capability', |
| 4032 | sub { return wantarray ? |
| 4033 | @has_capability_value |
| 4034 | : $has_capability_value ; |
| 4035 | } |
| 4036 | ) ; |
| 4037 | |
| 4038 | return $myimap ; |
| 4039 | } |
| 4040 | |
| 4041 | |
| 4042 | sub tests_capability_of |
| 4043 | { |
| 4044 | note( 'Entering tests_capability_of()' ) ; |
| 4045 | |
| 4046 | is( undef, capability_of( ), |
| 4047 | 'capability_of: no args => undef' ) ; |
| 4048 | |
| 4049 | my $myimap ; |
| 4050 | is( undef, capability_of( $myimap ), |
| 4051 | 'capability_of: undef => undef' ) ; |
| 4052 | |
| 4053 | |
| 4054 | $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; |
| 4055 | |
| 4056 | is( undef, capability_of( $myimap, 'CACA' ), |
| 4057 | 'capability_of: two args unknown capability => undef' ) ; |
| 4058 | |
| 4059 | |
| 4060 | is( $NUMBER_123456, capability_of( $myimap, 'APPENDLIMIT' ), |
| 4061 | 'capability_of: two args APPENDLIMIT 123456 => 123456 yeah!' ) ; |
| 4062 | |
| 4063 | note( 'Leaving tests_capability_of()' ) ; |
| 4064 | return ; |
| 4065 | } |
| 4066 | |
| 4067 | |
| 4068 | sub capability_of |
| 4069 | { |
| 4070 | my $imap = shift || return ; |
| 4071 | my $capability_keyword = shift || return ; |
| 4072 | |
| 4073 | my @capability = $imap->capability ; |
| 4074 | |
| 4075 | if ( ! @capability ) { return ; } |
| 4076 | my $capability_value = search_in_array( $capability_keyword, @capability ) ; |
| 4077 | |
| 4078 | return $capability_value ; |
| 4079 | } |
| 4080 | |
| 4081 | |
| 4082 | sub tests_search_in_array |
| 4083 | { |
| 4084 | note( 'Entering tests_search_in_array()' ) ; |
| 4085 | |
| 4086 | is( undef, search_in_array( 'KA' ), |
| 4087 | 'search_in_array: no array => undef ' ) ; |
| 4088 | |
| 4089 | is( 'VA', search_in_array( 'KA', ( 'KA=VA' ) ), |
| 4090 | 'search_in_array: KA KA=VA => VA ' ) ; |
| 4091 | |
| 4092 | is( 'VA', search_in_array( 'KA', ( 'KA=VA', 'KB=VB' ) ), |
| 4093 | 'search_in_array: KA KA=VA KB=VB => VA ' ) ; |
| 4094 | |
| 4095 | is( 'VB', search_in_array( 'KB', ( 'KA=VA', 'KB=VB' ) ), |
| 4096 | 'search_in_array: KA=VA KB=VB => VB ' ) ; |
| 4097 | |
| 4098 | note( 'Leaving tests_search_in_array()' ) ; |
| 4099 | return ; |
| 4100 | } |
| 4101 | |
| 4102 | sub search_in_array |
| 4103 | { |
| 4104 | my ( $key, @array ) = @ARG ; |
| 4105 | |
| 4106 | foreach my $item ( @array ) |
| 4107 | { |
| 4108 | |
| 4109 | if ( $item =~ /([^=]+)=(.*)/ ) |
| 4110 | { |
| 4111 | if ( $1 eq $key ) |
| 4112 | { |
| 4113 | return $2 ; |
| 4114 | } |
| 4115 | } |
| 4116 | } |
| 4117 | |
| 4118 | return ; |
| 4119 | } |
| 4120 | |
| 4121 | |
| 4122 | |
| 4123 | |
| 4124 | sub tests_appendlimit_from_capability |
| 4125 | { |
| 4126 | note( 'Entering tests_appendlimit_from_capability()' ) ; |
| 4127 | |
| 4128 | is( undef, appendlimit_from_capability( ), |
| 4129 | 'appendlimit_from_capability: no args => undef' |
| 4130 | ) ; |
| 4131 | |
| 4132 | my $myimap ; |
| 4133 | is( undef, appendlimit_from_capability( $myimap ), |
| 4134 | 'appendlimit_from_capability: undef arg => undef' |
| 4135 | ) ; |
| 4136 | |
| 4137 | |
| 4138 | $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; |
| 4139 | |
| 4140 | # Normal behavior |
| 4141 | is( $NUMBER_123456, appendlimit_from_capability( $myimap ), |
| 4142 | 'appendlimit_from_capability: APPENDLIMIT=123456 => 123456' |
| 4143 | ) ; |
| 4144 | |
| 4145 | # Not a number |
| 4146 | $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=ABC' ) ; |
| 4147 | |
| 4148 | is( undef, appendlimit_from_capability( $myimap ), |
| 4149 | 'appendlimit_from_capability: not a number => undef' |
| 4150 | ) ; |
| 4151 | |
| 4152 | note( 'Leaving tests_appendlimit_from_capability()' ) ; |
| 4153 | return ; |
| 4154 | } |
| 4155 | |
| 4156 | |
| 4157 | sub appendlimit_from_capability |
| 4158 | { |
| 4159 | my $myimap = shift ; |
| 4160 | if ( ! $myimap ) |
| 4161 | { |
| 4162 | myprint( "Warn: no imap with call to appendlimit_from_capability\n" ) ; |
| 4163 | return ; |
| 4164 | } |
| 4165 | |
| 4166 | #myprint( Data::Dumper->Dump( [ \$myimap ] ) ) ; |
| 4167 | my $appendlimit = capability_of( $myimap, 'APPENDLIMIT' ) ; |
| 4168 | #myprint( "has_capability APPENDLIMIT $appendlimit\n" ) ; |
| 4169 | if ( is_an_integer( $appendlimit ) ) |
| 4170 | { |
| 4171 | return $appendlimit ; |
| 4172 | } |
| 4173 | return ; |
| 4174 | } |
| 4175 | |
| 4176 | |
| 4177 | sub tests_appendlimit |
| 4178 | { |
| 4179 | note( 'Entering tests_appendlimit()' ) ; |
| 4180 | |
| 4181 | is( undef, appendlimit( ), |
| 4182 | 'appendlimit: no args => undef' |
| 4183 | ) ; |
| 4184 | |
| 4185 | my $mysync = { } ; |
| 4186 | |
| 4187 | is( undef, appendlimit( $mysync ), |
| 4188 | 'appendlimit: no imap2 => undef' |
| 4189 | ) ; |
| 4190 | |
| 4191 | my $myimap ; |
| 4192 | $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; |
| 4193 | |
| 4194 | $mysync->{ imap2 } = $myimap ; |
| 4195 | |
| 4196 | is( 123456, appendlimit( $mysync ), |
| 4197 | 'appendlimit: imap2 with APPENDLIMIT=123456 => 123456' |
| 4198 | ) ; |
| 4199 | |
| 4200 | note( 'Leaving tests_appendlimit()' ) ; |
| 4201 | return ; |
| 4202 | } |
| 4203 | |
| 4204 | sub appendlimit |
| 4205 | { |
| 4206 | my $mysync = shift || return ; |
| 4207 | my $myimap = $mysync->{ imap2 } ; |
| 4208 | |
| 4209 | my $appendlimit = appendlimit_from_capability( $myimap ) ; |
| 4210 | if ( defined $appendlimit ) |
| 4211 | { |
| 4212 | myprint( "Host2: found APPENDLIMIT=$appendlimit in CAPABILITY (use --appendlimit xxxx to override this automatic setting)\n" ) ; |
| 4213 | return $appendlimit ; |
| 4214 | } |
| 4215 | return ; |
| 4216 | |
| 4217 | } |
| 4218 | |
| 4219 | |
| 4220 | sub tests_maxsize_setting |
| 4221 | { |
| 4222 | note( 'Entering tests_maxsize_setting()' ) ; |
| 4223 | |
| 4224 | is( undef, maxsize_setting( ), |
| 4225 | 'maxsize_setting: no args => undef' |
| 4226 | ) ; |
| 4227 | |
| 4228 | my $mysync ; |
| 4229 | |
| 4230 | is( undef, maxsize_setting( $mysync ), |
| 4231 | 'maxsize_setting: undef arg => undef' |
| 4232 | ) ; |
| 4233 | |
| 4234 | $mysync = { } ; |
| 4235 | $mysync->{ maxsize } = $NUMBER_123456 ; |
| 4236 | |
| 4237 | # --maxsize alone |
| 4238 | is( $NUMBER_123456, maxsize_setting( $mysync ), |
| 4239 | 'maxsize_setting: --maxsize 123456 alone => 123456' |
| 4240 | ) ; |
| 4241 | |
| 4242 | |
| 4243 | $mysync = { } ; |
| 4244 | my $myimap ; |
| 4245 | |
| 4246 | $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ; |
| 4247 | $mysync->{ imap2 } = $myimap ; |
| 4248 | |
| 4249 | # APPENDLIMIT alone |
| 4250 | is( $NUMBER_654321, maxsize_setting( $mysync ), |
| 4251 | 'maxsize_setting: APPENDLIMIT 654321 alone => 654321' |
| 4252 | ) ; |
| 4253 | |
| 4254 | is( $NUMBER_654321, $mysync->{ maxsize }, |
| 4255 | 'maxsize_setting: APPENDLIMIT 654321 alone => maxsize 654321' |
| 4256 | ) ; |
| 4257 | |
| 4258 | # APPENDLIMIT with --appendlimit => --appendlimit wins |
| 4259 | $mysync->{ appendlimit } = $NUMBER_123456 ; |
| 4260 | |
| 4261 | is( $NUMBER_123456, maxsize_setting( $mysync ), |
| 4262 | 'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => 123456' |
| 4263 | ) ; |
| 4264 | |
| 4265 | is( $NUMBER_123456, $mysync->{ maxsize }, |
| 4266 | 'maxsize_setting: APPENDLIMIT 654321 + --appendlimit 123456 => maxsize 123456' |
| 4267 | ) ; |
| 4268 | |
| 4269 | # Fresh |
| 4270 | $mysync = { } ; |
| 4271 | $mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=654321' ) ; |
| 4272 | |
| 4273 | # Case: "APPENDLIMIT >= --maxsize" => maxsize. |
| 4274 | $mysync->{ maxsize } = $NUMBER_123456 ; |
| 4275 | |
| 4276 | is( $NUMBER_123456, maxsize_setting( $mysync ), |
| 4277 | 'maxsize_setting: APPENDLIMIT 654321 --maxsize 123456 => 123456' |
| 4278 | ) ; |
| 4279 | |
| 4280 | # Case: "APPENDLIMIT < --maxsize" => APPENDLIMIT. |
| 4281 | |
| 4282 | |
| 4283 | # Fresh |
| 4284 | $mysync = { } ; |
| 4285 | $mysync->{ imap2 } = $myimap = mock_capability( $myimap, 'IMAP4rev1', 'APPENDLIMIT=123456' ) ; |
| 4286 | $mysync->{ maxsize } = $NUMBER_654321 ; |
| 4287 | |
| 4288 | is( $NUMBER_123456, maxsize_setting( $mysync ), |
| 4289 | 'maxsize_setting: APPENDLIMIT 123456 --maxsize 654321 => 123456 ' |
| 4290 | ) ; |
| 4291 | |
| 4292 | # Now --truncmess stuff |
| 4293 | |
| 4294 | |
| 4295 | |
| 4296 | note( 'Leaving tests_maxsize_setting()' ) ; |
| 4297 | |
| 4298 | return ; |
| 4299 | } |
| 4300 | |
| 4301 | # Three variables to take account of |
| 4302 | # appendlimit (given by --appendlimit or CAPABILITY...) |
| 4303 | # maxsize |
| 4304 | # truncmess |
| 4305 | |
| 4306 | sub maxsize_setting |
| 4307 | { |
| 4308 | my $mysync = shift || return ; |
| 4309 | |
| 4310 | if ( defined $mysync->{ appendlimit } ) |
| 4311 | { |
| 4312 | myprint( "Host2: Getting appendlimit from --appendlimit $mysync->{ appendlimit }\n" ) ; |
| 4313 | } |
| 4314 | else |
| 4315 | { |
| 4316 | $mysync->{ appendlimit } = appendlimit( $mysync ) ; |
| 4317 | } |
| 4318 | |
| 4319 | |
| 4320 | if ( all_defined( $mysync->{ appendlimit }, $mysync->{ maxsize } ) ) |
| 4321 | { |
| 4322 | my $min_maxsize_appendlimit = min( $mysync->{ maxsize }, $mysync->{ appendlimit } ) ; |
| 4323 | myprint( "Host2: Setting maxsize to $min_maxsize_appendlimit (min of --maxsize $mysync->{ maxsize } and appendlimit $mysync->{ appendlimit }\n" ) ; |
| 4324 | $mysync->{ maxsize } = $min_maxsize_appendlimit ; |
| 4325 | return $mysync->{ maxsize } ; |
| 4326 | } |
| 4327 | elsif ( defined $mysync->{ appendlimit } ) |
| 4328 | { |
| 4329 | myprint( "Host2: Setting maxsize to appendlimit $mysync->{ appendlimit }\n" ) ; |
| 4330 | $mysync->{ maxsize } = $mysync->{ appendlimit } ; |
| 4331 | return $mysync->{ maxsize } ; |
| 4332 | }elsif ( defined $mysync->{ maxsize } ) |
| 4333 | { |
| 4334 | return $mysync->{ maxsize } ; |
| 4335 | }else |
| 4336 | { |
| 4337 | return ; |
| 4338 | } |
| 4339 | } |
| 4340 | |
| 4341 | |
| 4342 | |
| 4343 | |
| 4344 | sub all_defined |
| 4345 | { |
| 4346 | if ( not @ARG ) { |
| 4347 | return 0 ; |
| 4348 | } |
| 4349 | foreach my $elem ( @ARG ) { |
| 4350 | if ( not defined $elem ) { |
| 4351 | return 0 ; |
| 4352 | } |
| 4353 | } |
| 4354 | return 1 ; |
| 4355 | } |
| 4356 | |
| 4357 | sub tests_all_defined |
| 4358 | { |
| 4359 | note( 'Entering tests_all_defined()' ) ; |
| 4360 | |
| 4361 | is( 0, all_defined( ), 'all_defined: no param => 0' ) ; |
| 4362 | is( 0, all_defined( () ), 'all_defined: void list => 0' ) ; |
| 4363 | is( 0, all_defined( undef ), 'all_defined: undef => 0' ) ; |
| 4364 | is( 0, all_defined( undef, undef ), 'all_defined: undef => 0' ) ; |
| 4365 | is( 0, all_defined( 1, undef ), 'all_defined: 1 undef => 0' ) ; |
| 4366 | is( 0, all_defined( undef, 1 ), 'all_defined: undef 1 => 0' ) ; |
| 4367 | is( 1, all_defined( 1, 1 ), 'all_defined: 1 1 => 1' ) ; |
| 4368 | is( 1, all_defined( (1, 1) ), 'all_defined: (1 1) => 1' ) ; |
| 4369 | |
| 4370 | note( 'Leaving tests_all_defined()' ) ; |
| 4371 | return ; |
| 4372 | } |
| 4373 | |
| 4374 | |
| 4375 | sub tests_hashsynclocal |
| 4376 | { |
| 4377 | note( 'Entering tests_hashsynclocal()' ) ; |
| 4378 | |
| 4379 | my $mysync = { |
| 4380 | host1 => q{}, |
| 4381 | user1 => q{}, |
| 4382 | password1 => q{}, |
| 4383 | host2 => q{}, |
| 4384 | user2 => q{}, |
| 4385 | password2 => q{}, |
| 4386 | } ; |
| 4387 | |
| 4388 | is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no hashfile name' ) ; |
| 4389 | |
| 4390 | $mysync->{ hashfile } = q{} ; |
| 4391 | is( undef, hashsynclocal( $mysync ), 'hashsynclocal: empty hashfile name' ) ; |
| 4392 | |
| 4393 | $mysync->{ hashfile } = './noexist/rrr' ; |
| 4394 | is( undef, hashsynclocal( $mysync ), 'hashsynclocal: no exists hashfile dir' ) ; |
| 4395 | |
| 4396 | SKIP: { |
| 4397 | if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) { skip( 'Tests only for non-root Unix', 1 ) ; } |
| 4398 | $mysync->{ hashfile } = '/rrr' ; |
| 4399 | is( undef, hashsynclocal( $mysync ), 'hashsynclocal: permission denied' ) ; |
| 4400 | } |
| 4401 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'hashsynclocal: mkpath W/tmp/tests/' ) ; |
| 4402 | $mysync->{ hashfile } = 'W/tmp/tests/imapsync_hash' ; |
| 4403 | |
| 4404 | ok( ! -e 'W/tmp/tests/imapsync_hash' || unlink 'W/tmp/tests/imapsync_hash', 'hashsynclocal: unlink W/tmp/tests/imapsync_hash' ) ; |
| 4405 | ok( ! -e 'W/tmp/tests/imapsync_hash', 'hashsynclocal: verify there is no W/tmp/tests/imapsync_hash' ) ; |
| 4406 | is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync, 'mukksyhpmbixkxkpjlqivmlqsulpictj' ), 'hashsynclocal: creating/reading W/tmp/tests/imapsync_hash' ) ; |
| 4407 | # A second time now |
| 4408 | is( 'ecdeb4ede672794d173da4e08c52b8ee19b7d252', hashsynclocal( $mysync ), 'hashsynclocal: reading W/tmp/tests/imapsync_hash second time => same' ) ; |
| 4409 | |
| 4410 | note( 'Leaving tests_hashsynclocal()' ) ; |
| 4411 | return ; |
| 4412 | } |
| 4413 | |
| 4414 | sub hashsynclocal |
| 4415 | { |
| 4416 | my $mysync = shift ; |
| 4417 | my $hashkey = shift ; # Optional, only there for tests |
| 4418 | my $hashfile = $mysync->{ hashfile } ; |
| 4419 | $hashfile = createhashfileifneeded( $hashfile, $hashkey ) ; |
| 4420 | if ( ! $hashfile ) { |
| 4421 | return ; |
| 4422 | } |
| 4423 | $hashkey = firstline( $hashfile ) ; |
| 4424 | if ( ! $hashkey ) { |
| 4425 | myprint( "No hashkey!\n" ) ; |
| 4426 | return ; |
| 4427 | } |
| 4428 | my $hashsynclocal = hashsync( $mysync, $hashkey ) ; |
| 4429 | return( $hashsynclocal ) ; |
| 4430 | |
| 4431 | } |
| 4432 | |
| 4433 | sub tests_hashsync |
| 4434 | { |
| 4435 | note( 'Entering tests_hashsync()' ) ; |
| 4436 | |
| 4437 | |
| 4438 | is( 'fbdb1d1b18aa6c08324b7d64b71fb76370690e1d', hashsync( {}, q{} ), 'hashsync: empty args' ) ; |
| 4439 | my $mysync ; |
| 4440 | $mysync->{ host1 } = 'zzz' ; |
| 4441 | is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ; |
| 4442 | is( 'e86a28a3611c1e7bbaf8057cd00ae122781a11fe', hashsync( $mysync, q{} ), 'hashsync: host1 zzz => ' ) ; |
| 4443 | $mysync->{ host2 } = 'zzz' ; |
| 4444 | is( '15959573e4a86763253a7aedb1a2b0c60d133dc2', hashsync( $mysync, q{} ), 'hashsync: + host2 zzz => ' ) ; |
| 4445 | is( 'b8d4ab541b209c75928528020ca28ee43488bd8f', hashsync( $mysync, 'A' ), 'hashsync: + hashkey A => ' ) ; |
| 4446 | |
| 4447 | note( 'Leaving tests_hashsync()' ) ; |
| 4448 | return ; |
| 4449 | } |
| 4450 | |
| 4451 | sub hashsync |
| 4452 | { |
| 4453 | my $mysync = shift ; |
| 4454 | my $hashkey = shift ; |
| 4455 | |
| 4456 | my $mystring = join( q{}, |
| 4457 | $mysync->{ host1 } || q{}, |
| 4458 | $mysync->{ user1 } || q{}, |
| 4459 | $mysync->{ password1 } || q{}, |
| 4460 | $mysync->{ host2 } || q{}, |
| 4461 | $mysync->{ user2 } || q{}, |
| 4462 | $mysync->{ password2 } || q{}, |
| 4463 | ) ; |
| 4464 | my $hashsync = hmac_sha1_hex( $mystring, $hashkey ) ; |
| 4465 | #myprint( "$hashsync\n" ) ; |
| 4466 | return( $hashsync ) ; |
| 4467 | } |
| 4468 | |
| 4469 | |
| 4470 | sub tests_createhashfileifneeded |
| 4471 | { |
| 4472 | note( 'Entering tests_createhashfileifneeded()' ) ; |
| 4473 | |
| 4474 | is( undef, createhashfileifneeded( ), 'createhashfileifneeded: no parameters => undef' ) ; |
| 4475 | |
| 4476 | note( 'Leaving tests_createhashfileifneeded()' ) ; |
| 4477 | return ; |
| 4478 | } |
| 4479 | |
| 4480 | sub createhashfileifneeded |
| 4481 | { |
| 4482 | my $hashfile = shift ; |
| 4483 | my $hashkey = shift || rand32( ) ; |
| 4484 | |
| 4485 | # no name |
| 4486 | if ( ! $hashfile ) { |
| 4487 | return ; |
| 4488 | } |
| 4489 | # already there |
| 4490 | if ( -e -r $hashfile ) { |
| 4491 | return $hashfile ; |
| 4492 | } |
| 4493 | # not creatable |
| 4494 | if ( ! -w dirname( $hashfile ) ) { |
| 4495 | return ; |
| 4496 | } |
| 4497 | # creatable |
| 4498 | open my $FILE_HANDLE, '>', $hashfile |
| 4499 | or do { |
| 4500 | myprint( "Could not open $hashfile for writing. Check permissions or disk space." ) ; |
| 4501 | return ; |
| 4502 | } ; |
| 4503 | myprint( "Writing random hashkey in $hashfile, once for all times\n" ) ; |
| 4504 | print $FILE_HANDLE $hashkey ; |
| 4505 | close $FILE_HANDLE ; |
| 4506 | # Should be there now |
| 4507 | if ( -e -r $hashfile ) { |
| 4508 | return $hashfile ; |
| 4509 | } |
| 4510 | # unknown failure |
| 4511 | return ; |
| 4512 | } |
| 4513 | |
| 4514 | sub tests_rand32 |
| 4515 | { |
| 4516 | note( 'Entering tests_rand32()' ) ; |
| 4517 | |
| 4518 | my $string = rand32( ) ; |
| 4519 | myprint( "$string\n" ) ; |
| 4520 | is( 32, length( $string ), 'rand32: 32 characters long' ) ; |
| 4521 | is( 32, length( rand32( ) ), 'rand32: 32 characters long, another one' ) ; |
| 4522 | |
| 4523 | note( 'Leaving tests_rand32()' ) ; |
| 4524 | return ; |
| 4525 | } |
| 4526 | |
| 4527 | sub rand32 |
| 4528 | { |
| 4529 | my @chars = ( "a".."z" ) ; |
| 4530 | my $string; |
| 4531 | $string .= $chars[rand @chars] for 1..32 ; |
| 4532 | return $string ; |
| 4533 | } |
| 4534 | |
| 4535 | sub imap_id_stuff |
| 4536 | { |
| 4537 | my $mysync = shift ; |
| 4538 | |
| 4539 | if ( not $mysync->{id} ) { return ; } ; |
| 4540 | |
| 4541 | $mysync->{h1_imap_id} = imap_id( $mysync, $mysync->{imap1}, 'Host1' ) ; |
| 4542 | #myprint( 'Host1: ' . $mysync->{h1_imap_id} ) ; |
| 4543 | $mysync->{h2_imap_id} = imap_id( $mysync, $mysync->{imap2}, 'Host2' ) ; |
| 4544 | #myprint( 'Host2: ' . $mysync->{h2_imap_id} ) ; |
| 4545 | |
| 4546 | return ; |
| 4547 | } |
| 4548 | |
| 4549 | sub imap_id |
| 4550 | { |
| 4551 | my ( $mysync, $imap, $Side ) = @_ ; |
| 4552 | |
| 4553 | if ( not $mysync->{id} ) { return q{} ; } ; |
| 4554 | |
| 4555 | $Side ||= q{} ; |
| 4556 | my $imap_id_response = q{} ; |
| 4557 | |
| 4558 | if ( not $imap->has_capability( 'ID' ) ) { |
| 4559 | $imap_id_response = 'No ID capability' ; |
| 4560 | myprint( "$Side: No ID capability\n" ) ; |
| 4561 | }else{ |
| 4562 | my $id_inp = imapsync_id( $mysync, { side => lc $Side } ) ; |
| 4563 | myprint( "\n$Side: found ID capability. Sending/receiving ID, presented in raw IMAP for now.\n" |
| 4564 | . "In order to avoid sending/receiving ID, use option --noid\n" ) ; |
| 4565 | my $debug_before = $imap->Debug( ) ; |
| 4566 | $imap->Debug( 1 ) ; |
| 4567 | my $id_out = $imap->tag_and_run( 'ID ' . $id_inp ) ; |
| 4568 | #my $id_out = $imap->tag_and_run( 'ID NIL' ) ; |
| 4569 | myprint( "\n" ) ; |
| 4570 | $imap->Debug( $debug_before ) ; |
| 4571 | #$imap_id_response = Data::Dumper->Dump( [ $id_out ], [ 'IMAP_ID' ] ) ; |
| 4572 | } |
| 4573 | return( $imap_id_response ) ; |
| 4574 | } |
| 4575 | |
| 4576 | sub imapsync_id |
| 4577 | { |
| 4578 | my $mysync = shift ; |
| 4579 | my $overhashref = shift ; |
| 4580 | # See http://tools.ietf.org/html/rfc2971.html |
| 4581 | |
| 4582 | my $imapsync_id = { } ; |
| 4583 | |
| 4584 | my $imapsync_id_lamiral = { |
| 4585 | name => 'imapsync', |
| 4586 | version => imapsync_version( $mysync ), |
| 4587 | os => $OSNAME, |
| 4588 | vendor => 'Gilles LAMIRAL', |
| 4589 | 'support-url' => 'https://imapsync.lamiral.info/', |
| 4590 | # Example of date-time: 19-Sep-2015 08:56:07 |
| 4591 | date => date_from_rcs( q{$Date: 2019/12/23 20:18:02 $ } ), |
| 4592 | } ; |
| 4593 | |
| 4594 | my $imapsync_id_github = { |
| 4595 | name => 'imapsync', |
| 4596 | version => imapsync_version( $mysync ), |
| 4597 | os => $OSNAME, |
| 4598 | vendor => 'github', |
| 4599 | 'support-url' => 'https://github.com/imapsync/imapsync', |
| 4600 | date => date_from_rcs( q{$Date: 2019/12/23 20:18:02 $ } ), |
| 4601 | } ; |
| 4602 | |
| 4603 | $imapsync_id = $imapsync_id_lamiral ; |
| 4604 | #$imapsync_id = $imapsync_id_github ; |
| 4605 | my %mix = ( %{ $imapsync_id }, %{ $overhashref } ) ; |
| 4606 | my $imapsync_id_str = format_for_imap_arg( \%mix ) ; |
| 4607 | #myprint( "$imapsync_id_str\n" ) ; |
| 4608 | return( $imapsync_id_str ) ; |
| 4609 | } |
| 4610 | |
| 4611 | sub tests_imapsync_id |
| 4612 | { |
| 4613 | note( 'Entering tests_imapsync_id()' ) ; |
| 4614 | |
| 4615 | my $mysync ; |
| 4616 | ok( '("name" "imapsync" "version" "111" "os" "beurk" "vendor" "Gilles LAMIRAL" "support-url" "https://imapsync.lamiral.info/" "date" "22-12-1968" "side" "host1")' |
| 4617 | eq imapsync_id( $mysync, |
| 4618 | { |
| 4619 | version => 111, |
| 4620 | os => 'beurk', |
| 4621 | date => '22-12-1968', |
| 4622 | side => 'host1' |
| 4623 | } |
| 4624 | ), |
| 4625 | 'tests_imapsync_id override' |
| 4626 | ) ; |
| 4627 | |
| 4628 | note( 'Leaving tests_imapsync_id()' ) ; |
| 4629 | return ; |
| 4630 | } |
| 4631 | |
| 4632 | sub format_for_imap_arg |
| 4633 | { |
| 4634 | my $ref = shift ; |
| 4635 | |
| 4636 | my $string = q{} ; |
| 4637 | my %terms = %{ $ref } ; |
| 4638 | my @terms = ( ) ; |
| 4639 | if ( not ( %terms ) ) { return( 'NIL' ) } ; |
| 4640 | # sort like in RFC then add extra key/values |
| 4641 | foreach my $key ( qw( name version os os-version vendor support-url address date command arguments environment) ) { |
| 4642 | if ( $terms{ $key } ) { |
| 4643 | push @terms, $key, $terms{ $key } ; |
| 4644 | delete $terms{ $key } ; |
| 4645 | } |
| 4646 | } |
| 4647 | push @terms, %terms ; |
| 4648 | $string = '(' . ( join q{ }, map { '"' . $_ . '"' } @terms ) . ')' ; |
| 4649 | return( $string ) ; |
| 4650 | } |
| 4651 | |
| 4652 | |
| 4653 | |
| 4654 | sub tests_format_for_imap_arg |
| 4655 | { |
| 4656 | note( 'Entering tests_format_for_imap_arg()' ) ; |
| 4657 | |
| 4658 | ok( 'NIL' eq format_for_imap_arg( { } ), 'format_for_imap_arg empty hash ref' ) ; |
| 4659 | ok( '("name" "toto")' eq format_for_imap_arg( { name => 'toto' } ), 'format_for_imap_arg { name => toto }' ) ; |
| 4660 | ok( '("name" "toto" "key" "val")' eq format_for_imap_arg( { name => 'toto', key => 'val' } ), 'format_for_imap_arg 2 x key val' ) ; |
| 4661 | |
| 4662 | note( 'Leaving tests_format_for_imap_arg()' ) ; |
| 4663 | return ; |
| 4664 | } |
| 4665 | |
| 4666 | sub quota |
| 4667 | { |
| 4668 | my ( $mysync, $imap, $side ) = @_ ; |
| 4669 | |
| 4670 | my %side = ( |
| 4671 | h1 => 'Host1', |
| 4672 | h2 => 'Host2', |
| 4673 | ) ; |
| 4674 | my $Side = $side{ $side } ; |
| 4675 | my $debug_before = $imap->Debug( ) ; |
| 4676 | $imap->Debug( 1 ) ; |
| 4677 | if ( not $imap->has_capability( 'QUOTA' ) ) { |
| 4678 | $imap->Debug( $debug_before ) ; |
| 4679 | return ; |
| 4680 | } ; |
| 4681 | myprint( "\n$Side: found quota, presented in raw IMAP\n" ) ; |
| 4682 | my $getquotaroot = $imap->getquotaroot( 'INBOX' ) ; |
| 4683 | # Gmail INBOX quotaroot is "" but with it Mail::IMAPClient does a literal GETQUOTA {2} \n "" |
| 4684 | #$imap->quota( 'ROOT' ) ; |
| 4685 | #$imap->quota( '""' ) ; |
| 4686 | myprint( "\n" ) ; |
| 4687 | $imap->Debug( $debug_before ) ; |
| 4688 | my $quota_limit_bytes = quota_extract_storage_limit_in_bytes( $mysync, $getquotaroot ) ; |
| 4689 | my $quota_current_bytes = quota_extract_storage_current_in_bytes( $mysync, $getquotaroot ) ; |
| 4690 | $mysync->{$side}->{quota_limit_bytes} = $quota_limit_bytes ; |
| 4691 | $mysync->{$side}->{quota_current_bytes} = $quota_current_bytes ; |
| 4692 | my $quota_percent ; |
| 4693 | if ( $quota_limit_bytes > 0 ) { |
| 4694 | $quota_percent = mysprintf( '%.2f', $NUMBER_100 * $quota_current_bytes / $quota_limit_bytes ) ; |
| 4695 | }else{ |
| 4696 | $quota_percent = 0 ; |
| 4697 | } |
| 4698 | myprint( "$Side: Quota current storage is $quota_current_bytes bytes. Limit is $quota_limit_bytes bytes. So $quota_percent % full\n" ) ; |
| 4699 | if ( $QUOTA_PERCENT_LIMIT < $quota_percent ) { |
| 4700 | my $error = "$Side: $quota_percent % full: it is time to find a bigger place! ( $quota_current_bytes bytes / $quota_limit_bytes bytes )\n" ; |
| 4701 | errors_incr( $mysync, $error ) ; |
| 4702 | } |
| 4703 | return ; |
| 4704 | } |
| 4705 | |
| 4706 | sub tests_quota_extract_storage_limit_in_bytes |
| 4707 | { |
| 4708 | note( 'Entering tests_quota_extract_storage_limit_in_bytes()' ) ; |
| 4709 | |
| 4710 | my $mysync = {} ; |
| 4711 | my $imap_output = [ |
| 4712 | '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', |
| 4713 | '* QUOTA "Storage quota" (STORAGE 1 104857600)', |
| 4714 | '* QUOTA "Messages quota" (MESSAGE 2 100000)', |
| 4715 | '5 OK Getquotaroot completed.' |
| 4716 | ] ; |
| 4717 | ok( $NUMBER_104_857_600 * $KIBI == quota_extract_storage_limit_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_limit_in_bytes ') ; |
| 4718 | |
| 4719 | note( 'Leaving tests_quota_extract_storage_limit_in_bytes()' ) ; |
| 4720 | return ; |
| 4721 | } |
| 4722 | |
| 4723 | sub quota_extract_storage_limit_in_bytes |
| 4724 | { |
| 4725 | my $mysync = shift ; |
| 4726 | my $imap_output = shift ; |
| 4727 | |
| 4728 | my $limit_kb ; |
| 4729 | $limit_kb = ( map { /.*\(\s*STORAGE\s+\d+\s+(\d+)\s*\)/x ? $1 : () } @{ $imap_output } )[0] ; |
| 4730 | $limit_kb ||= 0 ; |
| 4731 | $mysync->{ debug } and myprint( "storage_limit_kb = $limit_kb\n" ) ; |
| 4732 | return( $KIBI * $limit_kb ) ; |
| 4733 | } |
| 4734 | |
| 4735 | |
| 4736 | sub tests_quota_extract_storage_current_in_bytes |
| 4737 | { |
| 4738 | note( 'Entering tests_quota_extract_storage_current_in_bytes()' ) ; |
| 4739 | |
| 4740 | my $mysync = {} ; |
| 4741 | my $imap_output = [ |
| 4742 | '* QUOTAROOT "INBOX" "Storage quota" "Messages quota"', |
| 4743 | '* QUOTA "Storage quota" (STORAGE 1 104857600)', |
| 4744 | '* QUOTA "Messages quota" (MESSAGE 2 100000)', |
| 4745 | '5 OK Getquotaroot completed.' |
| 4746 | ] ; |
| 4747 | ok( 1*$KIBI == quota_extract_storage_current_in_bytes( $mysync, $imap_output ), 'quota_extract_storage_current_in_bytes: 1 => 1024 ') ; |
| 4748 | |
| 4749 | note( 'Leaving tests_quota_extract_storage_current_in_bytes()' ) ; |
| 4750 | return ; |
| 4751 | } |
| 4752 | |
| 4753 | sub quota_extract_storage_current_in_bytes |
| 4754 | { |
| 4755 | my $mysync = shift ; |
| 4756 | my $imap_output = shift ; |
| 4757 | |
| 4758 | my $current_kb ; |
| 4759 | $current_kb = ( map { /.*\(\s*STORAGE\s+(\d+)\s+\d+\s*\)/x ? $1 : () } @{ $imap_output } )[0] ; |
| 4760 | $current_kb ||= 0 ; |
| 4761 | $mysync->{ debug } and myprint( "storage_current_kb = $current_kb\n" ) ; |
| 4762 | return( $KIBI * $current_kb ) ; |
| 4763 | |
| 4764 | } |
| 4765 | |
| 4766 | |
| 4767 | sub automap |
| 4768 | { |
| 4769 | my ( $mysync ) = @_ ; |
| 4770 | |
| 4771 | if ( $mysync->{automap} ) { |
| 4772 | myprint( "Turned on automapping folders ( use --noautomap to turn off automapping )\n" ) ; |
| 4773 | }else{ |
| 4774 | myprint( "Turned off automapping folders ( use --automap to turn on automapping )\n" ) ; |
| 4775 | return ; |
| 4776 | } |
| 4777 | |
| 4778 | $mysync->{h1_special} = special_from_folders_hash( $mysync, $mysync->{imap1}, 'Host1' ) ; |
| 4779 | $mysync->{h2_special} = special_from_folders_hash( $mysync, $mysync->{imap2}, 'Host2' ) ; |
| 4780 | |
| 4781 | build_possible_special( $mysync ) ; |
| 4782 | build_guess_special( $mysync ) ; |
| 4783 | build_automap( $mysync ) ; |
| 4784 | |
| 4785 | return ; |
| 4786 | } |
| 4787 | |
| 4788 | |
| 4789 | |
| 4790 | |
| 4791 | sub build_guess_special |
| 4792 | { |
| 4793 | my ( $mysync ) = shift ; |
| 4794 | |
| 4795 | foreach my $h1_fold ( sort keys %{ $mysync->{h1_folders_all} } ) { |
| 4796 | my $special = guess_special( $h1_fold, $mysync->{possible_special}, $mysync->{h1_prefix} ) ; |
| 4797 | if ( $special ) { |
| 4798 | $mysync->{h1_special_guessed}{$h1_fold} = $special ; |
| 4799 | my $already_guessed = $mysync->{h1_special_guessed}{$special} ; |
| 4800 | if ( $already_guessed ) { |
| 4801 | myprint( "Host1: $h1_fold not $special because set to $already_guessed\n" ) ; |
| 4802 | }else{ |
| 4803 | $mysync->{h1_special_guessed}{$special} = $h1_fold ; |
| 4804 | } |
| 4805 | } |
| 4806 | } |
| 4807 | foreach my $h2_fold ( sort keys %{ $mysync->{h2_folders_all} } ) { |
| 4808 | my $special = guess_special( $h2_fold, $mysync->{possible_special}, $mysync->{h2_prefix} ) ; |
| 4809 | if ( $special ) { |
| 4810 | $mysync->{h2_special_guessed}{$h2_fold} = $special ; |
| 4811 | my $already_guessed = $mysync->{h2_special_guessed}{$special} ; |
| 4812 | if ( $already_guessed ) { |
| 4813 | myprint( "Host2: $h2_fold not $special because set to $already_guessed\n" ) ; |
| 4814 | }else{ |
| 4815 | $mysync->{h2_special_guessed}{$special} = $h2_fold ; |
| 4816 | } |
| 4817 | } |
| 4818 | } |
| 4819 | return ; |
| 4820 | } |
| 4821 | |
| 4822 | sub guess_special |
| 4823 | { |
| 4824 | my( $folder, $possible_special_ref, $prefix ) = @_ ; |
| 4825 | |
| 4826 | my $folder_no_prefix = $folder ; |
| 4827 | $folder_no_prefix =~ s/\Q${prefix}\E//xms ; |
| 4828 | #$debug and myprint( "folder_no_prefix: $folder_no_prefix\n" ) ; |
| 4829 | |
| 4830 | my $guess_special = $possible_special_ref->{ $folder } |
| 4831 | || $possible_special_ref->{ $folder_no_prefix } |
| 4832 | || q{} ; |
| 4833 | |
| 4834 | return( $guess_special ) ; |
| 4835 | } |
| 4836 | |
| 4837 | sub tests_guess_special |
| 4838 | { |
| 4839 | note( 'Entering tests_guess_special()' ) ; |
| 4840 | |
| 4841 | my $possible_special_ref = build_possible_special( my $mysync ) ; |
| 4842 | ok( '\Sent' eq guess_special( 'Sent', $possible_special_ref, q{} ) ,'guess_special: Sent => \Sent' ) ; |
| 4843 | ok( q{} eq guess_special( 'Blabla', $possible_special_ref, q{} ) ,'guess_special: Blabla => q{}' ) ; |
| 4844 | ok( '\Sent' eq guess_special( 'INBOX.Sent', $possible_special_ref, 'INBOX.' ) ,'guess_special: INBOX.Sent => \Sent' ) ; |
| 4845 | ok( '\Sent' eq guess_special( 'IN BOX.Sent', $possible_special_ref, 'IN BOX.' ) ,'guess_special: IN BOX.Sent => \Sent' ) ; |
| 4846 | |
| 4847 | note( 'Leaving tests_guess_special()' ) ; |
| 4848 | return ; |
| 4849 | } |
| 4850 | |
| 4851 | sub build_automap |
| 4852 | { |
| 4853 | my $mysync = shift ; |
| 4854 | $mysync->{ debug } and myprint( "Entering build_automap\n" ) ; |
| 4855 | foreach my $h1_fold ( @{ $mysync->{h1_folders_wanted} } ) { |
| 4856 | my $h2_fold ; |
| 4857 | my $h1_special = $mysync->{h1_special}{$h1_fold} ; |
| 4858 | my $h1_special_guessed = $mysync->{h1_special_guessed}{$h1_fold} ; |
| 4859 | |
| 4860 | # Case 1: special on both sides. |
| 4861 | if ( $h1_special |
| 4862 | and exists $mysync->{h2_special}{$h1_special} ) { |
| 4863 | $h2_fold = $mysync->{h2_special}{$h1_special} ; |
| 4864 | $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; |
| 4865 | next ; |
| 4866 | } |
| 4867 | # Case 2: special on host1, not on host2 |
| 4868 | if ( $h1_special |
| 4869 | and ( not exists $mysync->{h2_special}{$h1_special} ) |
| 4870 | and ( exists $mysync->{h2_special_guessed}{$h1_special} ) |
| 4871 | ) { |
| 4872 | # special_guessed on host2 |
| 4873 | $h2_fold = $mysync->{h2_special_guessed}{$h1_special} ; |
| 4874 | $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; |
| 4875 | next ; |
| 4876 | } |
| 4877 | # Case 3: no special on host1, special on host2 |
| 4878 | if ( ( not $h1_special ) |
| 4879 | and ( $h1_special_guessed ) |
| 4880 | and ( exists $mysync->{h2_special}{$h1_special_guessed} ) |
| 4881 | ) { |
| 4882 | $h2_fold = $mysync->{h2_special}{$h1_special_guessed} ; |
| 4883 | $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; |
| 4884 | next ; |
| 4885 | } |
| 4886 | # Case 4: no special on both sides. |
| 4887 | if ( ( not $h1_special ) |
| 4888 | and ( $h1_special_guessed ) |
| 4889 | and ( not exists $mysync->{h2_special}{$h1_special_guessed} ) |
| 4890 | and ( exists $mysync->{h2_special_guessed}{$h1_special_guessed} ) |
| 4891 | ) { |
| 4892 | $h2_fold = $mysync->{h2_special_guessed}{$h1_special_guessed} ; |
| 4893 | $mysync->{f1f2auto}{ $h1_fold } = $h2_fold ; |
| 4894 | next ; |
| 4895 | } |
| 4896 | } |
| 4897 | return( $mysync->{f1f2auto} ) ; |
| 4898 | } |
| 4899 | |
| 4900 | # I will not add what there is at: |
| 4901 | # http://stackoverflow.com/questions/2185391/localized-gmail-imap-folders/2185548#2185548 |
| 4902 | # because it works well without |
| 4903 | sub build_possible_special |
| 4904 | { |
| 4905 | my $mysync = shift ; |
| 4906 | my $possible_special = { } ; |
| 4907 | # All|Archive|Drafts|Flagged|Junk|Sent|Trash |
| 4908 | |
| 4909 | $possible_special->{'\All'} = [ 'All', 'All Messages', '&BBIEQQQ1-' ] ; |
| 4910 | $possible_special->{'\Archive'} = [ 'Archive', 'Archives', '&BBAEQARFBDgEMg-' ] ; |
| 4911 | $possible_special->{'\Drafts'} = [ 'Drafts', 'DRAFTS', '&BCcENQRABD0EPgQyBDgEOgQ4-', 'Szkice', 'Wersje robocze' ] ; |
| 4912 | $possible_special->{'\Flagged'} = [ 'Flagged', 'Starred', '&BB8EPgQ8BDUERwQ1BD0EPQRLBDU-' ] ; |
| 4913 | $possible_special->{'\Junk'} = [ 'Junk', 'junk', 'Spam', 'SPAM', '&BCEEPwQwBDw-', |
| 4914 | 'Potwierdzony spam', 'Wiadomo&AVs-ci-&AVs-mieci', |
| 4915 | 'Junk E-Mail', 'Junk Email'] ; |
| 4916 | $possible_special->{'\Sent'} = [ 'Sent', 'Sent Messages', 'Sent Items', |
| 4917 | 'Gesendete Elemente', 'Gesendete Objekte', |
| 4918 | '&AMk-l&AOk-ments envoy&AOk-s', 'Envoy&AOk-', 'Objets envoy&AOk-s', |
| 4919 | 'Elementos enviados', |
| 4920 | '&kAFP4W4IMH8wojCkMMYw4A-', |
| 4921 | '&BB4EQgQ,BEAEMAQyBDsENQQ9BD0ESwQ1-', |
| 4922 | 'Elementy wys&AUI-ane'] ; |
| 4923 | $possible_special->{'\Trash'} = [ 'Trash', 'TRASH', |
| 4924 | '&BCMENAQwBDsENQQ9BD0ESwQ1-', '&BBoEPgRABDcEOAQ9BDA-', |
| 4925 | 'Kosz', |
| 4926 | 'Deleted Items', 'Deleted Messages' ] ; |
| 4927 | |
| 4928 | |
| 4929 | foreach my $special ( qw( \All \Archive \Drafts \Flagged \Junk \Sent \Trash ) ){ |
| 4930 | foreach my $possible_folder ( @{ $possible_special->{$special} } ) { |
| 4931 | $possible_special->{ $possible_folder } = $special ; |
| 4932 | } ; |
| 4933 | } |
| 4934 | $mysync->{possible_special} = $possible_special ; |
| 4935 | $mysync->{ debug } and myprint( Data::Dumper->Dump( [ $possible_special ], [ 'possible_special' ] ) ) ; |
| 4936 | return( $possible_special ) ; |
| 4937 | } |
| 4938 | |
| 4939 | sub tests_special_from_folders_hash |
| 4940 | { |
| 4941 | note( 'Entering tests_special_from_folders_hash()' ) ; |
| 4942 | |
| 4943 | my $mysync = {} ; |
| 4944 | require_ok( "Test::MockObject" ) ; |
| 4945 | my $imapT = Test::MockObject->new( ) ; |
| 4946 | |
| 4947 | is( undef, special_from_folders_hash( ), 'special_from_folders_hash: no args' ) ; |
| 4948 | is( undef, special_from_folders_hash( $mysync ), 'special_from_folders_hash: undef args' ) ; |
| 4949 | is_deeply( {}, special_from_folders_hash( $mysync, $imapT ), 'special_from_folders_hash: $imap void' ) ; |
| 4950 | |
| 4951 | $imapT->mock( 'folders_hash', sub { return( [ { name => 'Sent', attrs => [ '\Sent' ] } ] ) } ) ; |
| 4952 | |
| 4953 | is_deeply( { Sent => '\Sent', '\Sent' => 'Sent' }, |
| 4954 | special_from_folders_hash( $mysync, $imapT ), 'special_from_folders_hash: $imap \Sent' ) ; |
| 4955 | |
| 4956 | note( 'Leaving tests_special_from_folders_hash()' ) ; |
| 4957 | return( ) ; |
| 4958 | } |
| 4959 | |
| 4960 | sub special_from_folders_hash |
| 4961 | { |
| 4962 | my ( $mysync, $imap, $side ) = @_ ; |
| 4963 | my %special = ( ) ; |
| 4964 | |
| 4965 | if ( ! defined $imap ) { return ; } |
| 4966 | $side = defined $side ? $side : 'Host?' ; |
| 4967 | |
| 4968 | if ( ! $imap->can( 'folders_hash' ) ) { |
| 4969 | my $error = "$side: To have automagic rfc6154 folder mapping, upgrade Mail::IMAPClient >= 3.34\n" ; |
| 4970 | errors_incr( $mysync, $error ) ; |
| 4971 | return( \%special ) ; # empty hash ref |
| 4972 | } |
| 4973 | my $folders_hash = $imap->folders_hash( ) ; |
| 4974 | foreach my $fhash (@{ $folders_hash } ) { |
| 4975 | my @special = grep { /\\(?:All|Archive|Drafts|Flagged|Junk|Sent|Trash)/x } @{ $fhash->{attrs} } ; |
| 4976 | if ( @special ) { |
| 4977 | my $special = $special[0] ; # keep first one. Could be not very good. |
| 4978 | if ( exists $special{ $special } ) { |
| 4979 | myprintf( "%s: special %-20s = %s already assigned to %s\n", |
| 4980 | $side, $fhash->{name}, join( q{ }, @special ), $special{ $special } ) ; |
| 4981 | }else{ |
| 4982 | myprintf( "%s: special %-20s = %s\n", |
| 4983 | $side, $fhash->{name}, join( q{ }, @special ) ) ; |
| 4984 | $special{ $special } = $fhash->{name} ; |
| 4985 | $special{ $fhash->{name} } = $special ; # double entry value => key |
| 4986 | } |
| 4987 | } |
| 4988 | } |
| 4989 | myprint( "\n" ) if ( %special ) ; |
| 4990 | return( \%special ) ; |
| 4991 | } |
| 4992 | |
| 4993 | sub errors_incr |
| 4994 | { |
| 4995 | my ( $mysync, @error ) = @ARG ; |
| 4996 | $mysync->{nb_errors}++ ; |
| 4997 | |
| 4998 | if ( @error ) { |
| 4999 | errors_log( $mysync, @error ) ; |
| 5000 | myprint( @error ) ; |
| 5001 | } |
| 5002 | |
| 5003 | $mysync->{errorsmax} ||= $ERRORS_MAX ; |
| 5004 | if ( $mysync->{nb_errors} >= $mysync->{errorsmax} ) { |
| 5005 | myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). Exiting.\n" ) ; |
| 5006 | if ( $mysync->{errorsdump} ) { |
| 5007 | myprint( errorsdump( $mysync->{nb_errors}, errors_log( $mysync ) ) ) ; |
| 5008 | # again since errorsdump( ) can be very verbose and masquerade previous warning |
| 5009 | myprint( "Maximum number of errors $mysync->{errorsmax} reached ( you can change $mysync->{errorsmax} to any value, for example 100 with --errorsmax 100 ). Exiting.\n" ) ; |
| 5010 | } |
| 5011 | exit_clean( $mysync, $EXIT_WITH_ERRORS_MAX ) ; |
| 5012 | } |
| 5013 | return ; |
| 5014 | } |
| 5015 | |
| 5016 | sub tests_errors_log |
| 5017 | { |
| 5018 | note( 'Entering tests_errors_log()' ) ; |
| 5019 | is( undef, errors_log( ), 'errors_log: no args => undef' ) ; |
| 5020 | my $mysync = {} ; |
| 5021 | is( undef, errors_log( $mysync ), 'errors_log: empty => undef' ) ; |
| 5022 | is_deeply( [ 'aieaie' ], [ errors_log( $mysync, 'aieaie' ) ], 'errors_log: aieaie => aieaie' ) ; |
| 5023 | # cumulative |
| 5024 | is_deeply( [ 'aieaie' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie' ) ; |
| 5025 | is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync, 'ouille' ) ], 'errors_log: ouille => aieaie ouille' ) ; |
| 5026 | is_deeply( [ 'aieaie', 'ouille' ], [ errors_log( $mysync ) ], 'errors_log: nothing more => aieaie ouille' ) ; |
| 5027 | note( 'Leaving tests_errors_log()' ) ; |
| 5028 | return ; |
| 5029 | } |
| 5030 | |
| 5031 | sub errors_log |
| 5032 | { |
| 5033 | my ( $mysync, @error ) = @ARG ; |
| 5034 | |
| 5035 | if ( ! $mysync->{errors_log} ) { |
| 5036 | $mysync->{errors_log} = [] ; |
| 5037 | } |
| 5038 | |
| 5039 | if ( @error ) { |
| 5040 | push @{ $mysync->{errors_log} }, join( q{}, @error ) ; |
| 5041 | } |
| 5042 | if ( @{ $mysync->{errors_log} } ) { |
| 5043 | return @{ $mysync->{errors_log} } ; |
| 5044 | } |
| 5045 | else { |
| 5046 | return ; |
| 5047 | } |
| 5048 | } |
| 5049 | |
| 5050 | |
| 5051 | sub errorsdump |
| 5052 | { |
| 5053 | my( $nb_errors, @errors_log ) = @ARG ; |
| 5054 | my $error_num = 0 ; |
| 5055 | my $errors_list = q{} ; |
| 5056 | if ( @errors_log ) { |
| 5057 | $errors_list = "++++ Listing $nb_errors errors encountered during the sync ( avoid this listing with --noerrorsdump ).\n" ; |
| 5058 | foreach my $error ( @errors_log ) { |
| 5059 | $error_num++ ; |
| 5060 | $errors_list .= "Err $error_num/$nb_errors: $error" ; |
| 5061 | } |
| 5062 | } |
| 5063 | return( $errors_list ) ; |
| 5064 | } |
| 5065 | |
| 5066 | |
| 5067 | sub tests_live_result |
| 5068 | { |
| 5069 | note( 'Entering tests_live_result()' ) ; |
| 5070 | |
| 5071 | my $nb_errors = shift ; |
| 5072 | if ( $nb_errors ) { |
| 5073 | myprint( "Live tests failed with $nb_errors errors\n" ) ; |
| 5074 | } else { |
| 5075 | myprint( "Live tests ended successfully\n" ) ; |
| 5076 | } |
| 5077 | note( 'Leaving tests_live_result()' ) ; |
| 5078 | return ; |
| 5079 | } |
| 5080 | |
| 5081 | |
| 5082 | sub size_filtered_flag |
| 5083 | { |
| 5084 | my $mysync = shift ; |
| 5085 | my $h1_size = shift ; |
| 5086 | |
| 5087 | if ( defined $mysync->{ maxsize } and $h1_size >= $mysync->{ maxsize } ) { |
| 5088 | return( 1 ) ; |
| 5089 | } |
| 5090 | if ( defined $minsize and $h1_size <= $minsize ) { |
| 5091 | return( 1 ) ; |
| 5092 | } |
| 5093 | return( 0 ) ; |
| 5094 | } |
| 5095 | |
| 5096 | sub sync_flags_fir |
| 5097 | { |
| 5098 | my ( $mysync, $h1_fold, $h1_msg, $h2_fold, $h2_msg, $permanentflags2, $h1_fir_ref, $h2_fir_ref ) = @_ ; |
| 5099 | |
| 5100 | if ( not defined $h1_msg ) { return } ; |
| 5101 | if ( not defined $h2_msg ) { return } ; |
| 5102 | |
| 5103 | my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} ; |
| 5104 | return if size_filtered_flag( $mysync, $h1_size ) ; |
| 5105 | |
| 5106 | # used cached flag values for efficiency |
| 5107 | my $h1_flags = $h1_fir_ref->{ $h1_msg }->{ 'FLAGS' } || q{} ; |
| 5108 | my $h2_flags = $h2_fir_ref->{ $h2_msg }->{ 'FLAGS' } || q{} ; |
| 5109 | |
| 5110 | sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ; |
| 5111 | |
| 5112 | return ; |
| 5113 | } |
| 5114 | |
| 5115 | sub sync_flags_after_copy |
| 5116 | { |
| 5117 | # Activated with option --syncflagsaftercopy |
| 5118 | my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $permanentflags2 ) = @_ ; |
| 5119 | |
| 5120 | if ( my @h2_flags = $mysync->{imap2}->flags( $h2_msg ) ) { |
| 5121 | my $h2_flags = "@h2_flags" ; |
| 5122 | ( $mysync->{ debug } or $debugflags ) and myprint( "Host2: msg $h2_fold/$h2_msg flags before sync flags after copy ( $h2_flags )\n" ) ; |
| 5123 | sync_flags( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) ; |
| 5124 | }else{ |
| 5125 | myprint( "Host2: msg $h2_fold/$h2_msg could not get its flags for sync flags after copy\n" ) ; |
| 5126 | } |
| 5127 | return ; |
| 5128 | } |
| 5129 | |
| 5130 | # Globals |
| 5131 | # $debug |
| 5132 | # $debugflags |
| 5133 | # $permanentflags2 |
| 5134 | |
| 5135 | |
| 5136 | sub sync_flags |
| 5137 | { |
| 5138 | my( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $h2_msg, $h2_flags, $permanentflags2 ) = @_ ; |
| 5139 | |
| 5140 | ( $mysync->{ debug } or $debugflags ) and |
| 5141 | myprint( "Host1: flags init msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ; |
| 5142 | |
| 5143 | $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ; |
| 5144 | |
| 5145 | $h2_flags = flagscase( $h2_flags ) ; |
| 5146 | |
| 5147 | ( $mysync->{ debug } or $debugflags ) and |
| 5148 | myprint( "Host1: flags filt msg $h1_fold/$h1_msg flags( $h1_flags ) Host2 msg $h2_fold/$h2_msg flags( $h2_flags )\n" ) ; |
| 5149 | |
| 5150 | |
| 5151 | # compare flags - set flags if there a difference |
| 5152 | my @h1_flags = sort split(q{ }, $h1_flags ); |
| 5153 | my @h2_flags = sort split(q{ }, $h2_flags ); |
| 5154 | my $diff = compare_lists( \@h1_flags, \@h2_flags ); |
| 5155 | |
| 5156 | $diff and ( $mysync->{ debug } or $debugflags ) |
| 5157 | and myprint( "Host2: flags msg $h2_fold/$h2_msg replacing h2 flags( $h2_flags ) with h1 flags( $h1_flags )\n" ) ; |
| 5158 | |
| 5159 | # This sets flags exactly. So flags can be removed with this. |
| 5160 | # When you remove a \Seen flag on host1 you want it |
| 5161 | # to be removed on host2. Just add flags is not what |
| 5162 | # we need most of the time, so no + like in "+FLAGS.SILENT". |
| 5163 | |
| 5164 | if ( not $mysync->{dry} and $diff and not $mysync->{imap2}->store( $h2_msg, "FLAGS.SILENT (@h1_flags)" ) ) { |
| 5165 | my $error_msg = join q{}, "Host2: flags msg $h2_fold/$h2_msg could not add flags [@h1_flags]: ", |
| 5166 | $mysync->{imap2}->LastError || q{}, "\n" ; |
| 5167 | errors_incr( $mysync, $error_msg ) ; |
| 5168 | } |
| 5169 | |
| 5170 | return ; |
| 5171 | } |
| 5172 | |
| 5173 | |
| 5174 | |
| 5175 | sub _filter |
| 5176 | { |
| 5177 | my $mysync = shift ; |
| 5178 | my $str = shift or return q{} ; |
| 5179 | my $sz = $SIZE_MAX_STR ; |
| 5180 | my $len = length $str ; |
| 5181 | if ( not $mysync->{ debug } and $len > $sz*2 ) { |
| 5182 | my $beg = substr $str, 0, $sz ; |
| 5183 | my $end = substr $str, -$sz, $sz ; |
| 5184 | $str = $beg . '...' . $end ; |
| 5185 | } |
| 5186 | $str =~ s/\012?\015$//x ; |
| 5187 | return "(len=$len) " . $str ; |
| 5188 | } |
| 5189 | |
| 5190 | |
| 5191 | |
| 5192 | sub lost_connection |
| 5193 | { |
| 5194 | my( $mysync, $imap, $error_message ) = @_; |
| 5195 | if ( $imap->IsUnconnected( ) ) { |
| 5196 | $mysync->{nb_errors}++ ; |
| 5197 | my $lcomm = $imap->LastIMAPCommand || q{} ; |
| 5198 | my $einfo = $imap->LastError || @{$imap->History}[$LAST] || q{} ; |
| 5199 | |
| 5200 | # if string is long try reduce to a more reasonable size |
| 5201 | $lcomm = _filter( $mysync, $lcomm ) ; |
| 5202 | $einfo = _filter( $mysync, $einfo ) ; |
| 5203 | myprint( "Failure: last command: $lcomm\n") if ( $mysync->{ debug } && $lcomm) ; |
| 5204 | myprint( "Failure: lost connection $error_message: ", $einfo, "\n") ; |
| 5205 | return( 1 ) ; |
| 5206 | } |
| 5207 | else{ |
| 5208 | return( 0 ) ; |
| 5209 | } |
| 5210 | } |
| 5211 | |
| 5212 | sub tests_max |
| 5213 | { |
| 5214 | note( 'Entering tests_max()' ) ; |
| 5215 | |
| 5216 | is( 0, max( 0 ), 'max 0 => 0' ) ; |
| 5217 | is( 1, max( 1 ), 'max 1 => 1' ) ; |
| 5218 | is( $MINUS_ONE, max( $MINUS_ONE ), 'max -1 => -1') ; |
| 5219 | is( undef, max( ), 'max no arg => undef' ) ; |
| 5220 | is( undef, max( undef ), 'undef => undef' ) ; |
| 5221 | is( undef, max( undef, undef ), 'undef, undef => undef' ) ; |
| 5222 | |
| 5223 | is( $NUMBER_100, max( 1, $NUMBER_100 ), 'max 1 100 => 100' ) ; |
| 5224 | is( $NUMBER_100, max( $NUMBER_100, 1 ), 'max 100 1 => 100' ) ; |
| 5225 | is( $NUMBER_100, max( $NUMBER_100, $NUMBER_42, 1 ), 'max 100 42 1 => 100' ) ; |
| 5226 | is( $NUMBER_100, max( $NUMBER_100, '42', 1 ), 'max 100 42 1 => 100' ) ; |
| 5227 | is( $NUMBER_100, max( '100', '42', 1 ), 'max 100 42 1 => 100' ) ; |
| 5228 | is( $NUMBER_100, max( $NUMBER_100, 'haha', 1 ), 'max 100 haha 1 => 100') ; |
| 5229 | is( $NUMBER_100, max( 'bb', $NUMBER_100, 'haha' ), 'max bb 100 haha => 100') ; |
| 5230 | is( $MINUS_ONE, max( q{}, $MINUS_ONE, 'haha' ), 'max "" -1 haha => -1') ; |
| 5231 | is( $MINUS_ONE, max( q{}, $MINUS_ONE, $MINUS_TWO ), 'max "" -1 -2 => -1') ; |
| 5232 | is( $MINUS_ONE, max( 'haha', $MINUS_ONE, $MINUS_TWO ), 'max haha -1 -2 => -1') ; |
| 5233 | is( 1, max( $MINUS_ONE, 1 ), 'max -1 1 => 1') ; |
| 5234 | is( 1, max( undef, 1 ), 'max undef 1 => 1' ) ; |
| 5235 | is( 0, max( undef, 0 ), 'max undef 0 => 0' ) ; |
| 5236 | is( 'haha', max( 'haha' ), 'max haha => haha') ; |
| 5237 | is( 'bb', max( 'aa', 'bb' ), 'max aa bb => bb') ; |
| 5238 | is( 'bb', max( 'bb', 'aa' ), 'max bb aa => bb') ; |
| 5239 | is( 'bb', max( 'bb', 'aa', 'bb' ), 'max bb aa bb => bb') ; |
| 5240 | note( 'Leaving tests_max()' ) ; |
| 5241 | return ; |
| 5242 | } |
| 5243 | |
| 5244 | sub max |
| 5245 | { |
| 5246 | my @list = @_ ; |
| 5247 | return( undef ) if ( 0 == scalar @list ) ; |
| 5248 | |
| 5249 | my( @numbers, @notnumbers ) ; |
| 5250 | foreach my $item ( @list ) |
| 5251 | { |
| 5252 | if ( is_number( $item ) ) |
| 5253 | { |
| 5254 | push @numbers, $item ; |
| 5255 | } |
| 5256 | elsif ( defined $item ) |
| 5257 | { |
| 5258 | push @notnumbers, $item ; |
| 5259 | } |
| 5260 | } |
| 5261 | |
| 5262 | my @sorted ; |
| 5263 | |
| 5264 | if ( @numbers ) |
| 5265 | { |
| 5266 | @sorted = sort { $a <=> $b } @numbers ; |
| 5267 | } |
| 5268 | elsif ( @notnumbers ) |
| 5269 | { |
| 5270 | @sorted = sort { $a cmp $b } @notnumbers ; |
| 5271 | } |
| 5272 | else |
| 5273 | { |
| 5274 | return ; |
| 5275 | } |
| 5276 | |
| 5277 | return( pop @sorted ) ; |
| 5278 | } |
| 5279 | |
| 5280 | sub tests_is_number |
| 5281 | { |
| 5282 | note( 'Entering tests_is_number()' ) ; |
| 5283 | |
| 5284 | is( undef, is_number( ), 'is_number: no args => undef ' ) ; |
| 5285 | is( undef, is_number( undef ), 'is_number: undef => undef ' ) ; |
| 5286 | ok( is_number( 1 ), 'is_number: 1 => 1' ) ; |
| 5287 | ok( is_number( 1.1 ), 'is_number: 1.1 => 1' ) ; |
| 5288 | ok( is_number( 0 ), 'is_number: 0 => 1' ) ; |
| 5289 | ok( is_number( -1 ), 'is_number: -1 => 1' ) ; |
| 5290 | ok( ! is_number( 1.1.1 ), 'is_number: 1.1.1 => no' ) ; |
| 5291 | ok( ! is_number( q{} ), 'is_number: q{} => no' ) ; |
| 5292 | ok( ! is_number( 'haha' ), 'is_number: haha => no' ) ; |
| 5293 | ok( ! is_number( '0haha' ), 'is_number: 0haha => no' ) ; |
| 5294 | ok( ! is_number( '2haha' ), 'is_number: 2haha => no' ) ; |
| 5295 | ok( ! is_number( 'haha2' ), 'is_number: haha2 => no' ) ; |
| 5296 | |
| 5297 | note( 'Leaving tests_is_number()' ) ; |
| 5298 | return ; |
| 5299 | } |
| 5300 | |
| 5301 | |
| 5302 | |
| 5303 | sub is_number |
| 5304 | { |
| 5305 | my $item = shift ; |
| 5306 | |
| 5307 | if ( ! defined $item ) { return ; } |
| 5308 | |
| 5309 | if ( $item =~ /\A$RE{num}{real}\Z/ ) { |
| 5310 | return 1 ; |
| 5311 | } |
| 5312 | return ; |
| 5313 | } |
| 5314 | |
| 5315 | sub tests_min |
| 5316 | { |
| 5317 | note( 'Entering tests_min()' ) ; |
| 5318 | |
| 5319 | is( 0, min( 0 ), 'min 0 => 0' ) ; |
| 5320 | is( 1, min( 1 ), 'min 1 => 1' ) ; |
| 5321 | is( $MINUS_ONE, min( $MINUS_ONE ), 'min -1 => -1' ) ; |
| 5322 | is( undef, min( ), 'min no arg => undef' ) ; |
| 5323 | is( 1, min( 1, $NUMBER_100 ), 'min 1 100 => 1' ) ; |
| 5324 | is( 1, min( $NUMBER_100, 1 ), 'min 100 1 => 1' ) ; |
| 5325 | is( 1, min( $NUMBER_100, $NUMBER_42, 1 ), 'min 100 42 1 => 1' ) ; |
| 5326 | is( 1, min( $NUMBER_100, '42', 1 ), 'min 100 42 1 => 1' ) ; |
| 5327 | is( 1, min( '100', '42', 1 ), 'min 100 42 1 => 1' ) ; |
| 5328 | is( 1, min( $NUMBER_100, 'haha', 1 ), 'min 100 haha 1 => 1') ; |
| 5329 | is( $MINUS_ONE, min( $MINUS_ONE, 1 ), 'min -1 1 => -1') ; |
| 5330 | |
| 5331 | is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ; |
| 5332 | is( 0, min( undef, 0 ), 'min undef 0 => 0' ) ; |
| 5333 | is( 1, min( undef, 1 ), 'min undef 1 => 1' ) ; |
| 5334 | is( 0, min( undef, 2, 0, 1 ), 'min undef, 2, 0, 1 => 0' ) ; |
| 5335 | |
| 5336 | is( 'haha', min( 'haha' ), 'min haha => haha') ; |
| 5337 | is( 'aa', min( 'aa', 'bb' ), 'min aa bb => aa') ; |
| 5338 | is( 'aa', min( 'bb', 'aa' ), 'min bb aa bb => aa') ; |
| 5339 | is( 'aa', min( 'bb', 'aa', 'bb' ), 'min bb aa bb => aa') ; |
| 5340 | |
| 5341 | note( 'Leaving tests_min()' ) ; |
| 5342 | return ; |
| 5343 | } |
| 5344 | |
| 5345 | |
| 5346 | sub min |
| 5347 | { |
| 5348 | my @list = @_ ; |
| 5349 | return( undef ) if ( 0 == scalar @list ) ; |
| 5350 | |
| 5351 | my( @numbers, @notnumbers ) ; |
| 5352 | foreach my $item ( @list ) { |
| 5353 | if ( is_number( $item ) ) { |
| 5354 | push @numbers, $item ; |
| 5355 | }else{ |
| 5356 | push @notnumbers, $item ; |
| 5357 | } |
| 5358 | } |
| 5359 | |
| 5360 | my @sorted ; |
| 5361 | if ( @numbers ) { |
| 5362 | @sorted = sort { $a <=> $b } @numbers ; |
| 5363 | }elsif( @notnumbers ) { |
| 5364 | @sorted = sort { $a cmp $b } @notnumbers ; |
| 5365 | }else{ |
| 5366 | return ; |
| 5367 | } |
| 5368 | |
| 5369 | return( shift @sorted ) ; |
| 5370 | } |
| 5371 | |
| 5372 | |
| 5373 | sub check_lib_version |
| 5374 | { |
| 5375 | my $mysync = shift ; |
| 5376 | $mysync->{ debug } and myprint( "IMAPClient $Mail::IMAPClient::VERSION\n" ) ; |
| 5377 | if ( '2.2.9' eq $Mail::IMAPClient::VERSION ) { |
| 5378 | myprint( "imapsync no longer supports Mail::IMAPClient 2.2.9, upgrade it\n" ) ; |
| 5379 | return 0 ; |
| 5380 | } |
| 5381 | else{ |
| 5382 | # 3.x.x is no longer buggy with imapsync. |
| 5383 | # 3.30 or currently superior is imposed in the Perl "use Mail::IMAPClient line". |
| 5384 | return 1 ; |
| 5385 | } |
| 5386 | return ; |
| 5387 | } |
| 5388 | |
| 5389 | sub module_version_str |
| 5390 | { |
| 5391 | my( $module_name, $module_version ) = @_ ; |
| 5392 | my $str = mysprintf( "%-20s %s\n", $module_name, $module_version ) ; |
| 5393 | return( $str ) ; |
| 5394 | } |
| 5395 | |
| 5396 | sub modulesversion |
| 5397 | { |
| 5398 | |
| 5399 | my @list_version; |
| 5400 | |
| 5401 | my %modulesversion = ( |
| 5402 | 'Authen::NTLM' => sub { $Authen::NTLM::VERSION }, |
| 5403 | 'CGI' => sub { $CGI::VERSION }, |
| 5404 | 'Compress::Zlib' => sub { $Compress::Zlib::VERSION }, |
| 5405 | 'Crypt::OpenSSL::RSA' => sub { $Crypt::OpenSSL::RSA::VERSION }, |
| 5406 | 'Data::Uniqid' => sub { $Data::Uniqid::VERSION }, |
| 5407 | 'Digest::HMAC_MD5' => sub { $Digest::HMAC_MD5::VERSION }, |
| 5408 | 'Digest::HMAC_SHA1' => sub { $Digest::HMAC_SHA1::VERSION }, |
| 5409 | 'Digest::MD5' => sub { $Digest::MD5::VERSION }, |
| 5410 | 'Encode' => sub { $Encode::VERSION }, |
| 5411 | 'Encode::IMAPUTF7' => sub { $Encode::IMAPUTF7::VERSION }, |
| 5412 | 'File::Copy::Recursive' => sub { $File::Copy::Recursive::VERSION }, |
| 5413 | 'File::Spec' => sub { $File::Spec::VERSION }, |
| 5414 | 'Getopt::Long' => sub { $Getopt::Long::VERSION }, |
| 5415 | 'HTML::Entities' => sub { $HTML::Entities::VERSION }, |
| 5416 | 'IO::Socket' => sub { $IO::Socket::VERSION }, |
| 5417 | 'IO::Socket::INET' => sub { $IO::Socket::INET::VERSION }, |
| 5418 | 'IO::Socket::INET6' => sub { $IO::Socket::INET6::VERSION }, |
| 5419 | 'IO::Socket::IP' => sub { $IO::Socket::IP::VERSION }, |
| 5420 | 'IO::Socket::SSL' => sub { $IO::Socket::SSL::VERSION }, |
| 5421 | 'IO::Tee' => sub { $IO::Tee::VERSION }, |
| 5422 | 'JSON' => sub { $JSON::VERSION }, |
| 5423 | 'JSON::WebToken' => sub { $JSON::WebToken::VERSION }, |
| 5424 | 'LWP' => sub { $LWP::VERSION }, |
| 5425 | 'Mail::IMAPClient' => sub { $Mail::IMAPClient::VERSION }, |
| 5426 | 'MIME::Base64' => sub { $MIME::Base64::VERSION }, |
| 5427 | 'Net::Ping' => sub { $Net::Ping::VERSION }, |
| 5428 | 'Net::SSLeay' => sub { $Net::SSLeay::VERSION }, |
| 5429 | 'Term::ReadKey' => sub { $Term::ReadKey::VERSION }, |
| 5430 | 'Test::MockObject' => sub { $Test::MockObject::VERSION }, |
| 5431 | 'Time::HiRes' => sub { $Time::HiRes::VERSION }, |
| 5432 | 'Unicode::String' => sub { $Unicode::String::VERSION }, |
| 5433 | 'URI::Escape' => sub { $URI::Escape::VERSION }, |
| 5434 | #'Lalala' => sub { $Lalala::VERSION }, |
| 5435 | ) ; |
| 5436 | |
| 5437 | foreach my $module_name ( sort keys %modulesversion ) { |
| 5438 | # trick from http://www.perlmonks.org/?node_id=152122 |
| 5439 | my $file_name = $module_name . '.pm' ; |
| 5440 | $file_name =~s,::,/,xmgs; # Foo::Bar::Baz => Foo/Bar/Baz.pm |
| 5441 | my $v ; |
| 5442 | eval { |
| 5443 | require $file_name ; |
| 5444 | $v = defined $modulesversion{ $module_name } ? $modulesversion{ $module_name }->() : q{?} ; |
| 5445 | } or $v = q{Not installed} ; |
| 5446 | |
| 5447 | push @list_version, module_version_str( $module_name, $v ) ; |
| 5448 | } |
| 5449 | return( @list_version ) ; |
| 5450 | } |
| 5451 | |
| 5452 | |
| 5453 | sub tests_command_line_nopassword |
| 5454 | { |
| 5455 | note( 'Entering tests_command_line_nopassword()' ) ; |
| 5456 | |
| 5457 | ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' ); |
| 5458 | my $mysync = {} ; |
| 5459 | ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla' ), 'command_line_nopassword --blabla' ); |
| 5460 | #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ; |
| 5461 | ok( '--password1 MASKED' eq command_line_nopassword( $mysync, qw{ --password1 secret1}), 'command_line_nopassword --password1' ); |
| 5462 | ok( '--blabla --password1 MASKED --blibli' |
| 5463 | eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' ); |
| 5464 | $mysync->{showpasswords} = 1 ; |
| 5465 | ok( q{} eq command_line_nopassword(), 'command_line_nopassword void' ); |
| 5466 | ok( '--blabla' eq command_line_nopassword( $mysync, '--blabla'), 'command_line_nopassword --blabla' ); |
| 5467 | #myprint( command_line_nopassword((qw{ --password1 secret1 })), "\n" ) ; |
| 5468 | ok( '--password1 secret1' eq command_line_nopassword( $mysync, qw{ --password1 secret1} ), 'command_line_nopassword --password1' ); |
| 5469 | ok( '--blabla --password1 secret1 --blibli' |
| 5470 | eq command_line_nopassword( $mysync, qw{ --blabla --password1 secret1 --blibli } ), 'command_line_nopassword --password1 --blibli' ); |
| 5471 | |
| 5472 | note( 'Leaving tests_command_line_nopassword()' ) ; |
| 5473 | return ; |
| 5474 | } |
| 5475 | |
| 5476 | # Construct a command line copy with passwords replaced by MASKED. |
| 5477 | sub command_line_nopassword |
| 5478 | { |
| 5479 | my $mysync = shift @ARG ; |
| 5480 | my @argv = @ARG ; |
| 5481 | my @argv_nopassword ; |
| 5482 | |
| 5483 | if ( $mysync->{ cmdcgi } ) { |
| 5484 | @argv_nopassword = mask_password_value( @{ $mysync->{ cmdcgi } } ) ; |
| 5485 | return( "@argv_nopassword" ) ; |
| 5486 | } |
| 5487 | |
| 5488 | if ( $mysync->{showpasswords} ) |
| 5489 | { |
| 5490 | return( "@argv" ) ; |
| 5491 | } |
| 5492 | |
| 5493 | @argv_nopassword = mask_password_value( @argv ) ; |
| 5494 | return("@argv_nopassword") ; |
| 5495 | } |
| 5496 | |
| 5497 | sub mask_password_value |
| 5498 | { |
| 5499 | my @argv = @ARG ; |
| 5500 | my @argv_nopassword ; |
| 5501 | while ( @argv ) { |
| 5502 | my $arg = shift @argv ; # option name or value |
| 5503 | if ( $arg =~ m/-password[12]/x ) { |
| 5504 | shift @argv ; # password value |
| 5505 | push @argv_nopassword, $arg, 'MASKED' ; # option name and fake value |
| 5506 | }else{ |
| 5507 | push @argv_nopassword, $arg ; # same option or value |
| 5508 | } |
| 5509 | } |
| 5510 | return @argv_nopassword ; |
| 5511 | } |
| 5512 | |
| 5513 | |
| 5514 | sub tests_get_stdin_masked |
| 5515 | { |
| 5516 | note( 'Entering tests_get_stdin_masked()' ) ; |
| 5517 | |
| 5518 | is( q{}, get_stdin_masked( ), 'get_stdin_masked: no args' ) ; |
| 5519 | is( q{}, get_stdin_masked( 'Please ENTER: ' ), 'get_stdin_masked: ENTER' ) ; |
| 5520 | |
| 5521 | note( 'Leaving tests_get_stdin_masked()' ) ; |
| 5522 | return ; |
| 5523 | } |
| 5524 | |
| 5525 | ####################################################### |
| 5526 | # The issue is that prompt() does not prompt the prompt |
| 5527 | # when the program is used like |
| 5528 | # { sleep 2 ; echo blablabla ; } | ./imapsync ...--host1 lo --user1 tata --host2 lo --user2 titi |
| 5529 | |
| 5530 | # use IO::Prompter ; |
| 5531 | sub get_stdin_masked |
| 5532 | { |
| 5533 | my $prompt = shift || 'Say something: ' ; |
| 5534 | local @ARGV = () ; |
| 5535 | my $input = prompt( |
| 5536 | -prompt => $prompt, |
| 5537 | -echo => '*', |
| 5538 | ) ; |
| 5539 | #myprint( "You said: $input\n" ) ; |
| 5540 | return $input ; |
| 5541 | } |
| 5542 | |
| 5543 | sub ask_for_password_new |
| 5544 | { |
| 5545 | my $prompt = shift ; |
| 5546 | my $password = get_stdin_masked( $prompt ) ; |
| 5547 | return $password ; |
| 5548 | } |
| 5549 | ######################################################### |
| 5550 | |
| 5551 | |
| 5552 | sub ask_for_password |
| 5553 | { |
| 5554 | my $prompt = shift ; |
| 5555 | myprint( $prompt ) ; |
| 5556 | Term::ReadKey::ReadMode( 2 ) ; |
| 5557 | ## no critic (InputOutput::ProhibitExplicitStdin) |
| 5558 | my $password = <STDIN> ; |
| 5559 | chomp $password ; |
| 5560 | myprint( "\nGot it\n" ) ; |
| 5561 | Term::ReadKey::ReadMode( 0 ) ; |
| 5562 | return $password ; |
| 5563 | } |
| 5564 | |
| 5565 | # Have to refactor get_password1() get_password2() |
| 5566 | # to have only get_password() and two calls |
| 5567 | sub get_password1 |
| 5568 | { |
| 5569 | |
| 5570 | my $mysync = shift ; |
| 5571 | |
| 5572 | $mysync->{password1} |
| 5573 | || $mysync->{ passfile1 } |
| 5574 | || 'PREAUTH' eq $authmech1 |
| 5575 | || 'EXTERNAL' eq $authmech1 |
| 5576 | || $ENV{IMAPSYNC_PASSWORD1} |
| 5577 | || do |
| 5578 | { |
| 5579 | myprint( << 'FIN_PASSFILE' ) ; |
| 5580 | |
| 5581 | If you are afraid of giving password on the command line arguments, you can put the |
| 5582 | password of user1 in a file named file1 and use "--passfile1 file1" instead of typing it. |
| 5583 | Then give this file restrictive permissions with the command "chmod 600 file1". |
| 5584 | An other solution is to set the environment variable IMAPSYNC_PASSWORD1 |
| 5585 | FIN_PASSFILE |
| 5586 | my $user = $authuser1 || $mysync->{user1} ; |
| 5587 | my $host = $mysync->{host1} ; |
| 5588 | my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ; |
| 5589 | $mysync->{password1} = ask_for_password( $prompt ) ; |
| 5590 | } ; |
| 5591 | |
| 5592 | if ( defined $mysync->{ passfile1 } ) { |
| 5593 | if ( ! -e -r $mysync->{ passfile1 } ) { |
| 5594 | myprint( "Failure: file from parameter --passfile1 $mysync->{ passfile1 } does not exist or is not readable\n" ) ; |
| 5595 | $mysync->{nb_errors}++ ; |
| 5596 | exit_clean( $mysync, $EX_NOINPUT ) ; |
| 5597 | } |
| 5598 | # passfile1 readable |
| 5599 | $mysync->{password1} = firstline ( $mysync->{ passfile1 } ) ; |
| 5600 | return ; |
| 5601 | } |
| 5602 | if ( $ENV{IMAPSYNC_PASSWORD1} ) { |
| 5603 | $mysync->{password1} = $ENV{IMAPSYNC_PASSWORD1} ; |
| 5604 | return ; |
| 5605 | } |
| 5606 | return ; |
| 5607 | } |
| 5608 | |
| 5609 | sub get_password2 |
| 5610 | { |
| 5611 | |
| 5612 | my $mysync = shift ; |
| 5613 | |
| 5614 | $mysync->{password2} |
| 5615 | || $mysync->{ passfile2 } |
| 5616 | || 'PREAUTH' eq $authmech2 |
| 5617 | || 'EXTERNAL' eq $authmech2 |
| 5618 | || $ENV{IMAPSYNC_PASSWORD2} |
| 5619 | || do |
| 5620 | { |
| 5621 | myprint( << 'FIN_PASSFILE' ) ; |
| 5622 | |
| 5623 | If you are afraid of giving password on the command line arguments, you can put the |
| 5624 | password of user2 in a file named file2 and use "--passfile2 file2" instead of typing it. |
| 5625 | Then give this file restrictive permissions with the command "chmod 600 file2". |
| 5626 | An other solution is to set the environment variable IMAPSYNC_PASSWORD2 |
| 5627 | FIN_PASSFILE |
| 5628 | my $user = $authuser2 || $mysync->{user2} ; |
| 5629 | my $host = $mysync->{host2} ; |
| 5630 | my $prompt = "What's the password for $user" . ' at ' . "$host? (not visible while you type, then enter RETURN) " ; |
| 5631 | $mysync->{password2} = ask_for_password( $prompt ) ; |
| 5632 | } ; |
| 5633 | |
| 5634 | |
| 5635 | if ( defined $mysync->{ passfile2 } ) { |
| 5636 | if ( ! -e -r $mysync->{ passfile2 } ) { |
| 5637 | myprint( "Failure: file from parameter --passfile2 $mysync->{ passfile2 } does not exist or is not readable\n" ) ; |
| 5638 | $mysync->{nb_errors}++ ; |
| 5639 | exit_clean( $mysync, $EX_NOINPUT ) ; |
| 5640 | } |
| 5641 | # passfile2 readable |
| 5642 | $mysync->{password2} = firstline ( $mysync->{ passfile2 } ) ; |
| 5643 | return ; |
| 5644 | } |
| 5645 | if ( $ENV{IMAPSYNC_PASSWORD2} ) { |
| 5646 | $mysync->{password2} = $ENV{IMAPSYNC_PASSWORD2} ; |
| 5647 | return ; |
| 5648 | } |
| 5649 | return ; |
| 5650 | } |
| 5651 | |
| 5652 | |
| 5653 | |
| 5654 | |
| 5655 | sub remove_tmp_files |
| 5656 | { |
| 5657 | my $mysync = shift or return ; |
| 5658 | $mysync->{pidfile} or return ; |
| 5659 | if ( -e $mysync->{pidfile} ) { |
| 5660 | unlink $mysync->{pidfile} ; |
| 5661 | } |
| 5662 | return ; |
| 5663 | } |
| 5664 | |
| 5665 | sub cleanup_before_exit |
| 5666 | { |
| 5667 | my $mysync = shift ; |
| 5668 | remove_tmp_files( $mysync ) ; |
| 5669 | if ( $mysync->{imap1} and $mysync->{imap1}->IsConnected() ) |
| 5670 | { |
| 5671 | myprint( "Disconnecting from host1 $mysync->{ host1 } user1 $mysync->{ user1 }\n" ) ; |
| 5672 | $mysync->{imap1}->logout( ) ; |
| 5673 | } |
| 5674 | if ( $mysync->{imap2} and $mysync->{imap2}->IsConnected() ) |
| 5675 | { |
| 5676 | myprint( "Disconnecting from host2 $mysync->{ host2 } user2 $mysync->{ user2 }\n" ) ; |
| 5677 | $mysync->{imap2}->logout( ) ; |
| 5678 | } |
| 5679 | if ( $mysync->{log} ) { |
| 5680 | myprint( "Log file is $mysync->{logfile} ( to change it, use --logfile filepath ; or use --nolog to turn off logging )\n" ) ; |
| 5681 | } |
| 5682 | if ( $mysync->{log} and $mysync->{logfile_handle} ) { |
| 5683 | #myprint( "Closing $mysync->{ logfile }\n" ) ; |
| 5684 | close $mysync->{logfile_handle} ; |
| 5685 | } |
| 5686 | return ; |
| 5687 | } |
| 5688 | |
| 5689 | |
| 5690 | |
| 5691 | sub exit_clean |
| 5692 | { |
| 5693 | my $mysync = shift @ARG ; |
| 5694 | my $status = shift @ARG ; |
| 5695 | my @messages = @ARG ; |
| 5696 | if ( @messages ) |
| 5697 | { |
| 5698 | myprint( @messages ) ; |
| 5699 | } |
| 5700 | myprint( "Exiting with return value $status ($EXIT_TXT{$status}) $mysync->{nb_errors}/$mysync->{errorsmax} nb_errors/max_errors\n" ) ; |
| 5701 | cleanup_before_exit( $mysync ) ; |
| 5702 | |
| 5703 | exit $status ; |
| 5704 | } |
| 5705 | |
| 5706 | sub missing_option |
| 5707 | { |
| 5708 | my $mysync = shift ; |
| 5709 | my $option = shift ; |
| 5710 | $mysync->{nb_errors}++ ; |
| 5711 | exit_clean( $mysync, $EX_USAGE, "$option option is mandatory, for help run $PROGRAM_NAME --help\n" ) ; |
| 5712 | return ; |
| 5713 | } |
| 5714 | |
| 5715 | |
| 5716 | sub catch_ignore |
| 5717 | { |
| 5718 | my $mysync = shift ; |
| 5719 | my $signame = shift ; |
| 5720 | |
| 5721 | my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; |
| 5722 | myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), |
| 5723 | "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; |
| 5724 | stats( $mysync ) ; |
| 5725 | return ; |
| 5726 | } |
| 5727 | |
| 5728 | |
| 5729 | sub catch_exit |
| 5730 | { |
| 5731 | my $mysync = shift ; |
| 5732 | my $signame = shift || q{} ; |
| 5733 | if ( $signame ) { |
| 5734 | myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), |
| 5735 | "). Asked to terminate\n" ) ; |
| 5736 | if ( $mysync->{stats} ) { |
| 5737 | myprint( "Here are the final stats of this sync not completely finished so far\n" ) ; |
| 5738 | stats( $mysync ) ; |
| 5739 | myprint( "Ended by a signal $signame (my PID is $PROCESS_ID my PPID is ", |
| 5740 | getppid( ), "). I am asked to terminate immediately.\n" ) ; |
| 5741 | myprint( "You should resynchronize those accounts by running a sync again,\n", |
| 5742 | "since some messages and entire folders might still be missing on host2.\n" ) ; |
| 5743 | } |
| 5744 | ## no critic (RequireLocalizedPunctuationVars) |
| 5745 | $SIG{ $signame } = 'DEFAULT'; # restore default action |
| 5746 | # kill myself with $signame |
| 5747 | # https://www.cons.org/cracauer/sigint.html |
| 5748 | myprint( "Killing myself with signal $signame\n" ) ; |
| 5749 | cleanup_before_exit( $mysync ) ; |
| 5750 | kill( $signame, $PROCESS_ID ) ; |
| 5751 | sleep 1 ; |
| 5752 | $mysync->{nb_errors}++ ; |
| 5753 | exit_clean( $mysync, $EXIT_BY_SIGNAL, |
| 5754 | "Still there after killing myself with signal $signame...\n" |
| 5755 | ) ; |
| 5756 | } |
| 5757 | else |
| 5758 | { |
| 5759 | $mysync->{nb_errors}++ ; |
| 5760 | exit_clean( $mysync, $EXIT_BY_SIGNAL, "Exiting in catch_exit with no signal...\n" ) ; |
| 5761 | } |
| 5762 | return ; |
| 5763 | } |
| 5764 | |
| 5765 | |
| 5766 | sub catch_print |
| 5767 | { |
| 5768 | my $mysync = shift ; |
| 5769 | my $signame = shift ; |
| 5770 | |
| 5771 | my $sigcounter = ++$mysync->{ sigcounter }{ $signame } ; |
| 5772 | myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), |
| 5773 | "). Received $sigcounter $signame signals so far. Thanks!\n" ) ; |
| 5774 | return ; |
| 5775 | } |
| 5776 | |
| 5777 | sub here_twice |
| 5778 | { |
| 5779 | my $mysync = shift ; |
| 5780 | my $now = time ; |
| 5781 | my $previous = $mysync->{lastcatch} || 0 ; |
| 5782 | $mysync->{lastcatch} = $now ; |
| 5783 | |
| 5784 | if ( $INTERVAL_TO_EXIT >= $now - $previous ) { |
| 5785 | return $TRUE ; |
| 5786 | }else{ |
| 5787 | return $FALSE ; |
| 5788 | } |
| 5789 | } |
| 5790 | |
| 5791 | |
| 5792 | sub catch_reconnect |
| 5793 | { |
| 5794 | my $mysync = shift ; |
| 5795 | my $signame = shift ; |
| 5796 | if ( here_twice( $mysync ) ) { |
| 5797 | myprint( "Got two signals $signame within $INTERVAL_TO_EXIT seconds. Exiting...\n" ) ; |
| 5798 | catch_exit( $mysync, $signame ) ; |
| 5799 | }else{ |
| 5800 | myprint( "\nGot a signal $signame (my PID is $PROCESS_ID my PPID is ", getppid( ), ")\n", |
| 5801 | "Hit 2 ctr-c within 2 seconds to exit the program\n", |
| 5802 | "Hit only 1 ctr-c to reconnect to both imap servers\n", |
| 5803 | ) ; |
| 5804 | myprint( "For now only one signal $signame within $INTERVAL_TO_EXIT seconds.\n" ) ; |
| 5805 | |
| 5806 | if ( ! defined $mysync->{imap1} ) { return ; } |
| 5807 | if ( ! defined $mysync->{imap2} ) { return ; } |
| 5808 | |
| 5809 | myprint( "Info: reconnecting to host1 imap server $mysync->{host1}\n" ) ; |
| 5810 | $mysync->{imap1}->State( Mail::IMAPClient::Unconnected ) ; |
| 5811 | $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT} += 1 ; |
| 5812 | if ( $mysync->{imap1}->reconnect( ) ) |
| 5813 | { |
| 5814 | myprint( "Info: reconnected to host1 imap server $mysync->{host1}\n" ) ; |
| 5815 | } |
| 5816 | else |
| 5817 | { |
| 5818 | $mysync->{nb_errors}++ ; |
| 5819 | exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ; |
| 5820 | } |
| 5821 | myprint( "Info: reconnecting to host2 imap server\n" ) ; |
| 5822 | $mysync->{imap2}->State( Mail::IMAPClient::Unconnected ) ; |
| 5823 | $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT} += 1 ; |
| 5824 | if ( $mysync->{imap2}->reconnect( ) ) |
| 5825 | { |
| 5826 | myprint( "Info: reconnected to host2 imap server $mysync->{host2}\n" ) ; |
| 5827 | } |
| 5828 | else |
| 5829 | { |
| 5830 | $mysync->{nb_errors}++ ; |
| 5831 | exit_clean( $mysync, $EXIT_CONNECTION_FAILURE ) ; |
| 5832 | } |
| 5833 | myprint( "Info: reconnected to both imap servers\n" ) ; |
| 5834 | } |
| 5835 | return ; |
| 5836 | } |
| 5837 | |
| 5838 | sub install_signals |
| 5839 | { |
| 5840 | my $mysync = shift ; |
| 5841 | |
| 5842 | if ( under_docker_context( $mysync ) ) |
| 5843 | { |
| 5844 | # output( $mysync, "Under docker context so leaving signals as they are\n" ) ; |
| 5845 | output( $mysync, "Under docker context so installing only signals to exit\n" ) ; |
| 5846 | @{ $mysync->{ sigexit } } = ( defined( $mysync->{ sigexit } ) ) ? @{ $mysync->{ sigexit } } : ( 'INT', 'QUIT', 'TERM' ) ; |
| 5847 | sig_install( $mysync, 'catch_exit', @{ $mysync->{ sigexit } } ) ; |
| 5848 | } |
| 5849 | else |
| 5850 | { |
| 5851 | # Unix signals |
| 5852 | @{ $mysync->{ sigexit } } = ( defined( $mysync->{ sigexit } ) ) ? @{ $mysync->{ sigexit } } : ( 'QUIT', 'TERM' ) ; |
| 5853 | @{ $mysync->{ sigreconnect } } = ( defined( $mysync->{ sigreconnect } ) ) ? @{ $mysync->{ sigreconnect } } : ( 'INT' ) ; |
| 5854 | @{ $mysync->{ sigprint } } = ( defined( $mysync->{ sigprint } ) ) ? @{ $mysync->{ sigprint } } : ( 'HUP' ) ; |
| 5855 | @{ $mysync->{ sigignore } } = ( defined( $mysync->{ sigignore } ) ) ? @{ $mysync->{ sigignore } } : ( ) ; |
| 5856 | |
| 5857 | #local %SIG = %SIG ; |
| 5858 | sig_install( $mysync, 'catch_exit', @{ $mysync->{ sigexit } } ) ; |
| 5859 | sig_install( $mysync, 'catch_reconnect', @{ $mysync->{ sigreconnect } } ) ; |
| 5860 | sig_install( $mysync, 'catch_print', @{ $mysync->{ sigprint } } ) ; |
| 5861 | # --sigignore can override sigexit, sigreconnect and sigprint (for the same signals only) |
| 5862 | sig_install( $mysync, 'catch_ignore', @{ $mysync->{ sigignore } } ) ; |
| 5863 | |
| 5864 | sig_install_toggle_sleep( $mysync ) ; |
| 5865 | } |
| 5866 | |
| 5867 | return ; |
| 5868 | } |
| 5869 | |
| 5870 | |
| 5871 | |
| 5872 | sub tests_reconnect_12_if_needed |
| 5873 | { |
| 5874 | note( 'Entering tests_reconnect_12_if_needed()' ) ; |
| 5875 | |
| 5876 | my $mysync ; |
| 5877 | |
| 5878 | $mysync->{imap1} = Mail::IMAPClient->new( ) ; |
| 5879 | $mysync->{imap2} = Mail::IMAPClient->new( ) ; |
| 5880 | $mysync->{imap1}->Server( 'test1.lamiral.info' ) ; |
| 5881 | $mysync->{imap2}->Server( 'test2.lamiral.info' ) ; |
| 5882 | is( 2, reconnect_12_if_needed( $mysync ), 'reconnect_12_if_needed: test1&test2 .lamiral.info => 1' ) ; |
| 5883 | is( 1, $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test1.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; |
| 5884 | is( 1, $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_12_if_needed: test2.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; |
| 5885 | |
| 5886 | note( 'Leaving tests_reconnect_12_if_needed()' ) ; |
| 5887 | return ; |
| 5888 | } |
| 5889 | |
| 5890 | sub reconnect_12_if_needed |
| 5891 | { |
| 5892 | my $mysync = shift ; |
| 5893 | #return 2 ; |
| 5894 | if ( ! reconnect_if_needed( $mysync->{imap1} ) ) { |
| 5895 | return ; |
| 5896 | } |
| 5897 | if ( ! reconnect_if_needed( $mysync->{imap2} ) ) { |
| 5898 | return ; |
| 5899 | } |
| 5900 | # both were good |
| 5901 | return 2 ; |
| 5902 | } |
| 5903 | |
| 5904 | |
| 5905 | sub tests_reconnect_if_needed |
| 5906 | { |
| 5907 | note( 'Entering tests_reconnect_if_needed()' ) ; |
| 5908 | |
| 5909 | |
| 5910 | my $myimap ; |
| 5911 | |
| 5912 | is( undef, reconnect_if_needed( ), 'reconnect_if_needed: no args => undef' ) ; |
| 5913 | is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: undef arg => undef' ) ; |
| 5914 | |
| 5915 | $myimap = Mail::IMAPClient->new( ) ; |
| 5916 | $myimap->Debug( 1 ) ; |
| 5917 | is( undef, reconnect_if_needed( $myimap ), 'reconnect_if_needed: empty new Mail::IMAPClient => undef' ) ; |
| 5918 | $myimap->Server( 'test.lamiral.info' ) ; |
| 5919 | is( 1, reconnect_if_needed( $myimap ), 'reconnect_if_needed: test.lamiral.info => 1' ) ; |
| 5920 | is( 1, $myimap->{IMAPSYNC_RECONNECT_COUNT}, 'reconnect_if_needed: test.lamiral.info IMAPSYNC_RECONNECT_COUNT => 1' ) ; |
| 5921 | |
| 5922 | note( 'Leaving tests_reconnect_if_needed()' ) ; |
| 5923 | return ; |
| 5924 | } |
| 5925 | |
| 5926 | sub reconnect_if_needed |
| 5927 | { |
| 5928 | # return undef upon failure. |
| 5929 | # return 1 upon connection success, with or without reconnection. |
| 5930 | |
| 5931 | my $imap = shift ; |
| 5932 | |
| 5933 | if ( ! defined $imap ) { return ; } |
| 5934 | if ( ! $imap->Server( ) ) { return ; } |
| 5935 | |
| 5936 | if ( $imap->IsUnconnected( ) ) { |
| 5937 | $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ; |
| 5938 | if ( $imap->reconnect( ) ) { |
| 5939 | return 1 ; |
| 5940 | } |
| 5941 | }else{ |
| 5942 | return 1 ; |
| 5943 | } |
| 5944 | |
| 5945 | # A last forced one |
| 5946 | $imap->State( Mail::IMAPClient::Unconnected ) ; |
| 5947 | $imap->reconnect( ) ; |
| 5948 | $imap->{IMAPSYNC_RECONNECT_COUNT} += 1 ; |
| 5949 | if ( $imap->noop ) { |
| 5950 | # NOOP is ok |
| 5951 | return 1 ; |
| 5952 | } |
| 5953 | |
| 5954 | return ; |
| 5955 | } |
| 5956 | |
| 5957 | |
| 5958 | |
| 5959 | # $sync->{id} = defined $sync->{id} ? $sync->{id} : 1 ; |
| 5960 | # imap_id_stuff( $sync ) ; |
| 5961 | |
| 5962 | sub justconnect |
| 5963 | { |
| 5964 | my $mysync = shift ; |
| 5965 | my $justconnect1 = justconnect1( $sync ) ; |
| 5966 | my $justconnect2 = justconnect2( $sync ) ; |
| 5967 | return "$justconnect1 $justconnect2"; |
| 5968 | } |
| 5969 | |
| 5970 | sub justconnect1 |
| 5971 | { |
| 5972 | my $mysync = shift ; |
| 5973 | if ( $mysync->{host1} ) |
| 5974 | { |
| 5975 | myprint( "Host1: Will just connect to $mysync->{host1} without login\n" ) ; |
| 5976 | $mysync->{imap1} = connect_imap( |
| 5977 | $mysync->{host1}, $mysync->{port1}, $debugimap1, |
| 5978 | $mysync->{ssl1}, $mysync->{tls1}, 'Host1', |
| 5979 | $mysync->{h1}->{timeout}, $mysync->{h1} ) ; |
| 5980 | imap_id( $mysync, $mysync->{imap1}, 'Host1' ) ; |
| 5981 | $mysync->{imap1}->logout( ) ; |
| 5982 | return $mysync->{host1} ; |
| 5983 | } |
| 5984 | |
| 5985 | return q{} ; |
| 5986 | } |
| 5987 | |
| 5988 | sub justconnect2 |
| 5989 | { |
| 5990 | my $mysync = shift ; |
| 5991 | if ( $mysync->{host2} ) |
| 5992 | { |
| 5993 | myprint( "Host2: Will just connect to $mysync->{host2} without login\n" ) ; |
| 5994 | $mysync->{imap2} = connect_imap( |
| 5995 | $mysync->{host2}, $mysync->{port2}, $debugimap2, |
| 5996 | $mysync->{ssl2}, $mysync->{tls2}, 'Host2', |
| 5997 | $mysync->{h2}->{timeout}, $mysync->{h2} ) ; |
| 5998 | imap_id( $mysync, $mysync->{imap2}, 'Host2' ) ; |
| 5999 | $mysync->{imap2}->logout( ) ; |
| 6000 | return $mysync->{host2} ; |
| 6001 | } |
| 6002 | |
| 6003 | return q{} ; |
| 6004 | } |
| 6005 | |
| 6006 | sub skip_macosx |
| 6007 | { |
| 6008 | #return ; |
| 6009 | return( 'macosx.polarhome.com' eq hostname() ) ; |
| 6010 | } |
| 6011 | |
| 6012 | sub tests_mailimapclient_connect |
| 6013 | { |
| 6014 | note( 'Entering tests_mailimapclient_connect()' ) ; |
| 6015 | |
| 6016 | my $imap ; |
| 6017 | # ipv4 |
| 6018 | ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4: new' ) ; |
| 6019 | is( 'Mail::IMAPClient', ref( $imap ), 'mailimapclient_connect ipv4: ref is Mail::IMAPClient' ) ; |
| 6020 | |
| 6021 | # Mail::IMAPClient 3.40 die on this... So we skip it, thanks to "mature" IO::Socket::IP |
| 6022 | # Mail::IMAPClient 3.42 is ok so this test is back. |
| 6023 | is( undef, $imap->connect( ), 'mailimapclient_connect ipv4: connect with no server => failure' ) ; |
| 6024 | |
| 6025 | |
| 6026 | is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4: setting Server(test.lamiral.info)' ) ; |
| 6027 | is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4: setting Debug( 1 )' ) ; |
| 6028 | is( 143, $imap->Port( 143 ), 'mailimapclient_connect ipv4: setting Port( 143 )' ) ; |
| 6029 | is( 3, $imap->Timeout( 3 ), 'mailimapclient_connect ipv4: setting Timout( 3 )' ) ; |
| 6030 | like( ref( $imap->connect( ) ), qr/IO::Socket::INET|IO::Socket::IP/, 'mailimapclient_connect ipv4: connect to test.lamiral.info' ) ; |
| 6031 | like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4: logout' ) ; |
| 6032 | is( undef, undef $imap, 'mailimapclient_connect ipv4: free variable' ) ; |
| 6033 | |
| 6034 | # ipv4 + ssl |
| 6035 | ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv4 + ssl: new' ) ; |
| 6036 | is( 'test.lamiral.info', $imap->Server( 'test.lamiral.info' ), 'mailimapclient_connect ipv4 + ssl: setting Server(test.lamiral.info)' ) ; |
| 6037 | is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ; |
| 6038 | ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv4 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; |
| 6039 | is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv4 + ssl: setting Port( 993 )' ) ; |
| 6040 | like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv4 + ssl: connect to test.lamiral.info' ) ; |
| 6041 | like( $imap->logout( ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv4 + ssl: logout in ssl does not cause failure' ) ; |
| 6042 | is( undef, undef $imap, 'mailimapclient_connect ipv4 + ssl: free variable' ) ; |
| 6043 | |
| 6044 | # ipv6 + ssl |
| 6045 | # Fails often on ks2ipv6.lamiral.info |
| 6046 | |
| 6047 | ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect ipv6 + ssl: new' ) ; |
| 6048 | is( 'petiteipv6.lamiral.info', $imap->Server( 'petiteipv6.lamiral.info' ), 'mailimapclient_connect ipv6 + ssl: setting Server petiteipv6.lamiral.info' ) ; |
| 6049 | is( 3, $imap->Timeout( 3 ), 'mailimapclient_connect ipv4: setting Timout( 3 )' ) ; |
| 6050 | ok( $imap->Ssl( [ SSL_verify_mode => SSL_VERIFY_NONE, SSL_cipher_list => 'DEFAULT:!DH' ] ), 'mailimapclient_connect ipv6 + ssl: setting Ssl( SSL_VERIFY_NONE )' ) ; |
| 6051 | is( 993, $imap->Port( 993 ), 'mailimapclient_connect ipv6 + ssl: setting Port( 993 )' ) ; |
| 6052 | SKIP: { |
| 6053 | if ( |
| 6054 | 'CUILLERE' eq hostname() |
| 6055 | or |
| 6056 | skip_macosx() |
| 6057 | or |
| 6058 | -e '/.dockerenv' |
| 6059 | or |
| 6060 | 'pcHPDV7-HP' eq hostname() |
| 6061 | ) |
| 6062 | { |
| 6063 | skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 4 ) ; |
| 6064 | } |
| 6065 | |
| 6066 | is( 1, $imap->Debug( 1 ), 'mailimapclient_connect ipv4 + ssl: setting Debug( 1 )' ) ; |
| 6067 | |
| 6068 | # It sounds stupid but it avoids failures on the next test about $imap->connect |
| 6069 | is( '2a01:e34:ecde:70d0:223:54ff:fec2:36d7', resolv( 'petiteipv6.lamiral.info' ), 'resolv: petiteipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ; |
| 6070 | |
| 6071 | like( ref( $imap->connect( ) ), qr/IO::Socket::SSL/, 'mailimapclient_connect ipv6 + ssl: connect to petiteipv6.lamiral.info' ) ; |
| 6072 | # This one is ok on petite, not on ks2, do not know why, so commented. |
| 6073 | like( ref( $imap->logout( ) ), qr/Mail::IMAPClient/, 'mailimapclient_connect ipv6 + ssl: logout in ssl is ok on petiteipv6.lamiral.info' ) ; |
| 6074 | } |
| 6075 | |
| 6076 | is( undef, undef $imap, 'mailimapclient_connect ipv6 + ssl: free variable' ) ; |
| 6077 | |
| 6078 | |
| 6079 | note( 'Leaving tests_mailimapclient_connect()' ) ; |
| 6080 | return ; |
| 6081 | } |
| 6082 | |
| 6083 | |
| 6084 | sub tests_mailimapclient_connect_bug |
| 6085 | { |
| 6086 | note( 'Entering tests_mailimapclient_connect_bug()' ) ; |
| 6087 | |
| 6088 | my $imap ; |
| 6089 | |
| 6090 | # ipv6 |
| 6091 | ok( $imap = Mail::IMAPClient->new( ), 'mailimapclient_connect_bug ipv6: new' ) ; |
| 6092 | is( 'ks2ipv6.lamiral.info', $imap->Server( 'ks2ipv6.lamiral.info' ), 'mailimapclient_connect_bug ipv6: setting Server(ks2ipv6.lamiral.info)' ) ; |
| 6093 | is( 143, $imap->Port( 143 ), 'mailimapclient_connect_bug ipv6: setting Port( 993 )' ) ; |
| 6094 | |
| 6095 | SKIP: { |
| 6096 | if ( |
| 6097 | 'CUILLERE' eq hostname() |
| 6098 | or |
| 6099 | skip_macosx() |
| 6100 | or |
| 6101 | -e '/.dockerenv' |
| 6102 | or |
| 6103 | 'pcHPDV7-HP' eq hostname() |
| 6104 | ) |
| 6105 | { |
| 6106 | skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 1 ) ; |
| 6107 | } |
| 6108 | like( ref( $imap->connect( ) ), qr/IO::Socket::INET/, 'mailimapclient_connect_bug ipv6: connect to ks2ipv6.lamiral.info' ) |
| 6109 | or diag( 'mailimapclient_connect_bug ipv6: ', $imap->LastError( ), $!, ) ; |
| 6110 | } |
| 6111 | #is( $imap->logout( ), undef, 'mailimapclient_connect_bug ipv6: logout in ssl causes failure' ) ; |
| 6112 | is( undef, undef $imap, 'mailimapclient_connect_bug ipv6: free variable' ) ; |
| 6113 | |
| 6114 | note( 'Leaving tests_mailimapclient_connect_bug()' ) ; |
| 6115 | return ; |
| 6116 | } |
| 6117 | |
| 6118 | |
| 6119 | |
| 6120 | sub tests_connect_socket |
| 6121 | { |
| 6122 | note( 'Entering tests_connect_socket()' ) ; |
| 6123 | |
| 6124 | is( undef, connect_socket( ), 'connect_socket: no args' ) ; |
| 6125 | |
| 6126 | my $socket ; |
| 6127 | my $imap ; |
| 6128 | SKIP: { |
| 6129 | if ( |
| 6130 | 'CUILLERE' eq hostname() |
| 6131 | or |
| 6132 | skip_macosx() |
| 6133 | or |
| 6134 | -e '/.dockerenv' |
| 6135 | or |
| 6136 | 'pcHPDV7-HP' eq hostname() |
| 6137 | ) |
| 6138 | { |
| 6139 | skip( 'Tests avoided on CUILLERE/pcHPDV7-HP/macosx.polarhome.com/docker cannot do ipv6', 2 ) ; |
| 6140 | } |
| 6141 | |
| 6142 | $socket = IO::Socket::INET6->new( |
| 6143 | PeerAddr => 'ks2ipv6.lamiral.info', |
| 6144 | PeerPort => 143, |
| 6145 | ) ; |
| 6146 | |
| 6147 | |
| 6148 | ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 143 IO::Socket::INET6' ) ; |
| 6149 | #$imap->Debug( 1 ) ; |
| 6150 | # myprint( $imap->capability( ) ) ; |
| 6151 | if ( $imap ) { |
| 6152 | $imap->logout( ) ; |
| 6153 | } |
| 6154 | |
| 6155 | $IO::Socket::SSL::DEBUG = 4 ; |
| 6156 | $socket = IO::Socket::SSL->new( |
| 6157 | PeerHost => 'ks2ipv6.lamiral.info', |
| 6158 | PeerPort => 993, |
| 6159 | SSL_verify_mode => SSL_VERIFY_NONE, |
| 6160 | SSL_cipher_list => 'DEFAULT:!DH', |
| 6161 | ) ; |
| 6162 | # myprint( $socket ) ; |
| 6163 | ok( $imap = connect_socket( $socket ), 'connect_socket: ks2ipv6.lamiral.info port 993 IO::Socket::SSL' ) ; |
| 6164 | #$imap->Debug( 1 ) ; |
| 6165 | # myprint( $imap->capability( ) ) ; |
| 6166 | # $socket->close( ) ; |
| 6167 | if ( $imap ) { |
| 6168 | $socket->close( ) ; |
| 6169 | } |
| 6170 | #$socket->close(SSL_no_shutdown => 1) ; |
| 6171 | #$imap->logout( ) ; |
| 6172 | #myprint( "\n" ) ; |
| 6173 | #$imap->logout( ) ; |
| 6174 | } |
| 6175 | note( 'Leaving tests_connect_socket()' ) ; |
| 6176 | return ; |
| 6177 | } |
| 6178 | |
| 6179 | sub connect_socket |
| 6180 | { |
| 6181 | my( $socket ) = @ARG ; |
| 6182 | |
| 6183 | if ( ! defined $socket ) { return ; } |
| 6184 | |
| 6185 | my $host = $socket->peerhost( ) ; |
| 6186 | my $port = $socket->peerport( ) ; |
| 6187 | #print "socket->peerhost: ", $socket->peerhost( ), "\n" ; |
| 6188 | #print "socket->peerport: ", $socket->peerport( ), "\n" ; |
| 6189 | my $imap = Mail::IMAPClient->new( ) ; |
| 6190 | $imap->Socket( $socket ) ; |
| 6191 | my $banner = $imap->Results()->[0] ; |
| 6192 | #myprint( "banner: $banner" ) ; |
| 6193 | return $imap ; |
| 6194 | } |
| 6195 | |
| 6196 | |
| 6197 | sub tests_probe_imapssl |
| 6198 | { |
| 6199 | note( 'Entering tests_probe_imapssl()' ) ; |
| 6200 | |
| 6201 | is( undef, probe_imapssl( ), 'probe_imapssl: no args => undef' ) ; |
| 6202 | is( undef, probe_imapssl( 'unknown' ), 'probe_imapssl: unknown => undef' ) ; |
| 6203 | |
| 6204 | note( "hostname is: ", hostname() ) ; |
| 6205 | SKIP: { |
| 6206 | if ( |
| 6207 | 'CUILLERE' eq hostname() |
| 6208 | or |
| 6209 | skip_macosx() |
| 6210 | or |
| 6211 | -e '/.dockerenv' |
| 6212 | or |
| 6213 | 'pcHPDV7-HP' eq hostname() |
| 6214 | ) |
| 6215 | { |
| 6216 | skip( 'Tests avoided on CUILLERE or pcHPDV7-HP or Mac or docker: cannot do ipv6', 0 ) ; |
| 6217 | } |
| 6218 | # fed up with this one |
| 6219 | #like( probe_imapssl( 'ks2ipv6.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: ks2ipv6.lamiral.info matches "* OK"' ) ; |
| 6220 | } ; |
| 6221 | |
| 6222 | |
| 6223 | # It sounds stupid but it avoids failures on the next test about $imap->connect |
| 6224 | ok( resolv( 'imap.gmail.com' ), 'resolv: imap.gmail.com => something' ) ; |
| 6225 | like( probe_imapssl( 'imap.gmail.com' ), qr/^\* OK/, 'probe_imapssl: imap.gmail.com matches "* OK"' ) ; |
| 6226 | |
| 6227 | like( probe_imapssl( 'test1.lamiral.info' ), qr/^\* OK/, 'probe_imapssl: test1.lamiral.info matches "* OK"' ) ; |
| 6228 | |
| 6229 | note( 'Leaving tests_probe_imapssl()' ) ; |
| 6230 | return ; |
| 6231 | } |
| 6232 | |
| 6233 | |
| 6234 | sub probe_imapssl |
| 6235 | { |
| 6236 | my $host = shift ; |
| 6237 | |
| 6238 | if ( ! $host ) { return ; } |
| 6239 | $sync->{ debug } and $IO::Socket::SSL::DEBUG = 4 ; |
| 6240 | my $socket = IO::Socket::SSL->new( |
| 6241 | PeerHost => $host, |
| 6242 | PeerPort => $IMAP_SSL_PORT, |
| 6243 | SSL_verifycn_scheme => 'imap', |
| 6244 | SSL_verify_mode => $SSL_VERIFY_POLICY, |
| 6245 | SSL_cipher_list => 'DEFAULT:!DH', |
| 6246 | ) ; |
| 6247 | if ( ! $socket ) { return ; } |
| 6248 | $sync->{ debug } and print "socket: $socket\n" ; |
| 6249 | |
| 6250 | my $banner ; |
| 6251 | $socket->sysread( $banner, 65_536 ) ; |
| 6252 | $sync->{ debug } and print "banner: $banner" ; |
| 6253 | $socket->close( ) ; |
| 6254 | return $banner ; |
| 6255 | |
| 6256 | } |
| 6257 | |
| 6258 | sub connect_imap |
| 6259 | { |
| 6260 | my( $host, $port, $mydebugimap, $ssl, $tls, $Side, $mytimeout, $h ) = @_ ; |
| 6261 | my $imap = Mail::IMAPClient->new( ) ; |
| 6262 | |
| 6263 | if ( $ssl ) { set_ssl( $imap, $h ) } |
| 6264 | $imap->Server( $host ) ; |
| 6265 | $imap->Port( $port ) ; |
| 6266 | $imap->Debug( $mydebugimap ) ; |
| 6267 | $imap->Timeout( $mytimeout ) ; |
| 6268 | |
| 6269 | my $side = lc $Side ; |
| 6270 | myprint( "$Side: connecting on $side [$host] port [$port]\n" ) ; |
| 6271 | |
| 6272 | if ( ! $imap->connect( ) ) |
| 6273 | { |
| 6274 | $sync->{nb_errors}++ ; |
| 6275 | exit_clean( $sync, $EXIT_CONNECTION_FAILURE, |
| 6276 | "$Side: Can not open imap connection on [$host]: ", |
| 6277 | $imap->LastError, |
| 6278 | " $OS_ERROR\n" |
| 6279 | ) ; |
| 6280 | } |
| 6281 | myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ; |
| 6282 | |
| 6283 | my $banner = $imap->Results()->[0] ; |
| 6284 | |
| 6285 | myprint( "$Side banner: $banner" ) ; |
| 6286 | myprint( "$Side capability: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; |
| 6287 | |
| 6288 | if ( $tls ) { |
| 6289 | set_tls( $imap, $h ) ; |
| 6290 | if ( ! $imap->starttls( ) ) |
| 6291 | { |
| 6292 | $sync->{nb_errors}++ ; |
| 6293 | exit_clean( $sync, $EXIT_TLS_FAILURE, |
| 6294 | "$Side: Can not go to tls encryption on $side [$host]:", |
| 6295 | $imap->LastError, "\n" |
| 6296 | ) ; |
| 6297 | } |
| 6298 | myprint( "$Side: Socket successfuly converted to SSL\n" ) ; |
| 6299 | } |
| 6300 | return( $imap ) ; |
| 6301 | } |
| 6302 | |
| 6303 | |
| 6304 | sub login_imap |
| 6305 | { |
| 6306 | |
| 6307 | my @allargs = @_ ; |
| 6308 | my( |
| 6309 | $host, $port, $user, $domain, $password, |
| 6310 | $mydebugimap, $mytimeout, $fastio, |
| 6311 | $ssl, $tls, $authmech, $authuser, $reconnectretry, |
| 6312 | $proxyauth, $uid, $split, $Side, $h, $mysync ) = @allargs ; |
| 6313 | |
| 6314 | my $side = lc $Side ; |
| 6315 | myprint( "$Side: connecting and login on $side [$host] port [$port] with user [$user]\n" ) ; |
| 6316 | |
| 6317 | my $imap = init_imap( @allargs ) ; |
| 6318 | |
| 6319 | if ( ! $imap->connect() ) |
| 6320 | { |
| 6321 | $mysync->{nb_errors}++ ; |
| 6322 | exit_clean( $mysync, $EXIT_CONNECTION_FAILURE, |
| 6323 | "$Side failure: can not open imap connection on $side [$host] with user [$user]: ", |
| 6324 | $imap->LastError . " $OS_ERROR\n" |
| 6325 | ) ; |
| 6326 | } |
| 6327 | myprint( "$Side IP address: ", $imap->Socket->peerhost(), "\n" ) ; |
| 6328 | my $banner = $imap->Results()->[0] ; |
| 6329 | |
| 6330 | myprint( "$Side banner: $banner" ) ; |
| 6331 | myprint( "$Side capability before authentication: ", join(q{ }, @{ $imap->capability() || [] }), "\n" ) ; |
| 6332 | |
| 6333 | if ( (! $ssl) and (! defined $tls ) and $imap->has_capability( 'STARTTLS' ) ) { |
| 6334 | myprint( "$Side: going to ssl because STARTTLS is in CAPABILITY. Use --notls1 or --notls2 to avoid that behavior\n" ) ; |
| 6335 | $tls = 1 ; |
| 6336 | } |
| 6337 | |
| 6338 | if ( $authmech eq 'PREAUTH' ) { |
| 6339 | if ( $imap->IsAuthenticated( ) ) { |
| 6340 | $imap->Socket ; |
| 6341 | myprintf("%s: Assuming PREAUTH for %s\n", $Side, $imap->Server ) ; |
| 6342 | }else{ |
| 6343 | $mysync->{nb_errors}++ ; |
| 6344 | exit_clean( |
| 6345 | $mysync, $EXIT_AUTHENTICATION_FAILURE, |
| 6346 | "$Side failure: error login on $side [$host] with user [$user] auth [PREAUTH]\n" |
| 6347 | ) ; |
| 6348 | } |
| 6349 | } |
| 6350 | |
| 6351 | if ( $tls ) { |
| 6352 | set_tls( $imap, $h ) ; |
| 6353 | if ( ! $imap->starttls( ) ) |
| 6354 | { |
| 6355 | $mysync->{nb_errors}++ ; |
| 6356 | exit_clean( $mysync, $EXIT_TLS_FAILURE, |
| 6357 | "$Side failure: Can not go to tls encryption on $side [$host]:", |
| 6358 | $imap->LastError, "\n" |
| 6359 | ) ; |
| 6360 | } |
| 6361 | myprint( "$Side: Socket successfuly converted to SSL\n" ) ; |
| 6362 | } |
| 6363 | |
| 6364 | authenticate_imap( $imap, @allargs ) ; |
| 6365 | |
| 6366 | myprint( "$Side: success login on [$host] with user [$user] auth [$authmech]\n" ) ; |
| 6367 | return( $imap ) ; |
| 6368 | } |
| 6369 | |
| 6370 | |
| 6371 | sub authenticate_imap |
| 6372 | { |
| 6373 | my( $imap, |
| 6374 | $host, $port, $user, $domain, $password, |
| 6375 | $mydebugimap, $mytimeout, $fastio, |
| 6376 | $ssl, $tls, $authmech, $authuser, $reconnectretry, |
| 6377 | $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ; |
| 6378 | |
| 6379 | check_capability( $imap, $authmech, $Side ) ; |
| 6380 | $imap->User( $user ) ; |
| 6381 | $imap->Domain( $domain ) if ( defined $domain ) ; |
| 6382 | $imap->Authuser( $authuser ) ; |
| 6383 | $imap->Password( $password ) ; |
| 6384 | |
| 6385 | if ( 'X-MASTERAUTH' eq $authmech ) |
| 6386 | { |
| 6387 | xmasterauth( $imap ) ; |
| 6388 | return ; |
| 6389 | } |
| 6390 | |
| 6391 | if ( $proxyauth ) { |
| 6392 | $imap->Authmechanism(q{}) ; |
| 6393 | $imap->User( $authuser ) ; |
| 6394 | } else { |
| 6395 | $imap->Authmechanism( $authmech ) unless ( $authmech eq 'LOGIN' or $authmech eq 'PREAUTH' ) ; |
| 6396 | } |
| 6397 | |
| 6398 | $imap->Authcallback(\&xoauth) if ( 'XOAUTH' eq $authmech ) ; |
| 6399 | $imap->Authcallback(\&xoauth2) if ( 'XOAUTH2' eq $authmech ) ; |
| 6400 | $imap->Authcallback(\&plainauth) if ( ( 'PLAIN' eq $authmech ) or ( 'EXTERNAL' eq $authmech ) ) ; |
| 6401 | |
| 6402 | |
| 6403 | unless ( $authmech eq 'PREAUTH' or $imap->login( ) ) { |
| 6404 | my $info = "$Side failure: Error login on [$host] with user [$user] auth" ; |
| 6405 | my $einfo = $imap->LastError || @{$imap->History}[$LAST] ; |
| 6406 | chomp $einfo ; |
| 6407 | my $error = "$info [$authmech]: $einfo\n" ; |
| 6408 | if ( ( $authmech eq 'LOGIN' ) or $imap->IsUnconnected( ) or $authuser ) { |
| 6409 | $authuser ||= "" ; |
| 6410 | myprint( "$Side info: authmech [$authmech] user [$user] authuser [$authuser] IsUnconnected [", $imap->IsUnconnected( ), "]\n" ) ; |
| 6411 | $mysync->{nb_errors}++ ; |
| 6412 | exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, $error ) ; |
| 6413 | }else{ |
| 6414 | myprint( $error ) ; |
| 6415 | } |
| 6416 | # It is not secure to try plain text LOGIN when another authmech failed |
| 6417 | # but I do it. |
| 6418 | # I shell remove this code one day. |
| 6419 | myprint( "$Side info: trying LOGIN Auth mechanism on [$host] with user [$user]\n" ) ; |
| 6420 | $imap->Authmechanism(q{}) ; |
| 6421 | if ( ! $imap->login( ) ) |
| 6422 | { |
| 6423 | $mysync->{nb_errors}++ ; |
| 6424 | exit_clean( $mysync, $EXIT_AUTHENTICATION_FAILURE, |
| 6425 | "$info [LOGIN]: ", |
| 6426 | $imap->LastError, "\n" |
| 6427 | ) ; |
| 6428 | } |
| 6429 | } |
| 6430 | |
| 6431 | if ( $proxyauth ) { |
| 6432 | if ( ! $imap->proxyauth( $user ) ) { |
| 6433 | my $info = "$Side failure: Error doing proxyauth as user [$user] on [$host] using proxy-login as [$authuser]" ; |
| 6434 | my $einfo = $imap->LastError || @{$imap->History}[$LAST] ; |
| 6435 | chomp $einfo ; |
| 6436 | $mysync->{nb_errors}++ ; |
| 6437 | exit_clean( $mysync, |
| 6438 | $EXIT_AUTHENTICATION_FAILURE, |
| 6439 | "$info: $einfo\n" |
| 6440 | ) ; |
| 6441 | } |
| 6442 | } |
| 6443 | |
| 6444 | return ; |
| 6445 | } |
| 6446 | |
| 6447 | sub check_capability |
| 6448 | { |
| 6449 | |
| 6450 | my( $imap, $authmech, $Side ) = @_ ; |
| 6451 | |
| 6452 | |
| 6453 | if ( $imap->has_capability( "AUTH=$authmech" ) |
| 6454 | or $imap->has_capability( $authmech ) ) |
| 6455 | { |
| 6456 | myprintf("%s: %s says it has CAPABILITY for AUTHENTICATE %s\n", |
| 6457 | $Side, $imap->Server, $authmech) ; |
| 6458 | return ; |
| 6459 | } |
| 6460 | |
| 6461 | if ( $authmech eq 'LOGIN' ) |
| 6462 | { |
| 6463 | # Well, the warning is so common and useless that I prefer to remove it |
| 6464 | # No more "... says it has NO CAPABILITY for AUTHENTICATE LOGIN" |
| 6465 | return ; |
| 6466 | } |
| 6467 | |
| 6468 | |
| 6469 | myprintf( "%s: %s says it has NO CAPABILITY for AUTHENTICATE %s\n", |
| 6470 | $Side, $imap->Server, $authmech ) ; |
| 6471 | |
| 6472 | if ( $authmech eq 'PLAIN' ) |
| 6473 | { |
| 6474 | myprint( "$Side: frequently PLAIN is only supported with SSL, try --ssl or --tls options\n" ) ; |
| 6475 | } |
| 6476 | |
| 6477 | return ; |
| 6478 | } |
| 6479 | |
| 6480 | sub set_ssl |
| 6481 | { |
| 6482 | my ( $imap, $h ) = @_ ; |
| 6483 | # SSL_version can be |
| 6484 | # SSLv3 SSLv2 SSLv23 SSLv23:!SSLv2 (last one is the default in IO-Socket-SSL-1.953) |
| 6485 | # |
| 6486 | |
| 6487 | my $sslargs_hash = $h->{sslargs} ; |
| 6488 | |
| 6489 | my $sslargs_default = { |
| 6490 | SSL_verify_mode => $SSL_VERIFY_POLICY, |
| 6491 | SSL_verifycn_scheme => 'imap', |
| 6492 | SSL_cipher_list => 'DEFAULT:!DH', |
| 6493 | } ; |
| 6494 | |
| 6495 | # initiate with default values |
| 6496 | my %sslargs_mix = %{ $sslargs_default } ; |
| 6497 | # now override with passed values |
| 6498 | @sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ; |
| 6499 | # remove keys with undef values |
| 6500 | foreach my $key ( keys %sslargs_mix ) { |
| 6501 | delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ; |
| 6502 | } |
| 6503 | # back to an ARRAY |
| 6504 | my @sslargs_mix = %sslargs_mix ; |
| 6505 | #myprint( Data::Dumper->Dump( [ $sslargs_hash, $sslargs_default, \%sslargs_mix, \@sslargs_mix ] ) ) ; |
| 6506 | $imap->Ssl( \@sslargs_mix ) ; |
| 6507 | return ; |
| 6508 | } |
| 6509 | |
| 6510 | sub set_tls |
| 6511 | { |
| 6512 | my ( $imap, $h ) = @_ ; |
| 6513 | |
| 6514 | my $sslargs_hash = $h->{sslargs} ; |
| 6515 | |
| 6516 | my $sslargs_default = { |
| 6517 | SSL_verify_mode => $SSL_VERIFY_POLICY, |
| 6518 | SSL_cipher_list => 'DEFAULT:!DH', |
| 6519 | } ; |
| 6520 | |
| 6521 | # initiate with default values |
| 6522 | my %sslargs_mix = %{ $sslargs_default } ; |
| 6523 | # now override with passed values |
| 6524 | @sslargs_mix{ keys %{ $sslargs_hash } } = values %{ $sslargs_hash } ; |
| 6525 | # remove keys with undef values |
| 6526 | foreach my $key ( keys %sslargs_mix ) { |
| 6527 | delete $sslargs_mix{ $key } if ( not defined $sslargs_mix{ $key } ) ; |
| 6528 | } |
| 6529 | # back to an ARRAY |
| 6530 | my @sslargs_mix = %sslargs_mix ; |
| 6531 | |
| 6532 | $imap->Starttls( \@sslargs_mix ) ; |
| 6533 | return ; |
| 6534 | } |
| 6535 | |
| 6536 | |
| 6537 | |
| 6538 | |
| 6539 | sub init_imap |
| 6540 | { |
| 6541 | my( |
| 6542 | $host, $port, $user, $domain, $password, |
| 6543 | $mydebugimap, $mytimeout, $fastio, |
| 6544 | $ssl, $tls, $authmech, $authuser, $reconnectretry, |
| 6545 | $proxyauth, $uid, $split, $Side, $h, $mysync ) = @_ ; |
| 6546 | |
| 6547 | my ( $imap ) ; |
| 6548 | |
| 6549 | $imap = Mail::IMAPClient->new() ; |
| 6550 | |
| 6551 | if ( $mysync->{ tee } ) |
| 6552 | { |
| 6553 | # Well, it does not change anything, does it? |
| 6554 | # It does when suppressing the hack with *STDERR |
| 6555 | $imap->Debug_fh( $mysync->{ tee } ) ; |
| 6556 | } |
| 6557 | |
| 6558 | if ( $ssl ) { set_ssl( $imap, $h ) } |
| 6559 | if ( $tls ) { } # can not do set_tls() here because connect() will directly do a STARTTLS |
| 6560 | $imap->Clear(1); |
| 6561 | $imap->Server($host); |
| 6562 | $imap->Port($port); |
| 6563 | $imap->Fast_io($fastio); |
| 6564 | $imap->Buffer($buffersize || $DEFAULT_BUFFER_SIZE); |
| 6565 | $imap->Uid($uid); |
| 6566 | |
| 6567 | |
| 6568 | $imap->Peek(1); |
| 6569 | $imap->Debug($mydebugimap); |
| 6570 | if ( $mysync->{ showpasswords } ) { |
| 6571 | $imap->Showcredentials( 1 ) ; |
| 6572 | } |
| 6573 | defined $mytimeout and $imap->Timeout( $mytimeout ) ; |
| 6574 | |
| 6575 | $imap->Reconnectretry( $reconnectretry ) if ( $reconnectretry ) ; |
| 6576 | $imap->{IMAPSYNC_RECONNECT_COUNT} = 0 ; |
| 6577 | $imap->Ignoresizeerrors( $allowsizemismatch ) ; |
| 6578 | $split and $imap->Maxcommandlength( $SPLIT_FACTOR * $split ) ; |
| 6579 | |
| 6580 | |
| 6581 | return( $imap ) ; |
| 6582 | |
| 6583 | } |
| 6584 | |
| 6585 | sub plainauth |
| 6586 | { |
| 6587 | my $code = shift; |
| 6588 | my $imap = shift; |
| 6589 | |
| 6590 | my $string = mysprintf("%s\x00%s\x00%s", $imap->User, |
| 6591 | $imap->Authuser, $imap->Password); |
| 6592 | return encode_base64("$string", q{}); |
| 6593 | } |
| 6594 | |
| 6595 | # Copy from https://github.com/imapsync/imapsync/pull/25/files |
| 6596 | # Changes "use" pragmas to "require". |
| 6597 | # The openssl system call shall be replaced by pure Perl and |
| 6598 | # https://metacpan.org/pod/Crypt::OpenSSL::PKCS12 |
| 6599 | |
| 6600 | # Now the Joaquin Lopez code: |
| 6601 | # |
| 6602 | # Used this as an example: https://gist.github.com/gsainio/6322375 |
| 6603 | # |
| 6604 | # And this as a reference: https://developers.google.com/accounts/docs/OAuth2ServiceAccount |
| 6605 | # (note there is an http/rest tab, where the real info is hidden away... went on a witch hunt |
| 6606 | # until I noticed that...) |
| 6607 | # |
| 6608 | # This is targeted at gmail to maintain compatibility after google's oauth1 service is deactivated |
| 6609 | # on May 5th, 2015: https://developers.google.com/gmail/oauth_protocol |
| 6610 | # If there are other oauth2 implementations out there, this would need to be modified to be |
| 6611 | # compatible |
| 6612 | # |
| 6613 | # This is a good guide on setting up the google api/apps side of the equation: |
| 6614 | # http://www.limilabs.com/blog/oauth2-gmail-imap-service-account |
| 6615 | # |
| 6616 | # 2016/05/27: Updated to support oauth/key data in the .json files Google now defaults to |
| 6617 | # when creating gmail service accounts. They're easier to work with since they neither |
| 6618 | # requiring decrypting nor specifying the oauth2 client id separately. |
| 6619 | # |
| 6620 | # If the password arg ends in .json, it will assume this new json method, otherwise it |
| 6621 | # will fallback to the "oauth client id;.p12" format it was previously using. |
| 6622 | sub xoauth2 |
| 6623 | { |
| 6624 | require JSON::WebToken ; |
| 6625 | require LWP::UserAgent ; |
| 6626 | require HTML::Entities ; |
| 6627 | require JSON ; |
| 6628 | require JSON::WebToken::Crypt::RSA ; |
| 6629 | require Crypt::OpenSSL::RSA ; |
| 6630 | require Encode::Byte ; |
| 6631 | require IO::Socket::SSL ; |
| 6632 | |
| 6633 | my $code = shift; |
| 6634 | my $imap = shift; |
| 6635 | |
| 6636 | my ($iss,$key); |
| 6637 | |
| 6638 | if( $imap->Password =~ /^(.*\.json)$/x ) |
| 6639 | { |
| 6640 | my $json = JSON->new( ) ; |
| 6641 | my $filename = $1; |
| 6642 | $sync->{ debug } and myprint( "XOAUTH2 json file: $filename\n" ) ; |
| 6643 | my $FILE ; |
| 6644 | if ( ! open( $FILE, '<', $filename ) ) |
| 6645 | { |
| 6646 | $sync->{nb_errors}++ ; |
| 6647 | exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, |
| 6648 | "error [$filename]: $OS_ERROR\n" |
| 6649 | ) ; |
| 6650 | } |
| 6651 | my $jsonfile = $json->decode( join q{}, <$FILE> ) ; |
| 6652 | close $FILE ; |
| 6653 | |
| 6654 | $iss = $jsonfile->{client_id}; |
| 6655 | $key = $jsonfile->{private_key}; |
| 6656 | $sync->{ debug } and myprint( "Service account: $iss\n"); |
| 6657 | $sync->{ debug } and myprint( "Private key:\n$key\n"); |
| 6658 | } |
| 6659 | else |
| 6660 | { |
| 6661 | # Get iss (service account address), keyfile name, and keypassword if necessary |
| 6662 | ( $iss, my $keyfile, my $keypass ) = $imap->Password =~ /([\-\d\w\@\.]+);([a-zA-Z0-9 \_\-\.\/]+);?(.*)?/x ; |
| 6663 | |
| 6664 | # Assume key password is google default if not provided |
| 6665 | $keypass = 'notasecret' if not $keypass; |
| 6666 | |
| 6667 | $sync->{ debug } and myprint( "Service account: $iss\nKey file: $keyfile\nKey password: $keypass\n"); |
| 6668 | |
| 6669 | # Get private key from p12 file (would be better in perl...) |
| 6670 | $key = `openssl pkcs12 -in "$keyfile" -nodes -nocerts -passin pass:$keypass -nomacver`; |
| 6671 | |
| 6672 | $sync->{ debug } and myprint( "Private key:\n$key\n"); |
| 6673 | } |
| 6674 | |
| 6675 | # Create jwt of oauth2 request |
| 6676 | my $time = time ; |
| 6677 | my $jwt = JSON::WebToken->encode( { |
| 6678 | 'iss' => $iss, # service account |
| 6679 | 'scope' => 'https://mail.google.com/', |
| 6680 | 'aud' => 'https://www.googleapis.com/oauth2/v3/token', |
| 6681 | 'exp' => $time + $DEFAULT_EXPIRATION_TIME_OAUTH2_PK12, |
| 6682 | 'iat' => $time, |
| 6683 | 'prn' => $imap->User # user to auth as |
| 6684 | }, |
| 6685 | $key, 'RS256', {'typ' => 'JWT'} ); # Crypt::OpenSSL::RSA needed here. |
| 6686 | |
| 6687 | # Post oauth2 request |
| 6688 | my $ua = LWP::UserAgent->new( ) ; |
| 6689 | $ua->env_proxy( ) ; |
| 6690 | |
| 6691 | my $response = $ua->post('https://www.googleapis.com/oauth2/v3/token', |
| 6692 | { grant_type => HTML::Entities::encode_entities('urn:ietf:params:oauth:grant-type:jwt-bearer'), |
| 6693 | assertion => $jwt } ) ; |
| 6694 | |
| 6695 | unless( $response->is_success( ) ) { |
| 6696 | $sync->{nb_errors}++ ; |
| 6697 | exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, |
| 6698 | $response->code, "\n", $response->content, "\n" |
| 6699 | ) ; |
| 6700 | }else{ |
| 6701 | $sync->{ debug } and myprint( $response->content ) ; |
| 6702 | } |
| 6703 | |
| 6704 | # access_token in response is what we need |
| 6705 | my $data = JSON::decode_json( $response->content ) ; |
| 6706 | |
| 6707 | # format as oauth2 auth data |
| 6708 | my $xoauth2_string = encode_base64( 'user=' . $imap->User . "\1auth=Bearer " . $data->{access_token} . "\1\1", q{} ) ; |
| 6709 | |
| 6710 | $sync->{ debug } and myprint( "XOAUTH2 String: $xoauth2_string\n"); |
| 6711 | return($xoauth2_string); |
| 6712 | } |
| 6713 | |
| 6714 | |
| 6715 | |
| 6716 | |
| 6717 | # xoauth() thanks to Eduardo Bortoluzzi Junior |
| 6718 | sub xoauth |
| 6719 | { |
| 6720 | require URI::Escape ; |
| 6721 | require Data::Uniqid ; |
| 6722 | |
| 6723 | my $code = shift; |
| 6724 | my $imap = shift; |
| 6725 | |
| 6726 | # The base information needed to construct the OAUTH authentication |
| 6727 | my $method = 'GET' ; |
| 6728 | my $url = mysprintf( 'https://mail.google.com/mail/b/%s/imap/', $imap->User ) ; |
| 6729 | my $urlparm = mysprintf( 'xoauth_requestor_id=%s', URI::Escape::uri_escape( $imap->User ) ) ; |
| 6730 | |
| 6731 | # For Google Apps, the consumer key is the primary domain |
| 6732 | # TODO: create a command line argument to define the consumer key |
| 6733 | my @user_parts = split /@/x, $imap->User ; |
| 6734 | $sync->{ debug } and myprint( "XOAUTH: consumer key: $user_parts[1]\n" ) ; |
| 6735 | |
| 6736 | # All the parameters needed to be signed on the XOAUTH |
| 6737 | my %hash = (); |
| 6738 | $hash { 'xoauth_requestor_id' } = URI::Escape::uri_escape($imap->User); |
| 6739 | $hash { 'oauth_consumer_key' } = $user_parts[1]; |
| 6740 | $hash { 'oauth_nonce' } = md5_hex(Data::Uniqid::uniqid(rand(), 1==1)); |
| 6741 | $hash { 'oauth_signature_method' } = 'HMAC-SHA1'; |
| 6742 | $hash { 'oauth_timestamp' } = time ; |
| 6743 | $hash { 'oauth_version' } = '1.0'; |
| 6744 | |
| 6745 | # Base will hold the string to be signed |
| 6746 | my $base = "$method&" . URI::Escape::uri_escape( $url ) . q{&} ; |
| 6747 | |
| 6748 | # The parameters must be in dictionary order before signing |
| 6749 | my $baseparms = q{} ; |
| 6750 | foreach my $key ( sort keys %hash ) { |
| 6751 | if ( length( $baseparms ) > 0 ) { |
| 6752 | $baseparms .= q{&} ; |
| 6753 | } |
| 6754 | |
| 6755 | $baseparms .= "$key=$hash{$key}" ; |
| 6756 | } |
| 6757 | |
| 6758 | $base .= URI::Escape::uri_escape($baseparms); |
| 6759 | $sync->{ debug } and myprint( "XOAUTH: base request to sign: $base\n" ) ; |
| 6760 | # Sign it with the consumer secret, informed on the command line (password) |
| 6761 | my $digest = hmac_sha1( $base, URI::Escape::uri_escape( $imap->Password ) . q{&} ) ; |
| 6762 | |
| 6763 | # The parameters signed become a parameter and... |
| 6764 | $hash { 'oauth_signature' } = URI::Escape::uri_escape( substr encode_base64( $digest ), 0, $MINUS_ONE ) ; |
| 6765 | |
| 6766 | # ... we don't need the requestor_id anymore. |
| 6767 | delete $hash{'xoauth_requestor_id'} ; |
| 6768 | |
| 6769 | # Create the final authentication string |
| 6770 | my $string = $method . q{ } . $url . q{?} . $urlparm .q{ } ; |
| 6771 | |
| 6772 | # All the parameters must be sorted |
| 6773 | $baseparms = q{}; |
| 6774 | foreach my $key (sort keys %hash) { |
| 6775 | if(length($baseparms)>0) { |
| 6776 | $baseparms .= q{,} ; |
| 6777 | } |
| 6778 | |
| 6779 | $baseparms .= "$key=\"$hash{$key}\""; |
| 6780 | } |
| 6781 | |
| 6782 | $string .= $baseparms; |
| 6783 | |
| 6784 | $sync->{ debug } and myprint( "XOAUTH: authentication string: $string\n" ) ; |
| 6785 | |
| 6786 | # It must be base64 encoded |
| 6787 | return encode_base64("$string", q{}); |
| 6788 | } |
| 6789 | |
| 6790 | |
| 6791 | sub xmasterauth |
| 6792 | { |
| 6793 | # This is Kerio auth admin |
| 6794 | # This code comes from |
| 6795 | # https://github.com/imapsync/imapsync/pull/53/files |
| 6796 | |
| 6797 | my $imap = shift ; |
| 6798 | |
| 6799 | my $user = $imap->User( ) ; |
| 6800 | my $password = $imap->Password( ) ; |
| 6801 | my $authmech = 'X-MASTERAUTH' ; |
| 6802 | |
| 6803 | my @challenge = $imap->tag_and_run( $authmech, "+" ) ; |
| 6804 | if ( not defined $challenge[0] ) |
| 6805 | { |
| 6806 | $sync->{nb_errors}++ ; |
| 6807 | exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, |
| 6808 | "Failure authenticate with $authmech: ", |
| 6809 | $imap->LastError, "\n" |
| 6810 | ) ; |
| 6811 | return ; # hahaha! |
| 6812 | } |
| 6813 | $sync->{ debug } and myprint( "X-MASTERAUTH challenge: [@challenge]\n" ) ; |
| 6814 | |
| 6815 | $challenge[1] =~ s/^\+ |^\s+|\s+$//g ; |
| 6816 | if ( ! $imap->_imap_command( { addcrlf => 1, addtag => 0, tag => $imap->Count }, md5_hex( $challenge[1] . $password ) ) ) |
| 6817 | { |
| 6818 | $sync->{nb_errors}++ ; |
| 6819 | exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, |
| 6820 | "Failure authenticate with $authmech: ", |
| 6821 | $imap->LastError, "\n" |
| 6822 | ) ; |
| 6823 | } |
| 6824 | |
| 6825 | if ( ! $imap->tag_and_run( 'X-SETUSER ' . $user ) ) |
| 6826 | { |
| 6827 | $sync->{nb_errors}++ ; |
| 6828 | exit_clean( $sync, $EXIT_AUTHENTICATION_FAILURE, |
| 6829 | "Failure authenticate with $authmech: ", |
| 6830 | "X-SETUSER ", $imap->LastError, "\n" |
| 6831 | ) ; |
| 6832 | } |
| 6833 | |
| 6834 | $imap->State( Mail::IMAPClient::Authenticated ) ; |
| 6835 | # I comment this state because "Selected" state is usually done by SELECT or EXAMINE imap commands |
| 6836 | # $imap->State( Mail::IMAPClient::Selected ) ; |
| 6837 | |
| 6838 | return ; |
| 6839 | } |
| 6840 | |
| 6841 | |
| 6842 | sub tests_do_valid_directory |
| 6843 | { |
| 6844 | note( 'Entering tests_do_valid_directory()' ) ; |
| 6845 | |
| 6846 | Readonly my $NB_UNIX_tests_do_valid_directory => 2 ; |
| 6847 | SKIP: { |
| 6848 | skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory ) if ( 'MSWin32' eq $OSNAME ) ; |
| 6849 | ok( 1 == do_valid_directory( '.'), 'do_valid_directory: . good' ) ; |
| 6850 | ok( 1 == do_valid_directory( './W/tmp/tests/valid/sub'), 'do_valid_directory: ./W/tmp/tests/valid/sub good' ) ; |
| 6851 | } |
| 6852 | Readonly my $NB_UNIX_tests_do_valid_directory_non_root => 2 ; |
| 6853 | SKIP: { |
| 6854 | skip( 'Tests only for Unix', $NB_UNIX_tests_do_valid_directory_non_root ) if ( 'MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ; |
| 6855 | diag( 'Error / not writable is on purpose' ) ; |
| 6856 | ok( 0 == do_valid_directory( '/'), 'do_valid_directory: / bad' ) ; |
| 6857 | diag( 'Error permission denied on /noway is on purpose' ) ; |
| 6858 | ok( 0 == do_valid_directory( '/noway'), 'do_valid_directory: /noway bad' ) ; |
| 6859 | } |
| 6860 | |
| 6861 | |
| 6862 | note( 'Leaving tests_do_valid_directory()' ) ; |
| 6863 | return ; |
| 6864 | } |
| 6865 | |
| 6866 | sub banner_imapsync |
| 6867 | { |
| 6868 | my $mysync = shift @ARG ; |
| 6869 | my @argv = @ARG ; |
| 6870 | |
| 6871 | my $banner_imapsync = join q{}, |
| 6872 | q{$RCSfile: imapsync,v $ }, |
| 6873 | q{$Revision: 1.977 $ }, |
| 6874 | q{$Date: 2019/12/23 20:18:02 $ }, |
| 6875 | "\n", |
| 6876 | "Command line used, run by $EXECUTABLE_NAME:\n", |
| 6877 | "$PROGRAM_NAME ", command_line_nopassword( $mysync, @argv ), "\n" ; |
| 6878 | |
| 6879 | return( $banner_imapsync ) ; |
| 6880 | } |
| 6881 | |
| 6882 | sub do_valid_directory |
| 6883 | { |
| 6884 | my $dir = shift @ARG ; |
| 6885 | |
| 6886 | # all good => return ok. |
| 6887 | return( 1 ) if ( -d $dir and -r _ and -w _ ) ; |
| 6888 | |
| 6889 | # exist but bad |
| 6890 | if ( -e $dir and not -d _ ) { |
| 6891 | myprint( "Error: $dir exists but is not a directory\n" ) ; |
| 6892 | return( 0 ) ; |
| 6893 | } |
| 6894 | if ( -e $dir and not -w _ ) { |
| 6895 | my $sb = stat $dir ; |
| 6896 | myprintf( "Error: directory %s is not writable for user %s, permissions are %04o and owner is %s ( uid %s )\n", |
| 6897 | $dir, getpwuid_any_os( $EFFECTIVE_USER_ID ), ($sb->mode & oct($PERMISSION_FILTER) ), getpwuid_any_os( $sb->uid ), $sb->uid( ) ) ; |
| 6898 | return( 0 ) ; |
| 6899 | } |
| 6900 | # Trying to create it |
| 6901 | myprint( "Creating directory $dir\n" ) ; |
| 6902 | if ( ! eval { mkpath( $dir ) } ) { |
| 6903 | myprint( "$EVAL_ERROR" ) if ( $EVAL_ERROR ) ; |
| 6904 | } |
| 6905 | return( 1 ) if ( -d $dir and -r _ and -w _ ) ; |
| 6906 | return( 0 ) ; |
| 6907 | } |
| 6908 | |
| 6909 | |
| 6910 | sub tests_match_a_pid_number |
| 6911 | { |
| 6912 | note( 'Entering tests_match_a_pid_number()' ) ; |
| 6913 | |
| 6914 | is( undef, match_a_pid_number( ), 'match_a_pid_number: no args => undef' ) ; |
| 6915 | is( undef, match_a_pid_number( q{} ), 'match_a_pid_number: "" => undef' ) ; |
| 6916 | is( undef, match_a_pid_number( 'lalala' ), 'match_a_pid_number: lalala => undef' ) ; |
| 6917 | is( 1, match_a_pid_number( 1 ), 'match_a_pid_number: 1 => 1' ) ; |
| 6918 | is( 1, match_a_pid_number( 123 ), 'match_a_pid_number: 123 => 1' ) ; |
| 6919 | is( 1, match_a_pid_number( -123 ), 'match_a_pid_number: -123 => 1' ) ; |
| 6920 | is( 1, match_a_pid_number( '123' ), 'match_a_pid_number: "123" => 1' ) ; |
| 6921 | is( 1, match_a_pid_number( '-123' ), 'match_a_pid_number: "-123" => 1' ) ; |
| 6922 | is( undef, match_a_pid_number( 'a123' ), 'match_a_pid_number: a123 => undef' ) ; |
| 6923 | is( undef, match_a_pid_number( '-a123' ), 'match_a_pid_number: -a123 => undef' ) ; |
| 6924 | is( 1, match_a_pid_number( 99999 ), 'match_a_pid_number: 99999 => 1' ) ; |
| 6925 | is( 1, match_a_pid_number( -99999 ), 'match_a_pid_number: -99999 => 1' ) ; |
| 6926 | is( undef, match_a_pid_number( 0 ), 'match_a_pid_number: 0 => undef' ) ; |
| 6927 | is( undef, match_a_pid_number( 100000 ), 'match_a_pid_number: 100000 => undef' ) ; |
| 6928 | is( undef, match_a_pid_number( 123456 ), 'match_a_pid_number: 123456 => undef' ) ; |
| 6929 | is( undef, match_a_pid_number( '-0' ), 'match_a_pid_number: "-0" => undef' ) ; |
| 6930 | is( undef, match_a_pid_number( -100000 ), 'match_a_pid_number: -100000 => undef' ) ; |
| 6931 | is( undef, match_a_pid_number( -123456 ), 'match_a_pid_number: -123456 => undef' ) ; |
| 6932 | |
| 6933 | note( 'Leaving tests_match_a_pid_number()' ) ; |
| 6934 | return ; |
| 6935 | } |
| 6936 | |
| 6937 | sub match_a_pid_number |
| 6938 | { |
| 6939 | my $pid = shift @ARG ; |
| 6940 | if ( ! defined $pid ) { return ; } |
| 6941 | #print "$pid\n" ; |
| 6942 | if ( ! match( $pid, '^-?\d+$' ) ) { return ; } |
| 6943 | #print "$pid\n" ; |
| 6944 | # can be negative on Windows |
| 6945 | #if ( 0 > $pid ) { return ; } |
| 6946 | #if ( 65535 < $pid ) { return ; } |
| 6947 | if ( 99999 < abs( $pid ) ) { return ; } |
| 6948 | if ( 0 == abs( $pid ) ) { return ; } |
| 6949 | return 1 ; |
| 6950 | } |
| 6951 | |
| 6952 | sub tests_remove_pidfile_not_running |
| 6953 | { |
| 6954 | note( 'Entering tests_remove_pidfile_not_running()' ) ; |
| 6955 | |
| 6956 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'remove_pidfile_not_running: mkpath W/tmp/tests/' ) ; |
| 6957 | is( undef, remove_pidfile_not_running( ), 'remove_pidfile_not_running: no args => undef' ) ; |
| 6958 | is( undef, remove_pidfile_not_running( './W' ), 'remove_pidfile_not_running: a dir => undef' ) ; |
| 6959 | is( undef, remove_pidfile_not_running( 'noexists' ), 'remove_pidfile_not_running: noexists => undef' ) ; |
| 6960 | is( 1, touch( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: prepa empty W/tmp/tests/empty.pid' ) ; |
| 6961 | is( undef, remove_pidfile_not_running( 'W/tmp/tests/empty.pid' ), 'remove_pidfile_not_running: W/tmp/tests/empty.pid => undef' ) ; |
| 6962 | is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/lalala.pid' ) ; |
| 6963 | is( undef, remove_pidfile_not_running( 'W/tmp/tests/lalala.pid' ), 'remove_pidfile_not_running: W/tmp/tests/lalala.pid => undef' ) ; |
| 6964 | is( '55555', string_to_file( '55555', 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/notrunning.pid' ) ; |
| 6965 | is( 1, remove_pidfile_not_running( 'W/tmp/tests/notrunning.pid' ), 'remove_pidfile_not_running: W/tmp/tests/notrunning.pid => 1' ) ; |
| 6966 | is( $PROCESS_ID, string_to_file( $PROCESS_ID, 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: prepa W/tmp/tests/running.pid' ) ; |
| 6967 | is( undef, remove_pidfile_not_running( 'W/tmp/tests/running.pid' ), 'remove_pidfile_not_running: W/tmp/tests/running.pid => undef' ) ; |
| 6968 | |
| 6969 | note( 'Leaving tests_remove_pidfile_not_running()' ) ; |
| 6970 | return ; |
| 6971 | } |
| 6972 | |
| 6973 | sub remove_pidfile_not_running |
| 6974 | { |
| 6975 | # |
| 6976 | my $pid_filename = shift @ARG ; |
| 6977 | |
| 6978 | if ( ! $pid_filename ) { myprint( "No variable pid_filename\n" ) ; return } ; |
| 6979 | if ( ! -e $pid_filename ) { myprint( "File $pid_filename does not exist\n" ) ; return } ; |
| 6980 | if ( ! -f $pid_filename ) { myprint( "File $pid_filename is not a file\n" ) ; return } ; |
| 6981 | |
| 6982 | my $pid = firstline( $pid_filename ) ; |
| 6983 | if ( ! match_a_pid_number( $pid ) ) { myprint( "pid $pid in $pid_filename is not a number\n" ) ; return } ; |
| 6984 | # can't kill myself => do nothing |
| 6985 | if ( ! kill 'ZERO', $PROCESS_ID ) { myprint( "Can not kill ZERO myself $PROCESS_ID\n" ) ; return } ; |
| 6986 | |
| 6987 | # can't kill ZERO the pid => it is gone or own by another user => remove pidfile |
| 6988 | if ( ! kill 'ZERO', $pid ) { |
| 6989 | myprint( "Removing old $pid_filename since its PID $pid is not running anymore (oo-killed?)\n" ) ; |
| 6990 | if ( unlink $pid_filename ) { |
| 6991 | myprint( "Removed old $pid_filename\n" ) ; |
| 6992 | return 1 ; |
| 6993 | }else{ |
| 6994 | myprint( "Could not remove old $pid_filename because $!\n" ) ; |
| 6995 | return ; |
| 6996 | } |
| 6997 | } |
| 6998 | myprint( "Another imapsync process $pid is running as says pidfile $pid_filename\n" ) ; |
| 6999 | return ; |
| 7000 | } |
| 7001 | |
| 7002 | |
| 7003 | sub tests_tail |
| 7004 | { |
| 7005 | note( 'Entering tests_tail()' ) ; |
| 7006 | |
| 7007 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'tail: mkpath W/tmp/tests/' ) ; |
| 7008 | ok( ( ! -e 'W/tmp/tests/tail.pid' || unlink 'W/tmp/tests/tail.pid' ), 'tail: unlink W/tmp/tests/tail.pid' ) ; |
| 7009 | ok( ( ! -e 'W/tmp/tests/tail.txt' || unlink 'W/tmp/tests/tail.txt' ), 'tail: unlink W/tmp/tests/tail.txt' ) ; |
| 7010 | |
| 7011 | is( undef, tail( ), 'tail: no args => undef' ) ; |
| 7012 | my $mysync ; |
| 7013 | is( undef, tail( $mysync ), 'tail: no pidfile => undef' ) ; |
| 7014 | |
| 7015 | $mysync->{pidfile} = 'W/tmp/tests/tail.pid' ; |
| 7016 | is( undef, tail( $mysync ), 'tail: no pidfilelocking => undef' ) ; |
| 7017 | |
| 7018 | $mysync->{pidfilelocking} = 1 ; |
| 7019 | is( undef, tail( $mysync ), 'tail: pidfile no exists => undef' ) ; |
| 7020 | |
| 7021 | |
| 7022 | my $pidandlog = "33333\nW/tmp/tests/tail.txt\n" ; |
| 7023 | is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put pid 33333 and tail.txt in pidfile' ) ; |
| 7024 | is( undef, tail( $mysync ), 'tail: logfile to tail no exists => undef' ) ; |
| 7025 | |
| 7026 | my $tailcontent = "L1\nL2\nL3\nL4\nL5\n" ; |
| 7027 | is( $tailcontent, string_to_file( $tailcontent, 'W/tmp/tests/tail.txt' ), |
| 7028 | 'tail: put L1\nL2\nL3\nL4\nL5\n in W/tmp/tests/tail.txt' ) ; |
| 7029 | |
| 7030 | is( undef, tail( $mysync ), 'tail: fake pid in pidfile + tail off => 1' ) ; |
| 7031 | |
| 7032 | $mysync->{ tail } = 1 ; |
| 7033 | is( 1, tail( $mysync ), 'tail: fake pid in pidfile + tail on=> 1' ) ; |
| 7034 | |
| 7035 | # put my own pid, won't do tail |
| 7036 | $pidandlog = "$PROCESS_ID\nW/tmp/tests/tail.txt\n" ; |
| 7037 | is( $pidandlog, string_to_file( $pidandlog, $mysync->{pidfile} ), 'tail: put my own PID in pidfile' ) ; |
| 7038 | is( undef, tail( $mysync ), 'tail: my own pid in pidfile => undef' ) ; |
| 7039 | |
| 7040 | note( 'Leaving tests_tail()' ) ; |
| 7041 | return ; |
| 7042 | } |
| 7043 | |
| 7044 | |
| 7045 | |
| 7046 | sub tail |
| 7047 | { |
| 7048 | # return undef on failures |
| 7049 | # return 1 on success |
| 7050 | |
| 7051 | my $mysync = shift ; |
| 7052 | |
| 7053 | # no tail when aborting! |
| 7054 | if ( $mysync->{ abort } ) { return ; } |
| 7055 | |
| 7056 | my $pidfile = $mysync->{pidfile} ; |
| 7057 | my $lock = $mysync->{pidfilelocking} ; |
| 7058 | my $tail = $mysync->{tail} ; |
| 7059 | |
| 7060 | if ( ! $pidfile ) { return ; } |
| 7061 | if ( ! $lock ) { return ; } |
| 7062 | if ( ! $tail ) { return ; } |
| 7063 | |
| 7064 | my $pidtotail = firstline( $pidfile ) ; |
| 7065 | if ( ! $pidtotail ) { return ; } |
| 7066 | |
| 7067 | |
| 7068 | |
| 7069 | # It should not happen but who knows... |
| 7070 | if ( $pidtotail eq $PROCESS_ID ) { return ; } |
| 7071 | |
| 7072 | |
| 7073 | my $filetotail = secondline( $pidfile ) ; |
| 7074 | if ( ! $filetotail ) { return ; } |
| 7075 | |
| 7076 | if ( ! -r $filetotail ) |
| 7077 | { |
| 7078 | #myprint( "Error: can not read $filetotail\n" ) ; |
| 7079 | return ; |
| 7080 | } |
| 7081 | |
| 7082 | myprint( "Doing a tail -f on $filetotail for processus pid $pidtotail until it is finished.\n" ) ; |
| 7083 | my $file = File::Tail->new( |
| 7084 | name => $filetotail, |
| 7085 | nowait => 1, |
| 7086 | interval => 1, |
| 7087 | tail => 1, |
| 7088 | adjustafter => 2 |
| 7089 | ); |
| 7090 | |
| 7091 | my $moretimes = 200 ; |
| 7092 | # print one line at least |
| 7093 | my $line = $file->read ; |
| 7094 | myprint( $line ) ; |
| 7095 | while ( isrunning( $pidtotail, \$moretimes ) and defined( $line = $file->read ) ) |
| 7096 | { |
| 7097 | myprint( $line ); |
| 7098 | sleep( 0.02 ) ; |
| 7099 | } |
| 7100 | |
| 7101 | return 1 ; |
| 7102 | } |
| 7103 | |
| 7104 | sub isrunning |
| 7105 | { |
| 7106 | my $pidtocheck = shift ; |
| 7107 | my $moretimes_ref = shift ; |
| 7108 | |
| 7109 | if ( kill 'ZERO', $pidtocheck ) |
| 7110 | { |
| 7111 | #myprint( "$pidtocheck running\n" ) ; |
| 7112 | return 1 ; |
| 7113 | } |
| 7114 | elsif ( $$moretimes_ref >= 0 ) |
| 7115 | { |
| 7116 | # continue to consider it running |
| 7117 | $$moretimes_ref-- ; |
| 7118 | return 1 ; |
| 7119 | } |
| 7120 | else |
| 7121 | { |
| 7122 | myprint( "Tailed processus $pidtocheck ended\n" ) ; |
| 7123 | return ; |
| 7124 | } |
| 7125 | } |
| 7126 | |
| 7127 | sub tests_write_pidfile |
| 7128 | { |
| 7129 | note( 'Entering tests_write_pidfile()' ) ; |
| 7130 | |
| 7131 | my $mysync ; |
| 7132 | |
| 7133 | is( 1, write_pidfile( ), 'write_pidfile: no args => 1' ) ; |
| 7134 | |
| 7135 | # no pidfile => ok |
| 7136 | $mysync->{pidfile} = q{} ; |
| 7137 | is( 1, write_pidfile( $mysync ), 'write_pidfile: no pidfile => undef' ) ; |
| 7138 | |
| 7139 | # The pidfile path is bad => failure |
| 7140 | $mysync->{pidfile} = '/no/no/no.pid' ; |
| 7141 | is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid, no lock => undef' ) ; |
| 7142 | |
| 7143 | $mysync->{pidfilelocking} = 1 ; |
| 7144 | is( undef, write_pidfile( $mysync ), 'write_pidfile: no permission for /no/no/no.pid + lock => undef' ) ; |
| 7145 | |
| 7146 | $mysync->{pidfile} = 'W/tmp/tests/test.pid' ; |
| 7147 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'write_pidfile: mkpath W/tmp/tests/' ) ; |
| 7148 | is( 1, touch( $mysync->{pidfile} ), 'write_pidfile: lock prepa' ) ; |
| 7149 | |
| 7150 | $mysync->{pidfilelocking} = 0 ; |
| 7151 | is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock => 1' ) ; |
| 7152 | is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains $PROCESS_ID" ) ; |
| 7153 | is( q{}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: W/tmp/tests/test.pid contains no second line" ) ; |
| 7154 | |
| 7155 | $mysync->{pidfilelocking} = 1 ; |
| 7156 | is( undef, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + lock => undef' ) ; |
| 7157 | |
| 7158 | |
| 7159 | $mysync->{pidfilelocking} = 0 ; |
| 7160 | $mysync->{ logfile } = 'rrrr.txt' ; |
| 7161 | is( 1, write_pidfile( $mysync ), 'write_pidfile: W/tmp/tests/test.pid + no lock + logfile => 1' ) ; |
| 7162 | is( $PROCESS_ID, firstline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains $PROCESS_ID" ) ; |
| 7163 | is( q{rrrr.txt}, secondline( 'W/tmp/tests/test.pid' ), "write_pidfile: + no lock + logfile W/tmp/tests/test.pid contains rrrr.txt" ) ; |
| 7164 | |
| 7165 | |
| 7166 | note( 'Leaving tests_write_pidfile()' ) ; |
| 7167 | return ; |
| 7168 | } |
| 7169 | |
| 7170 | |
| 7171 | |
| 7172 | sub write_pidfile |
| 7173 | { |
| 7174 | # returns undef if something is considered fatal |
| 7175 | # returns 1 otherwise |
| 7176 | |
| 7177 | if ( ! @ARG ) { return 1 ; } |
| 7178 | |
| 7179 | my $mysync = shift @ARG ; |
| 7180 | |
| 7181 | # Do not write the pid file if this process goal is to abort the process designed by the pid file |
| 7182 | if ( $mysync->{abort} ) { return 1 ; } |
| 7183 | |
| 7184 | # |
| 7185 | my $pid_filename = $mysync->{ pidfile } ; |
| 7186 | my $lock = $mysync->{ pidfilelocking } ; |
| 7187 | |
| 7188 | if ( ! $pid_filename ) |
| 7189 | { |
| 7190 | myprint( "PID file is unset ( to set it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ; |
| 7191 | return( 1 ) ; |
| 7192 | } |
| 7193 | |
| 7194 | myprint( "PID file is $pid_filename ( to change it, use --pidfile filepath ; to avoid it use --pidfile \"\" )\n" ) ; |
| 7195 | if ( -e $pid_filename and $lock ) { |
| 7196 | myprint( "$pid_filename already exists, another imapsync may be curently running. Aborting imapsync.\n" ) ; |
| 7197 | return ; |
| 7198 | |
| 7199 | } |
| 7200 | |
| 7201 | if ( -e $pid_filename ) { |
| 7202 | myprint( "$pid_filename already exists, overwriting it ( use --pidfilelocking to avoid concurrent runs )\n" ) ; |
| 7203 | } |
| 7204 | |
| 7205 | my $pid_string = "$PROCESS_ID\n" ; |
| 7206 | my $pid_message = "Writing my PID $PROCESS_ID in $pid_filename\n" ; |
| 7207 | |
| 7208 | if ( $mysync->{ logfile } ) |
| 7209 | { |
| 7210 | $pid_string .= "$mysync->{ logfile }\n" ; |
| 7211 | $pid_message .= "Writing also my logfile name in $pid_filename : $mysync->{ logfile }\n" ; |
| 7212 | } |
| 7213 | |
| 7214 | if ( open my $FILE_HANDLE, '>', $pid_filename ) { |
| 7215 | myprint( $pid_message ) ; |
| 7216 | print $FILE_HANDLE $pid_string ; |
| 7217 | close $FILE_HANDLE ; |
| 7218 | return( 1 ) ; |
| 7219 | } |
| 7220 | else |
| 7221 | { |
| 7222 | myprint( "Could not open $pid_filename for writing. Check permissions or disk space: $OS_ERROR\n" ) ; |
| 7223 | return ; |
| 7224 | } |
| 7225 | } |
| 7226 | |
| 7227 | |
| 7228 | sub fix_Inbox_INBOX_mapping |
| 7229 | { |
| 7230 | my( $h1_all, $h2_all ) = @_ ; |
| 7231 | |
| 7232 | my $regex = q{} ; |
| 7233 | SWITCH: { |
| 7234 | if ( exists $h1_all->{INBOX} and exists $h2_all->{INBOX} ) { $regex = q{} ; last SWITCH ; } ; |
| 7235 | if ( exists $h1_all->{Inbox} and exists $h2_all->{Inbox} ) { $regex = q{} ; last SWITCH ; } ; |
| 7236 | if ( exists $h1_all->{INBOX} and exists $h2_all->{Inbox} ) { $regex = q{s/^INBOX$/Inbox/x} ; last SWITCH ; } ; |
| 7237 | if ( exists $h1_all->{Inbox} and exists $h2_all->{INBOX} ) { $regex = q{s/^Inbox$/INBOX/x} ; last SWITCH ; } ; |
| 7238 | } ; |
| 7239 | return( $regex ) ; |
| 7240 | } |
| 7241 | |
| 7242 | sub tests_fix_Inbox_INBOX_mapping |
| 7243 | { |
| 7244 | note( 'Entering tests_fix_Inbox_INBOX_mapping()' ) ; |
| 7245 | |
| 7246 | |
| 7247 | my( $h1_all, $h2_all ) ; |
| 7248 | |
| 7249 | $h1_all = { 'INBOX' => q{} } ; |
| 7250 | $h2_all = { 'INBOX' => q{} } ; |
| 7251 | ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX INBOX' ) ; |
| 7252 | |
| 7253 | $h1_all = { 'Inbox' => q{} } ; |
| 7254 | $h2_all = { 'Inbox' => q{} } ; |
| 7255 | ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox Inbox' ) ; |
| 7256 | |
| 7257 | $h1_all = { 'INBOX' => q{} } ; |
| 7258 | $h2_all = { 'Inbox' => q{} } ; |
| 7259 | ok( q{s/^INBOX$/Inbox/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX Inbox' ) ; |
| 7260 | |
| 7261 | $h1_all = { 'Inbox' => q{} } ; |
| 7262 | $h2_all = { 'INBOX' => q{} } ; |
| 7263 | ok( q{s/^Inbox$/INBOX/x} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: Inbox INBOX' ) ; |
| 7264 | |
| 7265 | $h1_all = { 'INBOX' => q{} } ; |
| 7266 | $h2_all = { 'rrrrr' => q{} } ; |
| 7267 | ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: INBOX rrrrrr' ) ; |
| 7268 | |
| 7269 | $h1_all = { 'rrrrr' => q{} } ; |
| 7270 | $h2_all = { 'Inbox' => q{} } ; |
| 7271 | ok( q{} eq fix_Inbox_INBOX_mapping( $h1_all, $h2_all ), 'fix_Inbox_INBOX_mapping: rrrrr Inbox' ) ; |
| 7272 | |
| 7273 | note( 'Leaving tests_fix_Inbox_INBOX_mapping()' ) ; |
| 7274 | return ; |
| 7275 | } |
| 7276 | |
| 7277 | |
| 7278 | sub jux_utf8_list |
| 7279 | { |
| 7280 | my @s_inp = @_ ; |
| 7281 | my $s_out = q{} ; |
| 7282 | foreach my $s ( @s_inp ) { |
| 7283 | $s_out .= jux_utf8( $s ) . "\n" ; |
| 7284 | } |
| 7285 | return( $s_out ) ; |
| 7286 | } |
| 7287 | |
| 7288 | sub tests_jux_utf8_list |
| 7289 | { |
| 7290 | note( 'Entering tests_jux_utf8_list()' ) ; |
| 7291 | |
| 7292 | use utf8 ; |
| 7293 | is( q{}, jux_utf8_list( ), 'jux_utf8_list: void' ) ; |
| 7294 | is( "[]\n", jux_utf8_list( q{} ), 'jux_utf8_list: empty string' ) ; |
| 7295 | is( "[INBOX]\n", jux_utf8_list( 'INBOX' ), 'jux_utf8_list: INBOX' ) ; |
| 7296 | is( "[&ANY-] = [Ö]\n", jux_utf8_list( '&ANY-' ), 'jux_utf8_list: [&ANY-] = [Ö]' ) ; |
| 7297 | |
| 7298 | note( 'Leaving tests_jux_utf8_list()' ) ; |
| 7299 | return( 0 ) ; |
| 7300 | } |
| 7301 | |
| 7302 | # editing utf8 can be tricky without an utf8 editor |
| 7303 | sub tests_jux_utf8_old |
| 7304 | { |
| 7305 | note( 'Entering tests_jux_utf8_old()' ) ; |
| 7306 | |
| 7307 | no utf8 ; |
| 7308 | |
| 7309 | is( '[]', jux_utf8_old( q{} ), 'jux_utf8_old: void => []' ) ; |
| 7310 | is( '[INBOX]', jux_utf8_old( 'INBOX'), 'jux_utf8_old: INBOX => [INBOX]' ) ; |
| 7311 | is( '[&ZTZO9nux-] = [收件箱]', jux_utf8_old( '&ZTZO9nux-'), 'jux_utf8_old: => [&ZTZO9nux-] = [收件箱]' ) ; |
| 7312 | is( '[&ANY-] = [Ö]', jux_utf8_old( '&ANY-'), 'jux_utf8_old: &ANY- => [&ANY-] = [Ö]' ) ; |
| 7313 | # +BD8EQAQ1BDQEOwQ+BDM- SHOULD stay as is! |
| 7314 | is( '[+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]', jux_utf8_old( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8_old: => [+BD8EQAQ1BDQEOwQ+BDM-] = [предлог]' ) ; |
| 7315 | is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8_old( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8_old: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; |
| 7316 | |
| 7317 | note( 'Leaving tests_jux_utf8_old()' ) ; |
| 7318 | return ; |
| 7319 | } |
| 7320 | |
| 7321 | sub jux_utf8_old |
| 7322 | { |
| 7323 | # juxtapose utf8 at the right if different |
| 7324 | my ( $s_utf7 ) = shift ; |
| 7325 | my ( $s_utf8 ) = imap_utf7_decode_old( $s_utf7 ) ; |
| 7326 | |
| 7327 | if ( $s_utf7 eq $s_utf8 ) { |
| 7328 | #myprint( "[$s_utf7]\n" ) ; |
| 7329 | return( "[$s_utf7]" ) ; |
| 7330 | }else{ |
| 7331 | #myprint( "[$s_utf7] = [$s_utf8]\n" ) ; |
| 7332 | return( "[$s_utf7] = [$s_utf8]" ) ; |
| 7333 | } |
| 7334 | } |
| 7335 | |
| 7336 | # Copied from http://cpansearch.perl.org/src/FABPOT/Unicode-IMAPUtf7-2.01/lib/Unicode/IMAPUtf7.pm |
| 7337 | # and then fixed with |
| 7338 | # https://rt.cpan.org/Public/Bug/Display.html?id=11172 |
| 7339 | sub imap_utf7_decode_old |
| 7340 | { |
| 7341 | my ( $s ) = shift ; |
| 7342 | |
| 7343 | # Algorithm |
| 7344 | # On remplace , par / dans les BASE 64 (, entre & et -) |
| 7345 | # On remplace les &, non suivi d'un - par + |
| 7346 | # On remplace les &- par & |
| 7347 | $s =~ s/&([^,&\-]*),([^,\-&]*)\-/&$1\/$2\-/xg ; |
| 7348 | $s =~ s/&(?!\-)/\+/xg ; |
| 7349 | $s =~ s/&\-/&/xg ; |
| 7350 | return( Unicode::String::utf7( $s )->utf8 ) ; |
| 7351 | } |
| 7352 | |
| 7353 | |
| 7354 | |
| 7355 | |
| 7356 | |
| 7357 | sub tests_jux_utf8 |
| 7358 | { |
| 7359 | note( 'Entering tests_jux_utf8()' ) ; |
| 7360 | #no utf8 ; |
| 7361 | use utf8 ; |
| 7362 | |
| 7363 | #binmode STDOUT, ":encoding(UTF-8)" ; |
| 7364 | binmode STDERR, ":encoding(UTF-8)" ; |
| 7365 | |
| 7366 | # This test is because the binary can fail on it, a PAR.pm issue. |
| 7367 | # The failure was with the underlying Encode::IMAPUTF7 module line 66 release 1.05 |
| 7368 | # Was solved by including Encode in imapsync and using "pp -x". |
| 7369 | ok( find_encoding( "UTF-16BE"), 'jux_utf8: Encode::find_encoding: UTF-16BE' ) ; |
| 7370 | |
| 7371 | # |
| 7372 | is( '[]', jux_utf8( q{} ), 'jux_utf8: void => []' ) ; |
| 7373 | is( '[INBOX]', jux_utf8( 'INBOX'), 'jux_utf8: INBOX => [INBOX]' ) ; |
| 7374 | is( '[&ANY-] = [Ö]', jux_utf8( '&ANY-'), 'jux_utf8: &ANY- => [&ANY-] = [Ö]' ) ; |
| 7375 | # +BD8EQAQ1BDQEOwQ+BDM- must stay as is |
| 7376 | is( '[+BD8EQAQ1BDQEOwQ+BDM-]', jux_utf8( '+BD8EQAQ1BDQEOwQ+BDM-' ), 'jux_utf8: => [+BD8EQAQ1BDQEOwQ+BDM-] = [+BD8EQAQ1BDQEOwQ+BDM-]' ) ; |
| 7377 | is( '[&BB8EQAQ+BDUEOgRC-] = [Проект]', jux_utf8( '&BB8EQAQ+BDUEOgRC-' ), 'jux_utf8: => [&BB8EQAQ+BDUEOgRC-] = [Проект]' ) ; |
| 7378 | |
| 7379 | is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( q{R&AOk-ponses 1200+1201+1202} ), 'jux_utf8: [R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]' ) ; |
| 7380 | my $str = Encode::IMAPUTF7::encode("IMAP-UTF-7", 'Réponses 1200+1201+1202' ) ; |
| 7381 | is( '[R&AOk-ponses 1200+1201+1202] = [Réponses 1200+1201+1202]', jux_utf8( $str ), "jux_utf8: [$str] = [Réponses 1200+1201+1202]" ) ; |
| 7382 | |
| 7383 | is( '[INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éà çù&*]', jux_utf8( 'INBOX.&AOkA4ADnAPk-&-*' ), "jux_utf8: [INBOX.&AOkA4ADnAPk-&-*] = [INBOX.éà çù&*]" ) ; |
| 7384 | |
| 7385 | is( '[&ZTZO9nux-] = [收件箱]', jux_utf8( '&ZTZO9nux-'), 'jux_utf8: => [&ZTZO9nux-] = [收件箱]' ) ; |
| 7386 | # |
| 7387 | note( 'Leaving tests_jux_utf8()' ) ; |
| 7388 | return ; |
| 7389 | } |
| 7390 | |
| 7391 | sub jux_utf8 |
| 7392 | { |
| 7393 | #use utf8 ; |
| 7394 | # juxtapose utf8 at the right if different |
| 7395 | my ( $s_utf7 ) = shift ; |
| 7396 | my ( $s_utf8 ) = imap_utf7_decode( $s_utf7 ) ; |
| 7397 | |
| 7398 | if ( $s_utf7 eq $s_utf8 ) { |
| 7399 | #myprint( "[$s_utf7]\n" ) ; |
| 7400 | return( "[$s_utf7]" ) ; |
| 7401 | }else{ |
| 7402 | #myprint( "[$s_utf7] = [$s_utf8]\n" ) ; |
| 7403 | return( "[$s_utf7] = [$s_utf8]" ) ; |
| 7404 | } |
| 7405 | } |
| 7406 | |
| 7407 | sub imap_utf7_decode |
| 7408 | { |
| 7409 | #use utf8 ; |
| 7410 | my ( $s ) = shift ; |
| 7411 | return( Encode::IMAPUTF7::decode("IMAP-UTF-7", $s ) ) ; |
| 7412 | } |
| 7413 | |
| 7414 | sub imap_utf7_encode |
| 7415 | { |
| 7416 | #use utf8 ; |
| 7417 | my ( $s ) = shift ; |
| 7418 | return( Encode::IMAPUTF7::encode("IMAP-UTF-7", $s ) ) ; |
| 7419 | } |
| 7420 | |
| 7421 | |
| 7422 | |
| 7423 | sub imap_utf7_encode_old |
| 7424 | { |
| 7425 | my ( $s ) = @_ ; |
| 7426 | |
| 7427 | $s = Unicode::String::utf8( $s )->utf7 ; |
| 7428 | |
| 7429 | $s =~ s/\+([^\/&\-]*)\/([^\/\-&]*)\-/\+$1,$2\-/xg ; |
| 7430 | $s =~ s/&/&\-/xg ; |
| 7431 | $s =~ s/\+([^+\-]+)?\-/&$1\-/xg ; |
| 7432 | return( $s ) ; |
| 7433 | } |
| 7434 | |
| 7435 | |
| 7436 | |
| 7437 | |
| 7438 | sub select_folder |
| 7439 | { |
| 7440 | my ( $mysync, $imap, $folder, $hostside ) = @_ ; |
| 7441 | if ( ! $imap->select( $folder ) ) { |
| 7442 | my $error = join q{}, |
| 7443 | "$hostside folder $folder: Could not select: ", |
| 7444 | $imap->LastError, "\n" ; |
| 7445 | errors_incr( $mysync, $error ) ; |
| 7446 | return( 0 ) ; |
| 7447 | }else{ |
| 7448 | # ok select succeeded |
| 7449 | return( 1 ) ; |
| 7450 | } |
| 7451 | } |
| 7452 | |
| 7453 | sub examine_folder |
| 7454 | { |
| 7455 | my ( $mysync, $imap, $folder, $hostside ) = @_ ; |
| 7456 | if ( ! $imap->examine( $folder ) ) { |
| 7457 | my $error = join q{}, |
| 7458 | "$hostside folder $folder: Could not examine: ", |
| 7459 | $imap->LastError, "\n" ; |
| 7460 | errors_incr( $mysync, $error ) ; |
| 7461 | return( 0 ) ; |
| 7462 | }else{ |
| 7463 | # ok select succeeded |
| 7464 | return( 1 ) ; |
| 7465 | } |
| 7466 | } |
| 7467 | |
| 7468 | |
| 7469 | sub count_from_select |
| 7470 | { |
| 7471 | my @lines = @ARG ; |
| 7472 | my $count ; |
| 7473 | foreach my $line ( @lines ) { |
| 7474 | #myprint( "line = [$line]\n" ) ; |
| 7475 | if ( $line =~ m/^\*\s+(\d+)\s+EXISTS/x ) { |
| 7476 | $count = $1 ; |
| 7477 | return( $count ) ; |
| 7478 | } |
| 7479 | } |
| 7480 | return( undef ) ; |
| 7481 | } |
| 7482 | |
| 7483 | |
| 7484 | |
| 7485 | sub create_folder_old |
| 7486 | { |
| 7487 | my $mysync = shift @ARG ; |
| 7488 | my( $imap, $h2_fold, $h1_fold ) = @ARG ; |
| 7489 | |
| 7490 | myprint( "Creating (old way) folder [$h2_fold] on host2\n" ) ; |
| 7491 | if ( ( 'INBOX' eq uc $h2_fold ) |
| 7492 | and ( $imap->exists( $h2_fold ) ) ) { |
| 7493 | myprint( "Folder [$h2_fold] already exists\n" ) ; |
| 7494 | return( 1 ) ; |
| 7495 | } |
| 7496 | if ( ! $mysync->{dry} ){ |
| 7497 | if ( ! $imap->create( $h2_fold ) ) { |
| 7498 | my $error = join q{}, |
| 7499 | "Could not create folder [$h2_fold] from [$h1_fold]: ", |
| 7500 | $imap->LastError( ), "\n" ; |
| 7501 | errors_incr( $mysync, $error ) ; |
| 7502 | # success if folder exists ("already exists" error) |
| 7503 | return( 1 ) if $imap->exists( $h2_fold ) ; |
| 7504 | # failure since create failed |
| 7505 | return( 0 ) ; |
| 7506 | }else{ |
| 7507 | #create succeeded |
| 7508 | myprint( "Created ( the old way ) folder [$h2_fold] on host2\n" ) ; |
| 7509 | return( 1 ) ; |
| 7510 | } |
| 7511 | }else{ |
| 7512 | # dry mode, no folder so many imap will fail, assuming failure |
| 7513 | myprint( "Created ( the old way ) folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ; |
| 7514 | return( 0 ) ; |
| 7515 | } |
| 7516 | } |
| 7517 | |
| 7518 | |
| 7519 | sub create_folder |
| 7520 | { |
| 7521 | my $mysync = shift @ARG ; |
| 7522 | my( $myimap2 , $h2_fold , $h1_fold ) = @ARG ; |
| 7523 | my( @parts , $parent ) ; |
| 7524 | |
| 7525 | if ( $myimap2->IsUnconnected( ) ) { |
| 7526 | myprint( "Host2: Unconnected state\n" ) ; |
| 7527 | return( 0 ) ; |
| 7528 | } |
| 7529 | |
| 7530 | if ( $create_folder_old ) { |
| 7531 | return( create_folder_old( $mysync, $myimap2 , $h2_fold , $h1_fold ) ) ; |
| 7532 | } |
| 7533 | myprint( "Creating folder [$h2_fold] on host2\n" ) ; |
| 7534 | if ( ( 'INBOX' eq uc $h2_fold ) |
| 7535 | and ( $myimap2->exists( $h2_fold ) ) ) { |
| 7536 | myprint( "Folder [$h2_fold] already exists\n" ) ; |
| 7537 | return( 1 ) ; |
| 7538 | } |
| 7539 | |
| 7540 | if ( $mixfolders and $myimap2->exists( $h2_fold ) ) { |
| 7541 | myprint( "Folder [$h2_fold] already exists (--nomixfolders is not set)\n" ) ; |
| 7542 | return( 1 ) ; |
| 7543 | } |
| 7544 | |
| 7545 | |
| 7546 | if ( ( not $mixfolders ) and ( $myimap2->exists( $h2_fold ) ) ) { |
| 7547 | myprint( "Folder [$h2_fold] already exists and --nomixfolders is set\n" ) ; |
| 7548 | return( 0 ) ; |
| 7549 | } |
| 7550 | |
| 7551 | @parts = split /\Q$mysync->{ h2_sep }\E/x, $h2_fold ; |
| 7552 | pop @parts ; |
| 7553 | $parent = join $mysync->{ h2_sep }, @parts ; |
| 7554 | $parent =~ s/^\s+|\s+$//xg ; |
| 7555 | if ( ( $parent ne q{} ) and ( ! $myimap2->exists( $parent ) ) ) { |
| 7556 | create_folder( $mysync, $myimap2 , $parent , $h1_fold ) ; |
| 7557 | } |
| 7558 | |
| 7559 | if ( ! $mysync->{dry} ) { |
| 7560 | if ( ! $myimap2->create( $h2_fold ) ) { |
| 7561 | my $error = join q{}, |
| 7562 | "Could not create folder [$h2_fold] from [$h1_fold]: " , |
| 7563 | $myimap2->LastError( ), "\n" ; |
| 7564 | errors_incr( $mysync, $error ) ; |
| 7565 | # success if folder exists ("already exists" error) |
| 7566 | return( 1 ) if $myimap2->exists( $h2_fold ) ; |
| 7567 | # failure since create failed |
| 7568 | return( 0 ) ; |
| 7569 | }else{ |
| 7570 | #create succeeded |
| 7571 | myprint( "Created folder [$h2_fold] on host2\n" ) ; |
| 7572 | return( 1 ) ; |
| 7573 | } |
| 7574 | }else{ |
| 7575 | # dry mode, no folder so many imap will fail, assuming failure |
| 7576 | myprint( "Created folder [$h2_fold] on host2 $mysync->{dry_message}\n" ) ; |
| 7577 | if ( ! $mysync->{ justfolders } ) { |
| 7578 | myprint( "Since --dry mode is on and folder [$h2_fold] on host2 does not exist yet, syncing messages will not be simulated.\n" |
| 7579 | . "To simulate message syncing, use --justfolders without --dry to first create the missing folders then rerun the --dry sync.\n" ) ; |
| 7580 | } |
| 7581 | return( 0 ) ; |
| 7582 | } |
| 7583 | } |
| 7584 | |
| 7585 | |
| 7586 | |
| 7587 | sub tests_folder_routines |
| 7588 | { |
| 7589 | note( 'Entering tests_folder_routines()' ) ; |
| 7590 | |
| 7591 | ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 1' ); |
| 7592 | ok( add_to_requested_folders('folder_foo'), 'add_to_requested_folders folder_foo' ); |
| 7593 | ok( is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 2' ); |
| 7594 | ok( !is_requested_folder('folder_NO_EXIST'), 'is_requested_folder folder_NO_EXIST' ); |
| 7595 | |
| 7596 | is_deeply( [ 'folder_foo' ], [ remove_from_requested_folders( 'folder_foo' ) ], 'removed folder_foo => folder_foo' ) ; |
| 7597 | ok( !is_requested_folder('folder_foo'), 'is_requested_folder folder_foo 3' ); |
| 7598 | my @f ; |
| 7599 | ok( @f = add_to_requested_folders('folder_bar', 'folder_toto'), "add result: @f" ); |
| 7600 | ok( is_requested_folder('folder_bar'), 'is_requested_folder 4' ); |
| 7601 | ok( is_requested_folder('folder_toto'), 'is_requested_folder 5' ); |
| 7602 | ok( remove_from_requested_folders('folder_toto'), 'remove_from_requested_folders: ' ); |
| 7603 | ok( !is_requested_folder('folder_toto'), 'is_requested_folder 6' ); |
| 7604 | |
| 7605 | is_deeply( [ 'folder_bar' ], [ remove_from_requested_folders('folder_bar') ], 'remove_from_requested_folders: empty' ) ; |
| 7606 | |
| 7607 | ok( 0 == compare_lists( [ sort_requested_folders( ) ], [] ), 'sort_requested_folders: all empty' ) ; |
| 7608 | ok( add_to_requested_folders( 'A_99', 'M_55', 'Z_11' ), 'add_to_requested_folders M_55 Z_11' ); |
| 7609 | ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'A_99', 'M_55', 'Z_11' ] ), 'sort_requested_folders: middle' ) ; |
| 7610 | |
| 7611 | |
| 7612 | @folderfirst = ( 'Z_11' ) ; |
| 7613 | |
| 7614 | ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'A_99', 'M_55' ] ), 'sort_requested_folders: first+middle' ) ; |
| 7615 | |
| 7616 | is_deeply( [ 'Z_11', 'A_99', 'M_55' ], [ sort_requested_folders( ) ], 'sort_requested_folders: first+middle is_deeply' ) ; |
| 7617 | |
| 7618 | @folderlast = ( 'A_99' ) ; |
| 7619 | ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_55', 'A_99' ] ), 'sort_requested_folders: first+middle+last 1' ) ; |
| 7620 | |
| 7621 | ok( add_to_requested_folders('M_55', 'M_44',), 'add_to_requested_folders M_55 M_44' ) ; |
| 7622 | |
| 7623 | ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_11', 'M_44', 'M_55', 'A_99'] ), 'sort_requested_folders: first+middle+last 2' ) ; |
| 7624 | |
| 7625 | |
| 7626 | ok( add_to_requested_folders('A_88', 'Z_22',), 'add_to_requested_folders A_88 Z_22' ) ; |
| 7627 | @folderfirst = qw( Z_22 Z_11 ) ; |
| 7628 | @folderlast = qw( A_99 A_88 ) ; |
| 7629 | ok( 0 == compare_lists( [ sort_requested_folders( ) ], [ 'Z_22', 'Z_11', 'M_44', 'M_55', 'A_99', 'A_88' ] ), 'sort_requested_folders: first+middle+last 3' ) ; |
| 7630 | undef @folderfirst ; |
| 7631 | undef @folderlast ; |
| 7632 | |
| 7633 | note( 'Leaving tests_folder_routines()' ) ; |
| 7634 | return ; |
| 7635 | } |
| 7636 | |
| 7637 | |
| 7638 | sub sort_requested_folders |
| 7639 | { |
| 7640 | my @requested_folders_sorted = () ; |
| 7641 | |
| 7642 | #myprint "folderfirst: @folderfirst\n" ; |
| 7643 | my @folderfirst_requested = remove_from_requested_folders( @folderfirst ) ; |
| 7644 | #myprint "folderfirst_requested: @folderfirst_requested\n" ; |
| 7645 | |
| 7646 | my @folderlast_requested = remove_from_requested_folders( @folderlast ) ; |
| 7647 | |
| 7648 | my @middle = sort keys %requested_folder ; |
| 7649 | |
| 7650 | @requested_folders_sorted = ( @folderfirst_requested, @middle, @folderlast_requested ) ; |
| 7651 | #myprint "requested_folders_sorted: @requested_folders_sorted\n" ; |
| 7652 | add_to_requested_folders( @requested_folders_sorted ) ; |
| 7653 | |
| 7654 | return( @requested_folders_sorted ) ; |
| 7655 | } |
| 7656 | |
| 7657 | sub is_requested_folder |
| 7658 | { |
| 7659 | my ( $folder ) = @_; |
| 7660 | |
| 7661 | return( defined $requested_folder{ $folder } ) ; |
| 7662 | } |
| 7663 | |
| 7664 | |
| 7665 | sub add_to_requested_folders |
| 7666 | { |
| 7667 | my @wanted_folders = @_ ; |
| 7668 | |
| 7669 | foreach my $folder ( @wanted_folders ) { |
| 7670 | ++$requested_folder{ $folder } ; |
| 7671 | } |
| 7672 | return( keys %requested_folder ) ; |
| 7673 | } |
| 7674 | |
| 7675 | sub tests_remove_from_requested_folders |
| 7676 | { |
| 7677 | note( 'Entering tests_remove_from_requested_folders()' ) ; |
| 7678 | |
| 7679 | is( undef, undef, 'remove_from_requested_folders: undef is undef' ) ; |
| 7680 | is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: no args' ) ; |
| 7681 | %requested_folder = ( |
| 7682 | 'F1' => 1, |
| 7683 | ) ; |
| 7684 | is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 => nothing' ) ; |
| 7685 | is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 => nothing' ) ; |
| 7686 | is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 => F1' ) ; |
| 7687 | is_deeply( { }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 => %requested_folder emptied' ) ; |
| 7688 | |
| 7689 | %requested_folder = ( |
| 7690 | 'F1' => 1, |
| 7691 | 'F2' => 1, |
| 7692 | ) ; |
| 7693 | is_deeply( [], [ remove_from_requested_folders( ) ], 'remove_from_requested_folders: remove nothing among F1 F2 => nothing' ) ; |
| 7694 | is_deeply( [], [ remove_from_requested_folders( 'Fno' ) ], 'remove_from_requested_folders: remove Fno among F1 F2 => nothing' ) ; |
| 7695 | is_deeply( [ 'F1' ], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F1 F2 => F1' ) ; |
| 7696 | is_deeply( { 'F2' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ; |
| 7697 | |
| 7698 | is_deeply( [], [ remove_from_requested_folders( 'F1' ) ], 'remove_from_requested_folders: remove F1 among F2 => nothing' ) ; |
| 7699 | is_deeply( [ 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F2 => F2' ) ; |
| 7700 | is_deeply( {}, { %requested_folder }, 'remove_from_requested_folders: remove F1 among F1 F2 => %requested_folder F2' ) ; |
| 7701 | |
| 7702 | %requested_folder = ( |
| 7703 | 'F1' => 1, |
| 7704 | 'F2' => 1, |
| 7705 | 'F3' => 1, |
| 7706 | ) ; |
| 7707 | is_deeply( [ 'F1', 'F2' ], [ remove_from_requested_folders( 'F1', 'F2' ) ], 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => F1 F2' ) ; |
| 7708 | is_deeply( { 'F3' => 1 }, { %requested_folder }, 'remove_from_requested_folders: remove F1 F2 among F1 F2 F3 => %requested_folder F3' ) ; |
| 7709 | |
| 7710 | |
| 7711 | |
| 7712 | note( 'Leaving tests_remove_from_requested_folders()' ) ; |
| 7713 | return ; |
| 7714 | } |
| 7715 | |
| 7716 | |
| 7717 | sub remove_from_requested_folders |
| 7718 | { |
| 7719 | my @unwanted_folders = @_ ; |
| 7720 | |
| 7721 | my @removed_folders = () ; |
| 7722 | foreach my $folder ( @unwanted_folders ) { |
| 7723 | if ( exists $requested_folder{ $folder } ) |
| 7724 | { |
| 7725 | delete $requested_folder{ $folder } ; |
| 7726 | push @removed_folders, $folder ; |
| 7727 | } |
| 7728 | } |
| 7729 | return( @removed_folders ) ; |
| 7730 | } |
| 7731 | |
| 7732 | sub compare_lists |
| 7733 | { |
| 7734 | my ($list_1_ref, $list_2_ref) = @_; |
| 7735 | |
| 7736 | return($MINUS_ONE) if ((not defined $list_1_ref) and defined $list_2_ref); |
| 7737 | return(0) if ((not defined $list_1_ref) and not defined $list_2_ref); # end if no list |
| 7738 | return(1) if (not defined $list_2_ref); # end if only one list |
| 7739 | |
| 7740 | if (not ref $list_1_ref ) {$list_1_ref = [$list_1_ref]}; |
| 7741 | if (not ref $list_2_ref ) {$list_2_ref = [$list_2_ref]}; |
| 7742 | |
| 7743 | |
| 7744 | my $last_used_indice = $MINUS_ONE; |
| 7745 | |
| 7746 | |
| 7747 | ELEMENT: |
| 7748 | foreach my $indice ( 0 .. $#{ $list_1_ref } ) { |
| 7749 | $last_used_indice = $indice ; |
| 7750 | |
| 7751 | # End of list_2 |
| 7752 | return 1 if ($indice > $#{ $list_2_ref } ) ; |
| 7753 | |
| 7754 | my $element_list_1 = $list_1_ref->[$indice] ; |
| 7755 | my $element_list_2 = $list_2_ref->[$indice] ; |
| 7756 | my $balance = $element_list_1 cmp $element_list_2 ; |
| 7757 | next ELEMENT if ($balance == 0) ; |
| 7758 | return $balance ; |
| 7759 | } |
| 7760 | # each element equal until last indice of list_1 |
| 7761 | return $MINUS_ONE if ($last_used_indice < $#{ $list_2_ref } ) ; |
| 7762 | |
| 7763 | # same size, each element equal |
| 7764 | return 0 ; |
| 7765 | } |
| 7766 | |
| 7767 | sub tests_compare_lists |
| 7768 | { |
| 7769 | note( 'Entering tests_compare_lists()' ) ; |
| 7770 | |
| 7771 | my $empty_list_ref = []; |
| 7772 | |
| 7773 | ok( 0 == compare_lists() , 'compare_lists, no args'); |
| 7774 | ok( 0 == compare_lists(undef) , 'compare_lists, undef = nothing'); |
| 7775 | ok( 0 == compare_lists(undef, undef) , 'compare_lists, undef = undef'); |
| 7776 | ok($MINUS_ONE == compare_lists(undef , []) , 'compare_lists, undef < []'); |
| 7777 | ok($MINUS_ONE == compare_lists(undef , [1]) , 'compare_lists, undef < [1]'); |
| 7778 | ok($MINUS_ONE == compare_lists(undef , [0]) , 'compare_lists, undef < [0]'); |
| 7779 | ok(+1 == compare_lists([]) , 'compare_lists, [] > nothing'); |
| 7780 | ok(+1 == compare_lists([], undef) , 'compare_lists, [] > undef'); |
| 7781 | ok( 0 == compare_lists([] , []) , 'compare_lists, [] = []'); |
| 7782 | |
| 7783 | ok($MINUS_ONE == compare_lists([] , [1]) , 'compare_lists, [] < [1]'); |
| 7784 | ok(+1 == compare_lists([1] , []) , 'compare_lists, [1] > []'); |
| 7785 | |
| 7786 | |
| 7787 | ok( 0 == compare_lists([1], 1 ) , 'compare_lists, [1] = 1 ') ; |
| 7788 | ok( 0 == compare_lists( 1 , [1]) , 'compare_lists, 1 = [1]') ; |
| 7789 | ok( 0 == compare_lists( 1 , 1 ) , 'compare_lists, 1 = 1 ') ; |
| 7790 | ok($MINUS_ONE == compare_lists( 0 , 1 ) , 'compare_lists, 0 < 1 ') ; |
| 7791 | ok($MINUS_ONE == compare_lists($MINUS_ONE , 0 ) , 'compare_lists, -1 < 0 ') ; |
| 7792 | ok($MINUS_ONE == compare_lists( 1 , 2 ) , 'compare_lists, 1 < 2 ') ; |
| 7793 | ok(+1 == compare_lists( 2 , 1 ) , 'compare_lists, 2 > 1 ') ; |
| 7794 | |
| 7795 | |
| 7796 | ok( 0 == compare_lists([1,2], [1,2]) , 'compare_lists, [1,2] = [1,2]' ) ; |
| 7797 | ok($MINUS_ONE == compare_lists([1], [1,2]) , 'compare_lists, [1] < [1,2]' ) ; |
| 7798 | ok(+1 == compare_lists([2], [1,2]) , 'compare_lists, [2] > [1,2]' ) ; |
| 7799 | ok($MINUS_ONE == compare_lists([1], [1,1]) , 'compare_lists, [1] < [1,1]' ) ; |
| 7800 | ok(+1 == compare_lists([1, 1], [1]) , 'compare_lists, [1, 1] > [1]' ) ; |
| 7801 | ok( 0 == compare_lists([1 .. $NUMBER_20_000] , [1 .. $NUMBER_20_000]) |
| 7802 | , 'compare_lists, [1..20_000] = [1..20_000]' ) ; |
| 7803 | ok($MINUS_ONE == compare_lists([1], [2]) , 'compare_lists, [1] < [2]') ; |
| 7804 | ok( 0 == compare_lists([2], [2]) , 'compare_lists, [0] = [2]') ; |
| 7805 | ok(+1 == compare_lists([2], [1]) , 'compare_lists, [2] > [1]') ; |
| 7806 | |
| 7807 | ok($MINUS_ONE == compare_lists(['a'], ['b']) , 'compare_lists, ["a"] < ["b"]') ; |
| 7808 | ok( 0 == compare_lists(['a'], ['a']) , 'compare_lists, ["a"] = ["a"]') ; |
| 7809 | ok( 0 == compare_lists(['ab'], ['ab']) , 'compare_lists, ["ab"] = ["ab"]') ; |
| 7810 | ok(+1 == compare_lists(['b'], ['a']) , 'compare_lists, ["b"] > ["a"]') ; |
| 7811 | ok($MINUS_ONE == compare_lists(['a'], ['aa']) , 'compare_lists, ["a"] < ["aa"]') ; |
| 7812 | ok($MINUS_ONE == compare_lists(['a'], ['a', 'a']), 'compare_lists, ["a"] < ["a", "a"]') ; |
| 7813 | ok( 0 == compare_lists([split q{ }, 'a b' ], ['a', 'b']), 'compare_lists, split') ; |
| 7814 | ok( 0 == compare_lists([sort split q{ }, 'b a' ], ['a', 'b']), 'compare_lists, sort split') ; |
| 7815 | |
| 7816 | note( 'Leaving tests_compare_lists()' ) ; |
| 7817 | return ; |
| 7818 | } |
| 7819 | |
| 7820 | |
| 7821 | sub guess_prefix |
| 7822 | { |
| 7823 | my @foldernames = @_ ; |
| 7824 | |
| 7825 | my $prefix_guessed = q{} ; |
| 7826 | foreach my $folder ( @foldernames ) { |
| 7827 | next if ( $folder =~ m{^INBOX$}xi ) ; # no guessing from INBOX |
| 7828 | if ( $folder !~ m{^INBOX}xi ) { |
| 7829 | $prefix_guessed = q{} ; # prefix empty guessed |
| 7830 | last ; |
| 7831 | } |
| 7832 | if ( $folder =~ m{^(INBOX(?:\.|\/))}xi ) { |
| 7833 | $prefix_guessed = $1 ; # prefix Inbox/ or INBOX. guessed |
| 7834 | } |
| 7835 | } |
| 7836 | return( $prefix_guessed ) ; |
| 7837 | } |
| 7838 | |
| 7839 | sub tests_guess_prefix |
| 7840 | { |
| 7841 | note( 'Entering tests_guess_prefix()' ) ; |
| 7842 | |
| 7843 | is( guess_prefix( ), q{}, 'guess_prefix: no args => empty string' ) ; |
| 7844 | is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ; |
| 7845 | is( q{} , guess_prefix( 'Inbox' ), 'guess_prefix: Inbox alone' ) ; |
| 7846 | is( q{} , guess_prefix( 'INBOX' ), 'guess_prefix: INBOX alone' ) ; |
| 7847 | is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk' ), 'guess_prefix: INBOX INBOX/Junk' ) ; |
| 7848 | is( 'INBOX.' , guess_prefix( 'INBOX', 'INBOX.Junk' ), 'guess_prefix: INBOX INBOX.Junk' ) ; |
| 7849 | is( 'Inbox/' , guess_prefix( 'Inbox', 'Inbox/Junk' ), 'guess_prefix: Inbox Inbox/Junk' ) ; |
| 7850 | is( 'Inbox.' , guess_prefix( 'Inbox', 'Inbox.Junk' ), 'guess_prefix: Inbox Inbox.Junk' ) ; |
| 7851 | is( 'INBOX/' , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr' ) ; |
| 7852 | is( q{} , guess_prefix( 'INBOX', 'INBOX/Junk', 'INBOX/rrr', 'zzz' ), 'guess_prefix: INBOX INBOX/Junk INBOX/rrr zzz' ) ; |
| 7853 | is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ; |
| 7854 | is( q{} , guess_prefix( 'INBOX', 'Junk' ), 'guess_prefix: INBOX Junk' ) ; |
| 7855 | |
| 7856 | note( 'Leaving tests_guess_prefix()' ) ; |
| 7857 | return ; |
| 7858 | } |
| 7859 | |
| 7860 | sub get_prefix |
| 7861 | { |
| 7862 | my( $imap, $prefix_in, $prefix_opt, $Side, $folders_ref ) = @_ ; |
| 7863 | my( $prefix_out, $prefix_guessed ) ; |
| 7864 | |
| 7865 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting prefix\n" ) ; |
| 7866 | $prefix_guessed = guess_prefix( @{ $folders_ref } ) ; |
| 7867 | myprint( "$Side: guessing prefix from folder listing: [$prefix_guessed]\n" ) ; |
| 7868 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Calling namespace capability\n" ) ; |
| 7869 | if ( $imap->has_capability( 'namespace' ) ) { |
| 7870 | my $r_namespace = $imap->namespace( ) ; |
| 7871 | $prefix_out = $r_namespace->[0][0][0] ; |
| 7872 | myprint( "$Side: prefix given by NAMESPACE: [$prefix_out]\n" ) ; |
| 7873 | if ( defined $prefix_in ) { |
| 7874 | myprint( "$Side: but using [$prefix_in] given by $prefix_opt\n" ) ; |
| 7875 | $prefix_out = $prefix_in ; |
| 7876 | return( $prefix_out ) ; |
| 7877 | }else{ |
| 7878 | # all good |
| 7879 | return( $prefix_out ) ; |
| 7880 | } |
| 7881 | } |
| 7882 | else{ |
| 7883 | if ( defined $prefix_in ) { |
| 7884 | myprint( "$Side: using [$prefix_in] given by $prefix_opt\n" ) ; |
| 7885 | $prefix_out = $prefix_in ; |
| 7886 | return( $prefix_out ) ; |
| 7887 | }else{ |
| 7888 | myprint( |
| 7889 | "$Side: No NAMESPACE capability so using guessed prefix [$prefix_guessed]\n", |
| 7890 | help_to_guess_prefix( $imap, $prefix_opt ) ) ; |
| 7891 | return( $prefix_guessed ) ; |
| 7892 | } |
| 7893 | } |
| 7894 | return ; |
| 7895 | } |
| 7896 | |
| 7897 | |
| 7898 | sub guess_separator |
| 7899 | { |
| 7900 | my @foldernames = @_ ; |
| 7901 | |
| 7902 | #return( undef ) unless ( @foldernames ) ; |
| 7903 | |
| 7904 | my $sep_guessed ; |
| 7905 | my %counter ; |
| 7906 | foreach my $folder ( @foldernames ) { |
| 7907 | $counter{'/'}++ while ( $folder =~ m{/}xg ) ; # count / |
| 7908 | $counter{'.'}++ while ( $folder =~ m{\.}xg ) ; # count . |
| 7909 | $counter{'\\\\'}++ while ( $folder =~ m{(\\){2}}xg ) ; # count \\ |
| 7910 | $counter{'\\'}++ while ( $folder =~ m{[^\\](\\){1}(?=[^\\])}xg ) ; # count \ |
| 7911 | } |
| 7912 | my @race_sorted = sort { $counter{ $b } <=> $counter{ $a } } keys %counter ; |
| 7913 | $sync->{ debug } and myprint( "@foldernames\n@race_sorted\n", %counter, "\n" ) ; |
| 7914 | $sep_guessed = shift @race_sorted || $LAST_RESSORT_SEPARATOR ; # / when nothing found. |
| 7915 | return( $sep_guessed ) ; |
| 7916 | } |
| 7917 | |
| 7918 | sub tests_guess_separator |
| 7919 | { |
| 7920 | note( 'Entering tests_guess_separator()' ) ; |
| 7921 | |
| 7922 | ok( '/' eq guess_separator( ), 'guess_separator: no args' ) ; |
| 7923 | ok( '/' eq guess_separator( 'abcd' ), 'guess_separator: abcd' ) ; |
| 7924 | ok( '/' eq guess_separator( 'a/b/c.d' ), 'guess_separator: a/b/c.d' ) ; |
| 7925 | ok( '.' eq guess_separator( 'a.b/c.d' ), 'guess_separator: a.b/c.d' ) ; |
| 7926 | ok( '\\\\' eq guess_separator( 'a\\\\b\\\\c.c\\\\d/e/f' ), 'guess_separator: a\\\\b\\\\c.c\\\\d/e/f' ) ; |
| 7927 | ok( '\\' eq guess_separator( 'a\\b\\c.c\\d/e/f' ), 'guess_separator: a\\b\\c.c\\d/e/f' ) ; |
| 7928 | ok( '\\' eq guess_separator( 'a\\b' ), 'guess_separator: a\\b' ) ; |
| 7929 | ok( '\\' eq guess_separator( 'a\\b\\c' ), 'guess_separator: a\\b\\c' ) ; |
| 7930 | |
| 7931 | note( 'Leaving tests_guess_separator()' ) ; |
| 7932 | return ; |
| 7933 | } |
| 7934 | |
| 7935 | sub get_separator |
| 7936 | { |
| 7937 | my( $imap, $sep_in, $sep_opt, $Side, $folders_ref ) = @_ ; |
| 7938 | my( $sep_out, $sep_guessed ) ; |
| 7939 | |
| 7940 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: Getting separator\n" ) ; |
| 7941 | $sep_guessed = guess_separator( @{ $folders_ref } ) ; |
| 7942 | myprint( "$Side: guessing separator from folder listing: [$sep_guessed]\n" ) ; |
| 7943 | |
| 7944 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "$Side: calling namespace capability\n" ) ; |
| 7945 | if ( $imap->has_capability( 'namespace' ) ) |
| 7946 | { |
| 7947 | $sep_out = $imap->separator( ) ; |
| 7948 | if ( defined $sep_out ) { |
| 7949 | myprint( "$Side: separator given by NAMESPACE: [$sep_out]\n" ) ; |
| 7950 | if ( defined $sep_in ) { |
| 7951 | myprint( "$Side: but using [$sep_in] given by $sep_opt\n" ) ; |
| 7952 | $sep_out = $sep_in ; |
| 7953 | return( $sep_out ) ; |
| 7954 | }else{ |
| 7955 | return( $sep_out ) ; |
| 7956 | } |
| 7957 | }else{ |
| 7958 | if ( defined $sep_in ) { |
| 7959 | myprint( "$Side: NAMESPACE request failed but using [$sep_in] given by $sep_opt\n" ) ; |
| 7960 | $sep_out = $sep_in ; |
| 7961 | return( $sep_out ) ; |
| 7962 | }else{ |
| 7963 | myprint( |
| 7964 | "$Side: NAMESPACE request failed so using guessed separator [$sep_guessed]\n", |
| 7965 | help_to_guess_sep( $imap, $sep_opt ) ) ; |
| 7966 | return( $sep_guessed ) ; |
| 7967 | } |
| 7968 | } |
| 7969 | } |
| 7970 | else |
| 7971 | { |
| 7972 | if ( defined $sep_in ) { |
| 7973 | myprint( "$Side: No NAMESPACE capability but using [$sep_in] given by $sep_opt\n" ) ; |
| 7974 | $sep_out = $sep_in ; |
| 7975 | return( $sep_out ) ; |
| 7976 | }else{ |
| 7977 | myprint( |
| 7978 | "$Side: No NAMESPACE capability, so using guessed separator [$sep_guessed]\n", |
| 7979 | help_to_guess_sep( $imap, $sep_opt ) ) ; |
| 7980 | return( $sep_guessed ) ; |
| 7981 | } |
| 7982 | } |
| 7983 | return ; |
| 7984 | } |
| 7985 | |
| 7986 | sub help_to_guess_sep |
| 7987 | { |
| 7988 | my( $imap, $sep_opt ) = @_ ; |
| 7989 | |
| 7990 | my $help_to_guess_sep = "You can set the separator character with the $sep_opt option,\n" |
| 7991 | . "the complete listing of folders may help you to find it\n" |
| 7992 | . folders_list_to_help( $imap ) ; |
| 7993 | |
| 7994 | return( $help_to_guess_sep ) ; |
| 7995 | } |
| 7996 | |
| 7997 | sub help_to_guess_prefix |
| 7998 | { |
| 7999 | my( $imap, $prefix_opt ) = @_ ; |
| 8000 | |
| 8001 | my $help_to_guess_prefix = "You can set the prefix namespace with the $prefix_opt option,\n" |
| 8002 | . "the folowing listing of folders may help you to find it:\n" |
| 8003 | . folders_list_to_help( $imap ) ; |
| 8004 | |
| 8005 | return( $help_to_guess_prefix ) ; |
| 8006 | } |
| 8007 | |
| 8008 | |
| 8009 | sub folders_list_to_help |
| 8010 | { |
| 8011 | my( $imap ) = shift ; |
| 8012 | |
| 8013 | my @folders = $imap->folders ; |
| 8014 | my $listing = join q{}, map { "[$_]\n" } @folders ; |
| 8015 | return( $listing ) ; |
| 8016 | } |
| 8017 | |
| 8018 | sub private_folders_separators_and_prefixes |
| 8019 | { |
| 8020 | # what are the private folders separators and prefixes for each server ? |
| 8021 | |
| 8022 | ( $sync->{ debug } or $sync->{debugfolders} ) and myprint( "Getting separators\n" ) ; |
| 8023 | $sync->{ h1_sep } = get_separator( $sync->{imap1}, $sync->{ sep1 }, '--sep1', 'Host1', \@h1_folders_all ) ; |
| 8024 | $sync->{ h2_sep } = get_separator( $sync->{imap2}, $sync->{ sep2 }, '--sep2', 'Host2', \@h2_folders_all ) ; |
| 8025 | |
| 8026 | |
| 8027 | $sync->{ h1_prefix } = get_prefix( $sync->{imap1}, $prefix1, '--prefix1', 'Host1', \@h1_folders_all ) ; |
| 8028 | $sync->{ h2_prefix } = get_prefix( $sync->{imap2}, $prefix2, '--prefix2', 'Host2', \@h2_folders_all ) ; |
| 8029 | |
| 8030 | myprint( "Host1: separator and prefix: [$sync->{ h1_sep }][$sync->{ h1_prefix }]\n" ) ; |
| 8031 | myprint( "Host2: separator and prefix: [$sync->{ h2_sep }][$sync->{ h2_prefix }]\n" ) ; |
| 8032 | return ; |
| 8033 | } |
| 8034 | |
| 8035 | |
| 8036 | sub subfolder1 |
| 8037 | { |
| 8038 | my $mysync = shift ; |
| 8039 | my $subfolder1 = sanitize_subfolder( $mysync->{ subfolder1 } ) ; |
| 8040 | |
| 8041 | if ( $subfolder1 ) |
| 8042 | { |
| 8043 | # turns off automap |
| 8044 | myprint( "Turning off automapping folders because of --subfolder1\n" ) ; |
| 8045 | $mysync->{ automap } = undef ; |
| 8046 | myprint( "Sanitizing subfolder1: [$mysync->{ subfolder1 }] => [$subfolder1]\n" ) ; |
| 8047 | $mysync->{ subfolder1 } = $subfolder1 ; |
| 8048 | if ( ! add_subfolder1_to_folderrec( $mysync ) ) |
| 8049 | { |
| 8050 | $mysync->{nb_errors}++ ; |
| 8051 | exit_clean( $mysync, $EXIT_SUBFOLDER1_NO_EXISTS, "subfolder1 $subfolder1 does not exist\n" ) ; |
| 8052 | } |
| 8053 | } |
| 8054 | else |
| 8055 | { |
| 8056 | $mysync->{ subfolder1 } = undef ; |
| 8057 | } |
| 8058 | |
| 8059 | return ; |
| 8060 | } |
| 8061 | |
| 8062 | sub subfolder2 |
| 8063 | { |
| 8064 | my $mysync = shift ; |
| 8065 | my $subfolder2 = sanitize_subfolder( $mysync->{ subfolder2 } ) ; |
| 8066 | if ( $subfolder2 ) |
| 8067 | { |
| 8068 | # turns off automap |
| 8069 | myprint( "Turning off automapping folders because of --subfolder2\n" ) ; |
| 8070 | $mysync->{ automap } = undef ; |
| 8071 | myprint( "Sanitizing subfolder2: [$mysync->{ subfolder2 }] => [$subfolder2]\n" ) ; |
| 8072 | $mysync->{ subfolder2 } = $subfolder2 ; |
| 8073 | set_regextrans2_for_subfolder2( $mysync ) ; |
| 8074 | } |
| 8075 | else |
| 8076 | { |
| 8077 | $mysync->{ subfolder2 } = undef ; |
| 8078 | } |
| 8079 | |
| 8080 | return ; |
| 8081 | } |
| 8082 | |
| 8083 | sub tests_sanitize_subfolder |
| 8084 | { |
| 8085 | note( 'Entering tests_sanitize_subfolder()' ) ; |
| 8086 | |
| 8087 | is( undef, sanitize_subfolder( ), 'sanitize_subfolder: no args => undef' ) ; |
| 8088 | is( undef, sanitize_subfolder( q{} ), 'sanitize_subfolder: empty => undef' ) ; |
| 8089 | is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blank => undef' ) ; |
| 8090 | is( undef, sanitize_subfolder( ' ' ), 'sanitize_subfolder: blanks => undef' ) ; |
| 8091 | is( 'abcd', sanitize_subfolder( 'abcd' ), 'sanitize_subfolder: abcd => abcd' ) ; |
| 8092 | is( 'ab cd', sanitize_subfolder( ' ab cd ' ), 'sanitize_subfolder: " ab cd " => "ab cd"' ) ; |
| 8093 | is( 'abcd', sanitize_subfolder( q{a&~b#\\c[]=d;} ), 'sanitize_subfolder: "a&~b#\\c[]=d;" => "abcd"' ) ; |
| 8094 | is( 'aA.b-_ 8c/dD', sanitize_subfolder( 'aA.b-_ 8c/dD' ), 'sanitize_subfolder: aA.b-_ 8c/dD => aA.b-_ 8c/dD' ) ; |
| 8095 | note( 'Leaving tests_sanitize_subfolder()' ) ; |
| 8096 | return ; |
| 8097 | } |
| 8098 | |
| 8099 | |
| 8100 | sub sanitize_subfolder |
| 8101 | { |
| 8102 | my $subfolder = shift ; |
| 8103 | |
| 8104 | if ( ! $subfolder ) |
| 8105 | { |
| 8106 | return ; |
| 8107 | } |
| 8108 | # Remove edging blanks |
| 8109 | $subfolder =~ s,^ +| +$,,g ; |
| 8110 | # Keep only abcd...ABCD...0123... and -_./ |
| 8111 | $subfolder =~ tr,-_a-zA-Z0-9./ ,,cd ; |
| 8112 | |
| 8113 | # A blank subfolder is not a subfolder |
| 8114 | if ( ! $subfolder ) |
| 8115 | { |
| 8116 | return ; |
| 8117 | } |
| 8118 | else |
| 8119 | { |
| 8120 | return $subfolder ; |
| 8121 | } |
| 8122 | } |
| 8123 | |
| 8124 | |
| 8125 | |
| 8126 | |
| 8127 | |
| 8128 | sub tests_add_subfolder1_to_folderrec |
| 8129 | { |
| 8130 | note( 'Entering tests_add_subfolder1_to_folderrec()' ) ; |
| 8131 | |
| 8132 | is( undef, add_subfolder1_to_folderrec( ), 'add_subfolder1_to_folderrec: undef => undef' ) ; |
| 8133 | is_deeply( [], [ add_subfolder1_to_folderrec( ) ], 'add_subfolder1_to_folderrec: no args => empty array' ) ; |
| 8134 | @folderrec = () ; |
| 8135 | my $mysync = {} ; |
| 8136 | is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: empty => empty array' ) ; |
| 8137 | is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: empty => empty folderrec' ) ; |
| 8138 | $mysync->{ subfolder1 } = 'SUBI' ; |
| 8139 | $h1_folders_all{ 'SUBI' } = 1 ; |
| 8140 | $mysync->{ h1_prefix } = 'INBOX/' ; |
| 8141 | is_deeply( [ 'SUBI' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBI => SUBI' ) ; |
| 8142 | is_deeply( [ 'SUBI' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBI => folderrec SUBI ' ) ; |
| 8143 | |
| 8144 | @folderrec = () ; |
| 8145 | $mysync->{ subfolder1 } = 'SUBO' ; |
| 8146 | is_deeply( [ ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO no exists => empty array' ) ; |
| 8147 | is_deeply( [ ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO no exists => empty folderrec' ) ; |
| 8148 | $h1_folders_all{ 'INBOX/SUBO' } = 1 ; |
| 8149 | is_deeply( [ 'INBOX/SUBO' ], [ add_subfolder1_to_folderrec( $mysync ) ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO' ) ; |
| 8150 | is_deeply( [ 'INBOX/SUBO' ], [ @folderrec ], 'add_subfolder1_to_folderrec: SUBO + INBOX/SUBO exists => INBOX/SUBO folderrec' ) ; |
| 8151 | |
| 8152 | note( 'Leaving tests_add_subfolder1_to_folderrec()' ) ; |
| 8153 | return ; |
| 8154 | } |
| 8155 | |
| 8156 | |
| 8157 | sub add_subfolder1_to_folderrec |
| 8158 | { |
| 8159 | my $mysync = shift ; |
| 8160 | if ( ! $mysync || ! $mysync->{ subfolder1 } ) |
| 8161 | { |
| 8162 | return ; |
| 8163 | } |
| 8164 | |
| 8165 | my $subfolder1 = $mysync->{ subfolder1 } ; |
| 8166 | my $subfolder1_extended = $mysync->{ h1_prefix } . $subfolder1 ; |
| 8167 | |
| 8168 | if ( exists $h1_folders_all{ $subfolder1 } ) |
| 8169 | { |
| 8170 | myprint( qq{Acting like --folderrec "$subfolder1"\n} ) ; |
| 8171 | push @folderrec, $subfolder1 ; |
| 8172 | } |
| 8173 | elsif ( exists $h1_folders_all{ $subfolder1_extended } ) |
| 8174 | { |
| 8175 | myprint( qq{Acting like --folderrec "$subfolder1_extended"\n} ) ; |
| 8176 | push @folderrec, $subfolder1_extended ; |
| 8177 | } |
| 8178 | else |
| 8179 | { |
| 8180 | myprint( qq{Nor folder "$subfolder1" nor "$subfolder1_extended" exists on host1\n} ) ; |
| 8181 | } |
| 8182 | return @folderrec ; |
| 8183 | } |
| 8184 | |
| 8185 | sub set_regextrans2_for_subfolder2 |
| 8186 | { |
| 8187 | my $mysync = shift ; |
| 8188 | |
| 8189 | |
| 8190 | unshift @{ $mysync->{ regextrans2 } }, |
| 8191 | q(s,^$mysync->{ h2_prefix }(.*),$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }$1,), |
| 8192 | q(s,^INBOX$,$mysync->{ h2_prefix }$mysync->{ subfolder2 }$mysync->{ h2_sep }INBOX,), |
| 8193 | q(s,^($mysync->{ h2_prefix }){2},$mysync->{ h2_prefix },); |
| 8194 | |
| 8195 | #myprint( "@{ $mysync->{ regextrans2 } }\n" ) ; |
| 8196 | return ; |
| 8197 | } |
| 8198 | |
| 8199 | |
| 8200 | |
| 8201 | # Looks like no globals here |
| 8202 | |
| 8203 | sub tests_imap2_folder_name |
| 8204 | { |
| 8205 | note( 'Entering tests_imap2_folder_name()' ) ; |
| 8206 | |
| 8207 | my $mysync = {} ; |
| 8208 | $mysync->{ h1_prefix } = q{} ; |
| 8209 | $mysync->{ h2_prefix } = q{} ; |
| 8210 | $mysync->{ h1_sep } = '/'; |
| 8211 | $mysync->{ h2_sep } = '.'; |
| 8212 | |
| 8213 | $mysync->{ debug } and myprint( <<"EOS" |
| 8214 | prefix1: [$mysync->{ h1_prefix }] |
| 8215 | prefix2: [$mysync->{ h2_prefix }] |
| 8216 | sep1: [$sync->{ h1_sep }] |
| 8217 | sep2: [$sync->{ h2_sep }] |
| 8218 | EOS |
| 8219 | ) ; |
| 8220 | |
| 8221 | $mysync->{ fixslash2 } = 0 ; |
| 8222 | is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string' ) ; |
| 8223 | is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ; |
| 8224 | is('spam.spam', imap2_folder_name( $mysync, 'spam/spam' ), 'imap2_folder_name: spam/spam' ) ; |
| 8225 | |
| 8226 | is( 'spam/spam', imap2_folder_name( $mysync, 'spam.spam' ), 'imap2_folder_name: spam.spam') ; |
| 8227 | is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam' ) ; |
| 8228 | is( 's pam.spam/sp am', imap2_folder_name( $mysync, 's pam/spam.sp am' ), 'imap2_folder_name: s pam/spam.sp am' ) ; |
| 8229 | |
| 8230 | $mysync->{f1f2h}{ 'auto' } = 'moto' ; |
| 8231 | is( 'moto', imap2_folder_name( $mysync, 'auto' ), 'imap2_folder_name: auto' ) ; |
| 8232 | $mysync->{f1f2h}{ 'auto/auto' } = 'moto x 2' ; |
| 8233 | is( 'moto x 2', imap2_folder_name( $mysync, 'auto/auto' ), 'imap2_folder_name: auto/auto' ) ; |
| 8234 | |
| 8235 | @{ $mysync->{ regextrans2 } } = ( 's,/,X,g' ) ; |
| 8236 | is( q{INBOX}, imap2_folder_name( $mysync, q{} ), 'imap2_folder_name: empty string [s,/,X,g]' ) ; |
| 8237 | is( 'blabla', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla [s,/,X,g]' ) ; |
| 8238 | is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam [s,/,X,g]'); |
| 8239 | is('spamXspam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam [s,/,X,g]'); |
| 8240 | is('spam.spamXspam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam [s,/,X,g]'); |
| 8241 | |
| 8242 | @{ $mysync->{ regextrans2 } } = ( 's, ,_,g' ) ; |
| 8243 | is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla [s, ,_,g]'); |
| 8244 | is('bla_bla', imap2_folder_name( $mysync, 'bla bla'), 'imap2_folder_name: blabla [s, ,_,g]'); |
| 8245 | |
| 8246 | @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ; |
| 8247 | is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), q{imap2_folder_name: blabla [s,\U(.*)\E,$1,]} ) ; |
| 8248 | |
| 8249 | $mysync->{ fixslash2 } = 1 ; |
| 8250 | @{ $mysync->{ regextrans2 } } = ( ) ; |
| 8251 | is(q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string'); |
| 8252 | is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla'); |
| 8253 | is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam'); |
| 8254 | is('spam_spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam_spam'); |
| 8255 | is('spam.spam_spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam_spam'); |
| 8256 | is('s pam.spam_spa m', imap2_folder_name( $mysync, 's pam/spam.spa m'), 'imap2_folder_name: s pam/spam.spa m -> s pam.spam_spa m'); |
| 8257 | |
| 8258 | $mysync->{ h1_sep } = '.'; |
| 8259 | $mysync->{ h2_sep } = '/'; |
| 8260 | is( q{INBOX}, imap2_folder_name( $mysync, q{}), 'imap2_folder_name: empty string'); |
| 8261 | is('blabla', imap2_folder_name( $mysync, 'blabla'), 'imap2_folder_name: blabla'); |
| 8262 | is('spam.spam', imap2_folder_name( $mysync, 'spam/spam'), 'imap2_folder_name: spam/spam -> spam.spam'); |
| 8263 | is('spam/spam', imap2_folder_name( $mysync, 'spam.spam'), 'imap2_folder_name: spam.spam -> spam/spam'); |
| 8264 | is('spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam'), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam'); |
| 8265 | |
| 8266 | |
| 8267 | |
| 8268 | $mysync->{ fixslash2 } = 0 ; |
| 8269 | $mysync->{ h1_prefix } = q{ }; |
| 8270 | |
| 8271 | is( 'spam.spam/spam', imap2_folder_name( $mysync, 'spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ; |
| 8272 | is( 'spam.spam/spam', imap2_folder_name( $mysync, ' spam/spam.spam' ), 'imap2_folder_name: spam/spam.spam -> spam.spam/spam' ) ; |
| 8273 | |
| 8274 | $mysync->{ h1_sep } = '.' ; |
| 8275 | $mysync->{ h2_sep } = '/' ; |
| 8276 | $mysync->{ h1_prefix } = 'INBOX.' ; |
| 8277 | $mysync->{ h2_prefix } = q{} ; |
| 8278 | @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\U$1,} ) ; |
| 8279 | is( 'BLABLA', imap2_folder_name( $mysync, 'blabla' ), 'imap2_folder_name: blabla' ) ; |
| 8280 | is( 'TEST/TEST/TEST/TEST', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ; |
| 8281 | @{ $mysync->{ regextrans2 } } = ( q{s,(.*),\L$1,} ) ; |
| 8282 | is( 'test/test/test/test', imap2_folder_name( $mysync, 'INBOX.TEST.test.Test.tesT' ), 'imap2_folder_name: INBOX.TEST.test.Test.tesT' ) ; |
| 8283 | |
| 8284 | # INBOX |
| 8285 | $mysync = {} ; |
| 8286 | $mysync->{ h1_prefix } = q{Pf1.} ; |
| 8287 | $mysync->{ h2_prefix } = q{Pf2/} ; |
| 8288 | $mysync->{ h1_sep } = '.'; |
| 8289 | $mysync->{ h2_sep } = '/'; |
| 8290 | |
| 8291 | # |
| 8292 | #$mysync->{ debug } = 1 ; |
| 8293 | is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'F1.F2.F3' ), 'imap2_folder_name: F1.F2.F3 -> Pf2/F1/F2/F3' ) ; |
| 8294 | is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'F1.INBOX' ), 'imap2_folder_name: F1.INBOX -> Pf2/F1/INBOX' ) ; |
| 8295 | is( 'INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> INBOX' ) ; |
| 8296 | |
| 8297 | is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.F1.F2.F3' ), 'imap2_folder_name: Pf1.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; |
| 8298 | is( 'Pf2/F1/INBOX', imap2_folder_name( $mysync, 'Pf1.F1.INBOX' ), 'imap2_folder_name: Pf1.F1.INBOX -> Pf2/F1/INBOX' ) ; |
| 8299 | is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.INBOX' ), 'imap2_folder_name: Pf1.INBOX -> INBOX' ) ; # not Pf2/INBOX: Yes I can! |
| 8300 | |
| 8301 | |
| 8302 | |
| 8303 | # subfolder2 |
| 8304 | $mysync = {} ; |
| 8305 | $mysync->{ h1_prefix } = q{} ; |
| 8306 | $mysync->{ h2_prefix } = q{} ; |
| 8307 | $mysync->{ h1_sep } = '/'; |
| 8308 | $mysync->{ h2_sep } = '.'; |
| 8309 | |
| 8310 | |
| 8311 | set_regextrans2_for_subfolder2( $mysync ) ; |
| 8312 | $mysync->{ subfolder2 } = 'S1.S2' ; |
| 8313 | is( 'S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.F1.F2.F3' ) ; |
| 8314 | is( 'S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: F1/F2/F3 -> S1.S2.INBOX' ) ; |
| 8315 | |
| 8316 | $mysync = {} ; |
| 8317 | $mysync->{ h1_prefix } = q{Pf1/} ; |
| 8318 | $mysync->{ h2_prefix } = q{Pf2.} ; |
| 8319 | $mysync->{ h1_sep } = '/'; |
| 8320 | $mysync->{ h2_sep } = '.'; |
| 8321 | #$mysync->{ debug } = 1 ; |
| 8322 | |
| 8323 | set_regextrans2_for_subfolder2( $mysync ) ; |
| 8324 | $mysync->{ subfolder2 } = 'Pf2.S1.S2' ; |
| 8325 | is( 'Pf2.S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> Pf2.S1.S2.F1.F2.F3' ) ; |
| 8326 | is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ; |
| 8327 | is( 'Pf2.S1.S2.F1.F2.F3', imap2_folder_name( $mysync, 'Pf1/F1/F2/F3' ), 'imap2_folder_name: F1/F2/F3 -> Pf2.S1.S2.F1.F2.F3' ) ; |
| 8328 | is( 'Pf2.S1.S2.INBOX', imap2_folder_name( $mysync, 'Pf1/INBOX' ), 'imap2_folder_name: INBOX -> Pf2.S1.S2.INBOX' ) ; |
| 8329 | |
| 8330 | # subfolder1 |
| 8331 | # scenario as the reverse of the previous tests, separators point of vue |
| 8332 | $mysync = {} ; |
| 8333 | $mysync->{ h1_prefix } = q{Pf1.} ; |
| 8334 | $mysync->{ h2_prefix } = q{Pf2/} ; |
| 8335 | $mysync->{ h1_sep } = '.'; |
| 8336 | $mysync->{ h2_sep } = '/'; |
| 8337 | #$mysync->{ debug } = 1 ; |
| 8338 | |
| 8339 | $mysync->{ subfolder1 } = 'S1.S2' ; |
| 8340 | is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'S1.S2.F1.F2.F3' ), 'imap2_folder_name: S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; |
| 8341 | is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.S1.S2.F1.F2.F3' ), 'imap2_folder_name: Pf1.S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; |
| 8342 | |
| 8343 | is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ; |
| 8344 | is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ; |
| 8345 | is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ; |
| 8346 | |
| 8347 | is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ; |
| 8348 | is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ; |
| 8349 | is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ; |
| 8350 | |
| 8351 | |
| 8352 | $mysync->{ subfolder1 } = 'S1.S2.' ; |
| 8353 | is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'S1.S2.F1.F2.F3' ), 'imap2_folder_name: S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; |
| 8354 | is( 'Pf2/F1/F2/F3', imap2_folder_name( $mysync, 'Pf1.S1.S2.F1.F2.F3' ), 'imap2_folder_name: Pf1.S1.S2.F1.F2.F3 -> Pf2/F1/F2/F3' ) ; |
| 8355 | |
| 8356 | is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.INBOX' ), 'imap2_folder_name: S1.S2.INBOX -> INBOX' ) ; |
| 8357 | is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2' ), 'imap2_folder_name: S1.S2 -> INBOX' ) ; |
| 8358 | is( 'INBOX', imap2_folder_name( $mysync, 'S1.S2.' ), 'imap2_folder_name: S1.S2. -> INBOX' ) ; |
| 8359 | |
| 8360 | is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.INBOX' ), 'imap2_folder_name: Pf1.S1.S2.INBOX -> INBOX' ) ; |
| 8361 | is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2' ), 'imap2_folder_name: Pf1.S1.S2 -> INBOX' ) ; |
| 8362 | is( 'INBOX', imap2_folder_name( $mysync, 'Pf1.S1.S2.' ), 'imap2_folder_name: Pf1.S1.S2. -> INBOX' ) ; |
| 8363 | |
| 8364 | |
| 8365 | # subfolder1 |
| 8366 | # scenario as Gmail |
| 8367 | $mysync = {} ; |
| 8368 | $mysync->{ h1_prefix } = q{} ; |
| 8369 | $mysync->{ h2_prefix } = q{} ; |
| 8370 | $mysync->{ h1_sep } = '/'; |
| 8371 | $mysync->{ h2_sep } = '/'; |
| 8372 | #$mysync->{ debug } = 1 ; |
| 8373 | |
| 8374 | $mysync->{ subfolder1 } = 'S1/S2' ; |
| 8375 | is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ; |
| 8376 | is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ; |
| 8377 | is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ; |
| 8378 | is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ; |
| 8379 | |
| 8380 | $mysync->{ subfolder1 } = 'S1/S2/' ; |
| 8381 | is( 'F1/F2/F3', imap2_folder_name( $mysync, 'S1/S2/F1/F2/F3' ), 'imap2_folder_name: S1/S2/F1/F2/F3 -> F1/F2/F3' ) ; |
| 8382 | is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/INBOX' ), 'imap2_folder_name: S1/S2/INBOX -> INBOX' ) ; |
| 8383 | is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2' ), 'imap2_folder_name: S1/S2 -> INBOX' ) ; |
| 8384 | is( 'INBOX', imap2_folder_name( $mysync, 'S1/S2/' ), 'imap2_folder_name: S1/S2/ -> INBOX' ) ; |
| 8385 | |
| 8386 | |
| 8387 | note( 'Leaving tests_imap2_folder_name()' ) ; |
| 8388 | return ; |
| 8389 | } |
| 8390 | |
| 8391 | |
| 8392 | # Global variables to remove: |
| 8393 | # None? |
| 8394 | |
| 8395 | |
| 8396 | sub imap2_folder_name |
| 8397 | { |
| 8398 | my $mysync = shift ; |
| 8399 | my ( $h1_fold ) = shift ; |
| 8400 | my ( $h2_fold ) ; |
| 8401 | if ( $mysync->{f1f2h}{ $h1_fold } ) { |
| 8402 | $h2_fold = $mysync->{f1f2h}{ $h1_fold } ; |
| 8403 | ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "f1f2 [$h1_fold] -> [$h2_fold]\n" ) ; |
| 8404 | return( $h2_fold ) ; |
| 8405 | } |
| 8406 | if ( $mysync->{f1f2auto}{ $h1_fold } ) { |
| 8407 | $h2_fold = $mysync->{f1f2auto}{ $h1_fold } ; |
| 8408 | ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "automap [$h1_fold] -> [$h2_fold]\n" ) ; |
| 8409 | return( $h2_fold ) ; |
| 8410 | } |
| 8411 | |
| 8412 | if ( $mysync->{ subfolder1 } ) |
| 8413 | { |
| 8414 | my $esc_h1_sep = "\\" . $mysync->{ h1_sep } ; |
| 8415 | # case where subfolder1 has the sep1 at the end, then remove it |
| 8416 | my $part_to_removed = remove_last_char_if_is( $mysync->{ subfolder1 }, $mysync->{ h1_sep } ) ; |
| 8417 | # remove the subfolder1 part and the sep1 if present after |
| 8418 | $h1_fold =~ s{$part_to_removed($esc_h1_sep)?}{} ; |
| 8419 | #myprint( "h1_fold=$h1_fold\n" ) ; |
| 8420 | } |
| 8421 | |
| 8422 | if ( ( q{} eq $h1_fold ) or ( $mysync->{ h1_prefix } eq $h1_fold ) ) |
| 8423 | { |
| 8424 | $h1_fold = 'INBOX' ; |
| 8425 | } |
| 8426 | |
| 8427 | $h2_fold = prefix_seperator_invertion( $mysync, $h1_fold ) ; |
| 8428 | $h2_fold = regextrans2( $mysync, $h2_fold ) ; |
| 8429 | return( $h2_fold ) ; |
| 8430 | } |
| 8431 | |
| 8432 | |
| 8433 | sub tests_remove_last_char_if_is |
| 8434 | { |
| 8435 | note( 'Entering tests_remove_last_char_if_is()' ) ; |
| 8436 | |
| 8437 | is( undef, remove_last_char_if_is( ), 'remove_last_char_if_is: no args => undef' ) ; |
| 8438 | is( q{}, remove_last_char_if_is( q{} ), 'remove_last_char_if_is: empty => empty' ) ; |
| 8439 | is( q{}, remove_last_char_if_is( q{}, 'Z' ), 'remove_last_char_if_is: empty Z => empty' ) ; |
| 8440 | is( q{}, remove_last_char_if_is( 'Z', 'Z' ), 'remove_last_char_if_is: Z Z => empty' ) ; |
| 8441 | is( 'abc', remove_last_char_if_is( 'abcZ', 'Z' ), 'remove_last_char_if_is: abcZ Z => abc' ) ; |
| 8442 | is( 'abcY', remove_last_char_if_is( 'abcY', 'Z' ), 'remove_last_char_if_is: abcY Z => abcY' ) ; |
| 8443 | note( 'Leaving tests_remove_last_char_if_is()' ) ; |
| 8444 | return ; |
| 8445 | } |
| 8446 | |
| 8447 | |
| 8448 | |
| 8449 | |
| 8450 | sub remove_last_char_if_is |
| 8451 | { |
| 8452 | my $string = shift ; |
| 8453 | my $char = shift ; |
| 8454 | |
| 8455 | if ( ! defined $string ) |
| 8456 | { |
| 8457 | return ; |
| 8458 | } |
| 8459 | |
| 8460 | if ( ! defined $char ) |
| 8461 | { |
| 8462 | return $string ; |
| 8463 | } |
| 8464 | |
| 8465 | my $last_char = substr $string, -1 ; |
| 8466 | if ( $char eq $last_char ) |
| 8467 | { |
| 8468 | chop $string ; |
| 8469 | return $string ; |
| 8470 | } |
| 8471 | else |
| 8472 | { |
| 8473 | return $string ; |
| 8474 | } |
| 8475 | } |
| 8476 | |
| 8477 | sub tests_prefix_seperator_invertion |
| 8478 | { |
| 8479 | note( 'Entering tests_prefix_seperator_invertion()' ) ; |
| 8480 | |
| 8481 | is( undef, prefix_seperator_invertion( ), 'prefix_seperator_invertion: no args => undef' ) ; |
| 8482 | is( q{}, prefix_seperator_invertion( undef, q{} ), 'prefix_seperator_invertion: empty string => empty string' ) ; |
| 8483 | is( 'lalala', prefix_seperator_invertion( undef, 'lalala' ), 'prefix_seperator_invertion: lalala => lalala' ) ; |
| 8484 | is( 'lal/ala', prefix_seperator_invertion( undef, 'lal/ala' ), 'prefix_seperator_invertion: lal/ala => lal/ala' ) ; |
| 8485 | is( 'lal.ala', prefix_seperator_invertion( undef, 'lal.ala' ), 'prefix_seperator_invertion: lal.ala => lal.ala' ) ; |
| 8486 | is( '////', prefix_seperator_invertion( undef, '////' ), 'prefix_seperator_invertion: //// => ////' ) ; |
| 8487 | is( '.....', prefix_seperator_invertion( undef, '.....' ), 'prefix_seperator_invertion: ..... => .....' ) ; |
| 8488 | |
| 8489 | my $mysync = { |
| 8490 | h1_prefix => q{}, |
| 8491 | h2_prefix => q{}, |
| 8492 | h1_sep => '/', |
| 8493 | h2_sep => '/', |
| 8494 | } ; |
| 8495 | |
| 8496 | is( q{}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: $mysync empty string => empty string' ) ; |
| 8497 | is( 'lalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: $mysync lalala => lalala' ) ; |
| 8498 | is( 'lal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: $mysync lal/ala => lal/ala' ) ; |
| 8499 | is( 'lal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: $mysync lal.ala => lal.ala' ) ; |
| 8500 | is( '////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: $mysync //// => ////' ) ; |
| 8501 | is( '.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: $mysync ..... => .....' ) ; |
| 8502 | |
| 8503 | $mysync = { |
| 8504 | h1_prefix => 'PPP', |
| 8505 | h2_prefix => 'QQQ', |
| 8506 | h1_sep => 's', |
| 8507 | h2_sep => 't', |
| 8508 | } ; |
| 8509 | |
| 8510 | is( q{QQQ}, prefix_seperator_invertion( $mysync, q{} ), 'prefix_seperator_invertion: PPPQQQst empty string => QQQ' ) ; |
| 8511 | is( 'QQQlalala', prefix_seperator_invertion( $mysync, 'lalala' ), 'prefix_seperator_invertion: PPPQQQst lalala => QQQlalala' ) ; |
| 8512 | is( 'QQQlal/ala', prefix_seperator_invertion( $mysync, 'lal/ala' ), 'prefix_seperator_invertion: PPPQQQst lal/ala => QQQlal/ala' ) ; |
| 8513 | is( 'QQQlal.ala', prefix_seperator_invertion( $mysync, 'lal.ala' ), 'prefix_seperator_invertion: PPPQQQst lal.ala => QQQlal.ala' ) ; |
| 8514 | is( 'QQQ////', prefix_seperator_invertion( $mysync, '////' ), 'prefix_seperator_invertion: PPPQQQst //// => QQQ////' ) ; |
| 8515 | is( 'QQQ.....', prefix_seperator_invertion( $mysync, '.....' ), 'prefix_seperator_invertion: PPPQQQst ..... => QQQ.....' ) ; |
| 8516 | |
| 8517 | is( 'QQQPlalala', prefix_seperator_invertion( $mysync, 'PPPPlalala' ), 'prefix_seperator_invertion: PPPQQQst PPPPlalala => QQQPlalala' ) ; |
| 8518 | is( 'QQQ', prefix_seperator_invertion( $mysync, 'PPP' ), 'prefix_seperator_invertion: PPPQQQst PPP => QQQ' ) ; |
| 8519 | is( 'QQQttt', prefix_seperator_invertion( $mysync, 'sss' ), 'prefix_seperator_invertion: PPPQQQst sss => QQQttt' ) ; |
| 8520 | is( 'QQQt', prefix_seperator_invertion( $mysync, 's' ), 'prefix_seperator_invertion: PPPQQQst s => QQQt' ) ; |
| 8521 | is( 'QQQtAAAtBBB', prefix_seperator_invertion( $mysync, 'PPPsAAAsBBB' ), 'prefix_seperator_invertion: PPPQQQst PPPsAAAsBBB => QQQtAAAtBBB' ) ; |
| 8522 | |
| 8523 | note( 'Leaving tests_prefix_seperator_invertion()' ) ; |
| 8524 | return ; |
| 8525 | } |
| 8526 | |
| 8527 | # Global variables to remove: |
| 8528 | |
| 8529 | |
| 8530 | sub prefix_seperator_invertion |
| 8531 | { |
| 8532 | my $mysync = shift ; |
| 8533 | my $h1_fold = shift ; |
| 8534 | my $h2_fold ; |
| 8535 | |
| 8536 | if ( not defined $h1_fold ) { return ; } |
| 8537 | |
| 8538 | my $my_h1_prefix = $mysync->{ h1_prefix } || q{} ; |
| 8539 | my $my_h2_prefix = $mysync->{ h2_prefix } || q{} ; |
| 8540 | my $my_h1_sep = $mysync->{ h1_sep } || '/' ; |
| 8541 | my $my_h2_sep = $mysync->{ h2_sep } || '/' ; |
| 8542 | |
| 8543 | # first we remove the prefix |
| 8544 | $h1_fold =~ s/^\Q$my_h1_prefix\E//x ; |
| 8545 | ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "removed host1 prefix: [$h1_fold]\n" ) ; |
| 8546 | $h2_fold = separator_invert( $mysync, $h1_fold, $my_h1_sep, $my_h2_sep ) ; |
| 8547 | ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "inverted separators: [$h2_fold]\n" ) ; |
| 8548 | |
| 8549 | # Adding the prefix supplied by namespace or the --prefix2 option |
| 8550 | # except for INBOX or Inbox |
| 8551 | if ( $h2_fold !~ m/^INBOX$/xi ) |
| 8552 | { |
| 8553 | $h2_fold = $my_h2_prefix . $h2_fold ; |
| 8554 | } |
| 8555 | |
| 8556 | ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "added host2 prefix: [$h2_fold]\n" ) ; |
| 8557 | return( $h2_fold ) ; |
| 8558 | } |
| 8559 | |
| 8560 | sub tests_separator_invert |
| 8561 | { |
| 8562 | note( 'Entering tests_separator_invert()' ) ; |
| 8563 | |
| 8564 | my $mysync = {} ; |
| 8565 | $mysync->{ fixslash2 } = 0 ; |
| 8566 | ok( not( defined separator_invert( ) ), 'separator_invert: no args' ) ; |
| 8567 | ok( not( defined separator_invert( q{} ) ), 'separator_invert: not enough args' ) ; |
| 8568 | ok( not( defined separator_invert( q{}, q{} ) ), 'separator_invert: not enough args' ) ; |
| 8569 | |
| 8570 | ok( q{} eq separator_invert( $mysync, q{}, q{}, q{} ), 'separator_invert: 3 empty strings' ) ; |
| 8571 | ok( 'lalala' eq separator_invert( $mysync, 'lalala', q{}, q{} ), 'separator_invert: empty separator' ) ; |
| 8572 | ok( 'lalala' eq separator_invert( $mysync, 'lalala', '/', '/' ), 'separator_invert: same separator /' ) ; |
| 8573 | ok( 'lal/ala' eq separator_invert( $mysync, 'lal/ala', '/', '/' ), 'separator_invert: same separator / 2' ) ; |
| 8574 | ok( 'lal.ala' eq separator_invert( $mysync, 'lal/ala', '/', '.' ), 'separator_invert: separators /.' ) ; |
| 8575 | ok( 'lal/ala' eq separator_invert( $mysync, 'lal.ala', '.', '/' ), 'separator_invert: separators ./' ) ; |
| 8576 | ok( 'la.l/ala' eq separator_invert( $mysync, 'la/l.ala', '.', '/' ), 'separator_invert: separators ./' ) ; |
| 8577 | |
| 8578 | ok( 'l/al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ; |
| 8579 | $mysync->{ fixslash2 } = 1 ; |
| 8580 | ok( 'l_al.ala' eq separator_invert( $mysync, 'l.al/ala', '/', '.' ), 'separator_invert: separators /.' ) ; |
| 8581 | |
| 8582 | note( 'Leaving tests_separator_invert()' ) ; |
| 8583 | return ; |
| 8584 | } |
| 8585 | |
| 8586 | # Global variables to remove: |
| 8587 | # |
| 8588 | sub separator_invert |
| 8589 | { |
| 8590 | my( $mysync, $h1_fold, $h1_separator, $h2_separator ) = @_ ; |
| 8591 | |
| 8592 | return( undef ) if ( not all_defined( $mysync, $h1_fold, $h1_separator, $h2_separator ) ) ; |
| 8593 | # The separator we hope we'll never encounter: 00000000 == 0x00 |
| 8594 | my $o_sep = "\000" ; |
| 8595 | |
| 8596 | my $h2_fold = $h1_fold ; |
| 8597 | $h2_fold =~ s,\Q$h2_separator,$o_sep,xg ; |
| 8598 | $h2_fold =~ s,\Q$h1_separator,$h2_separator,xg ; |
| 8599 | $h2_fold =~ s,\Q$o_sep,$h1_separator,xg ; |
| 8600 | $h2_fold =~ s,/,_,xg if( $mysync->{ fixslash2 } and '/' ne $h2_separator and '/' eq $h1_separator ) ; |
| 8601 | return( $h2_fold ) ; |
| 8602 | } |
| 8603 | |
| 8604 | |
| 8605 | sub regextrans2 |
| 8606 | { |
| 8607 | my( $mysync, $h2_fold ) = @_ ; |
| 8608 | # Transforming the folder name by the --regextrans2 option(s) |
| 8609 | foreach my $regextrans2 ( @{ $mysync->{ regextrans2 } } ) { |
| 8610 | my $h2_fold_before = $h2_fold ; |
| 8611 | my $ret = eval "\$h2_fold =~ $regextrans2 ; 1 " ; |
| 8612 | ( $mysync->{ debug } or $mysync->{debugfolders} ) and myprint( "[$h2_fold_before] -> [$h2_fold] using regextrans2 [$regextrans2]\n" ) ; |
| 8613 | if ( not ( defined $ret ) or $EVAL_ERROR ) { |
| 8614 | $mysync->{nb_errors}++ ; |
| 8615 | exit_clean( $mysync, $EX_USAGE, |
| 8616 | "error: eval regextrans2 '$regextrans2': $EVAL_ERROR\n" |
| 8617 | ) ; |
| 8618 | } |
| 8619 | } |
| 8620 | return( $h2_fold ) ; |
| 8621 | } |
| 8622 | |
| 8623 | |
| 8624 | sub tests_decompose_regex |
| 8625 | { |
| 8626 | note( 'Entering tests_decompose_regex()' ) ; |
| 8627 | |
| 8628 | ok( 1, 'decompose_regex 1' ) ; |
| 8629 | ok( 0 == compare_lists( [ q{}, q{} ], [ decompose_regex( q{} ) ] ), 'decompose_regex empty string' ) ; |
| 8630 | ok( 0 == compare_lists( [ '.*', 'lala' ], [ decompose_regex( 's/.*/lala/' ) ] ), 'decompose_regex s/.*/lala/' ) ; |
| 8631 | |
| 8632 | note( 'Leaving tests_decompose_regex()' ) ; |
| 8633 | return ; |
| 8634 | } |
| 8635 | |
| 8636 | sub decompose_regex |
| 8637 | { |
| 8638 | my $regex = shift ; |
| 8639 | my( $left_part, $right_part ) ; |
| 8640 | |
| 8641 | ( $left_part, $right_part ) = $regex =~ m{^s/((?:[^/]|\\/)+)/((?:[^/]|\\/)+)/}x; |
| 8642 | return( q{}, q{} ) if not $left_part ; |
| 8643 | return( $left_part, $right_part ) ; |
| 8644 | } |
| 8645 | |
| 8646 | |
| 8647 | |
| 8648 | sub tests_timenext |
| 8649 | { |
| 8650 | note( 'Entering tests_timenext()' ) ; |
| 8651 | |
| 8652 | is( undef, timenext( ), 'timenext: no args => undef' ) ; |
| 8653 | my $mysync ; |
| 8654 | is( undef, timenext( $mysync ), 'timenext: undef => undef' ) ; |
| 8655 | $mysync = {} ; |
| 8656 | ok( time - timenext( $mysync ) <= 1e-02, 'timenext: defined first time => ~ time' ) ; |
| 8657 | ok( timenext( $mysync ) <= 1e-02, 'timenext: second time => less than 1e-02' ) ; |
| 8658 | ok( timenext( $mysync ) <= 1e-02, 'timenext: third time => less than 1e-02' ) ; |
| 8659 | |
| 8660 | note( 'Leaving tests_timenext()' ) ; |
| 8661 | return ; |
| 8662 | } |
| 8663 | |
| 8664 | |
| 8665 | sub timenext |
| 8666 | { |
| 8667 | my $mysync = shift ; |
| 8668 | |
| 8669 | if ( ! defined $mysync ) |
| 8670 | { |
| 8671 | return ; |
| 8672 | } |
| 8673 | my ( $timenow, $timediff ) ; |
| 8674 | |
| 8675 | $mysync->{ timebefore } ||= 0; # epoch... |
| 8676 | $timenow = time ; |
| 8677 | $timediff = $timenow - $mysync->{ timebefore } ; |
| 8678 | $mysync->{ timebefore } = $timenow ; |
| 8679 | # myprint( "timenext: $timediff\n" ) ; |
| 8680 | return( $timediff ) ; |
| 8681 | } |
| 8682 | |
| 8683 | |
| 8684 | sub tests_timesince |
| 8685 | { |
| 8686 | note( 'Entering tests_timesince()' ) ; |
| 8687 | |
| 8688 | ok( timesince( time - 1 ) - 1 <= 1e-02, 'timesince: time - 1 => <= 1 + 1e-02' ) ; |
| 8689 | ok( timesince( time ) <= 1e-02, 'timesince: time => <= 1e-02' ) ; |
| 8690 | ok( timesince( ) - time <= 1e-02, 'timesince: no args => <= time + 1e-02' ) ; |
| 8691 | note( 'Leaving tests_timesince()' ) ; |
| 8692 | return ; |
| 8693 | } |
| 8694 | |
| 8695 | |
| 8696 | |
| 8697 | sub timesince |
| 8698 | { |
| 8699 | my $timeinit = shift || 0 ; |
| 8700 | my ( $timenow, $timediff ) ; |
| 8701 | $timenow = time ; |
| 8702 | $timediff = $timenow - $timeinit ; |
| 8703 | # Often used in a division so no 0 but a nano seconde. |
| 8704 | return( max( $timediff, min( 1e-09, $timediff ) ) ) ; |
| 8705 | } |
| 8706 | |
| 8707 | |
| 8708 | |
| 8709 | |
| 8710 | sub tests_flags_regex |
| 8711 | { |
| 8712 | note( 'Entering tests_flags_regex()' ) ; |
| 8713 | |
| 8714 | ok( q{} eq flags_regex(q{} ), 'flags_regex, null string q{}' ) ; |
| 8715 | ok( q{\Seen NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, nothing to do} ) ; |
| 8716 | |
| 8717 | @regexflag = ('I am BAD' ) ; |
| 8718 | ok( not ( defined flags_regex( q{} ) ), 'flags_regex, bad regex' ) ; |
| 8719 | |
| 8720 | @regexflag = ( 's/NonJunk//g' ) ; |
| 8721 | ok( q{\Seen $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove NonJunk: 's/NonJunk//g'} ) ; |
| 8722 | @regexflag = ( q{s/\$Spam//g} ) ; |
| 8723 | ok( q{\Seen NonJunk } eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove $Spam: 's/\$Spam//g'} ) ; |
| 8724 | |
| 8725 | @regexflag = ( 's/\\\\Seen//g' ) ; |
| 8726 | |
| 8727 | ok( q{ NonJunk $Spam} eq flags_regex( q{\Seen NonJunk $Spam} ), q{flags_regex, remove \Seen: 's/\\\\\\\\Seen//g'} ) ; |
| 8728 | |
| 8729 | @regexflag = ( 's/(\s|^)[^\\\\]\w+//g' ) ; |
| 8730 | ok( q{\Seen \Middle \End} eq flags_regex( q{\Seen NonJunk \Middle $Spam \End} ), q{flags_regex: only \word among \Seen NonJunk \Middle $Spam \End} ) ; |
| 8731 | ok( q{ \Seen \Middle \End1} eq flags_regex( q{Begin \Seen NonJunk \Middle $Spam \End1 End} ), |
| 8732 | q{flags_regex: only \word among Begin \Seen NonJunk \Middle $Spam \End1 End} ) ; |
| 8733 | |
| 8734 | @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g} ) ; |
| 8735 | ok( 'Keep1 Keep2 ReB' eq flags_regex('ReA Keep1 REM Keep2 ReB'), 'Keep only regex' ) ; |
| 8736 | |
| 8737 | ok( 'Keep1 Keep2 ' eq flags_regex( 'REM REM Keep1 Keep2'), 'Keep only regex' ) ; |
| 8738 | ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 REM REM Keep2'), 'Keep only regex' ) ; |
| 8739 | ok( 'Keep1 Keep2 ' eq flags_regex( 'REM Keep1 REM REM Keep2'), 'Keep only regex' ) ; |
| 8740 | ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2'), 'Keep only regex' ) ; |
| 8741 | ok( 'Keep1 ' eq flags_regex( 'REM Keep1'), 'Keep only regex' ) ; |
| 8742 | |
| 8743 | @regexflag = ( q{s/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g} ) ; |
| 8744 | ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 ReB'), 'Keep only regex' ) ; |
| 8745 | ok( 'Keep1 Keep2 ' eq flags_regex( 'Keep1 Keep2 REM REM REM'), 'Keep only regex' ) ; |
| 8746 | ok( 'Keep2 ' eq flags_regex('Keep2 REM REM REM'), 'Keep only regex' ) ; |
| 8747 | |
| 8748 | |
| 8749 | @regexflag = ( q{s/.*?(Keep1|Keep2|Keep3)/$1 /g}, |
| 8750 | 's/(Keep1|Keep2|Keep3) (?!(Keep1|Keep2|Keep3)).*/$1 /g' ) ; |
| 8751 | ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2 REM'), 'Keep only regex' ) ; |
| 8752 | ok( 'Keep1 Keep2 ' eq flags_regex('Keep1 REM Keep2 REM'), 'Keep only regex' ) ; |
| 8753 | ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 Keep2 REM'), 'Keep only regex' ) ; |
| 8754 | ok( 'Keep1 Keep2 ' eq flags_regex('REM Keep1 REM Keep2'), 'Keep only regex' ) ; |
| 8755 | ok( 'Keep1 Keep2 Keep3 ' eq flags_regex('REM Keep1 REM Keep2 REM REM Keep3 REM'), 'Keep only regex' ) ; |
| 8756 | ok( 'Keep1 ' eq flags_regex('REM REM Keep1 REM REM REM '), 'Keep only regex' ) ; |
| 8757 | ok( 'Keep1 Keep3 ' eq flags_regex('RE1 Keep1 RE2 Keep3 RE3 RE4 RE5 '), 'Keep only regex' ) ; |
| 8758 | |
| 8759 | @regexflag = ( 's/(.*)/$1 jrdH8u/' ) ; |
| 8760 | ok('REM REM REM REM REM jrdH8u' eq flags_regex('REM REM REM REM REM'), q{Add jrdH8u 's/(.*)/\$1 jrdH8u/'} ) ; |
| 8761 | @regexflag = ('s/jrdH8u *//'); |
| 8762 | ok('REM REM REM REM REM ' eq flags_regex('REM REM REM REM REM jrdH8u'), q{Remove jrdH8u s/jrdH8u *//} ) ; |
| 8763 | |
| 8764 | @regexflag = ( |
| 8765 | 's/.*?(?:(\\\\(?:Answered|Flagged|Deleted|Seen|Draft)\s?)|$)/defined($1)?$1:q()/eg' |
| 8766 | ); |
| 8767 | |
| 8768 | ok( '\\Deleted \\Answered ' |
| 8769 | eq flags_regex('Blabla \$Junk \\Deleted machin \\Answered truc'), |
| 8770 | 'Keep only regex: Exchange case (Phil)' ) ; |
| 8771 | |
| 8772 | ok( q{} eq flags_regex( q{} ), 'Keep only regex: Exchange case, null string (Phil)' ) ; |
| 8773 | |
| 8774 | ok( q{} |
| 8775 | eq flags_regex('Blabla $Junk machin truc'), |
| 8776 | 'Keep only regex: Exchange case, no accepted flags (Phil)' ) ; |
| 8777 | |
| 8778 | ok('\\Deleted \\Answered \\Draft \\Flagged ' |
| 8779 | eq flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), |
| 8780 | 'Keep only regex: Exchange case (Phil)' ) ; |
| 8781 | |
| 8782 | @regexflag = ( 's/\\\\Flagged//g' ) ; |
| 8783 | |
| 8784 | is('\Deleted \Answered \Draft ', |
| 8785 | flags_regex('\\Deleted \\Answered \\Draft \\Flagged '), |
| 8786 | 'flags_regex: remove \Flagged 1' ) ; |
| 8787 | is('\\Deleted \\Answered \\Draft', |
| 8788 | flags_regex('\\Deleted \\Flagged \\Answered \\Draft'), |
| 8789 | 'flags_regex: remove \Flagged 2' ) ; |
| 8790 | |
| 8791 | # I didn't understand why it gives \F |
| 8792 | # https://perldoc.perl.org/perlrebackslash.html |
| 8793 | # \F Foldcase till \E. Not in []. |
| 8794 | # https://perldoc.perl.org/functions/fc.html |
| 8795 | |
| 8796 | # \F Not available in old Perl so I comment the test |
| 8797 | |
| 8798 | # @regexflag = ( 's/\\Flagged/X/g' ) ; |
| 8799 | #is('\Deleted FX \Answered \FX \Draft \FX', |
| 8800 | #flags_regex( '\Deleted Flagged \Answered \Flagged \Draft \Flagged' ), |
| 8801 | # 'flags_regex: remove \Flagged 3 mistery...' ) ; |
| 8802 | |
| 8803 | note( 'Leaving tests_flags_regex()' ) ; |
| 8804 | return ; |
| 8805 | } |
| 8806 | |
| 8807 | sub flags_regex |
| 8808 | { |
| 8809 | my ( $h1_flags ) = @_ ; |
| 8810 | foreach my $regexflag ( @regexflag ) { |
| 8811 | my $h1_flags_orig = $h1_flags ; |
| 8812 | $debugflags and myprint( "eval \$h1_flags =~ $regexflag\n" ) ; |
| 8813 | my $ret = eval "\$h1_flags =~ $regexflag ; 1 " ; |
| 8814 | $debugflags and myprint( "regexflag $regexflag [$h1_flags_orig] -> [$h1_flags]\n" ) ; |
| 8815 | if( not ( defined $ret ) or $EVAL_ERROR ) { |
| 8816 | myprint( "Error: eval regexflag '$regexflag': $EVAL_ERROR\n" ) ; |
| 8817 | return( undef ) ; |
| 8818 | } |
| 8819 | } |
| 8820 | return( $h1_flags ) ; |
| 8821 | } |
| 8822 | |
| 8823 | sub acls_sync |
| 8824 | { |
| 8825 | my($h1_fold, $h2_fold) = @_ ; |
| 8826 | if ( $syncacls ) { |
| 8827 | my $h1_hash = $sync->{imap1}->getacl($h1_fold) |
| 8828 | or myprint( "Could not getacl for $h1_fold: $EVAL_ERROR\n" ) ; |
| 8829 | my $h2_hash = $sync->{imap2}->getacl($h2_fold) |
| 8830 | or myprint( "Could not getacl for $h2_fold: $EVAL_ERROR\n" ) ; |
| 8831 | my %users = map { ($_, 1) } ( keys %{ $h1_hash} , keys %{ $h2_hash } ) ; |
| 8832 | foreach my $user (sort keys %users ) { |
| 8833 | my $acl = $h1_hash->{$user} || 'none' ; |
| 8834 | myprint( "acl $user: [$acl]\n" ) ; |
| 8835 | next if ($h1_hash->{$user} && $h2_hash->{$user} && |
| 8836 | $h1_hash->{$user} eq $h2_hash->{$user}); |
| 8837 | unless ($sync->{dry}) { |
| 8838 | myprint( "setting acl $h2_fold $user $acl\n" ) ; |
| 8839 | $sync->{imap2}->setacl($h2_fold, $user, $acl) |
| 8840 | or myprint( "Could not set acl: $EVAL_ERROR\n" ) ; |
| 8841 | } |
| 8842 | } |
| 8843 | } |
| 8844 | return ; |
| 8845 | } |
| 8846 | |
| 8847 | |
| 8848 | sub tests_permanentflags |
| 8849 | { |
| 8850 | note( 'Entering tests_permanentflags()' ) ; |
| 8851 | |
| 8852 | my $string; |
| 8853 | ok(q{} eq permanentflags(' * OK [PERMANENTFLAGS (\* \Draft \Answered)] Limited'), |
| 8854 | 'permanentflags \*'); |
| 8855 | ok('\Draft \Answered' eq permanentflags(' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited'), |
| 8856 | 'permanentflags \Draft \Answered'); |
| 8857 | ok('\Draft \Answered' |
| 8858 | eq permanentflags('Blabla', |
| 8859 | ' * OK [PERMANENTFLAGS (\Draft \Answered)] Limited', |
| 8860 | 'Blabla'), |
| 8861 | 'permanentflags \Draft \Answered' |
| 8862 | ); |
| 8863 | ok(q{} eq permanentflags('Blabla'), 'permanentflags nothing'); |
| 8864 | |
| 8865 | note( 'Leaving tests_permanentflags()' ) ; |
| 8866 | return ; |
| 8867 | } |
| 8868 | |
| 8869 | sub permanentflags |
| 8870 | { |
| 8871 | my @lines = @_ ; |
| 8872 | |
| 8873 | foreach my $line (@lines) { |
| 8874 | if ( $line =~ m{\[PERMANENTFLAGS\s\(([^)]+?)\)\]}x ) { |
| 8875 | ( $debugflags or $sync->{ debug } ) and myprint( "permanentflags: $line" ) ; |
| 8876 | my $permanentflags = $1 ; |
| 8877 | if ( $permanentflags =~ m{\\\*}x ) { |
| 8878 | $permanentflags = q{} ; |
| 8879 | } |
| 8880 | return($permanentflags) ; |
| 8881 | } ; |
| 8882 | } |
| 8883 | return( q{} ) ; |
| 8884 | } |
| 8885 | |
| 8886 | sub tests_flags_filter |
| 8887 | { |
| 8888 | note( 'Entering tests_flags_filter()' ) ; |
| 8889 | |
| 8890 | ok( '\Seen' eq flags_filter('\Seen', '\Draft \Seen \Answered'), 'flags_filter ' ); |
| 8891 | ok( q{} eq flags_filter('\Seen', '\Draft \Answered'), 'flags_filter ' ); |
| 8892 | ok( '\Seen' eq flags_filter('\Seen', '\Seen'), 'flags_filter ' ); |
| 8893 | ok( '\Seen' eq flags_filter('\Seen', ' \Seen '), 'flags_filter ' ); |
| 8894 | ok( '\Seen \Draft' |
| 8895 | eq flags_filter('\Seen \Draft', '\Draft \Seen \Answered'), 'flags_filter ' ); |
| 8896 | ok( '\Seen \Draft' |
| 8897 | eq flags_filter('\Seen \Draft', ' \Draft \Seen \Answered '), 'flags_filter ' ); |
| 8898 | |
| 8899 | note( 'Leaving tests_flags_filter()' ) ; |
| 8900 | return ; |
| 8901 | } |
| 8902 | |
| 8903 | sub flags_filter |
| 8904 | { |
| 8905 | my( $flags, $allowed_flags ) = @_ ; |
| 8906 | |
| 8907 | my @flags = split /\s+/x, $flags ; |
| 8908 | my %allowed_flags = map { $_ => 1 } split q{ }, $allowed_flags ; |
| 8909 | my @flags_out = map { exists $allowed_flags{$_} ? $_ : () } @flags ; |
| 8910 | |
| 8911 | my $flags_out = join q{ }, @flags_out ; |
| 8912 | |
| 8913 | return( $flags_out ) ; |
| 8914 | } |
| 8915 | |
| 8916 | sub flagscase |
| 8917 | { |
| 8918 | my $flags = shift ; |
| 8919 | |
| 8920 | my @flags = split /\s+/x, $flags ; |
| 8921 | my %rfc_flags = map { $_ => 1 } split q{ }, '\Answered \Flagged \Deleted \Seen \Draft' ; |
| 8922 | my @flags_out = map { exists $rfc_flags{ ucsecond( lc $_ ) } ? ucsecond( lc $_ ) : $_ } @flags ; |
| 8923 | |
| 8924 | my $flags_out = join q{ }, @flags_out ; |
| 8925 | |
| 8926 | return( $flags_out ) ; |
| 8927 | } |
| 8928 | |
| 8929 | sub tests_flagscase |
| 8930 | { |
| 8931 | note( 'Entering tests_flagscase()' ) ; |
| 8932 | |
| 8933 | ok( '\Seen' eq flagscase( '\Seen' ), 'flagscase: \Seen -> \Seen' ) ; |
| 8934 | ok( '\Seen' eq flagscase( '\SEEN' ), 'flagscase: \SEEN -> \Seen' ) ; |
| 8935 | |
| 8936 | ok( '\Seen \Draft' eq flagscase( '\SEEN \DRAFT' ), 'flagscase: \SEEN \DRAFT -> \Seen \Draft' ) ; |
| 8937 | ok( '\Draft \Seen' eq flagscase( '\DRAFT \SEEN' ), 'flagscase: \DRAFT \SEEN -> \Draft \Seen' ) ; |
| 8938 | |
| 8939 | ok( '\Draft LALA \Seen' eq flagscase( '\DRAFT LALA \SEEN' ), 'flagscase: \DRAFT LALA \SEEN -> \Draft LALA \Seen' ) ; |
| 8940 | ok( '\Draft lala \Seen' eq flagscase( '\DRAFT lala \SEEN' ), 'flagscase: \DRAFT lala \SEEN -> \Draft lala \Seen' ) ; |
| 8941 | |
| 8942 | note( 'Leaving tests_flagscase()' ) ; |
| 8943 | return ; |
| 8944 | } |
| 8945 | |
| 8946 | |
| 8947 | |
| 8948 | sub ucsecond |
| 8949 | { |
| 8950 | my $string = shift ; |
| 8951 | my $output ; |
| 8952 | |
| 8953 | return( $string ) if ( 1 >= length $string ) ; |
| 8954 | |
| 8955 | $output = ( substr( $string, 0, 1) ) . ( uc substr $string, 1, 1 ) . ( substr $string, 2 ) ; |
| 8956 | #myprint( "UUU $string -> $output\n" ) ; |
| 8957 | return( $output ) ; |
| 8958 | } |
| 8959 | |
| 8960 | |
| 8961 | sub tests_ucsecond |
| 8962 | { |
| 8963 | note( 'Entering tests_ucsecond()' ) ; |
| 8964 | |
| 8965 | ok( 'aBcde' eq ucsecond( 'abcde' ), 'ucsecond: abcde -> aBcde' ) ; |
| 8966 | ok( 'ABCDE' eq ucsecond( 'ABCDE' ), 'ucsecond: ABCDE -> ABCDE' ) ; |
| 8967 | ok( 'ABCDE' eq ucsecond( 'AbCDE' ), 'ucsecond: AbCDE -> ABCDE' ) ; |
| 8968 | ok( 'ABCde' eq ucsecond( 'AbCde' ), 'ucsecond: AbCde -> ABCde' ) ; |
| 8969 | ok( 'A' eq ucsecond( 'A' ), 'ucsecond: A -> A' ) ; |
| 8970 | ok( 'AB' eq ucsecond( 'Ab' ), 'ucsecond: Ab -> AB' ) ; |
| 8971 | ok( '\B' eq ucsecond( '\b' ), 'ucsecond: \b -> \B' ) ; |
| 8972 | ok( '\Bcde' eq ucsecond( '\bcde' ), 'ucsecond: \bcde -> \Bcde' ) ; |
| 8973 | |
| 8974 | note( 'Leaving tests_ucsecond()' ) ; |
| 8975 | return ; |
| 8976 | } |
| 8977 | |
| 8978 | |
| 8979 | sub select_msgs |
| 8980 | { |
| 8981 | my ( $imap, $msgs_all_hash_ref, $search_cmd, $abletosearch, $folder ) = @_ ; |
| 8982 | my ( @msgs ) ; |
| 8983 | |
| 8984 | if ( $abletosearch ) { |
| 8985 | @msgs = select_msgs_by_search( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; |
| 8986 | }else{ |
| 8987 | @msgs = select_msgs_by_fetch( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) ; |
| 8988 | } |
| 8989 | return( @msgs ) ; |
| 8990 | |
| 8991 | } |
| 8992 | |
| 8993 | sub select_msgs_by_search |
| 8994 | { |
| 8995 | my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; |
| 8996 | my ( @msgs, @msgs_all ) ; |
| 8997 | |
| 8998 | # Need to have the whole list in msgs_all_hash_ref |
| 8999 | # without calling messages() several times. |
| 9000 | # Need all messages list to avoid deleting useful cache part |
| 9001 | # in case of --search or --minage or --maxage |
| 9002 | |
| 9003 | if ( ( defined $msgs_all_hash_ref and $usecache ) |
| 9004 | or ( not defined $maxage and not defined $minage and not defined $search_cmd ) |
| 9005 | ) { |
| 9006 | |
| 9007 | $debugdev and myprint( "Calling messages()\n" ) ; |
| 9008 | @msgs_all = $imap->messages( ) ; |
| 9009 | |
| 9010 | return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ; |
| 9011 | |
| 9012 | if ( defined $msgs_all_hash_ref ) { |
| 9013 | @{ $msgs_all_hash_ref }{ @msgs_all } = () ; |
| 9014 | } |
| 9015 | # return all messages |
| 9016 | if ( not defined $maxage and not defined $minage and not defined $search_cmd ) { |
| 9017 | return( @msgs_all ) ; |
| 9018 | } |
| 9019 | } |
| 9020 | |
| 9021 | if ( defined $search_cmd ) { |
| 9022 | @msgs = $imap->search( $search_cmd ) ; |
| 9023 | return( @msgs ) ; |
| 9024 | } |
| 9025 | |
| 9026 | # we are here only if $maxage or $minage is defined |
| 9027 | @msgs = select_msgs_by_age( $imap ) ; |
| 9028 | return( @msgs ); |
| 9029 | } |
| 9030 | |
| 9031 | |
| 9032 | sub select_msgs_by_fetch |
| 9033 | { |
| 9034 | my ( $imap, $msgs_all_hash_ref, $search_cmd, $folder ) = @_ ; |
| 9035 | my ( @msgs, @msgs_all, %fetch ) ; |
| 9036 | |
| 9037 | # Need to have the whole list in msgs_all_hash_ref |
| 9038 | # without calling messages() several times. |
| 9039 | # Need all messages list to avoid deleting useful cache part |
| 9040 | # in case of --search or --minage or --maxage |
| 9041 | |
| 9042 | |
| 9043 | $debugdev and myprint( "Calling fetch_hash()\n" ) ; |
| 9044 | my $uidnext = $imap->uidnext( $folder ) || $uidnext_default ; |
| 9045 | my $fetch_hash_uids = $fetch_hash_set || "1:$uidnext" ; |
| 9046 | %fetch = %{$imap->fetch_hash( $fetch_hash_uids, 'INTERNALDATE' ) } ; |
| 9047 | |
| 9048 | @msgs_all = sort { $a <=> $b } keys %fetch ; |
| 9049 | $debugdev and myprint( "Done fetch_hash()\n" ) ; |
| 9050 | |
| 9051 | return if ( $#msgs_all == 0 && !defined $msgs_all[0] ) ; |
| 9052 | |
| 9053 | if ( defined $msgs_all_hash_ref ) { |
| 9054 | @{ $msgs_all_hash_ref }{ @msgs_all } = () ; |
| 9055 | } |
| 9056 | # return all messages |
| 9057 | if ( not defined $maxage and not defined $minage and not defined $search_cmd ) { |
| 9058 | return( @msgs_all ) ; |
| 9059 | } |
| 9060 | |
| 9061 | if ( defined $search_cmd ) { |
| 9062 | myprint( "Warning: strange to see --search with --noabletosearch, an error can happen\n" ) ; |
| 9063 | @msgs = $imap->search( $search_cmd ) ; |
| 9064 | return( @msgs ) ; |
| 9065 | } |
| 9066 | |
| 9067 | # we are here only if $maxage or $minage is defined |
| 9068 | my( @max, @min, $maxage_epoch, $minage_epoch ) ; |
| 9069 | if ( defined $maxage ) { $maxage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ; } |
| 9070 | if ( defined $minage ) { $minage_epoch = $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ; } |
| 9071 | foreach my $msg ( @msgs_all ) { |
| 9072 | my $idate = $fetch{ $msg }->{'INTERNALDATE'} ; |
| 9073 | #myprint( "$idate\n" ) ; |
| 9074 | if ( defined $maxage and ( epoch( $idate ) >= $maxage_epoch ) ) { |
| 9075 | push @max, $msg ; |
| 9076 | } |
| 9077 | if ( defined $minage and ( epoch( $idate ) <= $minage_epoch ) ) { |
| 9078 | push @min, $msg ; |
| 9079 | } |
| 9080 | } |
| 9081 | @msgs = msgs_from_maxmin( \@max, \@min ) ; |
| 9082 | return( @msgs ) ; |
| 9083 | } |
| 9084 | |
| 9085 | sub select_msgs_by_age |
| 9086 | { |
| 9087 | my( $imap ) = @_ ; |
| 9088 | |
| 9089 | my( @max, @min, @msgs, @inter, @union ) ; |
| 9090 | |
| 9091 | if ( defined $maxage ) { |
| 9092 | @max = $imap->sentsince( $timestart_int - $NB_SECONDS_IN_A_DAY * $maxage ) ; |
| 9093 | } |
| 9094 | if ( defined $minage ) { |
| 9095 | @min = $imap->sentbefore( $timestart_int - $NB_SECONDS_IN_A_DAY * $minage ) ; |
| 9096 | } |
| 9097 | |
| 9098 | @msgs = msgs_from_maxmin( \@max, \@min ) ; |
| 9099 | return( @msgs ) ; |
| 9100 | } |
| 9101 | |
| 9102 | sub msgs_from_maxmin |
| 9103 | { |
| 9104 | my( $max_ref, $min_ref ) = @_ ; |
| 9105 | my( @max, @min, @msgs, @inter, @union ) ; |
| 9106 | |
| 9107 | @max = @{ $max_ref } ; |
| 9108 | @min = @{ $min_ref } ; |
| 9109 | |
| 9110 | SWITCH: { |
| 9111 | unless( defined $minage ) { @msgs = @max ; last SWITCH } ; |
| 9112 | unless( defined $maxage ) { @msgs = @min ; last SWITCH } ; |
| 9113 | my ( %union, %inter ) ; |
| 9114 | foreach my $m ( @min, @max ) { $union{ $m }++ && $inter{ $m }++ } |
| 9115 | @inter = sort { $a <=> $b } keys %inter ; |
| 9116 | @union = sort { $a <=> $b } keys %union ; |
| 9117 | # normal case |
| 9118 | if ( $minage <= $maxage ) { @msgs = @inter ; last SWITCH } ; |
| 9119 | # just exclude messages between |
| 9120 | if ( $minage > $maxage ) { @msgs = @union ; last SWITCH } ; |
| 9121 | |
| 9122 | } |
| 9123 | return( @msgs ) ; |
| 9124 | } |
| 9125 | |
| 9126 | sub tests_msgs_from_maxmin |
| 9127 | { |
| 9128 | note( 'Entering tests_msgs_from_maxmin()' ) ; |
| 9129 | |
| 9130 | my @msgs ; |
| 9131 | $maxage = $NUMBER_200 ; |
| 9132 | @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; |
| 9133 | ok( 0 == compare_lists( [ '1', '2' ], \@msgs ), 'msgs_from_maxmin: maxage++' ) ; |
| 9134 | $minage = $NUMBER_100 ; |
| 9135 | @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; |
| 9136 | ok( 0 == compare_lists( [ '2' ], \@msgs ), 'msgs_from_maxmin: -maxage++minage-' ) ; |
| 9137 | $minage = $NUMBER_300 ; |
| 9138 | @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; |
| 9139 | ok( 0 == compare_lists( [ '1', '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++maxage-minage++' ) ; |
| 9140 | $maxage = undef ; |
| 9141 | @msgs = msgs_from_maxmin( [ '1', '2' ], [ '2', '3' ] ) ; |
| 9142 | ok( 0 == compare_lists( [ '2', '3' ], \@msgs ), 'msgs_from_maxmin: ++minage-' ) ; |
| 9143 | |
| 9144 | note( 'Leaving tests_msgs_from_maxmin()' ) ; |
| 9145 | return ; |
| 9146 | } |
| 9147 | |
| 9148 | sub tests_info_date_from_uid |
| 9149 | { |
| 9150 | note( 'Entering tests_info_date_from_uid()' ) ; |
| 9151 | note( 'Leaving tests_info_date_from_uid()' ) ; |
| 9152 | |
| 9153 | return ; |
| 9154 | } |
| 9155 | |
| 9156 | sub info_date_from_uid |
| 9157 | { |
| 9158 | |
| 9159 | #my $first_uid = $msgs_all[ 0 ] ; |
| 9160 | #my $first_idate = $fetch{ $first_uid }->{'INTERNALDATE'} ; |
| 9161 | #my $first_epoch = epoch( $first_idate ) ; |
| 9162 | #my $first_days = ( $timestart_int - $first_epoch ) / $NB_SECONDS_IN_A_DAY ; |
| 9163 | #myprint( "\nOldest msg has UID $first_uid INTERNALDATE $first_idate EPOCH $first_epoch DAYS AGO $first_days\n" ) ; |
| 9164 | } |
| 9165 | |
| 9166 | |
| 9167 | sub lastuid |
| 9168 | { |
| 9169 | my $imap = shift ; |
| 9170 | my $folder = shift ; |
| 9171 | my $lastuid_guess = shift ; |
| 9172 | my $lastuid ; |
| 9173 | |
| 9174 | # rfc3501: The only reliable way to identify recent messages is to |
| 9175 | # look at message flags to see which have the \Recent flag |
| 9176 | # set, or to do a SEARCH RECENT. |
| 9177 | # SEARCH RECENT doesn't work this way on courrier. |
| 9178 | |
| 9179 | my @recent_messages ; |
| 9180 | # SEARCH RECENT for each transfer can be expensive with a big folder |
| 9181 | # Call commented for now |
| 9182 | #@recent_messages = $imap->recent( ) ; |
| 9183 | #myprint( "Recent: @recent_messages\n" ) ; |
| 9184 | |
| 9185 | my $max_recent ; |
| 9186 | $max_recent = max( @recent_messages ) ; |
| 9187 | |
| 9188 | if ( defined $max_recent and ($lastuid_guess <= $max_recent ) ) { |
| 9189 | $lastuid = $max_recent ; |
| 9190 | }else{ |
| 9191 | $lastuid = $lastuid_guess |
| 9192 | } |
| 9193 | return( $lastuid ) ; |
| 9194 | } |
| 9195 | |
| 9196 | sub size_filtered |
| 9197 | { |
| 9198 | my( $h1_size, $h1_msg, $h1_fold, $h2_fold ) = @_ ; |
| 9199 | |
| 9200 | $h1_size = 0 if ( ! $h1_size ) ; # null if empty or undef |
| 9201 | if ( defined $sync->{ maxsize } and $h1_size > $sync->{ maxsize } ) { |
| 9202 | myprint( "msg $h1_fold/$h1_msg skipped ($h1_size exceeds maxsize limit $sync->{ maxsize } bytes)\n" ) ; |
| 9203 | $sync->{ total_bytes_skipped } += $h1_size; |
| 9204 | $sync->{ nb_msg_skipped } += 1; |
| 9205 | return( 1 ) ; |
| 9206 | } |
| 9207 | if ( defined $minsize and $h1_size <= $minsize ) { |
| 9208 | myprint( "msg $h1_fold/$h1_msg skipped ($h1_size smaller than minsize $minsize bytes)\n" ) ; |
| 9209 | $sync->{ total_bytes_skipped } += $h1_size; |
| 9210 | $sync->{ nb_msg_skipped } += 1; |
| 9211 | return( 1 ) ; |
| 9212 | } |
| 9213 | return( 0 ) ; |
| 9214 | } |
| 9215 | |
| 9216 | sub message_exists |
| 9217 | { |
| 9218 | my( $imap, $msg ) = @_ ; |
| 9219 | return( 1 ) if not $imap->Uid( ) ; |
| 9220 | |
| 9221 | my $search_uid ; |
| 9222 | ( $search_uid ) = $imap->search( "UID $msg" ) ; |
| 9223 | #myprint( "$search ? $msg\n" ) ; |
| 9224 | return( 1 ) if ( $search_uid eq $msg ) ; |
| 9225 | return( 0 ) ; |
| 9226 | } |
| 9227 | |
| 9228 | |
| 9229 | # Globals |
| 9230 | # $sync->{ total_bytes_skipped } |
| 9231 | # $sync->{ nb_msg_skipped } |
| 9232 | # $mysync->{ h1_nb_msg_processed } |
| 9233 | sub stats_update_skip_message |
| 9234 | { |
| 9235 | my $mysync = shift ; # to be used |
| 9236 | my $h1_size = shift ; |
| 9237 | |
| 9238 | $mysync->{ total_bytes_skipped } += $h1_size ; |
| 9239 | $mysync->{ nb_msg_skipped } += 1 ; |
| 9240 | $mysync->{ h1_nb_msg_processed } +=1 ; |
| 9241 | return ; |
| 9242 | } |
| 9243 | |
| 9244 | sub copy_message |
| 9245 | { |
| 9246 | # copy |
| 9247 | |
| 9248 | my ( $mysync, $h1_msg, $h1_fold, $h2_fold, $h1_fir_ref, $permanentflags2, $cache_dir ) = @_ ; |
| 9249 | ( $mysync->{ debug } or $mysync->{dry} ) |
| 9250 | and myprint( "msg $h1_fold/$h1_msg copying to $h2_fold $mysync->{dry_message} " . eta( $mysync ) . "\n" ) ; |
| 9251 | |
| 9252 | my $h1_size = $h1_fir_ref->{$h1_msg}->{'RFC822.SIZE'} || 0 ; |
| 9253 | my $h1_flags = $h1_fir_ref->{$h1_msg}->{'FLAGS'} || q{} ; |
| 9254 | my $h1_idate = $h1_fir_ref->{$h1_msg}->{'INTERNALDATE'} || q{} ; |
| 9255 | |
| 9256 | |
| 9257 | if ( size_filtered( $h1_size, $h1_msg, $h1_fold, $h2_fold ) ) { |
| 9258 | $mysync->{ h1_nb_msg_processed } +=1 ; |
| 9259 | return ; |
| 9260 | } |
| 9261 | |
| 9262 | debugsleep( $mysync ) ; |
| 9263 | myprint( "- msg $h1_fold/$h1_msg S[$h1_size] F[$h1_flags] I[$h1_idate] has RFC822.SIZE null!\n" ) if ( ! $h1_size ) ; |
| 9264 | |
| 9265 | if ( $checkmessageexists and not message_exists( $mysync->{imap1}, $h1_msg ) ) { |
| 9266 | stats_update_skip_message( $mysync, $h1_size ) ; |
| 9267 | return ; |
| 9268 | } |
| 9269 | myprint( debugmemory( $mysync, " at C1" ) ) ; |
| 9270 | |
| 9271 | my ( $string, $string_len ) ; |
| 9272 | ( $string_len ) = message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, \$string ) ; |
| 9273 | |
| 9274 | myprint( debugmemory( $mysync, " at C2" ) ) ; |
| 9275 | |
| 9276 | # not defined or empty $string |
| 9277 | if ( ( not $string ) or ( not $string_len ) ) { |
| 9278 | myprint( "- msg $h1_fold/$h1_msg skipped.\n" ) ; |
| 9279 | stats_update_skip_message( $mysync, $h1_size ) ; |
| 9280 | return ; |
| 9281 | } |
| 9282 | |
| 9283 | # Lines too long (or not enough) => do no copy or fix |
| 9284 | if ( ( defined $maxlinelength ) or ( defined $minmaxlinelength ) ) { |
| 9285 | $string = linelengthstuff( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) ; |
| 9286 | if ( not defined $string ) { |
| 9287 | stats_update_skip_message( $mysync, $h1_size ) ; |
| 9288 | return ; |
| 9289 | } |
| 9290 | } |
| 9291 | |
| 9292 | my $h1_date = date_for_host2( $h1_msg, $h1_idate ) ; |
| 9293 | |
| 9294 | ( $mysync->{ debug } or $debugflags ) and |
| 9295 | myprint( "Host1: flags init msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; |
| 9296 | |
| 9297 | $h1_flags = flags_for_host2( $h1_flags, $permanentflags2 ) ; |
| 9298 | |
| 9299 | ( $mysync->{ debug } or $debugflags ) and |
| 9300 | myprint( "Host1: flags filt msg $h1_fold/$h1_msg date [$h1_date] flags [$h1_flags] size [$h1_size]\n" ) ; |
| 9301 | |
| 9302 | $h1_date = undef if ( $h1_date eq q{} ) ; |
| 9303 | |
| 9304 | my $new_id = append_message_on_host2( $mysync, \$string, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) ; |
| 9305 | |
| 9306 | |
| 9307 | |
| 9308 | if ( $new_id and $syncflagsaftercopy ) { |
| 9309 | sync_flags_after_copy( $mysync, $h1_fold, $h1_msg, $h1_flags, $h2_fold, $new_id, $permanentflags2 ) ; |
| 9310 | } |
| 9311 | |
| 9312 | myprint( debugmemory( $mysync, " at C3" ) ) ; |
| 9313 | |
| 9314 | return $new_id ; |
| 9315 | } |
| 9316 | |
| 9317 | |
| 9318 | |
| 9319 | sub linelengthstuff |
| 9320 | { |
| 9321 | my( $string, $h1_fold, $h1_msg, $string_len, $h1_size, $h1_flags, $h1_idate ) = @_ ; |
| 9322 | my $maxlinelength_string = max_line_length( $string ) ; |
| 9323 | $debugmaxlinelength and myprint( "msg $h1_fold/$h1_msg maxlinelength: $maxlinelength_string\n" ) ; |
| 9324 | |
| 9325 | if ( ( defined $minmaxlinelength ) and ( $maxlinelength_string <= $minmaxlinelength ) ) { |
| 9326 | my $subject = subject( $string ) ; |
| 9327 | $debugdev and myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " |
| 9328 | . "(Subject:[$subject]) (max line length under minmaxlinelength $minmaxlinelength bytes)\n" ) ; |
| 9329 | return ; |
| 9330 | } |
| 9331 | |
| 9332 | if ( ( defined $maxlinelength ) and ( $maxlinelength_string > $maxlinelength ) ) { |
| 9333 | my $subject = subject( $string ) ; |
| 9334 | if ( $maxlinelengthcmd ) { |
| 9335 | $string = pipemess( $string, $maxlinelengthcmd ) ; |
| 9336 | # string undef means something was bad. |
| 9337 | if ( not ( defined $string ) ) { |
| 9338 | myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] " |
| 9339 | . "(Subject:[$subject]) could not be successfully transformed by --maxlinelengthcmd option\n" ) ; |
| 9340 | return ; |
| 9341 | }else{ |
| 9342 | return $string ; |
| 9343 | } |
| 9344 | } |
| 9345 | myprint( "- msg $h1_fold/$h1_msg skipped S[$h1_size] F[$h1_flags] I[$h1_idate] " |
| 9346 | . "(Subject:[$subject]) (line length exceeds maxlinelength $maxlinelength bytes)\n" ) ; |
| 9347 | return ; |
| 9348 | } |
| 9349 | return $string ; |
| 9350 | } |
| 9351 | |
| 9352 | |
| 9353 | sub message_for_host2 |
| 9354 | { |
| 9355 | |
| 9356 | # global variable list: |
| 9357 | # @skipmess |
| 9358 | # @regexmess |
| 9359 | # @pipemess |
| 9360 | # $debugcontent |
| 9361 | # $debug |
| 9362 | # |
| 9363 | # API current |
| 9364 | # |
| 9365 | # at failure: |
| 9366 | # * return nothing ( will then be undef or () ) |
| 9367 | # * $string_ref content is undef or empty |
| 9368 | # at success: |
| 9369 | # * return string length ($string_ref content length) |
| 9370 | # * $string_ref content filled with message |
| 9371 | |
| 9372 | # API future |
| 9373 | # |
| 9374 | # |
| 9375 | my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) = @_ ; |
| 9376 | |
| 9377 | # abort when missing a parameter |
| 9378 | if ( ( ! $mysync ) or ( ! $h1_msg ) or ( ! $h1_fold ) or ( ! defined $h1_size ) |
| 9379 | or ( ! defined $h1_flags) or ( ! defined $h1_idate ) |
| 9380 | or ( ! $h1_fir_ref) or ( ! $string_ref ) ) |
| 9381 | { |
| 9382 | return ; |
| 9383 | } |
| 9384 | |
| 9385 | myprint( debugmemory( $mysync, " at M1" ) ) ; |
| 9386 | |
| 9387 | |
| 9388 | my $string_ok = $mysync->{imap1}->message_to_file( $string_ref, $h1_msg ) ; |
| 9389 | |
| 9390 | myprint( debugmemory( $mysync, " at M2" ) ) ; |
| 9391 | |
| 9392 | my $string_len = length_ref( $string_ref ) ; |
| 9393 | |
| 9394 | |
| 9395 | unless ( defined $string_ok and $string_len ) { |
| 9396 | # undef or 0 length |
| 9397 | my $error = join q{}, |
| 9398 | "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate] could not be fetched: ", |
| 9399 | $mysync->{imap1}->LastError || q{}, "\n" ; |
| 9400 | errors_incr( $mysync, $error ) ; |
| 9401 | $mysync->{ h1_nb_msg_processed } +=1 ; |
| 9402 | return ; |
| 9403 | } |
| 9404 | |
| 9405 | if ( @skipmess ) { |
| 9406 | my $match = skipmess( ${ $string_ref } ) ; |
| 9407 | # string undef means the eval regex was bad. |
| 9408 | if ( not ( defined $match ) ) { |
| 9409 | myprint( |
| 9410 | "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" |
| 9411 | . " could not be skipped by --skipmess option, bad regex\n" ) ; |
| 9412 | return ; |
| 9413 | } |
| 9414 | if ( $match ) { |
| 9415 | my $subject = subject( ${ $string_ref } ) ; |
| 9416 | myprint( "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" |
| 9417 | . " (Subject:[$subject]) skipped by --skipmess\n" ) ; |
| 9418 | return ; |
| 9419 | } |
| 9420 | } |
| 9421 | |
| 9422 | if ( @regexmess ) { |
| 9423 | ${ $string_ref } = regexmess( ${ $string_ref } ) ; |
| 9424 | # string undef means the eval regex was bad. |
| 9425 | if ( not ( defined ${ $string_ref } ) ) { |
| 9426 | myprint( |
| 9427 | "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" |
| 9428 | . " could not be transformed by --regexmess\n" ) ; |
| 9429 | return ; |
| 9430 | } |
| 9431 | } |
| 9432 | |
| 9433 | if ( @pipemess ) { |
| 9434 | ${ $string_ref } = pipemess( ${ $string_ref }, @pipemess ) ; |
| 9435 | # string undef means something was bad. |
| 9436 | if ( not ( defined ${ $string_ref } ) ) { |
| 9437 | myprint( |
| 9438 | "- msg $h1_fold/$h1_msg {$string_len} S[$h1_size] F[$h1_flags] I[$h1_idate]" |
| 9439 | . " could not be successfully transformed by --pipemess option\n" ) ; |
| 9440 | return ; |
| 9441 | } |
| 9442 | } |
| 9443 | |
| 9444 | if ( $mysync->{addheader} and defined $h1_fir_ref->{$h1_msg}->{'NO_HEADER'} ) { |
| 9445 | my $header = add_header( $h1_msg ) ; |
| 9446 | $mysync->{ debug } and myprint( "msg $h1_fold/$h1_msg adding custom header [$header]\n" ) ; |
| 9447 | ${ $string_ref } = $header . "\r\n" . ${ $string_ref } ; |
| 9448 | } |
| 9449 | |
| 9450 | if ( ( defined $mysync->{ truncmess } ) and is_an_integer( $mysync->{ truncmess } ) ) |
| 9451 | { |
| 9452 | ${ $string_ref } = truncmess( ${ $string_ref }, $mysync->{ truncmess } ) ; |
| 9453 | } |
| 9454 | |
| 9455 | $string_len = length_ref( $string_ref ) ; |
| 9456 | |
| 9457 | $debugcontent and myprint( |
| 9458 | q{=} x $STD_CHAR_PER_LINE, "\n", |
| 9459 | "F message content begin next line ($string_len characters long)\n", |
| 9460 | ${ $string_ref }, |
| 9461 | "\nF message content ended on previous line\n", q{=} x $STD_CHAR_PER_LINE, "\n" ) ; |
| 9462 | |
| 9463 | myprint( debugmemory( $mysync, " at M3" ) ) ; |
| 9464 | |
| 9465 | return $string_len ; |
| 9466 | } |
| 9467 | |
| 9468 | sub tests_truncmess |
| 9469 | { |
| 9470 | note( 'Entering tests_truncmess()' ) ; |
| 9471 | |
| 9472 | is( undef, truncmess( ), 'truncmess: no args => undef' ) ; |
| 9473 | is( 'abc', truncmess( 'abc' ), 'truncmess: abc => abc' ) ; |
| 9474 | is( 'ab', truncmess( 'abc', 2 ), 'truncmess: abc 2 => ab' ) ; |
| 9475 | is( 'abc', truncmess( 'abc', 3 ), 'truncmess: abc 3 => abc' ) ; |
| 9476 | is( 'abc', truncmess( 'abc', 4 ), 'truncmess: abc 4 => abc' ) ; |
| 9477 | is( '12345', truncmess( "123456789\n", 5 ), 'truncmess: "123456789\n", 5 => 12345' ) ; |
| 9478 | is( "123456789\n" x 5000, truncmess( "123456789\n" x 100000, 50000 ), 'truncmess: "123456789\n" x 100000, 50000 => "123456789\n" x 5000' ) ; |
| 9479 | note( 'Leaving tests_truncmess()' ) ; |
| 9480 | return ; |
| 9481 | } |
| 9482 | |
| 9483 | sub truncmess |
| 9484 | { |
| 9485 | my $string = shift ; |
| 9486 | my $length = shift ; |
| 9487 | |
| 9488 | if ( not defined $string ) { return ; } |
| 9489 | if ( not defined $length ) { return $string ; } |
| 9490 | |
| 9491 | $string = substr $string, 0, $length ; |
| 9492 | return $string ; |
| 9493 | } |
| 9494 | |
| 9495 | sub tests_message_for_host2 |
| 9496 | { |
| 9497 | note( 'Entering tests_message_for_host2()' ) ; |
| 9498 | |
| 9499 | |
| 9500 | my ( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ) ; |
| 9501 | |
| 9502 | is( undef, message_for_host2( ), q{message_for_host2: no args} ) ; |
| 9503 | is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), q{message_for_host2: undef args} ) ; |
| 9504 | |
| 9505 | require_ok( "Test::MockObject" ) ; |
| 9506 | my $imapT = Test::MockObject->new( ) ; |
| 9507 | $mysync->{imap1} = $imapT ; |
| 9508 | my $string ; |
| 9509 | |
| 9510 | $h1_msg = 1 ; |
| 9511 | $h1_fold = 'FoldFoo'; |
| 9512 | $h1_size = 9 ; |
| 9513 | $h1_flags = q{} ; |
| 9514 | $h1_idate = '10-Jul-2015 09:00:00 +0200' ; |
| 9515 | $h1_fir_ref = {} ; |
| 9516 | $string_ref = \$string ; |
| 9517 | $imapT->mock( 'message_to_file', |
| 9518 | sub { |
| 9519 | my ( $imap, $mystring_ref, $msg ) = @_ ; |
| 9520 | ${$mystring_ref} = 'blablabla' ; |
| 9521 | return length ${$mystring_ref} ; |
| 9522 | } |
| 9523 | ) ; |
| 9524 | is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), |
| 9525 | q{message_for_host2: msg 1 == "blablabla", length} ) ; |
| 9526 | is( 'blablabla', $string, q{message_for_host2: msg 1 == "blablabla", value} ) ; |
| 9527 | |
| 9528 | # so far so good |
| 9529 | # now the --pipemess stuff |
| 9530 | |
| 9531 | SKIP: { |
| 9532 | Readonly my $NB_WIN_tests_message_for_host2 => 0 ; |
| 9533 | skip( 'Not on MSWin32', $NB_WIN_tests_message_for_host2 ) if ('MSWin32' ne $OSNAME) ; |
| 9534 | # Windows |
| 9535 | # "type" command does not accept redirection of STDIN with < |
| 9536 | # "sort" does |
| 9537 | |
| 9538 | } ; |
| 9539 | |
| 9540 | SKIP: { |
| 9541 | Readonly my $NB_UNX_tests_message_for_host2 => 6 ; |
| 9542 | skip( 'Not on Unix', $NB_UNX_tests_message_for_host2 ) if ('MSWin32' eq $OSNAME) ; |
| 9543 | # Unix |
| 9544 | |
| 9545 | # no change by cat |
| 9546 | @pipemess = ( 'cat' ) ; |
| 9547 | is( 9, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), |
| 9548 | q{message_for_host2: --pipemess 'cat', length} ) ; |
| 9549 | is( 'blablabla', $string, q{message_for_host2: --pipemess 'cat', value} ) ; |
| 9550 | |
| 9551 | |
| 9552 | # failure by false |
| 9553 | @pipemess = ( 'false' ) ; |
| 9554 | is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), |
| 9555 | q{message_for_host2: --pipemess 'false', length} ) ; |
| 9556 | is( undef, $string, q{message_for_host2: --pipemess 'false', value} ) ; |
| 9557 | |
| 9558 | # failure by true since no output |
| 9559 | @pipemess = ( 'true' ) ; |
| 9560 | is( undef, message_for_host2( $mysync, $h1_msg, $h1_fold, $h1_size, $h1_flags, $h1_idate, $h1_fir_ref, $string_ref ), |
| 9561 | q{message_for_host2: --pipemess 'true', length} ) ; |
| 9562 | is( undef, $string, q{message_for_host2: --pipemess 'true', value} ) ; |
| 9563 | } |
| 9564 | |
| 9565 | note( 'Leaving tests_message_for_host2()' ) ; |
| 9566 | return ; |
| 9567 | } |
| 9568 | |
| 9569 | sub tests_labels_remove_subfolder1 |
| 9570 | { |
| 9571 | note( 'Entering tests_labels_remove_subfolder1()' ) ; |
| 9572 | is( undef, labels_remove_subfolder1( ), 'labels_remove_subfolder1: no parameters => undef' ) ; |
| 9573 | is( 'Blabla', labels_remove_subfolder1( 'Blabla' ), 'labels_remove_subfolder1: one parameter Blabla => Blabla' ) ; |
| 9574 | is( 'Blan blue', labels_remove_subfolder1( 'Blan blue' ), 'labels_remove_subfolder1: one parameter Blan blue => Blan blue' ) ; |
| 9575 | is( '\Bla "Blan blan" Blabla', labels_remove_subfolder1( '\Bla "Blan blan" Blabla' ), |
| 9576 | 'labels_remove_subfolder1: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ; |
| 9577 | |
| 9578 | is( 'Bla', labels_remove_subfolder1( 'Subf/Bla', 'Subf' ), 'labels_remove_subfolder1: Subf/Bla Subf => "Bla"' ) ; |
| 9579 | |
| 9580 | |
| 9581 | is( '"\\\\Bla"', labels_remove_subfolder1( '"\\\\Bla"', 'Subf' ), 'labels_remove_subfolder1: "\\\\Bla" Subf => "\\\\Bla"' ) ; |
| 9582 | |
| 9583 | is( 'Bla Kii', labels_remove_subfolder1( 'Subf/Bla Subf/Kii', 'Subf' ), |
| 9584 | 'labels_remove_subfolder1: Subf/Bla Subf/Kii, Subf => "Bla" "Kii"' ) ; |
| 9585 | |
| 9586 | is( '"\\\\Bla" Kii', labels_remove_subfolder1( '"\\\\Bla" Subf/Kii', 'Subf' ), |
| 9587 | 'labels_remove_subfolder1: "\\\\Bla" Subf/Kii Subf => "\\\\Bla" Kii' ) ; |
| 9588 | |
| 9589 | is( '"Blan blan"', labels_remove_subfolder1( '"Subf/Blan blan"', 'Subf' ), |
| 9590 | 'labels_remove_subfolder1: "Subf/Blan blan" Subf => "Blan blan"' ) ; |
| 9591 | |
| 9592 | is( '"\\\\Loo" "Blan blan" Kii', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii', 'Subf' ), |
| 9593 | 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii + Subf => "\\\\Loo" "Blan blan" Kii' ) ; |
| 9594 | |
| 9595 | is( '"\\\\Inbox"', labels_remove_subfolder1( 'Subf/INBOX', 'Subf' ), |
| 9596 | 'labels_remove_subfolder1: Subf/INBOX + Subf => "\\\\Inbox"' ) ; |
| 9597 | |
| 9598 | is( '"\\\\Loo" "Blan blan" Kii "\\\\Inbox"', labels_remove_subfolder1( '"\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX', 'Subf' ), |
| 9599 | 'labels_remove_subfolder1: "\\\\Loo" "Subf/Blan blan" Subf/Kii Subf/INBOX + Subf => "\\\\Loo" "Blan blan" Kii "\\\\Inbox"' ) ; |
| 9600 | |
| 9601 | |
| 9602 | note( 'Leaving tests_labels_remove_subfolder1()' ) ; |
| 9603 | return ; |
| 9604 | } |
| 9605 | |
| 9606 | |
| 9607 | |
| 9608 | sub labels_remove_subfolder1 |
| 9609 | { |
| 9610 | my $labels = shift ; |
| 9611 | my $subfolder1 = shift ; |
| 9612 | |
| 9613 | if ( not defined $labels ) { return ; } |
| 9614 | if ( not defined $subfolder1 ) { return $labels ; } |
| 9615 | |
| 9616 | my @labels = quotewords('\s+', 1, $labels ) ; |
| 9617 | #myprint( "@labels\n" ) ; |
| 9618 | my @labels_subfolder2 ; |
| 9619 | |
| 9620 | foreach my $label ( @labels ) |
| 9621 | { |
| 9622 | if ( $label =~ m{zzzzzzzzzz} ) |
| 9623 | { |
| 9624 | # \Seen \Deleted ... stay the same |
| 9625 | push @labels_subfolder2, $label ; |
| 9626 | } |
| 9627 | else |
| 9628 | { |
| 9629 | # Remove surrounding quotes if any, to add them again in case of space |
| 9630 | $label = join( q{}, quotewords('\s+', 0, $label ) ) ; |
| 9631 | $label =~ s{$subfolder1/?}{} ; |
| 9632 | if ( 'INBOX' eq $label ) |
| 9633 | { |
| 9634 | push @labels_subfolder2, q{"\\\\Inbox"} ; |
| 9635 | } |
| 9636 | elsif ( $label =~ m{\\} ) |
| 9637 | { |
| 9638 | push @labels_subfolder2, qq{"\\$label"} ; |
| 9639 | } |
| 9640 | elsif ( $label =~ m{ } ) |
| 9641 | { |
| 9642 | push @labels_subfolder2, qq{"$label"} ; |
| 9643 | } |
| 9644 | else |
| 9645 | { |
| 9646 | push @labels_subfolder2, $label ; |
| 9647 | } |
| 9648 | } |
| 9649 | } |
| 9650 | |
| 9651 | my $labels_subfolder2 = join( ' ', sort uniq( @labels_subfolder2 ) ) ; |
| 9652 | |
| 9653 | return $labels_subfolder2 ; |
| 9654 | } |
| 9655 | |
| 9656 | sub tests_labels_remove_special |
| 9657 | { |
| 9658 | note( 'Entering tests_labels_remove_special()' ) ; |
| 9659 | |
| 9660 | is( undef, labels_remove_special( ), 'labels_remove_special: no parameters => undef' ) ; |
| 9661 | is( q{}, labels_remove_special( q{} ), 'labels_remove_special: empty string => empty string' ) ; |
| 9662 | is( q{}, labels_remove_special( '"\\\\Inbox"' ), 'labels_remove_special:"\\\\Inbox" => empty string' ) ; |
| 9663 | is( q{}, labels_remove_special( '"\\\\Inbox" "\\\\Starred"' ), 'labels_remove_special:"\\\\Inbox" "\\\\Starred" => empty string' ) ; |
| 9664 | is( 'Bar Foo', labels_remove_special( 'Foo Bar' ), 'labels_remove_special:Foo Bar => Bar Foo' ) ; |
| 9665 | is( 'Bar Foo', labels_remove_special( 'Foo Bar "\\\\Inbox"' ), 'labels_remove_special:Foo Bar "\\\\Inbox" => Bar Foo' ) ; |
| 9666 | note( 'Leaving tests_labels_remove_special()' ) ; |
| 9667 | return ; |
| 9668 | } |
| 9669 | |
| 9670 | |
| 9671 | |
| 9672 | |
| 9673 | sub labels_remove_special |
| 9674 | { |
| 9675 | my $labels = shift ; |
| 9676 | |
| 9677 | if ( not defined $labels ) { return ; } |
| 9678 | |
| 9679 | my @labels = quotewords('\s+', 1, $labels ) ; |
| 9680 | myprint( "labels before remove_non_folded: @labels\n" ) ; |
| 9681 | my @labels_remove_special ; |
| 9682 | |
| 9683 | foreach my $label ( @labels ) |
| 9684 | { |
| 9685 | if ( $label =~ m{^\"\\\\} ) |
| 9686 | { |
| 9687 | # not kept |
| 9688 | } |
| 9689 | else |
| 9690 | { |
| 9691 | push @labels_remove_special, $label ; |
| 9692 | } |
| 9693 | } |
| 9694 | |
| 9695 | my $labels_remove_special = join( ' ', sort @labels_remove_special ) ; |
| 9696 | |
| 9697 | return $labels_remove_special ; |
| 9698 | } |
| 9699 | |
| 9700 | |
| 9701 | sub tests_labels_add_subfolder2 |
| 9702 | { |
| 9703 | note( 'Entering tests_labels_add_subfolder2()' ) ; |
| 9704 | is( undef, labels_add_subfolder2( ), 'labels_add_subfolder2: no parameters => undef' ) ; |
| 9705 | is( 'Blabla', labels_add_subfolder2( 'Blabla' ), 'labels_add_subfolder2: one parameter Blabla => Blabla' ) ; |
| 9706 | is( 'Blan blue', labels_add_subfolder2( 'Blan blue' ), 'labels_add_subfolder2: one parameter Blan blue => Blan blue' ) ; |
| 9707 | is( '\Bla "Blan blan" Blabla', labels_add_subfolder2( '\Bla "Blan blan" Blabla' ), |
| 9708 | 'labels_add_subfolder2: one parameter \Bla "Blan blan" Blabla => \Bla "Blan blan" Blabla' ) ; |
| 9709 | |
| 9710 | is( 'Subf/Bla', labels_add_subfolder2( 'Bla', 'Subf' ), 'labels_add_subfolder2: Bla Subf => "Subf/Bla"' ) ; |
| 9711 | |
| 9712 | |
| 9713 | is( 'Subf/\Bla', labels_add_subfolder2( '\\\\Bla', 'Subf' ), 'labels_add_subfolder2: \Bla Subf => \Bla' ) ; |
| 9714 | |
| 9715 | is( 'Subf/Bla Subf/Kii', labels_add_subfolder2( 'Bla Kii', 'Subf' ), |
| 9716 | 'labels_add_subfolder2: Bla Kii Subf => "Subf/Bla" "Subf/Kii"' ) ; |
| 9717 | |
| 9718 | is( 'Subf/Kii Subf/\Bla', labels_add_subfolder2( '\\\\Bla Kii', 'Subf' ), |
| 9719 | 'labels_add_subfolder2: \Bla Kii Subf => \Bla Subf/Kii' ) ; |
| 9720 | |
| 9721 | is( '"Subf/Blan blan"', labels_add_subfolder2( '"Blan blan"', 'Subf' ), |
| 9722 | 'labels_add_subfolder2: "Blan blan" Subf => "Subf/Blan blan"' ) ; |
| 9723 | |
| 9724 | is( '"Subf/Blan blan" Subf/Kii Subf/\Loo', labels_add_subfolder2( '\\\\Loo "Blan blan" Kii', 'Subf' ), |
| 9725 | 'labels_add_subfolder2: \Loo "Blan blan" Kii + Subf => "Subf/Blan blan" Subf/Kii Subf/\Loo' ) ; |
| 9726 | |
| 9727 | # "\\Inbox" is special, add to subfolder INBOX also because Gmail will but ... |
| 9728 | is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox"', 'Subf' ), |
| 9729 | 'labels_add_subfolder2: "\\\\Inbox" Subf => "Subf/\\\\Inbox" Subf/INBOX' ) ; |
| 9730 | |
| 9731 | # but not with INBOX folder |
| 9732 | is( '"Subf/\\\\Inbox"', labels_add_subfolder2( '"\\\\Inbox"', 'Subf', 'INBOX' ), |
| 9733 | 'labels_add_subfolder2: "\\\\Inbox" Subf INBOX => "Subf/\\\\Inbox"' ) ; |
| 9734 | |
| 9735 | # two times => one time |
| 9736 | is( '"Subf/\\\\Inbox" Subf/INBOX', labels_add_subfolder2( '"\\\\Inbox" "\\\\Inbox"', 'Subf' ), |
| 9737 | 'labels_add_subfolder2: "\\\\Inbox" "\\\\Inbox" Subf => "Subf/\\\\Inbox"' ) ; |
| 9738 | |
| 9739 | is( '"Subf/\\\\Starred"', labels_add_subfolder2( '"\\\\Starred"', 'Subf' ), |
| 9740 | 'labels_add_subfolder2: "\\\\Starred" Subf => "Subf/\\\\Starred"' ) ; |
| 9741 | |
| 9742 | note( 'Leaving tests_labels_add_subfolder2()' ) ; |
| 9743 | return ; |
| 9744 | } |
| 9745 | |
| 9746 | sub labels_add_subfolder2 |
| 9747 | { |
| 9748 | my $labels = shift ; |
| 9749 | my $subfolder2 = shift ; |
| 9750 | my $h1_folder = shift || q{} ; |
| 9751 | |
| 9752 | if ( not defined $labels ) { return ; } |
| 9753 | if ( not defined $subfolder2 ) { return $labels ; } |
| 9754 | |
| 9755 | # Isn't it messy? |
| 9756 | if ( 'INBOX' eq $h1_folder ) |
| 9757 | { |
| 9758 | $labels .= ' "\\\\Inbox"' ; |
| 9759 | } |
| 9760 | |
| 9761 | my @labels = uniq( quotewords('\s+', 1, $labels ) ) ; |
| 9762 | myprint( "labels before subfolder2: @labels\n" ) ; |
| 9763 | my @labels_subfolder2 ; |
| 9764 | |
| 9765 | |
| 9766 | foreach my $label ( @labels ) |
| 9767 | { |
| 9768 | # Isn't it more messy? |
| 9769 | if ( ( q{"\\\\Inbox"} eq $label ) and ( 'INBOX' ne $h1_folder ) ) |
| 9770 | { |
| 9771 | if ( $subfolder2 =~ m{ } ) |
| 9772 | { |
| 9773 | push @labels_subfolder2, qq{"$subfolder2/INBOX"} ; |
| 9774 | } |
| 9775 | else |
| 9776 | { |
| 9777 | push @labels_subfolder2, "$subfolder2/INBOX" ; |
| 9778 | } |
| 9779 | } |
| 9780 | if ( $label =~ m{^\"\\\\} ) |
| 9781 | { |
| 9782 | # \Seen \Deleted ... stay the same |
| 9783 | #push @labels_subfolder2, $label ; |
| 9784 | # Remove surrounding quotes if any, to add them again |
| 9785 | $label = join( q{}, quotewords('\s+', 0, $label ) ) ; |
| 9786 | push @labels_subfolder2, qq{"$subfolder2/\\$label"} ; |
| 9787 | |
| 9788 | } |
| 9789 | else |
| 9790 | { |
| 9791 | # Remove surrounding quotes if any, to add them again in case of space |
| 9792 | $label = join( q{}, quotewords('\s+', 0, $label ) ) ; |
| 9793 | if ( $label =~ m{ } ) |
| 9794 | { |
| 9795 | push @labels_subfolder2, qq{"$subfolder2/$label"} ; |
| 9796 | } |
| 9797 | else |
| 9798 | { |
| 9799 | push @labels_subfolder2, "$subfolder2/$label" ; |
| 9800 | } |
| 9801 | } |
| 9802 | } |
| 9803 | |
| 9804 | my $labels_subfolder2 = join( ' ', sort @labels_subfolder2 ) ; |
| 9805 | |
| 9806 | return $labels_subfolder2 ; |
| 9807 | } |
| 9808 | |
| 9809 | sub tests_labels |
| 9810 | { |
| 9811 | note( 'Entering tests_labels()' ) ; |
| 9812 | |
| 9813 | is( undef, labels( ), 'labels: no parameters => undef' ) ; |
| 9814 | is( undef, labels( undef ), 'labels: undef => undef' ) ; |
| 9815 | require_ok( "Test::MockObject" ) ; |
| 9816 | my $myimap = Test::MockObject->new( ) ; |
| 9817 | |
| 9818 | $myimap->mock( 'fetch_hash', |
| 9819 | sub { |
| 9820 | return( |
| 9821 | { '1' => { |
| 9822 | 'X-GM-LABELS' => '\Seen Blabla' |
| 9823 | } |
| 9824 | } |
| 9825 | ) ; |
| 9826 | } |
| 9827 | ) ; |
| 9828 | $myimap->mock( 'Debug' , sub { } ) ; |
| 9829 | $myimap->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one |
| 9830 | |
| 9831 | is( undef, labels( $myimap ), 'labels: one parameter => undef' ) ; |
| 9832 | is( '\Seen Blabla', labels( $myimap, '1' ), 'labels: $mysync UID_1 => \Seen Blabla' ) ; |
| 9833 | |
| 9834 | note( 'Leaving tests_labels()' ) ; |
| 9835 | return ; |
| 9836 | } |
| 9837 | |
| 9838 | sub labels |
| 9839 | { |
| 9840 | my ( $myimap, $uid ) = @ARG ; |
| 9841 | |
| 9842 | if ( not all_defined( $myimap, $uid ) ) { |
| 9843 | return ; |
| 9844 | } |
| 9845 | |
| 9846 | my $hash = $myimap->fetch_hash( [ $uid ], 'X-GM-LABELS' ) ; |
| 9847 | |
| 9848 | my $labels = $hash->{ $uid }->{ 'X-GM-LABELS' } ; |
| 9849 | #$labels = $myimap->Unescape( $labels ) ; |
| 9850 | return $labels ; |
| 9851 | } |
| 9852 | |
| 9853 | sub tests_synclabels |
| 9854 | { |
| 9855 | note( 'Entering tests_synclabels()' ) ; |
| 9856 | |
| 9857 | is( undef, synclabels( ), 'synclabels: no parameters => undef' ) ; |
| 9858 | is( undef, synclabels( undef ), 'synclabels: undef => undef' ) ; |
| 9859 | my $mysync ; |
| 9860 | is( undef, synclabels( $mysync ), 'synclabels: var undef => undef' ) ; |
| 9861 | |
| 9862 | require_ok( "Test::MockObject" ) ; |
| 9863 | $mysync = {} ; |
| 9864 | |
| 9865 | my $myimap1 = Test::MockObject->new( ) ; |
| 9866 | $myimap1->mock( 'fetch_hash', |
| 9867 | sub { |
| 9868 | return( |
| 9869 | { '1' => { |
| 9870 | 'X-GM-LABELS' => '\Seen Blabla' |
| 9871 | } |
| 9872 | } |
| 9873 | ) ; |
| 9874 | } |
| 9875 | ) ; |
| 9876 | $myimap1->mock( 'Debug', sub { } ) ; |
| 9877 | $myimap1->mock( 'Unescape', sub { return Mail::IMAPClient::Unescape( @_ ) } ) ; # real one |
| 9878 | |
| 9879 | my $myimap2 = Test::MockObject->new( ) ; |
| 9880 | |
| 9881 | $myimap2->mock( 'store', |
| 9882 | sub { |
| 9883 | return 1 ; |
| 9884 | } |
| 9885 | ) ; |
| 9886 | |
| 9887 | |
| 9888 | $mysync->{imap1} = $myimap1 ; |
| 9889 | $mysync->{imap2} = $myimap2 ; |
| 9890 | |
| 9891 | is( undef, synclabels( $mysync ), 'synclabels: fresh $mysync => undef' ) ; |
| 9892 | |
| 9893 | is( undef, synclabels( $mysync, '1' ), 'synclabels: $mysync UID_1 alone => undef' ) ; |
| 9894 | is( 1, synclabels( $mysync, '1', '2' ), 'synclabels: $mysync UID_1 UID_2 => 1' ) ; |
| 9895 | |
| 9896 | note( 'Leaving tests_synclabels()' ) ; |
| 9897 | return ; |
| 9898 | } |
| 9899 | |
| 9900 | |
| 9901 | sub synclabels |
| 9902 | { |
| 9903 | my( $mysync, $uid1, $uid2 ) = @ARG ; |
| 9904 | |
| 9905 | if ( not all_defined( $mysync, $uid1, $uid2 ) ) { |
| 9906 | return ; |
| 9907 | } |
| 9908 | my $myimap1 = $mysync->{ 'imap1' } || return ; |
| 9909 | my $myimap2 = $mysync->{ 'imap2' } || return ; |
| 9910 | |
| 9911 | $mysync->{debuglabels} and $myimap1->Debug( 1 ) ; |
| 9912 | my $labels1 = labels( $myimap1, $uid1 ) ; |
| 9913 | $mysync->{debuglabels} and $myimap1->Debug( 0 ) ; |
| 9914 | $mysync->{debuglabels} and myprint( "Host1 labels: $labels1\n" ) ; |
| 9915 | |
| 9916 | |
| 9917 | |
| 9918 | if ( $mysync->{ subfolder1 } and $labels1 ) |
| 9919 | { |
| 9920 | $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ; |
| 9921 | $mysync->{debuglabels} and myprint( "Host1 labels with subfolder1: $labels1\n" ) ; |
| 9922 | } |
| 9923 | |
| 9924 | if ( $mysync->{ subfolder2 } and $labels1 ) |
| 9925 | { |
| 9926 | $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 } ) ; |
| 9927 | $mysync->{debuglabels} and myprint( "Host1 labels with subfolder2: $labels1\n" ) ; |
| 9928 | } |
| 9929 | |
| 9930 | my $store ; |
| 9931 | if ( $labels1 and not $mysync->{ dry } ) |
| 9932 | { |
| 9933 | $mysync->{ debuglabels } and $myimap2->Debug( 1 ) ; |
| 9934 | $store = $myimap2->store( $uid2, "X-GM-LABELS ($labels1)" ) ; |
| 9935 | $mysync->{ debuglabels } and $myimap2->Debug( 0 ) ; |
| 9936 | } |
| 9937 | return $store ; |
| 9938 | } |
| 9939 | |
| 9940 | |
| 9941 | sub tests_resynclabels |
| 9942 | { |
| 9943 | note( 'Entering tests_resynclabels()' ) ; |
| 9944 | |
| 9945 | is( undef, resynclabels( ), 'resynclabels: no parameters => undef' ) ; |
| 9946 | is( undef, resynclabels( undef ), 'resynclabels: undef => undef' ) ; |
| 9947 | my $mysync ; |
| 9948 | is( undef, resynclabels( $mysync ), 'resynclabels: var undef => undef' ) ; |
| 9949 | |
| 9950 | my ( $h1_fir_ref, $h2_fir_ref ) ; |
| 9951 | |
| 9952 | $mysync->{ debuglabels } = 1 ; |
| 9953 | $h1_fir_ref->{ 11 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ; |
| 9954 | $h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Baa Kii' ; |
| 9955 | |
| 9956 | # labels are equal |
| 9957 | is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ), |
| 9958 | 'resynclabels: $mysync UID_1 UID_2 labels are equal => 1' ) ; |
| 9959 | |
| 9960 | # labels are different |
| 9961 | $h2_fir_ref->{ 22 }->{ 'X-GM-LABELS' } = '\Seen Zuu' ; |
| 9962 | require_ok( "Test::MockObject" ) ; |
| 9963 | my $myimap2 = Test::MockObject->new( ) ; |
| 9964 | $myimap2->mock( 'store', |
| 9965 | sub { |
| 9966 | return 1 ; |
| 9967 | } |
| 9968 | ) ; |
| 9969 | $myimap2->mock( 'Debug', sub { } ) ; |
| 9970 | $mysync->{imap2} = $myimap2 ; |
| 9971 | |
| 9972 | is( 1, resynclabels( $mysync, 11, 22, $h1_fir_ref, $h2_fir_ref ), |
| 9973 | 'resynclabels: $mysync UID_1 UID_2 labels are not equal => store => 1' ) ; |
| 9974 | |
| 9975 | note( 'Leaving tests_resynclabels()' ) ; |
| 9976 | return ; |
| 9977 | } |
| 9978 | |
| 9979 | |
| 9980 | |
| 9981 | sub resynclabels |
| 9982 | { |
| 9983 | my( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref, $h1_folder ) = @ARG ; |
| 9984 | |
| 9985 | if ( not all_defined( $mysync, $uid1, $uid2, $h1_fir_ref, $h2_fir_ref ) ) { |
| 9986 | return ; |
| 9987 | } |
| 9988 | |
| 9989 | my $labels1 = $h1_fir_ref->{ $uid1 }->{ 'X-GM-LABELS' } || q{} ; |
| 9990 | my $labels2 = $h2_fir_ref->{ $uid2 }->{ 'X-GM-LABELS' } || q{} ; |
| 9991 | |
| 9992 | if ( $mysync->{ subfolder1 } and $labels1 ) |
| 9993 | { |
| 9994 | $labels1 = labels_remove_subfolder1( $labels1, $mysync->{ subfolder1 } ) ; |
| 9995 | } |
| 9996 | |
| 9997 | if ( $mysync->{ subfolder2 } and $labels1 ) |
| 9998 | { |
| 9999 | $labels1 = labels_add_subfolder2( $labels1, $mysync->{ subfolder2 }, $h1_folder ) ; |
| 10000 | $labels2 = labels_remove_special( $labels2 ) ; |
| 10001 | } |
| 10002 | $mysync->{ debuglabels } and myprint( "Host1 labels fixed: $labels1\n" ) ; |
| 10003 | $mysync->{ debuglabels } and myprint( "Host2 labels : $labels2\n" ) ; |
| 10004 | |
| 10005 | my $store ; |
| 10006 | if ( $labels1 eq $labels2 ) |
| 10007 | { |
| 10008 | # no sync needed |
| 10009 | $mysync->{ debuglabels } and myprint( "Labels are already equal\n" ) ; |
| 10010 | return 1 ; |
| 10011 | } |
| 10012 | elsif ( not $mysync->{ dry } ) |
| 10013 | { |
| 10014 | # sync needed |
| 10015 | $mysync->{debuglabels} and $mysync->{imap2}->Debug( 1 ) ; |
| 10016 | $store = $mysync->{imap2}->store( $uid2, "X-GM-LABELS ($labels1)" ) ; |
| 10017 | $mysync->{debuglabels} and $mysync->{imap2}->Debug( 0 ) ; |
| 10018 | } |
| 10019 | |
| 10020 | return $store ; |
| 10021 | } |
| 10022 | |
| 10023 | sub tests_uniq |
| 10024 | { |
| 10025 | note( 'Entering tests_uniq()' ) ; |
| 10026 | |
| 10027 | is( 0, uniq( ), 'uniq: undef => 0' ) ; |
| 10028 | is_deeply( [ 'one' ], [ uniq( 'one' ) ], 'uniq: one => one' ) ; |
| 10029 | is_deeply( [ 'one' ], [ uniq( 'one', 'one' ) ], 'uniq: one one => one' ) ; |
| 10030 | is_deeply( [ 'one', 'two' ], [ uniq( 'one', 'one', 'two', 'one', 'two' ) ], 'uniq: one one two one two => one two' ) ; |
| 10031 | note( 'Leaving tests_uniq()' ) ; |
| 10032 | return ; |
| 10033 | } |
| 10034 | |
| 10035 | sub uniq |
| 10036 | { |
| 10037 | my @list = @ARG ; |
| 10038 | my %seen = ( ) ; |
| 10039 | my @uniq = ( ) ; |
| 10040 | foreach my $item ( @list ) { |
| 10041 | if ( ! $seen{ $item } ) { |
| 10042 | $seen{ $item } = 1 ; |
| 10043 | push( @uniq, $item ) ; |
| 10044 | } |
| 10045 | } |
| 10046 | return @uniq ; |
| 10047 | } |
| 10048 | |
| 10049 | |
| 10050 | sub length_ref |
| 10051 | { |
| 10052 | my $string_ref = shift ; |
| 10053 | my $string_len = defined ${ $string_ref } ? length( ${ $string_ref } ) : q{} ; # length or empty string |
| 10054 | return $string_len ; |
| 10055 | } |
| 10056 | |
| 10057 | sub tests_length_ref |
| 10058 | { |
| 10059 | note( 'Entering tests_length_ref()' ) ; |
| 10060 | |
| 10061 | my $notdefined ; |
| 10062 | is( q{}, length_ref( \$notdefined ), q{length_ref: value not defined} ) ; |
| 10063 | my $notref ; |
| 10064 | is( q{}, length_ref( $notref ), q{length_ref: param not a ref} ) ; |
| 10065 | |
| 10066 | my $lala = 'lala' ; |
| 10067 | is( 4, length_ref( \$lala ), q{length_ref: lala length == 4} ) ; |
| 10068 | is( 4, length_ref( \'lili' ), q{length_ref: lili length == 4} ) ; |
| 10069 | |
| 10070 | note( 'Leaving tests_length_ref()' ) ; |
| 10071 | return ; |
| 10072 | } |
| 10073 | |
| 10074 | sub date_for_host2 |
| 10075 | { |
| 10076 | my( $h1_msg, $h1_idate ) = @_ ; |
| 10077 | |
| 10078 | my $h1_date = q{} ; |
| 10079 | |
| 10080 | if ( $syncinternaldates ) { |
| 10081 | $h1_date = $h1_idate ; |
| 10082 | $sync->{ debug } and myprint( "internal date from host1: [$h1_date]\n" ) ; |
| 10083 | $h1_date = good_date( $h1_date ) ; |
| 10084 | $sync->{ debug } and myprint( "internal date from host1: [$h1_date] (fixed)\n" ) ; |
| 10085 | } |
| 10086 | |
| 10087 | if ( $idatefromheader ) { |
| 10088 | $h1_date = $sync->{imap1}->get_header( $h1_msg, 'Date' ) ; |
| 10089 | $sync->{ debug } and myprint( "header date from host1: [$h1_date]\n" ) ; |
| 10090 | $h1_date = good_date( $h1_date ) ; |
| 10091 | $sync->{ debug } and myprint( "header date from host1: [$h1_date] (fixed)\n" ) ; |
| 10092 | } |
| 10093 | |
| 10094 | return( $h1_date ) ; |
| 10095 | } |
| 10096 | |
| 10097 | sub flags_for_host2 |
| 10098 | { |
| 10099 | my( $h1_flags, $permanentflags2 ) = @_ ; |
| 10100 | # RFC 2060: This flag can not be altered by any client |
| 10101 | $h1_flags =~ s@\\Recent\s?@@xgi ; |
| 10102 | my $h1_flags_re ; |
| 10103 | if ( @regexflag and defined( $h1_flags_re = flags_regex( $h1_flags ) ) ) { |
| 10104 | $h1_flags = $h1_flags_re ; |
| 10105 | } |
| 10106 | $h1_flags = flagscase( $h1_flags ) if $flagscase ; |
| 10107 | $h1_flags = flags_filter( $h1_flags, $permanentflags2) if ( $permanentflags2 and $filterflags ) ; |
| 10108 | |
| 10109 | return( $h1_flags ) ; |
| 10110 | } |
| 10111 | |
| 10112 | sub subject |
| 10113 | { |
| 10114 | my $string = shift ; |
| 10115 | my $subject = q{} ; |
| 10116 | |
| 10117 | my $header = extract_header( $string ) ; |
| 10118 | |
| 10119 | if( $header =~ m/^Subject:\s*([^\n\r]*)\r?$/msx ) { |
| 10120 | #myprint( "MMM[$1]\n" ) ; |
| 10121 | $subject = $1 ; |
| 10122 | } |
| 10123 | return( $subject ) ; |
| 10124 | } |
| 10125 | |
| 10126 | sub tests_subject |
| 10127 | { |
| 10128 | note( 'Entering tests_subject()' ) ; |
| 10129 | |
| 10130 | ok( q{} eq subject( q{} ), 'subject: null') ; |
| 10131 | ok( 'toto le hero' eq subject( 'Subject: toto le hero' ), 'subject: toto le hero') ; |
| 10132 | ok( 'toto le hero' eq subject( 'Subject:toto le hero' ), 'subject: toto le hero blank') ; |
| 10133 | ok( 'toto le hero' eq subject( "Subject:toto le hero\r\n" ), 'subject: toto le hero\r\n') ; |
| 10134 | |
| 10135 | my $MESS ; |
| 10136 | $MESS = <<'EOF'; |
| 10137 | From: lalala |
| 10138 | Subject: toto le hero |
| 10139 | Date: zzzzzz |
| 10140 | |
| 10141 | Boogie boogie |
| 10142 | EOF |
| 10143 | ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 2') ; |
| 10144 | |
| 10145 | $MESS = <<'EOF'; |
| 10146 | Subject: toto le hero |
| 10147 | From: lalala |
| 10148 | Date: zzzzzz |
| 10149 | |
| 10150 | Boogie boogie |
| 10151 | EOF |
| 10152 | ok( 'toto le hero' eq subject( $MESS ), 'subject: toto le hero 3') ; |
| 10153 | |
| 10154 | |
| 10155 | $MESS = <<'EOF'; |
| 10156 | From: lalala |
| 10157 | Subject: cuicui |
| 10158 | Date: zzzzzz |
| 10159 | |
| 10160 | Subject: toto le hero |
| 10161 | EOF |
| 10162 | ok( 'cuicui' eq subject( $MESS ), 'subject: cuicui') ; |
| 10163 | |
| 10164 | $MESS = <<'EOF'; |
| 10165 | From: lalala |
| 10166 | Date: zzzzzz |
| 10167 | |
| 10168 | Subject: toto le hero |
| 10169 | EOF |
| 10170 | ok( q{} eq subject( $MESS ), 'subject: null but body could') ; |
| 10171 | |
| 10172 | note( 'Leaving tests_subject()' ) ; |
| 10173 | return ; |
| 10174 | } |
| 10175 | |
| 10176 | |
| 10177 | # GlobVar |
| 10178 | # $max_msg_size_in_bytes |
| 10179 | # $h2_uidguess |
| 10180 | # ... |
| 10181 | # |
| 10182 | # |
| 10183 | sub append_message_on_host2 |
| 10184 | { |
| 10185 | my( $mysync, $string_ref, $h1_fold, $h1_msg, $string_len, $h2_fold, $h1_size, $h1_flags, $h1_date, $cache_dir ) = @_ ; |
| 10186 | myprint( debugmemory( $mysync, " at A1" ) ) ; |
| 10187 | |
| 10188 | my $new_id ; |
| 10189 | if ( ! $mysync->{dry} ) { |
| 10190 | $max_msg_size_in_bytes = max( $string_len, $max_msg_size_in_bytes ) ; |
| 10191 | $new_id = $mysync->{imap2}->append_string( $h2_fold, ${ $string_ref }, $h1_flags, $h1_date ) ; |
| 10192 | myprint( debugmemory( $mysync, " at A2" ) ) ; |
| 10193 | if ( ! $new_id){ |
| 10194 | my $subject = subject( ${ $string_ref } ) ; |
| 10195 | my $error_imap = $mysync->{imap2}->LastError || q{} ; |
| 10196 | my $error = "- msg $h1_fold/$h1_msg {$string_len} could not append ( Subject:[$subject], Date:[$h1_date], Size:[$h1_size], Flags:[$h1_flags] ) to folder $h2_fold: $error_imap\n" ; |
| 10197 | errors_incr( $mysync, $error ) ; |
| 10198 | $mysync->{ h1_nb_msg_processed } +=1 ; |
| 10199 | return ; |
| 10200 | } |
| 10201 | else{ |
| 10202 | # good |
| 10203 | # $new_id is an id if the IMAP server has the |
| 10204 | # UIDPLUS capability else just a ref |
| 10205 | if ( $new_id !~ m{^\d+$}x ) { |
| 10206 | $new_id = lastuid( $mysync->{imap2}, $h2_fold, $h2_uidguess ) ; |
| 10207 | } |
| 10208 | if ( $mysync->{ synclabels } ) { synclabels( $mysync, $h1_msg, $new_id ) } |
| 10209 | $h2_uidguess += 1 ; |
| 10210 | $mysync->{ total_bytes_transferred } += $string_len ; |
| 10211 | $mysync->{ nb_msg_transferred } += 1 ; |
| 10212 | $mysync->{ h1_nb_msg_processed } +=1 ; |
| 10213 | |
| 10214 | my $time_spent = timesince( $mysync->{begin_transfer_time} ) ; |
| 10215 | my $rate = bytes_display_string( $mysync->{total_bytes_transferred} / $time_spent ) ; |
| 10216 | my $eta = eta( $mysync ) ; |
| 10217 | my $amount_transferred = bytes_display_string( $mysync->{total_bytes_transferred} ) ; |
| 10218 | myprintf( "msg %s/%-19s copied to %s/%-10s %.2f msgs/s %s/s %s copied %s\n", |
| 10219 | $h1_fold, "$h1_msg {$string_len}", $h2_fold, $new_id, $mysync->{nb_msg_transferred}/$time_spent, $rate, |
| 10220 | $amount_transferred, |
| 10221 | $eta ); |
| 10222 | sleep_if_needed( $mysync ) ; |
| 10223 | if ( $usecache and $cacheaftercopy and $new_id =~ m{^\d+$}x ) { |
| 10224 | $debugcache and myprint( "touch $cache_dir/${h1_msg}_$new_id\n" ) ; |
| 10225 | touch( "$cache_dir/${h1_msg}_$new_id" ) |
| 10226 | or croak( "Couldn't touch $cache_dir/${h1_msg}_$new_id" ) ; |
| 10227 | } |
| 10228 | if ( $mysync->{ delete1 } ) { |
| 10229 | delete_message_on_host1( $mysync, $h1_fold, $mysync->{ expungeaftereach }, $h1_msg ) ; |
| 10230 | } |
| 10231 | #myprint( "PRESS ENTER" ) and my $a = <> ; |
| 10232 | |
| 10233 | return( $new_id ) ; |
| 10234 | } |
| 10235 | } |
| 10236 | else{ |
| 10237 | $nb_msg_skipped_dry_mode += 1 ; |
| 10238 | $mysync->{ h1_nb_msg_processed } += 1 ; |
| 10239 | } |
| 10240 | |
| 10241 | return ; |
| 10242 | } |
| 10243 | |
| 10244 | |
| 10245 | sub tests_sleep_if_needed |
| 10246 | { |
| 10247 | note( 'Entering tests_sleep_if_needed()' ) ; |
| 10248 | |
| 10249 | is( undef, sleep_if_needed( ), 'sleep_if_needed: no args => undef' ) ; |
| 10250 | my $mysync ; |
| 10251 | is( undef, sleep_if_needed( $mysync ), 'sleep_if_needed: arg undef => undef' ) ; |
| 10252 | |
| 10253 | $mysync->{maxbytespersecond} = 1000 ; |
| 10254 | is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytespersecond only => no sleep => 0' ) ; |
| 10255 | $mysync->{begin_transfer_time} = time ; # now |
| 10256 | is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: begin_transfer_time now => no sleep => 0' ) ; |
| 10257 | $mysync->{begin_transfer_time} = time - 2 ; # 2 s before |
| 10258 | is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 0 => no sleep => 0' ) ; |
| 10259 | |
| 10260 | $mysync->{total_bytes_transferred} = 2200 ; |
| 10261 | $mysync->{begin_transfer_time} = time - 2 ; # 2 s before |
| 10262 | is( '0.20', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2s => sleep 0.2s' ) ; |
| 10263 | is( '0', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 2200 since 2+2 == 4s => no sleep' ) ; |
| 10264 | |
| 10265 | $mysync->{maxsleep} = 0.1 ; |
| 10266 | $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again |
| 10267 | is( '0.10', sleep_if_needed( $mysync ), 'sleep_if_needed: total_bytes_transferred == 4000 since 2s but maxsleep 0.1s => sleep 0.1s' ) ; |
| 10268 | |
| 10269 | $mysync->{maxbytesafter} = 4000 ; |
| 10270 | $mysync->{begin_transfer_time} = time - 2 ; # 2 s before again |
| 10271 | is( 0, sleep_if_needed( $mysync ), 'sleep_if_needed: maxbytesafter == total_bytes_transferred => no sleep => 0' ) ; |
| 10272 | |
| 10273 | note( 'Leaving tests_sleep_if_needed()' ) ; |
| 10274 | return ; |
| 10275 | } |
| 10276 | |
| 10277 | |
| 10278 | sub sleep_if_needed |
| 10279 | { |
| 10280 | my( $mysync ) = shift ; |
| 10281 | |
| 10282 | if ( ! $mysync ) { |
| 10283 | return ; |
| 10284 | } |
| 10285 | # No need to go further if there is no limit set |
| 10286 | if ( not ( $mysync->{maxmessagespersecond} |
| 10287 | or $mysync->{maxbytespersecond} ) |
| 10288 | ) { |
| 10289 | return ; |
| 10290 | } |
| 10291 | |
| 10292 | $mysync->{maxsleep} = defined $mysync->{maxsleep} ? $mysync->{maxsleep} : $MAX_SLEEP ; |
| 10293 | # Must be positive |
| 10294 | $mysync->{maxsleep} = max( 0, $mysync->{maxsleep} ) ; |
| 10295 | |
| 10296 | my $time_spent = timesince( $mysync->{begin_transfer_time} ) ; |
| 10297 | my $sleep_max_messages = sleep_max_messages( $mysync->{nb_msg_transferred}, $time_spent, $mysync->{maxmessagespersecond} ) ; |
| 10298 | |
| 10299 | my $maxbytesafter = $mysync->{maxbytesafter} || 0 ; |
| 10300 | my $total_bytes_transferred = $mysync->{total_bytes_transferred} || 0 ; |
| 10301 | my $total_bytes_to_consider = $total_bytes_transferred - $maxbytesafter ; |
| 10302 | |
| 10303 | #myprint( "maxbytesafter:$maxbytesafter\n" ) ; |
| 10304 | #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ; |
| 10305 | |
| 10306 | my $sleep_max_bytes = sleep_max_bytes( $total_bytes_to_consider, $time_spent, $mysync->{maxbytespersecond} ) ; |
| 10307 | my $sleep_max = min( $mysync->{maxsleep}, max( $sleep_max_messages, $sleep_max_bytes ) ) ; |
| 10308 | $sleep_max = mysprintf( "%.2f", $sleep_max ) ; # round with 2 decimals. |
| 10309 | if ( $sleep_max > 0 ) { |
| 10310 | myprint( "sleeping $sleep_max s\n" ) ; |
| 10311 | sleep $sleep_max ; |
| 10312 | # Slept |
| 10313 | return $sleep_max ; |
| 10314 | } |
| 10315 | # No sleep |
| 10316 | return 0 ; |
| 10317 | } |
| 10318 | |
| 10319 | sub sleep_max_messages |
| 10320 | { |
| 10321 | # how long we have to sleep to go under max_messages_per_second |
| 10322 | my( $nb_msg_transferred, $time_spent, $maxmessagespersecond ) = @_ ; |
| 10323 | if ( ( not defined $maxmessagespersecond ) or $maxmessagespersecond <= 0 ) { return( 0 ) } ; |
| 10324 | my $sleep = ( $nb_msg_transferred / $maxmessagespersecond ) - $time_spent ; |
| 10325 | # the sleep must be positive |
| 10326 | return( max( 0, $sleep ) ) ; |
| 10327 | } |
| 10328 | |
| 10329 | |
| 10330 | sub tests_sleep_max_messages |
| 10331 | { |
| 10332 | note( 'Entering tests_sleep_max_messages()' ) ; |
| 10333 | |
| 10334 | ok( 0 == sleep_max_messages( 4, 2, undef ), 'sleep_max_messages: maxmessagespersecond = undef') ; |
| 10335 | ok( 0 == sleep_max_messages( 4, 2, 0 ), 'sleep_max_messages: maxmessagespersecond = 0') ; |
| 10336 | ok( 0 == sleep_max_messages( 4, 2, $MINUS_ONE ), 'sleep_max_messages: maxmessagespersecond = -1') ; |
| 10337 | ok( 0 == sleep_max_messages( 4, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max reached') ; |
| 10338 | ok( 2 == sleep_max_messages( 8, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max over') ; |
| 10339 | ok( 0 == sleep_max_messages( 2, 2, 2 ), 'sleep_max_messages: maxmessagespersecond = 2 max not reached') ; |
| 10340 | |
| 10341 | note( 'Leaving tests_sleep_max_messages()' ) ; |
| 10342 | return ; |
| 10343 | } |
| 10344 | |
| 10345 | |
| 10346 | sub sleep_max_bytes |
| 10347 | { |
| 10348 | # how long we have to sleep to go under max_bytes_per_second |
| 10349 | my( $total_bytes_to_consider, $time_spent, $maxbytespersecond ) = @_ ; |
| 10350 | $total_bytes_to_consider ||= 0 ; |
| 10351 | $time_spent ||= 0 ; |
| 10352 | |
| 10353 | if ( ( not defined $maxbytespersecond ) or $maxbytespersecond <= 0 ) { return( 0 ) } ; |
| 10354 | #myprint( "total_bytes_to_consider:$total_bytes_to_consider\n" ) ; |
| 10355 | my $sleep = ( $total_bytes_to_consider / $maxbytespersecond ) - $time_spent ; |
| 10356 | # the sleep must be positive |
| 10357 | return( max( 0, $sleep ) ) ; |
| 10358 | } |
| 10359 | |
| 10360 | |
| 10361 | sub tests_sleep_max_bytes |
| 10362 | { |
| 10363 | note( 'Entering tests_sleep_max_bytes()' ) ; |
| 10364 | |
| 10365 | ok( 0 == sleep_max_bytes( 4000, 2, undef ), 'sleep_max_bytes: maxbytespersecond == undef => sleep 0' ) ; |
| 10366 | ok( 0 == sleep_max_bytes( 4000, 2, 0 ), 'sleep_max_bytes: maxbytespersecond = 0 => sleep 0') ; |
| 10367 | ok( 0 == sleep_max_bytes( 4000, 2, $MINUS_ONE ), 'sleep_max_bytes: maxbytespersecond = -1 => sleep 0') ; |
| 10368 | ok( 0 == sleep_max_bytes( 4000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max reached sharp => sleep 0') ; |
| 10369 | ok( 2 == sleep_max_bytes( 8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max over => sleep a little') ; |
| 10370 | ok( 0 == sleep_max_bytes( -8000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ; |
| 10371 | ok( 0 == sleep_max_bytes( 2000, 2, 2000 ), 'sleep_max_bytes: maxbytespersecond = 2k max not reached => sleep 0') ; |
| 10372 | ok( 0 == sleep_max_bytes( -2000, 2, 1000 ), 'sleep_max_bytes: maxbytespersecond = 1k max not reached => sleep 0') ; |
| 10373 | |
| 10374 | note( 'Leaving tests_sleep_max_bytes()' ) ; |
| 10375 | return ; |
| 10376 | } |
| 10377 | |
| 10378 | |
| 10379 | sub delete_message_on_host1 |
| 10380 | { |
| 10381 | my( $mysync, $h1_fold, $expunge, @h1_msg ) = @_ ; |
| 10382 | if ( ! $mysync->{ delete1 } ) { return ; } |
| 10383 | if ( ! @h1_msg ) { return ; } |
| 10384 | delete_messages_on_any( |
| 10385 | $mysync, |
| 10386 | $mysync->{imap1}, |
| 10387 | "Host1: $h1_fold", |
| 10388 | $expunge, |
| 10389 | $split1, |
| 10390 | @h1_msg ) ; |
| 10391 | return ; |
| 10392 | } |
| 10393 | |
| 10394 | sub tests_operators_and_exclam_precedence |
| 10395 | { |
| 10396 | note( 'Entering tests_operators_and_exclam_precedence()' ) ; |
| 10397 | |
| 10398 | is( 1, ! 0, 'tests_operators_and_exclam_precedence: ! 0 => 1' ) ; |
| 10399 | is( "", ! 1, 'tests_operators_and_exclam_precedence: ! 1 => ""' ) ; |
| 10400 | is( 1, not( 0 ), 'tests_operators_and_exclam_precedence: not( 0 ) => 1' ) ; |
| 10401 | is( "", not( 1 ), 'tests_operators_and_exclam_precedence: not( 1 ) => ""' ) ; |
| 10402 | |
| 10403 | # I wrote those tests to avoid perlcrit "Mixed high and low-precedence booleans" |
| 10404 | # and change sub delete_messages_on_any() but got 4 more warnings... So now commented. |
| 10405 | |
| 10406 | #is( 0, ( ! 0 and 0 ), 'tests_operators_and_exclam_precedence: ! 0 and 0 ) => 0' ) ; |
| 10407 | #is( 1, ( ! 0 and 1 ), 'tests_operators_and_exclam_precedence: ! 0 and 1 ) => 1' ) ; |
| 10408 | #is( "", ( ! 1 and 0 ), 'tests_operators_and_exclam_precedence: ! 1 and 0 ) => ""' ) ; |
| 10409 | #is( "", ( ! 1 and 1 ), 'tests_operators_and_exclam_precedence: ! 1 and 1 ) => ""' ) ; |
| 10410 | |
| 10411 | is( 0, ( ! 0 && 0 ), 'tests_operators_and_exclam_precedence: ! 0 && 0 ) => 0' ) ; |
| 10412 | is( 1, ( ! 0 && 1 ), 'tests_operators_and_exclam_precedence: ! 0 && 1 ) => 1' ) ; |
| 10413 | is( "", ( ! 1 && 0 ), 'tests_operators_and_exclam_precedence: ! 1 && 0 ) => ""' ) ; |
| 10414 | is( "", ( ! 1 && 1 ), 'tests_operators_and_exclam_precedence: ! 1 && 1 ) => ""' ) ; |
| 10415 | |
| 10416 | is( 2, ( ! 0 && 2 ), 'tests_operators_and_exclam_precedence: ! 0 && 2 ) => 1' ) ; |
| 10417 | |
| 10418 | note( 'Leaving tests_operators_and_exclam_precedence()' ) ; |
| 10419 | return ; |
| 10420 | } |
| 10421 | |
| 10422 | sub delete_messages_on_any |
| 10423 | { |
| 10424 | my( $mysync, $imap, $hostX_folder, $expunge, $split, @messages ) = @_ ; |
| 10425 | my $expunge_message = q{} ; |
| 10426 | |
| 10427 | my $dry_message = $mysync->{ dry_message } ; |
| 10428 | $expunge_message = 'and expunged' if ( $expunge ) ; |
| 10429 | # "Host1: msg " |
| 10430 | |
| 10431 | $imap->Debug( 1 ) ; |
| 10432 | |
| 10433 | while ( my @messages_part = splice @messages, 0, $split ) |
| 10434 | { |
| 10435 | foreach my $message ( @messages_part ) |
| 10436 | { |
| 10437 | myprint( "$hostX_folder/$message marking deleted $expunge_message $dry_message\n" ) ; |
| 10438 | } |
| 10439 | if ( ! $mysync->{dry} && @messages_part ) |
| 10440 | { |
| 10441 | my $nb_deleted = $imap->delete_message( $imap->Range( @messages_part ) ) ; |
| 10442 | if ( defined $nb_deleted ) |
| 10443 | { |
| 10444 | # $nb_deleted is not accurate |
| 10445 | $mysync->{ h1_nb_msg_deleted } += scalar @messages_part ; |
| 10446 | } |
| 10447 | else |
| 10448 | { |
| 10449 | my $error_imap = $imap->LastError || q{} ; |
| 10450 | my $error = join( q{}, "$hostX_folder folder, could not delete ", |
| 10451 | scalar @messages_part, ' messages: ', $error_imap, "\n" ) ; |
| 10452 | errors_incr( $mysync, $error ) ; |
| 10453 | } |
| 10454 | } |
| 10455 | } |
| 10456 | |
| 10457 | if ( $expunge ) { |
| 10458 | uidexpunge_or_expunge( $mysync, $imap, @messages ) ; |
| 10459 | } |
| 10460 | |
| 10461 | $imap->Debug( 0 ) ; |
| 10462 | |
| 10463 | return ; |
| 10464 | } |
| 10465 | |
| 10466 | |
| 10467 | sub tests_uidexpunge_or_expunge |
| 10468 | { |
| 10469 | note( 'Entering tests_uidexpunge_or_expunge()' ) ; |
| 10470 | |
| 10471 | |
| 10472 | is( undef, uidexpunge_or_expunge( ), 'uidexpunge_or_expunge: no args => undef' ) ; |
| 10473 | my $mysync ; |
| 10474 | is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: undef args => undef' ) ; |
| 10475 | $mysync = {} ; |
| 10476 | is( undef, uidexpunge_or_expunge( $mysync ), 'uidexpunge_or_expunge: arg empty => undef' ) ; |
| 10477 | my $imap ; |
| 10478 | is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: undef Mail-IMAPClient instance => undef' ) ; |
| 10479 | |
| 10480 | require_ok( "Test::MockObject" ) ; |
| 10481 | $imap = Test::MockObject->new( ) ; |
| 10482 | is( undef, uidexpunge_or_expunge( $mysync, $imap ), 'uidexpunge_or_expunge: no message (1) to uidexpunge => undef' ) ; |
| 10483 | |
| 10484 | my @messages = ( ) ; |
| 10485 | is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: no message (2) to uidexpunge => undef' ) ; |
| 10486 | |
| 10487 | @messages = ( '2', '1' ) ; |
| 10488 | $imap->mock( 'uidexpunge', sub { return ; } ) ; |
| 10489 | $imap->mock( 'expunge', sub { return ; } ) ; |
| 10490 | is( undef, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge failure => undef' ) ; |
| 10491 | |
| 10492 | $imap->mock( 'expunge', sub { return 1 ; } ) ; |
| 10493 | is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: uidexpunge failure => expunge ok => 1' ) ; |
| 10494 | |
| 10495 | $imap->mock( 'uidexpunge', sub { return 1 ; } ) ; |
| 10496 | is( 1, uidexpunge_or_expunge( $mysync, $imap, @messages ), 'uidexpunge_or_expunge: messages to uidexpunge ok => 1' ) ; |
| 10497 | |
| 10498 | note( 'Leaving tests_uidexpunge_or_expunge()' ) ; |
| 10499 | return ; |
| 10500 | } |
| 10501 | |
| 10502 | sub uidexpunge_or_expunge |
| 10503 | { |
| 10504 | my $mysync = shift ; |
| 10505 | my $imap = shift ; |
| 10506 | my @messages = @ARG ; |
| 10507 | |
| 10508 | if ( ! $imap ) { return ; } ; |
| 10509 | if ( ! @messages ) { return ; } ; |
| 10510 | |
| 10511 | # Doing uidexpunge |
| 10512 | my @uidexpunge_result = $imap->uidexpunge( @messages ) ; |
| 10513 | if ( @uidexpunge_result ) { |
| 10514 | return 1 ; |
| 10515 | } |
| 10516 | # Failure so doing expunge |
| 10517 | my $expunge_result = $imap->expunge( ) ; |
| 10518 | if ( $expunge_result ) { |
| 10519 | return 1 ; |
| 10520 | } |
| 10521 | # bad trip |
| 10522 | return ; |
| 10523 | } |
| 10524 | |
| 10525 | sub eta_print |
| 10526 | { |
| 10527 | my $mysync = shift ; |
| 10528 | if ( my $eta = eta( $mysync ) ) |
| 10529 | { |
| 10530 | myprint( "$eta\n" ) ; |
| 10531 | } |
| 10532 | return ; |
| 10533 | } |
| 10534 | |
| 10535 | sub tests_eta |
| 10536 | { |
| 10537 | note( 'Entering tests_eta()' ) ; |
| 10538 | |
| 10539 | is( q{}, eta( ), 'eta: no args => ""' ) ; |
| 10540 | is( q{}, eta( undef ), 'eta: undef => ""' ) ; |
| 10541 | my $mysync = {} ; |
| 10542 | # No foldersizes |
| 10543 | is( q{}, eta( $mysync ), 'eta: No foldersizes => ""' ) ; |
| 10544 | |
| 10545 | $mysync->{ foldersizes } = 1 ; |
| 10546 | |
| 10547 | $mysync->{ begin_transfer_time } = time ; # Now |
| 10548 | $mysync->{ h1_nb_msg_processed } = 0 ; |
| 10549 | |
| 10550 | is( "ETA: " . localtime( time ) . " 0 s 0/0 msgs left", |
| 10551 | eta( $mysync ), |
| 10552 | 'eta: no args => ETA: "Now" 0 s 0/0 msgs left' ) ; |
| 10553 | |
| 10554 | $mysync->{ h1_nb_msg_processed } = 1 ; |
| 10555 | $mysync->{ h1_nb_msg_start } = 2 ; |
| 10556 | is( "ETA: " . localtime( time ) . " 0 s 1/2 msgs left", |
| 10557 | eta( $mysync ), |
| 10558 | 'eta: 1, 1, 2 => ETA: "Now" 0 s 1/2 msgs left' ) ; |
| 10559 | |
| 10560 | note( 'Leaving tests_eta()' ) ; |
| 10561 | return ; |
| 10562 | } |
| 10563 | |
| 10564 | |
| 10565 | sub eta |
| 10566 | { |
| 10567 | my( $mysync ) = shift ; |
| 10568 | |
| 10569 | if ( ! $mysync ) |
| 10570 | { |
| 10571 | return q{} ; |
| 10572 | } |
| 10573 | |
| 10574 | return( q{} ) if not $mysync->{ foldersizes } ; |
| 10575 | |
| 10576 | my $h1_nb_msg_start = $mysync->{ h1_nb_msg_start } ; |
| 10577 | my $h1_nb_processed = $mysync->{ h1_nb_msg_processed } ; |
| 10578 | my $nb_msg_transferred = ( $mysync->{dry} ) ? $mysync->{ h1_nb_msg_processed } : $mysync->{ nb_msg_transferred } ; |
| 10579 | my $time_spent = timesince( $mysync->{ begin_transfer_time } ) ; |
| 10580 | $h1_nb_processed ||= 0 ; |
| 10581 | $h1_nb_msg_start ||= 0 ; |
| 10582 | $time_spent ||= 0 ; |
| 10583 | |
| 10584 | my $time_remaining = time_remaining( $time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_msg_transferred ) ; |
| 10585 | $mysync->{ debug } and myprint( "time_spent: $time_spent time_remaining: $time_remaining\n" ) ; |
| 10586 | my $nb_msg_remaining = $h1_nb_msg_start - $h1_nb_processed ; |
| 10587 | my $eta_date = localtime( time + $time_remaining ) ; |
| 10588 | return( mysprintf( 'ETA: %s %1.0f s %s/%s msgs left', |
| 10589 | $eta_date, $time_remaining, $nb_msg_remaining, $h1_nb_msg_start ) ) ; |
| 10590 | } |
| 10591 | |
| 10592 | |
| 10593 | |
| 10594 | |
| 10595 | sub time_remaining |
| 10596 | { |
| 10597 | |
| 10598 | my( $my_time_spent, $h1_nb_processed, $h1_nb_msg_start, $nb_transferred ) = @_ ; |
| 10599 | |
| 10600 | $nb_transferred ||= 1 ; # At least one is done (no division by zero) |
| 10601 | $h1_nb_processed ||= 0 ; |
| 10602 | $h1_nb_msg_start ||= $h1_nb_processed ; |
| 10603 | $my_time_spent ||= 0 ; |
| 10604 | |
| 10605 | my $time_remaining = ( $my_time_spent / $nb_transferred ) * ( $h1_nb_msg_start - $h1_nb_processed ) ; |
| 10606 | return( $time_remaining ) ; |
| 10607 | } |
| 10608 | |
| 10609 | |
| 10610 | sub tests_time_remaining |
| 10611 | { |
| 10612 | note( 'Entering tests_time_remaining()' ) ; |
| 10613 | |
| 10614 | # time_spent, nb_processed, nb_to_do_total, nb_transferred |
| 10615 | is( 0, time_remaining( ), 'time_remaining: no args -> 0' ) ; |
| 10616 | is( 0, time_remaining( 0, 0, 0, 0 ), 'time_remaining: 0, 0, 0, 0 -> 0' ) ; |
| 10617 | is( 1, time_remaining( 1, 1, 2, 1 ), 'time_remaining: 1, 1, 2, 1 -> 1' ) ; |
| 10618 | is( 1, time_remaining( 9, 9, 10, 9 ), 'time_remaining: 9, 9, 10, 9 -> 1' ) ; |
| 10619 | is( 9, time_remaining( 1, 1, 10, 1 ), 'time_remaining: 1, 1, 10, 1 -> 9' ) ; |
| 10620 | is( 5, time_remaining( 5, 5, 10, 5 ), 'time_remaining: 5, 5, 10, 5 -> 5' ) ; |
| 10621 | is( 25, time_remaining( 5, 5, 10, 0 ), 'time_remaining: 5, 5, 10, 0 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ; |
| 10622 | is( 25, time_remaining( 5, 5, 10, 1 ), 'time_remaining: 5, 5, 10, 1 -> ( 5 / 1 ) * ( 10 - 5) = 25' ) ; |
| 10623 | |
| 10624 | note( 'Leaving tests_time_remaining()' ) ; |
| 10625 | return ; |
| 10626 | } |
| 10627 | |
| 10628 | |
| 10629 | sub cache_map |
| 10630 | { |
| 10631 | my ( $cache_files_ref, $h1_msgs_ref, $h2_msgs_ref ) = @_; |
| 10632 | my ( %map1_2, %map2_1, %done2 ) ; |
| 10633 | |
| 10634 | my $h1_msgs_hash_ref = { } ; |
| 10635 | my $h2_msgs_hash_ref = { } ; |
| 10636 | |
| 10637 | @{ $h1_msgs_hash_ref }{ @{ $h1_msgs_ref } } = ( ) ; |
| 10638 | @{ $h2_msgs_hash_ref }{ @{ $h2_msgs_ref } } = ( ) ; |
| 10639 | |
| 10640 | foreach my $file ( sort @{ $cache_files_ref } ) { |
| 10641 | $debugcache and myprint( "C12: $file\n" ) ; |
| 10642 | ( $uid1, $uid2 ) = match_a_cache_file( $file ) ; |
| 10643 | |
| 10644 | if ( exists( $h1_msgs_hash_ref->{ defined $uid1 ? $uid1 : q{} } ) |
| 10645 | and exists( $h2_msgs_hash_ref->{ defined $uid2 ? $uid2 : q{} } ) ) { |
| 10646 | # keep only the greatest uid2 |
| 10647 | # 130_2301 and |
| 10648 | # 130_231 => keep only 130 -> 2301 |
| 10649 | |
| 10650 | # keep only the greatest uid1 |
| 10651 | # 1601_260 and |
| 10652 | # 161_260 => keep only 1601 -> 260 |
| 10653 | my $max_uid2 = max( $uid2, $map1_2{ $uid1 } || $MINUS_ONE ) ; |
| 10654 | if ( exists $done2{ $max_uid2 } ) { |
| 10655 | if ( $done2{ $max_uid2 } < $uid1 ) { |
| 10656 | $map1_2{ $uid1 } = $max_uid2 ; |
| 10657 | delete $map1_2{ $done2{ $max_uid2 } } ; |
| 10658 | $done2{ $max_uid2 } = $uid1 ; |
| 10659 | } |
| 10660 | }else{ |
| 10661 | $map1_2{ $uid1 } = $max_uid2 ; |
| 10662 | $done2{ $max_uid2 } = $uid1 ; |
| 10663 | } |
| 10664 | }; |
| 10665 | |
| 10666 | } |
| 10667 | %map2_1 = reverse %map1_2 ; |
| 10668 | return( \%map1_2, \%map2_1) ; |
| 10669 | } |
| 10670 | |
| 10671 | sub tests_cache_map |
| 10672 | { |
| 10673 | note( 'Entering tests_cache_map()' ) ; |
| 10674 | |
| 10675 | #$debugcache = 1 ; |
| 10676 | my @cache_files = qw ( |
| 10677 | 100_200 |
| 10678 | 101_201 |
| 10679 | 120_220 |
| 10680 | 142_242 |
| 10681 | 143_243 |
| 10682 | 177_277 |
| 10683 | 177_278 |
| 10684 | 177_279 |
| 10685 | 155_255 |
| 10686 | 180_280 |
| 10687 | 181_280 |
| 10688 | 182_280 |
| 10689 | 130_231 |
| 10690 | 130_2301 |
| 10691 | 161_260 |
| 10692 | 1601_260 |
| 10693 | ) ; |
| 10694 | |
| 10695 | my $msgs_1 = [120, 142, 143, 144, 161, 1601, 177, 182, 130 ]; |
| 10696 | my $msgs_2 = [ 242, 243, 260, 299, 377, 279, 255, 280, 231, 2301 ]; |
| 10697 | |
| 10698 | my( $c12, $c21 ) ; |
| 10699 | ok( ( $c12, $c21 ) = cache_map( \@cache_files, $msgs_1, $msgs_2 ), 'cache_map: 02' ); |
| 10700 | my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; |
| 10701 | my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; |
| 10702 | ok( 0 == compare_lists( [ 130, 142, 143, 177, 182, 1601 ], $a1 ), 'cache_map: 03' ); |
| 10703 | ok( 0 == compare_lists( [ 242, 243, 260, 279, 280, 2301 ], $a2 ), 'cache_map: 04' ); |
| 10704 | ok( ! $c12->{161}, 'cache_map: ! 161 -> 260' ); |
| 10705 | ok( 260 == $c12->{1601}, 'cache_map: 1601 -> 260' ); |
| 10706 | ok( 2301 == $c12->{130}, 'cache_map: 130 -> 2301' ); |
| 10707 | #myprint( $c12->{1601}, "\n" ) ; |
| 10708 | |
| 10709 | note( 'Leaving tests_cache_map()' ) ; |
| 10710 | return ; |
| 10711 | |
| 10712 | } |
| 10713 | |
| 10714 | sub cache_dir_fix |
| 10715 | { |
| 10716 | my $cache_dir = shift ; |
| 10717 | $cache_dir =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"\\])/\\$1/xg ; |
| 10718 | #myprint( "cache_dir_fix: $cache_dir\n" ) ; |
| 10719 | return( $cache_dir ) ; |
| 10720 | } |
| 10721 | |
| 10722 | sub tests_cache_dir_fix |
| 10723 | { |
| 10724 | note( 'Entering tests_cache_dir_fix()' ) ; |
| 10725 | |
| 10726 | ok( 'lalala' eq cache_dir_fix('lalala'), 'cache_dir_fix: lalala -> lalala' ); |
| 10727 | ok( 'ii\\\\ii' eq cache_dir_fix('ii\ii'), 'cache_dir_fix: ii\ii -> ii\\\\ii' ); |
| 10728 | ok( 'ii@ii' eq cache_dir_fix('ii@ii'), 'cache_dir_fix: ii@ii -> ii@ii' ); |
| 10729 | ok( 'ii@ii\\:ii' eq cache_dir_fix('ii@ii:ii'), 'cache_dir_fix: ii@ii:ii -> ii@ii\\:ii' ); |
| 10730 | ok( 'i\\\\i\\\\ii' eq cache_dir_fix('i\i\ii'), 'cache_dir_fix: i\i\ii -> i\\\\i\\\\ii' ); |
| 10731 | ok( 'i\\\\ii' eq cache_dir_fix('i\\ii'), 'cache_dir_fix: i\\ii -> i\\\\\\\\ii' ); |
| 10732 | ok( '\\\\ ' eq cache_dir_fix('\\ '), 'cache_dir_fix: \\ -> \\\\\ ' ); |
| 10733 | ok( '\\\\ ' eq cache_dir_fix('\ '), 'cache_dir_fix: \ -> \\\\\ ' ); |
| 10734 | ok( '\[bracket\]' eq cache_dir_fix('[bracket]'), 'cache_dir_fix: [bracket] -> \[bracket\]' ); |
| 10735 | |
| 10736 | note( 'Leaving tests_cache_dir_fix()' ) ; |
| 10737 | return ; |
| 10738 | } |
| 10739 | |
| 10740 | sub cache_dir_fix_win |
| 10741 | { |
| 10742 | my $cache_dir = shift ; |
| 10743 | $cache_dir =~ s/(\[|\])/[$1]/xg ; |
| 10744 | #myprint( "cache_dir_fix_win: $cache_dir\n" ) ; |
| 10745 | return( $cache_dir ) ; |
| 10746 | } |
| 10747 | |
| 10748 | sub tests_cache_dir_fix_win |
| 10749 | { |
| 10750 | note( 'Entering tests_cache_dir_fix_win()' ) ; |
| 10751 | |
| 10752 | ok( 'lalala' eq cache_dir_fix_win('lalala'), 'cache_dir_fix_win: lalala -> lalala' ); |
| 10753 | ok( '[[]bracket[]]' eq cache_dir_fix_win('[bracket]'), 'cache_dir_fix_win: [bracket] -> [[]bracket[]]' ); |
| 10754 | |
| 10755 | note( 'Leaving tests_cache_dir_fix_win()' ) ; |
| 10756 | return ; |
| 10757 | } |
| 10758 | |
| 10759 | |
| 10760 | |
| 10761 | |
| 10762 | sub get_cache |
| 10763 | { |
| 10764 | my ( $cache_dir, $h1_msgs_ref, $h2_msgs_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_; |
| 10765 | |
| 10766 | $debugcache and myprint( "Entering get_cache\n" ) ; |
| 10767 | |
| 10768 | -d $cache_dir or return( undef ); # exit if cache directory doesn't exist |
| 10769 | $debugcache and myprint( "cache_dir : $cache_dir\n" ) ; |
| 10770 | |
| 10771 | |
| 10772 | if ( 'MSWin32' ne $OSNAME ) { |
| 10773 | $cache_dir = cache_dir_fix( $cache_dir ) ; |
| 10774 | }else{ |
| 10775 | $cache_dir = cache_dir_fix_win( $cache_dir ) ; |
| 10776 | } |
| 10777 | |
| 10778 | $debugcache and myprint( "cache_dir_fix: $cache_dir\n" ) ; |
| 10779 | |
| 10780 | my @cache_files = bsd_glob( "$cache_dir/*" ) ; |
| 10781 | #$debugcache and myprint( "cache_files: [@cache_files]\n" ) ; |
| 10782 | |
| 10783 | $debugcache and myprint( 'cache_files: ', scalar @cache_files , " files found\n" ) ; |
| 10784 | |
| 10785 | my( $cache_1_2_ref, $cache_2_1_ref ) |
| 10786 | = cache_map( \@cache_files, $h1_msgs_ref, $h2_msgs_ref ) ; |
| 10787 | |
| 10788 | clean_cache( \@cache_files, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) ; |
| 10789 | |
| 10790 | $debugcache and myprint( "Exiting get_cache\n" ) ; |
| 10791 | return( $cache_1_2_ref, $cache_2_1_ref ) ; |
| 10792 | } |
| 10793 | |
| 10794 | |
| 10795 | sub tests_get_cache |
| 10796 | { |
| 10797 | note( 'Entering tests_get_cache()' ) ; |
| 10798 | |
| 10799 | ok( not( get_cache('/cache_no_exist') ), 'get_cache: /cache_no_exist' ); |
| 10800 | ok( ( not -d 'W/tmp/cache/F1/F2' or rmtree( 'W/tmp/cache/F1/F2' ) ), 'get_cache: rmtree W/tmp/cache/F1/F2' ) ; |
| 10801 | ok( mkpath( 'W/tmp/cache/F1/F2' ), 'get_cache: mkpath W/tmp/cache/F1/F2' ) ; |
| 10802 | |
| 10803 | my @test_files_cache = ( qw( |
| 10804 | W/tmp/cache/F1/F2/100_200 |
| 10805 | W/tmp/cache/F1/F2/101_201 |
| 10806 | W/tmp/cache/F1/F2/120_220 |
| 10807 | W/tmp/cache/F1/F2/142_242 |
| 10808 | W/tmp/cache/F1/F2/143_243 |
| 10809 | W/tmp/cache/F1/F2/177_277 |
| 10810 | W/tmp/cache/F1/F2/177_377 |
| 10811 | W/tmp/cache/F1/F2/177_777 |
| 10812 | W/tmp/cache/F1/F2/155_255 |
| 10813 | ) ) ; |
| 10814 | ok( touch( @test_files_cache ), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; |
| 10815 | |
| 10816 | |
| 10817 | # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 |
| 10818 | # on live: |
| 10819 | my $msgs_1 = [120, 142, 143, 144, 177 ]; |
| 10820 | my $msgs_2 = [ 242, 243, 299, 377, 777, 255 ]; |
| 10821 | |
| 10822 | my $msgs_all_1 = { 120 => 0, 142 => 0, 143 => 0, 144 => 0, 177 => 0 } ; |
| 10823 | my $msgs_all_2 = { 242 => 0, 243 => 0, 299 => 0, 377 => 0, 777 => 0, 255 => 0 } ; |
| 10824 | |
| 10825 | my( $c12, $c21 ) ; |
| 10826 | ok( ( $c12, $c21 ) = get_cache( 'W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); |
| 10827 | my $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; |
| 10828 | my $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; |
| 10829 | ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: 03' ); |
| 10830 | ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: 04' ); |
| 10831 | ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); |
| 10832 | ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); |
| 10833 | ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file removed 100_200'); |
| 10834 | ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file removed 101_201'); |
| 10835 | |
| 10836 | # test clean_cache executed |
| 10837 | $maxage = 2 ; |
| 10838 | ok( touch(@test_files_cache), 'get_cache: touch W/tmp/cache/F1/F2/...' ) ; |
| 10839 | ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/F1/F2', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2 ), 'get_cache: 02' ); |
| 10840 | ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 142_242'); |
| 10841 | ok( -f 'W/tmp/cache/F1/F2/142_242', 'get_cache: file kept 143_243'); |
| 10842 | ok( ! -f 'W/tmp/cache/F1/F2/100_200', 'get_cache: file NOT removed 100_200'); |
| 10843 | ok( ! -f 'W/tmp/cache/F1/F2/101_201', 'get_cache: file NOT removed 101_201'); |
| 10844 | |
| 10845 | |
| 10846 | # strange files |
| 10847 | #$debugcache = 1 ; |
| 10848 | $maxage = undef ; |
| 10849 | ok( ( not -d 'W/tmp/cache/rr\uee' or rmtree( 'W/tmp/cache/rr\uee' )), 'get_cache: rmtree W/tmp/cache/rr\uee' ) ; |
| 10850 | ok( mkpath( 'W/tmp/cache/rr\uee' ), 'get_cache: mkpath W/tmp/cache/rr\uee' ) ; |
| 10851 | |
| 10852 | @test_files_cache = ( qw( |
| 10853 | W/tmp/cache/rr\uee/100_200 |
| 10854 | W/tmp/cache/rr\uee/101_201 |
| 10855 | W/tmp/cache/rr\uee/120_220 |
| 10856 | W/tmp/cache/rr\uee/142_242 |
| 10857 | W/tmp/cache/rr\uee/143_243 |
| 10858 | W/tmp/cache/rr\uee/177_277 |
| 10859 | W/tmp/cache/rr\uee/177_377 |
| 10860 | W/tmp/cache/rr\uee/177_777 |
| 10861 | W/tmp/cache/rr\uee/155_255 |
| 10862 | ) ) ; |
| 10863 | ok( touch(@test_files_cache), 'get_cache: touch strange W/tmp/cache/...' ) ; |
| 10864 | |
| 10865 | # on cache: 100_200 101_201 142_242 143_243 177_277 177_377 177_777 155_255 |
| 10866 | # on live: |
| 10867 | $msgs_1 = [120, 142, 143, 144, 177 ] ; |
| 10868 | $msgs_2 = [ 242, 243, 299, 377, 777, 255 ] ; |
| 10869 | |
| 10870 | $msgs_all_1 = { 120 => q{}, 142 => q{}, 143 => q{}, 144 => q{}, 177 => q{} } ; |
| 10871 | $msgs_all_2 = { 242 => q{}, 243 => q{}, 299 => q{}, 377 => q{}, 777 => q{}, 255 => q{} } ; |
| 10872 | |
| 10873 | ok( ( $c12, $c21 ) = get_cache('W/tmp/cache/rr\uee', $msgs_1, $msgs_2, $msgs_all_1, $msgs_all_2), 'get_cache: strange path 02' ); |
| 10874 | $a1 = [ sort { $a <=> $b } keys %{ $c12 } ] ; |
| 10875 | $a2 = [ sort { $a <=> $b } keys %{ $c21 } ] ; |
| 10876 | ok( 0 == compare_lists( [ 142, 143, 177 ], $a1 ), 'get_cache: strange path 03' ); |
| 10877 | ok( 0 == compare_lists( [ 242, 243, 777 ], $a2 ), 'get_cache: strange path 04' ); |
| 10878 | ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 142_242'); |
| 10879 | ok( -f 'W/tmp/cache/rr\uee/142_242', 'get_cache: strange path file kept 143_243'); |
| 10880 | ok( ! -f 'W/tmp/cache/rr\uee/100_200', 'get_cache: strange path file removed 100_200'); |
| 10881 | ok( ! -f 'W/tmp/cache/rr\uee/101_201', 'get_cache: strange path file removed 101_201'); |
| 10882 | |
| 10883 | note( 'Leaving tests_get_cache()' ) ; |
| 10884 | return ; |
| 10885 | } |
| 10886 | |
| 10887 | sub match_a_cache_file |
| 10888 | { |
| 10889 | my $file = shift ; |
| 10890 | my ( $cache_uid1, $cache_uid2 ) ; |
| 10891 | |
| 10892 | return( ( undef, undef ) ) if ( ! $file ) ; |
| 10893 | if ( $file =~ m{(?:^|/)(\d+)_(\d+)$}x ) { |
| 10894 | $cache_uid1 = $1 ; |
| 10895 | $cache_uid2 = $2 ; |
| 10896 | } |
| 10897 | return( $cache_uid1, $cache_uid2 ) ; |
| 10898 | } |
| 10899 | |
| 10900 | sub tests_match_a_cache_file |
| 10901 | { |
| 10902 | note( 'Entering tests_match_a_cache_file()' ) ; |
| 10903 | |
| 10904 | my ( $tuid1, $tuid2 ) ; |
| 10905 | ok( ( $tuid1, $tuid2 ) = match_a_cache_file( ), 'match_a_cache_file: no arg' ) ; |
| 10906 | ok( ! defined $tuid1 , 'match_a_cache_file: no arg 1' ) ; |
| 10907 | ok( ! defined $tuid2 , 'match_a_cache_file: no arg 2' ) ; |
| 10908 | |
| 10909 | ok( ( $tuid1, $tuid2 ) = match_a_cache_file( q{} ), 'match_a_cache_file: empty arg' ) ; |
| 10910 | ok( ! defined $tuid1 , 'match_a_cache_file: empty arg 1' ) ; |
| 10911 | ok( ! defined $tuid2 , 'match_a_cache_file: empty arg 2' ) ; |
| 10912 | |
| 10913 | ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '000_000' ), 'match_a_cache_file: 000_000' ) ; |
| 10914 | ok( '000' eq $tuid1, 'match_a_cache_file: 000_000 1' ) ; |
| 10915 | ok( '000' eq $tuid2, 'match_a_cache_file: 000_000 2' ) ; |
| 10916 | |
| 10917 | ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '123_456' ), 'match_a_cache_file: 123_456' ) ; |
| 10918 | ok( '123' eq $tuid1, 'match_a_cache_file: 123_456 1' ) ; |
| 10919 | ok( '456' eq $tuid2, 'match_a_cache_file: 123_456 2' ) ; |
| 10920 | |
| 10921 | ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/tmp/truc/123_456' ), 'match_a_cache_file: /tmp/truc/123_456' ) ; |
| 10922 | ok( '123' eq $tuid1, 'match_a_cache_file: /tmp/truc/123_456 1' ) ; |
| 10923 | ok( '456' eq $tuid2, 'match_a_cache_file: /tmp/truc/123_456 2' ) ; |
| 10924 | |
| 10925 | ok( ( $tuid1, $tuid2 ) = match_a_cache_file( '/lala123_456' ), 'match_a_cache_file: NO /lala123_456' ) ; |
| 10926 | ok( ! $tuid1, 'match_a_cache_file: /lala123_456 1' ) ; |
| 10927 | ok( ! $tuid2, 'match_a_cache_file: /lala123_456 2' ) ; |
| 10928 | |
| 10929 | ok( ( $tuid1, $tuid2 ) = match_a_cache_file( 'la123_456' ), 'match_a_cache_file: NO la123_456' ) ; |
| 10930 | ok( ! $tuid1, 'match_a_cache_file: la123_456 1' ) ; |
| 10931 | ok( ! $tuid2, 'match_a_cache_file: la123_456 2' ) ; |
| 10932 | |
| 10933 | note( 'Leaving tests_match_a_cache_file()' ) ; |
| 10934 | return ; |
| 10935 | } |
| 10936 | |
| 10937 | sub clean_cache |
| 10938 | { |
| 10939 | my ( $cache_files_ref, $cache_1_2_ref, $h1_msgs_all_hash_ref, $h2_msgs_all_hash_ref ) = @_ ; |
| 10940 | |
| 10941 | $debugcache and myprint( "Entering clean_cache\n" ) ; |
| 10942 | |
| 10943 | $debugcache and myprint( map { "$_ -> " . $cache_1_2_ref->{ $_ } . "\n" } keys %{ $cache_1_2_ref } ) ; |
| 10944 | foreach my $file ( @{ $cache_files_ref } ) { |
| 10945 | $debugcache and myprint( "$file\n" ) ; |
| 10946 | my ( $cache_uid1, $cache_uid2 ) = match_a_cache_file( $file ) ; |
| 10947 | $debugcache and myprint( "u1: $cache_uid1 u2: $cache_uid2 c12: ", $cache_1_2_ref->{ $cache_uid1 } || q{}, "\n") ; |
| 10948 | # or ( ! exists( $cache_1_2_ref->{ $cache_uid1 } ) ) |
| 10949 | # or ( ! ( $cache_uid2 == $cache_1_2_ref->{ $cache_uid1 } ) ) |
| 10950 | if ( ( not defined $cache_uid1 ) |
| 10951 | or ( not defined $cache_uid2 ) |
| 10952 | or ( not exists $h1_msgs_all_hash_ref->{ $cache_uid1 } ) |
| 10953 | or ( not exists $h2_msgs_all_hash_ref->{ $cache_uid2 } ) |
| 10954 | ) { |
| 10955 | $debugcache and myprint( "remove $file\n" ) ; |
| 10956 | unlink $file or myprint( "$OS_ERROR" ) ; |
| 10957 | } |
| 10958 | } |
| 10959 | |
| 10960 | $debugcache and myprint( "Exiting clean_cache\n" ) ; |
| 10961 | return( 1 ) ; |
| 10962 | } |
| 10963 | |
| 10964 | sub tests_clean_cache |
| 10965 | { |
| 10966 | note( 'Entering tests_clean_cache()' ) ; |
| 10967 | |
| 10968 | ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache: rmtree W/tmp/cache/G1/G2' ) ; |
| 10969 | ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache: mkpath W/tmp/cache/G1/G2' ) ; |
| 10970 | |
| 10971 | my @test_files_cache = ( qw( |
| 10972 | W/tmp/cache/G1/G2/100_200 |
| 10973 | W/tmp/cache/G1/G2/101_201 |
| 10974 | W/tmp/cache/G1/G2/120_220 |
| 10975 | W/tmp/cache/G1/G2/142_242 |
| 10976 | W/tmp/cache/G1/G2/143_243 |
| 10977 | W/tmp/cache/G1/G2/177_277 |
| 10978 | W/tmp/cache/G1/G2/177_377 |
| 10979 | W/tmp/cache/G1/G2/177_777 |
| 10980 | W/tmp/cache/G1/G2/155_255 |
| 10981 | ) ) ; |
| 10982 | ok( touch(@test_files_cache), 'clean_cache: touch W/tmp/cache/G1/G2/...' ) ; |
| 10983 | |
| 10984 | ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 before' ); |
| 10985 | ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 before' ); |
| 10986 | ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 before' ); |
| 10987 | ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 before' ); |
| 10988 | ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 before' ); |
| 10989 | ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 before' ); |
| 10990 | |
| 10991 | my $cache = { |
| 10992 | 142 => 242, |
| 10993 | 177 => 777, |
| 10994 | } ; |
| 10995 | |
| 10996 | my $all_1 = { |
| 10997 | 142 => q{}, |
| 10998 | 177 => q{}, |
| 10999 | } ; |
| 11000 | |
| 11001 | my $all_2 = { |
| 11002 | 200 => q{}, |
| 11003 | 242 => q{}, |
| 11004 | 777 => q{}, |
| 11005 | } ; |
| 11006 | ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache: ' ) ; |
| 11007 | |
| 11008 | ok( ! -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache: 100_200 after' ); |
| 11009 | ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache: 142_242 after' ); |
| 11010 | ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache: 177_277 after' ); |
| 11011 | ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache: 177_377 after' ); |
| 11012 | ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache: 177_777 after' ); |
| 11013 | ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache: 155_255 after' ); |
| 11014 | |
| 11015 | note( 'Leaving tests_clean_cache()' ) ; |
| 11016 | return ; |
| 11017 | } |
| 11018 | |
| 11019 | sub tests_clean_cache_2 |
| 11020 | { |
| 11021 | note( 'Entering tests_clean_cache_2()' ) ; |
| 11022 | |
| 11023 | ok( ( not -d 'W/tmp/cache/G1/G2' or rmtree( 'W/tmp/cache/G1/G2' )), 'clean_cache_2: rmtree W/tmp/cache/G1/G2' ) ; |
| 11024 | ok( mkpath( 'W/tmp/cache/G1/G2' ), 'clean_cache_2: mkpath W/tmp/cache/G1/G2' ) ; |
| 11025 | |
| 11026 | my @test_files_cache = ( qw( |
| 11027 | W/tmp/cache/G1/G2/100_200 |
| 11028 | W/tmp/cache/G1/G2/101_201 |
| 11029 | W/tmp/cache/G1/G2/120_220 |
| 11030 | W/tmp/cache/G1/G2/142_242 |
| 11031 | W/tmp/cache/G1/G2/143_243 |
| 11032 | W/tmp/cache/G1/G2/177_277 |
| 11033 | W/tmp/cache/G1/G2/177_377 |
| 11034 | W/tmp/cache/G1/G2/177_777 |
| 11035 | W/tmp/cache/G1/G2/155_255 |
| 11036 | ) ) ; |
| 11037 | ok( touch(@test_files_cache), 'clean_cache_2: touch W/tmp/cache/G1/G2/...' ) ; |
| 11038 | |
| 11039 | ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 before' ); |
| 11040 | ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 before' ); |
| 11041 | ok( -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 before' ); |
| 11042 | ok( -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 before' ); |
| 11043 | ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 before' ); |
| 11044 | ok( -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 before' ); |
| 11045 | |
| 11046 | my $cache = { |
| 11047 | 142 => 242, |
| 11048 | 177 => 777, |
| 11049 | } ; |
| 11050 | |
| 11051 | my $all_1 = { |
| 11052 | $NUMBER_100 => q{}, |
| 11053 | 142 => q{}, |
| 11054 | 177 => q{}, |
| 11055 | } ; |
| 11056 | |
| 11057 | my $all_2 = { |
| 11058 | 200 => q{}, |
| 11059 | 242 => q{}, |
| 11060 | 777 => q{}, |
| 11061 | } ; |
| 11062 | |
| 11063 | |
| 11064 | |
| 11065 | ok( clean_cache( \@test_files_cache, $cache, $all_1, $all_2 ), 'clean_cache_2: ' ) ; |
| 11066 | |
| 11067 | ok( -f 'W/tmp/cache/G1/G2/100_200', 'clean_cache_2: 100_200 after' ); |
| 11068 | ok( -f 'W/tmp/cache/G1/G2/142_242', 'clean_cache_2: 142_242 after' ); |
| 11069 | ok( ! -f 'W/tmp/cache/G1/G2/177_277', 'clean_cache_2: 177_277 after' ); |
| 11070 | ok( ! -f 'W/tmp/cache/G1/G2/177_377', 'clean_cache_2: 177_377 after' ); |
| 11071 | ok( -f 'W/tmp/cache/G1/G2/177_777', 'clean_cache_2: 177_777 after' ); |
| 11072 | ok( ! -f 'W/tmp/cache/G1/G2/155_255', 'clean_cache_2: 155_255 after' ); |
| 11073 | |
| 11074 | note( 'Leaving tests_clean_cache_2()' ) ; |
| 11075 | return ; |
| 11076 | } |
| 11077 | |
| 11078 | |
| 11079 | |
| 11080 | sub tests_mkpath |
| 11081 | { |
| 11082 | note( 'Entering tests_mkpath()' ) ; |
| 11083 | |
| 11084 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'mkpath: mkpath W/tmp/tests/' ) ; |
| 11085 | |
| 11086 | SKIP: { |
| 11087 | skip( 'Tests only for Unix', 10 ) if ( 'MSWin32' eq $OSNAME ) ; |
| 11088 | my $long_path_unix = '123456789/' x 30 ; |
| 11089 | ok( ( -d "W/tmp/tests/long/$long_path_unix" or mkpath( "W/tmp/tests/long/$long_path_unix" ) ), 'mkpath: mkpath 300 char' ) ; |
| 11090 | ok( -d "W/tmp/tests/long/$long_path_unix", 'mkpath: mkpath > 300 char verified' ) ; |
| 11091 | ok( ( -d "W/tmp/tests/long/$long_path_unix" and rmtree( 'W/tmp/tests/long/' ) ), 'mkpath: rmtree 300 char' ) ; |
| 11092 | ok( ! -d "W/tmp/tests/long/$long_path_unix", 'mkpath: rmtree 300 char verified' ) ; |
| 11093 | |
| 11094 | ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ; |
| 11095 | ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ; |
| 11096 | ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ; |
| 11097 | ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ; |
| 11098 | |
| 11099 | eval { ok( 1 / 0, 'mkpath: divide by 0' ) ; } or ok( 1, 'mkpath: can not divide by 0' ) ; |
| 11100 | ok( 1, 'mkpath: still alive' ) ; |
| 11101 | } ; |
| 11102 | |
| 11103 | SKIP: { |
| 11104 | skip( 'Tests only for MSWin32', 13 ) if ( 'MSWin32' ne $OSNAME ) ; |
| 11105 | my $long_path_2_prefix = ".\\imapsync_tests" || '\\\?\\E:\\TEMP\\imapsync_tests' ; |
| 11106 | myprint( "long_path_2_prefix: $long_path_2_prefix\n" ) ; |
| 11107 | |
| 11108 | my $long_path_100 = $long_path_2_prefix . '\\' . '123456789\\' x 10 . 'END' ; |
| 11109 | my $long_path_300 = $long_path_2_prefix . '\\' . '123456789\\' x 30 . 'END' ; |
| 11110 | |
| 11111 | #myprint( "$long_path_100\n" ) ; |
| 11112 | |
| 11113 | ok( ( -d $long_path_2_prefix or mkpath( $long_path_2_prefix ) ), 'mkpath: -d mkpath small path' ) ; |
| 11114 | ok( ( -d $long_path_2_prefix ), 'mkpath: -d mkpath small path done' ) ; |
| 11115 | ok( ( -d $long_path_100 or mkpath( $long_path_100 ) ), 'mkpath: mkpath > 100 char' ) ; |
| 11116 | ok( ( -d $long_path_100 ), 'mkpath: -d mkpath > 200 char done' ) ; |
| 11117 | ok( ( -d $long_path_2_prefix and rmtree( $long_path_2_prefix ) ), 'mkpath: rmtree > 100 char' ) ; |
| 11118 | ok( (! -d $long_path_2_prefix ), 'mkpath: ! -d rmtree done' ) ; |
| 11119 | |
| 11120 | # Without the eval the following mkpath 300 just kill the whole process without a whisper |
| 11121 | #myprint( "$long_path_300\n" ) ; |
| 11122 | eval { ok( ( -d $long_path_300 or mkpath( $long_path_300 ) ), 'mkpath: create a path with 300 characters' ) ; } |
| 11123 | or ok( 1, 'mkpath: can not create a path with 300 characters' ) ; |
| 11124 | ok( ( ( ! -d $long_path_300 ) or -d $long_path_300 and rmtree( $long_path_300 ) ), 'mkpath: rmtree the 300 character path' ) ; |
| 11125 | ok( 1, 'mkpath: still alive' ) ; |
| 11126 | |
| 11127 | ok( ( -d 'W/tmp/tests/trailing_dots...' or mkpath( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: mkpath trailing_dots...' ) ; |
| 11128 | ok( -d 'W/tmp/tests/trailing_dots...', 'mkpath: mkpath trailing_dots... verified' ) ; |
| 11129 | ok( ( -d 'W/tmp/tests/trailing_dots...' and rmtree( 'W/tmp/tests/trailing_dots...' ) ), 'mkpath: rmtree trailing_dots...' ) ; |
| 11130 | ok( ! -d 'W/tmp/tests/trailing_dots...', 'mkpath: rmtree trailing_dots... verified' ) ; |
| 11131 | |
| 11132 | |
| 11133 | } ; |
| 11134 | |
| 11135 | note( 'Leaving tests_mkpath()' ) ; |
| 11136 | # Keep this because of the eval used by the caller (failed badly?) |
| 11137 | return 1 ; |
| 11138 | } |
| 11139 | |
| 11140 | sub tests_touch |
| 11141 | { |
| 11142 | note( 'Entering tests_touch()' ) ; |
| 11143 | |
| 11144 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' )), 'touch: mkpath W/tmp/tests/' ) ; |
| 11145 | ok( 1 == touch( 'W/tmp/tests/lala'), 'touch: W/tmp/tests/lala') ; |
| 11146 | ok( 1 == touch( 'W/tmp/tests/\y'), 'touch: W/tmp/tests/\y') ; |
| 11147 | ok( 0 == touch( '/no/no/no/aaa'), 'touch: not /aaa') ; |
| 11148 | ok( 1 == touch( 'W/tmp/tests/lili', 'W/tmp/tests/lolo'), 'touch: 2 files') ; |
| 11149 | ok( 0 == touch( 'W/tmp/tests/\y', '/no/no/aaa'), 'touch: 2 files, 1 fails' ) ; |
| 11150 | |
| 11151 | note( 'Leaving tests_touch()' ) ; |
| 11152 | return ; |
| 11153 | } |
| 11154 | |
| 11155 | |
| 11156 | sub touch |
| 11157 | { |
| 11158 | my @files = @_ ; |
| 11159 | my $failures = 0 ; |
| 11160 | |
| 11161 | foreach my $file ( @files ) { |
| 11162 | my $fh = IO::File->new ; |
| 11163 | if ( $fh->open(">> $file" ) ) { |
| 11164 | $fh->close ; |
| 11165 | }else{ |
| 11166 | myprint( "Could not open file $file in write/append mode\n" ) ; |
| 11167 | $failures++ ; |
| 11168 | } |
| 11169 | } |
| 11170 | return( ! $failures ); |
| 11171 | } |
| 11172 | |
| 11173 | |
| 11174 | sub tests_tmpdir_has_colon_bug |
| 11175 | { |
| 11176 | note( 'Entering tests_tmpdir_has_colon_bug()' ) ; |
| 11177 | |
| 11178 | ok( 0 == tmpdir_has_colon_bug( q{} ), 'tmpdir_has_colon_bug: ' ) ; |
| 11179 | ok( 0 == tmpdir_has_colon_bug( '/tmp' ), 'tmpdir_has_colon_bug: /tmp' ) ; |
| 11180 | ok( 1 == tmpdir_has_colon_bug( 'C:' ), 'tmpdir_has_colon_bug: C:' ) ; |
| 11181 | ok( 1 == tmpdir_has_colon_bug( 'C:\temp' ), 'tmpdir_has_colon_bug: C:\temp' ) ; |
| 11182 | |
| 11183 | note( 'Leaving tests_tmpdir_has_colon_bug()' ) ; |
| 11184 | return ; |
| 11185 | } |
| 11186 | |
| 11187 | sub tmpdir_has_colon_bug |
| 11188 | { |
| 11189 | my $path = shift ; |
| 11190 | |
| 11191 | my $path_filtered = filter_forbidden_characters( $path ) ; |
| 11192 | if ( $path_filtered ne $path ) { |
| 11193 | ( -d $path_filtered ) and myprint( "Path $path was previously mistakely changed to $path_filtered\n" ) ; |
| 11194 | return( 1 ) ; |
| 11195 | } |
| 11196 | return( 0 ) ; |
| 11197 | } |
| 11198 | |
| 11199 | sub tmpdir_fix_colon_bug |
| 11200 | { |
| 11201 | my $mysync = shift ; |
| 11202 | my $err = 0 ; |
| 11203 | if ( not (-d $mysync->{ tmpdir } and -r _ and -w _) ) { |
| 11204 | myprint( "tmpdir $mysync->{ tmpdir } is not valid\n" ) ; |
| 11205 | return( 0 ) ; |
| 11206 | } |
| 11207 | my $cachedir_new = "$mysync->{ tmpdir }/imapsync_cache" ; |
| 11208 | |
| 11209 | if ( not tmpdir_has_colon_bug( $cachedir_new ) ) { return( 0 ) } ; |
| 11210 | |
| 11211 | # check if old cache directory already exists |
| 11212 | my $cachedir_old = filter_forbidden_characters( $cachedir_new ) ; |
| 11213 | if ( not ( -d $cachedir_old ) ) { |
| 11214 | myprint( "Old cache directory $cachedir_new no exists, nothing to do\n" ) ; |
| 11215 | return( 1 ) ; |
| 11216 | } |
| 11217 | # check if new cache directory already exists |
| 11218 | if ( -d $cachedir_new ) { |
| 11219 | myprint( "New fixed cache directory $cachedir_new already exists, not moving the old one $cachedir_old. Fix this manually.\n" ) ; |
| 11220 | return( 0 ) ; |
| 11221 | }else{ |
| 11222 | # move the old one to the new place |
| 11223 | myprint( "Moving $cachedir_old to $cachedir_new Do not interrupt this task.\n" ) ; |
| 11224 | File::Copy::Recursive::rmove( $cachedir_old, $cachedir_new ) |
| 11225 | or do { |
| 11226 | myprint( "Could not move $cachedir_old to $cachedir_new\n" ) ; |
| 11227 | $err++ ; |
| 11228 | } ; |
| 11229 | # check it succeeded |
| 11230 | if ( -d $cachedir_new and -r _ and -w _ ) { |
| 11231 | myprint( "New fixed cache directory $cachedir_new ok\n" ) ; |
| 11232 | }else{ |
| 11233 | myprint( "New fixed cache directory $cachedir_new does not exist\n" ) ; |
| 11234 | $err++ ; |
| 11235 | } |
| 11236 | if ( -d $cachedir_old ) { |
| 11237 | myprint( "Old cache directory $cachedir_old still exists\n" ) ; |
| 11238 | $err++ ; |
| 11239 | }else{ |
| 11240 | myprint( "Old cache directory $cachedir_old successfuly moved\n" ) ; |
| 11241 | } |
| 11242 | } |
| 11243 | return( not $err ) ; |
| 11244 | } |
| 11245 | |
| 11246 | |
| 11247 | sub tests_cache_folder |
| 11248 | { |
| 11249 | note( 'Entering tests_cache_folder()' ) ; |
| 11250 | |
| 11251 | ok( '/path/fold1/fold2' eq cache_folder( q{}, '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ; |
| 11252 | ok( '/pa_th/fold1/fold2' eq cache_folder( q{}, '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ; |
| 11253 | ok( '/_p_a__th/fol_d1/fold2' eq cache_folder( q{}, '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ; |
| 11254 | |
| 11255 | ok( 'D:/path/fold1/fold2' eq cache_folder( 'D:', '/path', 'fold1', 'fold2'), 'cache_folder: /path, fold1, fold2 -> /path/fold1/fold2' ) ; |
| 11256 | ok( 'D:/pa_th/fold1/fold2' eq cache_folder( 'D:', '/pa*th', 'fold1', 'fold2'), 'cache_folder: /pa*th, fold1, fold2 -> /path/fold1/fold2' ) ; |
| 11257 | ok( 'D:/_p_a__th/fol_d1/fold2' eq cache_folder( 'D:', '/>p<a|*th', 'fol*d1', 'fold2'), 'cache_folder: />p<a|*th, fol*d1, fold2 -> /path/fol_d1/fold2' ) ; |
| 11258 | ok( '//' eq cache_folder( q{}, q{}, q{}, q{}), 'cache_folder: -> //' ) ; |
| 11259 | ok( '//_______' eq cache_folder( q{}, q{}, q{}, '*|?:"<>'), 'cache_folder: *|?:"<> -> //_______' ) ; |
| 11260 | |
| 11261 | note( 'Leaving tests_cache_folder()' ) ; |
| 11262 | return ; |
| 11263 | } |
| 11264 | |
| 11265 | sub cache_folder |
| 11266 | { |
| 11267 | my( $cache_base, $cache_dir, $h1_fold, $h2_fold ) = @_ ; |
| 11268 | |
| 11269 | my $sep_1 = $sync->{ h1_sep } || '/'; |
| 11270 | my $sep_2 = $sync->{ h2_sep } || '/'; |
| 11271 | |
| 11272 | #myprint( "$cache_dir h1_fold $h1_fold sep1 $sep_1 h2_fold $h2_fold sep2 $sep_2\n" ) ; |
| 11273 | $h1_fold = convert_sep_to_slash( $h1_fold, $sep_1 ) ; |
| 11274 | $h2_fold = convert_sep_to_slash( $h2_fold, $sep_2 ) ; |
| 11275 | |
| 11276 | my $cache_folder = "$cache_base" . filter_forbidden_characters( "$cache_dir/$h1_fold/$h2_fold" ) ; |
| 11277 | #myprint( "cache_folder [$cache_folder]\n" ) ; |
| 11278 | return( $cache_folder ) ; |
| 11279 | } |
| 11280 | |
| 11281 | sub tests_filter_forbidden_characters |
| 11282 | { |
| 11283 | note( 'Entering tests_filter_forbidden_characters()' ) ; |
| 11284 | |
| 11285 | ok( 'a_b' eq filter_forbidden_characters( 'a_b' ), 'filter_forbidden_characters: a_b -> a_b' ) ; |
| 11286 | ok( 'a_b' eq filter_forbidden_characters( 'a*b' ), 'filter_forbidden_characters: a*b -> a_b' ) ; |
| 11287 | ok( 'a_b' eq filter_forbidden_characters( 'a|b' ), 'filter_forbidden_characters: a|b -> a_b' ) ; |
| 11288 | ok( 'a_b' eq filter_forbidden_characters( 'a?b' ), 'filter_forbidden_characters: a?b -> a_b' ) ; |
| 11289 | ok( 'a_______b' eq filter_forbidden_characters( 'a*|?:"<>b' ), 'filter_forbidden_characters: a*|?:"<>b -> a_______b' ) ; |
| 11290 | |
| 11291 | SKIP: { |
| 11292 | skip( 'Not on MSWin32', 1 ) if ( 'MSWin32' eq $OSNAME ) ; |
| 11293 | ok( ( 'a b ' eq filter_forbidden_characters( 'a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b "' ) ; |
| 11294 | } ; |
| 11295 | |
| 11296 | SKIP: { |
| 11297 | skip( 'Only on MSWin32', 2 ) if ( 'MSWin32' ne $OSNAME ) ; |
| 11298 | ok( ( ' a b_' eq filter_forbidden_characters( ' a b ' ) ), 'filter_forbidden_characters: "a b " -> "a b_"' ) ; |
| 11299 | ok( ( ' a b_/ c d_' eq filter_forbidden_characters( ' a b / c d ' ) ), 'filter_forbidden_characters: " a b / c d " -> "a b_/ c d_"' ) ; |
| 11300 | } ; |
| 11301 | |
| 11302 | ok( 'a_b' eq filter_forbidden_characters( "a\tb" ), 'filter_forbidden_characters: a\tb -> a_b' ) ; |
| 11303 | ok( "a_b" eq filter_forbidden_characters( "a\rb" ), 'filter_forbidden_characters: a\rb -> a_b' ) ; |
| 11304 | ok( "a_b" eq filter_forbidden_characters( "a\nb" ), 'filter_forbidden_characters: a\nb -> a_b' ) ; |
| 11305 | ok( "a_b" eq filter_forbidden_characters( "a\\b" ), 'filter_forbidden_characters: a\b -> a_b' ) ; |
| 11306 | |
| 11307 | note( 'Leaving tests_filter_forbidden_characters()' ) ; |
| 11308 | return ; |
| 11309 | } |
| 11310 | |
| 11311 | sub filter_forbidden_characters |
| 11312 | { |
| 11313 | my $string = shift ; |
| 11314 | |
| 11315 | if ( ! defined $string ) { return ; } |
| 11316 | |
| 11317 | if ( 'MSWin32' eq $OSNAME ) { |
| 11318 | # Move trailing whitespace to _ " a b /c d " -> " a b_/c d_" |
| 11319 | $string =~ s{\ (/|$)}{_$1}xg ; |
| 11320 | } |
| 11321 | $string =~ s{[\Q*|?:"<>\E\t\r\n\\]}{_}xg ; |
| 11322 | #myprint( "[$string]\n" ) ; |
| 11323 | return( $string ) ; |
| 11324 | } |
| 11325 | |
| 11326 | sub tests_convert_sep_to_slash |
| 11327 | { |
| 11328 | note( 'Entering tests_convert_sep_to_slash()' ) ; |
| 11329 | |
| 11330 | |
| 11331 | ok(q{} eq convert_sep_to_slash(q{}, '/'), 'convert_sep_to_slash: no folder'); |
| 11332 | ok('INBOX' eq convert_sep_to_slash('INBOX', '/'), 'convert_sep_to_slash: INBOX'); |
| 11333 | ok('INBOX/foo' eq convert_sep_to_slash('INBOX/foo', '/'), 'convert_sep_to_slash: INBOX/foo'); |
| 11334 | ok('INBOX/foo' eq convert_sep_to_slash('INBOX_foo', '_'), 'convert_sep_to_slash: INBOX_foo'); |
| 11335 | ok('INBOX/foo/zob' eq convert_sep_to_slash('INBOX_foo_zob', '_'), 'convert_sep_to_slash: INBOX_foo_zob'); |
| 11336 | ok('INBOX/foo' eq convert_sep_to_slash('INBOX.foo', '.'), 'convert_sep_to_slash: INBOX.foo'); |
| 11337 | ok('INBOX/foo/hi' eq convert_sep_to_slash('INBOX.foo.hi', '.'), 'convert_sep_to_slash: INBOX.foo.hi'); |
| 11338 | |
| 11339 | note( 'Leaving tests_convert_sep_to_slash()' ) ; |
| 11340 | return ; |
| 11341 | } |
| 11342 | |
| 11343 | sub convert_sep_to_slash |
| 11344 | { |
| 11345 | my ( $folder, $sep ) = @_ ; |
| 11346 | |
| 11347 | $folder =~ s{\Q$sep\E}{/}xg ; |
| 11348 | return( $folder ) ; |
| 11349 | } |
| 11350 | |
| 11351 | |
| 11352 | sub tests_regexmess |
| 11353 | { |
| 11354 | note( 'Entering tests_regexmess()' ) ; |
| 11355 | |
| 11356 | ok( 'blabla' eq regexmess( 'blabla' ), 'regexmess, no regexmess, nothing to do' ) ; |
| 11357 | |
| 11358 | @regexmess = ( 'lalala' ) ; |
| 11359 | ok( not( defined regexmess( 'popopo' ) ), 'regexmess, bad regex lalala' ) ; |
| 11360 | |
| 11361 | @regexmess = ( 's/p/Z/g' ) ; |
| 11362 | ok( 'ZoZoZo' eq regexmess( 'popopo' ), 'regexmess, s/p/Z/g' ) ; |
| 11363 | |
| 11364 | @regexmess = ( 's{c}{C}gxms' ) ; |
| 11365 | ok("H1: abC\nH2: Cde\n\nBody abC" |
| 11366 | eq regexmess( "H1: abc\nH2: cde\n\nBody abc"), |
| 11367 | 'regexmess, c->C'); |
| 11368 | |
| 11369 | @regexmess = ( 's{\AFrom\ }{From:}gxms' ) ; |
| 11370 | ok( q{} |
| 11371 | eq regexmess(q{}), |
| 11372 | 'From mbox 1 add colon blank'); |
| 11373 | |
| 11374 | ok( 'From:<tartanpion@machin.truc>' |
| 11375 | eq regexmess('From <tartanpion@machin.truc>'), |
| 11376 | 'From mbox 2 add colo'); |
| 11377 | |
| 11378 | ok( "\n" . 'From <tartanpion@machin.truc>' |
| 11379 | eq regexmess("\n" . 'From <tartanpion@machin.truc>'), |
| 11380 | 'From mbox 3 add colo') ; |
| 11381 | |
| 11382 | ok( "From: zzz\n" . 'From <tartanpion@machin.truc>' |
| 11383 | eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), |
| 11384 | 'From mbox 4 add colo') ; |
| 11385 | |
| 11386 | @regexmess = ( 's{\AFrom\ [^\n]*(\n)?}{}gxms' ) ; |
| 11387 | ok( q{} |
| 11388 | eq regexmess(q{}), |
| 11389 | 'From mbox 1 remove, blank'); |
| 11390 | |
| 11391 | ok( q{} |
| 11392 | eq regexmess('From <tartanpion@machin.truc>'), |
| 11393 | 'From mbox 2 remove'); |
| 11394 | |
| 11395 | ok( "\n" . 'From <tartanpion@machin.truc>' |
| 11396 | eq regexmess("\n" . 'From <tartanpion@machin.truc>'), |
| 11397 | 'From mbox 3 remove'); |
| 11398 | |
| 11399 | #myprint( "[", regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), "]" ) ; |
| 11400 | ok( q{} . 'From <tartanpion@machin.truc>' |
| 11401 | eq regexmess("From zzz\n" . 'From <tartanpion@machin.truc>'), |
| 11402 | 'From mbox 4 remove'); |
| 11403 | |
| 11404 | |
| 11405 | ok( |
| 11406 | <<'EOM' |
| 11407 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11408 | From:<tartanpion@machin.truc> |
| 11409 | |
| 11410 | Hello, |
| 11411 | Bye. |
| 11412 | EOM |
| 11413 | eq regexmess( |
| 11414 | <<'EOM' |
| 11415 | From zzz |
| 11416 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11417 | From:<tartanpion@machin.truc> |
| 11418 | |
| 11419 | Hello, |
| 11420 | Bye. |
| 11421 | EOM |
| 11422 | ), 'From mbox 5 remove'); |
| 11423 | |
| 11424 | |
| 11425 | @regexmess = ( 's{\A((?:[^\n]+\n)+|)^Disposition-Notification-To:[^\n]*\n(\r?\n|.*\n\r?\n)}{$1$2}xms' ) ; # SUPER SUPER BEST! |
| 11426 | ok( |
| 11427 | <<'EOM' |
| 11428 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11429 | From:<tartanpion@machin.truc> |
| 11430 | |
| 11431 | Hello, |
| 11432 | Bye. |
| 11433 | EOM |
| 11434 | eq regexmess( |
| 11435 | <<'EOM' |
| 11436 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11437 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11438 | From:<tartanpion@machin.truc> |
| 11439 | |
| 11440 | Hello, |
| 11441 | Bye. |
| 11442 | EOM |
| 11443 | ), |
| 11444 | 'regexmess: 1 Delete header Disposition-Notification-To:'); |
| 11445 | |
| 11446 | ok( |
| 11447 | <<'EOM' |
| 11448 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11449 | From:<tartanpion@machin.truc> |
| 11450 | |
| 11451 | Hello, |
| 11452 | Bye. |
| 11453 | EOM |
| 11454 | eq regexmess( |
| 11455 | <<'EOM' |
| 11456 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11457 | From:<tartanpion@machin.truc> |
| 11458 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11459 | |
| 11460 | Hello, |
| 11461 | Bye. |
| 11462 | EOM |
| 11463 | ), |
| 11464 | 'regexmess: 2 Delete header Disposition-Notification-To:'); |
| 11465 | |
| 11466 | ok( |
| 11467 | <<'EOM' |
| 11468 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11469 | From:<tartanpion@machin.truc> |
| 11470 | |
| 11471 | Hello, |
| 11472 | Bye. |
| 11473 | EOM |
| 11474 | eq regexmess( |
| 11475 | <<'EOM' |
| 11476 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11477 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11478 | From:<tartanpion@machin.truc> |
| 11479 | |
| 11480 | Hello, |
| 11481 | Bye. |
| 11482 | EOM |
| 11483 | ), |
| 11484 | 'regexmess: 3 Delete header Disposition-Notification-To:'); |
| 11485 | |
| 11486 | ok( |
| 11487 | <<'EOM' |
| 11488 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11489 | From:<tartanpion@machin.truc> |
| 11490 | |
| 11491 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11492 | Bye. |
| 11493 | EOM |
| 11494 | eq regexmess( |
| 11495 | <<'EOM' |
| 11496 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11497 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11498 | From:<tartanpion@machin.truc> |
| 11499 | |
| 11500 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11501 | Bye. |
| 11502 | EOM |
| 11503 | ), |
| 11504 | 'regexmess: 4 Delete header Disposition-Notification-To:'); |
| 11505 | |
| 11506 | |
| 11507 | ok( |
| 11508 | <<'EOM' |
| 11509 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11510 | From:<tartanpion@machin.truc> |
| 11511 | |
| 11512 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11513 | Bye. |
| 11514 | EOM |
| 11515 | eq regexmess( |
| 11516 | <<'EOM' |
| 11517 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11518 | From:<tartanpion@machin.truc> |
| 11519 | |
| 11520 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11521 | Bye. |
| 11522 | EOM |
| 11523 | ), |
| 11524 | 'regexmess: 5 Delete header Disposition-Notification-To:'); |
| 11525 | |
| 11526 | |
| 11527 | ok( |
| 11528 | <<'EOM' |
| 11529 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11530 | From:<tartanpion@machin.truc> |
| 11531 | |
| 11532 | Hello, |
| 11533 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11534 | Bye. |
| 11535 | EOM |
| 11536 | eq regexmess( |
| 11537 | <<'EOM' |
| 11538 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11539 | From:<tartanpion@machin.truc> |
| 11540 | |
| 11541 | Hello, |
| 11542 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11543 | Bye. |
| 11544 | EOM |
| 11545 | ), |
| 11546 | 'regexmess: 6 Delete header Disposition-Notification-To:'); |
| 11547 | |
| 11548 | ok( |
| 11549 | <<'EOM' |
| 11550 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11551 | From:<tartanpion@machin.truc> |
| 11552 | |
| 11553 | Hello, |
| 11554 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11555 | |
| 11556 | Bye. |
| 11557 | EOM |
| 11558 | eq regexmess( |
| 11559 | <<'EOM' |
| 11560 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11561 | From:<tartanpion@machin.truc> |
| 11562 | |
| 11563 | Hello, |
| 11564 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11565 | |
| 11566 | Bye. |
| 11567 | EOM |
| 11568 | ), |
| 11569 | 'regexmess: 7 Delete header Disposition-Notification-To:'); |
| 11570 | |
| 11571 | |
| 11572 | ok( |
| 11573 | <<'EOM' |
| 11574 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11575 | From:<tartanpion@machin.truc> |
| 11576 | |
| 11577 | Hello, |
| 11578 | Bye. |
| 11579 | EOM |
| 11580 | eq regexmess( |
| 11581 | <<'EOM' |
| 11582 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11583 | From:<tartanpion@machin.truc> |
| 11584 | |
| 11585 | Hello, |
| 11586 | Bye. |
| 11587 | EOM |
| 11588 | ), |
| 11589 | 'regexmess: 8 Delete header Disposition-Notification-To:'); |
| 11590 | |
| 11591 | |
| 11592 | ok( |
| 11593 | <<'EOM' |
| 11594 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11595 | From:<tartanpion@machin.truc> |
| 11596 | |
| 11597 | Hello, |
| 11598 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11599 | Bye. |
| 11600 | EOM |
| 11601 | eq regexmess( |
| 11602 | <<'EOM' |
| 11603 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11604 | From:<tartanpion@machin.truc> |
| 11605 | |
| 11606 | Hello, |
| 11607 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11608 | Bye. |
| 11609 | EOM |
| 11610 | ), |
| 11611 | 'regexmess: 9 Delete header Disposition-Notification-To:'); |
| 11612 | |
| 11613 | |
| 11614 | |
| 11615 | ok( |
| 11616 | <<'EOM' |
| 11617 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11618 | From:<tartanpion@machin.truc> |
| 11619 | |
| 11620 | Hello, |
| 11621 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11622 | |
| 11623 | |
| 11624 | Bye. |
| 11625 | EOM |
| 11626 | eq regexmess( |
| 11627 | <<'EOM' |
| 11628 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11629 | From:<tartanpion@machin.truc> |
| 11630 | |
| 11631 | Hello, |
| 11632 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11633 | |
| 11634 | |
| 11635 | Bye. |
| 11636 | EOM |
| 11637 | ), |
| 11638 | 'regexmess: 10 Delete header Disposition-Notification-To:'); |
| 11639 | |
| 11640 | ok( |
| 11641 | <<'EOM' |
| 11642 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11643 | From:<tartanpion@machin.truc> |
| 11644 | |
| 11645 | Hello, |
| 11646 | |
| 11647 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11648 | |
| 11649 | Bye. |
| 11650 | EOM |
| 11651 | eq regexmess( |
| 11652 | <<'EOM' |
| 11653 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11654 | From:<tartanpion@machin.truc> |
| 11655 | |
| 11656 | Hello, |
| 11657 | |
| 11658 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11659 | |
| 11660 | Bye. |
| 11661 | EOM |
| 11662 | ), |
| 11663 | 'regexmess: 11 Delete header Disposition-Notification-To:'); |
| 11664 | |
| 11665 | ok( |
| 11666 | <<'EOM' |
| 11667 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11668 | From:<tartanpion@machin.truc> |
| 11669 | |
| 11670 | Hello, |
| 11671 | |
| 11672 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11673 | |
| 11674 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11675 | |
| 11676 | Bye. |
| 11677 | EOM |
| 11678 | eq regexmess( |
| 11679 | <<'EOM' |
| 11680 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11681 | From:<tartanpion@machin.truc> |
| 11682 | |
| 11683 | Hello, |
| 11684 | |
| 11685 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11686 | |
| 11687 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11688 | |
| 11689 | Bye. |
| 11690 | EOM |
| 11691 | ), |
| 11692 | 'regexmess: 12 Delete header Disposition-Notification-To:'); |
| 11693 | |
| 11694 | |
| 11695 | @regexmess = ( 's{\A(.*?(?! ^$))^Disposition-Notification-To:(.*?)$}{$1X-Disposition-Notification-To:$2}igxms' ) ; # BAD! |
| 11696 | @regexmess = ( 's{\A((?:[^\n]+\n)+|)(^Disposition-Notification-To:[^\n]*\n)(\r?\n|.*\n\r?\n)}{$1X-$2$3}ims' ) ; |
| 11697 | |
| 11698 | |
| 11699 | ok( |
| 11700 | <<'EOM' |
| 11701 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11702 | From:<tartanpion@machin.truc> |
| 11703 | |
| 11704 | Hello, |
| 11705 | |
| 11706 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11707 | |
| 11708 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11709 | |
| 11710 | Bye. |
| 11711 | EOM |
| 11712 | eq regexmess( |
| 11713 | <<'EOM' |
| 11714 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11715 | From:<tartanpion@machin.truc> |
| 11716 | |
| 11717 | Hello, |
| 11718 | |
| 11719 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11720 | |
| 11721 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11722 | |
| 11723 | Bye. |
| 11724 | EOM |
| 11725 | ), |
| 11726 | 'regexmess: 13 Delete header Disposition-Notification-To:'); |
| 11727 | |
| 11728 | ok( |
| 11729 | <<'EOM' |
| 11730 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11731 | X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11732 | From:<tartanpion@machin.truc> |
| 11733 | |
| 11734 | Hello, |
| 11735 | |
| 11736 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11737 | |
| 11738 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11739 | |
| 11740 | Bye. |
| 11741 | EOM |
| 11742 | eq regexmess( |
| 11743 | <<'EOM' |
| 11744 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11745 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11746 | From:<tartanpion@machin.truc> |
| 11747 | |
| 11748 | Hello, |
| 11749 | |
| 11750 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11751 | |
| 11752 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11753 | |
| 11754 | Bye. |
| 11755 | EOM |
| 11756 | ), |
| 11757 | 'regexmess: 14 Delete header Disposition-Notification-To:'); |
| 11758 | |
| 11759 | ok( |
| 11760 | <<'EOM' |
| 11761 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11762 | X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11763 | From:<tartanpion@machin.truc> |
| 11764 | |
| 11765 | Hello, |
| 11766 | |
| 11767 | Bye. |
| 11768 | EOM |
| 11769 | eq regexmess( |
| 11770 | <<'EOM' |
| 11771 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11772 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11773 | From:<tartanpion@machin.truc> |
| 11774 | |
| 11775 | Hello, |
| 11776 | |
| 11777 | Bye. |
| 11778 | EOM |
| 11779 | ), |
| 11780 | 'regexmess: 15 Delete header Disposition-Notification-To:'); |
| 11781 | |
| 11782 | |
| 11783 | ok( |
| 11784 | <<'EOM' |
| 11785 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11786 | From:<tartanpion@machin.truc> |
| 11787 | X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11788 | |
| 11789 | Hello, |
| 11790 | |
| 11791 | Bye. |
| 11792 | EOM |
| 11793 | eq regexmess( |
| 11794 | <<'EOM' |
| 11795 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11796 | From:<tartanpion@machin.truc> |
| 11797 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11798 | |
| 11799 | Hello, |
| 11800 | |
| 11801 | Bye. |
| 11802 | EOM |
| 11803 | ), |
| 11804 | 'regexmess: 16 Delete header Disposition-Notification-To:'); |
| 11805 | |
| 11806 | ok( |
| 11807 | <<'EOM' |
| 11808 | X-Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11809 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11810 | From:<tartanpion@machin.truc> |
| 11811 | |
| 11812 | Hello, |
| 11813 | |
| 11814 | Bye. |
| 11815 | EOM |
| 11816 | eq regexmess( |
| 11817 | <<'EOM' |
| 11818 | Disposition-Notification-To: Gilles LAMIRAL <gilles@lamiral.info> |
| 11819 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11820 | From:<tartanpion@machin.truc> |
| 11821 | |
| 11822 | Hello, |
| 11823 | |
| 11824 | Bye. |
| 11825 | EOM |
| 11826 | ), |
| 11827 | 'regexmess: 17 Delete header Disposition-Notification-To:'); |
| 11828 | |
| 11829 | @regexmess = ( 's/.{11}\K.*//gs' ) ; |
| 11830 | is( "0123456789\n", regexmess( "0123456789\n" x 100 ), 'regexmess, truncate whole message after 11 characters' ) ; |
| 11831 | is( "0123456789\n", regexmess( "0123456789\n" x 100_000 ), 'regexmess, truncate whole message after 11 characters ~ 1MB' ) ; |
| 11832 | |
| 11833 | @regexmess = ( 's/.{10000}\K.*//gs' ) ; |
| 11834 | is( "123456789\n" x 1000, regexmess( "123456789\n" x 100_000 ), 'regexmess, truncate whole message after 10000 characters ~ 1MB' ) ; |
| 11835 | |
| 11836 | @regexmess = ( 's/^(X-Ham-Report.*?\n)^X-/X-/sm' ) ; |
| 11837 | |
| 11838 | is( |
| 11839 | <<'EOM' |
| 11840 | X-Spam-Score: -1 |
| 11841 | X-Spam-Bar: / |
| 11842 | X-Spam-Flag: NO |
| 11843 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11844 | From:<tartanpion@machin.truc> |
| 11845 | |
| 11846 | Hello, |
| 11847 | |
| 11848 | Bye. |
| 11849 | EOM |
| 11850 | , |
| 11851 | regexmess( |
| 11852 | <<'EOM' |
| 11853 | X-Spam-Score: -1 |
| 11854 | X-Spam-Bar: / |
| 11855 | X-Ham-Report: =?utf-8?Q?Spam_detection_software=2C_running?= |
| 11856 | =?utf-8?Q?_on_the_system_=22ohp-ag006.int200?= |
| 11857 | _has_NOT_identified_thi?= |
| 11858 | =?utf-8?Q?s_incoming_email_as_spam.__The_o?= |
| 11859 | _message_has_been_attac?= |
| 11860 | =?utf-8?Q?hed_to_this_so_you_can_view_it_o?= |
| 11861 | ___________________________?= |
| 11862 | =?utf-8?Q?__author's_domain |
| 11863 | X-Spam-Flag: NO |
| 11864 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11865 | From:<tartanpion@machin.truc> |
| 11866 | |
| 11867 | Hello, |
| 11868 | |
| 11869 | Bye. |
| 11870 | EOM |
| 11871 | ), |
| 11872 | 'regexmess: 1 Delete header X-Ham-Report:'); |
| 11873 | |
| 11874 | |
| 11875 | # regex to play with Date: from the FAQ |
| 11876 | #@regexmess = 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms' |
| 11877 | |
| 11878 | |
| 11879 | |
| 11880 | |
| 11881 | |
| 11882 | note( 'Leaving tests_regexmess()' ) ; |
| 11883 | return ; |
| 11884 | |
| 11885 | } |
| 11886 | |
| 11887 | sub regexmess |
| 11888 | { |
| 11889 | my ( $string ) = @_ ; |
| 11890 | foreach my $regexmess ( @regexmess ) { |
| 11891 | $sync->{ debug } and myprint( "eval \$string =~ $regexmess\n" ) ; |
| 11892 | my $ret = eval "\$string =~ $regexmess ; 1" ; |
| 11893 | #myprint( "eval [$ret]\n" ) ; |
| 11894 | if ( ( not $ret ) or $EVAL_ERROR ) { |
| 11895 | myprint( "Error: eval regexmess '$regexmess': $EVAL_ERROR" ) ; |
| 11896 | return( undef ) ; |
| 11897 | } |
| 11898 | } |
| 11899 | $sync->{ debug } and myprint( "$string\n" ) ; |
| 11900 | return( $string ) ; |
| 11901 | } |
| 11902 | |
| 11903 | |
| 11904 | sub tests_skipmess |
| 11905 | { |
| 11906 | note( 'Entering tests_skipmess()' ) ; |
| 11907 | |
| 11908 | ok( not( defined skipmess( 'blabla' ) ), 'skipmess, no skipmess, no skip' ) ; |
| 11909 | |
| 11910 | @skipmess = ('[') ; |
| 11911 | ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex [' ) ; |
| 11912 | |
| 11913 | @skipmess = ('lalala') ; |
| 11914 | ok( not( defined skipmess( 'popopo' ) ), 'skipmess, bad regex lalala' ) ; |
| 11915 | |
| 11916 | @skipmess = ('/popopo/') ; |
| 11917 | ok( 1 == skipmess( 'popopo' ), 'skipmess, popopo match regex /popopo/' ) ; |
| 11918 | |
| 11919 | @skipmess = ('/popopo/') ; |
| 11920 | ok( 0 == skipmess( 'rrrrrr' ), 'skipmess, rrrrrr does not match regex /popopo/' ) ; |
| 11921 | |
| 11922 | @skipmess = ('m{^$}') ; |
| 11923 | ok( 1 == skipmess( q{} ), 'skipmess: empty string yes' ) ; |
| 11924 | ok( 0 == skipmess( 'Hi!' ), 'skipmess: empty string no' ) ; |
| 11925 | |
| 11926 | @skipmess = ('m{i}') ; |
| 11927 | ok( 1 == skipmess( 'Hi!' ), 'skipmess: i string yes' ) ; |
| 11928 | ok( 0 == skipmess( 'Bye!' ), 'skipmess: i string no' ) ; |
| 11929 | |
| 11930 | @skipmess = ('m{[\x80-\xff]}') ; |
| 11931 | ok( 0 == skipmess( 'Hi!' ), 'skipmess: i 8bit no' ) ; |
| 11932 | ok( 1 == skipmess( "\xff" ), 'skipmess: \xff 8bit yes' ) ; |
| 11933 | |
| 11934 | @skipmess = ('m{A}', 'm{B}') ; |
| 11935 | ok( 0 == skipmess( 'Hi!' ), 'skipmess: A or B no' ) ; |
| 11936 | ok( 0 == skipmess( 'lala' ), 'skipmess: A or B no' ) ; |
| 11937 | ok( 0 == skipmess( "\xff" ), 'skipmess: A or B no' ) ; |
| 11938 | ok( 1 == skipmess( 'AB' ), 'skipmess: A or B yes' ) ; |
| 11939 | ok( 1 == skipmess( 'BA' ), 'skipmess: A or B yes' ) ; |
| 11940 | ok( 1 == skipmess( 'AA' ), 'skipmess: A or B yes' ) ; |
| 11941 | ok( 1 == skipmess( 'Ok Bye' ), 'skipmess: A or B yes' ) ; |
| 11942 | |
| 11943 | |
| 11944 | @skipmess = ( 'm#\A((?:[^\n]+\n)+|)^Content-Type: Message/Partial;[^\n]*\n(?:\n|.*\n\n)#ism' ) ; # SUPER BEST! |
| 11945 | |
| 11946 | |
| 11947 | |
| 11948 | ok( 1 == skipmess( |
| 11949 | <<'EOM' |
| 11950 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11951 | Content-Type: Message/Partial; blabla |
| 11952 | From:<tartanpion@machin.truc> |
| 11953 | |
| 11954 | Hello! |
| 11955 | Bye. |
| 11956 | EOM |
| 11957 | ), |
| 11958 | 'skipmess: 1 match Content-Type: Message/Partial' ) ; |
| 11959 | |
| 11960 | ok( 0 == skipmess( |
| 11961 | <<'EOM' |
| 11962 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11963 | From:<tartanpion@machin.truc> |
| 11964 | |
| 11965 | Hello! |
| 11966 | Bye. |
| 11967 | EOM |
| 11968 | ), |
| 11969 | 'skipmess: 2 not match Content-Type: Message/Partial' ) ; |
| 11970 | |
| 11971 | |
| 11972 | ok( 1 == skipmess( |
| 11973 | <<'EOM' |
| 11974 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11975 | From:<tartanpion@machin.truc> |
| 11976 | Content-Type: Message/Partial; blabla |
| 11977 | |
| 11978 | Hello! |
| 11979 | Bye. |
| 11980 | EOM |
| 11981 | ), |
| 11982 | 'skipmess: 3 match Content-Type: Message/Partial' ) ; |
| 11983 | |
| 11984 | ok( 0 == skipmess( |
| 11985 | <<'EOM' |
| 11986 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 11987 | From:<tartanpion@machin.truc> |
| 11988 | |
| 11989 | Hello! |
| 11990 | Content-Type: Message/Partial; blabla |
| 11991 | Bye. |
| 11992 | EOM |
| 11993 | ), |
| 11994 | 'skipmess: 4 not match Content-Type: Message/Partial' ) ; |
| 11995 | |
| 11996 | |
| 11997 | ok( 0 == skipmess( |
| 11998 | <<'EOM' |
| 11999 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 12000 | From:<tartanpion@machin.truc> |
| 12001 | |
| 12002 | Hello! |
| 12003 | Content-Type: Message/Partial; blabla |
| 12004 | |
| 12005 | Bye. |
| 12006 | EOM |
| 12007 | ), |
| 12008 | 'skipmess: 5 not match Content-Type: Message/Partial' ) ; |
| 12009 | |
| 12010 | |
| 12011 | ok( 1 == skipmess( |
| 12012 | <<'EOM' |
| 12013 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 12014 | Content-Type: Message/Partial; blabla |
| 12015 | From:<tartanpion@machin.truc> |
| 12016 | |
| 12017 | Hello! |
| 12018 | |
| 12019 | Content-Type: Message/Partial; blabla |
| 12020 | |
| 12021 | Bye. |
| 12022 | EOM |
| 12023 | ), |
| 12024 | 'skipmess: 6 match Content-Type: Message/Partial' ) ; |
| 12025 | |
| 12026 | ok( 1 == skipmess( |
| 12027 | <<'EOM' |
| 12028 | Date: Sat, 10 Jul 2010 05:34:45 -0700 |
| 12029 | Content-Type: Message/Partial; |
| 12030 | From:<tartanpion@machin.truc> |
| 12031 | |
| 12032 | Hello! |
| 12033 | Bye. |
| 12034 | EOM |
| 12035 | ), |
| 12036 | 'skipmess: 7 match Content-Type: Message/Partial' ) ; |
| 12037 | |
| 12038 | ok( 1 == skipmess( |
| 12039 | <<'EOM' |
| 12040 | Date: Wed, 2 Jul 2014 02:26:40 +0000 |
| 12041 | MIME-Version: 1.0 |
| 12042 | Content-Type: message/partial; |
| 12043 | id="TAN_U_P<1404267997.00007489ed17>"; |
| 12044 | number=3; |
| 12045 | total=3 |
| 12046 | |
| 12047 | 6HQ6Hh3CdXj77qEGixerQ6zHx0OnQ/Cf5On4W0Y6vtU2crABZQtD46Hx1EOh8dDz4+OnTr1G |
| 12048 | |
| 12049 | |
| 12050 | Hello! |
| 12051 | Bye. |
| 12052 | EOM |
| 12053 | ), |
| 12054 | 'skipmess: 8 match Content-Type: Message/Partial' ) ; |
| 12055 | |
| 12056 | |
| 12057 | ok( 1 == skipmess( |
| 12058 | <<'EOM' |
| 12059 | Return-Path: <gilles@lamiral.info> |
| 12060 | Received: by lamiral.info (Postfix, from userid 1000) |
| 12061 | id 21EB12443BF; Mon, 2 Mar 2015 15:38:35 +0100 (CET) |
| 12062 | Subject: test: aethaecohngiexao |
| 12063 | To: <tata@petite.lamiral.info> |
| 12064 | X-Mailer: mail (GNU Mailutils 2.2) |
| 12065 | Message-Id: <20150302143835.21EB12443BF@lamiral.info> |
| 12066 | Content-Type: message/partial; |
| 12067 | id="TAN_U_P<1404267997.00007489ed17>"; |
| 12068 | number=3; |
| 12069 | total=3 |
| 12070 | Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) |
| 12071 | From: gilles@lamiral.info (Gilles LAMIRAL) |
| 12072 | |
| 12073 | test: aethaecohngiexao |
| 12074 | EOM |
| 12075 | ), |
| 12076 | 'skipmess: 9 match Content-Type: Message/Partial' ) ; |
| 12077 | |
| 12078 | ok( 1 == skipmess( |
| 12079 | <<'EOM' |
| 12080 | Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) |
| 12081 | From: gilles@lamiral.info (Gilles LAMIRAL) |
| 12082 | Content-Type: message/partial; |
| 12083 | id="TAN_U_P<1404267997.00007489ed17>"; |
| 12084 | number=3; |
| 12085 | total=3 |
| 12086 | |
| 12087 | test: aethaecohngiexao |
| 12088 | EOM |
| 12089 | . "lalala\n" x 3_000_000 |
| 12090 | ), |
| 12091 | 'skipmess: 10 match Content-Type: Message/Partial' ) ; |
| 12092 | |
| 12093 | ok( 0 == skipmess( |
| 12094 | <<'EOM' |
| 12095 | Date: Mon, 2 Mar 2015 15:38:34 +0100 (CET) |
| 12096 | From: gilles@lamiral.info (Gilles LAMIRAL) |
| 12097 | |
| 12098 | test: aethaecohngiexao |
| 12099 | EOM |
| 12100 | . "lalala\n" x 3_000_000 |
| 12101 | ), |
| 12102 | 'skipmess: 11 match Content-Type: Message/Partial' ) ; |
| 12103 | |
| 12104 | |
| 12105 | ok( 0 == skipmess( |
| 12106 | <<"EOM" |
| 12107 | From: fff\r |
| 12108 | To: fff\r |
| 12109 | Subject: Testing imapsync --skipmess\r |
| 12110 | Date: Mon, 22 Aug 2011 08:40:20 +0800\r |
| 12111 | Mime-Version: 1.0\r |
| 12112 | Content-Type: text/plain; charset=iso-8859-1\r |
| 12113 | Content-Transfer-Encoding: 7bit\r |
| 12114 | \r |
| 12115 | EOM |
| 12116 | . qq{!#"d%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefg\r\n } x 32_730 |
| 12117 | ), |
| 12118 | 'skipmess: 12 not match Content-Type: Message/Partial' ) ; |
| 12119 | # Complex regular subexpression recursion limit (32766) exceeded with more lines |
| 12120 | # exit; |
| 12121 | |
| 12122 | note( 'Leaving tests_skipmess()' ) ; |
| 12123 | return ; |
| 12124 | } |
| 12125 | |
| 12126 | sub skipmess |
| 12127 | { |
| 12128 | my ( $string ) = @_ ; |
| 12129 | my $match ; |
| 12130 | #myprint( "$string\n" ) ; |
| 12131 | foreach my $skipmess ( @skipmess ) { |
| 12132 | $sync->{ debug } and myprint( "eval \$match = \$string =~ $skipmess\n" ) ; |
| 12133 | my $ret = eval "\$match = \$string =~ $skipmess ; 1" ; |
| 12134 | #myprint( "eval [$ret]\n" ) ; |
| 12135 | $sync->{ debug } and myprint( "match [$match]\n" ) ; |
| 12136 | if ( ( not $ret ) or $EVAL_ERROR ) { |
| 12137 | myprint( "Error: eval skipmess '$skipmess': $EVAL_ERROR" ) ; |
| 12138 | return( undef ) ; |
| 12139 | } |
| 12140 | return( $match ) if ( $match ) ; |
| 12141 | } |
| 12142 | return( $match ) ; |
| 12143 | } |
| 12144 | |
| 12145 | |
| 12146 | |
| 12147 | |
| 12148 | sub tests_bytes_display_string |
| 12149 | { |
| 12150 | note( 'Entering tests_bytes_display_string()' ) ; |
| 12151 | |
| 12152 | |
| 12153 | is( 'NA', bytes_display_string( ), 'bytes_display_string: no args => NA' ) ; |
| 12154 | is( 'NA', bytes_display_string( undef ), 'bytes_display_string: undef => NA' ) ; |
| 12155 | is( 'NA', bytes_display_string( 'blabla' ), 'bytes_display_string: blabla => NA' ) ; |
| 12156 | |
| 12157 | ok( '0.000 KiB' eq bytes_display_string( 0 ), 'bytes_display_string: 0' ) ; |
| 12158 | ok( '0.001 KiB' eq bytes_display_string( 1 ), 'bytes_display_string: 1' ) ; |
| 12159 | ok( '0.010 KiB' eq bytes_display_string( 10 ), 'bytes_display_string: 10' ) ; |
| 12160 | ok( '1.000 MiB' eq bytes_display_string( 1_048_575 ), 'bytes_display_string: 1_048_575' ) ; |
| 12161 | ok( '1.000 MiB' eq bytes_display_string( 1_048_576 ), 'bytes_display_string: 1_048_576' ) ; |
| 12162 | |
| 12163 | ok( '1.000 GiB' eq bytes_display_string( 1_073_741_823 ), 'bytes_display_string: 1_073_741_823 ' ) ; |
| 12164 | ok( '1.000 GiB' eq bytes_display_string( 1_073_741_824 ), 'bytes_display_string: 1_073_741_824 ' ) ; |
| 12165 | |
| 12166 | ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_775 ), 'bytes_display_string: 1_099_511_627_775' ) ; |
| 12167 | ok( '1.000 TiB' eq bytes_display_string( 1_099_511_627_776 ), 'bytes_display_string: 1_099_511_627_776' ) ; |
| 12168 | |
| 12169 | ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_623 ), 'bytes_display_string: 1_125_899_906_842_623' ) ; |
| 12170 | ok( '1.000 PiB' eq bytes_display_string( 1_125_899_906_842_624 ), 'bytes_display_string: 1_125_899_906_842_624' ) ; |
| 12171 | |
| 12172 | ok( '1024.000 PiB' eq bytes_display_string( 1_152_921_504_606_846_975 ), 'bytes_display_string: 1_152_921_504_606_846_975' ) ; |
| 12173 | ok( '1024.000 PiB' eq bytes_display_string( 1_152_921_504_606_846_976 ), 'bytes_display_string: 1_152_921_504_606_846_976' ) ; |
| 12174 | |
| 12175 | ok( '1048576.000 PiB' eq bytes_display_string( 1_180_591_620_717_411_303_424 ), 'bytes_display_string: 1_180_591_620_717_411_303_424' ) ; |
| 12176 | |
| 12177 | #myprint( bytes_display_string( 1_180_591_620_717_411_303_424 ), "\n" ) ; |
| 12178 | note( 'Leaving tests_bytes_display_string()' ) ; |
| 12179 | |
| 12180 | return ; |
| 12181 | } |
| 12182 | |
| 12183 | sub bytes_display_string |
| 12184 | { |
| 12185 | my ( $bytes ) = @_ ; |
| 12186 | |
| 12187 | my $readable_value = q{} ; |
| 12188 | |
| 12189 | if ( ! defined( $bytes ) ) { |
| 12190 | return( 'NA' ) ; |
| 12191 | } |
| 12192 | |
| 12193 | if ( not match_number( $bytes ) ) { |
| 12194 | return( 'NA' ) ; |
| 12195 | } |
| 12196 | |
| 12197 | |
| 12198 | |
| 12199 | SWITCH: { |
| 12200 | if ( abs( $bytes ) < ( 1000 * $KIBI ) ) { |
| 12201 | $readable_value = mysprintf( '%.3f KiB', $bytes / $KIBI) ; |
| 12202 | last SWITCH ; |
| 12203 | } |
| 12204 | if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI ) ) { |
| 12205 | $readable_value = mysprintf( '%.3f MiB', $bytes / ($KIBI * $KIBI) ) ; |
| 12206 | last SWITCH ; |
| 12207 | } |
| 12208 | if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI) ) { |
| 12209 | $readable_value = mysprintf( '%.3f GiB', $bytes / ($KIBI * $KIBI * $KIBI) ) ; |
| 12210 | last SWITCH ; |
| 12211 | } |
| 12212 | if ( abs( $bytes ) < ( 1000 * $KIBI * $KIBI * $KIBI * $KIBI) ) { |
| 12213 | $readable_value = mysprintf( '%.3f TiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI) ) ; |
| 12214 | last SWITCH ; |
| 12215 | } else { |
| 12216 | $readable_value = mysprintf( '%.3f PiB', $bytes / ($KIBI * $KIBI * $KIBI * $KIBI * $KIBI) ) ; |
| 12217 | } |
| 12218 | # if you have exabytes (EiB) of email to transfer, you have too much email! |
| 12219 | } |
| 12220 | #myprint( "$bytes = $readable_value\n" ) ; |
| 12221 | return( $readable_value ) ; |
| 12222 | } |
| 12223 | |
| 12224 | |
| 12225 | sub tests_useheader_suggestion |
| 12226 | { |
| 12227 | note( 'Entering tests_useheader_suggestion()' ) ; |
| 12228 | |
| 12229 | is( undef, useheader_suggestion( ), 'useheader_suggestion: no args => undef' ) ; |
| 12230 | my $mysync = {} ; |
| 12231 | |
| 12232 | $mysync->{ h1_nb_msg_noheader } = 0 ; |
| 12233 | is( q{}, useheader_suggestion( $mysync ), 'useheader_suggestion: h1_nb_msg_noheader count null => no suggestion' ) ; |
| 12234 | $mysync->{ h1_nb_msg_noheader } = 2 ; |
| 12235 | is( q{in order to sync those 2 unidentified messages, add option --addheader}, useheader_suggestion( $mysync ), |
| 12236 | 'useheader_suggestion: h1_nb_msg_noheader count 2 => suggestion of --addheader' ) ; |
| 12237 | |
| 12238 | note( 'Leaving tests_useheader_suggestion()' ) ; |
| 12239 | return ; |
| 12240 | } |
| 12241 | |
| 12242 | sub useheader_suggestion |
| 12243 | { |
| 12244 | my $mysync = shift ; |
| 12245 | if ( ! defined $mysync->{ h1_nb_msg_noheader } ) |
| 12246 | { |
| 12247 | return ; |
| 12248 | } |
| 12249 | elsif ( 1 <= $mysync->{ h1_nb_msg_noheader } ) |
| 12250 | { |
| 12251 | return qq{in order to sync those $mysync->{ h1_nb_msg_noheader } unidentified messages, add option --addheader} ; |
| 12252 | } |
| 12253 | else |
| 12254 | { |
| 12255 | return q{} ; |
| 12256 | } |
| 12257 | return ; |
| 12258 | } |
| 12259 | |
| 12260 | sub stats |
| 12261 | { |
| 12262 | my $mysync = shift ; |
| 12263 | |
| 12264 | if ( ! $mysync->{stats} ) { |
| 12265 | return ; |
| 12266 | } |
| 12267 | |
| 12268 | my $timeend = time ; |
| 12269 | my $timediff = $timeend - $mysync->{timestart} ; |
| 12270 | |
| 12271 | my $timeend_str = localtime $timeend ; |
| 12272 | |
| 12273 | my $memory_consumption_at_end = memory_consumption( ) || 0 ; |
| 12274 | my $memory_consumption_at_start = $mysync->{ memory_consumption_at_start } || 0 ; |
| 12275 | my $memory_ratio = ($max_msg_size_in_bytes) ? |
| 12276 | mysprintf('%.1f', $memory_consumption_at_end / $max_msg_size_in_bytes) : 'NA' ; |
| 12277 | |
| 12278 | # my $useheader_suggestion = useheader_suggestion( $mysync ) ; |
| 12279 | myprint( "++++ Statistics\n" ) ; |
| 12280 | myprint( "Transfer started on : $timestart_str\n" ) ; |
| 12281 | myprint( "Transfer ended on : $timeend_str\n" ) ; |
| 12282 | myprintf( "Transfer time : %.1f sec\n", $timediff ) ; |
| 12283 | myprint( "Folders synced : $h1_folders_wanted_ct/$h1_folders_wanted_nb synced\n" ) ; |
| 12284 | myprint( "Messages transferred : $mysync->{ nb_msg_transferred } " ) ; |
| 12285 | myprint( "(could be $nb_msg_skipped_dry_mode without dry mode)" ) if ( $mysync->{dry} ) ; |
| 12286 | myprint( "\n" ) ; |
| 12287 | myprint( "Messages skipped : $mysync->{ nb_msg_skipped }\n" ) ; |
| 12288 | myprint( "Messages found duplicate on host1 : $h1_nb_msg_duplicate\n" ) ; |
| 12289 | myprint( "Messages found duplicate on host2 : $h2_nb_msg_duplicate\n" ) ; |
| 12290 | myprint( "Messages found crossduplicate on host2 : $mysync->{ h2_nb_msg_crossdup }\n" ) ; |
| 12291 | myprint( "Messages void (noheader) on host1 : $mysync->{ h1_nb_msg_noheader } ", useheader_suggestion( $mysync ), "\n" ) ; |
| 12292 | myprint( "Messages void (noheader) on host2 : $h2_nb_msg_noheader\n" ) ; |
| 12293 | nb_messages_in_1_not_in_2( $mysync ) ; |
| 12294 | nb_messages_in_2_not_in_1( $mysync ) ; |
| 12295 | myprintf( "Messages found in host1 not in host2 : %s messages\n", $mysync->{ nb_messages_in_1_not_in_2 } ) ; |
| 12296 | myprintf( "Messages found in host2 not in host1 : %s messages\n", $mysync->{ nb_messages_in_2_not_in_1 } ) ; |
| 12297 | myprint( "Messages deleted on host1 : $mysync->{ h1_nb_msg_deleted }\n" ) ; |
| 12298 | myprint( "Messages deleted on host2 : $h2_nb_msg_deleted\n" ) ; |
| 12299 | myprintf( "Total bytes transferred : %s (%s)\n", |
| 12300 | $mysync->{total_bytes_transferred}, |
| 12301 | bytes_display_string( $mysync->{total_bytes_transferred} ) ) ; |
| 12302 | myprintf( "Total bytes skipped : %s (%s)\n", |
| 12303 | $mysync->{ total_bytes_skipped }, |
| 12304 | bytes_display_string( $mysync->{ total_bytes_skipped } ) ) ; |
| 12305 | $timediff ||= 1 ; # No division per 0 |
| 12306 | myprintf("Message rate : %.1f messages/s\n", $mysync->{nb_msg_transferred} / $timediff ) ; |
| 12307 | myprintf("Average bandwidth rate : %.1f KiB/s\n", $mysync->{total_bytes_transferred} / $KIBI / $timediff ) ; |
| 12308 | myprint( "Reconnections to host1 : $mysync->{imap1}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; |
| 12309 | myprint( "Reconnections to host2 : $mysync->{imap2}->{IMAPSYNC_RECONNECT_COUNT}\n" ) ; |
| 12310 | myprintf("Memory consumption at the end : %.1f MiB (started with %.1f MiB)\n", |
| 12311 | $memory_consumption_at_end / $KIBI / $KIBI, |
| 12312 | $memory_consumption_at_start / $KIBI / $KIBI ) ; |
| 12313 | myprint( "Load end is : " . ( join( q{ }, loadavg( ) ) || 'unknown' ), " on $mysync->{cpu_number} cores\n" ) ; |
| 12314 | |
| 12315 | myprintf("Biggest message : %s bytes (%s)\n", |
| 12316 | $max_msg_size_in_bytes, |
| 12317 | bytes_display_string( $max_msg_size_in_bytes) ) ; |
| 12318 | myprint( "Memory/biggest message ratio : $memory_ratio\n" ) ; |
| 12319 | if ( $mysync->{ foldersizesatend } and $mysync->{ foldersizes } ) { |
| 12320 | |
| 12321 | |
| 12322 | my $nb_msg_start_diff = diff_or_NA( $mysync->{ h2_nb_msg_start }, $mysync->{ h1_nb_msg_start } ) ; |
| 12323 | my $bytes_start_diff = diff_or_NA( $mysync->{ h2_bytes_start }, $mysync->{ h1_bytes_start } ) ; |
| 12324 | |
| 12325 | myprintf("Start difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_start_diff, |
| 12326 | $bytes_start_diff, |
| 12327 | bytes_display_string( $bytes_start_diff ) ) ; |
| 12328 | |
| 12329 | my $nb_msg_end_diff = diff_or_NA( $h2_nb_msg_end, $h1_nb_msg_end ) ; |
| 12330 | my $bytes_end_diff = diff_or_NA( $h2_bytes_end, $h1_bytes_end ) ; |
| 12331 | |
| 12332 | myprintf("Final difference host2 - host1 : %s messages, %s bytes (%s)\n", $nb_msg_end_diff, |
| 12333 | $bytes_end_diff, |
| 12334 | bytes_display_string( $bytes_end_diff ) ) ; |
| 12335 | } |
| 12336 | |
| 12337 | comment_on_final_diff_in_1_not_in_2( $mysync ) ; |
| 12338 | comment_on_final_diff_in_2_not_in_1( $mysync ) ; |
| 12339 | myprint( "Detected $mysync->{nb_errors} errors\n\n" ) ; |
| 12340 | |
| 12341 | myprint( $warn_release, "\n" ) ; |
| 12342 | myprint( homepage( ), "\n" ) ; |
| 12343 | return ; |
| 12344 | } |
| 12345 | |
| 12346 | sub diff_or_NA |
| 12347 | { |
| 12348 | my( $n1, $n2 ) = @ARG ; |
| 12349 | |
| 12350 | if ( not defined $n1 or not defined $n2 ) { |
| 12351 | return 'NA' ; |
| 12352 | } |
| 12353 | |
| 12354 | if ( not match_number( $n1 ) |
| 12355 | or not match_number( $n2 ) ) { |
| 12356 | return 'NA' ; |
| 12357 | } |
| 12358 | |
| 12359 | return( $n1 - $n2 ) ; |
| 12360 | } |
| 12361 | |
| 12362 | sub match_number |
| 12363 | { |
| 12364 | my $n = shift @ARG ; |
| 12365 | |
| 12366 | if ( not defined $n ) { |
| 12367 | return 0 ; |
| 12368 | } |
| 12369 | if ( $n =~ /[0-9]+\.?[0-9]?/x ) { |
| 12370 | return 1 ; |
| 12371 | } |
| 12372 | else { |
| 12373 | return 0 ; |
| 12374 | } |
| 12375 | } |
| 12376 | |
| 12377 | |
| 12378 | sub tests_match_number |
| 12379 | { |
| 12380 | note( 'Entering tests_match_number()' ) ; |
| 12381 | |
| 12382 | |
| 12383 | is( 0, match_number( ), 'match_number: no parameters => 0' ) ; |
| 12384 | is( 0, match_number( undef ), 'match_number: undef => 0' ) ; |
| 12385 | is( 0, match_number( 'blabla' ), 'match_number: blabla => 0' ) ; |
| 12386 | is( 1, match_number( 0 ), 'match_number: 0 => 1' ) ; |
| 12387 | is( 1, match_number( 1 ), 'match_number: 1 => 1' ) ; |
| 12388 | is( 1, match_number( 1.0 ), 'match_number: 1.0 => 1' ) ; |
| 12389 | is( 1, match_number( 0.0 ), 'match_number: 0.0 => 1' ) ; |
| 12390 | |
| 12391 | note( 'Leaving tests_match_number()' ) ; |
| 12392 | return ; |
| 12393 | } |
| 12394 | |
| 12395 | |
| 12396 | |
| 12397 | sub tests_diff_or_NA |
| 12398 | { |
| 12399 | note( 'Entering tests_diff_or_NA()' ) ; |
| 12400 | |
| 12401 | |
| 12402 | is( 'NA', diff_or_NA( ), 'diff_or_NA: no parameters => NA' ) ; |
| 12403 | is( 'NA', diff_or_NA( undef ), 'diff_or_NA: undef => NA' ) ; |
| 12404 | is( 'NA', diff_or_NA( undef, undef ), 'diff_or_NA: undef undef => NA' ) ; |
| 12405 | is( 'NA', diff_or_NA( undef, 1 ), 'diff_or_NA: undef 1 => NA' ) ; |
| 12406 | is( 'NA', diff_or_NA( 1, undef ), 'diff_or_NA: 1 undef => NA' ) ; |
| 12407 | is( 'NA', diff_or_NA( 'blabla', 1 ), 'diff_or_NA: blabla 1 => NA' ) ; |
| 12408 | is( 'NA', diff_or_NA( 1, 'blabla' ), 'diff_or_NA: 1 blabla => NA' ) ; |
| 12409 | is( 0, diff_or_NA( 1, 1 ), 'diff_or_NA: 1 1 => 0' ) ; |
| 12410 | is( 1, diff_or_NA( 1, 0 ), 'diff_or_NA: 1 0 => 1' ) ; |
| 12411 | is( -1, diff_or_NA( 0, 1 ), 'diff_or_NA: 0 1 => -1' ) ; |
| 12412 | is( 0, diff_or_NA( 1.0, 1 ), 'diff_or_NA: 1.0 1 => 0' ) ; |
| 12413 | is( 1, diff_or_NA( 1.0, 0 ), 'diff_or_NA: 1.0 0 => 1' ) ; |
| 12414 | is( -1, diff_or_NA( 0, 1.0 ), 'diff_or_NA: 0 1.0 => -1' ) ; |
| 12415 | |
| 12416 | note( 'Leaving tests_diff_or_NA()' ) ; |
| 12417 | return ; |
| 12418 | } |
| 12419 | |
| 12420 | sub homepage |
| 12421 | { |
| 12422 | return( 'Homepage: https://imapsync.lamiral.info/' ) ; |
| 12423 | } |
| 12424 | |
| 12425 | |
| 12426 | sub load_modules |
| 12427 | { |
| 12428 | if ( $sync->{ssl1} |
| 12429 | or $sync->{ssl2} |
| 12430 | or $sync->{tls1} |
| 12431 | or $sync->{tls2}) { |
| 12432 | if ( $sync->{inet4} ) { |
| 12433 | IO::Socket::SSL->import( 'inet4' ) ; |
| 12434 | } |
| 12435 | if ( $sync->{inet6} ) { |
| 12436 | IO::Socket::SSL->import( 'inet6' ) ; |
| 12437 | } |
| 12438 | } |
| 12439 | return ; |
| 12440 | } |
| 12441 | |
| 12442 | |
| 12443 | |
| 12444 | sub parse_header_msg |
| 12445 | { |
| 12446 | my ( $mysync, $imap, $m_uid, $s_heads, $s_fir, $side, $s_hash ) = @_ ; |
| 12447 | |
| 12448 | my $head = $s_heads->{$m_uid} ; |
| 12449 | my $headnum = scalar keys %{ $head } ; |
| 12450 | $mysync->{ debug } and myprint( "$side: uid $m_uid number of headers, pass one: ", $headnum, "\n" ) ; |
| 12451 | |
| 12452 | if ( ( ! $headnum ) and ( $wholeheaderifneeded ) ){ |
| 12453 | $mysync->{ debug } and myprint( "$side: uid $m_uid no header by parse_headers so taking whole header with BODY.PEEK[HEADER]\n" ) ; |
| 12454 | $imap->fetch($m_uid, 'BODY.PEEK[HEADER]' ) ; |
| 12455 | my $whole_header = $imap->_transaction_literals ; |
| 12456 | |
| 12457 | #myprint( $whole_header ) ; |
| 12458 | $head = decompose_header( $whole_header ) ; |
| 12459 | |
| 12460 | $headnum = scalar keys %{ $head } ; |
| 12461 | $mysync->{ debug } and myprint( "$side: uid $m_uid number of headers, pass two: ", $headnum, "\n" ) ; |
| 12462 | } |
| 12463 | |
| 12464 | #myprint( Data::Dumper->Dump( [ $head, \%useheader ] ) ) ; |
| 12465 | |
| 12466 | my $headstr ; |
| 12467 | |
| 12468 | $headstr = header_construct( $head, $side, $m_uid ) ; |
| 12469 | |
| 12470 | if ( ( ! $headstr ) and ( $mysync->{addheader} ) and ( $side eq 'Host1' ) ) { |
| 12471 | my $header = add_header( $m_uid ) ; |
| 12472 | $mysync->{ debug } and myprint( "$side: uid $m_uid no header found so adding our own [$header]\n" ) ; |
| 12473 | $headstr .= uc $header ; |
| 12474 | $s_fir->{$m_uid}->{NO_HEADER} = 1; |
| 12475 | } |
| 12476 | |
| 12477 | return if ( ! $headstr ) ; |
| 12478 | |
| 12479 | my $size = $s_fir->{$m_uid}->{'RFC822.SIZE'} ; |
| 12480 | my $flags = $s_fir->{$m_uid}->{'FLAGS'} ; |
| 12481 | my $idate = $s_fir->{$m_uid}->{'INTERNALDATE'} ; |
| 12482 | $size = length $headstr unless ( $size ) ; |
| 12483 | my $m_md5 = md5_base64( $headstr ) ; |
| 12484 | $mysync->{ debug } and myprint( "$side: uid $m_uid sig $m_md5 size $size idate $idate\n" ) ; |
| 12485 | my $key ; |
| 12486 | if ($skipsize) { |
| 12487 | $key = "$m_md5"; |
| 12488 | } |
| 12489 | else { |
| 12490 | $key = "$m_md5:$size"; |
| 12491 | } |
| 12492 | # 0 return code is used to identify duplicate message hash |
| 12493 | return 0 if exists $s_hash->{"$key"}; |
| 12494 | $s_hash->{"$key"}{'5'} = $m_md5; |
| 12495 | $s_hash->{"$key"}{'s'} = $size; |
| 12496 | $s_hash->{"$key"}{'D'} = $idate; |
| 12497 | $s_hash->{"$key"}{'F'} = $flags; |
| 12498 | $s_hash->{"$key"}{'m'} = $m_uid; |
| 12499 | |
| 12500 | return( 1 ) ; |
| 12501 | } |
| 12502 | |
| 12503 | sub header_construct |
| 12504 | { |
| 12505 | |
| 12506 | my( $head, $side, $m_uid ) = @_ ; |
| 12507 | |
| 12508 | my $headstr ; |
| 12509 | foreach my $h ( sort keys %{ $head } ) { |
| 12510 | next if ( not ( exists $useheader{ uc $h } ) |
| 12511 | and ( not exists $useheader{ 'ALL' } ) |
| 12512 | ) ; |
| 12513 | foreach my $val ( sort @{$head->{$h}} ) { |
| 12514 | |
| 12515 | my $H = header_line_normalize( $h, $val ) ; |
| 12516 | |
| 12517 | # show stuff in debug mode |
| 12518 | $sync->{ debug } and myprint( "$side uid $m_uid header [$H]", "\n" ) ; |
| 12519 | |
| 12520 | if ($skipheader and $H =~ m/$skipheader/xi) { |
| 12521 | $sync->{ debug } and myprint( "$side uid $m_uid skipping header [$H]\n" ) ; |
| 12522 | next ; |
| 12523 | } |
| 12524 | $headstr .= "$H" ; |
| 12525 | } |
| 12526 | } |
| 12527 | return( $headstr ) ; |
| 12528 | } |
| 12529 | |
| 12530 | |
| 12531 | sub header_line_normalize |
| 12532 | { |
| 12533 | my( $header_key, $header_val ) = @_ ; |
| 12534 | |
| 12535 | # no 8-bit data in headers ! |
| 12536 | $header_val =~ s/[\x80-\xff]/X/xog; |
| 12537 | |
| 12538 | # change tabulations to space (Gmail bug on with "Received:" on multilines) |
| 12539 | $header_val =~ s/\t/\ /xgo ; |
| 12540 | |
| 12541 | # remove the first blanks ( dbmail bug? ) |
| 12542 | $header_val =~ s/^\s*//xo; |
| 12543 | |
| 12544 | # remove the last blanks ( Gmail bug ) |
| 12545 | $header_val =~ s/\s*$//xo; |
| 12546 | |
| 12547 | # remove successive blanks ( Mailenable does it ) |
| 12548 | $header_val =~ s/\s+/ /xgo; |
| 12549 | |
| 12550 | # remove Message-Id value domain part ( Mailenable changes it ) |
| 12551 | if ( ( $messageidnodomain ) and ( 'MESSAGE-ID' eq uc $header_key ) ) { $header_val =~ s/^([^@]+).*$/$1/xo ; } |
| 12552 | |
| 12553 | # and uppercase header line |
| 12554 | # (dbmail and dovecot) |
| 12555 | |
| 12556 | my $header_line = uc "$header_key: $header_val" ; |
| 12557 | |
| 12558 | return( $header_line ) ; |
| 12559 | } |
| 12560 | |
| 12561 | sub tests_header_line_normalize |
| 12562 | { |
| 12563 | note( 'Entering tests_header_line_normalize()' ) ; |
| 12564 | |
| 12565 | |
| 12566 | ok( ': ' eq header_line_normalize( q{}, q{} ), 'header_line_normalize: empty args' ) ; |
| 12567 | ok( 'HHH: VVV' eq header_line_normalize( 'hhh', 'vvv' ), 'header_line_normalize: hhh vvv ' ) ; |
| 12568 | ok( 'HHH: VVV' eq header_line_normalize( 'hhh', ' vvv' ), 'header_line_normalize: remove first blancs' ) ; |
| 12569 | ok( 'HHH: AA BB CCC D' eq header_line_normalize( 'hhh', 'aa bb ccc d' ), 'header_line_normalize: remove succesive blanks' ) ; |
| 12570 | ok( 'HHH: AA BB CCC' eq header_line_normalize( 'hhh', 'aa bb ccc ' ), 'header_line_normalize: remove last blanks' ) ; |
| 12571 | ok( 'HHH: VVV XX YY' eq header_line_normalize( 'hhh', "vvv\t\txx\tyy" ), 'header_line_normalize: tabs' ) ; |
| 12572 | ok( 'HHH: XABX' eq header_line_normalize( 'hhh', "\x80AB\xff" ), 'header_line_normalize: 8bit' ) ; |
| 12573 | |
| 12574 | note( 'Leaving tests_header_line_normalize()' ) ; |
| 12575 | return ; |
| 12576 | } |
| 12577 | |
| 12578 | |
| 12579 | sub tests_firstline |
| 12580 | { |
| 12581 | note( 'Entering tests_firstline()' ) ; |
| 12582 | |
| 12583 | is( q{}, firstline( 'W/tmp/tests/noexist.txt' ), 'firstline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; |
| 12584 | |
| 12585 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'firstline: mkpath W/tmp/tests/' ) ; |
| 12586 | |
| 12587 | is( "blabla\n" , string_to_file( "blabla\n", 'W/tmp/tests/firstline.txt' ), 'firstline: put blabla in W/tmp/tests/firstline.txt' ) ; |
| 12588 | is( 'blabla' , firstline( 'W/tmp/tests/firstline.txt' ), 'firstline: get blabla from W/tmp/tests/firstline.txt' ) ; |
| 12589 | |
| 12590 | is( q{} , string_to_file( q{}, 'W/tmp/tests/firstline2.txt' ), 'firstline: put empty string in W/tmp/tests/firstline2.txt' ) ; |
| 12591 | is( q{} , firstline( 'W/tmp/tests/firstline2.txt' ), 'firstline: get empty string from W/tmp/tests/firstline2.txt' ) ; |
| 12592 | |
| 12593 | is( "\n" , string_to_file( "\n", 'W/tmp/tests/firstline3.txt' ), 'firstline: put CR in W/tmp/tests/firstline3.txt' ) ; |
| 12594 | is( q{} , firstline( 'W/tmp/tests/firstline3.txt' ), 'firstline: get empty string from W/tmp/tests/firstline3.txt' ) ; |
| 12595 | |
| 12596 | is( "blabla\nTiti\n" , string_to_file( "blabla\nTiti\n", 'W/tmp/tests/firstline4.txt' ), 'firstline: put blabla\nTiti\n in W/tmp/tests/firstline4.txt' ) ; |
| 12597 | is( 'blabla' , firstline( 'W/tmp/tests/firstline4.txt' ), 'firstline: get blabla from W/tmp/tests/firstline4.txt' ) ; |
| 12598 | |
| 12599 | note( 'Leaving tests_firstline()' ) ; |
| 12600 | return ; |
| 12601 | } |
| 12602 | |
| 12603 | sub firstline |
| 12604 | { |
| 12605 | # extract the first line of a file (without \n) |
| 12606 | # return empty string if error or empty string |
| 12607 | |
| 12608 | my $file = shift ; |
| 12609 | my $line ; |
| 12610 | |
| 12611 | $line = nthline( $file, 1 ) ; |
| 12612 | return $line ; |
| 12613 | } |
| 12614 | |
| 12615 | |
| 12616 | |
| 12617 | sub tests_secondline |
| 12618 | { |
| 12619 | note( 'Entering tests_secondline()' ) ; |
| 12620 | |
| 12621 | is( q{}, secondline( 'W/tmp/tests/noexist.txt' ), 'secondline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; |
| 12622 | is( q{}, secondline( 'W/tmp/tests/noexist.txt', 2 ), 'secondline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; |
| 12623 | |
| 12624 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'secondline: mkpath W/tmp/tests/' ) ; |
| 12625 | |
| 12626 | is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/secondline.txt' ), 'secondline: put L1\nL2\nL3\nL4\n in W/tmp/tests/secondline.txt' ) ; |
| 12627 | is( 'L2' , secondline( 'W/tmp/tests/secondline.txt' ), 'secondline: get L2 from W/tmp/tests/secondline.txt' ) ; |
| 12628 | |
| 12629 | |
| 12630 | note( 'Leaving tests_secondline()' ) ; |
| 12631 | return ; |
| 12632 | } |
| 12633 | |
| 12634 | |
| 12635 | sub secondline |
| 12636 | { |
| 12637 | # extract the second line of a file (without \n) |
| 12638 | # return empty string if error or empty string |
| 12639 | |
| 12640 | my $file = shift ; |
| 12641 | my $line ; |
| 12642 | |
| 12643 | $line = nthline( $file, 2 ) ; |
| 12644 | return $line ; |
| 12645 | } |
| 12646 | |
| 12647 | |
| 12648 | |
| 12649 | |
| 12650 | sub tests_nthline |
| 12651 | { |
| 12652 | note( 'Entering tests_nthline()' ) ; |
| 12653 | |
| 12654 | is( q{}, nthline( 'W/tmp/tests/noexist.txt' ), 'nthline: getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; |
| 12655 | is( q{}, nthline( 'W/tmp/tests/noexist.txt', 2 ), 'nthline: 2nd getting empty string from inexisting W/tmp/tests/noexist.txt' ) ; |
| 12656 | |
| 12657 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'nthline: mkpath W/tmp/tests/' ) ; |
| 12658 | |
| 12659 | is( "L1\nL2\nL3\nL4\n" , string_to_file( "L1\nL2\nL3\nL4\n", 'W/tmp/tests/nthline.txt' ), 'nthline: put L1\nL2\nL3\nL4\n in W/tmp/tests/nthline.txt' ) ; |
| 12660 | is( 'L3' , nthline( 'W/tmp/tests/nthline.txt', 3 ), 'nthline: get L3 from W/tmp/tests/nthline.txt' ) ; |
| 12661 | |
| 12662 | |
| 12663 | note( 'Leaving tests_nthline()' ) ; |
| 12664 | return ; |
| 12665 | } |
| 12666 | |
| 12667 | |
| 12668 | sub nthline |
| 12669 | { |
| 12670 | # extract the nth line of a file (without \n) |
| 12671 | # return empty string if error or empty string |
| 12672 | |
| 12673 | my $file = shift ; |
| 12674 | my $num = shift ; |
| 12675 | |
| 12676 | if ( ! all_defined( $file, $num ) ) { return q{} ; } |
| 12677 | |
| 12678 | my $line ; |
| 12679 | |
| 12680 | $line = ( file_to_array( $file ) )[$num - 1] ; |
| 12681 | if ( ! defined $line ) |
| 12682 | { |
| 12683 | return q{} ; |
| 12684 | } |
| 12685 | else |
| 12686 | { |
| 12687 | chomp $line ; |
| 12688 | return $line ; |
| 12689 | } |
| 12690 | } |
| 12691 | |
| 12692 | |
| 12693 | # Should be unit tested and then be used by file_to_string, refactoring file_to_string |
| 12694 | sub file_to_array |
| 12695 | { |
| 12696 | |
| 12697 | my( $file ) = shift ; |
| 12698 | my @string ; |
| 12699 | |
| 12700 | open my $FILE, '<', $file or do { |
| 12701 | myprint( "Error reading file $file : $OS_ERROR\n" ) ; |
| 12702 | return ; |
| 12703 | } ; |
| 12704 | @string = <$FILE> ; |
| 12705 | close $FILE ; |
| 12706 | return( @string ) ; |
| 12707 | } |
| 12708 | |
| 12709 | |
| 12710 | sub tests_file_to_string |
| 12711 | { |
| 12712 | note( 'Entering tests_file_to_string()' ) ; |
| 12713 | |
| 12714 | is( undef, file_to_string( ), 'file_to_string: no args => undef' ) ; |
| 12715 | is( undef, file_to_string( '/noexist' ), 'file_to_string: /noexist => undef' ) ; |
| 12716 | is( undef, file_to_string( '/' ), 'file_to_string: reading a directory => undef' ) ; |
| 12717 | ok( file_to_string( $PROGRAM_NAME ), 'file_to_string: reading myself' ) ; |
| 12718 | |
| 12719 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'file_to_string: mkpath W/tmp/tests/' ) ; |
| 12720 | |
| 12721 | is( 'lilili', string_to_file( 'lilili', 'W/tmp/tests/canbewritten' ), 'file_to_string: string_to_file filling W/tmp/tests/canbewritten with lilili' ) ; |
| 12722 | is( 'lilili', file_to_string( 'W/tmp/tests/canbewritten' ), 'file_to_string: reading W/tmp/tests/canbewritten is lilili' ) ; |
| 12723 | |
| 12724 | is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'file_to_string: string_to_file filling W/tmp/tests/empty with empty string' ) ; |
| 12725 | is( q{}, file_to_string( 'W/tmp/tests/empty' ), 'file_to_string: reading W/tmp/tests/empty is empty' ) ; |
| 12726 | |
| 12727 | note( 'Leaving tests_file_to_string()' ) ; |
| 12728 | return ; |
| 12729 | } |
| 12730 | |
| 12731 | sub file_to_string |
| 12732 | { |
| 12733 | my $file = shift ; |
| 12734 | if ( ! $file ) { return ; } |
| 12735 | if ( ! -e $file ) { return ; } |
| 12736 | if ( ! -f $file ) { return ; } |
| 12737 | if ( ! -r $file ) { return ; } |
| 12738 | my @string ; |
| 12739 | if ( open my $FILE, '<', $file ) { |
| 12740 | @string = <$FILE> ; |
| 12741 | close $FILE ; |
| 12742 | return( join q{}, @string ) ; |
| 12743 | }else{ |
| 12744 | myprint( "Error reading file $file : $OS_ERROR\n" ) ; |
| 12745 | return ; |
| 12746 | } |
| 12747 | } |
| 12748 | |
| 12749 | |
| 12750 | sub tests_string_to_file |
| 12751 | { |
| 12752 | note( 'Entering tests_string_to_file()' ) ; |
| 12753 | |
| 12754 | is( undef, string_to_file( ), 'string_to_file: no args => undef' ) ; |
| 12755 | is( undef, string_to_file( 'lalala' ), 'string_to_file: one arg => undef' ) ; |
| 12756 | is( undef, string_to_file( 'lalala', '.' ), 'string_to_file: writing a directory => undef' ) ; |
| 12757 | ok( (-d 'W/tmp/tests/' or mkpath( 'W/tmp/tests/' ) ), 'string_to_file: mkpath W/tmp/tests/' ) ; |
| 12758 | is( 'lalala', string_to_file( 'lalala', 'W/tmp/tests/canbewritten' ), 'string_to_file: W/tmp/tests/canbewritten with lalala' ) ; |
| 12759 | is( q{}, string_to_file( q{}, 'W/tmp/tests/empty' ), 'string_to_file: W/tmp/tests/empty with empty string' ) ; |
| 12760 | |
| 12761 | SKIP: { |
| 12762 | Readonly my $NB_UNX_tests_string_to_file => 1 ; |
| 12763 | skip( 'Not on Unix non-root', $NB_UNX_tests_string_to_file ) if ('MSWin32' eq $OSNAME or '0' eq $EFFECTIVE_USER_ID ) ; |
| 12764 | is( undef, string_to_file( 'lalala', '/cantouch' ), 'string_to_file: /cantouch denied => undef' ) ; |
| 12765 | } |
| 12766 | |
| 12767 | note( 'Leaving tests_string_to_file()' ) ; |
| 12768 | return ; |
| 12769 | } |
| 12770 | |
| 12771 | sub string_to_file |
| 12772 | { |
| 12773 | my( $string, $file ) = @_ ; |
| 12774 | if( ! defined $string ) { return ; } |
| 12775 | if( ! defined $file ) { return ; } |
| 12776 | |
| 12777 | if ( ! -e $file && ! -w dirname( $file ) ) { |
| 12778 | myprint( "string_to_file: directory of $file is not writable\n" ) ; |
| 12779 | return ; |
| 12780 | } |
| 12781 | |
| 12782 | if ( ! sysopen( FILE, $file, O_WRONLY|O_TRUNC|O_CREAT, 0600) ) { |
| 12783 | myprint( "string_to_file: failure writing to $file with error: $OS_ERROR\n" ) ; |
| 12784 | return ; |
| 12785 | } |
| 12786 | print FILE $string ; |
| 12787 | close FILE ; |
| 12788 | return $string ; |
| 12789 | } |
| 12790 | |
| 12791 | 0 and <<'MULTILINE_COMMENT' ; |
| 12792 | This is a multiline comment. |
| 12793 | Based on David Carter discussion, to do: |
| 12794 | * Call parameters stay the same. |
| 12795 | * Now always "return( $string, $error )". Descriptions below. |
| 12796 | OK * Still capture STDOUT via "1> $output_tmpfile" to finish in $string and "return( $string, $error )" |
| 12797 | OK * Now also capture STDERR via "2> $error_tmpfile" to finish in $error and "return( $string, $error )" |
| 12798 | OK * in case of CHILD_ERROR, return( undef, $error ) |
| 12799 | and print $error, with folder/UID/maybeSubject context, |
| 12800 | on console and at the end with the final error listing. Count this as a sync error. |
| 12801 | * in case of good command, take final $string as is, unless void. In case $error with value then print it. |
| 12802 | * in case of good command and final $string empty, consider it like CHILD_ERROR => |
| 12803 | return( undef, $error ) and print $error, with folder/UID/maybeSubject context, |
| 12804 | on console and at the end with the final error listing. Count this as a sync error. |
| 12805 | MULTILINE_COMMENT |
| 12806 | # End of multiline comment. |
| 12807 | |
| 12808 | sub pipemess |
| 12809 | { |
| 12810 | my ( $string, @commands ) = @_ ; |
| 12811 | my $error = q{} ; |
| 12812 | foreach my $command ( @commands ) { |
| 12813 | my $input_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.inp.txt" ; |
| 12814 | my $output_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.out.txt" ; |
| 12815 | my $error_tmpfile = "$sync->{ tmpdir }/imapsync_tmp_file.$PROCESS_ID.err.txt" ; |
| 12816 | string_to_file( $string, $input_tmpfile ) ; |
| 12817 | ` $command < $input_tmpfile 1> $output_tmpfile 2> $error_tmpfile ` ; |
| 12818 | my $is_command_ko = $CHILD_ERROR ; |
| 12819 | my $error_cmd = file_to_string( $error_tmpfile ) ; |
| 12820 | chomp( $error_cmd ) ; |
| 12821 | $string = file_to_string( $output_tmpfile ) ; |
| 12822 | my $string_len = length( $string ) ; |
| 12823 | unlink $input_tmpfile, $output_tmpfile, $error_tmpfile ; |
| 12824 | |
| 12825 | if ( $is_command_ko or ( ! $string_len ) ) { |
| 12826 | my $cmd_exit_value = $CHILD_ERROR >> 8 ; |
| 12827 | my $cmd_end_signal = $CHILD_ERROR & 127 ; |
| 12828 | my $signal_log = ( $cmd_end_signal ) ? " signal $cmd_end_signal and" : q{} ; |
| 12829 | my $error_log = qq{Failure: --pipemess command "$command" ended with$signal_log "$string_len" characters exit value "$cmd_exit_value" and STDERR "$error_cmd"\n} ; |
| 12830 | myprint( $error_log ) ; |
| 12831 | if ( wantarray ) { |
| 12832 | return @{ [ undef, $error_log ] } |
| 12833 | }else{ |
| 12834 | return ; |
| 12835 | } |
| 12836 | } |
| 12837 | if ( $error_cmd ) { |
| 12838 | $error .= qq{STDERR of --pipemess "$command": $error_cmd\n} ; |
| 12839 | myprint( qq{STDERR of --pipemess "$command": $error_cmd\n} ) ; |
| 12840 | } |
| 12841 | } |
| 12842 | #myprint( "[$string]\n" ) ; |
| 12843 | if ( wantarray ) { |
| 12844 | return ( $string, $error ) ; |
| 12845 | }else{ |
| 12846 | return $string ; |
| 12847 | } |
| 12848 | } |
| 12849 | |
| 12850 | |
| 12851 | |
| 12852 | sub tests_pipemess |
| 12853 | { |
| 12854 | note( 'Entering tests_pipemess()' ) ; |
| 12855 | |
| 12856 | |
| 12857 | SKIP: { |
| 12858 | Readonly my $NB_WIN_tests_pipemess => 3 ; |
| 12859 | skip( 'Not on MSWin32', $NB_WIN_tests_pipemess ) if ('MSWin32' ne $OSNAME) ; |
| 12860 | # Windows |
| 12861 | # "type" command does not accept redirection of STDIN with < |
| 12862 | # "sort" does |
| 12863 | ok( "nochange\n" eq pipemess( 'nochange', 'sort' ), 'pipemess: nearly no change by sort' ) ; |
| 12864 | ok( "nochange2\n" eq pipemess( 'nochange2', qw( sort sort ) ), 'pipemess: nearly no change by sort,sort' ) ; |
| 12865 | # command not found |
| 12866 | #diag( 'Warning and failure about cacaprout are on purpose' ) ; |
| 12867 | ok( ! defined( pipemess( q{}, 'cacaprout' ) ), 'pipemess: command not found' ) ; |
| 12868 | |
| 12869 | } ; |
| 12870 | |
| 12871 | my ( $stringT, $errorT ) ; |
| 12872 | |
| 12873 | SKIP: { |
| 12874 | Readonly my $NB_UNX_tests_pipemess => 25 ; |
| 12875 | skip( 'Not on Unix', $NB_UNX_tests_pipemess ) if ('MSWin32' eq $OSNAME) ; |
| 12876 | # Unix |
| 12877 | ok( 'nochange' eq pipemess( 'nochange', 'cat' ), 'pipemess: no change by cat' ) ; |
| 12878 | |
| 12879 | ok( 'nochange2' eq pipemess( 'nochange2', 'cat', 'cat' ), 'pipemess: no change by cat,cat' ) ; |
| 12880 | |
| 12881 | ok( " 1\tnumberize\n" eq pipemess( "numberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ; |
| 12882 | ok( " 1\tnumberize\n 2\tnumberize\n" eq pipemess( "numberize\nnumberize\n", 'cat -n' ), 'pipemess: numberize by cat -n' ) ; |
| 12883 | |
| 12884 | ok( "A\nB\nC\n" eq pipemess( "A\nC\nB\n", 'sort' ), 'pipemess: sort' ) ; |
| 12885 | |
| 12886 | # command not found |
| 12887 | #diag( 'Warning and failure about cacaprout are on purpose' ) ; |
| 12888 | is( undef, pipemess( q{}, 'cacaprout' ), 'pipemess: command not found' ) ; |
| 12889 | |
| 12890 | # success with true but no output at all |
| 12891 | is( undef, pipemess( q{blabla}, 'true' ), 'pipemess: true but no output' ) ; |
| 12892 | |
| 12893 | # failure with false and no output at all |
| 12894 | is( undef, pipemess( q{blabla}, 'false' ), 'pipemess: false and no output' ) ; |
| 12895 | |
| 12896 | # Failure since pipemess is not a real pipe, so first cat wait for standard input |
| 12897 | is( q{blabla}, pipemess( q{blabla}, '( cat|cat ) ' ), 'pipemess: ok by ( cat|cat )' ) ; |
| 12898 | |
| 12899 | |
| 12900 | ( $stringT, $errorT ) = pipemess( 'nochange', 'cat' ) ; |
| 12901 | is( $stringT, 'nochange', 'pipemess: list context, no change by cat, string' ) ; |
| 12902 | is( $errorT, q{}, 'pipemess: list context, no change by cat, no error' ) ; |
| 12903 | |
| 12904 | ( $stringT, $errorT ) = pipemess( 'dontcare', 'true' ) ; |
| 12905 | is( $stringT, undef, 'pipemess: list context, true but no output, string' ) ; |
| 12906 | like( $errorT, qr{\QFailure: --pipemess command "true" ended with "0" characters exit value "0" and STDERR ""\E}xm, 'pipemess: list context, true but no output, error' ) ; |
| 12907 | |
| 12908 | ( $stringT, $errorT ) = pipemess( 'dontcare', 'false' ) ; |
| 12909 | is( $stringT, undef, 'pipemess: list context, false and no output, string' ) ; |
| 12910 | like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm, |
| 12911 | 'pipemess: list context, false and no output, error' ) ; |
| 12912 | |
| 12913 | ( $stringT, $errorT ) = pipemess( 'dontcare', '/bin/echo -n blablabla' ) ; |
| 12914 | is( $stringT, q{blablabla}, 'pipemess: list context, "echo -n blablabla", string' ) ; |
| 12915 | is( $errorT, q{}, 'pipemess: list context, "echo blablabla", error' ) ; |
| 12916 | |
| 12917 | |
| 12918 | ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ; |
| 12919 | is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla", string' ) ; |
| 12920 | like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla", error' ) ; |
| 12921 | |
| 12922 | |
| 12923 | ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo -n blablabla 3>&1 1>&2 2>&3 )', 'false' ) ; |
| 12924 | is( $stringT, undef, 'pipemess: list context, "no output STDERR blablabla then false", string' ) ; |
| 12925 | like( $errorT, qr{blablabla"}xm, 'pipemess: list context, "no output STDERR blablabla then false", error' ) ; |
| 12926 | |
| 12927 | ( $stringT, $errorT ) = pipemess( 'dontcare', 'false', '( echo -n blablabla 3>&1 1>&2 2>&3 )' ) ; |
| 12928 | is( $stringT, undef, 'pipemess: list context, "false then STDERR blablabla", string' ) ; |
| 12929 | like( $errorT, qr{\QFailure: --pipemess command "false" ended with "0" characters exit value "1" and STDERR ""\E}xm, |
| 12930 | 'pipemess: list context, "false then STDERR blablabla", error' ) ; |
| 12931 | |
| 12932 | ( $stringT, $errorT ) = pipemess( 'dontcare', '( echo rrrrr ; echo -n error_blablabla 3>&1 1>&2 2>&3 )' ) ; |
| 12933 | like( $stringT, qr{rrrrr}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", string' ) ; |
| 12934 | like( $errorT, qr{STDERR.*error_blablabla}xm, 'pipemess: list context, "STDOUT rrrrr STDERR error_blablabla", error' ) ; |
| 12935 | |
| 12936 | } |
| 12937 | |
| 12938 | ( $stringT, $errorT ) = pipemess( 'dontcare', 'cacaprout' ) ; |
| 12939 | is( $stringT, undef, 'pipemess: list context, cacaprout not found, string' ) ; |
| 12940 | like( $errorT, qr{\QFailure: --pipemess command "cacaprout" ended with "0" characters exit value\E}xm, |
| 12941 | 'pipemess: list context, cacaprout not found, error' ) ; |
| 12942 | |
| 12943 | note( 'Leaving tests_pipemess()' ) ; |
| 12944 | return ; |
| 12945 | } |
| 12946 | |
| 12947 | |
| 12948 | |
| 12949 | sub tests_is_a_release_number |
| 12950 | { |
| 12951 | note( 'Entering tests_is_a_release_number()' ) ; |
| 12952 | |
| 12953 | is( undef, is_a_release_number( ), 'is_a_release_number: no args => undef' ) ; |
| 12954 | ok( is_a_release_number( $RELEASE_NUMBER_EXAMPLE_1 ), 'is_a_release_number 1.351' ) ; |
| 12955 | ok( is_a_release_number( $RELEASE_NUMBER_EXAMPLE_2 ), 'is_a_release_number 42.4242' ) ; |
| 12956 | ok( is_a_release_number( imapsync_version( $sync ) ), 'is_a_release_number imapsync_version( )' ) ; |
| 12957 | ok( ! is_a_release_number( 'blabla' ), '! is_a_release_number blabla' ) ; |
| 12958 | |
| 12959 | note( 'Leaving tests_is_a_release_number()' ) ; |
| 12960 | return ; |
| 12961 | } |
| 12962 | |
| 12963 | sub is_a_release_number |
| 12964 | { |
| 12965 | my $number = shift ; |
| 12966 | if ( ! defined $number ) { return ; } |
| 12967 | return( $number =~ m{^\d+\.\d+$}xo ) ; |
| 12968 | } |
| 12969 | |
| 12970 | |
| 12971 | |
| 12972 | sub imapsync_version_public |
| 12973 | { |
| 12974 | |
| 12975 | my $local_version = imapsync_version( $sync ) ; |
| 12976 | my $imapsync_basename = imapsync_basename( ) ; |
| 12977 | my $context = imapsync_context( ) ; |
| 12978 | my $agent_info = "$OSNAME system, perl " |
| 12979 | . mysprintf( '%vd', $PERL_VERSION) |
| 12980 | . ", Mail::IMAPClient $Mail::IMAPClient::VERSION" |
| 12981 | . " $imapsync_basename" |
| 12982 | . " $context" ; |
| 12983 | my $sock = IO::Socket::INET->new( |
| 12984 | PeerAddr => 'imapsync.lamiral.info', |
| 12985 | PeerPort => 80, |
| 12986 | Proto => 'tcp', |
| 12987 | ) ; |
| 12988 | return( 'unknown' ) if not $sock ; |
| 12989 | print $sock |
| 12990 | "GET /prj/imapsync/VERSION HTTP/1.0\r\n", |
| 12991 | "User-Agent: imapsync/$local_version ($agent_info)\r\n", |
| 12992 | "Host: ks.lamiral.info\r\n\r\n" ; |
| 12993 | my @line = <$sock> ; |
| 12994 | close $sock ; |
| 12995 | my $last_release = $line[$LAST] ; |
| 12996 | chomp $last_release ; |
| 12997 | return( $last_release ) ; |
| 12998 | } |
| 12999 | |
| 13000 | sub not_long_imapsync_version_public |
| 13001 | { |
| 13002 | #myprint( "Entering not_long_imapsync_version_public\n" ) ; |
| 13003 | |
| 13004 | my $fake = shift ; |
| 13005 | if ( $fake ) { return $fake } |
| 13006 | |
| 13007 | my $val ; |
| 13008 | |
| 13009 | # Doesn't work with gethostbyname (see perlipc) |
| 13010 | #local $SIG{ALRM} = sub { die "alarm\n" } ; |
| 13011 | |
| 13012 | if ('MSWin32' eq $OSNAME) { |
| 13013 | local $SIG{ALRM} = sub { die "alarm\n" } ; |
| 13014 | }else{ |
| 13015 | |
| 13016 | POSIX::sigaction(SIGALRM, |
| 13017 | POSIX::SigAction->new(sub { croak 'alarm' } ) ) |
| 13018 | or myprint( "Error setting SIGALRM handler: $OS_ERROR\n" ) ; |
| 13019 | } |
| 13020 | |
| 13021 | my $ret = eval { |
| 13022 | alarm 3 ; |
| 13023 | { |
| 13024 | $val = imapsync_version_public( ) ; |
| 13025 | #sleep 4 ; |
| 13026 | #myprint( "End of imapsync_version_public\n" ) ; |
| 13027 | } |
| 13028 | alarm 0 ; |
| 13029 | 1 ; |
| 13030 | } ; |
| 13031 | #myprint( "eval [$ret]\n" ) ; |
| 13032 | if ( ( not $ret ) or $EVAL_ERROR ) { |
| 13033 | #myprint( "$EVAL_ERROR" ) ; |
| 13034 | if ($EVAL_ERROR =~ /alarm/) { |
| 13035 | # timed out |
| 13036 | return('timeout') ; |
| 13037 | }else{ |
| 13038 | alarm 0 ; |
| 13039 | return( 'unknown' ) ; # propagate unexpected errors |
| 13040 | } |
| 13041 | }else { |
| 13042 | # Good! |
| 13043 | return( $val ) ; |
| 13044 | } |
| 13045 | } |
| 13046 | |
| 13047 | sub tests_not_long_imapsync_version_public |
| 13048 | { |
| 13049 | note( 'Entering tests_not_long_imapsync_version_public()' ) ; |
| 13050 | |
| 13051 | |
| 13052 | is( 1, is_a_release_number( not_long_imapsync_version_public( ) ), |
| 13053 | 'not_long_imapsync_version_public: public release is a number' ) ; |
| 13054 | |
| 13055 | note( 'Leaving tests_not_long_imapsync_version_public()' ) ; |
| 13056 | return ; |
| 13057 | } |
| 13058 | |
| 13059 | sub check_last_release |
| 13060 | { |
| 13061 | my $fake = shift ; |
| 13062 | my $public_release = not_long_imapsync_version_public( $fake ) ; |
| 13063 | $sync->{ debug } and myprint( "check_last_release: [$public_release]\n" ) ; |
| 13064 | my $inline_help_when_on = '( Use --noreleasecheck to avoid this release check. )' ; |
| 13065 | |
| 13066 | if ( $public_release eq 'unknown' ) { |
| 13067 | return( 'Imapsync public release is unknown.' . $inline_help_when_on ) ; |
| 13068 | } |
| 13069 | |
| 13070 | if ( $public_release eq 'timeout' ) { |
| 13071 | return( 'Imapsync public release is unknown (timeout).' . $inline_help_when_on ) ; |
| 13072 | } |
| 13073 | |
| 13074 | if ( ! is_a_release_number( $public_release ) ) { |
| 13075 | return( "Imapsync public release is unknown ($public_release)." . $inline_help_when_on ) ; |
| 13076 | } |
| 13077 | |
| 13078 | my $imapsync_here = imapsync_version( $sync ) ; |
| 13079 | |
| 13080 | if ( $public_release > $imapsync_here ) { |
| 13081 | return( 'This imapsync is not up to date. ' . "( local $imapsync_here < official $public_release )" . $inline_help_when_on ) ; |
| 13082 | }else{ |
| 13083 | return( 'This imapsync is up to date. ' . "( local $imapsync_here >= official $public_release )" . $inline_help_when_on ) ; |
| 13084 | } |
| 13085 | |
| 13086 | return( 'really unknown' ) ; # Should never arrive here |
| 13087 | } |
| 13088 | |
| 13089 | sub tests_check_last_release |
| 13090 | { |
| 13091 | note( 'Entering tests_check_last_release()' ) ; |
| 13092 | |
| 13093 | diag( check_last_release( 1.1 ) ) ; |
| 13094 | # \Q \E here to avoid putting \ before each space |
| 13095 | like( check_last_release( 1.1 ), qr/\Qis up to date\E/mxs, 'check_last_release: up to date' ) ; |
| 13096 | like( check_last_release( 1.1 ), qr/1\.1/mxs, 'check_last_release: up to date, include number' ) ; |
| 13097 | diag( check_last_release( 999.999 ) ) ; |
| 13098 | like( check_last_release( 999.999 ), qr/\Qnot up to date\E/mxs, 'check_last_release: not up to date' ) ; |
| 13099 | like( check_last_release( 999.999 ), qr/999\.999/mxs, 'check_last_release: not up to date, include number' ) ; |
| 13100 | like( check_last_release( 'unknown' ), qr/\QImapsync public release is unknown\E/mxs, 'check_last_release: unknown' ) ; |
| 13101 | like( check_last_release( 'timeout' ), qr/\QImapsync public release is unknown (timeout)\E/mxs, 'check_last_release: timeout' ) ; |
| 13102 | like( check_last_release( 'lalala' ), qr/\QImapsync public release is unknown (lalala)\E/mxs, 'check_last_release: lalala' ) ; |
| 13103 | diag( check_last_release( ) ) ; |
| 13104 | |
| 13105 | note( 'Leaving tests_check_last_release()' ) ; |
| 13106 | return ; |
| 13107 | } |
| 13108 | |
| 13109 | sub tests_imapsync_context |
| 13110 | { |
| 13111 | note( 'Entering tests_imapsync_context()' ) ; |
| 13112 | |
| 13113 | like( imapsync_context( ), qr/^CGI|^Docker|^DockerCGI|^Standard/, 'imapsync_context: CGI or Docker or DockerCGI or Standard' ) ; |
| 13114 | note( 'Leaving tests_imapsync_context()' ) ; |
| 13115 | return ; |
| 13116 | } |
| 13117 | |
| 13118 | sub imapsync_context |
| 13119 | { |
| 13120 | my $mysync = shift ; |
| 13121 | |
| 13122 | my $context = q{} ; |
| 13123 | |
| 13124 | if ( under_docker_context( $mysync ) && under_cgi_context( $mysync ) ) |
| 13125 | { |
| 13126 | $context = 'DockerCGI' ; |
| 13127 | } |
| 13128 | elsif ( under_docker_context( $mysync ) ) |
| 13129 | { |
| 13130 | $context = 'Docker' ; |
| 13131 | } |
| 13132 | elsif ( under_cgi_context( $mysync ) ) |
| 13133 | { |
| 13134 | $context = 'CGI' ; |
| 13135 | } |
| 13136 | else |
| 13137 | { |
| 13138 | $context = 'Standard' ; |
| 13139 | } |
| 13140 | |
| 13141 | return $context ; |
| 13142 | |
| 13143 | } |
| 13144 | |
| 13145 | sub imapsync_version |
| 13146 | { |
| 13147 | my $mysync = shift ; |
| 13148 | my $rcs = $mysync->{rcs} ; |
| 13149 | my $version ; |
| 13150 | |
| 13151 | $version = version_from_rcs( $rcs ) ; |
| 13152 | return( $version ) ; |
| 13153 | } |
| 13154 | |
| 13155 | |
| 13156 | sub tests_version_from_rcs |
| 13157 | { |
| 13158 | note( 'Entering tests_version_from_rcs()' ) ; |
| 13159 | |
| 13160 | is( undef, version_from_rcs( ), 'version_from_rcs: no args => UNKNOWN' ) ; |
| 13161 | is( 1.831, version_from_rcs( q{imapsync,v 1.831 2017/08/27} ), 'version_from_rcs: imapsync,v 1.831 2017/08/27 => 1.831' ) ; |
| 13162 | is( 'UNKNOWN', version_from_rcs( 1.831 ), 'version_from_rcs: 1.831 => UNKNOWN' ) ; |
| 13163 | |
| 13164 | note( 'Leaving tests_version_from_rcs()' ) ; |
| 13165 | return ; |
| 13166 | } |
| 13167 | |
| 13168 | |
| 13169 | sub version_from_rcs |
| 13170 | { |
| 13171 | |
| 13172 | my $rcs = shift ; |
| 13173 | if ( ! $rcs ) { return ; } |
| 13174 | |
| 13175 | my $version = 'UNKNOWN' ; |
| 13176 | |
| 13177 | if ( $rcs =~ m{,v\s+(\d+\.\d+)}mxso ) { |
| 13178 | $version = $1 |
| 13179 | } |
| 13180 | |
| 13181 | return( $version ) ; |
| 13182 | } |
| 13183 | |
| 13184 | |
| 13185 | sub tests_imapsync_basename |
| 13186 | { |
| 13187 | note( 'Entering tests_imapsync_basename()' ) ; |
| 13188 | |
| 13189 | ok( imapsync_basename() =~ m/imapsync/, 'imapsync_basename: match imapsync'); |
| 13190 | ok( 'blabla' ne imapsync_basename(), 'imapsync_basename: do not equal blabla'); |
| 13191 | |
| 13192 | note( 'Leaving tests_imapsync_basename()' ) ; |
| 13193 | return ; |
| 13194 | } |
| 13195 | |
| 13196 | sub imapsync_basename |
| 13197 | { |
| 13198 | |
| 13199 | return basename( $PROGRAM_NAME ) ; |
| 13200 | |
| 13201 | } |
| 13202 | |
| 13203 | |
| 13204 | sub localhost_info |
| 13205 | { |
| 13206 | my $mysync = shift ; |
| 13207 | my( $infos ) = join( q{}, |
| 13208 | "Here is imapsync ", imapsync_version( $mysync ), |
| 13209 | " on host " . hostname(), |
| 13210 | ", a $OSNAME system with ", |
| 13211 | ram_memory_info( ), |
| 13212 | "\n", |
| 13213 | 'with Perl ', |
| 13214 | mysprintf( '%vd ', $PERL_VERSION), |
| 13215 | "and Mail::IMAPClient $Mail::IMAPClient::VERSION", |
| 13216 | ) ; |
| 13217 | return( $infos ) ; |
| 13218 | } |
| 13219 | |
| 13220 | sub tests_cpu_number |
| 13221 | { |
| 13222 | note( 'Entering tests_cpu_number()' ) ; |
| 13223 | |
| 13224 | is( 1, is_an_integer( cpu_number( ) ), "cpu_number: is_an_integer" ) ; |
| 13225 | ok( 1 <= cpu_number( ), "cpu_number: 1 or more" ) ; |
| 13226 | is( 1, cpu_number( 1 ), "cpu_number: 1 => 1" ) ; |
| 13227 | is( 1, cpu_number( $MINUS_ONE ), "cpu_number: -1 => 1" ) ; |
| 13228 | is( 1, cpu_number( 'lalala' ), "cpu_number: lalala => 1" ) ; |
| 13229 | is( $NUMBER_42, cpu_number( $NUMBER_42 ), "cpu_number: $NUMBER_42 => $NUMBER_42" ) ; |
| 13230 | note( 'Leaving tests_cpu_number()' ) ; |
| 13231 | return ; |
| 13232 | } |
| 13233 | |
| 13234 | sub cpu_number |
| 13235 | { |
| 13236 | |
| 13237 | my $cpu_number_forced = shift ; |
| 13238 | # Well, here 1 is better than 0 or undef |
| 13239 | my $cpu_number = 1 ; # Default value, erased if better found |
| 13240 | |
| 13241 | my @cpuinfo ; |
| 13242 | if ( $ENV{"NUMBER_OF_PROCESSORS"} ) { |
| 13243 | # might be under a Windows system |
| 13244 | $cpu_number = $ENV{"NUMBER_OF_PROCESSORS"} ; |
| 13245 | $sync->{ debug } and myprint( "Number of processors found by env var NUMBER_OF_PROCESSORS: $cpu_number\n" ) ; |
| 13246 | }elsif ( 'darwin' eq $OSNAME or 'freebsd' eq $OSNAME ) { |
| 13247 | $cpu_number = backtick( "sysctl -n hw.ncpu" ) ; |
| 13248 | chomp( $cpu_number ) ; |
| 13249 | $sync->{ debug } and myprint( "Number of processors found by cmd 'sysctl -n hw.ncpu': $cpu_number\n" ) ; |
| 13250 | }elsif ( ! -e '/proc/cpuinfo' ) { |
| 13251 | $sync->{ debug } and myprint( "Number of processors not found so I might assume there is only 1\n" ) ; |
| 13252 | $cpu_number = 1 ; |
| 13253 | }elsif( @cpuinfo = file_to_array( '/proc/cpuinfo' ) ) { |
| 13254 | $cpu_number = grep { /^processor/mxs } @cpuinfo ; |
| 13255 | $sync->{ debug } and myprint( "Number of processors found via /proc/cpuinfo: $cpu_number\n" ) ; |
| 13256 | } |
| 13257 | |
| 13258 | if ( defined $cpu_number_forced ) { |
| 13259 | $cpu_number = $cpu_number_forced ; |
| 13260 | } |
| 13261 | return( integer_or_1( $cpu_number ) ) ; |
| 13262 | } |
| 13263 | |
| 13264 | |
| 13265 | sub tests_integer_or_1 |
| 13266 | { |
| 13267 | note( 'Entering tests_integer_or_1()' ) ; |
| 13268 | |
| 13269 | is( 1, integer_or_1( ), 'integer_or_1: no args => 1' ) ; |
| 13270 | is( 1, integer_or_1( undef ), 'integer_or_1: undef => 1' ) ; |
| 13271 | is( $NUMBER_10, integer_or_1( $NUMBER_10 ), 'integer_or_1: 10 => 10' ) ; |
| 13272 | is( 1, integer_or_1( q{} ), 'integer_or_1: empty string => 1' ) ; |
| 13273 | is( 1, integer_or_1( 'lalala' ), 'integer_or_1: lalala => 1' ) ; |
| 13274 | |
| 13275 | note( 'Leaving tests_integer_or_1()' ) ; |
| 13276 | return ; |
| 13277 | } |
| 13278 | |
| 13279 | sub integer_or_1 |
| 13280 | { |
| 13281 | my $number = shift ; |
| 13282 | if ( is_an_integer( $number ) ) { |
| 13283 | return $number ; |
| 13284 | } |
| 13285 | # else |
| 13286 | return 1 ; |
| 13287 | } |
| 13288 | |
| 13289 | sub tests_is_an_integer |
| 13290 | { |
| 13291 | note( 'Entering tests_is_an_integer()' ) ; |
| 13292 | |
| 13293 | is( undef, is_an_integer( ), 'is_an_integer: no args => undef ' ) ; |
| 13294 | ok( is_an_integer( 1 ), 'is_an_integer: 1 => yes ') ; |
| 13295 | ok( is_an_integer( $NUMBER_42 ), 'is_an_integer: 42 => yes ') ; |
| 13296 | ok( is_an_integer( "$NUMBER_42" ), 'is_an_integer: "$NUMBER_42" => yes ') ; |
| 13297 | ok( is_an_integer( '42' ), 'is_an_integer: "42" => yes ') ; |
| 13298 | ok( is_an_integer( $NUMBER_104_857_600 ), 'is_an_integer: 104_857_600 => yes') ; |
| 13299 | ok( is_an_integer( "$NUMBER_104_857_600" ), 'is_an_integer: "$NUMBER_104_857_600" => yes') ; |
| 13300 | ok( is_an_integer( '104857600' ), 'is_an_integer: 104857600 => yes') ; |
| 13301 | ok( ! is_an_integer( 'blabla' ), 'is_an_integer: blabla => no' ) ; |
| 13302 | ok( ! is_an_integer( q{} ), 'is_an_integer: empty string => no' ) ; |
| 13303 | |
| 13304 | note( 'Leaving tests_is_an_integer()' ) ; |
| 13305 | return ; |
| 13306 | } |
| 13307 | |
| 13308 | sub is_an_integer |
| 13309 | { |
| 13310 | my $number = shift ; |
| 13311 | if ( ! defined $number ) { return ; } |
| 13312 | return( $number =~ m{^\d+$}xo ) ; |
| 13313 | } |
| 13314 | |
| 13315 | |
| 13316 | |
| 13317 | |
| 13318 | sub tests_loadavg |
| 13319 | { |
| 13320 | note( 'Entering tests_loadavg()' ) ; |
| 13321 | |
| 13322 | |
| 13323 | SKIP: { |
| 13324 | skip( 'Tests for darwin', 2 ) if ('darwin' ne $OSNAME) ; |
| 13325 | is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ; |
| 13326 | is_deeply( [ '0.11', '0.22', '0.33' ], |
| 13327 | [ loadavg( 'W/t/loadavg.out' ) ], |
| 13328 | 'loadavg W/t/loadavg.out => 0.11 0.22 0.33' ) ; |
| 13329 | } ; |
| 13330 | |
| 13331 | SKIP: { |
| 13332 | skip( 'Tests for linux', 3 ) if ('linux' ne $OSNAME) ; |
| 13333 | is( undef, loadavg( '/noexist' ), 'loadavg: /noexist => undef' ) ; |
| 13334 | ok( loadavg( ), 'loadavg: no args' ) ; |
| 13335 | |
| 13336 | is_deeply( [ '0.39', '0.30', '0.37', '1/602' ], |
| 13337 | [ loadavg( '0.39 0.30 0.37 1/602 6073' ) ], |
| 13338 | 'loadavg 0.39 0.30 0.37 1/602 6073 => [0.39, 0.30, 0.37, 1/602]' ) ; |
| 13339 | } ; |
| 13340 | |
| 13341 | SKIP: { |
| 13342 | skip( 'Tests for Windows', 1 ) if ('MSWin32' ne $OSNAME) ; |
| 13343 | is_deeply( [ 0 ], |
| 13344 | [ loadavg( ) ], |
| 13345 | 'loadavg on MSWin32 => 0' ) ; |
| 13346 | |
| 13347 | } ; |
| 13348 | |
| 13349 | note( 'Leaving tests_loadavg()' ) ; |
| 13350 | return ; |
| 13351 | } |
| 13352 | |
| 13353 | |
| 13354 | sub loadavg |
| 13355 | { |
| 13356 | if ( 'linux' eq $OSNAME ) { |
| 13357 | return ( loadavg_linux( @ARG ) ) ; |
| 13358 | } |
| 13359 | if ( 'freebsd' eq $OSNAME ) { |
| 13360 | return ( loadavg_freebsd( @ARG ) ) ; |
| 13361 | } |
| 13362 | if ( 'darwin' eq $OSNAME ) { |
| 13363 | return ( loadavg_darwin( @ARG ) ) ; |
| 13364 | } |
| 13365 | if ( 'MSWin32' eq $OSNAME ) { |
| 13366 | return ( loadavg_windows( @ARG ) ) ; |
| 13367 | } |
| 13368 | return( 'unknown' ) ; |
| 13369 | |
| 13370 | } |
| 13371 | |
| 13372 | sub loadavg_linux |
| 13373 | { |
| 13374 | my $line = shift ; |
| 13375 | |
| 13376 | if ( ! $line ) { |
| 13377 | $line = firstline( '/proc/loadavg' ) or return ; |
| 13378 | } |
| 13379 | |
| 13380 | my ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) = split /\s/mxs, $line ; |
| 13381 | if ( all_defined( $avg_1_min, $avg_5_min, $avg_15_min ) ) { |
| 13382 | $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min $current_runs\n" ) ; |
| 13383 | return ( $avg_1_min, $avg_5_min, $avg_15_min, $current_runs ) ; |
| 13384 | } |
| 13385 | return ; |
| 13386 | } |
| 13387 | |
| 13388 | sub loadavg_freebsd |
| 13389 | { |
| 13390 | my $file = shift ; |
| 13391 | # Example of output of command "sysctl vm.loadavg": |
| 13392 | # vm.loadavg: { 0.15 0.08 0.08 } |
| 13393 | my $loadavg ; |
| 13394 | |
| 13395 | if ( ! defined $file ) { |
| 13396 | eval { |
| 13397 | $loadavg = `/sbin/sysctl vm.loadavg` ; |
| 13398 | #myprint( "LOADAVG FREEBSD: $loadavg\n" ) ; |
| 13399 | } ; |
| 13400 | if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } |
| 13401 | }else{ |
| 13402 | $loadavg = firstline( $file ) or return ; |
| 13403 | } |
| 13404 | |
| 13405 | my ( $avg_1_min, $avg_5_min, $avg_15_min ) |
| 13406 | = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ; |
| 13407 | $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ; |
| 13408 | return ( $avg_1_min, $avg_5_min, $avg_15_min ) ; |
| 13409 | } |
| 13410 | |
| 13411 | sub loadavg_darwin |
| 13412 | { |
| 13413 | my $file = shift ; |
| 13414 | # Example of output of command "sysctl vm.loadavg": |
| 13415 | # vm.loadavg: { 0.15 0.08 0.08 } |
| 13416 | my $loadavg ; |
| 13417 | |
| 13418 | if ( ! defined $file ) { |
| 13419 | eval { |
| 13420 | $loadavg = `/usr/sbin/sysctl vm.loadavg` ; |
| 13421 | #myprint( "LOADAVG DARWIN: $loadavg\n" ) ; |
| 13422 | } ; |
| 13423 | if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } |
| 13424 | }else{ |
| 13425 | $loadavg = firstline( $file ) or return ; |
| 13426 | } |
| 13427 | |
| 13428 | my ( $avg_1_min, $avg_5_min, $avg_15_min ) |
| 13429 | = $loadavg =~ /vm\.loadavg\s*[:=]\s*\{?\s*(\d+\.?\d*)\s+(\d+\.?\d*)\s+(\d+\.?\d*)/mxs ; |
| 13430 | $sync->{ debug } and myprint( "System load: $avg_1_min $avg_5_min $avg_15_min\n" ) ; |
| 13431 | return ( $avg_1_min, $avg_5_min, $avg_15_min ) ; |
| 13432 | } |
| 13433 | |
| 13434 | sub loadavg_windows |
| 13435 | { |
| 13436 | my $file = shift ; |
| 13437 | # Example of output of command "wmic cpu get loadpercentage": |
| 13438 | # LoadPercentage |
| 13439 | # 12 |
| 13440 | my $loadavg ; |
| 13441 | |
| 13442 | if ( ! defined $file ) { |
| 13443 | eval { |
| 13444 | #$loadavg = `CMD wmic cpu get loadpercentage` ; |
| 13445 | $loadavg = "LoadPercentage\n0\n" ; |
| 13446 | #myprint( "LOADAVG WIN: $loadavg\n" ) ; |
| 13447 | } ; |
| 13448 | if ( $EVAL_ERROR ) { myprint( "[$EVAL_ERROR]\n" ) ; return ; } |
| 13449 | }else{ |
| 13450 | $loadavg = file_to_string( $file ) or return ; |
| 13451 | #myprint( "$loadavg" ) ; |
| 13452 | } |
| 13453 | $loadavg =~ /LoadPercentage\n(\d+)/xms ; |
| 13454 | my $num = $1 ; |
| 13455 | $num /= 100 ; |
| 13456 | |
| 13457 | $sync->{ debug } and myprint( "System load: $num\n" ) ; |
| 13458 | return ( $num ) ; |
| 13459 | } |
| 13460 | |
| 13461 | |
| 13462 | |
| 13463 | |
| 13464 | |
| 13465 | |
| 13466 | sub tests_load_and_delay |
| 13467 | { |
| 13468 | note( 'Entering tests_load_and_delay()' ) ; |
| 13469 | |
| 13470 | is( undef, load_and_delay( ), 'load_and_delay: no args => undef ' ) ; |
| 13471 | is( undef, load_and_delay( 1 ), 'load_and_delay: not 4 args => undef ' ) ; |
| 13472 | is( undef, load_and_delay( 0, 1, 1, 1 ), 'load_and_delay: division per 0 => undef ' ) ; |
| 13473 | is( 0, load_and_delay( 1, 1, 1, 1 ), 'load_and_delay: one core, loads are all 1 => ok ' ) ; |
| 13474 | is( 0, load_and_delay( 1, 1, 1, 1, 'lalala' ), 'load_and_delay: five arguments is ok' ) ; |
| 13475 | is( 0, load_and_delay( 2, 2, 2, 2 ), 'load_and_delay: two core, loads are all 2 => ok ' ) ; |
| 13476 | is( 0, load_and_delay( 2, 2, 4, 5 ), 'load_and_delay: two core, load1m is 2 => ok ' ) ; |
| 13477 | |
| 13478 | # Old behavior, rather strict |
| 13479 | # is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; |
| 13480 | # is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; |
| 13481 | # is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; |
| 13482 | # is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; |
| 13483 | # is( 1, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; |
| 13484 | # is( 1, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; |
| 13485 | # is( 5, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; |
| 13486 | # is( 15, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; |
| 13487 | |
| 13488 | # is( 0, load_and_delay( 4, 0, 2, 2 ), 'load_and_delay: four core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; |
| 13489 | # is( 1, load_and_delay( 4, 8, 0, 0 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; |
| 13490 | # is( 1, load_and_delay( 4, 8, 0, 2 ), 'load_and_delay: four core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; |
| 13491 | # is( 5, load_and_delay( 4, 8, 8, 0 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; |
| 13492 | # is( 15, load_and_delay( 4, 8, 8, 8 ), 'load_and_delay: four core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; |
| 13493 | |
| 13494 | # New behavior, tolerate more load |
| 13495 | |
| 13496 | is( 0, load_and_delay( 1, 0, 0, 0 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=0 => 0 ' ) ; |
| 13497 | is( 0, load_and_delay( 1, 0, 0, 2 ), 'load_and_delay: one core, load1m=0 load5m=0 load15m=2 => 0 ' ) ; |
| 13498 | is( 0, load_and_delay( 1, 0, 2, 0 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=0 => 0 ' ) ; |
| 13499 | is( 0, load_and_delay( 1, 0, 2, 2 ), 'load_and_delay: one core, load1m=0 load5m=2 load15m=2 => 0 ' ) ; |
| 13500 | is( 0, load_and_delay( 1, 2, 0, 0 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=0 => 1 ' ) ; |
| 13501 | is( 0, load_and_delay( 1, 2, 0, 2 ), 'load_and_delay: one core, load1m=2 load5m=0 load15m=2 => 1 ' ) ; |
| 13502 | is( 0, load_and_delay( 1, 2, 2, 0 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=0 => 5 ' ) ; |
| 13503 | is( 0, load_and_delay( 1, 2, 2, 2 ), 'load_and_delay: one core, load1m=2 load5m=2 load15m=2 => 15 ' ) ; |
| 13504 | |
| 13505 | is( 1, load_and_delay( 1, 4, 0, 0 ), 'load_and_delay: one core, load1m=4 load5m=0 load15m=0 => 1 ' ) ; |
| 13506 | is( 1, load_and_delay( 1, 4, 0, 4 ), 'load_and_delay: one core, load1m=4 load5m=0 load15m=4 => 1 ' ) ; |
| 13507 | is( 5, load_and_delay( 1, 4, 4, 0 ), 'load_and_delay: one core, load1m=4 load5m=4 load15m=0 => 5 ' ) ; |
| 13508 | is( 15, load_and_delay( 1, 4, 4, 4 ), 'load_and_delay: one core, load1m=4 load5m=4 load15m=4 => 15 ' ) ; |
| 13509 | |
| 13510 | is( 0, load_and_delay( 4, 0, 9, 9 ), 'load_and_delay: four core, load1m=0 load5m=9 load15m=9 => 0 ' ) ; |
| 13511 | is( 1, load_and_delay( 4, 9, 0, 0 ), 'load_and_delay: four core, load1m=9 load5m=0 load15m=0 => 1 ' ) ; |
| 13512 | is( 1, load_and_delay( 4, 9, 0, 9 ), 'load_and_delay: four core, load1m=9 load5m=0 load15m=9 => 1 ' ) ; |
| 13513 | is( 5, load_and_delay( 4, 9, 9, 0 ), 'load_and_delay: four core, load1m=9 load5m=9 load15m=0 => 5 ' ) ; |
| 13514 | is( 15, load_and_delay( 4, 9, 9, 9 ), 'load_and_delay: four core, load1m=9 load5m=9 load15m=9 => 15 ' ) ; |
| 13515 | |
| 13516 | note( 'Leaving tests_load_and_delay()' ) ; |
| 13517 | return ; |
| 13518 | } |
| 13519 | |
| 13520 | sub load_and_delay |
| 13521 | { |
| 13522 | # Basically return 0 if load is not heavy, ie <= 1 per processor |
| 13523 | |
| 13524 | # Not enough arguments |
| 13525 | if ( 4 > scalar @ARG ) { return ; } |
| 13526 | |
| 13527 | my ( $cpu_num, $avg_1_min, $avg_5_min, $avg_15_min ) = @ARG ; |
| 13528 | |
| 13529 | if ( 0 == $cpu_num ) { return ; } |
| 13530 | |
| 13531 | # Let divide by number of cores |
| 13532 | ( $avg_1_min, $avg_5_min, $avg_15_min ) = map { $_ / $cpu_num } ( $avg_1_min, $avg_5_min, $avg_15_min ) ; |
| 13533 | # One of avg ok => ok, for now it is a OR |
| 13534 | if ( $avg_1_min <= 2 ) { return 0 ; } |
| 13535 | if ( $avg_5_min <= 2 ) { return 1 ; } # Retry in 1 minute |
| 13536 | if ( $avg_15_min <= 2 ) { return 5 ; } # Retry in 5 minutes |
| 13537 | return 15 ; # Retry in 15 minutes |
| 13538 | } |
| 13539 | |
| 13540 | sub ram_memory_info |
| 13541 | { |
| 13542 | # In GigaBytes so division by 1024 * 1024 * 1024 |
| 13543 | # |
| 13544 | return( |
| 13545 | sprintf( "%.1f/%.1f free GiB of RAM", |
| 13546 | Sys::MemInfo::get("freemem") / ( $KIBI ** 3 ), |
| 13547 | Sys::MemInfo::get("totalmem") / ( $KIBI ** 3 ), |
| 13548 | ) |
| 13549 | ) ; |
| 13550 | } |
| 13551 | |
| 13552 | |
| 13553 | |
| 13554 | sub tests_memory_stress |
| 13555 | { |
| 13556 | note( 'Entering tests_memory_stress()' ) ; |
| 13557 | |
| 13558 | is( undef, memory_stress( ), 'memory_stress: => undef' ) ; |
| 13559 | |
| 13560 | note( 'Leaving tests_memory_stress()' ) ; |
| 13561 | return ; |
| 13562 | } |
| 13563 | |
| 13564 | sub memory_stress |
| 13565 | { |
| 13566 | |
| 13567 | my $total_ram_in_MB = Sys::MemInfo::get("totalmem") / ( $KIBI * $KIBI ) ; |
| 13568 | my $i = 1 ; |
| 13569 | |
| 13570 | myprintf("Stress memory consumption before: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; |
| 13571 | while ( $i < $total_ram_in_MB / 1.7 ) { $a .= "A" x 1000_000; $i++ } ; |
| 13572 | myprintf("Stress memory consumption after: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ; |
| 13573 | return ; |
| 13574 | |
| 13575 | } |
| 13576 | |
| 13577 | sub tests_memory_consumption |
| 13578 | { |
| 13579 | note( 'Entering tests_memory_consumption()' ) ; |
| 13580 | |
| 13581 | like( memory_consumption( ), qr{\d+}xms,'memory_consumption no args') ; |
| 13582 | like( memory_consumption( 1 ), qr{\d+}xms,'memory_consumption 1') ; |
| 13583 | like( memory_consumption( $PROCESS_ID ), qr{\d+}xms,"memory_consumption_of_pids $PROCESS_ID") ; |
| 13584 | |
| 13585 | like( memory_consumption_ratio(), qr{\d+}xms, 'memory_consumption_ratio' ) ; |
| 13586 | like( memory_consumption_ratio(1), qr{\d+}xms, 'memory_consumption_ratio 1' ) ; |
| 13587 | like( memory_consumption_ratio(10), qr{\d+}xms, 'memory_consumption_ratio 10' ) ; |
| 13588 | |
| 13589 | like( memory_consumption(), qr{\d+}xms, "memory_consumption\n" ) ; |
| 13590 | |
| 13591 | note( 'Leaving tests_memory_consumption()' ) ; |
| 13592 | return ; |
| 13593 | } |
| 13594 | |
| 13595 | sub memory_consumption |
| 13596 | { |
| 13597 | # memory consumed by imapsync until now in bytes |
| 13598 | return( ( memory_consumption_of_pids( ) )[0] ); |
| 13599 | } |
| 13600 | |
| 13601 | sub debugmemory |
| 13602 | { |
| 13603 | my $mysync = shift ; |
| 13604 | if ( ! $mysync->{debugmemory} ) { return q{} ; } |
| 13605 | |
| 13606 | my $precision = shift ; |
| 13607 | return( mysprintf( "Memory consumption$precision: %.1f MiB\n", memory_consumption( ) / $KIBI / $KIBI ) ) ; |
| 13608 | } |
| 13609 | |
| 13610 | sub memory_consumption_of_pids |
| 13611 | { |
| 13612 | |
| 13613 | my @pid = @_; |
| 13614 | @pid = ( @pid ) ? @pid : ( $PROCESS_ID ) ; |
| 13615 | |
| 13616 | $sync->{ debug } and myprint( "memory_consumption_of_pids PIDs: @pid\n" ) ; |
| 13617 | my @val ; |
| 13618 | if ( ( 'MSWin32' eq $OSNAME ) or ( 'cygwin' eq $OSNAME ) ) { |
| 13619 | @val = memory_consumption_of_pids_win32( @pid ) ; |
| 13620 | }else{ |
| 13621 | # Unix |
| 13622 | my @ps = qx{ ps -o vsz -p @pid } ; |
| 13623 | #myprint( "ps: @ps" ) ; |
| 13624 | |
| 13625 | # Use IPC::Open3 from perlcrit -3 |
| 13626 | # It stalls on Darwin, don't understand why! |
| 13627 | #my @ps = backtick( "ps -o vsz -p @pid" ) ; |
| 13628 | #myprint( "ps: @ps" ) ; |
| 13629 | |
| 13630 | shift @ps; # First line is column name "VSZ" |
| 13631 | chomp @ps; |
| 13632 | # convert to octets |
| 13633 | |
| 13634 | @val = map { $_ * $KIBI } @ps ; |
| 13635 | } |
| 13636 | $sync->{ debug } and myprint( "@val\n" ) ; |
| 13637 | return( @val ) ; |
| 13638 | } |
| 13639 | |
| 13640 | sub memory_consumption_of_pids_win32 |
| 13641 | { |
| 13642 | # Windows |
| 13643 | my @PID = @_; |
| 13644 | my %PID; |
| 13645 | # hash of pids as key values |
| 13646 | map { $PID{$_}++ } @PID; |
| 13647 | |
| 13648 | # Does not work but should work reading the tasklist documentation |
| 13649 | #@ps = qx{ tasklist /FI "PID eq @PID" }; |
| 13650 | |
| 13651 | my @ps = qx{ tasklist /NH /FO CSV } ; |
| 13652 | #my @ps = backtick( 'tasklist /NH /FO CSV' ) ; |
| 13653 | #myprint( "-" x $STD_CHAR_PER_LINE, "\n", @ps, "-" x $STD_CHAR_PER_LINE, "\n" ) ; |
| 13654 | my @val; |
| 13655 | foreach my $line (@ps) { |
| 13656 | my($name, $pid, $mem) = (split ',', $line )[0,1,4]; |
| 13657 | next if (! $pid); |
| 13658 | #myprint( "[$name][$pid][$mem]" ) ; |
| 13659 | if ($PID{remove_qq($pid)}) { |
| 13660 | #myprint( "MATCH !\n" ) ; |
| 13661 | chomp $mem ; |
| 13662 | $mem = remove_qq($mem); |
| 13663 | $mem = remove_Ko($mem); |
| 13664 | $mem = remove_not_num($mem); |
| 13665 | #myprint( "[$mem]\n" ) ; |
| 13666 | push @val, $mem * $KIBI; |
| 13667 | } |
| 13668 | } |
| 13669 | return(@val); |
| 13670 | } |
| 13671 | |
| 13672 | |
| 13673 | sub tests_backtick |
| 13674 | { |
| 13675 | note( 'Entering tests_backtick()' ) ; |
| 13676 | |
| 13677 | is( undef, backtick( ), 'backtick: no args' ) ; |
| 13678 | is( undef, backtick( q{} ), 'backtick: empty command' ) ; |
| 13679 | |
| 13680 | SKIP: { |
| 13681 | skip( 'test for MSWin32', 5 ) if ('MSWin32' ne $OSNAME) ; |
| 13682 | my @output ; |
| 13683 | @output = backtick( 'echo Hello World!' ) ; |
| 13684 | # Add \r on Windows. |
| 13685 | ok( "Hello World!\r\n" eq $output[0], 'backtick: echo Hello World!' ) ; |
| 13686 | $sync->{ debug } and myprint( "[@output]" ) ; |
| 13687 | @output = backtick( 'echo Hello & echo World!' ) ; |
| 13688 | ok( "Hello \r\n" eq $output[0], 'backtick: echo Hello & echo World! line 1' ) ; |
| 13689 | ok( "World!\r\n" eq $output[1], 'backtick: echo Hello & echo World! line 2' ) ; |
| 13690 | $sync->{ debug } and myprint( "[@output][$output[0]][$output[1]]" ) ; |
| 13691 | # Scalar context |
| 13692 | ok( "Hello World!\r\n" eq backtick( 'echo Hello World!' ), |
| 13693 | 'backtick: echo Hello World! scalar' ) ; |
| 13694 | ok( "Hello \r\nWorld!\r\n" eq backtick( 'echo Hello & echo World!' ), |
| 13695 | 'backtick: echo Hello & echo World! scalar 2 lines' ) ; |
| 13696 | } ; |
| 13697 | SKIP: { |
| 13698 | skip( 'test for Unix', 7 ) if ('MSWin32' eq $OSNAME) ; |
| 13699 | is( undef, backtick( 'aaaarrrg' ), 'backtick: aaaarrrg command not found' ) ; |
| 13700 | # Array context |
| 13701 | my @output ; |
| 13702 | @output = backtick( 'echo Hello World!' ) ; |
| 13703 | ok( "Hello World!\n" eq $output[0], 'backtick: echo Hello World!' ) ; |
| 13704 | $sync->{ debug } and myprint( "[@output]" ) ; |
| 13705 | @output = backtick( "echo Hello\necho World!" ) ; |
| 13706 | ok( "Hello\n" eq $output[0], 'backtick: echo Hello; echo World! line 1' ) ; |
| 13707 | ok( "World!\n" eq $output[1], 'backtick: echo Hello; echo World! line 2' ) ; |
| 13708 | $sync->{ debug } and myprint( "[@output]" ) ; |
| 13709 | # Scalar context |
| 13710 | ok( "Hello World!\n" eq backtick( 'echo Hello World!' ), |
| 13711 | 'backtick: echo Hello World! scalar' ) ; |
| 13712 | ok( "Hello\nWorld!\n" eq backtick( "echo Hello\necho World!" ), |
| 13713 | 'backtick: echo Hello; echo World! scalar 2 lines' ) ; |
| 13714 | # Return error positive value, that's ok |
| 13715 | is( undef, backtick( 'false' ), 'backtick: false returns no output' ) ; |
| 13716 | my $mem = backtick( "ps -o vsz -p $PROCESS_ID" ) ; |
| 13717 | $sync->{ debug } and myprint( "MEM=$mem\n" ) ; |
| 13718 | |
| 13719 | } |
| 13720 | |
| 13721 | note( 'Leaving tests_backtick()' ) ; |
| 13722 | return ; |
| 13723 | } |
| 13724 | |
| 13725 | |
| 13726 | sub backtick |
| 13727 | { |
| 13728 | my $command = shift ; |
| 13729 | |
| 13730 | if ( ! $command ) { return ; } |
| 13731 | |
| 13732 | my ( $writer, $reader, $err ) ; |
| 13733 | my @output ; |
| 13734 | my $pid ; |
| 13735 | my $eval = eval { |
| 13736 | $pid = IPC::Open3::open3( $writer, $reader, $err, $command ) ; |
| 13737 | } ; |
| 13738 | if ( $EVAL_ERROR ) { |
| 13739 | myprint( $EVAL_ERROR ) ; |
| 13740 | return ; |
| 13741 | } |
| 13742 | if ( ! $eval ) { return ; } |
| 13743 | if ( ! $pid ) { return ; } |
| 13744 | waitpid( $pid, 0 ) ; |
| 13745 | @output = <$reader>; # Output here |
| 13746 | # |
| 13747 | #my @errors = <$err>; #Errors here, instead of the console |
| 13748 | if ( not @output ) { return ; } |
| 13749 | #myprint( @output ) ; |
| 13750 | |
| 13751 | if ( $output[0] =~ /\Qopen3: exec of $command failed\E/mxs ) { return ; } |
| 13752 | if ( wantarray ) { |
| 13753 | return( @output ) ; |
| 13754 | } else { |
| 13755 | return( join( q{}, @output) ) ; |
| 13756 | } |
| 13757 | } |
| 13758 | |
| 13759 | |
| 13760 | |
| 13761 | sub tests_check_binary_embed_all_dyn_libs |
| 13762 | { |
| 13763 | note( 'Entering tests_check_binary_embed_all_dyn_libs()' ) ; |
| 13764 | |
| 13765 | is( 1, check_binary_embed_all_dyn_libs( ), 'check_binary_embed_all_dyn_libs: no args => 1' ) ; |
| 13766 | |
| 13767 | note( 'Leaving tests_check_binary_embed_all_dyn_libs()' ) ; |
| 13768 | |
| 13769 | return ; |
| 13770 | } |
| 13771 | |
| 13772 | |
| 13773 | sub check_binary_embed_all_dyn_libs |
| 13774 | { |
| 13775 | my @search_dyn_lib_locale = search_dyn_lib_locale( ) ; |
| 13776 | |
| 13777 | if ( @search_dyn_lib_locale ) |
| 13778 | { |
| 13779 | myprint( "Found myself $PROGRAM_NAME pid $PROCESS_ID using locale dynamic libraries that seems out of myself:\n" ) ; |
| 13780 | myprint( @search_dyn_lib_locale ) ; |
| 13781 | if ( $PROGRAM_NAME =~ m{imapsync_bin_Darwin} ) |
| 13782 | { |
| 13783 | return 0 ; |
| 13784 | } |
| 13785 | elsif ( $PROGRAM_NAME =~ m{imapsync.*\.exe} ) |
| 13786 | { |
| 13787 | return 0 ; |
| 13788 | } |
| 13789 | else |
| 13790 | { |
| 13791 | # is always ok for non binary |
| 13792 | return 1 ; |
| 13793 | } |
| 13794 | } |
| 13795 | else |
| 13796 | { |
| 13797 | # Found only embedded dynamic lib |
| 13798 | myprint( "Found nothing\n" ) ; |
| 13799 | return 1 ; |
| 13800 | } |
| 13801 | } |
| 13802 | |
| 13803 | sub search_dyn_lib_locale |
| 13804 | { |
| 13805 | if ( 'darwin' eq $OSNAME ) |
| 13806 | { |
| 13807 | return search_dyn_lib_locale_darwin( ) ; |
| 13808 | } |
| 13809 | if ( 'linux' eq $OSNAME ) |
| 13810 | { |
| 13811 | return search_dyn_lib_locale_linux( ) ; |
| 13812 | } |
| 13813 | if ( 'MSWin32' eq $OSNAME ) |
| 13814 | { |
| 13815 | return search_dyn_lib_locale_MSWin32( ) ; |
| 13816 | } |
| 13817 | |
| 13818 | } |
| 13819 | |
| 13820 | sub search_dyn_lib_locale_darwin |
| 13821 | { |
| 13822 | my $command = qq{ lsof -p $PID | grep ' REG ' | grep .dylib | grep -v '/par-' } ; |
| 13823 | myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; |
| 13824 | return backtick( $command ) ; |
| 13825 | } |
| 13826 | |
| 13827 | sub search_dyn_lib_locale_linux |
| 13828 | { |
| 13829 | my $command = qq{ lsof -p $PID | grep ' REG ' | grep -v '/tmp/par-' | grep '\.so' } ; |
| 13830 | myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; |
| 13831 | return backtick( $command ) ; |
| 13832 | } |
| 13833 | |
| 13834 | sub search_dyn_lib_locale_MSWin32 |
| 13835 | { |
| 13836 | my $command = qq{ Listdlls.exe $PID|findstr Strawberry } ; |
| 13837 | # $command = qq{ Listdlls.exe $PID|findstr Strawberry } ; |
| 13838 | myprint( "Search non embeded dynamic libs with the command: $command\n" ) ; |
| 13839 | return qx( $command ) ; |
| 13840 | } |
| 13841 | |
| 13842 | |
| 13843 | |
| 13844 | sub remove_not_num |
| 13845 | { |
| 13846 | |
| 13847 | my $string = shift ; |
| 13848 | $string =~ tr/0-9//cd ; |
| 13849 | #myprint( "tr [$string]\n" ) ; |
| 13850 | return( $string ) ; |
| 13851 | } |
| 13852 | |
| 13853 | sub tests_remove_not_num |
| 13854 | { |
| 13855 | note( 'Entering tests_remove_not_num()' ) ; |
| 13856 | |
| 13857 | ok( '123' eq remove_not_num( 123 ), 'remove_not_num( 123 )' ) ; |
| 13858 | ok( '123' eq remove_not_num( '123' ), q{remove_not_num( '123' )} ) ; |
| 13859 | ok( '123' eq remove_not_num( '12 3' ), q{remove_not_num( '12 3' )} ) ; |
| 13860 | ok( '123' eq remove_not_num( 'a 12 3 Ko' ), q{remove_not_num( 'a 12 3 Ko' )} ) ; |
| 13861 | |
| 13862 | note( 'Leaving tests_remove_not_num()' ) ; |
| 13863 | return ; |
| 13864 | } |
| 13865 | |
| 13866 | sub remove_Ko |
| 13867 | { |
| 13868 | my $string = shift; |
| 13869 | if ($string =~ /^(.*)\sKo$/xo) { |
| 13870 | return($1); |
| 13871 | }else{ |
| 13872 | return($string); |
| 13873 | } |
| 13874 | } |
| 13875 | |
| 13876 | sub remove_qq |
| 13877 | { |
| 13878 | my $string = shift; |
| 13879 | if ($string =~ /^"(.*)"$/xo) { |
| 13880 | return($1); |
| 13881 | }else{ |
| 13882 | return($string); |
| 13883 | } |
| 13884 | } |
| 13885 | |
| 13886 | sub memory_consumption_ratio |
| 13887 | { |
| 13888 | |
| 13889 | my ($base) = @_; |
| 13890 | $base ||= 1; |
| 13891 | my $consu = memory_consumption(); |
| 13892 | return($consu / $base); |
| 13893 | } |
| 13894 | |
| 13895 | |
| 13896 | sub date_from_rcs |
| 13897 | { |
| 13898 | my $d = shift ; |
| 13899 | |
| 13900 | my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ; |
| 13901 | if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { |
| 13902 | # Handles the following format |
| 13903 | # 2015/07/10 11:05:59 -- Generated by RCS Date tag. |
| 13904 | #myprint( "$d\n" ) ; |
| 13905 | #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; |
| 13906 | my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ; |
| 13907 | $month = $num2mon{$month} ; |
| 13908 | $d = "$day-$month-$year $hour:$min:$sec +0000" ; |
| 13909 | #myprint( "$d\n" ) ; |
| 13910 | } |
| 13911 | return( $d ) ; |
| 13912 | } |
| 13913 | |
| 13914 | sub tests_date_from_rcs |
| 13915 | { |
| 13916 | note( 'Entering tests_date_from_rcs()' ) ; |
| 13917 | |
| 13918 | ok('19-Sep-2015 16:11:07 +0000' |
| 13919 | eq date_from_rcs('Date: 2015/09/19 16:11:07 '), 'date_from_rcs from RCS date' ) ; |
| 13920 | |
| 13921 | note( 'Leaving tests_date_from_rcs()' ) ; |
| 13922 | return ; |
| 13923 | } |
| 13924 | |
| 13925 | sub good_date |
| 13926 | { |
| 13927 | # two incoming formats: |
| 13928 | # header Tue, 24 Aug 2010 16:00:00 +0200 |
| 13929 | # internal 24-Aug-2010 16:00:00 +0200 |
| 13930 | |
| 13931 | # outgoing format: internal date format |
| 13932 | # 24-Aug-2010 16:00:00 +0200 |
| 13933 | |
| 13934 | my $d = shift ; |
| 13935 | return(q{}) if not defined $d; |
| 13936 | |
| 13937 | SWITCH: { |
| 13938 | if ( $d =~ m{(\d?)(\d-...-\d{4})(\s\d{2}:\d{2}:\d{2})(\s(?:\+|-)\d{4})?}xo ) { |
| 13939 | #myprint( "internal: [$1][$2][$3][$4]\n" ) ; |
| 13940 | my ($day_1, $date_rest, $hour, $zone) = ($1,$2,$3,$4) ; |
| 13941 | $day_1 = '0' if ($day_1 eq q{}) ; |
| 13942 | $zone = ' +0000' if not defined $zone ; |
| 13943 | $d = $day_1 . $date_rest . $hour . $zone ; |
| 13944 | last SWITCH ; |
| 13945 | } |
| 13946 | |
| 13947 | if ($d =~ m{(?:\w{3,},\s)?(\d{1,2}),?\s+(\w{3,})\s+(\d{2,4})\s+(\d{1,2})(?::|\.)(\d{1,2})(?:(?::|\.)(\d{1,2}))?\s*((?:\+|-)\d{4})?}xo ) { |
| 13948 | # Handles any combination of following formats |
| 13949 | # Tue, 24 Aug 2010 16:00:00 +0200 -- Standard |
| 13950 | # 24 Aug 2010 16:00:00 +0200 -- Missing Day of Week |
| 13951 | # Tue, 24 Aug 97 16:00:00 +0200 -- Two digit year |
| 13952 | # Tue, 24 Aug 1997 16.00.00 +0200 -- Periods instead of colons |
| 13953 | # Tue, 24 Aug 1997 16:00:00 +0200 -- Extra whitespace between year and hour |
| 13954 | # Tue, 24 Aug 1997 6:5:2 +0200 -- Single digit hour, min, or second |
| 13955 | # Tue, 24, Aug 1997 16:00:00 +0200 -- Extra comma |
| 13956 | |
| 13957 | #myprint( "header: [$1][$2][$3][$4][$5][$6][$7][$8]\n" ) ; |
| 13958 | my ($day, $month, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7,$8); |
| 13959 | $year = '19' . $year if length($year) == 2 && $year =~ m/^[789]/xo; |
| 13960 | $year = '20' . $year if length($year) == 2; |
| 13961 | |
| 13962 | $month = substr $month, 0, 3 if length($month) > 4; |
| 13963 | $day = mysprintf( '%02d', $day); |
| 13964 | $hour = mysprintf( '%02d', $hour); |
| 13965 | $min = mysprintf( '%02d', $min); |
| 13966 | $sec = '00' if not defined $sec ; |
| 13967 | $sec = mysprintf( '%02d', $sec ) ; |
| 13968 | $zone = '+0000' if not defined $zone ; |
| 13969 | $d = "$day-$month-$year $hour:$min:$sec $zone" ; |
| 13970 | last SWITCH ; |
| 13971 | } |
| 13972 | |
| 13973 | if ($d =~ m{(?:.{3})\s(...)\s+(\d{1,2})\s(\d{1,2}):(\d{1,2}):(\d{1,2})\s(?:\w{3})?\s?(\d{4})}xo ) { |
| 13974 | # Handles any combination of following formats |
| 13975 | # Sun Aug 20 11:55:09 2006 |
| 13976 | # Wed Jan 24 11:58:38 MST 2007 |
| 13977 | # Wed Jan 2 08:40:57 2008 |
| 13978 | |
| 13979 | #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; |
| 13980 | my ($month, $day, $hour, $min, $sec, $year) = ($1,$2,$3,$4,$5,$6); |
| 13981 | $day = mysprintf( '%02d', $day ) ; |
| 13982 | $hour = mysprintf( '%02d', $hour ) ; |
| 13983 | $min = mysprintf( '%02d', $min ) ; |
| 13984 | $sec = mysprintf( '%02d', $sec ) ; |
| 13985 | $d = "$day-$month-$year $hour:$min:$sec +0000" ; |
| 13986 | last SWITCH ; |
| 13987 | } |
| 13988 | my %num2mon = qw( 01 Jan 02 Feb 03 Mar 04 Apr 05 May 06 Jun 07 Jul 08 Aug 09 Sep 10 Oct 11 Nov 12 Dec ) ; |
| 13989 | |
| 13990 | if ($d =~ m{(\d{4})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { |
| 13991 | # Handles the following format |
| 13992 | # 2015/07/10 11:05:59 -- Generated by RCS Date tag. |
| 13993 | #myprint( "$d\n" ) ; |
| 13994 | #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; |
| 13995 | my ($year, $month, $day, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6) ; |
| 13996 | $month = $num2mon{$month} ; |
| 13997 | $d = "$day-$month-$year $hour:$min:$sec +0000" ; |
| 13998 | #myprint( "$d\n" ) ; |
| 13999 | last SWITCH ; |
| 14000 | } |
| 14001 | |
| 14002 | if ($d =~ m{(\d{2})/(\d{2})/(\d{2})\s(\d{2}):(\d{2}):(\d{2})}xo ) { |
| 14003 | # Handles the following format |
| 14004 | # 02/06/09 22:18:08 -- Generated by AVTECH TemPageR devices |
| 14005 | |
| 14006 | #myprint( "header: [$1][$2][$3][$4][$5][$6]\n" ) ; |
| 14007 | my ($month, $day, $year, $hour, $min, $sec) = ($1,$2,$3,$4,$5,$6); |
| 14008 | $year = '20' . $year; |
| 14009 | $month = $num2mon{$month}; |
| 14010 | $d = "$day-$month-$year $hour:$min:$sec +0000"; |
| 14011 | last SWITCH ; |
| 14012 | } |
| 14013 | |
| 14014 | if ($d =~ m{\w{6,},\s(\w{3})\w+\s+(\d{1,2}),\s(\d{4})\s(\d{2}):(\d{2})\s(AM|PM)}xo ) { |
| 14015 | # Handles the following format |
| 14016 | # Saturday, December 14, 2002 05:00 PM - KBtoys.com order confirmations |
| 14017 | |
| 14018 | my ($month, $day, $year, $hour, $min, $apm) = ($1,$2,$3,$4,$5,$6); |
| 14019 | |
| 14020 | $hour += 12 if $apm eq 'PM' ; |
| 14021 | $day = mysprintf( '%02d', $day ) ; |
| 14022 | $d = "$day-$month-$year $hour:$min:00 +0000" ; |
| 14023 | last SWITCH ; |
| 14024 | } |
| 14025 | |
| 14026 | if ($d =~ m{(\w{3})\s(\d{1,2})\s(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-)\d{4})}xo ) { |
| 14027 | # Handles the following format |
| 14028 | # Saturday, December 14, 2002 05:00 PM - jr.com order confirmations |
| 14029 | |
| 14030 | my ($month, $day, $year, $hour, $min, $sec, $zone) = ($1,$2,$3,$4,$5,$6,$7); |
| 14031 | |
| 14032 | $day = mysprintf( '%02d', $day ) ; |
| 14033 | $d = "$day-$month-$year $hour:$min:$sec $zone"; |
| 14034 | last SWITCH ; |
| 14035 | } |
| 14036 | |
| 14037 | if ($d =~ m{(\d{1,2})-(\w{3})-(\d{4})}xo ) { |
| 14038 | # Handles the following format |
| 14039 | # 21-Jun-2001 - register.com domain transfer email circa 2001 |
| 14040 | |
| 14041 | my ($day, $month, $year) = ($1,$2,$3); |
| 14042 | $day = mysprintf( '%02d', $day); |
| 14043 | $d = "$day-$month-$year 11:11:11 +0000"; |
| 14044 | last SWITCH ; |
| 14045 | } |
| 14046 | |
| 14047 | # unknown or unmatch => return same string |
| 14048 | return($d); |
| 14049 | } |
| 14050 | |
| 14051 | $d = qq("$d") ; |
| 14052 | return( $d ) ; |
| 14053 | } |
| 14054 | |
| 14055 | |
| 14056 | sub tests_good_date |
| 14057 | { |
| 14058 | note( 'Entering tests_good_date()' ) ; |
| 14059 | |
| 14060 | ok(q{} eq good_date(), 'good_date no arg'); |
| 14061 | ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24-Aug-2010 16:00:00 +0200'), 'good_date internal 2digit zone'); |
| 14062 | ok('"24-Aug-2010 16:00:00 +0000"' eq good_date('24-Aug-2010 16:00:00'), 'good_date internal 2digit no zone'); |
| 14063 | ok('"01-Sep-2010 16:00:00 +0200"' eq good_date( '1-Sep-2010 16:00:00 +0200'), 'good_date internal SP 1digit'); |
| 14064 | ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('Tue, 24 Aug 2010 16:00:00 +0200'), 'good_date header 2digit zone'); |
| 14065 | ok('"01-Sep-2010 16:00:00 +0000"' eq good_date('Wed, 1 Sep 2010 16:00:00'), 'good_date header SP 1digit zone'); |
| 14066 | ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200'), 'good_date header SP 1digit zone'); |
| 14067 | ok('"01-Sep-2010 16:00:00 +0200"' eq good_date('Wed, 1 Sep 2010 16:00:00 +0200 (CEST)'), 'good_date header SP 1digit zone'); |
| 14068 | ok('"06-Feb-2009 22:18:08 +0000"' eq good_date('02/06/09 22:18:08'), 'good_date header TemPageR'); |
| 14069 | ok('"02-Jan-2008 08:40:57 +0000"' eq good_date('Wed Jan 2 08:40:57 2008'), 'good_date header dice.com support 1digit day'); |
| 14070 | ok('"20-Aug-2006 11:55:09 +0000"' eq good_date('Sun Aug 20 11:55:09 2006'), 'good_date header dice.com support 2digit day'); |
| 14071 | ok('"24-Jan-2007 11:58:38 +0000"' eq good_date('Wed Jan 24 11:58:38 MST 2007'), 'good_date header status-now.com'); |
| 14072 | ok('"24-Aug-2010 16:00:00 +0200"' eq good_date('24 Aug 2010 16:00:00 +0200'), 'good_date header missing date of week'); |
| 14073 | ok('"24-Aug-2067 16:00:00 +0200"' eq good_date('Tue, 24 Aug 67 16:00:00 +0200'), 'good_date header 2digit year'); |
| 14074 | ok('"24-Aug-1977 16:00:00 +0200"' eq good_date('Tue, 24 Aug 77 16:00:00 +0200'), 'good_date header 2digit year'); |
| 14075 | ok('"24-Aug-1987 16:00:00 +0200"' eq good_date('Tue, 24 Aug 87 16:00:00 +0200'), 'good_date header 2digit year'); |
| 14076 | ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 97 16:00:00 +0200'), 'good_date header 2digit year'); |
| 14077 | ok('"24-Aug-2004 16:00:00 +0200"' eq good_date('Tue, 24 Aug 04 16:00:00 +0200'), 'good_date header 2digit year'); |
| 14078 | ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16.00.00 +0200'), 'good_date header period time sep'); |
| 14079 | ok('"24-Aug-1997 16:00:00 +0200"' eq good_date('Tue, 24 Aug 1997 16:00:00 +0200'), 'good_date header extra white space type1'); |
| 14080 | ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24 Aug 1997 5:6:2 +0200'), 'good_date header 1digit time vals'); |
| 14081 | ok('"24-Aug-1997 05:06:02 +0200"' eq good_date('Tue, 24, Aug 1997 05:06:02 +0200'), 'good_date header extra commas'); |
| 14082 | ok('"01-Oct-2003 12:45:24 +0000"' eq good_date('Wednesday, 01 October 2003 12:45:24 CDT'), 'good_date header no abbrev'); |
| 14083 | ok('"11-Jan-2005 17:58:27 -0500"' eq good_date('Tue, 11 Jan 2005 17:58:27 -0500'), 'good_date extra white space'); |
| 14084 | ok('"18-Dec-2002 15:07:00 +0000"' eq good_date('Wednesday, December 18, 2002 03:07 PM'), 'good_date kbtoys.com orders'); |
| 14085 | ok('"16-Dec-2004 02:01:49 -0500"' eq good_date('Dec 16 2004 02:01:49 -0500'), 'good_date jr.com orders'); |
| 14086 | ok('"21-Jun-2001 11:11:11 +0000"' eq good_date('21-Jun-2001'), 'good_date register.com domain transfer'); |
| 14087 | ok('"18-Nov-2012 18:34:38 +0100"' eq good_date('Sun, 18 Nov 2012 18:34:38 +0100'), 'good_date pop2imap bug (Westeuropäische Normalzeit)'); |
| 14088 | ok('"19-Sep-2015 16:11:07 +0000"' eq good_date('Date: 2015/09/19 16:11:07 '), 'good_date from RCS date' ) ; |
| 14089 | |
| 14090 | note( 'Leaving tests_good_date()' ) ; |
| 14091 | return ; |
| 14092 | } |
| 14093 | |
| 14094 | |
| 14095 | sub tests_list_keys_in_2_not_in_1 |
| 14096 | { |
| 14097 | note( 'Entering tests_list_keys_in_2_not_in_1()' ) ; |
| 14098 | |
| 14099 | |
| 14100 | my @list; |
| 14101 | ok( ! list_keys_in_2_not_in_1( {}, {}), 'list_keys_in_2_not_in_1: {} {}'); |
| 14102 | ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {}, {} ) ] ), 'list_keys_in_2_not_in_1: {} {}'); |
| 14103 | ok( 0 == compare_lists( ['a','b'], [ list_keys_in_2_not_in_1( {}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {} {a, b}'); |
| 14104 | ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a} {a, b}'); |
| 14105 | ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b} {a, b}'); |
| 14106 | ok( 0 == compare_lists( [], [ list_keys_in_2_not_in_1( {'a' => 1, 'b' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}'); |
| 14107 | ok( 0 == compare_lists( ['b'], [ list_keys_in_2_not_in_1( {'a' => 1, 'c' => 1}, {'a' => 1, 'b' => 1}) ]), 'list_keys_in_2_not_in_1: {a, b, c} {a, b}'); |
| 14108 | |
| 14109 | note( 'Leaving tests_list_keys_in_2_not_in_1()' ) ; |
| 14110 | return ; |
| 14111 | } |
| 14112 | |
| 14113 | sub list_keys_in_2_not_in_1 |
| 14114 | { |
| 14115 | my $hash_1_ref = shift; |
| 14116 | my $hash_2_ref = shift; |
| 14117 | my @list; |
| 14118 | |
| 14119 | foreach my $key ( sort keys %{ $hash_2_ref } ) { |
| 14120 | #$sync->{ debug } and print "$key\n" ; |
| 14121 | if ( exists $hash_1_ref->{$key} ) |
| 14122 | { |
| 14123 | next ; |
| 14124 | } |
| 14125 | #$sync->{ debug } and print "list_keys_in_2_not_in_1: $key\n" ; |
| 14126 | push @list, $key ; |
| 14127 | } |
| 14128 | #$sync->{ debug } and print "@list\n" ; |
| 14129 | return( @list ) ; |
| 14130 | } |
| 14131 | |
| 14132 | |
| 14133 | sub list_folders_in_2_not_in_1 |
| 14134 | { |
| 14135 | |
| 14136 | my ( @h2_folders_not_in_h1, %h2_folders_not_in_h1 ) ; |
| 14137 | @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h1_folders_all, \%h2_folders_all ) ; |
| 14138 | map { $h2_folders_not_in_h1{$_} = 1} @h2_folders_not_in_h1 ; |
| 14139 | @h2_folders_not_in_h1 = list_keys_in_2_not_in_1( \%h2_folders_from_1_all, \%h2_folders_not_in_h1 ) ; |
| 14140 | #$sync->{ debug } and print "h2_folders_not_in_h1: @h2_folders_not_in_h1\n" ; |
| 14141 | return( reverse @h2_folders_not_in_h1 ) ; |
| 14142 | } |
| 14143 | |
| 14144 | sub tests_nb_messages_in_2_not_in_1 |
| 14145 | { |
| 14146 | note( 'Entering tests_stats_across_folders()' ) ; |
| 14147 | is( undef, nb_messages_in_2_not_in_1( ), 'nb_messages_in_2_not_in_1: no args => undef' ) ; |
| 14148 | |
| 14149 | my $mysync->{ h1_folders_of_md5 }->{ 'some_id_01' }->{ 'some_folder_01' } = 1 ; |
| 14150 | is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: no messages in 2 => 0' ) ; |
| 14151 | |
| 14152 | $mysync->{ h1_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_01' } = 2 ; |
| 14153 | $mysync->{ h2_folders_of_md5 }->{ 'some_id_in_1_and_2' }->{ 'some_folder_02' } = 4 ; |
| 14154 | |
| 14155 | is( 0, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: a common message => 0' ) ; |
| 14156 | |
| 14157 | $mysync->{ h2_folders_of_md5 }->{ 'some_id_in_2_not_in_1' }->{ 'some_folder_02' } = 1 ; |
| 14158 | is( 1, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: one message in_2_not_in_1 => 1' ) ; |
| 14159 | |
| 14160 | $mysync->{ h2_folders_of_md5 }->{ 'some_other_id_in_2_not_in_1' }->{ 'some_folder_02' } = 3 ; |
| 14161 | is( 2, nb_messages_in_2_not_in_1( $mysync ), 'nb_messages_in_2_not_in_1: two messages in_2_not_in_1 => 2' ) ; |
| 14162 | |
| 14163 | note( 'Leaving tests_stats_across_folders()' ) ; |
| 14164 | return ; |
| 14165 | } |
| 14166 | |
| 14167 | sub nb_messages_in_2_not_in_1 |
| 14168 | { |
| 14169 | my $mysync = shift ; |
| 14170 | if ( not defined $mysync ) { return ; } |
| 14171 | |
| 14172 | $mysync->{ nb_messages_in_2_not_in_1 } = scalar( |
| 14173 | list_keys_in_2_not_in_1( |
| 14174 | $mysync->{ h1_folders_of_md5 }, |
| 14175 | $mysync->{ h2_folders_of_md5 } ) ) ; |
| 14176 | |
| 14177 | return $mysync->{ nb_messages_in_2_not_in_1 } ; |
| 14178 | } |
| 14179 | |
| 14180 | |
| 14181 | sub nb_messages_in_1_not_in_2 |
| 14182 | { |
| 14183 | my $mysync = shift ; |
| 14184 | if ( not defined $mysync ) { return ; } |
| 14185 | |
| 14186 | $mysync->{ nb_messages_in_1_not_in_2 } = scalar( |
| 14187 | list_keys_in_2_not_in_1( |
| 14188 | $mysync->{ h2_folders_of_md5 }, |
| 14189 | $mysync->{ h1_folders_of_md5 } ) ) ; |
| 14190 | |
| 14191 | return $mysync->{ nb_messages_in_1_not_in_2 } ; |
| 14192 | } |
| 14193 | |
| 14194 | |
| 14195 | |
| 14196 | sub comment_on_final_diff_in_1_not_in_2 |
| 14197 | { |
| 14198 | my $mysync = shift ; |
| 14199 | |
| 14200 | if ( not defined $mysync |
| 14201 | or $mysync->{ justfolders } |
| 14202 | or $mysync->{ useuid } |
| 14203 | ) |
| 14204 | { |
| 14205 | return ; |
| 14206 | } |
| 14207 | |
| 14208 | my $nb_identified_h1_messages = scalar( keys %{ $mysync->{ h1_folders_of_md5 } } ) ; |
| 14209 | my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ; |
| 14210 | $mysync->{ debug } and myprint( "nb_keys h1_folders_of_md5 $nb_identified_h1_messages\n" ) ; |
| 14211 | $mysync->{ debug } and myprint( "nb_keys h2_folders_of_md5 $nb_identified_h2_messages\n" ) ; |
| 14212 | |
| 14213 | if ( 0 == $nb_identified_h1_messages ) { return ; } |
| 14214 | |
| 14215 | # Calculate if not yet done |
| 14216 | if ( not defined $mysync->{ nb_messages_in_1_not_in_2 } ) |
| 14217 | { |
| 14218 | nb_messages_in_1_not_in_2( $mysync ) ; |
| 14219 | } |
| 14220 | |
| 14221 | |
| 14222 | if ( 0 == $mysync->{ nb_messages_in_1_not_in_2 } ) |
| 14223 | { |
| 14224 | myprint( "The sync looks good, all ", |
| 14225 | $nb_identified_h1_messages, |
| 14226 | " identified messages in host1 are on host2.\n" ) ; |
| 14227 | } |
| 14228 | else |
| 14229 | { |
| 14230 | myprint( "The sync is not finished, there are ", |
| 14231 | $mysync->{ nb_messages_in_1_not_in_2 }, |
| 14232 | " identified messages in host1 that are not on host2.\n" ) ; |
| 14233 | } |
| 14234 | |
| 14235 | |
| 14236 | if ( 1 <= $mysync->{ h1_nb_msg_noheader } ) |
| 14237 | { |
| 14238 | myprint( "There are ", |
| 14239 | $mysync->{ h1_nb_msg_noheader }, |
| 14240 | " unidentified messages (usually Sent or Draft messages).", |
| 14241 | " To sync them add option --addheader\n" ) ; |
| 14242 | } |
| 14243 | else |
| 14244 | { |
| 14245 | myprint( "There is no unidentified message\n" ) ; |
| 14246 | } |
| 14247 | |
| 14248 | return ; |
| 14249 | } |
| 14250 | |
| 14251 | sub comment_on_final_diff_in_2_not_in_1 |
| 14252 | { |
| 14253 | my $mysync = shift ; |
| 14254 | |
| 14255 | if ( not defined $mysync |
| 14256 | or $mysync->{ justfolders } |
| 14257 | or $mysync->{ useuid } |
| 14258 | ) |
| 14259 | { |
| 14260 | return ; |
| 14261 | } |
| 14262 | |
| 14263 | my $nb_identified_h2_messages = scalar( keys %{ $mysync->{ h2_folders_of_md5 } } ) ; |
| 14264 | # Calculate if not done yet |
| 14265 | if ( not defined $mysync->{ nb_messages_in_2_not_in_1 } ) |
| 14266 | { |
| 14267 | nb_messages_in_2_not_in_1( $mysync ) ; |
| 14268 | } |
| 14269 | |
| 14270 | if ( 0 == $mysync->{ nb_messages_in_2_not_in_1 } ) |
| 14271 | { |
| 14272 | myprint( "The sync is strict, all ", |
| 14273 | $nb_identified_h2_messages, |
| 14274 | " identified messages in host2 are on host1.\n" ) ; |
| 14275 | } |
| 14276 | else |
| 14277 | { |
| 14278 | myprint( "The sync is not strict, there are ", |
| 14279 | $mysync->{ nb_messages_in_2_not_in_1 }, |
| 14280 | " messages in host2 that are not on host1.", |
| 14281 | " Use --delete2 to delete them and have a strict sync.", |
| 14282 | " ($nb_identified_h2_messages identified messages in host2)\n" ) ; |
| 14283 | } |
| 14284 | return ; |
| 14285 | } |
| 14286 | |
| 14287 | |
| 14288 | sub tests_match |
| 14289 | { |
| 14290 | note( 'Entering tests_match()' ) ; |
| 14291 | |
| 14292 | # undef serie |
| 14293 | is( undef, match( ), 'match: no args => undef' ) ; |
| 14294 | is( undef, match( 'lalala' ), 'match: one args => undef' ) ; |
| 14295 | |
| 14296 | # This one gives 0 under a binary made by pp |
| 14297 | # but 1 under "normal" Perl interpreter. So a PAR bug? |
| 14298 | #is( 1, match( q{}, q{} ), 'match: q{} =~ q{} => 1' ) ; |
| 14299 | |
| 14300 | is( 'lalala', match( 'lalala', 'lalala' ), 'match: lalala =~ lalala => lalala' ) ; |
| 14301 | is( 'lalala', match( 'lalala', '^lalala' ), 'match: lalala =~ ^lalala => lalala' ) ; |
| 14302 | is( 'lalala', match( 'lalala', 'lalala$' ), 'match: lalala =~ lalala$ => lalala' ) ; |
| 14303 | is( 'lalala', match( 'lalala', '^lalala$' ), 'match: lalala =~ ^lalala$ => lalala' ) ; |
| 14304 | is( '_lalala_', match( '_lalala_', 'lalala' ), 'match: _lalala_ =~ lalala => _lalala_' ) ; |
| 14305 | is( 'lalala', match( 'lalala', '.*' ), 'match: lalala =~ .* => lalala' ) ; |
| 14306 | is( 'lalala', match( 'lalala', '.' ), 'match: lalala =~ . => lalala' ) ; |
| 14307 | is( '/lalala/', match( '/lalala/', '/lalala/' ), 'match: /lalala/ =~ /lalala/ => /lalala/' ) ; |
| 14308 | |
| 14309 | is( 0, match( 'foo', 's/foo/bar/g' ), 'match: foo =~ s/foo/bar/g => 0' ) ; |
| 14310 | is( 's/foo/bar/g', match( 's/foo/bar/g', 's/foo/bar/g' ), 'match: s/foo/bar/g =~ s/foo/bar/g => s/foo/bar/g' ) ; |
| 14311 | |
| 14312 | |
| 14313 | is( 0, match( 'lalala', 'ooo' ), 'match: lalala =~ ooo => 0' ) ; |
| 14314 | is( 0, match( 'lalala', 'lal_ala' ), 'match: lalala =~ lal_ala => 0' ) ; |
| 14315 | is( 0, match( 'lalala', '\.' ), 'match: lalala =~ \. => 0' ) ; |
| 14316 | is( 0, match( 'lalalaX', '^lalala$' ), 'match: lalalaX =~ ^lalala$ => 0' ) ; |
| 14317 | is( 0, match( 'lalala', '/lalala/' ), 'match: lalala =~ /lalala/ => 0' ) ; |
| 14318 | |
| 14319 | is( 'LALALA', match( 'LALALA', '(?i:lalala)' ), 'match: LALALA =~ (?i:lalala) => 1' ) ; |
| 14320 | |
| 14321 | is( undef, match( 'LALALA', '(?{`ls /`})' ), 'match: LALALA =~ (?{`ls /`}) => undef' ) ; |
| 14322 | is( undef, match( 'LALALA', '(?{print "CACA"})' ), 'match: LALALA =~ (?{print "CACA"}) => undef' ) ; |
| 14323 | is( undef, match( 'CACA', '(??{print "CACA"})' ), 'match: CACA =~ (??{print "CACA"}) => undef' ) ; |
| 14324 | |
| 14325 | note( 'Leaving tests_match()' ) ; |
| 14326 | |
| 14327 | return ; |
| 14328 | } |
| 14329 | |
| 14330 | sub match |
| 14331 | { |
| 14332 | my( $var, $regex ) = @ARG ; |
| 14333 | |
| 14334 | # undef cases |
| 14335 | if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; } |
| 14336 | |
| 14337 | # normal cases |
| 14338 | if ( eval { $var =~ qr{$regex} } ) { |
| 14339 | return $var ; |
| 14340 | }elsif ( $EVAL_ERROR ) { |
| 14341 | myprint( "Fatal regex $regex\n" ) ; |
| 14342 | return ; |
| 14343 | } else { |
| 14344 | return 0 ; |
| 14345 | } |
| 14346 | return ; |
| 14347 | } |
| 14348 | |
| 14349 | |
| 14350 | sub tests_notmatch |
| 14351 | { |
| 14352 | note( 'Entering tests_notmatch()' ) ; |
| 14353 | |
| 14354 | # undef serie |
| 14355 | is( undef, notmatch( ), 'notmatch: no args => undef' ) ; |
| 14356 | is( undef, notmatch( 'lalala' ), 'notmatch: one args => undef' ) ; |
| 14357 | |
| 14358 | is( 1, notmatch( 'lalala', '/lalala/' ), 'notmatch: lalala !~ /lalala/ => 1' ) ; |
| 14359 | is( 0, notmatch( '/lalala/', '/lalala/' ), 'notmatch: /lalala/ !~ /lalala/ => 0' ) ; |
| 14360 | is( 1, notmatch( 'lalala', '/ooo/' ), 'notmatch: lalala !~ /ooo/ => 1' ) ; |
| 14361 | |
| 14362 | # This one gives 1 under a binary made by pp |
| 14363 | # but 0 under "normal" Perl interpreter. So a PAR bug, same in tests_match . |
| 14364 | #is( 0, notmatch( q{}, q{} ), 'notmatch: q{} !~ q{} => 0' ) ; |
| 14365 | |
| 14366 | is( 0, notmatch( 'lalala', 'lalala' ), 'notmatch: lalala !~ lalala => 0' ) ; |
| 14367 | is( 0, notmatch( 'lalala', '^lalala' ), 'notmatch: lalala !~ ^lalala => 0' ) ; |
| 14368 | is( 0, notmatch( 'lalala', 'lalala$' ), 'notmatch: lalala !~ lalala$ => 0' ) ; |
| 14369 | is( 0, notmatch( 'lalala', '^lalala$' ), 'notmatch: lalala !~ ^lalala$ => 0' ) ; |
| 14370 | is( 0, notmatch( '_lalala_', 'lalala' ), 'notmatch: _lalala_ !~ lalala => 0' ) ; |
| 14371 | is( 0, notmatch( 'lalala', '.*' ), 'notmatch: lalala !~ .* => 0' ) ; |
| 14372 | is( 0, notmatch( 'lalala', '.' ), 'notmatch: lalala !~ . => 0' ) ; |
| 14373 | |
| 14374 | |
| 14375 | is( 1, notmatch( 'lalala', 'ooo' ), 'notmatch: does not match regex => 1' ) ; |
| 14376 | is( 1, notmatch( 'lalala', 'lal_ala' ), 'notmatch: does not match regex => 1' ) ; |
| 14377 | is( 1, notmatch( 'lalala', '\.' ), 'notmatch: matches regex => 0' ) ; |
| 14378 | is( 1, notmatch( 'lalalaX', '^lalala$' ), 'notmatch: does not match regex => 1' ) ; |
| 14379 | |
| 14380 | note( 'Leaving tests_notmatch()' ) ; |
| 14381 | |
| 14382 | return ; |
| 14383 | } |
| 14384 | |
| 14385 | sub notmatch |
| 14386 | { |
| 14387 | my( $var, $regex ) = @ARG ; |
| 14388 | |
| 14389 | # undef cases |
| 14390 | if ( ( ! defined $var ) or ( ! defined $regex ) ) { return ; } |
| 14391 | |
| 14392 | # normal cases |
| 14393 | if ( eval { $var !~ $regex } ) { |
| 14394 | return 1 ; |
| 14395 | }elsif ( $EVAL_ERROR ) { |
| 14396 | myprint( "Fatal regex $regex\n" ) ; |
| 14397 | return ; |
| 14398 | }else{ |
| 14399 | return 0 ; |
| 14400 | } |
| 14401 | return ; |
| 14402 | } |
| 14403 | |
| 14404 | |
| 14405 | sub delete_folders_in_2_not_in_1 |
| 14406 | { |
| 14407 | |
| 14408 | foreach my $folder ( @h2_folders_not_in_1 ) { |
| 14409 | if ( defined $delete2foldersonly and eval "\$folder !~ $delete2foldersonly" ) { |
| 14410 | myprint( "Not deleting $folder because of --delete2foldersonly $delete2foldersonly\n" ) ; |
| 14411 | next ; |
| 14412 | } |
| 14413 | if ( defined $delete2foldersbutnot and eval "\$folder =~ $delete2foldersbutnot" ) { |
| 14414 | myprint( "Not deleting $folder because of --delete2foldersbutnot $delete2foldersbutnot\n" ) ; |
| 14415 | next ; |
| 14416 | } |
| 14417 | my $res = $sync->{dry} ; # always success in dry mode! |
| 14418 | $sync->{imap2}->unsubscribe( $folder ) if ( ! $sync->{dry} ) ; |
| 14419 | $res = $sync->{imap2}->delete( $folder ) if ( ! $sync->{dry} ) ; |
| 14420 | if ( $res ) { |
| 14421 | myprint( "Deleted $folder", "$sync->{dry_message}", "\n" ) ; |
| 14422 | }else{ |
| 14423 | myprint( "Deleting $folder failed", "\n" ) ; |
| 14424 | } |
| 14425 | } |
| 14426 | return ; |
| 14427 | } |
| 14428 | |
| 14429 | sub delete_folder |
| 14430 | { |
| 14431 | my ( $mysync, $imap, $folder, $Side ) = @_ ; |
| 14432 | if ( ! $mysync ) { return ; } |
| 14433 | if ( ! $imap ) { return ; } |
| 14434 | if ( ! $folder ) { return ; } |
| 14435 | $Side ||= 'HostX' ; |
| 14436 | |
| 14437 | my $res = $mysync->{dry} ; # always success in dry mode! |
| 14438 | if ( ! $mysync->{dry} ) { |
| 14439 | $imap->unsubscribe( $folder ) ; |
| 14440 | $res = $imap->delete( $folder ) ; |
| 14441 | } |
| 14442 | if ( $res ) { |
| 14443 | myprint( "$Side deleted $folder", $mysync->{dry_message}, "\n" ) ; |
| 14444 | return 1 ; |
| 14445 | }else{ |
| 14446 | myprint( "$Side deleting $folder failed", "\n" ) ; |
| 14447 | return ; |
| 14448 | } |
| 14449 | } |
| 14450 | |
| 14451 | sub delete1emptyfolders |
| 14452 | { |
| 14453 | my $mysync = shift ; |
| 14454 | if ( ! $mysync ) { return ; } # abort if no parameter |
| 14455 | if ( ! $mysync->{delete1emptyfolders} ) { return ; } # abort if --delete1emptyfolders off |
| 14456 | my $imap = $mysync->{imap1} ; |
| 14457 | if ( ! $imap ) { return ; } # abort if no imap |
| 14458 | if ( $imap->IsUnconnected( ) ) { return ; } # abort if disconnected |
| 14459 | |
| 14460 | my %folders_kept ; |
| 14461 | myprint( qq{Host1 deleting empty folders\n} ) ; |
| 14462 | foreach my $folder ( reverse sort @{ $mysync->{h1_folders_wanted} } ) { |
| 14463 | my $parenthood = $imap->is_parent( $folder ) ; |
| 14464 | if ( defined $parenthood and $parenthood ) { |
| 14465 | myprint( "Host1: folder $folder has subfolders\n" ) ; |
| 14466 | $folders_kept{ $folder }++ ; |
| 14467 | next ; |
| 14468 | } |
| 14469 | my $nb_messages_select = examine_folder_and_count( $mysync, $imap, $folder, 'Host1' ) ; |
| 14470 | if ( ! defined $nb_messages_select ) { next ; } # Select failed => Neither continue nor keep this folder } |
| 14471 | my $nb_messages_search = scalar( @{ $imap->messages( ) } ) ; |
| 14472 | if ( 0 != $nb_messages_select and 0 != $nb_messages_search ) { |
| 14473 | myprint( "Host1: folder $folder has messages: $nb_messages_search (search) $nb_messages_select (select)\n" ) ; |
| 14474 | $folders_kept{ $folder }++ ; |
| 14475 | next ; |
| 14476 | } |
| 14477 | if ( 0 != $nb_messages_select + $nb_messages_search ) { |
| 14478 | myprint( "Host1: folder $folder odd messages count: $nb_messages_search (search) $nb_messages_select (select)\n" ) ; |
| 14479 | $folders_kept{ $folder }++ ; |
| 14480 | next ; |
| 14481 | } |
| 14482 | # Here we must have 0 messages by messages() aka "SEARCH ALL" and also "EXAMINE" |
| 14483 | if ( uc $folder eq 'INBOX' ) { |
| 14484 | myprint( "Host1: Not deleting $folder\n" ) ; |
| 14485 | $folders_kept{ $folder }++ ; |
| 14486 | next ; |
| 14487 | } |
| 14488 | myprint( "Host1: deleting empty folder $folder\n" ) ; |
| 14489 | # can not delete a SELECTed or EXAMINEd folder so closing it |
| 14490 | # could changed be SELECT INBOX |
| 14491 | $imap->close( ) ; # close after examine does not expunge; anyway expunging an empty folder... |
| 14492 | if ( delete_folder( $mysync, $imap, $folder, 'Host1' ) ) { |
| 14493 | next ; # Deleted, good! |
| 14494 | }else{ |
| 14495 | $folders_kept{ $folder }++ ; |
| 14496 | next ; # Not deleted, bad! |
| 14497 | } |
| 14498 | } |
| 14499 | remove_deleted_folders_from_wanted_list( $mysync, %folders_kept ) ; |
| 14500 | myprint( qq{Host1 ended deleting empty folders\n} ) ; |
| 14501 | return ; |
| 14502 | } |
| 14503 | |
| 14504 | sub remove_deleted_folders_from_wanted_list |
| 14505 | { |
| 14506 | my ( $mysync, %folders_kept ) = @ARG ; |
| 14507 | |
| 14508 | my @h1_folders_wanted_init = @{ $mysync->{h1_folders_wanted} } ; |
| 14509 | my @h1_folders_wanted_last ; |
| 14510 | foreach my $folder ( @h1_folders_wanted_init ) { |
| 14511 | if ( $folders_kept{ $folder } ) { |
| 14512 | push @h1_folders_wanted_last, $folder ; |
| 14513 | } |
| 14514 | } |
| 14515 | @{ $mysync->{h1_folders_wanted} } = @h1_folders_wanted_last ; |
| 14516 | return ; |
| 14517 | } |
| 14518 | |
| 14519 | |
| 14520 | sub examine_folder_and_count |
| 14521 | { |
| 14522 | my ( $mysync, $imap, $folder, $Side ) = @_ ; |
| 14523 | $Side ||= 'HostX' ; |
| 14524 | |
| 14525 | if ( ! examine_folder( $mysync, $imap, $folder, $Side ) ) { |
| 14526 | return ; |
| 14527 | } |
| 14528 | my $nb_messages_select = count_from_select( $imap->History ) ; |
| 14529 | return $nb_messages_select ; |
| 14530 | } |
| 14531 | |
| 14532 | |
| 14533 | sub tests_delete1emptyfolders |
| 14534 | { |
| 14535 | note( 'Entering tests_delete1emptyfolders()' ) ; |
| 14536 | |
| 14537 | |
| 14538 | is( undef, delete1emptyfolders( ), q{delete1emptyfolders: undef} ) ; |
| 14539 | my $syncT ; |
| 14540 | is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef 2} ) ; |
| 14541 | my $imapT ; |
| 14542 | $syncT->{imap1} = $imapT ; |
| 14543 | is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: undef imap} ) ; |
| 14544 | |
| 14545 | require_ok( "Test::MockObject" ) ; |
| 14546 | $imapT = Test::MockObject->new( ) ; |
| 14547 | $syncT->{imap1} = $imapT ; |
| 14548 | |
| 14549 | $imapT->set_true( 'IsUnconnected' ) ; |
| 14550 | is( undef, delete1emptyfolders( $syncT ), q{delete1emptyfolders: Unconnected imap} ) ; |
| 14551 | |
| 14552 | # Now connected tests |
| 14553 | $imapT->set_false( 'IsUnconnected' ) ; |
| 14554 | $imapT->mock( 'LastError', sub { q{LastError mocked} } ) ; |
| 14555 | |
| 14556 | $syncT->{delete1emptyfolders} = 0 ; |
| 14557 | tests_delete1emptyfolders_unit( |
| 14558 | $syncT, |
| 14559 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14560 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14561 | q{tests_delete1emptyfolders: --delete1emptyfolders OFF} |
| 14562 | ) ; |
| 14563 | |
| 14564 | # All are parents => no deletion at all |
| 14565 | $imapT->set_true( 'is_parent' ) ; |
| 14566 | $syncT->{delete1emptyfolders} = 1 ; |
| 14567 | tests_delete1emptyfolders_unit( |
| 14568 | $syncT, |
| 14569 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14570 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14571 | q{tests_delete1emptyfolders: --delete1emptyfolders ON} |
| 14572 | ) ; |
| 14573 | |
| 14574 | # No parents but examine false for all => skip all |
| 14575 | $imapT->set_false( 'is_parent', 'examine' ) ; |
| 14576 | |
| 14577 | tests_delete1emptyfolders_unit( |
| 14578 | $syncT, |
| 14579 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14580 | [ ], |
| 14581 | q{tests_delete1emptyfolders: EXAMINE fails} |
| 14582 | ) ; |
| 14583 | |
| 14584 | # examine ok for all but History bad => skip all |
| 14585 | $imapT->set_true( 'examine' ) ; |
| 14586 | $imapT->mock( 'History', sub { ( q{History badly mocked} ) } ) ; |
| 14587 | tests_delete1emptyfolders_unit( |
| 14588 | $syncT, |
| 14589 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14590 | [ ], |
| 14591 | q{tests_delete1emptyfolders: examine ok but History badly mocked so count messages fails} |
| 14592 | ) ; |
| 14593 | |
| 14594 | # History good but some messages EXISTS == messages() => no deletion |
| 14595 | $imapT->mock( 'History', sub { ( q{* 2 EXISTS} ) } ) ; |
| 14596 | $imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ; |
| 14597 | tests_delete1emptyfolders_unit( |
| 14598 | $syncT, |
| 14599 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14600 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14601 | q{tests_delete1emptyfolders: History EXAMINE ok, several messages} |
| 14602 | ) ; |
| 14603 | |
| 14604 | # 0 EXISTS but != messages() => no deletion |
| 14605 | $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ; |
| 14606 | $imapT->mock( 'messages', sub { [ qw{ UID_1 UID_2 } ] } ) ; |
| 14607 | tests_delete1emptyfolders_unit( |
| 14608 | $syncT, |
| 14609 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14610 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14611 | q{tests_delete1emptyfolders: 0 EXISTS but 2 by messages()} |
| 14612 | ) ; |
| 14613 | |
| 14614 | # 1 EXISTS but != 0 == messages() => no deletion |
| 14615 | $imapT->mock( 'History', sub { ( q{* 1 EXISTS} ) } ) ; |
| 14616 | $imapT->mock( 'messages', sub { [ ] } ) ; |
| 14617 | tests_delete1emptyfolders_unit( |
| 14618 | $syncT, |
| 14619 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14620 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14621 | q{tests_delete1emptyfolders: 1 EXISTS but 0 by messages()} |
| 14622 | ) ; |
| 14623 | |
| 14624 | # 0 EXISTS and 0 == messages() => deletion except INBOX |
| 14625 | $imapT->mock( 'History', sub { ( q{* 0 EXISTS} ) } ) ; |
| 14626 | $imapT->mock( 'messages', sub { [ ] } ) ; |
| 14627 | $imapT->set_true( qw{ delete close unsubscribe } ) ; |
| 14628 | $syncT->{dry_message} = q{ (not really since in a mocked test)} ; |
| 14629 | tests_delete1emptyfolders_unit( |
| 14630 | $syncT, |
| 14631 | [ qw{ INBOX DELME1 DELME2 } ], |
| 14632 | [ qw{ INBOX } ], |
| 14633 | q{tests_delete1emptyfolders: 0 EXISTS 0 by messages() delete folders, keep INBOX} |
| 14634 | ) ; |
| 14635 | |
| 14636 | note( 'Leaving tests_delete1emptyfolders()' ) ; |
| 14637 | return ; |
| 14638 | } |
| 14639 | |
| 14640 | sub tests_delete1emptyfolders_unit |
| 14641 | { |
| 14642 | note( 'Entering tests_delete1emptyfolders_unit()' ) ; |
| 14643 | |
| 14644 | my $syncT = shift ; |
| 14645 | my $folders1wanted_init_ref = shift ; |
| 14646 | my $folders1wanted_after_ref = shift ; |
| 14647 | my $comment = shift || q{delete1emptyfolders:} ; |
| 14648 | |
| 14649 | my @folders1wanted_init = @{ $folders1wanted_init_ref } ; |
| 14650 | my @folders1wanted_after = @{ $folders1wanted_after_ref } ; |
| 14651 | |
| 14652 | @{ $syncT->{h1_folders_wanted} } = @folders1wanted_init ; |
| 14653 | |
| 14654 | is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_init, qq{$comment, init check} ) ; |
| 14655 | delete1emptyfolders( $syncT ) ; |
| 14656 | is_deeply( $syncT->{h1_folders_wanted}, \@folders1wanted_after, qq{$comment, after check} ) ; |
| 14657 | |
| 14658 | note( 'Leaving tests_delete1emptyfolders_unit()' ) ; |
| 14659 | return ; |
| 14660 | } |
| 14661 | |
| 14662 | sub extract_header |
| 14663 | { |
| 14664 | my $string = shift ; |
| 14665 | |
| 14666 | my ( $header ) = split /\n\n/x, $string ; |
| 14667 | if ( ! $header ) { return( q{} ) ; } |
| 14668 | #myprint( "[$header]\n" ) ; |
| 14669 | return( $header ) ; |
| 14670 | } |
| 14671 | |
| 14672 | sub tests_extract_header |
| 14673 | { |
| 14674 | note( 'Entering tests_extract_header()' ) ; |
| 14675 | |
| 14676 | my $h = <<'EOM'; |
| 14677 | Message-Id: <20100428101817.A66CB162474E@plume.est.belle> |
| 14678 | Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) |
| 14679 | From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) |
| 14680 | EOM |
| 14681 | chomp $h ; |
| 14682 | ok( $h eq extract_header( |
| 14683 | <<'EOM' |
| 14684 | Message-Id: <20100428101817.A66CB162474E@plume.est.belle> |
| 14685 | Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) |
| 14686 | From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) |
| 14687 | |
| 14688 | body |
| 14689 | lalala |
| 14690 | EOM |
| 14691 | ), 'extract_header: 1') ; |
| 14692 | |
| 14693 | |
| 14694 | |
| 14695 | note( 'Leaving tests_extract_header()' ) ; |
| 14696 | return ; |
| 14697 | } |
| 14698 | |
| 14699 | sub decompose_header{ |
| 14700 | my $string = shift ; |
| 14701 | |
| 14702 | # a hash, for a keyword header KEY value are list of strings [VAL1, VAL1_other, etc] |
| 14703 | # Think of multiple "Received:" header lines. |
| 14704 | my $header = { } ; |
| 14705 | |
| 14706 | my ($key, $val ) ; |
| 14707 | my @line = split /\n|\r\n/x, $string ; |
| 14708 | foreach my $line ( @line ) { |
| 14709 | #myprint( "DDD $line\n" ) ; |
| 14710 | # End of header |
| 14711 | last if ( $line =~ m{^$}xo ) ; |
| 14712 | # Key: value |
| 14713 | if ( $line =~ m/(^[^:]+):\s(.*)/xo ) { |
| 14714 | $key = $1 ; |
| 14715 | $val = $2 ; |
| 14716 | $debugdev and myprint( "DDD KV [$key] [$val]\n" ) ; |
| 14717 | push @{ $header->{ $key } }, $val ; |
| 14718 | # blanc and value => value from previous line continues |
| 14719 | }elsif( $line =~ m/^(\s+)(.*)/xo ) { |
| 14720 | $val = $2 ; |
| 14721 | $debugdev and myprint( "DDD V [$val]\n" ) ; |
| 14722 | @{ $header->{ $key } }[ $LAST ] .= " $val" if $key ; |
| 14723 | # dirty line? |
| 14724 | }else{ |
| 14725 | next ; |
| 14726 | } |
| 14727 | } |
| 14728 | |
| 14729 | #myprint( Data::Dumper->Dump( [ $header ] ) ) ; |
| 14730 | |
| 14731 | return( $header ) ; |
| 14732 | } |
| 14733 | |
| 14734 | |
| 14735 | sub tests_decompose_header{ |
| 14736 | note( 'Entering tests_decompose_header()' ) ; |
| 14737 | |
| 14738 | |
| 14739 | my $header_dec ; |
| 14740 | |
| 14741 | $header_dec = decompose_header( |
| 14742 | <<'EOH' |
| 14743 | KEY_1: VAL_1 |
| 14744 | KEY_2: VAL_2 |
| 14745 | VAL_2_+ |
| 14746 | VAL_2_++ |
| 14747 | KEY_3: VAL_3 |
| 14748 | KEY_1: VAL_1_other |
| 14749 | KEY_4: VAL_4 |
| 14750 | VAL_4_+ |
| 14751 | KEY_5 BLANC: VAL_5 |
| 14752 | |
| 14753 | KEY_6_BAD_BODY: VAL_6 |
| 14754 | EOH |
| 14755 | ) ; |
| 14756 | |
| 14757 | ok( 'VAL_3' |
| 14758 | eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: VAL_3' ) ; |
| 14759 | |
| 14760 | ok( 'VAL_1' |
| 14761 | eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: VAL_1' ) ; |
| 14762 | |
| 14763 | ok( 'VAL_1_other' |
| 14764 | eq $header_dec->{ 'KEY_1' }[1], 'decompose_header: VAL_1_other' ) ; |
| 14765 | |
| 14766 | ok( 'VAL_2 VAL_2_+ VAL_2_++' |
| 14767 | eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: VAL_2 VAL_2_+ VAL_2_++' ) ; |
| 14768 | |
| 14769 | ok( 'VAL_4 VAL_4_+' |
| 14770 | eq $header_dec->{ 'KEY_4' }[0], 'decompose_header: VAL_4 VAL_4_+' ) ; |
| 14771 | |
| 14772 | ok( ' VAL_5' |
| 14773 | eq $header_dec->{ 'KEY_5 BLANC' }[0], 'decompose_header: KEY_5 BLANC' ) ; |
| 14774 | |
| 14775 | ok( not( defined $header_dec->{ 'KEY_6_BAD_BODY' }[0] ), 'decompose_header: KEY_6_BAD_BODY' ) ; |
| 14776 | |
| 14777 | |
| 14778 | $header_dec = decompose_header( |
| 14779 | <<'EOH' |
| 14780 | Message-Id: <20100428101817.A66CB162474E@plume.est.belle> |
| 14781 | Date: Wed, 28 Apr 2010 12:18:17 +0200 (CEST) |
| 14782 | From: gilles@louloutte.dyndns.org (Gilles LAMIRAL) |
| 14783 | EOH |
| 14784 | ) ; |
| 14785 | |
| 14786 | ok( '<20100428101817.A66CB162474E@plume.est.belle>' |
| 14787 | eq $header_dec->{ 'Message-Id' }[0], 'decompose_header: 1' ) ; |
| 14788 | |
| 14789 | $header_dec = decompose_header( |
| 14790 | <<'EOH' |
| 14791 | Return-Path: <gilles@louloutte.dyndns.org> |
| 14792 | Received: by plume.est.belle (Postfix, from userid 1000) |
| 14793 | id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST) |
| 14794 | Subject: test:eekahceishukohpe |
| 14795 | EOH |
| 14796 | ) ; |
| 14797 | ok( |
| 14798 | 'by plume.est.belle (Postfix, from userid 1000) id 120A71624742; Wed, 28 Apr 2010 01:46:40 +0200 (CEST)' |
| 14799 | eq $header_dec->{ 'Received' }[0], 'decompose_header: 2' ) ; |
| 14800 | |
| 14801 | $header_dec = decompose_header( |
| 14802 | <<'EOH' |
| 14803 | Received: from plume (localhost [127.0.0.1]) |
| 14804 | by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 |
| 14805 | for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET) |
| 14806 | Received: from plume [192.168.68.7] |
| 14807 | by plume with POP3 (fetchmail-6.3.6) |
| 14808 | for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET) |
| 14809 | EOH |
| 14810 | ) ; |
| 14811 | ok( |
| 14812 | 'from plume (localhost [127.0.0.1]) by plume.est.belle (Postfix) with ESMTP id C6EB73F6C9 for <gilles@localhost>; Mon, 26 Nov 2007 10:39:06 +0100 (CET)' |
| 14813 | eq $header_dec->{ 'Received' }[0], 'decompose_header: 3' ) ; |
| 14814 | ok( |
| 14815 | 'from plume [192.168.68.7] by plume with POP3 (fetchmail-6.3.6) for <gilles@localhost> (single-drop); Mon, 26 Nov 2007 10:39:06 +0100 (CET)' |
| 14816 | eq $header_dec->{ 'Received' }[1], 'decompose_header: 3' ) ; |
| 14817 | |
| 14818 | # Bad header beginning with a blank character |
| 14819 | $header_dec = decompose_header( |
| 14820 | <<'EOH' |
| 14821 | KEY_1: VAL_1 |
| 14822 | KEY_2: VAL_2 |
| 14823 | VAL_2_+ |
| 14824 | VAL_2_++ |
| 14825 | KEY_3: VAL_3 |
| 14826 | KEY_1: VAL_1_other |
| 14827 | EOH |
| 14828 | ) ; |
| 14829 | |
| 14830 | ok( 'VAL_3' |
| 14831 | eq $header_dec->{ 'KEY_3' }[0], 'decompose_header: Bad header VAL_3' ) ; |
| 14832 | |
| 14833 | ok( 'VAL_1_other' |
| 14834 | eq $header_dec->{ 'KEY_1' }[0], 'decompose_header: Bad header VAL_1_other' ) ; |
| 14835 | |
| 14836 | ok( 'VAL_2 VAL_2_+ VAL_2_++' |
| 14837 | eq $header_dec->{ 'KEY_2' }[0], 'decompose_header: Bad header VAL_2 VAL_2_+ VAL_2_++' ) ; |
| 14838 | |
| 14839 | note( 'Leaving tests_decompose_header()' ) ; |
| 14840 | return ; |
| 14841 | } |
| 14842 | |
| 14843 | sub tests_epoch |
| 14844 | { |
| 14845 | note( 'Entering tests_epoch()' ) ; |
| 14846 | |
| 14847 | ok( '1282658400' eq epoch( '24-Aug-2010 16:00:00 +0200' ), 'epoch 24-Aug-2010 16:00:00 +0200 -> 1282658400' ) ; |
| 14848 | ok( '1282658400' eq epoch( '24-Aug-2010 14:00:00 +0000' ), 'epoch 24-Aug-2010 14:00:00 +0000 -> 1282658400' ) ; |
| 14849 | ok( '1282658400' eq epoch( '24-Aug-2010 12:00:00 -0200' ), 'epoch 24-Aug-2010 12:00:00 -0200 -> 1282658400' ) ; |
| 14850 | ok( '1282658400' eq epoch( '24-Aug-2010 16:01:00 +0201' ), 'epoch 24-Aug-2010 16:01:00 +0201 -> 1282658400' ) ; |
| 14851 | ok( '1282658400' eq epoch( '24-Aug-2010 14:01:00 +0001' ), 'epoch 24-Aug-2010 14:01:00 +0001 -> 1282658400' ) ; |
| 14852 | |
| 14853 | ok( '1280671200' eq epoch( '1-Aug-2010 16:00:00 +0200' ), 'epoch 1-Aug-2010 16:00:00 +0200 -> 1280671200' ) ; |
| 14854 | ok( '1280671200' eq epoch( '1-Aug-2010 14:00:00 +0000' ), 'epoch 1-Aug-2010 14:00:00 +0000 -> 1280671200' ) ; |
| 14855 | ok( '1280671200' eq epoch( '1-Aug-2010 12:00:00 -0200' ), 'epoch 1-Aug-2010 12:00:00 -0200 -> 1280671200' ) ; |
| 14856 | ok( '1280671200' eq epoch( '1-Aug-2010 16:01:00 +0201' ), 'epoch 1-Aug-2010 16:01:00 +0201 -> 1280671200' ) ; |
| 14857 | ok( '1280671200' eq epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; |
| 14858 | |
| 14859 | is( '1280671200', epoch( '1-Aug-2010 14:01:00 +0001' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; |
| 14860 | is( '946684800', epoch( '00-Jan-0000 00:00:00 +0000' ), 'epoch 1-Aug-2010 14:01:00 +0001 -> 1280671200' ) ; |
| 14861 | |
| 14862 | note( 'Leaving tests_epoch()' ) ; |
| 14863 | return ; |
| 14864 | } |
| 14865 | |
| 14866 | sub epoch |
| 14867 | { |
| 14868 | # incoming format: |
| 14869 | # internal date 24-Aug-2010 16:00:00 +0200 |
| 14870 | |
| 14871 | # outgoing format: epoch |
| 14872 | |
| 14873 | |
| 14874 | my $d = shift ; |
| 14875 | return(q{}) if not defined $d; |
| 14876 | |
| 14877 | my ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) ; |
| 14878 | my $time ; |
| 14879 | |
| 14880 | if ( $d =~ m{(\d{1,2})-([A-Z][a-z]{2})-(\d{4})\s(\d{2}):(\d{2}):(\d{2})\s((?:\+|-))(\d{2})(\d{2})}xo ) { |
| 14881 | #myprint( "internal: [$1][$2][$3][$4][$5][$6][$7][$8][$9]\n" ) ; |
| 14882 | ( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m ) |
| 14883 | = ( $1, $2, $3, $4, $5, $6, $7, $8, $9 ) ; |
| 14884 | #myprint( "( $mday, $month, $year, $hour, $min, $sec, $sign, $zone_h, $zone_m )\n" ) ; |
| 14885 | |
| 14886 | $sign = +1 if ( '+' eq $sign ) ; |
| 14887 | $sign = $MINUS_ONE if ( '-' eq $sign ) ; |
| 14888 | |
| 14889 | if ( 0 == $mday ) { |
| 14890 | myprint( "buggy day in $d. Fixed to 01\n" ) ; |
| 14891 | $mday = '01' ; |
| 14892 | } |
| 14893 | $time = timegm( $sec, $min, $hour, $mday, $month_abrev{$month}, $year ) |
| 14894 | - $sign * ( 3600 * $zone_h + 60 * $zone_m ) ; |
| 14895 | |
| 14896 | #myprint( "$time ", scalar localtime($time), "\n"); |
| 14897 | } |
| 14898 | return( $time ) ; |
| 14899 | } |
| 14900 | |
| 14901 | sub tests_add_header |
| 14902 | { |
| 14903 | note( 'Entering tests_add_header()' ) ; |
| 14904 | |
| 14905 | ok( 'Message-Id: <mistake@imapsync>' eq add_header(), 'add_header no arg' ) ; |
| 14906 | ok( 'Message-Id: <123456789@imapsync>' eq add_header( '123456789' ), 'add_header 123456789' ) ; |
| 14907 | |
| 14908 | note( 'Leaving tests_add_header()' ) ; |
| 14909 | return ; |
| 14910 | } |
| 14911 | |
| 14912 | sub add_header |
| 14913 | { |
| 14914 | my $header_uid = shift || 'mistake' ; |
| 14915 | my $header_Message_Id = 'Message-Id: <' . $header_uid . '@imapsync>' ; |
| 14916 | return( $header_Message_Id ) ; |
| 14917 | } |
| 14918 | |
| 14919 | |
| 14920 | |
| 14921 | |
| 14922 | sub tests_max_line_length |
| 14923 | { |
| 14924 | note( 'Entering tests_max_line_length()' ) ; |
| 14925 | |
| 14926 | ok( 0 == max_line_length( q{} ), 'max_line_length: 0 == null string' ) ; |
| 14927 | ok( 1 == max_line_length( "\n" ), 'max_line_length: 1 == \n' ) ; |
| 14928 | ok( 1 == max_line_length( "\n\n" ), 'max_line_length: 1 == \n\n' ) ; |
| 14929 | ok( 1 == max_line_length( "\n" x 500 ), 'max_line_length: 1 == 500 \n' ) ; |
| 14930 | ok( 1 == max_line_length( 'a' ), 'max_line_length: 1 == a' ) ; |
| 14931 | ok( 2 == max_line_length( "a\na" ), 'max_line_length: 2 == a\na' ) ; |
| 14932 | ok( 2 == max_line_length( "a\na\n" ), 'max_line_length: 2 == a\na\n' ) ; |
| 14933 | ok( 3 == max_line_length( "a\nab\n" ), 'max_line_length: 3 == a\nab\n' ) ; |
| 14934 | ok( 3 == max_line_length( "a\nab\n" x 1_000 ), 'max_line_length: 3 == 1_000 a\nab\n' ) ; |
| 14935 | ok( 3 == max_line_length( "a\nab\nabc" ), 'max_line_length: 3 == a\nab\nabc' ) ; |
| 14936 | |
| 14937 | ok( 4 == max_line_length( "a\nab\nabc\n" ), 'max_line_length: 4 == a\nab\nabc\n' ) ; |
| 14938 | ok( 5 == max_line_length( "a\nabcd\nabc\n" ), 'max_line_length: 5 == a\nabcd\nabc\n' ) ; |
| 14939 | ok( 5 == max_line_length( "a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd" ), 'max_line_length: 5 == a\nabcd\nabc\n\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd\nabcd' ) ; |
| 14940 | |
| 14941 | note( 'Leaving tests_max_line_length()' ) ; |
| 14942 | return ; |
| 14943 | } |
| 14944 | |
| 14945 | sub max_line_length |
| 14946 | { |
| 14947 | my $string = shift ; |
| 14948 | my $max = 0 ; |
| 14949 | |
| 14950 | while ( $string =~ m/([^\n]*\n?)/msxg ) { |
| 14951 | $max = max( $max, length $1 ) ; |
| 14952 | } |
| 14953 | return( $max ) ; |
| 14954 | } |
| 14955 | |
| 14956 | |
| 14957 | sub tests_setlogfile |
| 14958 | { |
| 14959 | note( 'Entering tests_setlogfile()' ) ; |
| 14960 | |
| 14961 | my $mysync = {} ; |
| 14962 | $mysync->{logdir} = 'vallogdir' ; |
| 14963 | $mysync->{logfile} = 'vallogfile.txt' ; |
| 14964 | is( 'vallogdir/vallogfile.txt', setlogfile( $mysync ), |
| 14965 | 'setlogfile: logdir vallogdir, logfile vallogfile.txt, vallogdir/vallogfile.txt' ) ; |
| 14966 | |
| 14967 | SKIP: { |
| 14968 | skip( 'Too hard to have a well known timezone on Windows', 9 ) if ( 'MSWin32' eq $OSNAME ) ; |
| 14969 | |
| 14970 | local $ENV{TZ} = 'GMT' ; |
| 14971 | |
| 14972 | $mysync = { |
| 14973 | timestart => 2, |
| 14974 | } ; |
| 14975 | |
| 14976 | is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000__.txt", setlogfile( $mysync ), |
| 14977 | "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000__.txt" ) ; |
| 14978 | |
| 14979 | $mysync = { |
| 14980 | timestart => 2, |
| 14981 | user1 => 'user1', |
| 14982 | user2 => 'user2', |
| 14983 | abort => 1, |
| 14984 | } ; |
| 14985 | |
| 14986 | is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_abort.txt", setlogfile( $mysync ), |
| 14987 | "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_abort.txt" ) ; |
| 14988 | |
| 14989 | $mysync = { |
| 14990 | timestart => 2, |
| 14991 | user1 => 'user1', |
| 14992 | user2 => 'user2', |
| 14993 | remote => 'zzz', |
| 14994 | } ; |
| 14995 | |
| 14996 | is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote.txt", setlogfile( $mysync ), |
| 14997 | "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote.txt" ) ; |
| 14998 | |
| 14999 | $mysync = { |
| 15000 | timestart => 2, |
| 15001 | user1 => 'user1', |
| 15002 | user2 => 'user2', |
| 15003 | remote => 'zzz', |
| 15004 | abort => 1, |
| 15005 | } ; |
| 15006 | |
| 15007 | is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote_abort.txt", setlogfile( $mysync ), |
| 15008 | "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2_remote_abort.txt" ) ; |
| 15009 | |
| 15010 | |
| 15011 | $mysync = { |
| 15012 | timestart => 2, |
| 15013 | user1 => 'user1', |
| 15014 | user2 => 'user2', |
| 15015 | } ; |
| 15016 | |
| 15017 | is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt", setlogfile( $mysync ), |
| 15018 | "setlogfile: default is like $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt" ) ; |
| 15019 | |
| 15020 | $mysync->{logdir} = undef ; |
| 15021 | $mysync->{logfile} = undef ; |
| 15022 | is( "$DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt", setlogfile( $mysync ), |
| 15023 | "setlogfile: logdir undef, $DEFAULT_LOGDIR/1970_01_01_00_00_02_000_user1_user2.txt" ) ; |
| 15024 | |
| 15025 | $mysync->{logdir} = q{} ; |
| 15026 | $mysync->{logfile} = undef ; |
| 15027 | is( '1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), |
| 15028 | 'setlogfile: logdir empty, 1970_01_01_00_00_02_000_user1_user2.txt' ) ; |
| 15029 | |
| 15030 | $mysync->{logdir} = 'vallogdir' ; |
| 15031 | $mysync->{logfile} = undef ; |
| 15032 | is( 'vallogdir/1970_01_01_00_00_02_000_user1_user2.txt', setlogfile( $mysync ), |
| 15033 | 'setlogfile: logdir vallogdir, vallogdir/1970_01_01_00_00_02_000_user1_user2.txt' ) ; |
| 15034 | |
| 15035 | $mysync = { |
| 15036 | user1 => 'us/er1a*|?:"<>b', |
| 15037 | user2 => 'u/ser2a*|?:"<>b', |
| 15038 | } ; |
| 15039 | |
| 15040 | is( "$DEFAULT_LOGDIR/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt", setlogfile( $mysync ), |
| 15041 | "setlogfile: logdir undef, $DEFAULT_LOGDIR/1970_01_01_00_00_00_000_us_er1a_______b_u_ser2a_______b.txt" ) ; |
| 15042 | |
| 15043 | |
| 15044 | |
| 15045 | } ; |
| 15046 | |
| 15047 | note( 'Leaving tests_setlogfile()' ) ; |
| 15048 | return ; |
| 15049 | } |
| 15050 | |
| 15051 | sub setlogfile |
| 15052 | { |
| 15053 | my( $mysync ) = shift ; |
| 15054 | |
| 15055 | # When aborting another process the log file name finishes with "_abort.txt" |
| 15056 | my $abort_suffix = ( $mysync->{abort} ) ? '_abort' : q{} ; |
| 15057 | # When acting as a proxy the log file name finishes with "_remote.txt" |
| 15058 | # proxy mode is not done yet |
| 15059 | my $remote_suffix = ( $mysync->{remote} ) ? '_remote' : q{} ; |
| 15060 | |
| 15061 | my $suffix = ( |
| 15062 | filter_forbidden_characters( slash_to_underscore( $mysync->{user1} ) ) || q{} ) |
| 15063 | . '_' |
| 15064 | . ( filter_forbidden_characters( slash_to_underscore( $mysync->{user2} ) ) || q{} ) |
| 15065 | . $remote_suffix . $abort_suffix ; |
| 15066 | |
| 15067 | $mysync->{logdir} = defined $mysync->{logdir} ? $mysync->{logdir} : $DEFAULT_LOGDIR ; |
| 15068 | |
| 15069 | $mysync->{logfile} = defined $mysync->{logfile} |
| 15070 | ? "$mysync->{logdir}/$mysync->{logfile}" |
| 15071 | : logfile( $mysync->{timestart}, $suffix, $mysync->{logdir} ) ; |
| 15072 | |
| 15073 | return( $mysync->{logfile} ) ; |
| 15074 | } |
| 15075 | |
| 15076 | sub tests_logfile |
| 15077 | { |
| 15078 | note( 'Entering tests_logfile()' ) ; |
| 15079 | |
| 15080 | SKIP: { |
| 15081 | # Too hard to have a well known timezone on Windows |
| 15082 | skip( 'Too hard to have a well known timezone on Windows', 10 ) if ( 'MSWin32' eq $OSNAME ) ; |
| 15083 | |
| 15084 | local $ENV{TZ} = 'GMT' ; |
| 15085 | { POSIX::tzset unless ('MSWin32' eq $OSNAME) ; |
| 15086 | is( '1970_01_01_00_00_00_000.txt', logfile( ), 'logfile: no args => 1970_01_01_00_00_00.txt' ) ; |
| 15087 | is( '1970_01_01_00_00_00_000.txt', logfile( 0 ), 'logfile: 0 => 1970_01_01_00_00_00.txt' ) ; |
| 15088 | is( '1970_01_01_00_01_01_000.txt', logfile( 61 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ; |
| 15089 | is( '1970_01_01_00_01_01_234.txt', logfile( 61.234 ), 'logfile: 0 => 1970_01_01_00_01_01.txt' ) ; |
| 15090 | is( '2010_08_24_14_00_00_000.txt', logfile( 1_282_658_400 ), 'logfile: 1_282_658_400 => 2010_08_24_14_00_00.txt' ) ; |
| 15091 | is( '2010_08_24_14_01_01_000.txt', logfile( 1_282_658_461 ), 'logfile: 1_282_658_461 => 2010_08_24_14_01_01.txt' ) ; |
| 15092 | is( '2010_08_24_14_01_01_000_poupinette.txt', logfile( 1_282_658_461, 'poupinette' ), 'logfile: 1_282_658_461 poupinette => 2010_08_24_14_01_01_poupinette.txt' ) ; |
| 15093 | is( '2010_08_24_14_01_01_000_removeblanks.txt', logfile( 1_282_658_461, ' remove blanks ' ), 'logfile: 1_282_658_461 remove blanks => 2010_08_24_14_01_01_000_removeblanks' ) ; |
| 15094 | |
| 15095 | is( '2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup' ), |
| 15096 | 'logfile: 1_282_658_461.2347 poup => 2010_08_24_14_01_01_234_poup.txt' ) ; |
| 15097 | |
| 15098 | is( 'dirdir/2010_08_24_14_01_01_234_poup.txt', logfile( 1_282_658_461.2347, 'poup', 'dirdir' ), |
| 15099 | 'logfile: 1_282_658_461.2347 poup dirdir => dirdir/2010_08_24_14_01_01_234_poup.txt' ) ; |
| 15100 | |
| 15101 | |
| 15102 | |
| 15103 | } |
| 15104 | POSIX::tzset unless ('MSWin32' eq $OSNAME) ; |
| 15105 | } ; |
| 15106 | |
| 15107 | note( 'Leaving tests_logfile()' ) ; |
| 15108 | return ; |
| 15109 | } |
| 15110 | |
| 15111 | |
| 15112 | sub logfile |
| 15113 | { |
| 15114 | my ( $time, $suffix, $dir ) = @_ ; |
| 15115 | |
| 15116 | $time ||= 0 ; |
| 15117 | $suffix ||= q{} ; |
| 15118 | $suffix =~ tr/ //ds ; |
| 15119 | my $sep_suffix = ( $suffix ) ? '_' : q{} ; |
| 15120 | $dir ||= q{} ; |
| 15121 | my $sep_dir = ( $dir ) ? '/' : q{} ; |
| 15122 | |
| 15123 | my $date_str = POSIX::strftime( '%Y_%m_%d_%H_%M_%S', localtime $time ) ; |
| 15124 | # Because of ab tests or web accesses, more than one sync withing one second is possible |
| 15125 | # so we add also milliseconds |
| 15126 | $date_str .= sprintf "_%03d", ($time - int( $time ) ) * 1000 ; # without rounding |
| 15127 | my $logfile = "${dir}${sep_dir}${date_str}${sep_suffix}${suffix}.txt" ; |
| 15128 | return( $logfile ) ; |
| 15129 | } |
| 15130 | |
| 15131 | |
| 15132 | |
| 15133 | sub tests_slash_to_underscore |
| 15134 | { |
| 15135 | note( 'Entering tests_slash_to_underscore()' ) ; |
| 15136 | |
| 15137 | is( undef, slash_to_underscore( ), 'slash_to_underscore: no parameters => undef' ) ; |
| 15138 | is( '_', slash_to_underscore( '/' ), 'slash_to_underscore: / => _' ) ; |
| 15139 | is( '_abc_def_', slash_to_underscore( '/abc/def/' ), 'slash_to_underscore: /abc/def/ => _abc_def_' ) ; |
| 15140 | note( 'Leaving tests_slash_to_underscore()' ) ; |
| 15141 | return ; |
| 15142 | } |
| 15143 | |
| 15144 | sub slash_to_underscore |
| 15145 | { |
| 15146 | my $string = shift ; |
| 15147 | |
| 15148 | if ( ! defined $string ) { return ; } |
| 15149 | |
| 15150 | $string =~ tr{/}{_} ; |
| 15151 | |
| 15152 | return( $string ) ; |
| 15153 | } |
| 15154 | |
| 15155 | |
| 15156 | |
| 15157 | |
| 15158 | sub tests_million_folders_baby_2 |
| 15159 | { |
| 15160 | note( 'Entering tests_million_folders_baby_2()' ) ; |
| 15161 | |
| 15162 | my %long ; |
| 15163 | @long{ 1 .. 900_000 } = (1) x 900_000 ; |
| 15164 | #myprint( %long, "\n" ) ; |
| 15165 | my $pasglop = 0 ; |
| 15166 | foreach my $elem ( 1 .. 900_000 ) { |
| 15167 | #$debug and myprint( "$elem " ) ; |
| 15168 | if ( not exists $long{ $elem } ) { |
| 15169 | $pasglop++ ; |
| 15170 | } |
| 15171 | } |
| 15172 | ok( 0 == $pasglop, 'tests_million_folders_baby_2: search among 900_000' ) ; |
| 15173 | # myprint( "$pasglop\n" ) ; |
| 15174 | |
| 15175 | note( 'Leaving tests_million_folders_baby_2()' ) ; |
| 15176 | return ; |
| 15177 | } |
| 15178 | |
| 15179 | |
| 15180 | |
| 15181 | sub tests_always_fail |
| 15182 | { |
| 15183 | note( 'Entering tests_always_fail()' ) ; |
| 15184 | |
| 15185 | is( 0, 1, 'always_fail: 0 is 1' ) ; |
| 15186 | |
| 15187 | note( 'Leaving tests_always_fail()' ) ; |
| 15188 | return ; |
| 15189 | } |
| 15190 | |
| 15191 | |
| 15192 | sub tests_logfileprepa |
| 15193 | { |
| 15194 | note( 'Entering tests_logfileprepa()' ) ; |
| 15195 | |
| 15196 | is( undef, logfileprepa( ), 'logfileprepa: no args => undef' ) ; |
| 15197 | my $logfile = 'W/tmp/tests/tests_logfileprepa.txt' ; |
| 15198 | is( 1, logfileprepa( $logfile ), 'logfileprepa: W/tmp/tests/tests_logfileprepa.txt => 1' ) ; |
| 15199 | |
| 15200 | note( 'Leaving tests_logfileprepa()' ) ; |
| 15201 | return ; |
| 15202 | } |
| 15203 | |
| 15204 | sub logfileprepa |
| 15205 | { |
| 15206 | my $logfile = shift ; |
| 15207 | |
| 15208 | if ( ! defined( $logfile ) ) |
| 15209 | { |
| 15210 | return ; |
| 15211 | }else |
| 15212 | { |
| 15213 | #myprint( "[$logfile]\n" ) ; |
| 15214 | my $dirname = dirname( $logfile ) ; |
| 15215 | do_valid_directory( $dirname ) || return( 0 ) ; |
| 15216 | return( 1 ) ; |
| 15217 | } |
| 15218 | } |
| 15219 | |
| 15220 | |
| 15221 | sub tests_teelaunch |
| 15222 | { |
| 15223 | note( 'Entering tests_teelaunch()' ) ; |
| 15224 | |
| 15225 | is( undef, teelaunch( ), 'teelaunch: no args => undef' ) ; |
| 15226 | my $mysync = {} ; |
| 15227 | is( undef, teelaunch( $mysync ), 'teelaunch: arg empty {} => undef' ) ; |
| 15228 | $mysync->{logfile} = q{} ; |
| 15229 | is( undef, teelaunch( $mysync ), 'teelaunch: logfile empty string => undef' ) ; |
| 15230 | $mysync->{logfile} = 'W/tmp/tests/tests_teelaunch.txt' ; |
| 15231 | isa_ok( my $tee = teelaunch( $mysync ), 'IO::Tee' , 'teelaunch: logfile W/tmp/tests/tests_teelaunch.txt' ) ; |
| 15232 | is( 1, print( $tee "Hi!\n" ), 'teelaunch: write Hi!') ; |
| 15233 | is( "Hi!\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\n' ) ; |
| 15234 | is( 1, print( $tee "Hoo\n" ), 'teelaunch: write Hoo') ; |
| 15235 | is( "Hi!\nHoo\n", file_to_string( 'W/tmp/tests/tests_teelaunch.txt' ), 'teelaunch: reading W/tmp/tests/tests_teelaunch.txt is Hi!\nHoo\n' ) ; |
| 15236 | |
| 15237 | note( 'Leaving tests_teelaunch()' ) ; |
| 15238 | return ; |
| 15239 | } |
| 15240 | |
| 15241 | sub teelaunch |
| 15242 | { |
| 15243 | my $mysync = shift ; |
| 15244 | |
| 15245 | if ( ! defined( $mysync ) ) |
| 15246 | { |
| 15247 | return ; |
| 15248 | } |
| 15249 | |
| 15250 | my $logfile = $mysync->{logfile} ; |
| 15251 | |
| 15252 | if ( ! $logfile ) |
| 15253 | { |
| 15254 | return ; |
| 15255 | } |
| 15256 | |
| 15257 | logfileprepa( $logfile ) || croak "Error no valid directory to write log file $logfile : $OS_ERROR" ; |
| 15258 | |
| 15259 | # This is a log file opened during the whole sync |
| 15260 | ## no critic (InputOutput::RequireBriefOpen) |
| 15261 | open my $logfile_handle, '>', $logfile |
| 15262 | or croak( "Can not open $logfile for write: $OS_ERROR" ) ; |
| 15263 | binmode $logfile_handle, ":encoding(UTF-8)" ; |
| 15264 | my $tee = IO::Tee->new( $logfile_handle, \*STDOUT ) ; |
| 15265 | $tee->autoflush( 1 ) ; |
| 15266 | $mysync->{logfile_handle} = $logfile_handle ; |
| 15267 | $mysync->{tee} = $tee ; |
| 15268 | return $tee ; |
| 15269 | } |
| 15270 | |
| 15271 | sub getpwuid_any_os |
| 15272 | { |
| 15273 | my $uid = shift ; |
| 15274 | |
| 15275 | return( scalar getlogin ) if ( 'MSWin32' eq $OSNAME ) ; # Windows system |
| 15276 | return( scalar getpwuid $uid ) ; # Unix system |
| 15277 | |
| 15278 | |
| 15279 | } |
| 15280 | |
| 15281 | sub simulong |
| 15282 | { |
| 15283 | my $max_seconds = shift ; |
| 15284 | my $division = 5 ; |
| 15285 | my $last_count = $division * $max_seconds ; |
| 15286 | foreach my $i ( 1 .. ( $last_count ) ) { |
| 15287 | myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" ) ; |
| 15288 | #myprint( "Are you still here ETA: " . ($last_count - $i) . "/$last_count msgs left\n" . ( "Ah" x 40 . "\n") x 4000 ) ; |
| 15289 | sleep( 1 / $division ) ; |
| 15290 | } |
| 15291 | |
| 15292 | return ; |
| 15293 | } |
| 15294 | |
| 15295 | |
| 15296 | |
| 15297 | sub printenv |
| 15298 | { |
| 15299 | myprint( "Environment variables listing:\n", |
| 15300 | ( map { "$_ => $ENV{$_}\n" } sort keys %ENV), |
| 15301 | "Environment variables listing end\n" ) ; |
| 15302 | return ; |
| 15303 | } |
| 15304 | |
| 15305 | sub testsexit |
| 15306 | { |
| 15307 | my $mysync = shift ; |
| 15308 | if ( ! ( $mysync->{ tests } or $mysync->{ testsdebug } or $mysync->{ testsunit } ) ) { |
| 15309 | return ; |
| 15310 | } |
| 15311 | my $test_builder = Test::More->builder ; |
| 15312 | tests( $mysync ) ; |
| 15313 | testsdebug( $mysync ) ; |
| 15314 | testunitsession( $mysync ) ; |
| 15315 | |
| 15316 | my @summary = $test_builder->summary() ; |
| 15317 | my @details = $test_builder->details() ; |
| 15318 | my $nb_tests_run = scalar( @summary ) ; |
| 15319 | my $nb_tests_expected = $test_builder->expected_tests() ; |
| 15320 | my $nb_tests_failed = count_0s( @summary ) ; |
| 15321 | my $tests_failed = report_failures( @details ) ; |
| 15322 | if ( $nb_tests_failed or ( $nb_tests_run != $nb_tests_expected ) ) { |
| 15323 | #$test_builder->reset( ) ; |
| 15324 | myprint( "Summary of tests: failed $nb_tests_failed tests, run $nb_tests_run tests, expected to run $nb_tests_expected tests.\n", |
| 15325 | "List of failed tests:\n", $tests_failed ) ; |
| 15326 | exit $EXIT_TESTS_FAILED ; |
| 15327 | } |
| 15328 | |
| 15329 | cleanup_mess_from_tests( ) ; |
| 15330 | # Cover is larger with --tests --testslive |
| 15331 | if ( ! $mysync->{ testslive } ) |
| 15332 | { |
| 15333 | exit ; |
| 15334 | } |
| 15335 | return ; |
| 15336 | } |
| 15337 | |
| 15338 | sub cleanup_mess_from_tests |
| 15339 | { |
| 15340 | undef @pipemess ; |
| 15341 | return ; |
| 15342 | } |
| 15343 | |
| 15344 | sub after_get_options |
| 15345 | { |
| 15346 | my $mysync = shift ; |
| 15347 | my $numopt = shift ; |
| 15348 | |
| 15349 | |
| 15350 | # exit with --help option or no option at all |
| 15351 | $mysync->{ debug } and myprint( "numopt:$numopt\n" ) ; |
| 15352 | |
| 15353 | if ( $help or not $numopt ) { |
| 15354 | myprint( usage( $mysync ) ) ; |
| 15355 | exit ; |
| 15356 | } |
| 15357 | |
| 15358 | return ; |
| 15359 | } |
| 15360 | |
| 15361 | sub tests_remove_edging_blanks |
| 15362 | { |
| 15363 | note( 'Entering tests_remove_edging_blanks()' ) ; |
| 15364 | |
| 15365 | is( undef, remove_edging_blanks( ), 'remove_edging_blanks: no args => undef' ) ; |
| 15366 | is( 'abcd', remove_edging_blanks( 'abcd' ), 'remove_edging_blanks: abcd => abcd' ) ; |
| 15367 | is( 'ab cd', remove_edging_blanks( ' ab cd ' ), 'remove_edging_blanks: " ab cd " => "ab cd"' ) ; |
| 15368 | |
| 15369 | note( 'Leaving tests_remove_edging_blanks()' ) ; |
| 15370 | return ; |
| 15371 | } |
| 15372 | |
| 15373 | |
| 15374 | |
| 15375 | sub remove_edging_blanks |
| 15376 | { |
| 15377 | my $string = shift ; |
| 15378 | if ( ! defined $string ) |
| 15379 | { |
| 15380 | return ; |
| 15381 | } |
| 15382 | $string =~ s,^ +| +$,,g ; |
| 15383 | return $string ; |
| 15384 | } |
| 15385 | |
| 15386 | |
| 15387 | sub tests_sanitize |
| 15388 | { |
| 15389 | note( 'Entering tests_remove_edging_blanks()' ) ; |
| 15390 | |
| 15391 | is( undef, sanitize( ), 'sanitize: no args => undef' ) ; |
| 15392 | my $mysync = {} ; |
| 15393 | |
| 15394 | $mysync->{ host1 } = ' example.com ' ; |
| 15395 | $mysync->{ user1 } = ' to to ' ; |
| 15396 | $mysync->{ password1 } = ' sex is good! ' ; |
| 15397 | is( undef, sanitize( $mysync ), 'sanitize: => undef' ) ; |
| 15398 | is( 'example.com', $mysync->{ host1 }, 'sanitize: host1 " example.com " => "example.com"' ) ; |
| 15399 | is( 'to to', $mysync->{ user1 }, 'sanitize: user1 " to to " => "to to"' ) ; |
| 15400 | is( 'sex is good!', $mysync->{ password1 }, 'sanitize: password1 " sex is good! " => "sex is good!"' ) ; |
| 15401 | note( 'Leaving tests_remove_edging_blanks()' ) ; |
| 15402 | return ; |
| 15403 | } |
| 15404 | |
| 15405 | |
| 15406 | sub sanitize |
| 15407 | { |
| 15408 | my $mysync = shift ; |
| 15409 | if ( ! defined $mysync ) |
| 15410 | { |
| 15411 | return ; |
| 15412 | } |
| 15413 | |
| 15414 | foreach my $parameter ( qw( host1 host2 user1 user2 password1 password2 ) ) |
| 15415 | { |
| 15416 | $mysync->{ $parameter } = remove_edging_blanks( $mysync->{ $parameter } ) ; |
| 15417 | } |
| 15418 | return ; |
| 15419 | } |
| 15420 | |
| 15421 | sub easyany |
| 15422 | { |
| 15423 | my $mysync = shift ; |
| 15424 | |
| 15425 | # Gmail |
| 15426 | if ( $mysync->{gmail1} and $mysync->{gmail2} ) { |
| 15427 | $mysync->{ debug } and myprint( "gmail1 gmail2\n") ; |
| 15428 | gmail12( $mysync ) ; |
| 15429 | return ; |
| 15430 | } |
| 15431 | if ( $mysync->{gmail1} ) { |
| 15432 | $mysync->{ debug } and myprint( "gmail1\n" ) ; |
| 15433 | gmail1( $mysync ) ; |
| 15434 | } |
| 15435 | if ( $mysync->{gmail2} ) { |
| 15436 | $mysync->{ debug } and myprint( "gmail2\n" ) ; |
| 15437 | gmail2( $mysync ) ; |
| 15438 | } |
| 15439 | # Office 365 |
| 15440 | if ( $mysync->{office1} ) { |
| 15441 | office1( $mysync ) ; |
| 15442 | } |
| 15443 | |
| 15444 | if ( $mysync->{office2} ) { |
| 15445 | office2( $mysync ) ; |
| 15446 | } |
| 15447 | |
| 15448 | # Exchange |
| 15449 | if ( $mysync->{exchange1} ) { |
| 15450 | exchange1( $mysync ) ; |
| 15451 | } |
| 15452 | |
| 15453 | if ( $mysync->{exchange2} ) { |
| 15454 | exchange2( $mysync ) ; |
| 15455 | } |
| 15456 | |
| 15457 | |
| 15458 | # Domino |
| 15459 | if ( $mysync->{domino1} ) { |
| 15460 | domino1( $mysync ) ; |
| 15461 | } |
| 15462 | |
| 15463 | if ( $mysync->{domino2} ) { |
| 15464 | domino2( $mysync ) ; |
| 15465 | } |
| 15466 | |
| 15467 | return ; |
| 15468 | } |
| 15469 | |
| 15470 | # From and for https://imapsync.lamiral.info/FAQ.d/FAQ.Gmail.txt |
| 15471 | sub gmail12 |
| 15472 | { |
| 15473 | my $mysync = shift ; |
| 15474 | # Gmail at host1 and host2 |
| 15475 | $mysync->{host1} ||= 'imap.gmail.com' ; |
| 15476 | $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; |
| 15477 | $mysync->{host2} ||= 'imap.gmail.com' ; |
| 15478 | $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; |
| 15479 | $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 when computed from Gmail documentation |
| 15480 | $mysync->{maxbytesafter} ||= 1_000_000_000 ; |
| 15481 | $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; |
| 15482 | $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; |
| 15483 | $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 0 ; |
| 15484 | $mysync->{ synclabels } = ( defined $mysync->{ synclabels } ) ? $mysync->{ synclabels } : 1 ; |
| 15485 | $mysync->{ resynclabels } = ( defined $mysync->{ resynclabels } ) ? $mysync->{ resynclabels } : 1 ; |
| 15486 | push @exclude, '\[Gmail\]$' ; |
| 15487 | push @folderlast, '[Gmail]/All Mail' ; |
| 15488 | return ; |
| 15489 | } |
| 15490 | |
| 15491 | |
| 15492 | sub gmail1 |
| 15493 | { |
| 15494 | my $mysync = shift ; |
| 15495 | # Gmail at host2 |
| 15496 | $mysync->{host1} ||= 'imap.gmail.com' ; |
| 15497 | $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; |
| 15498 | $mysync->{maxbytespersecond} ||= 40_000 ; # should be 20_000 computed from by Gmail documentation |
| 15499 | $mysync->{maxbytesafter} ||= 2_500_000_000 ; |
| 15500 | $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; |
| 15501 | $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; |
| 15502 | $skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ; |
| 15503 | |
| 15504 | push @useheader, 'X-Gmail-Received', 'Message-Id' ; |
| 15505 | push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ; |
| 15506 | push @folderlast, '[Gmail]/All Mail' ; |
| 15507 | return ; |
| 15508 | } |
| 15509 | |
| 15510 | sub gmail2 |
| 15511 | { |
| 15512 | my $mysync = shift ; |
| 15513 | # Gmail at host2 |
| 15514 | $mysync->{host2} ||= 'imap.gmail.com' ; |
| 15515 | $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; |
| 15516 | $mysync->{maxbytespersecond} ||= 20_000 ; # should be 10_000 computed from by Gmail documentation |
| 15517 | $mysync->{maxbytesafter} ||= 1_000_000_000 ; # In fact it is documented as half: 500_000_000 |
| 15518 | |
| 15519 | $mysync->{automap} = ( defined $mysync->{automap} ) ? $mysync->{automap} : 1 ; |
| 15520 | #$skipcrossduplicates = ( defined $skipcrossduplicates ) ? $skipcrossduplicates : 1 ; |
| 15521 | $mysync->{ expunge1 } = ( defined $mysync->{ expunge1 } ) ? $mysync->{ expunge1 } : 1 ; |
| 15522 | $mysync->{addheader} = ( defined $mysync->{addheader} ) ? $mysync->{addheader} : 1 ; |
| 15523 | $mysync->{maxsleep} = ( defined $mysync->{maxsleep} ) ? $mysync->{maxsleep} : $MAX_SLEEP ; ; |
| 15524 | |
| 15525 | $mysync->{maxsize} = ( defined $mysync->{maxsize} ) ? $mysync->{maxsize} : $GMAIL_MAXSIZE ; |
| 15526 | |
| 15527 | if ( ! $mysync->{noexclude} ) { |
| 15528 | push @exclude, '\[Gmail\]$' ; |
| 15529 | } |
| 15530 | push @useheader, 'Message-Id' ; |
| 15531 | push @{ $mysync->{ regextrans2 } }, 's,\[Gmail\].,,' ; |
| 15532 | |
| 15533 | # push @{ $mysync->{ regextrans2 } }, 's/[ ]+/_/g' ; # is now replaced |
| 15534 | # by the two more specific following regexes, |
| 15535 | # they remove just the beginning and trailing blanks, not all. |
| 15536 | push @{ $mysync->{ regextrans2 } }, 's,^ +| +$,,g' ; |
| 15537 | push @{ $mysync->{ regextrans2 } }, 's,/ +| +/,/,g' ; |
| 15538 | # |
| 15539 | push @{ $mysync->{ regextrans2 } }, q{s/['\\^"]/_/g} ; # Verified this |
| 15540 | push @folderlast, '[Gmail]/All Mail' ; |
| 15541 | return ; |
| 15542 | } |
| 15543 | |
| 15544 | |
| 15545 | # From https://imapsync.lamiral.info/FAQ.d/FAQ.Exchange.txt |
| 15546 | sub office1 |
| 15547 | { |
| 15548 | # Office 365 at host1 |
| 15549 | my $mysync = shift ; |
| 15550 | |
| 15551 | output( $mysync, q{Option --office1 is like: --host1 outlook.office365.com --ssl1 --exclude "^Files$"} . "\n" ) ; |
| 15552 | output( $mysync, "Option --office1 (cont) : unless overrided with --host1 otherhost --nossl1 --noexclude\n" ) ; |
| 15553 | $mysync->{host1} ||= 'outlook.office365.com' ; |
| 15554 | $mysync->{ssl1} = ( defined $mysync->{ssl1} ) ? $mysync->{ssl1} : 1 ; |
| 15555 | if ( ! $mysync->{noexclude} ) { |
| 15556 | push @exclude, '^Files$' ; |
| 15557 | } |
| 15558 | return ; |
| 15559 | } |
| 15560 | |
| 15561 | |
| 15562 | sub office2 |
| 15563 | { |
| 15564 | # Office 365 at host2 |
| 15565 | my $mysync = shift ; |
| 15566 | output( $mysync, qq{Option --office2 is like: --host2 outlook.office365.com --ssl2 --maxsize 45_000_000 --maxmessagespersecond 4\n} ) ; |
| 15567 | output( $mysync, qq{Option --office2 (cont) : --disarmreadreceipts --regexmess "wrap 10500" --f1f2 "Files=Files_renamed_by_imapsync"\n} ) ; |
| 15568 | output( $mysync, qq{Option --office2 (cont) : unless overrided with --host2 otherhost --nossl2 ... --nodisarmreadreceipts --noregexmess\n} ) ; |
| 15569 | output( $mysync, qq{Option --office2 (cont) : and --nof1f2 to avoid Files folder renamed to Files_renamed_by_imapsync\n} ) ; |
| 15570 | $mysync->{host2} ||= 'outlook.office365.com' ; |
| 15571 | $mysync->{ssl2} = ( defined $mysync->{ssl2} ) ? $mysync->{ssl2} : 1 ; |
| 15572 | $mysync->{ maxsize } ||= 45_000_000 ; |
| 15573 | $mysync->{maxmessagespersecond} ||= 4 ; |
| 15574 | #push @regexflag, 's/\\\\Flagged//g' ; # No problem without! tested 2018_09_10 |
| 15575 | $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; |
| 15576 | # I dislike double negation but here is one |
| 15577 | if ( ! $mysync->{noregexmess} ) |
| 15578 | { |
| 15579 | push @regexmess, 's,(.{10239}),$1\r\n,g' ; |
| 15580 | } |
| 15581 | # and another... |
| 15582 | if ( ! $mysync->{nof1f2} ) |
| 15583 | { |
| 15584 | push @{ $mysync->{f1f2} }, 'Files=Files_renamed_by_imapsync' ; |
| 15585 | } |
| 15586 | return ; |
| 15587 | } |
| 15588 | |
| 15589 | sub exchange1 |
| 15590 | { |
| 15591 | # Exchange 2010/2013 at host1 |
| 15592 | my $mysync = shift ; |
| 15593 | output( $mysync, "Option --exchange1 does nothing (except printing this line...)\n" ) ; |
| 15594 | # Well nothing to do so far |
| 15595 | return ; |
| 15596 | } |
| 15597 | |
| 15598 | sub exchange2 |
| 15599 | { |
| 15600 | # Exchange 2010/2013 at host2 |
| 15601 | my $mysync = shift ; |
| 15602 | output( $mysync, "Option --exchange2 is like: --maxsize 10_000_000 --maxmessagespersecond 4 --disarmreadreceipts\n" ) ; |
| 15603 | output( $mysync, "Option --exchange2 (cont) : --regexflag del Flagged --regexmess wrap 10500\n" ) ; |
| 15604 | output( $mysync, "Option --exchange2 (cont) : unless overrided with --maxsize xxx --nodisarmreadreceipts --noregexflag --noregexmess\n" ) ; |
| 15605 | $mysync->{ maxsize } ||= 10_000_000 ; |
| 15606 | $mysync->{maxmessagespersecond} ||= 4 ; |
| 15607 | $disarmreadreceipts = ( defined $disarmreadreceipts ) ? $disarmreadreceipts : 1 ; |
| 15608 | # I dislike double negation but here are two |
| 15609 | if ( ! $mysync->{noregexflag} ) { |
| 15610 | push @regexflag, 's/\\\\Flagged//g' ; |
| 15611 | } |
| 15612 | if ( ! $mysync->{noregexmess} ) { |
| 15613 | push @regexmess, 's,(.{10239}),$1\r\n,g' ; |
| 15614 | } |
| 15615 | return ; |
| 15616 | } |
| 15617 | |
| 15618 | sub domino1 |
| 15619 | { |
| 15620 | # Domino at host1 |
| 15621 | my $mysync = shift ; |
| 15622 | |
| 15623 | $mysync->{ sep1 } = q{\\} ; |
| 15624 | $prefix1 = q{} ; |
| 15625 | $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ; |
| 15626 | return ; |
| 15627 | } |
| 15628 | |
| 15629 | sub domino2 |
| 15630 | { |
| 15631 | # Domino at host1 |
| 15632 | my $mysync = shift ; |
| 15633 | |
| 15634 | $mysync->{ sep2 } = q{\\} ; |
| 15635 | $prefix2 = q{} ; |
| 15636 | $messageidnodomain = ( defined $messageidnodomain ) ? $messageidnodomain : 1 ; |
| 15637 | push @{ $mysync->{ regextrans2 } }, 's,^Inbox\\\\(.*),$1,i' ; |
| 15638 | return ; |
| 15639 | } |
| 15640 | |
| 15641 | |
| 15642 | sub tests_resolv |
| 15643 | { |
| 15644 | note( 'Entering tests_resolv()' ) ; |
| 15645 | |
| 15646 | # is( , resolv( ), 'resolv: => ' ) ; |
| 15647 | is( undef, resolv( ), 'resolv: no args => undef' ) ; |
| 15648 | is( undef, resolv( q{} ), 'resolv: empty string => undef' ) ; |
| 15649 | is( undef, resolv( 'hostnotexist' ), 'resolv: hostnotexist => undef' ) ; |
| 15650 | is( '127.0.0.1', resolv( '127.0.0.1' ), 'resolv: 127.0.0.1 => 127.0.0.1' ) ; |
| 15651 | is( '127.0.0.1', resolv( 'localhost' ), 'resolv: localhost => 127.0.0.1' ) ; |
| 15652 | is( '5.135.158.182', resolv( 'imapsync.lamiral.info' ), 'resolv: imapsync.lamiral.info => 5.135.158.182' ) ; |
| 15653 | |
| 15654 | # ip6-localhost ( in /etc/hosts ) |
| 15655 | is( '::1', resolv( 'ip6-localhost' ), 'resolv: ip6-localhost => ::1' ) ; |
| 15656 | is( '::1', resolv( '::1' ), 'resolv: ::1 => ::1' ) ; |
| 15657 | # ks2 |
| 15658 | is( '2001:41d0:8:d8b6::1', resolv( '2001:41d0:8:d8b6::1' ), 'resolv: 2001:41d0:8:d8b6::1 => 2001:41d0:8:d8b6::1' ) ; |
| 15659 | is( '2001:41d0:8:d8b6::1', resolv( 'ks2ipv6.lamiral.info' ), 'resolv: ks2ipv6.lamiral.info => 2001:41d0:8:d8b6::1' ) ; |
| 15660 | # ks3 |
| 15661 | is( '2001:41d0:8:bebd::1', resolv( '2001:41d0:8:bebd::1' ), 'resolv: 2001:41d0:8:bebd::1 => 2001:41d0:8:bebd::1' ) ; |
| 15662 | is( '2001:41d0:8:bebd::1', resolv( 'ks3ipv6.lamiral.info' ), 'resolv: ks3ipv6.lamiral.info => 2001:41d0:8:bebd::1' ) ; |
| 15663 | |
| 15664 | |
| 15665 | note( 'Leaving tests_resolv()' ) ; |
| 15666 | return ; |
| 15667 | } |
| 15668 | |
| 15669 | |
| 15670 | |
| 15671 | sub resolv |
| 15672 | { |
| 15673 | my $host = shift @ARG ; |
| 15674 | |
| 15675 | if ( ! $host ) { return ; } |
| 15676 | my $addr ; |
| 15677 | if ( defined &Socket::getaddrinfo ) { |
| 15678 | $addr = resolv_with_getaddrinfo( $host ) ; |
| 15679 | return( $addr ) ; |
| 15680 | } |
| 15681 | |
| 15682 | |
| 15683 | |
| 15684 | my $iaddr = inet_aton( $host ) ; |
| 15685 | if ( ! $iaddr ) { return ; } |
| 15686 | $addr = inet_ntoa( $iaddr ) ; |
| 15687 | |
| 15688 | return $addr ; |
| 15689 | } |
| 15690 | |
| 15691 | sub resolv_with_getaddrinfo |
| 15692 | { |
| 15693 | my $host = shift @ARG ; |
| 15694 | |
| 15695 | if ( ! $host ) { return ; } |
| 15696 | |
| 15697 | my ( $err_getaddrinfo, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; |
| 15698 | if ( $err_getaddrinfo ) { |
| 15699 | myprint( "Cannot getaddrinfo of $host: $err_getaddrinfo\n" ) ; |
| 15700 | return ; |
| 15701 | } |
| 15702 | |
| 15703 | my @addr ; |
| 15704 | while( my $ai = shift @res ) { |
| 15705 | my ( $err_getnameinfo, $ipaddr ) = Socket::getnameinfo( $ai->{addr}, Socket::NI_NUMERICHOST(), Socket::NIx_NOSERV() ) ; |
| 15706 | if ( $err_getnameinfo ) { |
| 15707 | myprint( "Cannot getnameinfo of $host: $err_getnameinfo\n" ) ; |
| 15708 | return ; |
| 15709 | } |
| 15710 | $sync->{ debug } and myprint( "$host => $ipaddr\n" ) ; |
| 15711 | push @addr, $ipaddr ; |
| 15712 | my $reverse ; |
| 15713 | ( $err_getnameinfo, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; |
| 15714 | $sync->{ debug } and myprint( "$host => $ipaddr => $reverse\n" ) ; |
| 15715 | } |
| 15716 | |
| 15717 | return $addr[0] ; |
| 15718 | } |
| 15719 | |
| 15720 | sub tests_resolvrev |
| 15721 | { |
| 15722 | note( 'Entering tests_resolvrev()' ) ; |
| 15723 | |
| 15724 | # is( , resolvrev( ), 'resolvrev: => ' ) ; |
| 15725 | is( undef, resolvrev( ), 'resolvrev: no args => undef' ) ; |
| 15726 | is( undef, resolvrev( q{} ), 'resolvrev: empty string => undef' ) ; |
| 15727 | is( undef, resolvrev( 'hostnotexist' ), 'resolvrev: hostnotexist => undef' ) ; |
| 15728 | is( 'localhost', resolvrev( '127.0.0.1' ), 'resolvrev: 127.0.0.1 => localhost' ) ; |
| 15729 | is( 'localhost', resolvrev( 'localhost' ), 'resolvrev: localhost => localhost' ) ; |
| 15730 | is( 'ks.lamiral.info', resolvrev( 'imapsync.lamiral.info' ), 'resolvrev: imapsync.lamiral.info => ks.lamiral.info' ) ; |
| 15731 | |
| 15732 | # ip6-localhost ( in /etc/hosts ) |
| 15733 | is( 'ip6-localhost', resolvrev( 'ip6-localhost' ), 'resolvrev: ip6-localhost => ip6-localhost' ) ; |
| 15734 | is( 'ip6-localhost', resolvrev( '::1' ), 'resolvrev: ::1 => ip6-localhost' ) ; |
| 15735 | # ks2 |
| 15736 | is( 'ks2ipv6.lamiral.info', resolvrev( '2001:41d0:8:d8b6::1' ), 'resolvrev: 2001:41d0:8:d8b6::1 => ks2ipv6.lamiral.info' ) ; |
| 15737 | is( 'ks2ipv6.lamiral.info', resolvrev( 'ks2ipv6.lamiral.info' ), 'resolvrev: ks2ipv6.lamiral.info => ks2ipv6.lamiral.info' ) ; |
| 15738 | # ks3 |
| 15739 | is( 'ks3ipv6.lamiral.info', resolvrev( '2001:41d0:8:bebd::1' ), 'resolvrev: 2001:41d0:8:bebd::1 => ks3ipv6.lamiral.info' ) ; |
| 15740 | is( 'ks3ipv6.lamiral.info', resolvrev( 'ks3ipv6.lamiral.info' ), 'resolvrev: ks3ipv6.lamiral.info => ks3ipv6.lamiral.info' ) ; |
| 15741 | |
| 15742 | |
| 15743 | note( 'Leaving tests_resolvrev()' ) ; |
| 15744 | return ; |
| 15745 | } |
| 15746 | |
| 15747 | sub resolvrev |
| 15748 | { |
| 15749 | my $host = shift @ARG ; |
| 15750 | |
| 15751 | if ( ! $host ) { return ; } |
| 15752 | |
| 15753 | if ( defined &Socket::getaddrinfo ) { |
| 15754 | my $name = resolvrev_with_getaddrinfo( $host ) ; |
| 15755 | return( $name ) ; |
| 15756 | } |
| 15757 | |
| 15758 | return ; |
| 15759 | } |
| 15760 | |
| 15761 | sub resolvrev_with_getaddrinfo |
| 15762 | { |
| 15763 | my $host = shift @ARG ; |
| 15764 | |
| 15765 | if ( ! $host ) { return ; } |
| 15766 | |
| 15767 | my ( $err, @res ) = Socket::getaddrinfo( $host, "", { socktype => Socket::SOCK_RAW } ) ; |
| 15768 | if ( $err ) { |
| 15769 | myprint( "Cannot getaddrinfo of $host: $err\n" ) ; |
| 15770 | return ; |
| 15771 | } |
| 15772 | |
| 15773 | my @name ; |
| 15774 | while( my $ai = shift @res ) { |
| 15775 | my ( $err, $reverse ) = Socket::getnameinfo( $ai->{addr}, 0, Socket::NIx_NOSERV() ) ; |
| 15776 | if ( $err ) { |
| 15777 | myprint( "Cannot getnameinfo of $host: $err\n" ) ; |
| 15778 | return ; |
| 15779 | } |
| 15780 | $sync->{ debug } and myprint( "$host => $reverse\n" ) ; |
| 15781 | push @name, $reverse ; |
| 15782 | } |
| 15783 | |
| 15784 | return $name[0] ; |
| 15785 | } |
| 15786 | |
| 15787 | |
| 15788 | |
| 15789 | sub tests_imapsping |
| 15790 | { |
| 15791 | note( 'Entering tests_imapsping()' ) ; |
| 15792 | |
| 15793 | is( undef, imapsping( ), 'imapsping: no args => undef' ) ; |
| 15794 | is( undef, imapsping( 'hostnotexist' ), 'imapsping: hostnotexist => undef' ) ; |
| 15795 | is( 1, imapsping( 'imapsync.lamiral.info' ), 'imapsping: imapsync.lamiral.info => 1' ) ; |
| 15796 | is( 1, imapsping( 'ks2ipv6.lamiral.info' ), 'imapsping: ks2ipv6.lamiral.info => 1' ) ; |
| 15797 | note( 'Leaving tests_imapsping()' ) ; |
| 15798 | return ; |
| 15799 | } |
| 15800 | |
| 15801 | sub imapsping |
| 15802 | { |
| 15803 | my $host = shift ; |
| 15804 | return tcpping( $host, $IMAP_SSL_PORT ) ; |
| 15805 | } |
| 15806 | |
| 15807 | sub tests_tcpping |
| 15808 | { |
| 15809 | note( 'Entering tests_tcpping()' ) ; |
| 15810 | |
| 15811 | is( undef, tcpping( ), 'tcpping: no args => undef' ) ; |
| 15812 | is( undef, tcpping( 'hostnotexist' ), 'tcpping: one arg => undef' ) ; |
| 15813 | is( undef, tcpping( undef, 888 ), 'tcpping: arg undef, port => undef' ) ; |
| 15814 | is( undef, tcpping( 'hostnotexist', 993 ), 'tcpping: hostnotexist 993 => undef' ) ; |
| 15815 | is( undef, tcpping( 'hostnotexist', 888 ), 'tcpping: hostnotexist 888 => undef' ) ; |
| 15816 | is( 1, tcpping( 'imapsync.lamiral.info', 993 ), 'tcpping: imapsync.lamiral.info 993 => 1' ) ; |
| 15817 | is( 0, tcpping( 'imapsync.lamiral.info', 888 ), 'tcpping: imapsync.lamiral.info 888 => 0' ) ; |
| 15818 | is( 1, tcpping( '5.135.158.182', 993 ), 'tcpping: 5.135.158.182 993 => 1' ) ; |
| 15819 | is( 0, tcpping( '5.135.158.182', 888 ), 'tcpping: 5.135.158.182 888 => 0' ) ; |
| 15820 | |
| 15821 | # Net::Ping supports ipv6 only after release 1.50 |
| 15822 | # http://cpansearch.perl.org/src/RURBAN/Net-Ping-2.59/Changes |
| 15823 | # Anyway I plan to avoid Net-Ping for that too long standing feature |
| 15824 | # Net-Ping is integrated in Perl itself, who knows ipv6 for a long time |
| 15825 | is( 1, tcpping( '2001:41d0:8:d8b6::1', 993 ), 'tcpping: 2001:41d0:8:d8b6::1 993 => 1' ) ; |
| 15826 | is( 0, tcpping( '2001:41d0:8:d8b6::1', 888 ), 'tcpping: 2001:41d0:8:d8b6::1 888 => 0' ) ; |
| 15827 | |
| 15828 | note( 'Leaving tests_tcpping()' ) ; |
| 15829 | return ; |
| 15830 | } |
| 15831 | |
| 15832 | sub tcpping |
| 15833 | { |
| 15834 | if ( 2 != scalar( @ARG ) ) { |
| 15835 | return ; |
| 15836 | } |
| 15837 | my ( $host, $port ) = @ARG ; |
| 15838 | if ( ! $host ) { return ; } |
| 15839 | if ( ! $port ) { return ; } |
| 15840 | |
| 15841 | my $mytimeout = $TCP_PING_TIMEOUT ; |
| 15842 | require Net::Ping ; |
| 15843 | #my $p = Net::Ping->new( 'tcp' ) ; |
| 15844 | my $p = Net::Ping->new( ) ; |
| 15845 | $p->{port_num} = $port ; |
| 15846 | $p->service_check( 1 ) ; |
| 15847 | $p->hires( 1 ) ; |
| 15848 | my ($ping_ok, $rtt, $ip ) = $p->ping( $host, $mytimeout ) ; |
| 15849 | if ( ! defined $ping_ok ) { return ; } |
| 15850 | my $rtt_approx = sprintf( "%.3f", $rtt ) ; |
| 15851 | $sync->{ debug } and myprint( "Host $host timeout $mytimeout port $port ok $ping_ok ip $ip acked in $rtt_approx s\n" ) ; |
| 15852 | $p->close( ) ; |
| 15853 | if( $ping_ok ) { |
| 15854 | return 1 ; |
| 15855 | }else{ |
| 15856 | return 0 ; |
| 15857 | } |
| 15858 | } |
| 15859 | |
| 15860 | sub tests_sslcheck |
| 15861 | { |
| 15862 | note( 'Entering tests_sslcheck()' ) ; |
| 15863 | |
| 15864 | my $mysync ; |
| 15865 | |
| 15866 | is( undef, sslcheck( $mysync ), 'sslcheck: no sslcheck => undef' ) ; |
| 15867 | |
| 15868 | $mysync = { |
| 15869 | sslcheck => 1, |
| 15870 | } ; |
| 15871 | |
| 15872 | is( 0, sslcheck( $mysync ), 'sslcheck: no host => 0' ) ; |
| 15873 | |
| 15874 | $mysync = { |
| 15875 | sslcheck => 1, |
| 15876 | host1 => 'imapsync.lamiral.info', |
| 15877 | tls1 => 1, |
| 15878 | } ; |
| 15879 | |
| 15880 | is( 0, sslcheck( $mysync ), 'sslcheck: tls1 => 0' ) ; |
| 15881 | |
| 15882 | $mysync = { |
| 15883 | sslcheck => 1, |
| 15884 | host1 => 'imapsync.lamiral.info', |
| 15885 | } ; |
| 15886 | |
| 15887 | |
| 15888 | is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info => 1' ) ; |
| 15889 | is( 1, $mysync->{ssl1}, 'sslcheck: imapsync.lamiral.info => ssl1 1' ) ; |
| 15890 | |
| 15891 | $mysync->{sslcheck} = 0 ; |
| 15892 | is( undef, sslcheck( $mysync ), 'sslcheck: sslcheck off => undef' ) ; |
| 15893 | |
| 15894 | $mysync = { |
| 15895 | sslcheck => 1, |
| 15896 | host1 => 'imapsync.lamiral.info', |
| 15897 | host2 => 'test2.lamiral.info', |
| 15898 | } ; |
| 15899 | |
| 15900 | is( 2, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info + test2.lamiral.info => 2' ) ; |
| 15901 | |
| 15902 | $mysync = { |
| 15903 | sslcheck => 1, |
| 15904 | host1 => 'imapsync.lamiral.info', |
| 15905 | host2 => 'test2.lamiral.info', |
| 15906 | tls1 => 1, |
| 15907 | } ; |
| 15908 | |
| 15909 | is( 1, sslcheck( $mysync ), 'sslcheck: imapsync.lamiral.info + test2.lamiral.info + tls1 => 1' ) ; |
| 15910 | |
| 15911 | note( 'Leaving tests_sslcheck()' ) ; |
| 15912 | return ; |
| 15913 | } |
| 15914 | |
| 15915 | sub sslcheck |
| 15916 | { |
| 15917 | my $mysync = shift ; |
| 15918 | |
| 15919 | if ( ! $mysync->{sslcheck} ) { |
| 15920 | return ; |
| 15921 | } |
| 15922 | my $nb_on = 0 ; |
| 15923 | $mysync->{ debug } and myprint( "sslcheck\n" ) ; |
| 15924 | if ( |
| 15925 | ( ! defined $mysync->{port1} ) |
| 15926 | and |
| 15927 | ( ! defined $mysync->{tls1} ) |
| 15928 | and |
| 15929 | ( ! defined $mysync->{ssl1} ) |
| 15930 | and |
| 15931 | ( defined $mysync->{host1} ) |
| 15932 | ) { |
| 15933 | myprint( "Host1: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ; |
| 15934 | if ( probe_imapssl( $mysync->{host1} ) ) { |
| 15935 | $mysync->{ssl1} = 1 ; |
| 15936 | myprint( "Host1: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl1 --notls1 to turn off SSL and TLS wizardry)\n" ) ; |
| 15937 | $nb_on++ ; |
| 15938 | }else{ |
| 15939 | myprint( "Host1: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ; |
| 15940 | } |
| 15941 | } |
| 15942 | |
| 15943 | if ( |
| 15944 | ( ! defined $mysync->{port2} ) |
| 15945 | and |
| 15946 | ( ! defined $mysync->{tls2} ) |
| 15947 | and |
| 15948 | ( ! defined $mysync->{ssl2} ) |
| 15949 | and |
| 15950 | ( defined $mysync->{host2} ) |
| 15951 | ) { |
| 15952 | myprint( "Host2: probing ssl on port $IMAP_SSL_PORT ( use --nosslcheck to avoid this ssl probe ) \n" ) ; |
| 15953 | if ( probe_imapssl( $mysync->{host2} ) ) { |
| 15954 | $mysync->{ssl2} = 1 ; |
| 15955 | myprint( "Host2: sslcheck detected open ssl port $IMAP_SSL_PORT so turning ssl on (use --nossl2 --notls2 to turn off SSL and TLS wizardry)\n" ) ; |
| 15956 | $nb_on++ ; |
| 15957 | }else{ |
| 15958 | myprint( "Host2: sslcheck did not detected open ssl port $IMAP_SSL_PORT. Will use standard $IMAP_PORT port.\n" ) ; |
| 15959 | } |
| 15960 | } |
| 15961 | return $nb_on ; |
| 15962 | } |
| 15963 | |
| 15964 | |
| 15965 | sub testslive_init |
| 15966 | { |
| 15967 | my $mysync = shift ; |
| 15968 | $mysync->{host1} ||= 'test1.lamiral.info' ; |
| 15969 | $mysync->{user1} ||= 'test1' ; |
| 15970 | $mysync->{password1} ||= 'secret1' ; |
| 15971 | $mysync->{host2} ||= 'test2.lamiral.info' ; |
| 15972 | $mysync->{user2} ||= 'test2' ; |
| 15973 | $mysync->{password2} ||= 'secret2' ; |
| 15974 | return ; |
| 15975 | } |
| 15976 | |
| 15977 | sub testslive6_init |
| 15978 | { |
| 15979 | my $mysync = shift ; |
| 15980 | $mysync->{host1} ||= 'ks2ipv6.lamiral.info' ; |
| 15981 | $mysync->{user1} ||= 'test1' ; |
| 15982 | $mysync->{password1} ||= 'secret1' ; |
| 15983 | $mysync->{host2} ||= 'ks2ipv6.lamiral.info' ; |
| 15984 | $mysync->{user2} ||= 'test2' ; |
| 15985 | $mysync->{password2} ||= 'secret2' ; |
| 15986 | return ; |
| 15987 | } |
| 15988 | |
| 15989 | |
| 15990 | sub tests_backslash_caret |
| 15991 | { |
| 15992 | note( 'Entering tests_backslash_caret()' ) ; |
| 15993 | |
| 15994 | is( "lalala", backslash_caret( "lalala" ), 'backslash_caret: lalala => lalala' ) ; |
| 15995 | is( "lalala\n", backslash_caret( "lalala\n" ), 'backslash_caret: lalala => lalala 2nd' ) ; |
| 15996 | is( '^', backslash_caret( '\\' ), 'backslash_caret: \\ => ^' ) ; |
| 15997 | is( "^\n", backslash_caret( "\\\n" ), 'backslash_caret: \\ => ^' ) ; |
| 15998 | is( "\\lalala", backslash_caret( "\\lalala" ), 'backslash_caret: \\lalala => \\lalala' ) ; |
| 15999 | is( "\\lal\\ala", backslash_caret( "\\lal\\ala" ), 'backslash_caret: \\lal\\ala => \\lal\\ala' ) ; |
| 16000 | is( "\\lalala\n", backslash_caret( "\\lalala\n" ), 'backslash_caret: \\lalala => \\lalala 2nd' ) ; |
| 16001 | is( "lalala^\n", backslash_caret( "lalala\\\n" ), 'backslash_caret: lalala\\\n => lalala^\n' ) ; |
| 16002 | is( "lalala^\nlalala^\n", backslash_caret( "lalala\\\nlalala\\\n" ), 'backslash_caret: lalala\\\nlalala\\\n => lalala^\nlalala^\n' ) ; |
| 16003 | is( "lal\\ala^\nlalala^\n", backslash_caret( "lal\\ala\\\nlalala\\\n" ), 'backslash_caret: lal\\ala\\\nlalala\\\n => lal\\ala^\nlalala^\n' ) ; |
| 16004 | |
| 16005 | note( 'Leaving tests_backslash_caret()' ) ; |
| 16006 | return ; |
| 16007 | } |
| 16008 | |
| 16009 | sub backslash_caret |
| 16010 | { |
| 16011 | my $string = shift ; |
| 16012 | |
| 16013 | $string =~ s{\\ $ }{^}gxms ; |
| 16014 | |
| 16015 | return $string ; |
| 16016 | } |
| 16017 | |
| 16018 | sub tests_split_around_equal |
| 16019 | { |
| 16020 | note( 'Entering tests_split_around_equal()' ) ; |
| 16021 | |
| 16022 | is( undef, split_around_equal( ), 'split_around_equal: no args => undef' ) ; |
| 16023 | is_deeply( { toto => 'titi' }, { split_around_equal( 'toto=titi' ) }, 'split_around_equal: toto=titi => toto => titi' ) ; |
| 16024 | is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B=C=D' ) }, 'split_around_equal: toto=titi => toto => titi' ) ; |
| 16025 | is_deeply( { A => 'B', C => 'D' }, { split_around_equal( 'A=B', 'C=D' ) }, 'split_around_equal: A=B C=D => A => B, C=>D' ) ; |
| 16026 | |
| 16027 | note( 'Leaving tests_split_around_equal()' ) ; |
| 16028 | return ; |
| 16029 | } |
| 16030 | |
| 16031 | sub split_around_equal |
| 16032 | { |
| 16033 | if ( ! @ARG ) { return ; } ; |
| 16034 | return map { split /=/mxs, $_ } @ARG ; |
| 16035 | |
| 16036 | } |
| 16037 | |
| 16038 | |
| 16039 | |
| 16040 | sub tests_sig_install |
| 16041 | { |
| 16042 | note( 'Entering tests_sig_install()' ) ; |
| 16043 | |
| 16044 | my $mysync ; |
| 16045 | is( undef, sig_install( ), 'sig_install: no args => undef' ) ; |
| 16046 | is( undef, sig_install( $mysync ), 'sig_install: arg undef => undef' ) ; |
| 16047 | $mysync = { } ; |
| 16048 | is( undef, sig_install( $mysync ), 'sig_install: empty hash => undef' ) ; |
| 16049 | |
| 16050 | SKIP: { |
| 16051 | Readonly my $SKIP_15 => 15 ; |
| 16052 | if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_15 ) ; } |
| 16053 | # Default to ignore USR1 USR2 in case future install fails |
| 16054 | local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ; |
| 16055 | kill( 'USR1', $PROCESS_ID ) ; |
| 16056 | |
| 16057 | $mysync->{ debugsig } = 1 ; |
| 16058 | # Assign USR1 to call sub tototo |
| 16059 | # Surely a better value than undef should be returned when doing real signal stuff |
| 16060 | is( undef, sig_install( $mysync, 'tototo', 'USR1' ), 'sig_install: USR1 tototo' ) ; |
| 16061 | |
| 16062 | is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 1' ) ; |
| 16063 | is( 1, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 1' ) ; |
| 16064 | |
| 16065 | #return ; |
| 16066 | # Assign USR2 to call sub tototo |
| 16067 | is( undef, sig_install( $mysync, 'tototo', 'USR2' ), 'sig_install: USR2 tototo' ) ; |
| 16068 | |
| 16069 | is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR2 myself 1' ) ; |
| 16070 | is( 2, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 2' ) ; |
| 16071 | |
| 16072 | is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ; |
| 16073 | is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call nb 3' ) ; |
| 16074 | |
| 16075 | |
| 16076 | local $SIG{ USR1 } = local $SIG{ USR2 } = sub { } ; |
| 16077 | is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 3' ) ; |
| 16078 | is( 3, $mysync->{ tototo_calls }, 'sig_install: tototo call still nb 3' ) ; |
| 16079 | |
| 16080 | # Assign USR1 + USR2 to call sub tototo |
| 16081 | is( undef, sig_install( $mysync, 'tototo', 'USR1', 'USR2' ), 'sig_install: USR1 USR2 tototo' ) ; |
| 16082 | is( 1, kill( 'USR1', $PROCESS_ID ), 'sig_install: kill USR1 myself 4' ) ; |
| 16083 | is( 4, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 4' ) ; |
| 16084 | |
| 16085 | is( 1, kill( 'USR2', $PROCESS_ID ), 'sig_install: kill USR1 myself 2' ) ; |
| 16086 | is( 5, $mysync->{ tototo_calls }, 'sig_install: tototo call now nb 5' ) ; |
| 16087 | } |
| 16088 | |
| 16089 | |
| 16090 | note( 'Leaving tests_sig_install()' ) ; |
| 16091 | return ; |
| 16092 | } |
| 16093 | |
| 16094 | |
| 16095 | # |
| 16096 | sub sig_install |
| 16097 | { |
| 16098 | my $mysync = shift ; |
| 16099 | if ( ! $mysync ) { return ; } |
| 16100 | my $mysubname = shift ; |
| 16101 | if ( ! $mysubname ) { return ; } |
| 16102 | |
| 16103 | if ( ! @ARG ) { return ; } |
| 16104 | |
| 16105 | my @signals = @ARG ; |
| 16106 | |
| 16107 | my $mysub = \&$mysubname ; |
| 16108 | #$mysync->{ debugsig } = 1 ; |
| 16109 | $mysync->{ debugsig } and myprint( "In sig_install with sub $mysubname and signal @ARG\n" ) ; |
| 16110 | |
| 16111 | my $subsignal = sub { |
| 16112 | my $signame = shift ; |
| 16113 | $mysync->{ debugsig } and myprint( "In subsignal with $signame and $mysubname\n" ) ; |
| 16114 | &$mysub( $mysync, $signame ) ; |
| 16115 | } ; |
| 16116 | |
| 16117 | foreach my $signal ( @signals ) { |
| 16118 | $mysync->{ debugsig } and myprint( "Installing signal $signal to call sub $mysubname\n") ; |
| 16119 | output( $mysync, "kill -$signal $PROCESS_ID # special behavior: call to sub $mysubname\n" ) ; |
| 16120 | ## no critic (RequireLocalizedPunctuationVars) |
| 16121 | $SIG{ $signal } = $subsignal ; |
| 16122 | } |
| 16123 | return ; |
| 16124 | } |
| 16125 | |
| 16126 | |
| 16127 | sub tototo |
| 16128 | { |
| 16129 | my $mysync = shift ; |
| 16130 | myprint("In tototo with @ARG\n" ) ; |
| 16131 | $mysync->{ tototo_calls } += 1 ; |
| 16132 | return ; |
| 16133 | } |
| 16134 | |
| 16135 | sub mygetppid |
| 16136 | { |
| 16137 | if ( 'MSWin32' eq $OSNAME ) { |
| 16138 | return( 'unknown under MSWin32 (too complicated)' ) ; |
| 16139 | } else { |
| 16140 | # Unix |
| 16141 | return( getppid( ) ) ; |
| 16142 | } |
| 16143 | } |
| 16144 | |
| 16145 | |
| 16146 | |
| 16147 | sub tests_toggle_sleep |
| 16148 | { |
| 16149 | note( 'Entering tests_toggle_sleep()' ) ; |
| 16150 | |
| 16151 | is( undef, toggle_sleep( ), 'toggle_sleep: no args => undef' ) ; |
| 16152 | my $mysync ; |
| 16153 | is( undef, toggle_sleep( $mysync ), 'toggle_sleep: undef => undef' ) ; |
| 16154 | $mysync = { } ; |
| 16155 | is( undef, toggle_sleep( $mysync ), 'toggle_sleep: no maxsleep => undef' ) ; |
| 16156 | |
| 16157 | $mysync->{maxsleep} = 3 ; |
| 16158 | is( 0, toggle_sleep( $mysync ), 'toggle_sleep: 3 => 0' ) ; |
| 16159 | |
| 16160 | is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ; |
| 16161 | is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ; |
| 16162 | is( $MAX_SLEEP, toggle_sleep( $mysync ), "toggle_sleep: 0 => $MAX_SLEEP" ) ; |
| 16163 | is( 0, toggle_sleep( $mysync ), "toggle_sleep: $MAX_SLEEP => 0" ) ; |
| 16164 | |
| 16165 | SKIP: { |
| 16166 | Readonly my $SKIP_9 => 9 ; |
| 16167 | if ( 'MSWin32' eq $OSNAME ) { skip( 'Tests only for Unix', $SKIP_9 ) ; } |
| 16168 | # Default to ignore USR1 USR2 in case future install fails |
| 16169 | local $SIG{ USR1 } = sub { } ; |
| 16170 | kill( 'USR1', $PROCESS_ID ) ; |
| 16171 | |
| 16172 | $mysync->{ debugsig } = 1 ; |
| 16173 | # Assign USR1 to call sub toggle_sleep |
| 16174 | is( undef, sig_install( $mysync, \&toggle_sleep, 'USR1' ), 'toggle_sleep: install USR1 toggle_sleep' ) ; |
| 16175 | |
| 16176 | |
| 16177 | $mysync->{maxsleep} = 4 ; |
| 16178 | is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ; |
| 16179 | is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ; |
| 16180 | |
| 16181 | is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ; |
| 16182 | is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ; |
| 16183 | |
| 16184 | is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself' ) ; |
| 16185 | is( 0, $mysync->{ maxsleep }, 'toggle_sleep: toggle_sleep called => sleeps are 0s' ) ; |
| 16186 | |
| 16187 | is( 1, kill( 'USR1', $PROCESS_ID ), 'toggle_sleep: kill USR1 myself again' ) ; |
| 16188 | is( $MAX_SLEEP, $mysync->{ maxsleep }, "toggle_sleep: toggle_sleep called => sleeps are ${MAX_SLEEP}s" ) ; |
| 16189 | } |
| 16190 | |
| 16191 | note( 'Leaving tests_toggle_sleep()' ) ; |
| 16192 | return ; |
| 16193 | } |
| 16194 | |
| 16195 | |
| 16196 | sub toggle_sleep |
| 16197 | { |
| 16198 | my $mysync = shift ; |
| 16199 | |
| 16200 | myprint("In toggle_sleep with @ARG\n" ) ; |
| 16201 | |
| 16202 | if ( !defined( $mysync ) ) { return ; } |
| 16203 | if ( !defined( $mysync->{maxsleep} ) ) { return ; } |
| 16204 | |
| 16205 | $mysync->{ maxsleep } = max( 0, $MAX_SLEEP - $mysync->{maxsleep} ) ; |
| 16206 | myprint("Resetting maxsleep to ", $mysync->{maxsleep}, "s\n" ) ; |
| 16207 | return $mysync->{maxsleep} ; |
| 16208 | } |
| 16209 | |
| 16210 | sub mypod2usage |
| 16211 | { |
| 16212 | my $fh_pod2usage = shift ; |
| 16213 | |
| 16214 | pod2usage( |
| 16215 | -exitval => 'NOEXIT', |
| 16216 | -noperldoc => 1, |
| 16217 | -verbose => 99, |
| 16218 | -sections => [ qw(NAME VERSION USAGE OPTIONS) ], |
| 16219 | -indent => 1, |
| 16220 | -loose => 1, |
| 16221 | -output => $fh_pod2usage, |
| 16222 | ) ; |
| 16223 | |
| 16224 | return ; |
| 16225 | } |
| 16226 | |
| 16227 | sub usage |
| 16228 | { |
| 16229 | my $mysync = shift ; |
| 16230 | |
| 16231 | if ( ! defined $mysync ) { return ; } |
| 16232 | |
| 16233 | my $usage = q{} ; |
| 16234 | my $usage_from_pod ; |
| 16235 | my $usage_footer = usage_footer( $mysync ) ; |
| 16236 | |
| 16237 | # pod2usage writes on a filehandle only and I want a variable |
| 16238 | open my $fh_pod2usage, ">", \$usage_from_pod |
| 16239 | or do { warn $OS_ERROR ; return ; } ; |
| 16240 | mypod2usage( $fh_pod2usage ) ; |
| 16241 | close $fh_pod2usage ; |
| 16242 | |
| 16243 | if ( 'MSWin32' eq $OSNAME ) { |
| 16244 | $usage_from_pod = backslash_caret( $usage_from_pod ) ; |
| 16245 | } |
| 16246 | $usage = join( q{}, $usage_from_pod, $usage_footer ) ; |
| 16247 | |
| 16248 | return( $usage ) ; |
| 16249 | } |
| 16250 | |
| 16251 | sub tests_usage |
| 16252 | { |
| 16253 | note( 'Entering tests_usage()' ) ; |
| 16254 | |
| 16255 | my $usage ; |
| 16256 | like( $usage = usage( $sync ), qr/Name:/, 'usage: contains Name:' ) ; |
| 16257 | myprint( $usage ) ; |
| 16258 | like( $usage, qr/Version:/, 'usage: contains Version:' ) ; |
| 16259 | like( $usage, qr/Usage:/, 'usage: contains Usage:' ) ; |
| 16260 | like( $usage, qr/imapsync/, 'usage: contains imapsync' ) ; |
| 16261 | |
| 16262 | is( undef, usage( ), 'usage: no args => undef' ) ; |
| 16263 | |
| 16264 | note( 'Leaving tests_usage()' ) ; |
| 16265 | return ; |
| 16266 | } |
| 16267 | |
| 16268 | |
| 16269 | sub usage_footer |
| 16270 | { |
| 16271 | my $mysync = shift ; |
| 16272 | |
| 16273 | my $footer = q{} ; |
| 16274 | |
| 16275 | my $localhost_info = localhost_info( $mysync ) ; |
| 16276 | my $rcs = $mysync->{rcs} ; |
| 16277 | my $homepage = homepage( ) ; |
| 16278 | |
| 16279 | my $imapsync_release = $STR_use_releasecheck ; |
| 16280 | |
| 16281 | if ( $mysync->{releasecheck} ) { |
| 16282 | $imapsync_release = check_last_release( ) ; |
| 16283 | } |
| 16284 | |
| 16285 | $footer = qq{$localhost_info |
| 16286 | $rcs |
| 16287 | $imapsync_release |
| 16288 | $homepage |
| 16289 | } ; |
| 16290 | return( $footer ) ; |
| 16291 | } |
| 16292 | |
| 16293 | |
| 16294 | |
| 16295 | sub usage_complete |
| 16296 | { |
| 16297 | # Unused, I guess this function could be deleted |
| 16298 | my $usage = <<'EOF' ; |
| 16299 | --skipheader reg : Don't take into account header keyword |
| 16300 | matching reg ex: --skipheader 'X.*' |
| 16301 | |
| 16302 | --skipsize : Don't take message size into account to compare |
| 16303 | messages on both sides. On by default. |
| 16304 | Use --no-skipsize for using size comparaison. |
| 16305 | --allowsizemismatch : allow RFC822.SIZE != fetched msg size |
| 16306 | consider also --skipsize to avoid duplicate messages |
| 16307 | when running syncs more than one time per mailbox |
| 16308 | |
| 16309 | --reconnectretry1 int : reconnect to host1 if connection is lost up to |
| 16310 | int times per imap command (default is 3) |
| 16311 | --reconnectretry2 int : same as --reconnectretry1 but for host2 |
| 16312 | --split1 int : split the requests in several parts on host1. |
| 16313 | int is the number of messages handled per request. |
| 16314 | default is like --split1 100. |
| 16315 | --split2 int : same thing on host2. |
| 16316 | --nofixInboxINBOX : Don't fix Inbox INBOX mapping. |
| 16317 | EOF |
| 16318 | return( $usage ) ; |
| 16319 | } |
| 16320 | |
| 16321 | sub myGetOptions |
| 16322 | { |
| 16323 | |
| 16324 | # Started as a copy of Luke Ross Getopt::Long::CGI |
| 16325 | # https://metacpan.org/release/Getopt-Long-CGI |
| 16326 | # So this sub function is under the same license as Getopt-Long-CGI Luke Ross wants it, |
| 16327 | # which was Perl 5.6 or later licenses at the date of the copy. |
| 16328 | |
| 16329 | my $mysync = shift @ARG ; |
| 16330 | my $arguments_ref = shift @ARG ; |
| 16331 | my %options = @ARG ; |
| 16332 | |
| 16333 | my $mycgi = $mysync->{cgi} ; |
| 16334 | |
| 16335 | if ( not under_cgi_context() ) { |
| 16336 | |
| 16337 | # Not CGI - pass upstream for normal command line handling |
| 16338 | return Getopt::Long::GetOptionsFromArray( $arguments_ref, %options ) ; |
| 16339 | } |
| 16340 | |
| 16341 | # We must be in CGI context now |
| 16342 | if ( ! defined( $mycgi ) ) { return ; } |
| 16343 | |
| 16344 | my $badthings = 0 ; |
| 16345 | foreach my $key ( sort keys %options ) { |
| 16346 | my $val = $options{$key} ; |
| 16347 | |
| 16348 | if ( $key !~ m/^([\w\d\|]+)([=:][isf])?([\+!\@\%])?$/mxs ) { |
| 16349 | $badthings++ ; |
| 16350 | next ; # Unknown item |
| 16351 | } |
| 16352 | |
| 16353 | my $name = [ split '|', $1, 1 ]->[0] ; |
| 16354 | |
| 16355 | if ( ( $3 || q{} ) eq '+' ) { |
| 16356 | ${$val} = $mycgi->param( $name ) ; # "Incremental" integer |
| 16357 | } |
| 16358 | elsif ( $2 ) { |
| 16359 | my @values = $mycgi->multi_param( $name ) ; |
| 16360 | my $type = $2 ; |
| 16361 | |
| 16362 | #myprint( "type[$type]values[@values]\$3[", $3 || q{}, "]val[$val]ref(val)[", ref($val), "]\n" ) ; |
| 16363 | if ( ( $3 || q{} ) eq '%' or ref( $val ) eq 'HASH' ) { |
| 16364 | my %values = map { split /=/mxs, $_ } @values ; |
| 16365 | |
| 16366 | if ( $type =~ m/i$/mxs ) { |
| 16367 | foreach my $k ( keys %values ) { |
| 16368 | $values{$k} = int $values{$k} ; |
| 16369 | } |
| 16370 | } |
| 16371 | elsif ( $type =~ m/f$/mxs ) { |
| 16372 | foreach my $k ( keys %values ) { |
| 16373 | $values{$k} = 0 + $values{$k}; |
| 16374 | } |
| 16375 | } |
| 16376 | if ( 'REF' eq ref $val ) { |
| 16377 | %{ ${$val} } = %values ; |
| 16378 | } |
| 16379 | else { |
| 16380 | %{$val} = %values ; |
| 16381 | } |
| 16382 | } |
| 16383 | else { |
| 16384 | if ( $type =~ m/i$/mxs ) { |
| 16385 | @values = map { q{} ne $_ ? int $_ : undef } @values ; |
| 16386 | } |
| 16387 | elsif ( $type =~ m/f$/mxs ) { |
| 16388 | @values = map { 0 + $_ } @values ; |
| 16389 | } |
| 16390 | if ( ( $3 || q{} ) eq '@' ) { |
| 16391 | @{ ${$val} } = @values ; |
| 16392 | my @option = map { +( "--$name", "$_" ) } @values ; |
| 16393 | push @{ $mysync->{ cmdcgi } }, @option ; |
| 16394 | } |
| 16395 | elsif ( ref( $val ) eq 'ARRAY' ) { |
| 16396 | @{$val} = @values ; |
| 16397 | } |
| 16398 | elsif ( my $value = $values[0] ) |
| 16399 | { |
| 16400 | ${$val} = $value ; |
| 16401 | push @{ $mysync->{ cmdcgi } }, "--$name", $value ; |
| 16402 | } |
| 16403 | else |
| 16404 | { |
| 16405 | |
| 16406 | } |
| 16407 | } |
| 16408 | } |
| 16409 | else |
| 16410 | { |
| 16411 | # Checkbox |
| 16412 | # Considers only --name |
| 16413 | # Should consider also --no-name and --noname |
| 16414 | my $value = $mycgi->param( $name ) ; |
| 16415 | if ( $value ) |
| 16416 | { |
| 16417 | ${$val} = 1 ; |
| 16418 | push @{ $mysync->{ cmdcgi } }, "--$name" ; |
| 16419 | } |
| 16420 | else |
| 16421 | { |
| 16422 | ${$val} = undef ; |
| 16423 | } |
| 16424 | } |
| 16425 | } |
| 16426 | if ( $badthings ) { |
| 16427 | return ; # undef or () |
| 16428 | } |
| 16429 | else { |
| 16430 | return ( 1 ) ; |
| 16431 | } |
| 16432 | } |
| 16433 | |
| 16434 | |
| 16435 | my @blabla ; # just used to check get_options_cgi() with an array |
| 16436 | |
| 16437 | sub tests_get_options_cgi_context |
| 16438 | { |
| 16439 | note( 'Entering tests_get_options_cgi()' ) ; |
| 16440 | |
| 16441 | # Temporary, have to think harder about testing CGI context in command line --tests |
| 16442 | # API: |
| 16443 | # * input arguments: two ways, command line or CGI |
| 16444 | # * the program arguments |
| 16445 | # * QUERY_STRING env variable |
| 16446 | # * return |
| 16447 | # * QUERY_STRING length |
| 16448 | |
| 16449 | # CGI context |
| 16450 | local $ENV{SERVER_SOFTWARE} = 'Votre serviteur' ; |
| 16451 | |
| 16452 | # Real full test |
| 16453 | # = 'host1=test1.lamiral.info&user1=test1&password1=secret1&host2=test2.lamiral.info&user2=test2&password2=secret2&debugenv=on' |
| 16454 | my $mysync ; |
| 16455 | is( undef, get_options( $mysync ), 'get_options cgi context: no CGI module => undef' ) ; |
| 16456 | |
| 16457 | require CGI ; |
| 16458 | CGI->import( qw( -no_debug -utf8 ) ) ; |
| 16459 | |
| 16460 | is( undef, get_options( $mysync ), 'get_options cgi context: no CGI param => undef' ) ; |
| 16461 | # Testing boolean |
| 16462 | $mysync->{cgi} = CGI->new( 'version=on&debugenv=on' ) ; |
| 16463 | local $ENV{'QUERY_STRING'} = 'version=on&debugenv=on' ; |
| 16464 | is( 22, get_options( $mysync ), 'get_options cgi context: QUERY_STRING => 22' ) ; |
| 16465 | is( 1, $mysync->{ version }, 'get_options cgi context: --version => 1' ) ; |
| 16466 | # debugenv is not allowed in cgi context |
| 16467 | is( undef, $mysync->{debugenv}, 'get_options cgi context: $mysync->{debugenv} => undef' ) ; |
| 16468 | |
| 16469 | # QUERY_STRING in this test is only for return value of get_options |
| 16470 | # Have to think harder, GET/POST context, is this return value a good thing? |
| 16471 | local $ENV{'QUERY_STRING'} = 'host1=test1.lamiral.info&user1=test1' ; |
| 16472 | $mysync->{cgi} = CGI->new( 'host1=test1.lamiral.info&user1=test1' ) ; |
| 16473 | is( 36, get_options( $mysync, ), 'get_options cgi context: QUERY_STRING => 36' ) ; |
| 16474 | is( 'test1', $mysync->{user1}, 'get_options cgi context: $mysync->{user1} => test1' ) ; |
| 16475 | #local $ENV{'QUERY_STRING'} = undef ; |
| 16476 | |
| 16477 | # Testing @ |
| 16478 | $mysync->{cgi} = CGI->new( 'blabla=fd1' ) ; |
| 16479 | get_options( $mysync ) ; |
| 16480 | is_deeply( [ 'fd1' ], [ @blabla ], 'get_options cgi context: @blabla => fd1' ) ; |
| 16481 | $mysync->{cgi} = CGI->new( 'blabla=fd1&blabla=fd2' ) ; |
| 16482 | get_options( $mysync ) ; |
| 16483 | is_deeply( [ 'fd1', 'fd2' ], [ @blabla ], 'get_options cgi context: @blabla => fd1, fd2' ) ; |
| 16484 | |
| 16485 | # Testing s@ as ref |
| 16486 | $mysync->{cgi} = CGI->new( 'folder=fd1' ) ; |
| 16487 | get_options( $mysync ) ; |
| 16488 | is_deeply( [ 'fd1' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1' ) ; |
| 16489 | $mysync->{cgi} = CGI->new( 'folder=fd1&folder=fd2' ) ; |
| 16490 | get_options( $mysync ) ; |
| 16491 | is_deeply( [ 'fd1', 'fd2' ], $mysync->{ folder }, 'get_options cgi context: $mysync->{ folder } => fd1, fd2' ) ; |
| 16492 | |
| 16493 | # Testing % |
| 16494 | $mysync->{cgi} = CGI->new( 'f1f2h=s1=d1&f1f2h=s2=d2&f1f2h=s3=d3' ) ; |
| 16495 | get_options( $mysync ) ; |
| 16496 | |
| 16497 | is_deeply( { 's1' => 'd1', 's2' => 'd2', 's3' => 'd3' }, |
| 16498 | $mysync->{f1f2h}, 'get_options cgi context: f1f2h => s1=d1 s2=d2 s3=d3' ) ; |
| 16499 | |
| 16500 | # Testing boolean ! with --noxxx, doesnot work |
| 16501 | $mysync->{cgi} = CGI->new( 'nodry=on' ) ; |
| 16502 | get_options( $mysync ) ; |
| 16503 | is( undef, $mysync->{dry}, 'get_options cgi context: --nodry => $mysync->{dry} => undef' ) ; |
| 16504 | |
| 16505 | $mysync->{cgi} = CGI->new( 'host1=example.com' ) ; |
| 16506 | get_options( $mysync ) ; |
| 16507 | is( 'example.com', $mysync->{host1}, 'get_options cgi context: --host1=example.com => $mysync->{host1} => example.com' ) ; |
| 16508 | |
| 16509 | #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; |
| 16510 | $mysync->{cgi} = CGI->new( 'simulong=' ) ; |
| 16511 | get_options( $mysync ) ; |
| 16512 | is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong= => $mysync->{simulong} => undef' ) ; |
| 16513 | |
| 16514 | $mysync->{cgi} = CGI->new( 'simulong' ) ; |
| 16515 | get_options( $mysync ) ; |
| 16516 | is( undef, $mysync->{simulong}, 'get_options cgi context: --simulong => $mysync->{simulong} => undef' ) ; |
| 16517 | |
| 16518 | $mysync->{cgi} = CGI->new( 'simulong=4' ) ; |
| 16519 | get_options( $mysync ) ; |
| 16520 | is( 4, $mysync->{simulong}, 'get_options cgi context: --simulong=4 => $mysync->{simulong} => 4' ) ; |
| 16521 | is( undef, $mysync->{ folder }, 'get_options cgi context: --simulong=4 => $mysync->{ folder } => undef' ) ; |
| 16522 | #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; |
| 16523 | |
| 16524 | $mysync ={} ; |
| 16525 | $mysync->{cgi} = CGI->new( 'justfoldersizes=on' ) ; |
| 16526 | get_options( $mysync ) ; |
| 16527 | is( 1, $mysync->{ justfoldersizes }, 'get_options cgi context: --justfoldersizes=1 => justfoldersizes => 1' ) ; |
| 16528 | myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; |
| 16529 | |
| 16530 | note( 'Leaving tests_get_options_cgi_context()' ) ; |
| 16531 | return ; |
| 16532 | } |
| 16533 | |
| 16534 | |
| 16535 | |
| 16536 | sub get_options_cgi |
| 16537 | { |
| 16538 | # In CGI context arguments are not in @ARGV but in QUERY_STRING variable (with GET). |
| 16539 | my $mysync = shift @ARG ; |
| 16540 | $mysync->{cgi} || return ; |
| 16541 | my @arguments = @ARG ; |
| 16542 | # final 0 is used to print usage when no option is given |
| 16543 | my $numopt = length $ENV{'QUERY_STRING'} || 1 ; |
| 16544 | $mysync->{f1f2h} = {} ; |
| 16545 | my $opt_ret = myGetOptions( |
| 16546 | $mysync, |
| 16547 | \@arguments, |
| 16548 | 'abort' => \$mysync->{abort}, |
| 16549 | 'host1=s' => \$mysync->{ host1 }, |
| 16550 | 'host2=s' => \$mysync->{ host2 }, |
| 16551 | 'user1=s' => \$mysync->{ user1 }, |
| 16552 | 'user2=s' => \$mysync->{ user2 }, |
| 16553 | 'password1=s' => \$mysync->{password1}, |
| 16554 | 'password2=s' => \$mysync->{password2}, |
| 16555 | 'dry!' => \$mysync->{dry}, |
| 16556 | 'version' => \$mysync->{version}, |
| 16557 | 'ssl1!' => \$mysync->{ssl1}, |
| 16558 | 'ssl2!' => \$mysync->{ssl2}, |
| 16559 | 'tls1!' => \$mysync->{tls1}, |
| 16560 | 'tls2!' => \$mysync->{tls2}, |
| 16561 | 'justlogin!' => \$mysync->{justlogin}, |
| 16562 | 'justconnect!' => \$mysync->{justconnect}, |
| 16563 | 'addheader!' => \$mysync->{addheader}, |
| 16564 | 'automap!' => \$mysync->{automap}, |
| 16565 | 'justautomap!' => \$mysync->{justautomap}, |
| 16566 | 'gmail1' => \$mysync->{gmail1}, |
| 16567 | 'gmail2' => \$mysync->{gmail2}, |
| 16568 | 'office1' => \$mysync->{office1}, |
| 16569 | 'office2' => \$mysync->{office2}, |
| 16570 | 'exchange1' => \$mysync->{exchange1}, |
| 16571 | 'exchange2' => \$mysync->{exchange2}, |
| 16572 | 'domino1' => \$mysync->{domino1}, |
| 16573 | 'domino2' => \$mysync->{domino2}, |
| 16574 | 'f1f2=s@' => \$mysync->{f1f2}, |
| 16575 | 'f1f2h=s%' => \$mysync->{f1f2h}, |
| 16576 | 'folder=s@' => \$mysync->{ folder }, |
| 16577 | 'blabla=s' => \@blabla, |
| 16578 | 'testslive!' => \$mysync->{testslive}, |
| 16579 | 'testslive6!' => \$mysync->{testslive6}, |
| 16580 | 'releasecheck!' => \$mysync->{releasecheck}, |
| 16581 | 'simulong=i' => \$mysync->{simulong}, |
| 16582 | 'debugsleep=f' => \$mysync->{debugsleep}, |
| 16583 | 'subfolder1=s' => \$mysync->{ subfolder1 }, |
| 16584 | 'subfolder2=s' => \$mysync->{ subfolder2 }, |
| 16585 | 'justfolders!' => \$mysync->{ justfolders }, |
| 16586 | 'justfoldersizes!' => \$mysync->{ justfoldersizes }, |
| 16587 | 'delete1!' => \$mysync->{ delete1 }, |
| 16588 | 'delete2!' => \$mysync->{ delete2 }, |
| 16589 | 'delete2duplicates!' => \$mysync->{ delete2duplicates }, |
| 16590 | 'tail!' => \$mysync->{tail}, |
| 16591 | |
| 16592 | # blabla and f1f2h=s% could be removed but |
| 16593 | # tests_get_options_cgi() should be split before |
| 16594 | # with a sub tests_myGetOptions() |
| 16595 | ) ; |
| 16596 | |
| 16597 | $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ; |
| 16598 | |
| 16599 | if ( ! $opt_ret ) { |
| 16600 | return ; |
| 16601 | } |
| 16602 | return $numopt ; |
| 16603 | } |
| 16604 | |
| 16605 | sub get_options_cmd |
| 16606 | { |
| 16607 | my $mysync = shift @ARG ; |
| 16608 | my @arguments = @ARG ; |
| 16609 | my $mycgi = $mysync->{cgi} ; |
| 16610 | # final 0 is used to print usage when no option is given on command line |
| 16611 | my $numopt = scalar @arguments || 0 ; |
| 16612 | my $argv = join "\x00", @arguments ; |
| 16613 | |
| 16614 | if ( $argv =~ m/-delete\x002/x ) { |
| 16615 | output( $mysync, "May be you mean --delete2 instead of --delete 2\n" ) ; |
| 16616 | return ; |
| 16617 | } |
| 16618 | $mysync->{f1f2h} = {} ; |
| 16619 | my $opt_ret = myGetOptions( |
| 16620 | $mysync, |
| 16621 | \@arguments, |
| 16622 | 'debug!' => \$mysync->{ debug }, |
| 16623 | 'debuglist!' => \$debuglist, |
| 16624 | 'debugcontent!' => \$debugcontent, |
| 16625 | 'debugsleep=f' => \$mysync->{debugsleep}, |
| 16626 | 'debugflags!' => \$debugflags, |
| 16627 | 'debugimap!' => \$debugimap, |
| 16628 | 'debugimap1!' => \$debugimap1, |
| 16629 | 'debugimap2!' => \$debugimap2, |
| 16630 | 'debugdev!' => \$debugdev, |
| 16631 | 'debugmemory!' => \$mysync->{debugmemory}, |
| 16632 | 'debugfolders!' => \$mysync->{debugfolders}, |
| 16633 | 'debugssl=i' => \$mysync->{debugssl}, |
| 16634 | 'debugcgi!' => \$debugcgi, |
| 16635 | 'debugenv!' => \$mysync->{debugenv}, |
| 16636 | 'debugsig!' => \$mysync->{debugsig}, |
| 16637 | 'debuglabels!' => \$mysync->{debuglabels}, |
| 16638 | 'simulong=i' => \$mysync->{simulong}, |
| 16639 | 'abort' => \$mysync->{abort}, |
| 16640 | 'host1=s' => \$mysync->{ host1 }, |
| 16641 | 'host2=s' => \$mysync->{ host2 }, |
| 16642 | 'port1=i' => \$mysync->{port1}, |
| 16643 | 'port2=i' => \$mysync->{port2}, |
| 16644 | 'inet4|ipv4' => \$mysync->{inet4}, |
| 16645 | 'inet6|ipv6' => \$mysync->{inet6}, |
| 16646 | 'user1=s' => \$mysync->{ user1 }, |
| 16647 | 'user2=s' => \$mysync->{ user2 }, |
| 16648 | 'gmail1' => \$mysync->{gmail1}, |
| 16649 | 'gmail2' => \$mysync->{gmail2}, |
| 16650 | 'office1' => \$mysync->{office1}, |
| 16651 | 'office2' => \$mysync->{office2}, |
| 16652 | 'exchange1' => \$mysync->{exchange1}, |
| 16653 | 'exchange2' => \$mysync->{exchange2}, |
| 16654 | 'domino1' => \$mysync->{domino1}, |
| 16655 | 'domino2' => \$mysync->{domino2}, |
| 16656 | 'domain1=s' => \$domain1, |
| 16657 | 'domain2=s' => \$domain2, |
| 16658 | 'password1=s' => \$mysync->{password1}, |
| 16659 | 'password2=s' => \$mysync->{password2}, |
| 16660 | 'passfile1=s' => \$mysync->{ passfile1 }, |
| 16661 | 'passfile2=s' => \$mysync->{ passfile2 }, |
| 16662 | 'authmd5!' => \$authmd5, |
| 16663 | 'authmd51!' => \$authmd51, |
| 16664 | 'authmd52!' => \$authmd52, |
| 16665 | 'sep1=s' => \$mysync->{ sep1 }, |
| 16666 | 'sep2=s' => \$mysync->{ sep2 }, |
| 16667 | 'sanitize!' => \$mysync->{ sanitize }, |
| 16668 | 'folder=s@' => \$mysync->{ folder }, |
| 16669 | 'folderrec=s' => \@folderrec, |
| 16670 | 'include=s' => \@include, |
| 16671 | 'exclude=s' => \@exclude, |
| 16672 | 'noexclude' => \$mysync->{noexclude}, |
| 16673 | 'folderfirst=s' => \@folderfirst, |
| 16674 | 'folderlast=s' => \@folderlast, |
| 16675 | 'prefix1=s' => \$prefix1, |
| 16676 | 'prefix2=s' => \$prefix2, |
| 16677 | 'subfolder1=s' => \$mysync->{ subfolder1 }, |
| 16678 | 'subfolder2=s' => \$mysync->{ subfolder2 }, |
| 16679 | 'fixslash2!' => \$mysync->{ fixslash2 }, |
| 16680 | 'fixInboxINBOX!' => \$fixInboxINBOX, |
| 16681 | 'regextrans2=s@' => \$mysync->{ regextrans2 }, |
| 16682 | 'mixfolders!' => \$mixfolders, |
| 16683 | 'skipemptyfolders!' => \$mysync->{ skipemptyfolders }, |
| 16684 | 'regexmess=s' => \@regexmess, |
| 16685 | 'noregexmess' => \$mysync->{noregexmess}, |
| 16686 | 'skipmess=s' => \@skipmess, |
| 16687 | 'pipemess=s' => \@pipemess, |
| 16688 | 'pipemesscheck!' => \$pipemesscheck, |
| 16689 | 'disarmreadreceipts!' => \$disarmreadreceipts, |
| 16690 | 'regexflag=s' => \@regexflag, |
| 16691 | 'noregexflag' => \$mysync->{noregexflag}, |
| 16692 | 'filterflags!' => \$filterflags, |
| 16693 | 'flagscase!' => \$flagscase, |
| 16694 | 'syncflagsaftercopy!' => \$syncflagsaftercopy, |
| 16695 | 'resyncflags!' => \$mysync->{ resyncflags }, |
| 16696 | 'synclabels!' => \$mysync->{ synclabels }, |
| 16697 | 'resynclabels!' => \$mysync->{ resynclabels }, |
| 16698 | 'delete|delete1!' => \$mysync->{ delete1 }, |
| 16699 | 'delete2!' => \$mysync->{ delete2 }, |
| 16700 | 'delete2duplicates!' => \$mysync->{ delete2duplicates }, |
| 16701 | 'delete2folders!' => \$delete2folders, |
| 16702 | 'delete2foldersonly=s' => \$delete2foldersonly, |
| 16703 | 'delete2foldersbutnot=s' => \$delete2foldersbutnot, |
| 16704 | 'syncinternaldates!' => \$syncinternaldates, |
| 16705 | 'idatefromheader!' => \$idatefromheader, |
| 16706 | 'syncacls!' => \$syncacls, |
| 16707 | 'maxsize=i' => \$mysync->{ maxsize }, |
| 16708 | 'appendlimit=i' => \$mysync->{ appendlimit }, |
| 16709 | 'truncmess=i' => \$mysync->{ truncmess }, |
| 16710 | 'minsize=i' => \$minsize, |
| 16711 | 'maxage=f' => \$maxage, |
| 16712 | 'minage=f' => \$minage, |
| 16713 | 'search=s' => \$search, |
| 16714 | 'search1=s' => \$mysync->{ search1 }, |
| 16715 | 'search2=s' => \$mysync->{ search2 }, |
| 16716 | 'foldersizes!' => \$mysync->{ foldersizes }, |
| 16717 | 'foldersizesatend!' => \$mysync->{ foldersizesatend }, |
| 16718 | 'dry!' => \$mysync->{dry}, |
| 16719 | 'expunge1|expunge!' => \$mysync->{ expunge1 }, |
| 16720 | 'expunge2!' => \$mysync->{ expunge2 }, |
| 16721 | 'uidexpunge2!' => \$mysync->{ uidexpunge2 }, |
| 16722 | 'subscribed' => \$subscribed, |
| 16723 | 'subscribe!' => \$subscribe, |
| 16724 | 'subscribeall|subscribe_all!' => \$subscribeall, |
| 16725 | 'justbanner!' => \$justbanner, |
| 16726 | 'justfolders!'=> \$mysync->{ justfolders }, |
| 16727 | 'justfoldersizes!' => \$mysync->{ justfoldersizes }, |
| 16728 | 'fast!' => \$fast, |
| 16729 | 'version' => \$mysync->{version}, |
| 16730 | 'help' => \$help, |
| 16731 | 'timeout=i' => \$timeout, |
| 16732 | 'timeout1=i' => \$mysync->{h1}->{timeout}, |
| 16733 | 'timeout2=i' => \$mysync->{h2}->{timeout}, |
| 16734 | 'skipheader=s' => \$skipheader, |
| 16735 | 'useheader=s' => \@useheader, |
| 16736 | 'wholeheaderifneeded!' => \$wholeheaderifneeded, |
| 16737 | 'messageidnodomain!' => \$messageidnodomain, |
| 16738 | 'skipsize!' => \$skipsize, |
| 16739 | 'allowsizemismatch!' => \$allowsizemismatch, |
| 16740 | 'fastio1!' => \$fastio1, |
| 16741 | 'fastio2!' => \$fastio2, |
| 16742 | 'sslcheck!' => \$mysync->{sslcheck}, |
| 16743 | 'ssl1!' => \$mysync->{ssl1}, |
| 16744 | 'ssl2!' => \$mysync->{ssl2}, |
| 16745 | 'ssl1_ssl_version=s' => \$mysync->{h1}->{sslargs}->{SSL_version}, |
| 16746 | 'ssl2_ssl_version=s' => \$mysync->{h2}->{sslargs}->{SSL_version}, |
| 16747 | 'sslargs1=s%' => \$mysync->{h1}->{sslargs}, |
| 16748 | 'sslargs2=s%' => \$mysync->{h2}->{sslargs}, |
| 16749 | 'tls1!' => \$mysync->{tls1}, |
| 16750 | 'tls2!' => \$mysync->{tls2}, |
| 16751 | 'uid1!' => \$uid1, |
| 16752 | 'uid2!' => \$uid2, |
| 16753 | 'authmech1=s' => \$authmech1, |
| 16754 | 'authmech2=s' => \$authmech2, |
| 16755 | 'authuser1=s' => \$authuser1, |
| 16756 | 'authuser2=s' => \$authuser2, |
| 16757 | 'proxyauth1' => \$proxyauth1, |
| 16758 | 'proxyauth2' => \$proxyauth2, |
| 16759 | 'split1=i' => \$split1, |
| 16760 | 'split2=i' => \$split2, |
| 16761 | 'buffersize=i' => \$buffersize, |
| 16762 | 'reconnectretry1=i' => \$reconnectretry1, |
| 16763 | 'reconnectretry2=i' => \$reconnectretry2, |
| 16764 | 'tests!' => \$mysync->{ tests }, |
| 16765 | 'testsdebug|tests_debug!' => \$mysync->{ testsdebug }, |
| 16766 | 'testsunit=s@' => \$mysync->{testsunit}, |
| 16767 | 'testslive!' => \$mysync->{testslive}, |
| 16768 | 'testslive6!' => \$mysync->{testslive6}, |
| 16769 | 'justlogin!' => \$mysync->{justlogin}, |
| 16770 | 'justconnect!' => \$mysync->{justconnect}, |
| 16771 | 'tmpdir=s' => \$mysync->{ tmpdir }, |
| 16772 | 'pidfile=s' => \$mysync->{pidfile}, |
| 16773 | 'pidfilelocking!' => \$mysync->{pidfilelocking}, |
| 16774 | 'sigexit=s@' => \$mysync->{ sigexit }, |
| 16775 | 'sigreconnect=s@' => \$mysync->{ sigreconnect }, |
| 16776 | 'sigignore=s@' => \$mysync->{ sigignore }, |
| 16777 | 'releasecheck!' => \$mysync->{releasecheck}, |
| 16778 | 'modulesversion|modules_version!' => \$modulesversion, |
| 16779 | 'usecache!' => \$usecache, |
| 16780 | 'cacheaftercopy!' => \$cacheaftercopy, |
| 16781 | 'debugcache!' => \$debugcache, |
| 16782 | 'useuid!' => \$useuid, |
| 16783 | 'addheader!' => \$mysync->{addheader}, |
| 16784 | 'exitwhenover=i' => \$mysync->{ exitwhenover }, |
| 16785 | 'checkselectable!' => \$mysync->{ checkselectable }, |
| 16786 | 'checkfoldersexist!' => \$mysync->{ checkfoldersexist }, |
| 16787 | 'checkmessageexists!' => \$checkmessageexists, |
| 16788 | 'expungeaftereach!' => \$mysync->{ expungeaftereach }, |
| 16789 | 'abletosearch!' => \$mysync->{abletosearch}, |
| 16790 | 'abletosearch1!' => \$mysync->{abletosearch1}, |
| 16791 | 'abletosearch2!' => \$mysync->{abletosearch2}, |
| 16792 | 'showpasswords!' => \$mysync->{showpasswords}, |
| 16793 | 'maxlinelength=i' => \$maxlinelength, |
| 16794 | 'maxlinelengthcmd=s' => \$maxlinelengthcmd, |
| 16795 | 'minmaxlinelength=i' => \$minmaxlinelength, |
| 16796 | 'debugmaxlinelength!' => \$debugmaxlinelength, |
| 16797 | 'fixcolonbug!' => \$fixcolonbug, |
| 16798 | 'create_folder_old!' => \$create_folder_old, |
| 16799 | 'maxmessagespersecond=f' => \$mysync->{maxmessagespersecond}, |
| 16800 | 'maxbytespersecond=i' => \$mysync->{maxbytespersecond}, |
| 16801 | 'maxbytesafter=i' => \$mysync->{maxbytesafter}, |
| 16802 | 'maxsleep=f' => \$mysync->{maxsleep}, |
| 16803 | 'skipcrossduplicates!' => \$skipcrossduplicates, |
| 16804 | 'debugcrossduplicates!' => \$debugcrossduplicates, |
| 16805 | 'log!' => \$mysync->{log}, |
| 16806 | 'tail!' => \$mysync->{tail}, |
| 16807 | 'logfile=s' => \$mysync->{logfile}, |
| 16808 | 'logdir=s' => \$mysync->{logdir}, |
| 16809 | 'errorsmax=i' => \$mysync->{errorsmax}, |
| 16810 | 'errorsdump!' => \$mysync->{errorsdump}, |
| 16811 | 'fetch_hash_set=s' => \$fetch_hash_set, |
| 16812 | 'automap!' => \$mysync->{automap}, |
| 16813 | 'justautomap!' => \$mysync->{justautomap}, |
| 16814 | 'id!' => \$mysync->{id}, |
| 16815 | 'f1f2=s@' => \$mysync->{f1f2}, |
| 16816 | 'nof1f2' => \$mysync->{nof1f2}, |
| 16817 | 'f1f2h=s%' => \$mysync->{f1f2h}, |
| 16818 | 'justfolderlists!' => \$mysync->{justfolderlists}, |
| 16819 | 'delete1emptyfolders' => \$mysync->{delete1emptyfolders}, |
| 16820 | ) ; |
| 16821 | #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; |
| 16822 | $mysync->{ debug } and output( $mysync, "get options: [$opt_ret][$numopt]\n" ) ; |
| 16823 | my $numopt_after = scalar @arguments ; |
| 16824 | #myprint( "get options: [$opt_ret][$numopt][$numopt_after]\n" ) ; |
| 16825 | if ( $numopt_after ) { |
| 16826 | myprint( |
| 16827 | "Extra arguments found: @arguments\n", |
| 16828 | "It usually means a quoting issue in the command line ", |
| 16829 | "or some misspelling options.\n", |
| 16830 | ) ; |
| 16831 | return ; |
| 16832 | } |
| 16833 | if ( ! $opt_ret ) { |
| 16834 | return ; |
| 16835 | } |
| 16836 | return $numopt ; |
| 16837 | } |
| 16838 | |
| 16839 | |
| 16840 | |
| 16841 | sub tests_get_options |
| 16842 | { |
| 16843 | note( 'Entering tests_get_options()' ) ; |
| 16844 | |
| 16845 | # CAVEAT: still setting global variables, be careful |
| 16846 | # with tests, the context increases! $debug stays on for example. |
| 16847 | # API: |
| 16848 | # * input arguments: two ways, command line or CGI |
| 16849 | # * the program arguments |
| 16850 | # * QUERY_STRING env variable |
| 16851 | # * return |
| 16852 | # * undef if bad things happened like |
| 16853 | # * options not known |
| 16854 | # * --delete 2 input |
| 16855 | # * number of arguments or QUERY_STRING length |
| 16856 | my $mysync = { } ; |
| 16857 | is( undef, get_options( $mysync, qw( --noexist ) ), 'get_options: --noexist => undef' ) ; |
| 16858 | is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ; |
| 16859 | $mysync = { } ; |
| 16860 | is( undef, get_options( $mysync, qw( --lalala --noexist --version ) ), 'get_options: --lalala --noexist --version => undef' ) ; |
| 16861 | is( 1, $mysync->{ version }, 'get_options: --version => 1' ) ; |
| 16862 | is( undef, $mysync->{ noexist }, 'get_options: --noexist => undef' ) ; |
| 16863 | $mysync = { } ; |
| 16864 | is( 1, get_options( $mysync, qw( --delete2 ) ), 'get_options: --delete2 => 1' ) ; |
| 16865 | is( 1, $mysync->{ delete2 }, 'get_options: --delete2 => var delete2 = 1' ) ; |
| 16866 | $mysync = { } ; |
| 16867 | is( undef, get_options( $mysync, qw( --delete 2 ) ), 'get_options: --delete 2 => var undef' ) ; |
| 16868 | is( undef, $mysync->{ delete1 }, 'get_options: --delete 2 => var still undef ; good!' ) ; |
| 16869 | $mysync = { } ; |
| 16870 | is( undef, get_options( $mysync, "--delete 2" ), 'get_options: --delete 2 => undef' ) ; |
| 16871 | |
| 16872 | is( 1, get_options( $mysync, "--version" ), 'get_options: --version => 1' ) ; |
| 16873 | is( 1, get_options( $mysync, "--help" ), 'get_options: --help => 1' ) ; |
| 16874 | |
| 16875 | is( undef, get_options( $mysync, qw( --noexist --version ) ), 'get_options: --debug --noexist --version => undef' ) ; |
| 16876 | is( 1, get_options( $mysync, qw( --version ) ), 'get_options: --version => 1' ) ; |
| 16877 | is( undef, get_options( $mysync, qw( extra ) ), 'get_options: extra => undef' ) ; |
| 16878 | is( undef, get_options( $mysync, qw( extra1 --version extra2 ) ), 'get_options: extra1 --version extra2 => undef' ) ; |
| 16879 | |
| 16880 | $mysync = { } ; |
| 16881 | is( 2, get_options( $mysync, qw( --host1 HOST_01) ), 'get_options: --host1 HOST_01 => 1' ) ; |
| 16882 | is( 'HOST_01', $mysync->{ host1 }, 'get_options: --host1 HOST_01 => HOST_01' ) ; |
| 16883 | #myprint( Data::Dumper->Dump( [ $mysync ] ) ) ; |
| 16884 | |
| 16885 | note( 'Leaving tests_get_options()' ) ; |
| 16886 | return ; |
| 16887 | } |
| 16888 | |
| 16889 | |
| 16890 | |
| 16891 | sub get_options |
| 16892 | { |
| 16893 | my $mysync = shift @ARG ; |
| 16894 | my @arguments = @ARG ; |
| 16895 | #myprint( "1 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ; |
| 16896 | my $ret ; |
| 16897 | if ( under_cgi_context( ) ) { |
| 16898 | # CGI context |
| 16899 | $ret = get_options_cgi( $mysync, @arguments ) ; |
| 16900 | }else{ |
| 16901 | # Command line context ; |
| 16902 | $ret = get_options_cmd( $mysync, @arguments ) ; |
| 16903 | } ; |
| 16904 | #myprint( "2 mysync: ", Data::Dumper->Dump( [ $mysync ] ) ) ; |
| 16905 | foreach my $key ( sort keys %{ $mysync } ) { |
| 16906 | if ( ! defined $mysync->{$key} ) { |
| 16907 | delete $mysync->{$key} ; |
| 16908 | next ; |
| 16909 | } |
| 16910 | if ( 'ARRAY' eq ref( $mysync->{$key} ) |
| 16911 | and 0 == scalar( @{ $mysync->{$key} } ) ) { |
| 16912 | delete $mysync->{$key} ; |
| 16913 | } |
| 16914 | } |
| 16915 | return $ret ; |
| 16916 | } |
| 16917 | |
| 16918 | sub testunitsession |
| 16919 | { |
| 16920 | my $mysync = shift ; |
| 16921 | |
| 16922 | if ( ! $mysync ) { return ; } |
| 16923 | if ( ! $mysync->{ testsunit } ) { return ; } |
| 16924 | |
| 16925 | my @functions = @{ $mysync->{ testsunit } } ; |
| 16926 | |
| 16927 | if ( ! @functions ) { return ; } |
| 16928 | |
| 16929 | SKIP: { |
| 16930 | if ( ! @functions ) { skip 'No test in normal run' ; } |
| 16931 | testsunit( @functions ) ; |
| 16932 | done_testing( ) ; |
| 16933 | } |
| 16934 | return ; |
| 16935 | } |
| 16936 | |
| 16937 | sub tests_count_0s |
| 16938 | { |
| 16939 | note( 'Entering tests_count_zeros()' ) ; |
| 16940 | is( 0, count_0s( ), 'count_0s: no parameters => 0' ) ; |
| 16941 | is( 1, count_0s( 0 ), 'count_0s: 0 => 1' ) ; |
| 16942 | is( 0, count_0s( 1 ), 'count_0s: 1 => 0' ) ; |
| 16943 | is( 1, count_0s( 1, 0, 1 ), 'count_0s: 1, 0, 1 => 1' ) ; |
| 16944 | is( 2, count_0s( 1, 0, 1, 0 ), 'count_0s: 1, 0, 1, 0 => 2' ) ; |
| 16945 | note( 'Leaving tests_count_zeros()' ) ; |
| 16946 | return ; |
| 16947 | } |
| 16948 | sub count_0s |
| 16949 | { |
| 16950 | my @array = @ARG ; |
| 16951 | |
| 16952 | if ( ! @array ) { return 0 ; } |
| 16953 | my $nb_zeros = 0 ; |
| 16954 | map { $_ == 0 and $nb_zeros += 1 } @array ; |
| 16955 | return $nb_zeros ; |
| 16956 | } |
| 16957 | |
| 16958 | sub tests_report_failures |
| 16959 | { |
| 16960 | note( 'Entering tests_report_failures()' ) ; |
| 16961 | |
| 16962 | is( undef, report_failures( ), 'report_failures: no parameters => undef' ) ; |
| 16963 | is( "nb 1 - first\n", report_failures( ({'ok' => 0, name => 'first'}) ), 'report_failures: "first" failed => nb 1 - first' ) ; |
| 16964 | is( q{}, report_failures( ( {'ok' => 1, name => 'first'} ) ), 'report_failures: "first" success =>' ) ; |
| 16965 | is( "nb 2 - second\n", report_failures( ( {'ok' => 1, name => 'second'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: "second" failed => nb 2 - second' ) ; |
| 16966 | is( "nb 1 - first\nnb 2 - second\n", report_failures( ( {'ok' => 0, name => 'first'}, {'ok' => 0, name => 'second'} ) ), 'report_failures: both failed => nb 1 - first nb 2 - second' ) ; |
| 16967 | note( 'Leaving tests_report_failures()' ) ; |
| 16968 | return ; |
| 16969 | } |
| 16970 | |
| 16971 | sub report_failures |
| 16972 | { |
| 16973 | my @details = @ARG ; |
| 16974 | |
| 16975 | if ( ! @details ) { return ; } |
| 16976 | |
| 16977 | my $counter = 1 ; |
| 16978 | my $report = q{} ; |
| 16979 | foreach my $details ( @details ) { |
| 16980 | if ( ! $details->{ 'ok' } ) { |
| 16981 | my $name = $details->{ 'name' } || 'NONAME' ; |
| 16982 | $report .= "nb $counter - $name\n" ; |
| 16983 | } |
| 16984 | $counter += 1 ; |
| 16985 | } |
| 16986 | return $report ; |
| 16987 | |
| 16988 | } |
| 16989 | |
| 16990 | sub tests_true |
| 16991 | { |
| 16992 | note( 'Entering tests_true()' ) ; |
| 16993 | |
| 16994 | is( 1, 1, 'true: 1 is 1' ) ; |
| 16995 | note( 'Leaving tests_true()' ) ; |
| 16996 | return ; |
| 16997 | } |
| 16998 | |
| 16999 | sub tests_testsunit |
| 17000 | { |
| 17001 | note( 'Entering tests_testunit()' ) ; |
| 17002 | |
| 17003 | is( undef, testsunit( ), 'testsunit: no parameters => undef' ) ; |
| 17004 | is( undef, testsunit( undef ), 'testsunit: an undef parameter => undef' ) ; |
| 17005 | is( undef, testsunit( q{} ), 'testsunit: an empty parameter => undef' ) ; |
| 17006 | is( undef, testsunit( 'idonotexist' ), 'testsunit: a do not exist function as parameter => undef' ) ; |
| 17007 | is( undef, testsunit( 'tests_true' ), 'testsunit: tests_true => undef' ) ; |
| 17008 | note( 'Leaving tests_testunit()' ) ; |
| 17009 | return ; |
| 17010 | } |
| 17011 | |
| 17012 | sub testsunit |
| 17013 | { |
| 17014 | my @functions = @ARG ; |
| 17015 | |
| 17016 | if ( ! @functions ) { # |
| 17017 | myprint( "testsunit warning: no argument given\n" ) ; |
| 17018 | return ; |
| 17019 | } |
| 17020 | |
| 17021 | foreach my $function ( @functions ) { |
| 17022 | if ( ! $function ) { |
| 17023 | myprint( "testsunit warning: argument is empty\n" ) ; |
| 17024 | next ; |
| 17025 | } |
| 17026 | if ( ! exists &$function ) { |
| 17027 | myprint( "testsunit warning: function $function does not exist\n" ) ; |
| 17028 | next ; |
| 17029 | } |
| 17030 | if ( ! defined &$function ) { |
| 17031 | myprint( "testsunit warning: function $function is not defined\n" ) ; |
| 17032 | next ; |
| 17033 | } |
| 17034 | my $function_ref = \&{ $function } ; |
| 17035 | &$function_ref() ; |
| 17036 | } |
| 17037 | return ; |
| 17038 | } |
| 17039 | |
| 17040 | sub testsdebug |
| 17041 | { |
| 17042 | # Now a little obsolete since there is |
| 17043 | # imapsync ... --testsunit "anyfunction" |
| 17044 | my $mysync = shift ; |
| 17045 | if ( ! $mysync->{ testsdebug } ) { return ; } |
| 17046 | SKIP: { |
| 17047 | if ( ! $mysync->{ testsdebug } ) { |
| 17048 | skip 'No test in normal run' ; |
| 17049 | } |
| 17050 | |
| 17051 | note( 'Entering testsdebug()' ) ; |
| 17052 | #ok( ( ( not -d 'W/tmp/tests' ) or rmtree( 'W/tmp/tests/' ) ), 'testsdebug: rmtree W/tmp/tests' ) ; |
| 17053 | #tests_check_binary_embed_all_dyn_libs( ) ; |
| 17054 | #tests_killpid_by_parent( ) ; |
| 17055 | #tests_killpid_by_brother( ) ; |
| 17056 | #tests_kill_zero( ) ; |
| 17057 | #tests_connect_socket( ) ; |
| 17058 | tests_probe_imapssl( ) ; |
| 17059 | #tests_always_fail( ) ; |
| 17060 | |
| 17061 | note( 'Leaving testsdebug()' ) ; |
| 17062 | done_testing( ) ; |
| 17063 | } |
| 17064 | return ; |
| 17065 | } |
| 17066 | |
| 17067 | |
| 17068 | sub tests |
| 17069 | { |
| 17070 | my $mysync = shift ; |
| 17071 | if ( ! $mysync->{ tests } ) { return ; } |
| 17072 | |
| 17073 | SKIP: { |
| 17074 | skip 'No test in normal run' if ( ! $mysync->{ tests } ) ; |
| 17075 | note( 'Entering tests()' ) ; |
| 17076 | tests_folder_routines( ) ; |
| 17077 | tests_compare_lists( ) ; |
| 17078 | tests_regexmess( ) ; |
| 17079 | tests_skipmess( ) ; |
| 17080 | tests_flags_regex(); |
| 17081 | tests_ucsecond( ) ; |
| 17082 | tests_permanentflags(); |
| 17083 | tests_flags_filter( ) ; |
| 17084 | tests_separator_invert( ) ; |
| 17085 | tests_imap2_folder_name( ) ; |
| 17086 | tests_command_line_nopassword( ) ; |
| 17087 | tests_good_date( ) ; |
| 17088 | tests_max( ) ; |
| 17089 | tests_remove_not_num(); |
| 17090 | tests_memory_consumption( ) ; |
| 17091 | tests_is_a_release_number(); |
| 17092 | tests_imapsync_basename(); |
| 17093 | tests_list_keys_in_2_not_in_1(); |
| 17094 | tests_convert_sep_to_slash( ) ; |
| 17095 | tests_match_a_cache_file( ) ; |
| 17096 | tests_cache_map( ) ; |
| 17097 | tests_get_cache( ) ; |
| 17098 | tests_clean_cache( ) ; |
| 17099 | tests_clean_cache_2( ) ; |
| 17100 | tests_touch( ) ; |
| 17101 | tests_flagscase( ) ; |
| 17102 | tests_mkpath( ) ; |
| 17103 | tests_extract_header( ) ; |
| 17104 | tests_decompose_header( ) ; |
| 17105 | tests_epoch( ) ; |
| 17106 | tests_add_header( ) ; |
| 17107 | tests_cache_dir_fix( ) ; |
| 17108 | tests_cache_dir_fix_win( ) ; |
| 17109 | tests_filter_forbidden_characters( ) ; |
| 17110 | tests_cache_folder( ) ; |
| 17111 | tests_time_remaining( ) ; |
| 17112 | tests_decompose_regex( ) ; |
| 17113 | tests_backtick( ) ; |
| 17114 | tests_bytes_display_string( ) ; |
| 17115 | tests_header_line_normalize( ) ; |
| 17116 | tests_fix_Inbox_INBOX_mapping( ) ; |
| 17117 | tests_max_line_length( ) ; |
| 17118 | tests_subject( ) ; |
| 17119 | tests_msgs_from_maxmin( ) ; |
| 17120 | tests_tmpdir_has_colon_bug( ) ; |
| 17121 | tests_sleep_max_messages( ) ; |
| 17122 | tests_sleep_max_bytes( ) ; |
| 17123 | tests_logfile( ) ; |
| 17124 | tests_setlogfile( ) ; |
| 17125 | tests_jux_utf8_old( ) ; |
| 17126 | tests_jux_utf8( ) ; |
| 17127 | tests_pipemess( ) ; |
| 17128 | tests_jux_utf8_list( ) ; |
| 17129 | tests_guess_prefix( ) ; |
| 17130 | tests_guess_separator( ) ; |
| 17131 | tests_format_for_imap_arg( ) ; |
| 17132 | tests_imapsync_id( ) ; |
| 17133 | tests_date_from_rcs( ) ; |
| 17134 | tests_quota_extract_storage_limit_in_bytes( ) ; |
| 17135 | tests_quota_extract_storage_current_in_bytes( ) ; |
| 17136 | tests_guess_special( ) ; |
| 17137 | tests_do_valid_directory( ) ; |
| 17138 | tests_delete1emptyfolders( ) ; |
| 17139 | tests_message_for_host2( ) ; |
| 17140 | tests_length_ref( ) ; |
| 17141 | tests_firstline( ) ; |
| 17142 | tests_diff_or_NA( ) ; |
| 17143 | tests_match_number( ) ; |
| 17144 | tests_all_defined( ) ; |
| 17145 | tests_special_from_folders_hash( ) ; |
| 17146 | tests_notmatch( ) ; |
| 17147 | tests_match( ) ; |
| 17148 | tests_get_options( ) ; |
| 17149 | tests_get_options_cgi_context( ) ; |
| 17150 | tests_rand32( ) ; |
| 17151 | tests_hashsynclocal( ) ; |
| 17152 | tests_hashsync( ) ; |
| 17153 | tests_output( ) ; |
| 17154 | tests_output_reset_with( ) ; |
| 17155 | tests_output_start( ) ; |
| 17156 | tests_check_last_release( ) ; |
| 17157 | tests_loadavg( ) ; |
| 17158 | tests_cpu_number( ) ; |
| 17159 | tests_load_and_delay( ) ; |
| 17160 | #tests_imapsping( ) ; |
| 17161 | #tests_tcpping( ) ; |
| 17162 | tests_sslcheck( ) ; |
| 17163 | tests_not_long_imapsync_version_public( ) ; |
| 17164 | tests_reconnect_if_needed( ) ; |
| 17165 | tests_reconnect_12_if_needed( ) ; |
| 17166 | tests_sleep_if_needed( ) ; |
| 17167 | tests_string_to_file( ) ; |
| 17168 | tests_file_to_string( ) ; |
| 17169 | tests_under_cgi_context( ) ; |
| 17170 | tests_umask( ) ; |
| 17171 | tests_umask_str( ) ; |
| 17172 | tests_set_umask( ) ; |
| 17173 | tests_createhashfileifneeded( ) ; |
| 17174 | tests_slash_to_underscore( ) ; |
| 17175 | tests_testsunit( ) ; |
| 17176 | tests_count_0s( ) ; |
| 17177 | tests_report_failures( ) ; |
| 17178 | tests_min( ) ; |
| 17179 | #tests_connect_socket( ) ; |
| 17180 | #tests_resolvrev( ) ; |
| 17181 | tests_usage( ) ; |
| 17182 | tests_version_from_rcs( ) ; |
| 17183 | tests_backslash_caret( ) ; |
| 17184 | #tests_mailimapclient_connect_bug( ) ; # it fails with Mail-IMAPClient <= 3.39 |
| 17185 | tests_write_pidfile( ) ; |
| 17186 | tests_remove_pidfile_not_running( ) ; |
| 17187 | tests_match_a_pid_number( ) ; |
| 17188 | tests_prefix_seperator_invertion( ) ; |
| 17189 | tests_is_an_integer( ) ; |
| 17190 | tests_integer_or_1( ) ; |
| 17191 | tests_is_number( ) ; |
| 17192 | tests_sig_install( ) ; |
| 17193 | tests_template( ) ; |
| 17194 | tests_split_around_equal( ) ; |
| 17195 | tests_toggle_sleep( ) ; |
| 17196 | tests_labels( ) ; |
| 17197 | tests_synclabels( ) ; |
| 17198 | tests_uidexpunge_or_expunge( ) ; |
| 17199 | tests_appendlimit_from_capability( ) ; |
| 17200 | tests_maxsize_setting( ) ; |
| 17201 | tests_mock_capability( ) ; |
| 17202 | tests_appendlimit( ) ; |
| 17203 | tests_capability_of( ) ; |
| 17204 | tests_search_in_array( ) ; |
| 17205 | tests_operators_and_exclam_precedence( ) ; |
| 17206 | tests_teelaunch( ) ; |
| 17207 | tests_logfileprepa( ) ; |
| 17208 | tests_useheader_suggestion( ) ; |
| 17209 | tests_nb_messages_in_2_not_in_1( ) ; |
| 17210 | tests_labels_add_subfolder2( ) ; |
| 17211 | tests_labels_remove_subfolder1( ) ; |
| 17212 | tests_resynclabels( ) ; |
| 17213 | tests_labels_remove_special( ) ; |
| 17214 | tests_uniq( ) ; |
| 17215 | tests_remove_from_requested_folders( ) ; |
| 17216 | tests_errors_log( ) ; |
| 17217 | tests_add_subfolder1_to_folderrec( ) ; |
| 17218 | tests_sanitize_subfolder( ) ; |
| 17219 | tests_remove_edging_blanks( ) ; |
| 17220 | tests_sanitize( ) ; |
| 17221 | tests_remove_last_char_if_is( ) ; |
| 17222 | tests_check_binary_embed_all_dyn_libs( ) ; |
| 17223 | tests_nthline( ) ; |
| 17224 | tests_secondline( ) ; |
| 17225 | tests_tail( ) ; |
| 17226 | tests_truncmess( ) ; |
| 17227 | tests_eta( ) ; |
| 17228 | tests_timesince( ) ; |
| 17229 | tests_timenext( ) ; |
| 17230 | tests_foldersize( ) ; |
| 17231 | tests_imapsync_context( ) ; |
| 17232 | tests_abort( ) ; |
| 17233 | tests_probe_imapssl( ) ; |
| 17234 | tests_mailimapclient_connect( ) ; |
| 17235 | #tests_resolv( ) ; |
| 17236 | |
| 17237 | # Those three are for later use, when webserver will be inside imapsync |
| 17238 | # or will be deleted them if I abandon the project. |
| 17239 | #tests_killpid_by_parent( ) ; |
| 17240 | #tests_killpid_by_brother( ) ; |
| 17241 | #tests_kill_zero( ) ; |
| 17242 | |
| 17243 | #tests_always_fail( ) ; |
| 17244 | done_testing( 1496 ) ; |
| 17245 | note( 'Leaving tests()' ) ; |
| 17246 | } |
| 17247 | return ; |
| 17248 | } |
| 17249 | |
| 17250 | sub tests_template |
| 17251 | { |
| 17252 | note( 'Entering tests_template()' ) ; |
| 17253 | |
| 17254 | is( undef, undef, 'template: no args => undef' ) ; |
| 17255 | is_deeply( {}, {}, 'template: a hash is a hash' ) ; |
| 17256 | is_deeply( [], [], 'template: an array is an array' ) ; |
| 17257 | note( 'Leaving tests_template()' ) ; |
| 17258 | return ; |
| 17259 | } |
| 17260 | |
| 17261 | |