├── IMAP_Tools_User_Guide.pdf ├── IMAPtoMbox.pl ├── MboxtoIMAP.pl ├── README.md ├── delIMAPdups.pl ├── delete_imap_mailboxes.pl ├── dumptoIMAP.pl ├── flag_de.gif ├── flag_en.gif ├── imapCapability.pl ├── imapPing.pl ├── imap_audit.pl ├── imap_search.pl ├── imap_to_maildir.pl ├── imapcopy.cf ├── imapcopy.cgi ├── imapcopy.cgi.debug ├── imapcopy.html ├── imapcopy.log.debug ├── imapcopy.pl ├── imapcopy.tar ├── imapcopy.wildcard.html ├── imapcopy_de.html ├── imapcopy_en.html ├── imapcopy_notify.admin ├── imapcopy_send.pl ├── imapdump.pl ├── imapfilter.pl ├── imapsync.pl ├── index.html ├── license.txt ├── list_account_sizes.pl ├── list_imap_folders.pl ├── maildir_to_imap.pl ├── mbxIMAPsync.pl ├── migrateIMAP.pl ├── pop3toimap.pl ├── purgeMbx.pl ├── release_notes_1.291.txt ├── release_notes_1.298.txt ├── release_notes_1.300.txt ├── release_notes_1.303.txt ├── release_notes_1.309.txt ├── release_notes_1.313.txt ├── release_notes_1.326.txt ├── release_notes_1.335.txt ├── release_notes_1.347.txt ├── test_admin_login ├── test_oauth2_login.pl ├── thunderbird_to_imap.pl └── trash.pl /IMAP_Tools_User_Guide.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrewnimmo/rick-sanders-imap-tools/20b0f5071f8d70e252bbc055001386d939cca61f/IMAP_Tools_User_Guide.pdf -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # rick-sanders-imap-tools 2 | https://web.archive.org/web/20170302015826/http://www.athensfbc.com/imap-tools/ 3 | -------------------------------------------------------------------------------- /flag_de.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrewnimmo/rick-sanders-imap-tools/20b0f5071f8d70e252bbc055001386d939cca61f/flag_de.gif -------------------------------------------------------------------------------- /flag_en.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrewnimmo/rick-sanders-imap-tools/20b0f5071f8d70e252bbc055001386d939cca61f/flag_en.gif -------------------------------------------------------------------------------- /imapCapability.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # $Header: /mhub4/sources/imap-tools/imapCapability.pl,v 1.10 2015/12/05 14:44:58 rick Exp $ 4 | 5 | ########################################################################### 6 | # Program name imapCapability.pl # 7 | # Written by Rick Sanders # 8 | # Date 23 December 2007 # 9 | # # 10 | # Description # 11 | # # 12 | # imapCapability.pl is a simple program for querying an IMAP # 13 | # server for a list of the IMAP features it supports. # 14 | # # 15 | # Description # 16 | # # 17 | # imapCapability is used to discover what services an IMAP # 18 | # server supports. # 19 | # # 20 | # Usage: imapCapability.pl -h -u -p # 21 | # Optional arguments: -d (debug) -m (list folders) # 22 | # # 23 | # Sample output: # 24 | # The server supports the following IMAP capabilities: # 25 | # # 26 | # IMAP4 IMAP4REV1 ACL NAMESPACE UIDPLUS IDLE LITERAL+ QUOTA # 27 | # ID MULTIAPPEND LISTEXT CHILDREN BINARY LOGIN-REFERRALS # 28 | # UNSELECT STARTTLS AUTH=LOGIN AUTH=PLAIN AUTH=CRAM-MD5 # 29 | # AUTH=DIGEST-MD5 AUTH=GSSAPI AUTH=MSN AUTH=NTLM # 30 | ########################################################################### 31 | 32 | ############################################################################ 33 | # Copyright (c) 2012 Rick Sanders # 34 | # # 35 | # Permission to use, copy, modify, and distribute this software for any # 36 | # purpose with or without fee is hereby granted, provided that the above # 37 | # copyright notice and this permission notice appear in all copies. # 38 | # # 39 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES # 40 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF # 41 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR # 42 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES # 43 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN # 44 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF # 45 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. # 46 | ############################################################################ 47 | 48 | use Socket; 49 | use FileHandle; 50 | use Fcntl; 51 | use Getopt::Std; 52 | use IO::Socket; 53 | eval 'use Encode qw/encode decode/'; 54 | eval 'use Encode::IMAPUTF7 qw/encode decode/'; 55 | use MIME::Base64 qw(encode_base64 decode_base64); 56 | 57 | ################################################################# 58 | # Main program. # 59 | ################################################################# 60 | 61 | ($host,$user,$pwd) = getArgs(); 62 | 63 | unless ( $host and $user and $pwd ) { 64 | print "Host:Port > "; 65 | chomp($host = <>); 66 | print "Username > "; 67 | chomp($user = <>); 68 | print "Password > "; 69 | chomp($pwd = <>); 70 | } 71 | 72 | unless ( $host and $user and $pwd ) { 73 | print "Please supply host, username, and password\n"; 74 | exit; 75 | } 76 | 77 | init(); 78 | 79 | connectToHost($host, \$conn) or exit; 80 | login($user,$pwd, $conn) or exit; 81 | capability( $conn ); 82 | 83 | if ( $list_mbxs ) { 84 | print STDOUT "\nList of mailboxes for $user:\n\n"; 85 | @mbxs = listMailboxes( $conn ); 86 | 87 | foreach $mbx ( @mbxs ) { 88 | $mbx1 = decode( 'IMAP-UTF-7', $mbx ); 89 | if ( $mbx eq $mbx1 ) { 90 | print STDOUT " $mbx\n"; 91 | } elsif( $utf7_installed ) { 92 | print STDOUT " $mbx ($mbx1)\n"; 93 | } else { 94 | print STDOUT " $mbx\n"; 95 | } 96 | } 97 | } 98 | logout( $conn ); 99 | 100 | sub init { 101 | 102 | # Determine whether we have SSL support via openSSL and IO::Socket::SSL 103 | $ssl_installed = 1; 104 | eval 'use IO::Socket::SSL'; 105 | if ( $@ ) { 106 | $ssl_installed = 0; 107 | } 108 | 109 | $utf7_installed = 1; 110 | eval 'use Encode::IMAPUTF7 qw/decode/'; 111 | if ( $@ ) { 112 | $utf7_installed = 0; 113 | } 114 | } 115 | 116 | sub getArgs { 117 | 118 | getopts( "h:u:p:dmA:I" ); 119 | $host = $opt_h; 120 | $user = $opt_u; 121 | $pwd = $opt_p; 122 | $debug = $opt_d; 123 | $admin_user = $opt_A; 124 | $list_mbxs = 1 if $opt_m; 125 | $showIMAP = 1 if $opt_I; 126 | 127 | if ( $admin_user ) { 128 | # Don't need user password 129 | $pwd = 'XXXX'; 130 | } 131 | 132 | if ( $opt_H ) { 133 | usage(); 134 | } 135 | 136 | if ( $host =~ /CRAM-MD5/i ) { 137 | $method = 'CRAM-MD5'; 138 | $host =~ s/\/CRAM-MD5//i; 139 | } 140 | 141 | if ( !$host or !$user or !$pwd ) { 142 | usage(); 143 | } 144 | 145 | return ($host,$user,$pwd); 146 | 147 | } 148 | 149 | sub usage { 150 | 151 | print STDOUT "usage: imapCapability.pl -h -u -p \n"; 152 | print STDOUT " Option argument: -m (list mailboxes)\n"; 153 | print STDOUT "To use CRAM-MD5 for logins add /CRAM-MD5 like this: -i server/user/password/CRAM-MD5\n"; 154 | exit; 155 | 156 | } 157 | 158 | 159 | sub connectToHost { 160 | 161 | my $host = shift; 162 | my $conn = shift; 163 | 164 | ($host,$port) = split(/:/, $host); 165 | $port = 143 unless $port; 166 | 167 | # We know whether to use SSL for ports 143 and 993. For any 168 | # other ones we'll have to figure it out. 169 | $mode = sslmode( $host, $port ); 170 | 171 | if ( $mode eq 'SSL' ) { 172 | unless( $ssl_installed == 1 ) { 173 | warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 174 | exit; 175 | } 176 | print "Attempting an SSL connection\n" if $debug; 177 | $$conn = IO::Socket::SSL->new( 178 | Proto => "tcp", 179 | SSL_verify_mode => 0x00, 180 | PeerAddr => $host, 181 | PeerPort => $port, 182 | Domain => AF_INET, 183 | ); 184 | 185 | unless ( $$conn ) { 186 | $error = IO::Socket::SSL::errstr(); 187 | print "Error connecting to $host: $error\n"; 188 | exit; 189 | } 190 | } else { 191 | # Non-SSL connection 192 | print "Attempting a non-SSL connection\n" if $debug; 193 | $$conn = IO::Socket::INET->new( 194 | Proto => "tcp", 195 | PeerAddr => $host, 196 | PeerPort => $port, 197 | ); 198 | 199 | unless ( $$conn ) { 200 | print "Error connecting to $host:$port: $@\n"; 201 | warn "Error connecting to $host:$port: $@"; 202 | exit; 203 | } 204 | } 205 | print "Connected to $host on port $port\n"; 206 | 207 | } 208 | 209 | sub sslmode { 210 | 211 | my $host = shift; 212 | my $port = shift; 213 | my $mode; 214 | 215 | # Determine whether to make an SSL connection 216 | # to the host. Return 'SSL' if so. 217 | 218 | if ( $port == 143 ) { 219 | # Standard non-SSL port 220 | return ''; 221 | } elsif ( $port == 993 ) { 222 | # Standard SSL port 223 | return 'SSL'; 224 | } 225 | 226 | unless ( $ssl_installed ) { 227 | # We don't have SSL installed on this machine 228 | return ''; 229 | } 230 | 231 | # For any other port we need to determine whether it supports SSL 232 | 233 | my $conn = IO::Socket::SSL->new( 234 | Proto => "tcp", 235 | SSL_verify_mode => 0x00, 236 | PeerAddr => $host, 237 | PeerPort => $port, 238 | ); 239 | 240 | if ( $conn ) { 241 | close( $conn ); 242 | $mode = 'SSL'; 243 | } else { 244 | $mode = ''; 245 | } 246 | 247 | return $mode; 248 | } 249 | 250 | 251 | sub login { 252 | 253 | my $user = shift; 254 | my $pwd = shift; 255 | my $conn = shift; 256 | 257 | if ( uc( $method ) eq 'CRAM-MD5' ) { 258 | # A CRAM-MD5 login is requested 259 | Log("login method $method"); 260 | my $rc = login_cram_md5( $user, $pwd, $conn ); 261 | return $rc; 262 | } 263 | 264 | if ( $admin_user ) { 265 | # An AUTHENTICATE = PLAIN login has been requested 266 | ($authuser,$authpwd) = split(/:/, $admin_user ); 267 | login_plain( $user, $authuser, $authpwd, $conn ) or exit; 268 | return 1; 269 | } 270 | 271 | if ( $pwd =~ /^oauth2:(.+)/i ) { 272 | $token = $1; 273 | Log("password is an OAUTH2 token"); 274 | login_xoauth2( $user, $token, $conn ); 275 | return 1; 276 | } 277 | 278 | sendCommand ($conn, "1 LOGIN $user $pwd"); 279 | while (1) { 280 | readResponse ( $conn ); 281 | last if $response =~ /^1 OK/i; 282 | if ($response =~ /^1 NO|^1 BAD/i) { 283 | print "Unexpected LOGIN response: $response\n"; 284 | return 0; 285 | } 286 | } 287 | print "Logged in as $user\n" if $debug; 288 | 289 | return 1; 290 | } 291 | 292 | # login_plain 293 | # 294 | # login in at the source host with the user's name and password. If provided 295 | # with administrator credential, use them as this eliminates the need for the 296 | # user's password. 297 | # 298 | sub login_plain { 299 | 300 | my $user = shift; 301 | my $admin = shift; 302 | my $pwd = shift; 303 | my $conn = shift; 304 | 305 | # Do an AUTHENTICATE = PLAIN. If an admin user has been provided then use it. 306 | 307 | if ( !$admin ) { 308 | # Log in as the user 309 | $admin = $user 310 | } 311 | 312 | $login_str = sprintf("%s\x00%s\x00%s", $user,$admin,$pwd); 313 | $login_str = encode_base64("$login_str", ""); 314 | $len = length( $login_str ); 315 | 316 | # sendCommand ($conn, "1 AUTHENTICATE \"PLAIN\" {$len}" ); 317 | sendCommand ($conn, "1 AUTHENTICATE PLAIN" ); 318 | 319 | my $loops; 320 | while (1) { 321 | readResponse ( $conn ); 322 | last if $response =~ /\+/; 323 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 324 | Log ("unexpected LOGIN response: $response"); 325 | exit; 326 | } 327 | $last if $loops++ > 5; 328 | } 329 | 330 | sendCommand ($conn, "$login_str" ); 331 | my $loops; 332 | while (1) { 333 | readResponse ( $conn ); 334 | 335 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 336 | # The destination is an Exchange server 337 | $exchange = 1; 338 | Log("The destination is an Exchange server"); 339 | } 340 | 341 | last if $response =~ /^1 OK/i; 342 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 343 | Log ("unexpected LOGIN response: $response"); 344 | exit; 345 | } 346 | $last if $loops++ > 5; 347 | } 348 | 349 | return 1; 350 | 351 | } 352 | 353 | # login_xoauth2 354 | # 355 | # login in at the source host with the user's name and an XOAUTH2 token. 356 | # 357 | sub login_xoauth2 { 358 | 359 | my $user = shift; 360 | my $token = shift; 361 | my $conn = shift; 362 | 363 | # Do an AUTHENTICATE = XOAUTH2 login 364 | 365 | $login_str = encode_base64("user=". $user ."\x01auth=Bearer ". $token ."\x01\x01", ''); 366 | sendCommand ($conn, "1 AUTHENTICATE XOAUTH2 $login_str" ); 367 | 368 | my $loops; 369 | while (1) { 370 | readResponse ( $conn ); 371 | if ( $response =~ /^\+ (.+)/ ) { 372 | $error = decode_base64( $1 ); 373 | Log("XOAUTH authentication as $user failed: $error"); 374 | return 0; 375 | } 376 | last if $response =~ /^1 OK/; 377 | if ($response =~ /^1 NO|^1 BAD|^\* BYE|failed/i) { 378 | Log ("unexpected LOGIN response: $response"); 379 | return 0; 380 | } 381 | $last if $loops++ > 5; 382 | } 383 | 384 | Log("login complete") if $debug; 385 | 386 | return 1; 387 | 388 | } 389 | 390 | sub login_cram_md5 { 391 | 392 | my $user = shift; 393 | my $pwd = shift; 394 | my $conn = shift; 395 | 396 | sendCommand ($conn, "1 AUTHENTICATE CRAM-MD5"); 397 | while (1) { 398 | readResponse ( $conn ); 399 | last if $response =~ /^\+/; 400 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 401 | Log ("unexpected LOGIN response: $response"); 402 | return 0; 403 | } 404 | } 405 | 406 | my ($challenge) = $response =~ /^\+ (.+)/; 407 | 408 | Log("challenge $challenge") if $debug; 409 | $response = cram_md5( $challenge, $user, $pwd ); 410 | Log("response $response") if $debug; 411 | 412 | sendCommand ($conn, $response); 413 | while (1) { 414 | readResponse ( $conn ); 415 | 416 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 417 | # The destination is an Exchange server 418 | $exchange = 1; 419 | Log("The destination is an Exchange server"); 420 | } 421 | 422 | last if $response =~ /^1 OK/i; 423 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 424 | Log ("unexpected LOGIN response: $response"); 425 | return 0; 426 | } 427 | } 428 | Log("Logged in as $user") if $debug; 429 | 430 | return 1; 431 | } 432 | 433 | 434 | 435 | sub cram_md5 { 436 | 437 | my $challenge = shift; 438 | my $user = shift; 439 | my $password = shift; 440 | 441 | eval 'use Digest::HMAC_MD5 qw(hmac_md5_hex)'; 442 | use MIME::Base64 qw(decode_base64 encode_base64); 443 | 444 | # Adapated from script by Paul Makepeace , 2002-10-12 445 | # Takes user, key, and base-64 encoded challenge and returns base-64 446 | # encoded CRAM. See, 447 | # IMAP/POP AUTHorize Extension for Simple Challenge/Response: 448 | # RFC 2195 http://www.faqs.org/rfcs/rfc2195.html 449 | # SMTP Service Extension for Authentication: 450 | # RFC 2554 http://www.faqs.org/rfcs/rfc2554.html 451 | # Args: tim tanstaaftanstaaf PDE4OTYuNjk3MTcwOTUyQHBvc3RvZmZpY2UucmVzdG9uLm1jaS5uZXQ+ 452 | # should yield: dGltIGI5MTNhNjAyYzdlZGE3YTQ5NWI0ZTZlNzMzNGQzODkw 453 | 454 | my $challenge_data = decode_base64($challenge); 455 | my $hmac_digest = hmac_md5_hex($challenge_data, $password); 456 | my $response = encode_base64("$user $hmac_digest"); 457 | chomp $response; 458 | 459 | if ( $debug ) { 460 | Log("Challenge: $challenge_data"); 461 | Log("HMAC digest: $hmac_digest"); 462 | Log("CRAM Base64: $response"); 463 | } 464 | 465 | return $response; 466 | } 467 | 468 | sub capability { 469 | 470 | my $conn = shift; 471 | my @response; 472 | my $capability; 473 | 474 | sendCommand ($conn, "1 CAPABILITY"); 475 | while (1) { 476 | readResponse ( $conn ); 477 | $capability = $response if $response =~ /\* CAPABILITY/i; 478 | last if $response =~ /^1 OK/i; 479 | if ($response =~ /^1 NO|^1 BAD/i) { 480 | print "Unexpected response: $response\n"; 481 | return 0; 482 | } 483 | } 484 | 485 | print STDOUT "\nThe server supports the following IMAP capabilities:\n\n"; 486 | $capability =~ s/^\* CAPABILITY //; 487 | print "$capability\n"; 488 | 489 | } 490 | 491 | sub logout { 492 | 493 | my $conn = shift; 494 | 495 | undef @response; 496 | sendCommand ($conn, "1 LOGOUT"); 497 | while ( 1 ) { 498 | readResponse ($conn); 499 | if ( $response =~ /^1 OK/i ) { 500 | last; 501 | } 502 | elsif ( $response !~ /^\*/ ) { 503 | print "Unexpected LOGOUT response: $response\n"; 504 | last; 505 | } 506 | } 507 | close $conn; 508 | return; 509 | } 510 | 511 | sub sendCommand { 512 | 513 | my $fd = shift; 514 | my $cmd = shift; 515 | 516 | print $fd "$cmd\r\n"; 517 | print STDOUT "$cmd\n" if $showIMAP; 518 | } 519 | 520 | sub readResponse { 521 | 522 | my $fd = shift; 523 | 524 | $response = <$fd>; 525 | chop $response; 526 | $response =~ s/\r//g; 527 | push (@response,$response); 528 | print STDOUT "$response\n" if $showIMAP; 529 | } 530 | 531 | 532 | # listMailboxes 533 | # 534 | # Get a list of the user's mailboxes 535 | # 536 | sub listMailboxes { 537 | 538 | my $conn = shift; 539 | 540 | sendCommand ($conn, "1 LIST \"\" *"); 541 | undef @response; 542 | while ( 1 ) { 543 | &readResponse ($conn); 544 | if ( $response =~ /^1 OK/i ) { 545 | last; 546 | } 547 | elsif ( $response !~ /^\*/ ) { 548 | &Log ("unexpected response: $response"); 549 | return 0; 550 | } 551 | } 552 | 553 | @mbxs = (); 554 | for $i (0 .. $#response) { 555 | $response[$i] =~ s/\s+/ /; 556 | if ( $response[$i] =~ /"$/ ) { 557 | $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i; 558 | $mbx = $3; 559 | } elsif ( $response[$i] =~ /\* LIST \((.*)\) NIL (.+)/i ) { 560 | $mbx = $2; 561 | } else { 562 | $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i; 563 | $mbx = $3; 564 | } 565 | $mbx =~ s/^\s+//; $mbx =~ s/\s+$//; 566 | push ( @mbxs, $mbx ) if $mbx ne ''; 567 | } 568 | 569 | return @mbxs; 570 | } 571 | 572 | sub isAscii { 573 | 574 | my $str = shift; 575 | my $ascii = 1; 576 | 577 | # Determine whether a string contains non-ASCII characters 578 | 579 | my $test = $str; 580 | $test=~s/\P{IsASCII}/?/g; 581 | $ascii = 0 unless $test eq $str; 582 | 583 | return $ascii; 584 | 585 | } 586 | 587 | sub Log { 588 | 589 | my $str = shift; 590 | 591 | print STDERR "$str\n"; 592 | 593 | } 594 | -------------------------------------------------------------------------------- /imapPing.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # $Header: /mhub4/sources/imap-tools/imapPing.pl,v 1.5 2015/12/05 14:57:32 rick Exp $ 4 | 5 | ############################################################################ 6 | # Program imapPing.pl # 7 | # Date 20 January 2008 # 8 | # # 9 | # Description # 10 | # # 11 | # This script performs some basic IMAP operations on a user's # 12 | # account and displays the time as each one is executed. The # 13 | # operations are: # 14 | # 1. Connect to the IMAP server # 15 | # 2. Log in with the user's name and password # 16 | # 3. Get a list of mailboxes in the user's account # 17 | # 4. Select the INBOX # 18 | # 5. Get a list of messages in the INBOX # 19 | # 6. Log off the server # 20 | # # 21 | # Usage: imapPing.pl -h -u -p # 22 | # # 23 | ############################################################################ 24 | # Copyright (c) 2008 Rick Sanders # 25 | # # 26 | # Permission to use, copy, modify, and distribute this software for any # 27 | # purpose with or without fee is hereby granted, provided that the above # 28 | # copyright notice and this permission notice appear in all copies. # 29 | # # 30 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES # 31 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF # 32 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR # 33 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES # 34 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN # 35 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF # 36 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. # 37 | ############################################################################ 38 | 39 | use Getopt::Std; 40 | use Socket; 41 | use FileHandle; 42 | use Fcntl; 43 | use IO::Socket; 44 | use MIME::Base64 qw(encode_base64 decode_base64); 45 | 46 | init(); 47 | ($host,$user,$pwd) = getArgs(); 48 | 49 | print STDOUT pack( "A35 A10", "Connecting to $host", getTime() ); 50 | connectToHost( $host, \$conn ); 51 | 52 | print STDOUT pack( "A35 A10","Logging in as $user", getTime() ); 53 | login( $user,$pwd, $conn ); 54 | 55 | print STDOUT pack( "A35 A10","Get list of mailboxes", getTime() ); 56 | getMailboxList( $conn ); 57 | 58 | print STDOUT pack( "A35 A10","Selecting the INBOX", getTime() ); 59 | selectMbx( 'INBOX', $conn ) if $rc; 60 | 61 | print STDOUT pack( "A35 A10","Get list of msgs in INBOX", getTime() ); 62 | getMsgList( 'INBOX', $conn ); 63 | 64 | print STDOUT pack( "A35 A10","Logging out", getTime() ); 65 | logout( $conn ); 66 | 67 | print STDOUT pack( "A35 A10","Done", getTime() ); 68 | 69 | exit; 70 | 71 | exit 1; 72 | 73 | 74 | sub init { 75 | 76 | # Determine whether we have SSL support via openSSL and IO::Socket::SSL 77 | $ssl_installed = 1; 78 | eval 'use IO::Socket::SSL'; 79 | if ( $@ ) { 80 | $ssl_installed = 0; 81 | } 82 | 83 | getTime(); 84 | $debug = 1; 85 | } 86 | 87 | sub getTime { 88 | 89 | ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime; 90 | if ($year < 99) { $yr = 2000; } 91 | else { $yr = 1900; } 92 | $date = sprintf ("%.2d-%.2d-%d.%.2d:%.2d:%.2d \n", 93 | $mon+1,$mday,$year+$yr,$hour,$min,$sec); 94 | $time = sprintf ("%.2d:%.2d:%.2d \n",$hour,$min,$sec); 95 | 96 | return $time; 97 | } 98 | 99 | sub getArgs { 100 | 101 | getopts( "h:u:p:A:I" ); 102 | $host = $opt_h; 103 | $user = $opt_u; 104 | $pwd = $opt_p; 105 | $admin_user = $opt_A; 106 | $showIMAP = 1 if $opt_I; 107 | print "opt_h $opt_h\n"; 108 | print "opt_p $opt_p\n"; 109 | print "opt_u $opt_u\n"; 110 | 111 | $method = 'CRAM-MD5' if $opt_h =~ /CRAM-MD5/i; 112 | $host =~ s/\/CRAM-MD5//i; 113 | 114 | if ( $opt_H ) { 115 | usage(); 116 | } 117 | 118 | if ( $admin_user ) { 119 | $pwd = 'XXX'; # Don't need the user's password 120 | } 121 | 122 | print "host $host pwd $pwd\n"; 123 | unless ( $host and $user and $pwd ) { 124 | usage(); 125 | exit; 126 | } 127 | 128 | 129 | return ($host,$user,$pwd); 130 | 131 | } 132 | 133 | # sendCommand 134 | # 135 | # This subroutine formats and sends an IMAP protocol command to an 136 | # IMAP server on a specified connection. 137 | # 138 | 139 | sub sendCommand 140 | { 141 | local($fd) = shift @_; 142 | local($cmd) = shift @_; 143 | 144 | print $fd "$cmd\r\n"; 145 | print STDOUT ">> $cmd\n" if $showIMAP; 146 | } 147 | 148 | # 149 | # readResponse 150 | # 151 | # This subroutine reads and formats an IMAP protocol response from an 152 | # IMAP server on a specified connection. 153 | # 154 | 155 | sub readResponse 156 | { 157 | local($fd) = shift @_; 158 | 159 | $response = <$fd>; 160 | chop $response; 161 | $response =~ s/\r//g; 162 | push (@response,$response); 163 | print STDOUT "<< $response\n" if $showIMAP; 164 | } 165 | 166 | # Make a connection to an IMAP host 167 | 168 | sub connectToHost { 169 | 170 | my $host = shift; 171 | my $conn = shift; 172 | 173 | ($host,$port) = split(/:/, $host); 174 | $port = 143 unless $port; 175 | 176 | # We know whether to use SSL for ports 143 and 993. For any 177 | # other ones we'll have to figure it out. 178 | $mode = sslmode( $host, $port ); 179 | 180 | if ( $mode eq 'SSL' ) { 181 | unless( $ssl_installed == 1 ) { 182 | warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 183 | exit; 184 | } 185 | $$conn = IO::Socket::SSL->new( 186 | Proto => "tcp", 187 | SSL_verify_mode => 0x00, 188 | PeerAddr => $host, 189 | PeerPort => $port, 190 | Domain => AF_INET, 191 | ); 192 | 193 | unless ( $$conn ) { 194 | $error = IO::Socket::SSL::errstr(); 195 | warn("Error connecting to $host: $error"); 196 | exit; 197 | } 198 | } else { 199 | # Non-SSL connection 200 | $$conn = IO::Socket::INET->new( 201 | Proto => "tcp", 202 | PeerAddr => $host, 203 | PeerPort => $port, 204 | ); 205 | 206 | unless ( $$conn ) { 207 | warn "Error connecting to $host:$port: $@"; 208 | exit; 209 | } 210 | } 211 | 212 | } 213 | 214 | sub sslmode { 215 | 216 | my $host = shift; 217 | my $port = shift; 218 | my $mode; 219 | 220 | # Determine whether to make an SSL connection 221 | # to the host. Return 'SSL' if so. 222 | 223 | if ( $port == 143 ) { 224 | # Standard non-SSL port 225 | return ''; 226 | } elsif ( $port == 993 ) { 227 | # Standard SSL port 228 | return 'SSL'; 229 | } 230 | 231 | unless ( $ssl_installed ) { 232 | # We don't have SSL installed on this machine 233 | return ''; 234 | } 235 | 236 | # For any other port we need to determine whether it supports SSL 237 | 238 | my $conn = IO::Socket::SSL->new( 239 | Proto => "tcp", 240 | SSL_verify_mode => 0x00, 241 | PeerAddr => $host, 242 | PeerPort => $port, 243 | ); 244 | 245 | if ( $conn ) { 246 | close( $conn ); 247 | $mode = 'SSL'; 248 | } else { 249 | $mode = ''; 250 | } 251 | 252 | return $mode; 253 | } 254 | 255 | 256 | # login 257 | # 258 | # login in at the source host with the user's name and password 259 | # 260 | sub login { 261 | 262 | my $user = shift; 263 | my $pwd = shift; 264 | my $conn = shift; 265 | 266 | if ( uc( $method ) eq 'CRAM-MD5' ) { 267 | # A CRAM-MD5 login is requested 268 | Log("login method $method"); 269 | my $rc = login_cram_md5( $user, $pwd, $conn ); 270 | return $rc; 271 | } 272 | 273 | if ( $admin_user ) { 274 | # An AUTHENTICATE = PLAIN login has been requested 275 | ($authuser,$authpwd) = split(/:/, $admin_user ); 276 | login_plain( $user, $authuser, $authpwd, $conn ) or exit; 277 | return 1; 278 | } 279 | 280 | if ( $pwd =~ /^oauth2:(.+)/i ) { 281 | $token = $1; 282 | Log("password is an OAUTH2 token"); 283 | login_xoauth2( $user, $token, $conn ); 284 | return 1; 285 | } 286 | 287 | sendCommand ($conn, "1 LOGIN $user $pwd"); 288 | while (1) { 289 | readResponse ($conn); 290 | if ($response =~ /^1 OK/i) { 291 | last; 292 | } 293 | elsif ($response !~ /^\*/) { 294 | print STDOUT "Unexpected login response $response\n"; 295 | return 0; 296 | } 297 | } 298 | 299 | return 1; 300 | } 301 | 302 | # login_plain 303 | # 304 | # login in at the source host with the user's name and password. If provided 305 | # with administrator credential, use them as this eliminates the need for the 306 | # user's password. 307 | # 308 | sub login_plain { 309 | 310 | my $user = shift; 311 | my $admin = shift; 312 | my $pwd = shift; 313 | my $conn = shift; 314 | 315 | # Do an AUTHENTICATE = PLAIN. If an admin user has been provided then use it. 316 | 317 | if ( !$admin ) { 318 | # Log in as the user 319 | $admin = $user 320 | } 321 | 322 | $login_str = sprintf("%s\x00%s\x00%s", $user,$admin,$pwd); 323 | $login_str = encode_base64("$login_str", ""); 324 | $len = length( $login_str ); 325 | 326 | # sendCommand ($conn, "1 AUTHENTICATE \"PLAIN\" {$len}" ); 327 | sendCommand ($conn, "1 AUTHENTICATE PLAIN" ); 328 | 329 | my $loops; 330 | while (1) { 331 | readResponse ( $conn ); 332 | last if $response =~ /\+/; 333 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 334 | Log ("unexpected LOGIN response: $response"); 335 | exit; 336 | } 337 | $last if $loops++ > 5; 338 | } 339 | 340 | sendCommand ($conn, "$login_str" ); 341 | my $loops; 342 | while (1) { 343 | readResponse ( $conn ); 344 | 345 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 346 | # The destination is an Exchange server 347 | $exchange = 1; 348 | Log("The destination is an Exchange server"); 349 | } 350 | 351 | last if $response =~ /^1 OK/i; 352 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 353 | Log ("unexpected LOGIN response: $response"); 354 | exit; 355 | } 356 | $last if $loops++ > 5; 357 | } 358 | 359 | return 1; 360 | 361 | } 362 | 363 | # login_xoauth2 364 | # 365 | # login in at the source host with the user's name and an XOAUTH2 token. 366 | # 367 | sub login_xoauth2 { 368 | 369 | my $user = shift; 370 | my $token = shift; 371 | my $conn = shift; 372 | 373 | # Do an AUTHENTICATE = XOAUTH2 login 374 | 375 | $login_str = encode_base64("user=". $user ."\x01auth=Bearer ". $token ."\x01\x01", ''); 376 | sendCommand ($conn, "1 AUTHENTICATE XOAUTH2 $login_str" ); 377 | 378 | my $loops; 379 | while (1) { 380 | readResponse ( $conn ); 381 | if ( $response =~ /^\+ (.+)/ ) { 382 | $error = decode_base64( $1 ); 383 | Log("XOAUTH authentication as $user failed: $error"); 384 | return 0; 385 | } 386 | last if $response =~ /^1 OK/; 387 | if ($response =~ /^1 NO|^1 BAD|^\* BYE|failed/i) { 388 | Log ("unexpected LOGIN response: $response"); 389 | return 0; 390 | } 391 | $last if $loops++ > 5; 392 | } 393 | 394 | Log("login complete") if $debug; 395 | 396 | return 1; 397 | 398 | } 399 | 400 | sub login_cram_md5 { 401 | 402 | my $user = shift; 403 | my $pwd = shift; 404 | my $conn = shift; 405 | 406 | sendCommand ($conn, "1 AUTHENTICATE CRAM-MD5"); 407 | while (1) { 408 | readResponse ( $conn ); 409 | last if $response =~ /^\+/; 410 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 411 | Log ("unexpected LOGIN response: $response"); 412 | return 0; 413 | } 414 | } 415 | 416 | my ($challenge) = $response =~ /^\+ (.+)/; 417 | 418 | Log("challenge $challenge") if $debug; 419 | $response = cram_md5( $challenge, $user, $pwd ); 420 | Log("response $response") if $debug; 421 | 422 | sendCommand ($conn, $response); 423 | while (1) { 424 | readResponse ( $conn ); 425 | 426 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 427 | # The destination is an Exchange server 428 | $exchange = 1; 429 | Log("The destination is an Exchange server"); 430 | } 431 | 432 | last if $response =~ /^1 OK/i; 433 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 434 | Log ("unexpected LOGIN response: $response"); 435 | return 0; 436 | } 437 | } 438 | Log("Logged in as $user") if $debug; 439 | 440 | return 1; 441 | } 442 | 443 | 444 | 445 | sub cram_md5 { 446 | 447 | my $challenge = shift; 448 | my $user = shift; 449 | my $password = shift; 450 | 451 | eval 'use Digest::HMAC_MD5 qw(hmac_md5_hex)'; 452 | use MIME::Base64 qw(decode_base64 encode_base64); 453 | 454 | # Adapated from script by Paul Makepeace , 2002-10-12 455 | # Takes user, key, and base-64 encoded challenge and returns base-64 456 | # encoded CRAM. See, 457 | # IMAP/POP AUTHorize Extension for Simple Challenge/Response: 458 | # RFC 2195 http://www.faqs.org/rfcs/rfc2195.html 459 | # SMTP Service Extension for Authentication: 460 | # RFC 2554 http://www.faqs.org/rfcs/rfc2554.html 461 | # Args: tim tanstaaftanstaaf PDE4OTYuNjk3MTcwOTUyQHBvc3RvZmZpY2UucmVzdG9uLm1jaS5uZXQ+ 462 | # should yield: dGltIGI5MTNhNjAyYzdlZGE3YTQ5NWI0ZTZlNzMzNGQzODkw 463 | 464 | my $challenge_data = decode_base64($challenge); 465 | my $hmac_digest = hmac_md5_hex($challenge_data, $password); 466 | my $response = encode_base64("$user $hmac_digest"); 467 | chomp $response; 468 | 469 | if ( $debug ) { 470 | Log("Challenge: $challenge_data"); 471 | Log("HMAC digest: $hmac_digest"); 472 | Log("CRAM Base64: $response"); 473 | } 474 | 475 | return $response; 476 | } 477 | 478 | 479 | # logout 480 | # 481 | # log out from the source host 482 | # 483 | sub logout { 484 | 485 | my $conn = shift; 486 | 487 | # print STDOUT "Logging out\n" if $debug; 488 | sendCommand ($conn, "1 LOGOUT"); 489 | while ( 1 ) { 490 | readResponse ($conn); 491 | if ( $response =~ /^1 OK/i ) { 492 | last; 493 | } 494 | elsif ( $response !~ /^\*/ ) { 495 | print STDOUT "unexpected LOGOUT response: $response\n"; 496 | last; 497 | } 498 | } 499 | close $conn; 500 | 501 | return; 502 | 503 | } 504 | 505 | 506 | sub usage { 507 | 508 | print STDOUT "\nUsage: imapPing.pl \n\n"; 509 | print STDOUT " -h \n"; 510 | print STDOUT " -u \n"; 511 | print STDOUT " -p \n"; 512 | print STDOUT "To use CRAM-MD5 for logins add /CRAM-MD5 like this: -h hostname/CRAM-MD5\n"; 513 | 514 | exit; 515 | 516 | } 517 | 518 | 519 | sub selectInbox { 520 | 521 | my $mbx = shift; 522 | my $conn = shift; 523 | 524 | # Select a mailbox 525 | 526 | sendCommand ($conn, "1 SELECT $mbx"); 527 | while (1) { 528 | readResponse ($conn); 529 | if ($response =~ /^1 OK/i) { 530 | last; 531 | } 532 | elsif ($response !~ /^\*/) { 533 | print STDOUT "Unexpected SELECT INBOX response: $response\n"; 534 | return 0; 535 | } 536 | } 537 | 538 | } 539 | 540 | sub getMailboxList { 541 | 542 | my $conn = shift; 543 | 544 | # Get a list of the user's mailboxes 545 | 546 | sendCommand ($conn, "1 LIST \"\" *"); 547 | @response = (); 548 | while ( 1 ) { 549 | readResponse ($conn); 550 | last if $response =~ /^1 OK/i; 551 | 552 | if ( $response !~ /^\*/ ) { 553 | print STDOUT "unexpected response: $response\n"; 554 | return 0; 555 | } 556 | } 557 | 558 | @mbxs = (); 559 | for $i (0 .. $#response) { 560 | # print STDERR "$response[$i]\n"; 561 | $response[$i] =~ s/\s+/ /; 562 | ($dmy,$mbx) = split(/"\/"/,$response[$i]); 563 | $mbx =~ s/^\s+//; $mbx =~ s/\s+$//; 564 | $mbx =~ s/"//g; 565 | 566 | if ($mbx =~ /^\#/) { 567 | # Skip public mbxs 568 | next; 569 | } 570 | 571 | if ($mbx ne '') { 572 | push(@mbxs,$mbx); 573 | } 574 | } 575 | 576 | return 1; 577 | } 578 | 579 | sub getMsgList { 580 | 581 | my $mailbox = shift; 582 | my $conn = shift; 583 | 584 | # Select the mailbox in read-only mode 585 | 586 | sendCommand ($conn, "1 EXAMINE \"$mailbox\""); 587 | undef @response; 588 | $empty=0; 589 | while ( 1 ) { 590 | readResponse ($conn); 591 | 592 | last if $response =~ /^1 OK/i; 593 | 594 | if ( $response !~ /^\*/ ) { 595 | print STDOUT "Error: $response\n"; 596 | return 0; 597 | } 598 | } 599 | 600 | sendCommand ($conn, "1 FETCH 1:* (UID FLAGS)"); 601 | undef @response; 602 | while ( 1 ) { 603 | readResponse ($conn); 604 | last if $response =~ /^1 OK/i; 605 | if ( $response !~ /^\*/ ) { 606 | print STDOUT "Unexpected response: $response\n"; 607 | return 0; 608 | } 609 | } 610 | 611 | # Get a list of the msgs in the mailbox 612 | # 613 | undef @msgs; 614 | for $i (0 .. $#response) { 615 | $_ = $response[$i]; 616 | $_ =~ /\* ([^FETCH]*)/; 617 | $uid = $1; 618 | $uid =~ s/\s+$//; 619 | if ($response[$i] =~ /\\Seen/) { $seen = 1; } 620 | if (($uid ne 'OK') && ($uid ne '')) { 621 | push (@msgs,"$uid $seen"); 622 | } 623 | } 624 | return 1; 625 | } 626 | 627 | sub Log { 628 | 629 | my $string = shift; 630 | 631 | print STDERR "$string\n"; 632 | 633 | } 634 | -------------------------------------------------------------------------------- /imapcopy.cf: -------------------------------------------------------------------------------- 1 | LOGFILE: imapcopy.log 2 | IMAPCOPY: imapcopy.pl 3 | PROCESS_LIMIT: 8 4 | DEBUG: 0 5 | SHOWIMAP: 0 6 | -------------------------------------------------------------------------------- /imapcopy.cgi: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # $Header: /mhub4/sources/imap-tools/imapcopy.cgi,v 1.14 2016/02/08 17:09:39 rick Exp $ 4 | 5 | ####################################################################### 6 | # Program name imapcopy.cgi # 7 | # Written by Rick Sanders # 8 | # # 9 | # Description # 10 | # # 11 | # imapcopy.cgi is used to manage the imapcopy.pl script in CGI # 12 | # mode. # 13 | ####################################################################### 14 | 15 | use Socket; 16 | use FileHandle; 17 | use Fcntl; 18 | use Getopt::Std; 19 | use CGI; 20 | use CGI::Carp qw(fatalsToBrowser); 21 | use IO::Socket; 22 | use POSIX 'setsid'; 23 | use Cwd; 24 | 25 | init(); 26 | get_html(); 27 | 28 | # Check the source and dest logins in case the user has provided 29 | # invalid credentials or host names 30 | 31 | test_logins(); 32 | 33 | # To prevent someone from seeing the passwords in ps pass them 34 | # as ENV variables. 35 | 36 | $ENV{SOURCEPWD} = $sourcePwd; 37 | $ENV{DESTPWD} = $destPwd; 38 | 39 | list_folders(); 40 | 41 | my $cmd = "$imapcopy "; 42 | $cmd .= "-S $sourceHost/$sourceUser/SOURCEPWD "; 43 | $cmd .= "-D $destHost/$destUser/DESTPWD "; 44 | $cmd .= "-I " if $DEFAULTS{'SHOWIMAP'} == 1; 45 | $cmd .= "-d " if $DEFAULTS{'DEBUG'} == 1; 46 | $cmd .= "-L $logfile " if $logfile; 47 | $cmd .= "-m \"$mbxList\" " if $mbxList; 48 | $cmd .= "-e \"$excludeMbxs\" " if $excludeMbxs; 49 | $cmd .= "-a $sent_after " if $sent_after; 50 | $cmd .= "-b $sent_before " if $sent_before; 51 | $cmd .= "-U " if $update; 52 | $cmd .= "$DEFAULTS{ARGUMENTS} " if $DEFAULTS{ARGUMENTS}; 53 | 54 | print STDOUT "
Your copy job has been started. You will be notified when it has completed
"; 55 | launch_daemon( $cmd ); 56 | 57 | exit; 58 | 59 | 60 | sub init { 61 | 62 | $os = $ENV{'OS'}; 63 | 64 | print "Content-type: text/html\n\n\n"; 65 | print ''; 66 | print ''; 67 | print 'IMAP Copy'; 68 | print ''; 70 | 71 | if ( -e "imapcopy.cf" ) { 72 | open(CF, " ) { 75 | chomp; 76 | ($kw,$value) = split(/\s*:\s*/, $_, 2); 77 | $DEFAULTS{$kw} = $value; 78 | } 79 | close CF; 80 | 81 | if ( $DEFAULTS{'IMAPCOPY'} ) { 82 | $imapcopy = $DEFAULTS{'IMAPCOPY'}; 83 | } else { 84 | my $here = getcwd; 85 | $imapcopy = "$here/imapcopy.pl"; 86 | } 87 | 88 | $logfile = $DEFAULTS{'LOGFILE'}; 89 | if ( $logfile ) { 90 | if ( !open(LOG, ">> $logfile")) { 91 | print STDOUT "Can't open $logfile: $!\n"; 92 | exit; 93 | } 94 | select(LOG); $| = 1; 95 | } 96 | Log("$0 starting"); 97 | 98 | $count = count_imapcopy_processes(); 99 | if ( $DEFAULTS{PROCESS_LIMIT} ) { 100 | exit if $count > $DEFAULTS{PROCESS_LIMIT}; 101 | } 102 | 103 | # Determine whether we have SSL support via openSSL and IO::Socket::SSL 104 | $ssl_installed = 1; 105 | eval 'use IO::Socket::SSL'; 106 | if ( $@ ) { 107 | $ssl_installed = 0; 108 | } 109 | 110 | # Set up signal handling 111 | $SIG{'ALRM'} = 'signalHandler'; 112 | $SIG{'HUP'} = 'signalHandler'; 113 | $SIG{'INT'} = 'signalHandler'; 114 | $SIG{'TERM'} = 'signalHandler'; 115 | $SIG{'URG'} = 'signalHandler'; 116 | 117 | } 118 | 119 | sub launch_daemon { 120 | 121 | my $cmd = shift; 122 | my $parent = $$; 123 | use POSIX 'setsid'; 124 | 125 | # The purpose of this routine is to launch imapcopy as a grandkid which detaches 126 | # it from the Apache process so that it will not die if the user closes his browser. 127 | 128 | if ( !defined (my $kid = fork) ) { 129 | print STDOUT "Cannot fork a child process: $!
"; 130 | Log("Cannot fork: $!"); 131 | exit; 132 | } 133 | if ( $kid ) { 134 | exit(0); 135 | } else { 136 | close STDIN; 137 | close STDOUT; 138 | close STDERR; 139 | if ( !setsid ) { 140 | Log("Cannot execute 'setsid', exiting"); 141 | exit; 142 | } 143 | 144 | umask(0027); # create files with perms -rw-r----- 145 | if ( !chdir '/' ) { 146 | Log("Can't chdir to /: $!"); 147 | exit; 148 | } 149 | 150 | if ( !(open STDIN, '<', '/dev/null') ) { 151 | Log("Cannot redirect STDIN: $!"); 152 | exit; 153 | } 154 | 155 | if ( !(open STDOUT, '>', '/dev/null') ) { 156 | Log("Cannot redirect STDOUT: $!"); 157 | exit; 158 | } 159 | 160 | if ( !(open STDERR, '>>', $logfile) ) { 161 | Log("Cannot redirect STDERR: $!"); 162 | exit; 163 | } 164 | 165 | if ( !defined (my $grandkid = fork) ) { 166 | exit; 167 | } else { 168 | if ( $grandkid != 0 and $$ != $parent ) { 169 | Log("Execute $cmd"); 170 | $rc = `$cmd`; 171 | Log("rc = $rc"); 172 | } 173 | exit(0); 174 | } 175 | } 176 | } 177 | 178 | sub get_html { 179 | 180 | my $fields = shift; 181 | my $formData=0; 182 | 183 | # Get the HTML form values 184 | # 185 | my $query = new CGI; 186 | 187 | $sourceHost = $query->param('sourceHost'); 188 | $sourceUser = $query->param('sourceUser'); 189 | $sourcePwd = $query->param('sourcePwd'); 190 | 191 | $destHost = $query->param('destHost'); 192 | $destUser = $query->param('destUser'); 193 | $destPwd = $query->param('destPwd'); 194 | 195 | $mbxList = $query->param('mbxList'); 196 | $excludeMbxs = $query->param('excludeMbxList'); 197 | $sent_after = $query->param('sent_after'); 198 | $sent_before = $query->param('sent_before'); 199 | $update = $query->param('update'); 200 | 201 | $update = 1 if $update eq 'on'; 202 | 203 | } 204 | 205 | sub Log { 206 | 207 | my $str = shift; 208 | 209 | if ( $logfile ) { 210 | ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime; 211 | if ($year < 99) { $yr = 2000; } 212 | else { $yr = 1900; } 213 | $line = sprintf ("%.2d-%.2d-%d.%.2d:%.2d:%.2d %s\n", 214 | $mon + 1, $mday, $year + $yr, $hour, $min, $sec,$str); 215 | print LOG "$line"; 216 | } 217 | 218 | } 219 | 220 | 221 | 222 | # login 223 | # 224 | # login in at the source host with the user's name and password 225 | # 226 | sub login { 227 | 228 | my $user = shift; 229 | my $pwd = shift; 230 | my $host = shift; 231 | my $conn = shift; 232 | my $method = shift; 233 | 234 | Log("method $method") if $debug; 235 | 236 | return 1 if $method eq 'PREAUTH'; # Server pre-authenticates users 237 | 238 | Log("Authenticating to $host as $user"); 239 | if ( uc( $method ) eq 'CRAM-MD5' ) { 240 | # A CRAM-MD5 login is requested 241 | Log("login method $method"); 242 | my $rc = login_cram_md5( $user, $pwd, $conn ); 243 | return $rc; 244 | } 245 | 246 | if ( $user =~ /(.+):(.+)/ ) { 247 | # An AUTHENTICATE = PLAIN login has been requested 248 | $sourceUser = $1; 249 | $authuser = $2; 250 | login_plain( $sourceUser, $authuser, $pwd, $conn ) or exit; 251 | return 1; 252 | } 253 | 254 | # Otherwise do an ordinary login 255 | 256 | sendCommand ($conn, "1 LOGIN $user \"$pwd\""); 257 | while (1) { 258 | readResponse ( $conn ); 259 | 260 | if ( $response =~ /Cyrus/i and $conn eq $dst ) { 261 | Log("Destination is a Cyrus server"); 262 | $cyrus = 1; 263 | } 264 | 265 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 266 | # The destination is an Exchange server 267 | unless ( $exchange_override ) { 268 | $exchange = 1; 269 | Log("The destination is an Exchange server"); 270 | } 271 | } 272 | last if $response =~ /^1 OK/i; 273 | 274 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 275 | Log ("unexpected LOGIN response: $response"); 276 | return 0; 277 | } 278 | } 279 | Log("Logged in as $user") if $debug; 280 | 281 | return 1; 282 | } 283 | 284 | 285 | sub login_cram_md5 { 286 | 287 | my $user = shift; 288 | my $pwd = shift; 289 | my $conn = shift; 290 | 291 | sendCommand ($conn, "1 AUTHENTICATE CRAM-MD5"); 292 | while (1) { 293 | readResponse ( $conn ); 294 | last if $response =~ /^\+/; 295 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 296 | Log ("unexpected LOGIN response: $response"); 297 | return 0; 298 | } 299 | } 300 | 301 | my ($challenge) = $response =~ /^\+ (.+)/; 302 | 303 | Log("challenge $challenge") if $debug; 304 | $response = cram_md5( $challenge, $user, $pwd ); 305 | Log("response $response") if $debug; 306 | 307 | sendCommand ($conn, $response); 308 | while (1) { 309 | readResponse ( $conn ); 310 | 311 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 312 | # The destination is an Exchange server 313 | $exchange = 1; 314 | Log("The destination is an Exchange server"); 315 | } 316 | 317 | last if $response =~ /^1 OK/i; 318 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 319 | Log ("unexpected LOGIN response: $response"); 320 | return 0; 321 | } 322 | } 323 | Log("Logged in as $user") if $debug; 324 | 325 | return 1; 326 | } 327 | 328 | # login_plain 329 | # 330 | # login in at the source host with the user's name and password. If provided 331 | # with administrator credential, use them as this eliminates the need for the 332 | # user's password. 333 | # 334 | sub login_plain { 335 | 336 | my $user = shift; 337 | my $admin = shift; 338 | my $pwd = shift; 339 | my $conn = shift; 340 | 341 | # Do an AUTHENTICATE = PLAIN. If an admin user has been provided then use it. 342 | 343 | if ( !$admin ) { 344 | # Log in as the user 345 | $admin = $user 346 | } 347 | 348 | $login_str = sprintf("%s\x00%s\x00%s", $user,$admin,$pwd); 349 | $login_str = encode_base64("$login_str", ""); 350 | $len = length( $login_str ); 351 | 352 | # sendCommand ($conn, "1 AUTHENTICATE \"PLAIN\" {$len}" ); 353 | sendCommand ($conn, "1 AUTHENTICATE PLAIN" ); 354 | 355 | my $loops; 356 | while (1) { 357 | readResponse ( $conn ); 358 | last if $response =~ /\+/; 359 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 360 | Log ("unexpected LOGIN response: $response"); 361 | exit; 362 | } 363 | $last if $loops++ > 5; 364 | } 365 | 366 | sendCommand ($conn, "$login_str" ); 367 | my $loops; 368 | while (1) { 369 | readResponse ( $conn ); 370 | 371 | if ( $response =~ /Cyrus/i and $conn eq $dst ) { 372 | Log("Destination is a Cyrus server"); 373 | $cyrus = 1; 374 | } 375 | 376 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 377 | # The destination is an Exchange server 378 | $exchange = 1; 379 | Log("The destination is an Exchange server"); 380 | } 381 | 382 | last if $response =~ /^1 OK/i; 383 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 384 | Log ("unexpected LOGIN response: $response"); 385 | exit; 386 | } 387 | $last if $loops++ > 5; 388 | } 389 | 390 | return 1; 391 | 392 | } 393 | 394 | # logout 395 | # 396 | # log out from the host 397 | # 398 | sub logout { 399 | 400 | my $conn = shift; 401 | 402 | undef @response; 403 | sendCommand ($conn, "1 LOGOUT"); 404 | while ( 1 ) { 405 | readResponse ($conn); 406 | if ( $response =~ /^1 OK/i ) { 407 | last; 408 | } 409 | elsif ( $response !~ /^\*/ ) { 410 | Log ("unexpected LOGOUT response: $response"); 411 | last; 412 | } 413 | } 414 | close $conn; 415 | return; 416 | } 417 | 418 | # Make a connection to a IMAP host 419 | 420 | sub connectToHost { 421 | 422 | my $host = shift; 423 | my $conn = shift; 424 | 425 | Log("Connecting to $host") if $debug; 426 | 427 | ($host,$port) = split(/:/, $host); 428 | $port = 143 unless $port; 429 | 430 | # We know whether to use SSL for ports 143 and 993. For any 431 | # other ones we'll have to figure it out. 432 | $mode = sslmode( $host, $port ); 433 | 434 | if ( $mode eq 'SSL' ) { 435 | unless( $ssl_installed == 1 ) { 436 | warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 437 | Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 438 | exit; 439 | } 440 | Log("Attempting an SSL connection") if $debug; 441 | $$conn = IO::Socket::SSL->new( 442 | Proto => "tcp", 443 | SSL_verify_mode => 0x00, 444 | PeerAddr => $host, 445 | PeerPort => $port, 446 | Domain => AF_INET, 447 | Timeout => 10, 448 | ); 449 | 450 | unless ( $$conn ) { 451 | $error = IO::Socket::SSL::errstr(); 452 | Log("Error connecting to $host: $error"); 453 | print STDOUT "Error: Can't connect to $host.
"; 454 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 455 | exit; 456 | } 457 | } else { 458 | # Non-SSL connection 459 | Log("Attempting a non-SSL connection") if $debug; 460 | $$conn = IO::Socket::INET->new( 461 | Proto => "tcp", 462 | PeerAddr => $host, 463 | PeerPort => $port, 464 | Timeout => 10, 465 | ); 466 | 467 | unless ( $$conn ) { 468 | Log("Error connecting to $host:$port: $@"); 469 | print STDOUT "Error: Can't connect to $host.
"; 470 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 471 | exit; 472 | } 473 | } 474 | Log("Connected to $host on port $port"); 475 | 476 | } 477 | 478 | sub sslmode { 479 | 480 | my $host = shift; 481 | my $port = shift; 482 | my $mode; 483 | 484 | # Determine whether to make an SSL connection 485 | # to the host. Return 'SSL' if so. 486 | 487 | if ( $port == 143 ) { 488 | # Standard non-SSL port 489 | return ''; 490 | } elsif ( $port == 993 ) { 491 | # Standard SSL port 492 | return 'SSL'; 493 | } 494 | 495 | unless ( $ssl_installed ) { 496 | # We don't have SSL installed on this machine 497 | return ''; 498 | } 499 | 500 | # For any other port we need to determine whether it supports SSL 501 | 502 | my $conn = IO::Socket::SSL->new( 503 | Proto => "tcp", 504 | SSL_verify_mode => 0x00, 505 | PeerAddr => $host, 506 | PeerPort => $port, 507 | ); 508 | 509 | if ( $conn ) { 510 | close( $conn ); 511 | $mode = 'SSL'; 512 | } else { 513 | $mode = ''; 514 | } 515 | 516 | return $mode; 517 | } 518 | 519 | sub test_logins { 520 | 521 | # Verify that we can log in at the source and destination before launching 522 | # the copy job. 523 | 524 | $destUser = $sourceUser if $destUser eq '*'; 525 | $destPwd = $sourcePwd if $destPwd eq '*'; 526 | 527 | print "

"; 528 | if ( !connectToHost($sourceHost, \$src) ) { 529 | print STDOUT " Error: Can't connect to $sourceHost. Check that $sourceHost is correct.
"; 530 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 531 | exit; 532 | } 533 | if ( !login($sourceUser,$sourcePwd, $sourceHost, $src, $srcMethod) ) { 534 | print STDOUT "Error: Can't login as $sourceUser. Check your username and password
"; 535 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 536 | exit; 537 | } 538 | if ( !connectToHost($destHost, \$dst) ) { 539 | print STDOUT "Error: Can't connect to $destHost. Check that $destHost is correct.\n"; 540 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 541 | exit; 542 | } 543 | if ( !login($destUser,$destPwd, $destHost, $dst, $dstMethod) ) { 544 | print STDOUT "Error: Can't login as $destUser. Check your username and password
"; 545 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 546 | exit; 547 | } 548 | 549 | } 550 | 551 | sub sendCommand { 552 | 553 | my $fd = shift; 554 | my $cmd = shift; 555 | 556 | print $fd "$cmd\r\n"; 557 | 558 | Log (">> $cmd") if $showIMAP; 559 | } 560 | 561 | # 562 | # readResponse 563 | # 564 | # This subroutine reads and formats an IMAP protocol response from an 565 | # IMAP server on a specified connection. 566 | # 567 | 568 | sub readResponse { 569 | 570 | my $fd = shift; 571 | 572 | $response = <$fd>; 573 | chop $response; 574 | $response =~ s/\r//g; 575 | push (@response,$response); 576 | Log ("<< $response") if $showIMAP; 577 | } 578 | 579 | sub count_imapcopy_processes { 580 | 581 | my $count; 582 | 583 | # Count how many imapcopy processes are currently running 584 | # and exit if the max has been reached. 585 | 586 | foreach $_ ( `ps -ef | grep imapcopy.pl` ) { 587 | next unless /imapcopy.pl/; 588 | next if /grep/; 589 | $count++; 590 | } 591 | 592 | $process_limit = $DEFAULTS{PROCESS_LIMIT}; 593 | if ( $process_limit > 0 and $count > $process_limit ) { 594 | print STDOUT "

The maximum number of IMAP copies is already running. Please try again later.
"; 595 | } 596 | return $count; 597 | 598 | } 599 | 600 | sub commafy { 601 | 602 | my $number = shift; 603 | 604 | $_ = $$number; 605 | 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; 606 | $$number = $_; 607 | } 608 | 609 | sub list_folders { 610 | 611 | # Show the user his folders so he knows what will get migrated 612 | 613 | Log("This is list_folders.") if $debug; 614 | Log("LISTFOLDERS config param is set to >$DEFAULTS{LISTFOLDERS}<"); 615 | return unless $DEFAULTS{LISTFOLDERS} =~ /1|YES/i; 616 | 617 | list_imap_folders(); 618 | 619 | } 620 | 621 | sub list_imap_folders { 622 | 623 | @mbxs = getMailboxList( $srcPrefix, $src ); 624 | 625 | print STDOUT "
"; 626 | print STDOUT "
FolderMessagesMB"; 627 | 628 | foreach $mbx ( @mbxs ) { 629 | ($msgcount,$size) = count_msgs( $mbx, $src ); 630 | commafy( \$msgcount ); 631 | commafy( \$size ); 632 | print STDOUT "
$mbx$msgcount$size
" unless $mbx eq ''; 633 | $total_msgs += $msgcount; 634 | $total_bytes += $size; 635 | } 636 | commafy( \$total_msgs ); 637 | commafy( \$total_bytes ); 638 | print STDOUT "
Totals$total_msgs$total_bytes
"; 639 | print STDOUT "
"; 640 | 641 | } 642 | 643 | # getMailboxList 644 | # 645 | # get a list of the user's mailboxes from the source host 646 | # 647 | sub getMailboxList { 648 | 649 | my $prefix = shift; 650 | my $conn = shift; 651 | my @mbxs; 652 | 653 | # Get a list of the user's mailboxes 654 | # 655 | 656 | Log("Get list of user's mailboxes",2) if $debugMode; 657 | 658 | if ( $mbxList ) { 659 | foreach $mbx ( split(/,/, $mbxList) ) { 660 | $mbx = $prefix . $mbx if $prefix; 661 | if ( $opt_R ) { 662 | # Get all submailboxes under the ones specified 663 | $mbx .= '*'; 664 | @mailboxes = listMailboxes( $mbx, $conn); 665 | push( @mbxs, @mailboxes ); 666 | } else { 667 | push( @mbxs, $mbx ); 668 | } 669 | } 670 | } else { 671 | # Get all mailboxes 672 | @mbxs = listMailboxes( '*', $conn); 673 | } 674 | 675 | if ( $src_uwash_imap ) { 676 | my @temp; 677 | foreach $_ ( @mbxs ) { 678 | next if /^\./; # Skip if starting with a dot 679 | s/^Mail\///; 680 | push( @temp, $_); 681 | } 682 | @mbxs = @temp; 683 | @temp = (); 684 | } 685 | 686 | return @mbxs; 687 | } 688 | 689 | # listMailboxes 690 | # 691 | # Get a list of the user's mailboxes 692 | # 693 | sub listMailboxes { 694 | 695 | my $prefix = shift; 696 | my $conn = shift; 697 | 698 | sendCommand ($conn, "1 LIST \"\" \"$prefix\""); 699 | undef @response; 700 | while ( 1 ) { 701 | &readResponse ($conn); 702 | if ( $response =~ /^1 OK/i ) { 703 | last; 704 | } 705 | elsif ( $response !~ /^\*/ ) { 706 | &Log ("unexpected response: $response"); 707 | return 0; 708 | } 709 | } 710 | 711 | @mbxs = (); 712 | for $i (0 .. $#response) { 713 | $response[$i] =~ s/\s+/ /; 714 | if ( $response[$i] =~ /"$/ ) { 715 | $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i; 716 | $mbx = $3; 717 | } elsif ( $response[$i] =~ /\* LIST \((.*)\) NIL (.+)/i ) { 718 | $mbx = $2; 719 | } else { 720 | $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i; 721 | $mbx = $3; 722 | } 723 | $mbx =~ s/^\s+//; $mbx =~ s/\s+$//; 724 | 725 | if ($response[$i] =~ /NOSELECT/i) { 726 | next; 727 | } 728 | 729 | next if $mbx =~ /\[Gmail\]\/All Mail/; 730 | 731 | push ( @mbxs, $mbx ) if $mbx ne ''; 732 | } 733 | 734 | return @mbxs; 735 | } 736 | 737 | sub count_msgs { 738 | 739 | my $mbx = shift; 740 | my $conn = shift; 741 | my @msgs; 742 | 743 | # Get the msg count and size 744 | 745 | getMsgList( $mbx, \@msgs, $conn, 'SELECT' ); 746 | my $msgcount = $#msgs + 1; 747 | 748 | my $total = 0; 749 | foreach my $size ( @msgs ) { 750 | $total += $size; 751 | } 752 | $total = sprintf("%.2f", $total/1000000); 753 | $total .= ' MB'; 754 | my $count = scalar @msgs; 755 | 756 | return ($count,$total); 757 | 758 | } 759 | 760 | sub getMsgList { 761 | 762 | my $mailbox = shift; 763 | my $msgs = shift; 764 | my $conn = shift; 765 | my $mode = shift; 766 | my $seen; 767 | my $empty; 768 | my $msgnum; 769 | my $from; 770 | my $flags; 771 | my $msgid; 772 | 773 | Log("large_msg_threshold $large_msg_threshold") if $debug; 774 | @$msgs = (); 775 | $mode = 'EXAMINE' unless $mode; 776 | sendCommand ($conn, "1 $mode \"$mailbox\""); 777 | undef @response; 778 | $empty=0; 779 | while ( 1 ) { 780 | readResponse ( $conn ); 781 | if ( $response =~ / 0 EXISTS/i ) { $empty=1; } 782 | if ( $response =~ /^1 OK/i ) { 783 | last; 784 | } 785 | elsif ( $response !~ /^\*/ ) { 786 | Log ("unexpected response: $response"); 787 | return 0; 788 | } 789 | } 790 | 791 | return (0, 0) if $empty; 792 | 793 | my $start = 1; 794 | my $end = '*'; 795 | $start = $start_fetch if $start_fetch; 796 | $end = $end_fetch if $end_fetch; 797 | 798 | sendCommand ( $conn, "1 FETCH $start:$end (RFC822.SIZE body.peek[header.fields (Subject)])"); 799 | 800 | @response = (); 801 | while ( 1 ) { 802 | readResponse ( $conn ); 803 | 804 | if ( $response =~ /^1 OK/i ) { 805 | last; 806 | } 807 | last if $response =~ /^1 NO|^1 BAD|^\* BYE/; 808 | 809 | if ( $response =~ /^\* BYE/ ) { 810 | Log("The server terminated our connection: $response"); 811 | exit; 812 | } 813 | } 814 | 815 | $flags = ''; 816 | for $i (0 .. $#response) { 817 | $response = $response[$i]; 818 | last if $response[$i] =~ /^1 OK FETCH complete/i; 819 | 820 | if ( $response =~ /^\* BYE/ ) { 821 | Log("The server terminated our connection: $response[$i]"); 822 | Log("msgnum $msgnum"); 823 | exit; 824 | } 825 | 826 | if ( $response[$i] =~ /Subject:\s*(.+)/i ) { 827 | $subject = $1; 828 | } 829 | 830 | if ( $response[$i] =~ /INTERNALDATE (.+) RFC822\.SIZE/i ) { 831 | $date = $1; 832 | $date =~ /"(.+)"/; 833 | $date = $1; 834 | $date =~ s/"//g; 835 | } 836 | 837 | if ( $response[$i] =~ /\(RFC822\.SIZE (.+)\)/i) { 838 | ($size) = split(/\s+/, $1); 839 | Log("msg size $size") if $debug; 840 | if ( $report_large_msgs == 1 and $size > $large_msg_threshold) { 841 | Log("Added msg size $size to large_msg_report") if $debug; 842 | push( @large_msgs, "$size $mailbox $subject"); 843 | $subject = ''; 844 | } 845 | } 846 | 847 | if ( $size ) { 848 | push (@$msgs,$size); 849 | $size = ''; 850 | } 851 | } 852 | 853 | return 1; 854 | 855 | } 856 | 857 | -------------------------------------------------------------------------------- /imapcopy.cgi.debug: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # $Header: /mhub4/sources/imap-tools/imapcopy.cgi,v 1.13 2016/01/26 20:28:57 rick Exp $ 4 | 5 | ####################################################################### 6 | # Program name imapcopy.cgi # 7 | # Written by Rick Sanders # 8 | # # 9 | # Description # 10 | # # 11 | # imapcopy.cgi is used to manage the imapcopy.pl script in CGI # 12 | # mode. # 13 | ####################################################################### 14 | 15 | use Socket; 16 | use FileHandle; 17 | use Fcntl; 18 | use Getopt::Std; 19 | use CGI; 20 | use CGI::Carp qw(fatalsToBrowser); 21 | use IO::Socket; 22 | use POSIX 'setsid'; 23 | use Cwd; 24 | 25 | init(); 26 | get_html(); 27 | 28 | # Check the source and dest logins in case the user has provided 29 | # invalid credentials or host names 30 | 31 | test_logins(); 32 | 33 | # To prevent someone from seeing the passwords in ps pass them 34 | # as ENV variables. 35 | 36 | $ENV{SOURCEPWD} = $sourcePwd; 37 | $ENV{DESTPWD} = $destPwd; 38 | 39 | my $cmd = "$imapcopy "; 40 | $cmd .= "-S $sourceHost/$sourceUser/SOURCEPWD "; 41 | $cmd .= "-D $destHost/$destUser/DESTPWD "; 42 | $cmd .= "-I " if $DEFAULTS{'SHOWIMAP'} == 1; 43 | $cmd .= "-d " if $DEFAULTS{'DEBUG'} == 1; 44 | $cmd .= "-L $logfile " if $logfile; 45 | $cmd .= "-m \"$mbxList\" " if $mbxList; 46 | $cmd .= "-e \"$excludeMbxs\" " if $excludeMbxs; 47 | $cmd .= "-a $sent_after " if $sent_after; 48 | $cmd .= "-b $sent_before " if $sent_before; 49 | $cmd .= "-U " if $update; 50 | $cmd .= "$DEFAULTS{ARGUMENTS} " if $DEFAULTS{ARGUMENTS}; 51 | 52 | print STDOUT "
Your copy job has been started. You will be notified when it has completed
"; 53 | Log("calling list_folders"); 54 | list_folders(); 55 | Log("launch the imapcopy daemon process"); 56 | launch_daemon( $cmd ); 57 | 58 | exit; 59 | 60 | 61 | sub init { 62 | 63 | $os = $ENV{'OS'}; 64 | 65 | print "Content-type: text/html\n\n\n"; 66 | print ''; 67 | print ''; 68 | print 'IMAP Copy'; 69 | print ''; 71 | 72 | if ( -e "imapcopy.cf" ) { 73 | open(CF, " ) { 76 | chomp; 77 | ($kw,$value) = split(/\s*:\s*/, $_, 2); 78 | $DEFAULTS{$kw} = $value; 79 | } 80 | close CF; 81 | 82 | if ( $DEFAULTS{'IMAPCOPY'} ) { 83 | $imapcopy = $DEFAULTS{'IMAPCOPY'}; 84 | } else { 85 | my $here = getcwd; 86 | $imapcopy = "$here/imapcopy.pl"; 87 | } 88 | 89 | $logfile = $DEFAULTS{'LOGFILE'}; 90 | if ( $logfile ) { 91 | if ( !open(LOG, ">> $logfile")) { 92 | print STDOUT "Can't open $logfile: $!\n"; 93 | exit; 94 | } 95 | select(LOG); $| = 1; 96 | } 97 | Log("$0 starting"); 98 | 99 | $count = count_imapcopy_processes(); 100 | if ( $DEFAULTS{PROCESS_LIMIT} ) { 101 | exit if $count > $DEFAULTS{PROCESS_LIMIT}; 102 | } 103 | 104 | # Determine whether we have SSL support via openSSL and IO::Socket::SSL 105 | $ssl_installed = 1; 106 | eval 'use IO::Socket::SSL'; 107 | if ( $@ ) { 108 | $ssl_installed = 0; 109 | } 110 | 111 | # Set up signal handling 112 | $SIG{'ALRM'} = 'signalHandler'; 113 | $SIG{'HUP'} = 'signalHandler'; 114 | $SIG{'INT'} = 'signalHandler'; 115 | $SIG{'TERM'} = 'signalHandler'; 116 | $SIG{'URG'} = 'signalHandler'; 117 | 118 | } 119 | 120 | sub launch_daemon { 121 | 122 | my $cmd = shift; 123 | my $parent = $$; 124 | use POSIX 'setsid'; 125 | 126 | # The purpose of this routine is to launch imapcopy as a grandkid which detaches 127 | # it from the Apache process so that it will not die if the user closes his browser. 128 | 129 | if ( !defined (my $kid = fork) ) { 130 | print STDOUT "Cannot fork a child process: $!
"; 131 | Log("Cannot fork: $!"); 132 | exit; 133 | } 134 | if ( $kid ) { 135 | exit(0); 136 | } else { 137 | close STDIN; 138 | close STDOUT; 139 | close STDERR; 140 | if ( !setsid ) { 141 | Log("Cannot execute 'setsid', exiting"); 142 | exit; 143 | } 144 | 145 | umask(0027); # create files with perms -rw-r----- 146 | if ( !chdir '/' ) { 147 | Log("Can't chdir to /: $!"); 148 | exit; 149 | } 150 | 151 | if ( !(open STDIN, '<', '/dev/null') ) { 152 | Log("Cannot redirect STDIN: $!"); 153 | exit; 154 | } 155 | 156 | if ( !(open STDOUT, '>', '/dev/null') ) { 157 | Log("Cannot redirect STDOUT: $!"); 158 | exit; 159 | } 160 | 161 | if ( !(open STDERR, '>>', $logfile) ) { 162 | Log("Cannot redirect STDERR: $!"); 163 | exit; 164 | } 165 | 166 | if ( !defined (my $grandkid = fork) ) { 167 | exit; 168 | } else { 169 | if ( $grandkid != 0 and $$ != $parent ) { 170 | Log("Execute $cmd"); 171 | $rc = `$cmd`; 172 | Log("rc = $rc"); 173 | } 174 | exit(0); 175 | } 176 | } 177 | } 178 | 179 | sub get_html { 180 | 181 | my $fields = shift; 182 | my $formData=0; 183 | 184 | # Get the HTML form values 185 | # 186 | my $query = new CGI; 187 | 188 | $sourceHost = $query->param('sourceHost'); 189 | $sourceUser = $query->param('sourceUser'); 190 | $sourcePwd = $query->param('sourcePwd'); 191 | 192 | $destHost = $query->param('destHost'); 193 | $destUser = $query->param('destUser'); 194 | $destPwd = $query->param('destPwd'); 195 | 196 | $mbxList = $query->param('mbxList'); 197 | $excludeMbxs = $query->param('excludeMbxList'); 198 | $sent_after = $query->param('sent_after'); 199 | $sent_before = $query->param('sent_before'); 200 | $update = $query->param('update'); 201 | 202 | $update = 1 if $update eq 'on'; 203 | 204 | } 205 | 206 | sub Log { 207 | 208 | my $str = shift; 209 | 210 | if ( $logfile ) { 211 | ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime; 212 | if ($year < 99) { $yr = 2000; } 213 | else { $yr = 1900; } 214 | $line = sprintf ("%.2d-%.2d-%d.%.2d:%.2d:%.2d %s\n", 215 | $mon + 1, $mday, $year + $yr, $hour, $min, $sec,$str); 216 | print LOG "$line"; 217 | } 218 | 219 | } 220 | 221 | 222 | 223 | # login 224 | # 225 | # login in at the source host with the user's name and password 226 | # 227 | sub login { 228 | 229 | my $user = shift; 230 | my $pwd = shift; 231 | my $host = shift; 232 | my $conn = shift; 233 | my $method = shift; 234 | 235 | Log("method $method") if $debug; 236 | 237 | return 1 if $method eq 'PREAUTH'; # Server pre-authenticates users 238 | 239 | Log("Authenticating to $host as $user"); 240 | if ( uc( $method ) eq 'CRAM-MD5' ) { 241 | # A CRAM-MD5 login is requested 242 | Log("login method $method"); 243 | my $rc = login_cram_md5( $user, $pwd, $conn ); 244 | return $rc; 245 | } 246 | 247 | if ( $user =~ /(.+):(.+)/ ) { 248 | # An AUTHENTICATE = PLAIN login has been requested 249 | $sourceUser = $1; 250 | $authuser = $2; 251 | login_plain( $sourceUser, $authuser, $pwd, $conn ) or exit; 252 | return 1; 253 | } 254 | 255 | # Otherwise do an ordinary login 256 | 257 | sendCommand ($conn, "1 LOGIN $user \"$pwd\""); 258 | while (1) { 259 | readResponse ( $conn ); 260 | 261 | if ( $response =~ /Cyrus/i and $conn eq $dst ) { 262 | Log("Destination is a Cyrus server"); 263 | $cyrus = 1; 264 | } 265 | 266 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 267 | # The destination is an Exchange server 268 | unless ( $exchange_override ) { 269 | $exchange = 1; 270 | Log("The destination is an Exchange server"); 271 | } 272 | } 273 | last if $response =~ /^1 OK/i; 274 | 275 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 276 | Log ("unexpected LOGIN response: $response"); 277 | return 0; 278 | } 279 | } 280 | Log("Logged in as $user") if $debug; 281 | 282 | return 1; 283 | } 284 | 285 | 286 | sub login_cram_md5 { 287 | 288 | my $user = shift; 289 | my $pwd = shift; 290 | my $conn = shift; 291 | 292 | sendCommand ($conn, "1 AUTHENTICATE CRAM-MD5"); 293 | while (1) { 294 | readResponse ( $conn ); 295 | last if $response =~ /^\+/; 296 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 297 | Log ("unexpected LOGIN response: $response"); 298 | return 0; 299 | } 300 | } 301 | 302 | my ($challenge) = $response =~ /^\+ (.+)/; 303 | 304 | Log("challenge $challenge") if $debug; 305 | $response = cram_md5( $challenge, $user, $pwd ); 306 | Log("response $response") if $debug; 307 | 308 | sendCommand ($conn, $response); 309 | while (1) { 310 | readResponse ( $conn ); 311 | 312 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 313 | # The destination is an Exchange server 314 | $exchange = 1; 315 | Log("The destination is an Exchange server"); 316 | } 317 | 318 | last if $response =~ /^1 OK/i; 319 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 320 | Log ("unexpected LOGIN response: $response"); 321 | return 0; 322 | } 323 | } 324 | Log("Logged in as $user") if $debug; 325 | 326 | return 1; 327 | } 328 | 329 | # login_plain 330 | # 331 | # login in at the source host with the user's name and password. If provided 332 | # with administrator credential, use them as this eliminates the need for the 333 | # user's password. 334 | # 335 | sub login_plain { 336 | 337 | my $user = shift; 338 | my $admin = shift; 339 | my $pwd = shift; 340 | my $conn = shift; 341 | 342 | # Do an AUTHENTICATE = PLAIN. If an admin user has been provided then use it. 343 | 344 | if ( !$admin ) { 345 | # Log in as the user 346 | $admin = $user 347 | } 348 | 349 | $login_str = sprintf("%s\x00%s\x00%s", $user,$admin,$pwd); 350 | $login_str = encode_base64("$login_str", ""); 351 | $len = length( $login_str ); 352 | 353 | # sendCommand ($conn, "1 AUTHENTICATE \"PLAIN\" {$len}" ); 354 | sendCommand ($conn, "1 AUTHENTICATE PLAIN" ); 355 | 356 | my $loops; 357 | while (1) { 358 | readResponse ( $conn ); 359 | last if $response =~ /\+/; 360 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 361 | Log ("unexpected LOGIN response: $response"); 362 | exit; 363 | } 364 | $last if $loops++ > 5; 365 | } 366 | 367 | sendCommand ($conn, "$login_str" ); 368 | my $loops; 369 | while (1) { 370 | readResponse ( $conn ); 371 | 372 | if ( $response =~ /Cyrus/i and $conn eq $dst ) { 373 | Log("Destination is a Cyrus server"); 374 | $cyrus = 1; 375 | } 376 | 377 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 378 | # The destination is an Exchange server 379 | $exchange = 1; 380 | Log("The destination is an Exchange server"); 381 | } 382 | 383 | last if $response =~ /^1 OK/i; 384 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 385 | Log ("unexpected LOGIN response: $response"); 386 | exit; 387 | } 388 | $last if $loops++ > 5; 389 | } 390 | 391 | return 1; 392 | 393 | } 394 | 395 | # logout 396 | # 397 | # log out from the host 398 | # 399 | sub logout { 400 | 401 | my $conn = shift; 402 | 403 | undef @response; 404 | sendCommand ($conn, "1 LOGOUT"); 405 | while ( 1 ) { 406 | readResponse ($conn); 407 | if ( $response =~ /^1 OK/i ) { 408 | last; 409 | } 410 | elsif ( $response !~ /^\*/ ) { 411 | Log ("unexpected LOGOUT response: $response"); 412 | last; 413 | } 414 | } 415 | close $conn; 416 | return; 417 | } 418 | 419 | # Make a connection to a IMAP host 420 | 421 | sub connectToHost { 422 | 423 | my $host = shift; 424 | my $conn = shift; 425 | 426 | Log("Connecting to $host") if $debug; 427 | 428 | ($host,$port) = split(/:/, $host); 429 | $port = 143 unless $port; 430 | 431 | # We know whether to use SSL for ports 143 and 993. For any 432 | # other ones we'll have to figure it out. 433 | $mode = sslmode( $host, $port ); 434 | 435 | if ( $mode eq 'SSL' ) { 436 | unless( $ssl_installed == 1 ) { 437 | warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 438 | Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 439 | exit; 440 | } 441 | Log("Attempting an SSL connection") if $debug; 442 | $$conn = IO::Socket::SSL->new( 443 | Proto => "tcp", 444 | SSL_verify_mode => 0x00, 445 | PeerAddr => $host, 446 | PeerPort => $port, 447 | Domain => AF_INET, 448 | Timeout => 10, 449 | ); 450 | 451 | unless ( $$conn ) { 452 | $error = IO::Socket::SSL::errstr(); 453 | Log("Error connecting to $host: $error"); 454 | print STDOUT "Error: Can't connect to $host.
"; 455 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 456 | exit; 457 | } 458 | } else { 459 | # Non-SSL connection 460 | Log("Attempting a non-SSL connection") if $debug; 461 | $$conn = IO::Socket::INET->new( 462 | Proto => "tcp", 463 | PeerAddr => $host, 464 | PeerPort => $port, 465 | Timeout => 10, 466 | ); 467 | 468 | unless ( $$conn ) { 469 | Log("Error connecting to $host:$port: $@"); 470 | print STDOUT "Error: Can't connect to $host.
"; 471 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 472 | exit; 473 | } 474 | } 475 | Log("Connected to $host on port $port"); 476 | 477 | } 478 | 479 | sub sslmode { 480 | 481 | my $host = shift; 482 | my $port = shift; 483 | my $mode; 484 | 485 | # Determine whether to make an SSL connection 486 | # to the host. Return 'SSL' if so. 487 | 488 | if ( $port == 143 ) { 489 | # Standard non-SSL port 490 | return ''; 491 | } elsif ( $port == 993 ) { 492 | # Standard SSL port 493 | return 'SSL'; 494 | } 495 | 496 | unless ( $ssl_installed ) { 497 | # We don't have SSL installed on this machine 498 | return ''; 499 | } 500 | 501 | # For any other port we need to determine whether it supports SSL 502 | 503 | my $conn = IO::Socket::SSL->new( 504 | Proto => "tcp", 505 | SSL_verify_mode => 0x00, 506 | PeerAddr => $host, 507 | PeerPort => $port, 508 | ); 509 | 510 | if ( $conn ) { 511 | close( $conn ); 512 | $mode = 'SSL'; 513 | } else { 514 | $mode = ''; 515 | } 516 | 517 | return $mode; 518 | } 519 | 520 | sub test_logins { 521 | 522 | # Verify that we can log in at the source and destination before launching 523 | # the copy job. 524 | 525 | $destUser = $sourceUser if $destUser eq '*'; 526 | $destPwd = $sourcePwd if $destPwd eq '*'; 527 | 528 | print "

"; 529 | if ( !connectToHost($sourceHost, \$src) ) { 530 | print STDOUT " Error: Can't connect to $sourceHost. Check that $sourceHost is correct.
"; 531 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 532 | exit; 533 | } 534 | if ( !login($sourceUser,$sourcePwd, $sourceHost, $src, $srcMethod) ) { 535 | print STDOUT "Error: Can't login as $sourceUser. Check your username and password
"; 536 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 537 | exit; 538 | } 539 | if ( !connectToHost($destHost, \$dst) ) { 540 | print STDOUT "Error: Can't connect to $destHost. Check that $destHost is correct.\n"; 541 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 542 | exit; 543 | } 544 | if ( !login($destUser,$destPwd, $destHost, $dst, $dstMethod) ) { 545 | print STDOUT "Error: Can't login as $destUser. Check your username and password
"; 546 | print STDOUT "Hit the Back button on your browser, correct the info, and try again."; 547 | exit; 548 | } 549 | 550 | } 551 | 552 | sub sendCommand { 553 | 554 | my $fd = shift; 555 | my $cmd = shift; 556 | 557 | print $fd "$cmd\r\n"; 558 | 559 | Log (">> $cmd") if $showIMAP; 560 | } 561 | 562 | # 563 | # readResponse 564 | # 565 | # This subroutine reads and formats an IMAP protocol response from an 566 | # IMAP server on a specified connection. 567 | # 568 | 569 | sub readResponse { 570 | 571 | my $fd = shift; 572 | 573 | $response = <$fd>; 574 | chop $response; 575 | $response =~ s/\r//g; 576 | push (@response,$response); 577 | Log ("<< $response") if $showIMAP; 578 | } 579 | 580 | sub count_imapcopy_processes { 581 | 582 | my $count; 583 | 584 | # Count how many imapcopy processes are currently running 585 | # and exit if the max has been reached. 586 | 587 | foreach $_ ( `ps -ef | grep imapcopy.pl` ) { 588 | next unless /imapcopy.pl/; 589 | next if /grep/; 590 | $count++; 591 | } 592 | 593 | $process_limit = $DEFAULTS{PROCESS_LIMIT}; 594 | if ( $process_limit > 0 and $count > $process_limit ) { 595 | print STDOUT "

The maximum number of IMAP copies is already running. Please try again later.
"; 596 | } 597 | return $count; 598 | 599 | } 600 | 601 | sub commafy { 602 | 603 | my $number = shift; 604 | 605 | $_ = $$number; 606 | 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; 607 | $$number = $_; 608 | } 609 | 610 | sub list_folders { 611 | 612 | my $cmd; 613 | 614 | # Show the user his folders so he knows what will get migrated 615 | 616 | Log("This is list_folders."); 617 | 618 | Log("LISTFOLDERS config param is set to >$DEFAULTS{LISTFOLDERS}<"); 619 | return unless $DEFAULTS{LISTFOLDERS} =~ /1|YES/i; 620 | 621 | Log("OK to list the folders"); 622 | Log("Listing the files in the local directory"); 623 | foreach $_ ( `ls -l` ) { 624 | chomp; 625 | Log(" $_"); 626 | } 627 | if ( !-e "list_imap_folders.pl" ) { 628 | Log("ERROR: list_imap_folders.pl was not found"); 629 | return; 630 | } else { 631 | Log("list_imap_folders was found"); 632 | } 633 | 634 | # $cmd = "./list_imap_folders.pl -s -S $sourceHost/$sourceUser/$sourcePwd"; 635 | $results = `$rc`; 636 | 637 | Log("Executing the list command"); 638 | print STDOUT "
The following folders and messages will be copied.

"; 639 | 640 | $show_sizes = 1; 641 | print STDOUT "
"; 642 | if ( $show_sizes ) { 643 | print STDOUT "
FolderMessagesMB"; 644 | } else { 645 | print STDOUT "
Folder"; 646 | } 647 | 648 | my $total_msgs; 649 | my $total_bytes; 650 | # foreach $_ ( split(/\n/, `./list_imap_folders.pl -S $sourceHost/$sourceUser/$sourcePwd `) ) { 651 | 652 | foreach $_ ( split(/\n/, `./list_imap_folders.pl -s -S $sourceHost/$sourceUser/$sourcePwd 2&>1`) ) { 653 | Log("screen line $_"); 654 | 655 | next if /Can't open list_imap_folders|=================/; 656 | next if /Mailbox delimiter|Mailbox prefix/; 657 | next if /^$sourceUser/; 658 | 659 | Log("show_sizes = $show_sizes"); 660 | if ( $show_sizes == 1 ) { 661 | Log("Getting the sizes"); 662 | /(.+)\s+\((.+) msgs,\s+(.+)\s+MB\)/; 663 | $folder = $1; 664 | $msgs = $2; 665 | $bytes = $3; 666 | $total_msgs += $2; 667 | $total_bytes += $3; 668 | commafy( \$msgs ); 669 | print STDOUT "
$folder$msgs$bytes\n" unless $folder eq ''; 670 | } else { 671 | Log("don't get the sizes"); 672 | print STDOUT "
$_"; 673 | } 674 | 675 | } 676 | commafy( \$total_msgs ); 677 | commafy( \$total_bytes ); 678 | Log("print the totals"); 679 | 680 | print STDOUT "
Total$total_msgs$total_bytes\n"; 681 | print STDOUT "
\n"; 682 | 683 | Log("done"); 684 | } 685 | -------------------------------------------------------------------------------- /imapcopy.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | IMAPCOPY 4 | 5 | 6 |
7 | 8 | 25 | 26 | 27 | 29 | 30 |

IMAPCOPY

31 | 32 |
33 | 34 | 35 | 36 | 40 | 43 | 47 |
Source server 37 | 38 | 39 |
Destination server 41 | 42 |
Source username 44 | Source password 45 | 46 |
Destination username 48 | Destination password 49 |
50 | 51 |

52 | 53 | 54 | 58 | 62 | 66 | 70 |
Copy only these folders 55 | folder1,folder2,... 56 | 57 |
Exclude these folders 59 | folder1,folder2,... 60 | 61 |
After date 63 | DD-MMM-YYYY 64 | 65 |
Before Date 67 | DD-MMM-YYYY 68 | 69 |
Update Mode 71 |
72 |
73 | 74 |

75 | 76 | 77 | 78 |

79 | After clicking on Submit the copy process will start. 80 | Depending on the size of your 81 | account it will take a few minutes or more to copy everything over. 82 | When it finishes you will receive an e-mail notifying of the results. 83 | 84 |
85 | 86 | 87 | -------------------------------------------------------------------------------- /imapcopy.log.debug: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andrewnimmo/rick-sanders-imap-tools/20b0f5071f8d70e252bbc055001386d939cca61f/imapcopy.log.debug -------------------------------------------------------------------------------- /imapcopy.wildcard.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | IMAPCOPY 4 | 5 | 6 |
7 | 8 | 25 | 26 | 27 | 29 | 30 |

IMAPCOPY

31 | 32 |

33 | EN 34 |

35 | 36 |
37 | 38 | 39 | 40 | 41 | 42 | 43 | 47 | 48 | 49 | 50 |
Username 44 | Password 45 | 46 |
Update Mode 51 |
52 |
53 | 54 |

55 | 56 | 57 | 58 |

59 | After clicking on Submit the copy process will start. 60 | Depending on the size of your 61 | account it will take a few minutes or more to copy everything over. 62 | When it finishes you will receive an e-mail notifying of the results. 63 | 64 |
65 | 66 | 67 | -------------------------------------------------------------------------------- /imapcopy_de.html: -------------------------------------------------------------------------------- 1 | 2 | IMAPCOPY 3 | 4 | 5 |
6 | 7 | 24 | 25 | 26 | 28 | 29 |

IMAPCOPY

30 | 31 |

32 | EN 33 | DE 34 |

35 | 36 |
37 | 38 | 39 | 40 | 44 | 47 | 51 |
Quellserver: 41 | 42 | 43 |
Zielserver: 45 | 46 |
Benutzername Quellserver: 48 | Passwort Quellserver: 49 | 50 |
Benutzername Zielserver: 52 | Passwort Zielserver: 53 |
54 | 55 |

56 | 57 | 58 | 62 | 66 | 70 | 74 |
Nur diese Ordner kopieren: 59 | Ordner1,Ordner2, ... 60 | 61 |
Diese Ordner nicht kopieren: 63 | Ordner1,Ordner2, ... 64 | 65 |
Nachrichten kopieren nach Datum 67 | TT-MMM-JJJJ 68 | 69 |
Nachrichten kopieren vor Datum 71 | TT-MMM-JJJJ 72 | 73 |
Update Mode
(nur noch nicht kopierte Nachrichten) 75 |
76 |
77 | 78 |

79 | 80 | 81 | 82 |

83 | Nach Start imapcopy wird der Kopierprozess gestartet. Abhängig von der Größe der zu kopierenden Accounts kann es einige Minuten oder länger dauern bis alle Nachrichten kopiert sind. Am Ende des Kopierprozesses erhalten Sie eine Nachricht per E-Mail. 84 |
85 | 86 | 87 | -------------------------------------------------------------------------------- /imapcopy_en.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | IMAPCOPY 4 | 5 | 6 |
7 | 8 | 25 | 26 | 27 | 29 | 30 |

IMAPCOPY

31 | 32 |

33 | EN 34 | DE 35 |

36 | 37 |
38 | 39 | 40 | 41 | 45 | 48 | 52 |
Source server 42 | 43 | 44 |
Destination server 46 | 47 |
Source username 49 | Source password 50 | 51 |
Destination username 53 | Destination password 54 |
55 | 56 |

57 | 58 | 59 | 63 | 67 | 71 | 75 |
Copy only these folders 60 | folder1,folder2,... 61 | 62 |
Exclude these folders 64 | folder1,folder2,... 65 | 66 |
After date 68 | DD-MMM-YYYY 69 | 70 |
Before Date 72 | DD-MMM-YYYY 73 | 74 |
Update Mode 76 |
77 |
78 | 79 |

80 | 81 | 82 | 83 |

84 | After clicking on Submit the copy process will start. 85 | Depending on the size of your 86 | account it will take a few minutes or more to copy everything over. 87 | When it finishes you will receive an e-mail notifying of the results. 88 | 89 |
90 | 91 | 92 | -------------------------------------------------------------------------------- /imapcopy_notify.admin: -------------------------------------------------------------------------------- 1 | mx-biz.mail.am0.yahoodns.net:support@hopehealthsystems.com 2 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | IMAP Tools 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 19 | 20 | 21 |

IMAP Tools 22 |            23 | 24 |

25 | 26 | Notice: Due to the death of Rick Sanders IMAP Tools is no longer 27 | in business. Purchasers of the IMAP Tools are released from any licensing contraints. 28 | Please feel free to re-distribute the IMAP Tools as you see fit.

29 | 30 | Thanks for your business and best wishes to everyone!
 31 |

32 | 33 |

34 | Updated: December 28, 2016
35 | 36 |
37 | Welcome to the IMAP Tools Website! 38 |            39 | Rick Sanders   rfs9999@earthlink.net 40 |            41 | 42 |

43 | Subscribe to IMAP-Tools mailing list 44 |         45 | Search the mailing list archives 46 |         47 | View the mailing list archives 48 |
49 | 50 |

51 | 52 | 53 | What is the IMAP Tools Set? 54 | It is a set of Perl programs for use with IMAP 55 | servers. 56 | IMAP Tools enable you to do a great many things including the following: 57 |
58 |

59 | 60 | 61 |

  • Copy a user's folders and messages to a new server 62 | (imapcopy.pl) 63 |
  • Bulk migration of hundreds or thousands of users to a new hosting server 64 | (migrateIMAP.pl) 65 |
  • Move messages between folders based on a set of rules 66 | (imapfilter.pl) 67 |
  • Back up and restore IMAP accounts 68 | (imapdump.pl and 69 | dumptoIMAP.pl) 70 |
  • Synchronize accounts on two different IMAP servers 71 | (imapsync.pl) 72 |
  • Purge duplicate messages 73 | (delIMAPdups.pl) 74 |
  • Load messages from Maildir servers into IMAP and vice-versa 75 | (maildir_to_imap.pl and 76 | imap_to_maildir.pl) 77 |
  • Load messages from Mbox servers into IMAP and vice-versa 78 | (IMAPtoMbox.pl and 79 | MboxtoIMAP.pl) 80 |
  • Do you have a Kerio Connect server? Take a look at the 81 | Kerio Archiver 82 |
  • and a lot of other things 83 | 84 | 85 | 86 |

    87 | What is in the IMAP Tools Set? 88 |
    89 | IMAP Tools User Guide     90 |
    91 | IMAP Tools FAQ 92 |
    93 | Do you have a question about the IMAP Tools? 94 |
    95 | Examples 96 |
    97 | Read comments from IMAP Tools users. 98 |
    99 | 100 | Custom IMAP-enabled application development 101 | 102 | 103 | 104 |
    105 | 106 |
    107 | Notes: 108 | 109 |
  • Change History 110 |
  • Release Notes 111 |
  • Admin Mode 112 |
  • SSL Support 113 |
  • OAUTH2 Support <=== NEW 114 |
  • CRAM-MD5 Logins 115 |
  • IMAP debugging and tracing 116 | 117 | 118 |

    119 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /license.txt: -------------------------------------------------------------------------------- 1 | 2 | ############################################################################ 3 | # Copyright (c) 2012 Rick Sanders # 4 | # # 5 | # Permission to use, copy, and modify this software for any purpose # 6 | # is hereby granted, provided that the above copyright notice and this # 7 | # permission notice appear in all copies. # 8 | # # 9 | # This software is not assignable and may not be resold without the # 10 | # express written permission of the author. The sofware can be hosted # 11 | # on any or all of the license holder's servers and sites. # 12 | # # 13 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES # 14 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF # 15 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR # 16 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES # 17 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN # 18 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF # 19 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. # 20 | ############################################################################ 21 | 22 | -------------------------------------------------------------------------------- /mbxIMAPsync.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Socket; 4 | use FileHandle; 5 | use Fcntl; 6 | use Getopt::Std; 7 | use MIME::Base64 qw(encode_base64 decode_base64); 8 | 9 | ###################################################################### 10 | # Program name mbxIMAPsync.pl # 11 | # Written by Rick Sanders # 12 | # Date 12 Feb 2004 # 13 | # # 14 | # Description # 15 | # # 16 | # mbxIMAPsync is used to synchronize the contents of a Unix # 17 | # mailfiles with an IMAP mailbox. The user supplies the location # 18 | # & name of the Unix mailbox (eg /var/mail/rfs) and the hostname, # 19 | # username, & password of the IMAP account along with the name # 20 | # of the IMAP mailbox. For example: # 21 | # # 22 | # ./mbxIMAPsync.pl -f /var/mail/rfs -i imapsrv/rfs/mypass -m INBOX # 23 | # # 24 | # mbxIMAPsync compares the messages in the mailfile with those in # 25 | # the IMAP mailbox by Message-Id and adds the ones in the mailfile # 26 | # which are not in the IMAP mailbox. Then it looks for messages # 27 | # in the IMAP mailbox which are not in the mailfile and removes # 28 | # them from the IMAP mailbox. # 29 | # # 30 | # See the Usage() for available options. # 31 | ###################################################################### 32 | 33 | init(); 34 | 35 | connectToHost($imapHost, \$conn ); 36 | login($imapUser,$imapPwd, $conn ); 37 | 38 | # Get list of msgs in the mailfile by Message-Id 39 | 40 | $added=$purged=0; 41 | print STDOUT "Processing $mailfile\n"; 42 | print STDOUT "Checking for messages to add\n"; 43 | @msgs = readMbox( $mailfile ); 44 | foreach $msg ( @msgs ) { 45 | @msgid = grep( /^Message-ID:/i, @$msg ); 46 | ($label,$msgid) = split(/:/, $msgid[0]); 47 | chomp $msgid; 48 | trim( *msgid ); 49 | $mailfileMsgs{"$msgid"} = '1'; 50 | push( @sourceMsgs, $msgid ); 51 | 52 | if ( !findMsg( $msgid, $mbx, $conn ) ) { 53 | # print STDOUT "Need to add msgid >$msgid<\n"; 54 | my $message; 55 | 56 | foreach $_ ( @$msg ) { chop $_; $message .= "$_\r\n"; } 57 | 58 | if ( insertMsg($mbx, \$message, $flags, $date, $conn ) ) { 59 | $added++; 60 | print STDOUT " Added $msgid\n"; 61 | } 62 | } 63 | } 64 | 65 | # Remove any messages from the IMAP mailbox that no longer 66 | # exist in the mailfile 67 | 68 | print STDOUT "Checking for messages to purge\n"; 69 | getMsgList( $mbx, \@imapMsgs, $conn ); 70 | foreach $msgid ( @imapMsgs ) { 71 | if ( $mailfileMsgs{"$msgid"} eq '' ) { 72 | if ( deleteMsg($msgid, $mbx, $conn ) ) { 73 | Log(" Marked $msgid for deletion"); 74 | print STDOUT " Marked msgid $msgid for deletion\n"; 75 | $deleted++; 76 | } 77 | } 78 | } 79 | 80 | if ( $deleted ) { 81 | # Need to purge the deleted messages 82 | $purged = expungeMbx( $mbx, $conn ); 83 | } 84 | 85 | Log("Done"); 86 | Log("Added $added messages to IMAP mailbox $mbx"); 87 | Log("Purged $purged messages from IMAP mailbox $mbx"); 88 | 89 | print STDOUT "\nAdded $added messages to IMAP mailbox $mbx\n"; 90 | print STDOUT "Purged $purged messages from IMAP mailbox $mbx\n"; 91 | 92 | exit; 93 | 94 | 95 | sub init { 96 | 97 | if ( ! getopts('f:m:i:L:dxA:F:I') ) { 98 | usage(); 99 | exit; 100 | } 101 | 102 | ($imapHost,$imapUser,$imapPwd) = split(/\//, $opt_i); 103 | $mailfile = $opt_f; 104 | $mbx = $opt_m; 105 | $logfile = $opt_L; 106 | $admin_user = $opt_A; 107 | $msgs_per_folder = $opt_F; 108 | $debug = 1 if $opt_d; 109 | $showIMAP = 1; 110 | 111 | if ( $logfile ) { 112 | if ( ! open (LOG, ">> $logfile") ) { 113 | print "Can't open logfile $logfile: $!\n"; 114 | $logfile = ''; 115 | } 116 | } 117 | Log("\nThis is mbxIMAPsync\n"); 118 | 119 | if ( !-e $mailfile ) { 120 | Log("$mailfile does not exist"); 121 | exit; 122 | } 123 | 124 | # Determine whether we have SSL support via openSSL and IO::Socket::SSL 125 | $ssl_installed = 1; 126 | eval 'use IO::Socket::SSL'; 127 | if ( $@ ) { 128 | $ssl_installed = 0; 129 | } 130 | } 131 | 132 | sub usage { 133 | 134 | print "Usage: mbxIMAPsync.pl\n"; 135 | print " -f \n"; 136 | print " -i imapHost/imapUser/imapPassword\n"; 137 | print " -m \n"; 138 | print " [-L ]\n"; 139 | print " [-d debug]\n"; 140 | 141 | } 142 | 143 | sub readMbox { 144 | 145 | my $file = shift; 146 | my @mail = (); 147 | my $mail = []; 148 | my $blank = 1; 149 | local *FH; 150 | local $_; 151 | 152 | Log("Reading the mailfile") if $debug; 153 | open(FH,"< $file") or die "Can't open $file"; 154 | 155 | while() { 156 | if($blank && /\AFrom .*\d{4}/) { 157 | push(@mail, $mail) if scalar(@{$mail}); 158 | $mail = [ $_ ]; 159 | $blank = 0; 160 | } 161 | else { 162 | $blank = m#\A\Z#o ? 1 : 0; 163 | push(@{$mail}, $_); 164 | } 165 | } 166 | 167 | push(@mail, $mail) if scalar(@{$mail}); 168 | close(FH); 169 | 170 | return wantarray ? @mail : \@mail; 171 | } 172 | 173 | sub Log { 174 | 175 | my $line = shift; 176 | my $msg; 177 | 178 | ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime (time); 179 | $msg = sprintf ("%.2d-%.2d-%.4d.%.2d:%.2d:%.2d %s", 180 | $mon + 1, $mday, $year + 1900, $hour, $min, $sec, $line); 181 | 182 | if ( $logfile ) { 183 | print LOG "$msg\n"; 184 | } 185 | print STDERR "$line\n"; 186 | 187 | } 188 | 189 | # Make a connection to a IMAP host 190 | 191 | sub connectToHost { 192 | 193 | my $host = shift; 194 | my $conn = shift; 195 | 196 | Log("Connecting to $host") if $debug; 197 | 198 | ($host,$port) = split(/:/, $host); 199 | $port = 143 unless $port; 200 | 201 | # We know whether to use SSL for ports 143 and 993. For any 202 | # other ones we'll have to figure it out. 203 | $mode = sslmode( $host, $port ); 204 | 205 | if ( $mode eq 'SSL' ) { 206 | unless( $ssl_installed == 1 ) { 207 | warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 208 | Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 209 | exit; 210 | } 211 | Log("Attempting an SSL connection") if $debug; 212 | $$conn = IO::Socket::SSL->new( 213 | Proto => "tcp", 214 | SSL_verify_mode => 0x00, 215 | PeerAddr => $host, 216 | PeerPort => $port, 217 | Domain => AF_INET, 218 | ); 219 | 220 | unless ( $$conn ) { 221 | $error = IO::Socket::SSL::errstr(); 222 | Log("Error connecting to $host: $error"); 223 | exit; 224 | } 225 | } else { 226 | # Non-SSL connection 227 | Log("Attempting a non-SSL connection") if $debug; 228 | $$conn = IO::Socket::INET->new( 229 | Proto => "tcp", 230 | PeerAddr => $host, 231 | PeerPort => $port, 232 | ); 233 | 234 | unless ( $$conn ) { 235 | Log("Error connecting to $host:$port: $@"); 236 | warn "Error connecting to $host:$port: $@"; 237 | exit; 238 | } 239 | } 240 | # Log("Connected to $host on port $port"); 241 | 242 | } 243 | 244 | sub sslmode { 245 | 246 | my $host = shift; 247 | my $port = shift; 248 | my $mode; 249 | 250 | # Determine whether to make an SSL connection 251 | # to the host. Return 'SSL' if so. 252 | 253 | if ( $port == 143 ) { 254 | # Standard non-SSL port 255 | return ''; 256 | } elsif ( $port == 993 ) { 257 | # Standard SSL port 258 | return 'SSL'; 259 | } 260 | 261 | unless ( $ssl_installed ) { 262 | # We don't have SSL installed on this machine 263 | return ''; 264 | } 265 | 266 | # For any other port we need to determine whether it supports SSL 267 | 268 | my $conn = IO::Socket::SSL->new( 269 | Proto => "tcp", 270 | SSL_verify_mode => 0x00, 271 | PeerAddr => $host, 272 | PeerPort => $port, 273 | ); 274 | 275 | if ( $conn ) { 276 | close( $conn ); 277 | $mode = 'SSL'; 278 | } else { 279 | $mode = ''; 280 | } 281 | 282 | return $mode; 283 | } 284 | 285 | # 286 | # login in at the source host with the user's name and password 287 | # 288 | sub login { 289 | 290 | my $user = shift; 291 | my $pwd = shift; 292 | my $conn = shift; 293 | 294 | if ( $admin_user ) { 295 | ($admin_user,$admin_pwd) = split(/:/, $admin_user); 296 | login_plain( $user, $admin_user, $admin_pwd, $conn ) or exit; 297 | return 1; 298 | } 299 | 300 | if ( $pwd =~ /^oauth2:(.+)/i ) { 301 | $token = $1; 302 | Log("password is an OAUTH2 token"); 303 | login_xoauth2( $user, $token, $conn ); 304 | return 1; 305 | } 306 | 307 | Log("Logging in as $user") if $debug; 308 | sendCommand ($conn, "1 LOGIN $user $pwd"); 309 | while (1) { 310 | readResponse ( $conn ); 311 | if ($response =~ /^1 OK/i) { 312 | last; 313 | } 314 | elsif ($response =~ /NO/) { 315 | Log ("unexpected LOGIN response: $response"); 316 | return 0; 317 | } 318 | } 319 | Log("Logged in as $user") if $debug; 320 | 321 | return 1; 322 | } 323 | 324 | # login_plain 325 | # 326 | # login in at the source host with the user's name and password. If provided 327 | # with administrator credential, use them as this eliminates the need for the 328 | # user's password. 329 | # 330 | sub login_plain { 331 | 332 | my $user = shift; 333 | my $admin = shift; 334 | my $pwd = shift; 335 | my $conn = shift; 336 | 337 | # Do an AUTHENTICATE = PLAIN. If an admin user has been provided then use it. 338 | 339 | if ( !$admin ) { 340 | # Log in as the user 341 | $admin = $user 342 | } 343 | 344 | $login_str = sprintf("%s\x00%s\x00%s", $user,$admin,$pwd); 345 | $login_str = encode_base64("$login_str", ""); 346 | $len = length( $login_str ); 347 | 348 | # sendCommand ($conn, "1 AUTHENTICATE \"PLAIN\" {$len}" ); 349 | sendCommand ($conn, "1 AUTHENTICATE PLAIN" ); 350 | 351 | my $loops; 352 | while (1) { 353 | readResponse ( $conn ); 354 | last if $response =~ /\+/; 355 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 356 | Log ("unexpected LOGIN response: $response"); 357 | exit; 358 | } 359 | $last if $loops++ > 5; 360 | } 361 | 362 | sendCommand ($conn, "$login_str" ); 363 | my $loops; 364 | while (1) { 365 | readResponse ( $conn ); 366 | 367 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 368 | # The destination is an Exchange server 369 | $exchange = 1; 370 | Log("The destination is an Exchange server"); 371 | } 372 | 373 | last if $response =~ /^1 OK/i; 374 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 375 | Log ("unexpected LOGIN response: $response"); 376 | exit; 377 | } 378 | $last if $loops++ > 5; 379 | } 380 | 381 | return 1; 382 | 383 | } 384 | 385 | # login_xoauth2 386 | # 387 | # login in at the source host with the user's name and an XOAUTH2 token. 388 | # 389 | sub login_xoauth2 { 390 | 391 | my $user = shift; 392 | my $token = shift; 393 | my $conn = shift; 394 | 395 | # Do an AUTHENTICATE = XOAUTH2 login 396 | 397 | $login_str = encode_base64("user=". $user ."\x01auth=Bearer ". $token ."\x01\x01", ''); 398 | sendCommand ($conn, "1 AUTHENTICATE XOAUTH2 $login_str" ); 399 | 400 | my $loops; 401 | while (1) { 402 | readResponse ( $conn ); 403 | if ( $response =~ /^\+ (.+)/ ) { 404 | $error = decode_base64( $1 ); 405 | Log("XOAUTH authentication as $user failed: $error"); 406 | return 0; 407 | } 408 | last if $response =~ /^1 OK/; 409 | if ($response =~ /^1 NO|^1 BAD|^\* BYE|failed/i) { 410 | Log ("unexpected LOGIN response: $response"); 411 | return 0; 412 | } 413 | $last if $loops++ > 5; 414 | } 415 | 416 | Log("login complete") if $debug; 417 | 418 | return 1; 419 | 420 | } 421 | 422 | 423 | # logout 424 | # 425 | # log out from the host 426 | # 427 | sub logout { 428 | 429 | my $conn = shift; 430 | 431 | ++$lsn; 432 | undef @response; 433 | sendCommand ($conn, "$lsn LOGOUT"); 434 | while ( 1 ) { 435 | readResponse ($conn); 436 | if ( $response =~ /^$lsn OK/i ) { 437 | last; 438 | } 439 | elsif ( $response !~ /^\*/ ) { 440 | Log ("unexpected LOGOUT response: $response"); 441 | last; 442 | } 443 | } 444 | close $conn; 445 | return; 446 | } 447 | 448 | # readResponse 449 | # 450 | # This subroutine reads and formats an IMAP protocol response from an 451 | # IMAP server on a specified connection. 452 | # 453 | 454 | sub readResponse 455 | { 456 | local($fd) = shift @_; 457 | 458 | $response = <$fd>; 459 | chop $response; 460 | $response =~ s/\r//g; 461 | push (@response,$response); 462 | Log ("<< $response",2) if $showIMAP; 463 | } 464 | 465 | # 466 | # sendCommand 467 | # 468 | # This subroutine formats and sends an IMAP protocol command to an 469 | # IMAP server on a specified connection. 470 | # 471 | 472 | sub sendCommand 473 | { 474 | local($fd) = shift @_; 475 | local($cmd) = shift @_; 476 | 477 | print $fd "$cmd\r\n"; 478 | 479 | if ($showIMAP) { Log (">> $cmd",2); } 480 | } 481 | 482 | # 483 | sub insertMsg { 484 | 485 | my $mbx = shift; 486 | my $message = shift; 487 | my $flags = shift; 488 | my $date = shift; 489 | my $conn = shift; 490 | my ($lsn,$lenx); 491 | 492 | Log(" Inserting message into mailbox $mbx") if $debug; 493 | $lenx = length($$message); 494 | 495 | # Create the mailbox unless we have already done so 496 | ++$lsn; 497 | if ($destMbxs{"$mbx"} eq '') { 498 | Log("creating mailbox $mbx") if $debug; 499 | sendCommand (IMAP, "$lsn CREATE \"$mbx\""); 500 | while ( 1 ) { 501 | readResponse (IMAP); 502 | if ( $response =~ /^1 OK/i ) { 503 | last; 504 | } 505 | elsif ( $response !~ /^\*/ ) { 506 | if (!($response =~ /already exists|reserved mailbox name/i)) { 507 | Log ("WARNING: $response"); 508 | } 509 | last; 510 | } 511 | } 512 | } 513 | 514 | $destMbxs{"$mbx"} = '1'; 515 | 516 | ++$lsn; 517 | $flags =~ s/\\Recent//i; 518 | 519 | # &sendCommand (IMAP, "$lsn APPEND \"$mbx\" ($flags) \"$date\" \{$lenx\}"); 520 | sendCommand (IMAP, "$lsn APPEND \"$mbx\" \{$lenx\}"); 521 | readResponse (IMAP); 522 | if ( $response !~ /^\+/ ) { 523 | Log ("unexpected APPEND response: $response"); 524 | # next; 525 | push(@errors,"Error appending message to $mbx for $user"); 526 | return 0; 527 | } 528 | 529 | print IMAP "$$message\r\n"; 530 | 531 | undef @response; 532 | while ( 1 ) { 533 | readResponse (IMAP); 534 | if ( $response =~ /^$lsn OK/i ) { 535 | last; 536 | } 537 | elsif ( $response !~ /^\*/ ) { 538 | Log ("unexpected APPEND response: $response"); 539 | # next; 540 | return 0; 541 | } 542 | } 543 | 544 | return 1; 545 | } 546 | 547 | # getMsgList 548 | # 549 | # Get a list of the user's messages in the indicated mailbox on 550 | # the IMAP host 551 | # 552 | sub getMsgList { 553 | 554 | my $mailbox = shift; 555 | my $msgs = shift; 556 | my $conn = shift; 557 | my $seen; 558 | my $empty; 559 | my $msgnum; 560 | 561 | Log("Getting list of msgs in $mailbox") if $debug; 562 | trim( *mailbox ); 563 | sendCommand ($conn, "1 EXAMINE \"$mailbox\""); 564 | undef @response; 565 | $empty=0; 566 | while ( 1 ) { 567 | readResponse ( $conn ); 568 | if ( $response =~ / 0 EXISTS/i ) { $empty=1; } 569 | if ( $response =~ /^1 OK/i ) { 570 | # print STDERR "response $response\n"; 571 | last; 572 | } 573 | elsif ( $response !~ /^\*/ ) { 574 | Log ("unexpected response: $response"); 575 | # print STDERR "Error: $response\n"; 576 | return 0; 577 | } 578 | } 579 | 580 | sendCommand ( $conn, "1 FETCH 1:* (uid flags internaldate body[header.fields (Message-Id)])"); 581 | undef @response; 582 | while ( 1 ) { 583 | readResponse ( $conn ); 584 | if ( $response =~ /^1 OK/i ) { 585 | # print STDERR "response $response\n"; 586 | last; 587 | } 588 | elsif ( $XDXDXD ) { 589 | Log ("unexpected response: $response"); 590 | Log ("Unable to get list of messages in this mailbox"); 591 | push(@errors,"Error getting list of $user's msgs"); 592 | return 0; 593 | } 594 | } 595 | 596 | # Get a list of the msgs in the mailbox 597 | # 598 | undef @msgs; 599 | undef $flags; 600 | for $i (0 .. $#response) { 601 | $seen=0; 602 | $_ = $response[$i]; 603 | 604 | last if /OK FETCH complete/; 605 | 606 | if ( $response[$i] =~ /FETCH \(UID / ) { 607 | $response[$i] =~ /\* ([^FETCH \(UID]*)/; 608 | $msgnum = $1; 609 | } 610 | 611 | if ($response[$i] =~ /FLAGS/) { 612 | # Get the list of flags 613 | $response[$i] =~ /FLAGS \(([^\)]*)/; 614 | $flags = $1; 615 | $flags =~ s/\\Recent//i; 616 | } 617 | if ( $response[$i] =~ /INTERNALDATE ([^\)]*)/ ) { 618 | ### $response[$i] =~ /INTERNALDATE (.+) ([^BODY]*)/i; 619 | $response[$i] =~ /INTERNALDATE (.+) BODY/i; 620 | $date = $1; 621 | $date =~ s/"//g; 622 | } 623 | if ( $response[$i] =~ /^Message-Id:/i ) { 624 | ($label,$msgid) = split(/: /, $response[$i]); 625 | push (@$msgs,$msgid); 626 | } 627 | } 628 | } 629 | 630 | # trim 631 | # 632 | # remove leading and trailing spaces from a string 633 | sub trim { 634 | 635 | local (*string) = @_; 636 | 637 | $string =~ s/^\s+//; 638 | $string =~ s/\s+$//; 639 | 640 | return; 641 | } 642 | 643 | 644 | sub findMsg { 645 | 646 | my $msgid = shift; 647 | my $mbx = shift; 648 | my $conn = shift; 649 | my $msgnum; 650 | my $noSuchMbx; 651 | 652 | Log("Searching for $msgid in $mbx") if $debug; 653 | sendCommand ( $conn, "1 SELECT \"$mbx\""); 654 | while (1) { 655 | readResponse ($conn); 656 | if ( $response =~ /^1 NO/ ) { 657 | $noSuchMbx = 1; 658 | last; 659 | } 660 | last if $response =~ /^1 OK/; 661 | } 662 | return '' if $noSuchMbx; 663 | 664 | Log("Search for $msgid") if $debug; 665 | sendCommand ( $conn, "1 SEARCH header Message-Id \"$msgid\""); 666 | while (1) { 667 | readResponse ($conn); 668 | if ( $response =~ /\* SEARCH /i ) { 669 | ($dmy, $msgnum) = split(/\* SEARCH /i, $response); 670 | ($msgnum) = split(/ /, $msgnum); 671 | } 672 | 673 | last if $response =~ /^1 OK/; 674 | last if $response =~ /complete/i; 675 | } 676 | 677 | if ( $msgnum ) { 678 | Log("Message exists") if $debug; 679 | } else { 680 | Log("Message does not exist") if $debug; 681 | } 682 | 683 | return $msgnum; 684 | } 685 | 686 | sub deleteMsg { 687 | 688 | my $msgid = shift; 689 | my $mbx = shift; 690 | my $conn = shift; 691 | my $rc; 692 | 693 | Log("Deleting message $msgid") if $debug; 694 | $msgnum = findMsg( $msgid, $mbx, $conn ); 695 | 696 | sendCommand ( $conn, "1 STORE $msgnum +FLAGS (\\Deleted)"); 697 | while (1) { 698 | readResponse ($conn); 699 | if ( $response =~ /^1 OK/i ) { 700 | $rc = 1; 701 | Log(" Marked $msgid for delete"); 702 | last; 703 | } 704 | 705 | if ( $response =~ /^1 BAD|^1 NO/i ) { 706 | Log("Error setting \Deleted flag for msg $msgnum: $response"); 707 | $rc = 0; 708 | last; 709 | } 710 | } 711 | 712 | return $rc; 713 | 714 | } 715 | 716 | sub expungeMbx { 717 | 718 | my $mbx = shift; 719 | my $conn = shift; 720 | my $purged=0; 721 | 722 | Log("Purging $mbx") if $debug; 723 | sendCommand ( $conn, "1 SELECT \"$mbx\""); 724 | while (1) { 725 | readResponse ($conn); 726 | last if $response =~ /^1 OK/; 727 | 728 | if ( $response =~ /^1 NO|^1 BAD/i ) { 729 | Log("Error selecting mailbox $mbx: $response"); 730 | last; 731 | } 732 | } 733 | 734 | sendCommand ( $conn, "1 EXPUNGE"); 735 | while (1) { 736 | readResponse ($conn); 737 | last if $response =~ /^1 OK/; 738 | $purged++ if $response =~ /EXPUNGE/i; 739 | 740 | if ( $response =~ /^1 BAD|^1 NO/i ) { 741 | print STDOUT "Error expunging messages: $response\n"; 742 | last; 743 | } 744 | } 745 | 746 | return $purged; 747 | 748 | } 749 | 750 | -------------------------------------------------------------------------------- /purgeMbx.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # $Header: /mhub4/sources/imap-tools/purgeMbx.pl,v 1.9 2015/12/24 22:25:13 rick Exp $ 4 | 5 | ############################################################################ 6 | # Program name purgeMbx.pl # 7 | # Written by Rick Sanders # 8 | # Date 5/24/2008 # 9 | # # 10 | # Description # 11 | # # 12 | # This script deletes all of the messages in a user's IMAP # 13 | # mailbox. # 14 | # # 15 | # purgeMbx.pl is called like this: # 16 | # ./purgeMbx.pl -s host/user/password -m # 17 | # # 18 | # Note that the mailbox name is case-sensitive. # 19 | # # 20 | # Optional arguments: # 21 | # -d debug # 22 | # -L # 23 | ############################################################################ 24 | 25 | ############################################################################ 26 | # Copyright (c) 2008 Rick Sanders # 27 | # # 28 | # Permission to use, copy, modify, and distribute this software for any # 29 | # purpose with or without fee is hereby granted, provided that the above # 30 | # copyright notice and this permission notice appear in all copies. # 31 | # # 32 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES # 33 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF # 34 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR # 35 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES # 36 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN # 37 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF # 38 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. # 39 | ############################################################################ 40 | 41 | use Socket; 42 | use FileHandle; 43 | use Fcntl; 44 | use Getopt::Std; 45 | use IO::Socket; 46 | use MIME::Base64 qw(encode_base64 decode_base64 ); 47 | 48 | ################################################################# 49 | # Main program. # 50 | ################################################################# 51 | 52 | init(); 53 | 54 | sigprc(); 55 | 56 | # Get list of all messages on the source host by Message-Id 57 | # 58 | connectToHost($host, \$conn); 59 | login($user,$pwd, $conn) or exit; 60 | 61 | if ( $mbx eq '*' ) { 62 | @mailboxes = listMailboxes( '*', $conn); 63 | } else { 64 | push( @mailboxes, $mbx ); 65 | } 66 | 67 | foreach $mbx ( @mailboxes ) { 68 | Log("Purging the \"$mbx\" mailbox"); 69 | @sourceMsgs = (); 70 | getMsgList( $mbx, \@msgs, $conn ); 71 | Log("$mbx mailbox is empty") unless @msgs; 72 | foreach $msgnum ( @msgs ) { 73 | $total++; 74 | deleteMsg( $msgnum, $conn ); 75 | } 76 | expungeMbx( $mbx, $conn ) if @msgs; 77 | 78 | Log("$total messages were deleted from \"$mbx\" mailbox"); 79 | } 80 | 81 | logout( $conn ); 82 | 83 | exit; 84 | 85 | 86 | sub init { 87 | 88 | $version = 'V1.0.1'; 89 | $os = $ENV{'OS'}; 90 | 91 | processArgs(); 92 | 93 | # Determine whether we have SSL support via openSSL and IO::Socket::SSL 94 | $ssl_installed = 1; 95 | eval 'use IO::Socket::SSL'; 96 | if ( $@ ) { 97 | $ssl_installed = 0; 98 | } 99 | 100 | $timeout = 60 unless $timeout; 101 | 102 | # Open the logFile 103 | # 104 | if ( $logfile ) { 105 | if ( !open(LOG, ">> $logfile")) { 106 | print STDOUT "Can't open $logfile: $!\n"; 107 | } 108 | select(LOG); $| = 1; 109 | } 110 | Log("\n$0 starting"); 111 | $total=0; 112 | 113 | } 114 | 115 | # 116 | # sendCommand 117 | # 118 | # This subroutine formats and sends an IMAP protocol command to an 119 | # IMAP server on a specified connection. 120 | # 121 | 122 | sub sendCommand 123 | { 124 | local($fd) = shift @_; 125 | local($cmd) = shift @_; 126 | 127 | print $fd "$cmd\r\n"; 128 | 129 | if ($showIMAP) { Log (">> $cmd",2); } 130 | } 131 | 132 | # 133 | # readResponse 134 | # 135 | # This subroutine reads and formats an IMAP protocol response from an 136 | # IMAP server on a specified connection. 137 | # 138 | 139 | sub readResponse 140 | { 141 | local($fd) = shift @_; 142 | 143 | $response = <$fd>; 144 | chop $response; 145 | $response =~ s/\r//g; 146 | push (@response,$response); 147 | if ($showIMAP) { Log ("<< $response",2); } 148 | } 149 | 150 | # 151 | # Log 152 | # 153 | # This subroutine formats and writes a log message to STDERR. 154 | # 155 | 156 | sub Log { 157 | 158 | my $str = shift; 159 | 160 | # If a logile has been specified then write the output to it 161 | # Otherwise write it to STDOUT 162 | 163 | if ( $logfile ) { 164 | ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime; 165 | if ($year < 99) { $yr = 2000; } 166 | else { $yr = 1900; } 167 | $line = sprintf ("%.2d-%.2d-%d.%.2d:%.2d:%.2d %s %s\n", 168 | $mon + 1, $mday, $year + $yr, $hour, $min, $sec,$$,$str); 169 | print LOG "$line"; 170 | } 171 | print STDOUT "$str\n"; 172 | 173 | } 174 | 175 | # Make a connection to an IMAP host 176 | 177 | sub connectToHost { 178 | 179 | my $host = shift; 180 | my $conn = shift; 181 | 182 | Log("Connecting to $host") if $debug; 183 | 184 | ($host,$port) = split(/:/, $host); 185 | $port = 143 unless $port; 186 | 187 | # We know whether to use SSL for ports 143 and 993. For any 188 | # other ones we'll have to figure it out. 189 | $mode = sslmode( $host, $port ); 190 | 191 | if ( $mode eq 'SSL' ) { 192 | unless( $ssl_installed == 1 ) { 193 | warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 194 | Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 195 | exit; 196 | } 197 | Log("Attempting an SSL connection") if $debug; 198 | $$conn = IO::Socket::SSL->new( 199 | Proto => "tcp", 200 | SSL_verify_mode => 0x00, 201 | PeerAddr => $host, 202 | PeerPort => $port, 203 | Domain => AF_INET, 204 | ); 205 | 206 | unless ( $$conn ) { 207 | $error = IO::Socket::SSL::errstr(); 208 | Log("Error connecting to $host: $error"); 209 | warn("Error connecting to $host: $error"); 210 | exit; 211 | } 212 | } else { 213 | # Non-SSL connection 214 | Log("Attempting a non-SSL connection") if $debug; 215 | $$conn = IO::Socket::INET->new( 216 | Proto => "tcp", 217 | PeerAddr => $host, 218 | PeerPort => $port, 219 | ); 220 | 221 | unless ( $$conn ) { 222 | Log("Error connecting to $host:$port: $@"); 223 | warn "Error connecting to $host:$port: $@"; 224 | exit; 225 | } 226 | } 227 | Log("Connected to $host on port $port"); 228 | 229 | } 230 | 231 | sub sslmode { 232 | 233 | my $host = shift; 234 | my $port = shift; 235 | my $mode; 236 | 237 | # Determine whether to make an SSL connection 238 | # to the host. Return 'SSL' if so. 239 | 240 | if ( $port == 143 ) { 241 | # Standard non-SSL port 242 | return ''; 243 | } elsif ( $port == 993 ) { 244 | # Standard SSL port 245 | return 'SSL'; 246 | } 247 | 248 | unless ( $ssl_installed ) { 249 | # We don't have SSL installed on this machine 250 | return ''; 251 | } 252 | 253 | # For any other port we need to determine whether it supports SSL 254 | 255 | my $conn = IO::Socket::SSL->new( 256 | Proto => "tcp", 257 | SSL_verify_mode => 0x00, 258 | PeerAddr => $host, 259 | PeerPort => $port, 260 | ); 261 | 262 | if ( $conn ) { 263 | close( $conn ); 264 | $mode = 'SSL'; 265 | } else { 266 | $mode = ''; 267 | } 268 | 269 | return $mode; 270 | } 271 | 272 | 273 | # trim 274 | # 275 | # remove leading and trailing spaces from a string 276 | sub trim { 277 | 278 | local (*string) = @_; 279 | 280 | $string =~ s/^\s+//; 281 | $string =~ s/\s+$//; 282 | 283 | return; 284 | } 285 | 286 | 287 | # login 288 | # 289 | # login in at the source host with the user's name and password 290 | # 291 | sub login { 292 | 293 | my $user = shift; 294 | my $pwd = shift; 295 | my $conn = shift; 296 | 297 | if ( uc( $method ) eq 'CRAM-MD5' ) { 298 | # A CRAM-MD5 login is requested 299 | Log("login method $method"); 300 | my $rc = login_cram_md5( $user, $pwd, $conn ); 301 | return $rc; 302 | } 303 | 304 | if ( $admin_user ) { 305 | ($admin_user,$admin_pwd) = split(/:/, $admin_user); 306 | login_plain( $user, $admin_user, $admin_pwd, $conn ) or exit; 307 | return 1; 308 | } 309 | 310 | if ( $pwd =~ /^oauth2:(.+)/i ) { 311 | $token = $1; 312 | Log("password is an OAUTH2 token"); 313 | login_xoauth2( $user, $token, $conn ); 314 | return 1; 315 | } 316 | 317 | sendCommand ($conn, "1 LOGIN \"$user\" \"$pwd\""); 318 | while (1) { 319 | readResponse ( $conn ); 320 | if ($response =~ /1 OK/i) { 321 | last; 322 | } 323 | if ($response =~ /^(.+) NO|^(.+) BAD/i) { 324 | Log ("unexpected LOGIN response: $response"); 325 | return 0; 326 | } 327 | } 328 | Log("Logged in as $user") if $debug; 329 | 330 | return 1; 331 | } 332 | 333 | # login_plain 334 | # 335 | # login in at the source host with the user's name and password. If provided 336 | # with administrator credential, use them as this eliminates the need for the 337 | # user's password. 338 | # 339 | sub login_plain { 340 | 341 | my $user = shift; 342 | my $admin = shift; 343 | my $pwd = shift; 344 | my $conn = shift; 345 | 346 | # Do an AUTHENTICATE = PLAIN. If an admin user has been provided then use it. 347 | 348 | if ( !$admin ) { 349 | # Log in as the user 350 | $admin = $user 351 | } 352 | 353 | $login_str = sprintf("%s\x00%s\x00%s", $user,$admin,$pwd); 354 | $login_str = encode_base64("$login_str", ""); 355 | $len = length( $login_str ); 356 | 357 | # sendCommand ($conn, "1 AUTHENTICATE \"PLAIN\" {$len}" ); 358 | sendCommand ($conn, "1 AUTHENTICATE PLAIN" ); 359 | 360 | my $loops; 361 | while (1) { 362 | readResponse ( $conn ); 363 | last if $response =~ /\+/; 364 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 365 | Log ("unexpected LOGIN response: $response"); 366 | exit; 367 | } 368 | $last if $loops++ > 5; 369 | } 370 | 371 | sendCommand ($conn, "$login_str" ); 372 | my $loops; 373 | while (1) { 374 | readResponse ( $conn ); 375 | 376 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 377 | # The destination is an Exchange server 378 | $exchange = 1; 379 | Log("The destination is an Exchange server"); 380 | } 381 | 382 | last if $response =~ /^1 OK/i; 383 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 384 | Log ("unexpected LOGIN response: $response"); 385 | exit; 386 | } 387 | $last if $loops++ > 5; 388 | } 389 | 390 | return 1; 391 | 392 | } 393 | 394 | # login_xoauth2 395 | # 396 | # login in at the source host with the user's name and an XOAUTH2 token. 397 | # 398 | sub login_xoauth2 { 399 | 400 | my $user = shift; 401 | my $token = shift; 402 | my $conn = shift; 403 | 404 | # Do an AUTHENTICATE = XOAUTH2 login 405 | 406 | $login_str = encode_base64("user=". $user ."\x01auth=Bearer ". $token ."\x01\x01", ''); 407 | sendCommand ($conn, "1 AUTHENTICATE XOAUTH2 $login_str" ); 408 | 409 | my $loops; 410 | while (1) { 411 | readResponse ( $conn ); 412 | if ( $response =~ /^\+ (.+)/ ) { 413 | $error = decode_base64( $1 ); 414 | Log("XOAUTH authentication as $user failed: $error"); 415 | return 0; 416 | } 417 | last if $response =~ /^1 OK/; 418 | if ($response =~ /^1 NO|^1 BAD|^\* BYE|failed/i) { 419 | Log ("unexpected LOGIN response: $response"); 420 | return 0; 421 | } 422 | $last if $loops++ > 5; 423 | } 424 | 425 | Log("login complete") if $debug; 426 | 427 | return 1; 428 | 429 | } 430 | 431 | sub login_cram_md5 { 432 | 433 | my $user = shift; 434 | my $pwd = shift; 435 | my $conn = shift; 436 | 437 | sendCommand ($conn, "1 AUTHENTICATE CRAM-MD5"); 438 | while (1) { 439 | readResponse ( $conn ); 440 | last if $response =~ /^\+/; 441 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 442 | Log ("unexpected LOGIN response: $response"); 443 | return 0; 444 | } 445 | } 446 | 447 | my ($challenge) = $response =~ /^\+ (.+)/; 448 | 449 | Log("challenge $challenge") if $debug; 450 | $response = cram_md5( $challenge, $user, $pwd ); 451 | Log("response $response") if $debug; 452 | 453 | sendCommand ($conn, $response); 454 | while (1) { 455 | readResponse ( $conn ); 456 | 457 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 458 | # The destination is an Exchange server 459 | $exchange = 1; 460 | Log("The destination is an Exchange server"); 461 | } 462 | 463 | last if $response =~ /^1 OK/i; 464 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 465 | Log ("unexpected LOGIN response: $response"); 466 | return 0; 467 | } 468 | } 469 | Log("Logged in as $user") if $debug; 470 | 471 | return 1; 472 | } 473 | 474 | 475 | 476 | sub cram_md5 { 477 | 478 | my $challenge = shift; 479 | my $user = shift; 480 | my $password = shift; 481 | 482 | eval 'use Digest::HMAC_MD5 qw(hmac_md5_hex)'; 483 | use MIME::Base64 qw(decode_base64 encode_base64); 484 | 485 | # Adapated from script by Paul Makepeace , 2002-10-12 486 | # Takes user, key, and base-64 encoded challenge and returns base-64 487 | # encoded CRAM. See, 488 | # IMAP/POP AUTHorize Extension for Simple Challenge/Response: 489 | # RFC 2195 http://www.faqs.org/rfcs/rfc2195.html 490 | # SMTP Service Extension for Authentication: 491 | # RFC 2554 http://www.faqs.org/rfcs/rfc2554.html 492 | # Args: tim tanstaaftanstaaf PDE4OTYuNjk3MTcwOTUyQHBvc3RvZmZpY2UucmVzdG9uLm1jaS5uZXQ+ 493 | # should yield: dGltIGI5MTNhNjAyYzdlZGE3YTQ5NWI0ZTZlNzMzNGQzODkw 494 | 495 | my $challenge_data = decode_base64($challenge); 496 | my $hmac_digest = hmac_md5_hex($challenge_data, $password); 497 | my $response = encode_base64("$user $hmac_digest"); 498 | chomp $response; 499 | 500 | if ( $debug ) { 501 | Log("Challenge: $challenge_data"); 502 | Log("HMAC digest: $hmac_digest"); 503 | Log("CRAM Base64: $response"); 504 | } 505 | 506 | return $response; 507 | } 508 | 509 | 510 | # logout 511 | # 512 | # log out from the host 513 | # 514 | sub logout { 515 | 516 | my $conn = shift; 517 | 518 | ++$lsn; 519 | undef @response; 520 | sendCommand ($conn, "$lsn LOGOUT"); 521 | while ( 1 ) { 522 | readResponse ($conn); 523 | if ( $response =~ /^$lsn OK/i ) { 524 | last; 525 | } 526 | elsif ( $response !~ /^\*/ ) { 527 | Log ("unexpected LOGOUT response: $response"); 528 | last; 529 | } 530 | } 531 | close $conn; 532 | return; 533 | } 534 | 535 | 536 | # getMsgList 537 | # 538 | # Get a list of messages in a mailbox 539 | # 540 | sub getMsgList { 541 | 542 | my $mailbox = shift; 543 | my $msgs = shift; 544 | my $conn = shift; 545 | my $seen; 546 | my $empty; 547 | my $msgnum; 548 | my $from; 549 | my $flags; 550 | 551 | trim( *mailbox ); 552 | sendCommand ($conn, "1 SELECT \"$mailbox\""); 553 | undef @response; 554 | $empty=0; 555 | while ( 1 ) { 556 | readResponse ( $conn ); 557 | if ( $response =~ / 0 EXISTS/i ) { $empty=1; } 558 | if ( $response =~ /^1 OK/i ) { 559 | # print STDERR "response $response\n"; 560 | last; 561 | } 562 | elsif ( $response !~ /^\*/ ) { 563 | Log ("unexpected response: $response"); 564 | # print STDERR "Error: $response\n"; 565 | return 0; 566 | } 567 | } 568 | 569 | sendCommand ( $conn, "1 FETCH 1:* (uid flags internaldate body[header.fields (From Date)])"); 570 | undef @response; 571 | while ( 1 ) { 572 | readResponse ( $conn ); 573 | if ( $response =~ /^1 OK/i ) { 574 | # print STDERR "response $response\n"; 575 | last; 576 | } 577 | last if $response =~ /^1 NO|^1 BAD/; 578 | } 579 | 580 | @msgs = (); 581 | $flags = ''; 582 | for $i (0 .. $#response) { 583 | last if $response[$i] =~ /^1 OK FETCH complete/i; 584 | 585 | if ($response[$i] =~ /FLAGS/) { 586 | # Get the list of flags 587 | $response[$i] =~ /FLAGS \(([^\)]*)/; 588 | $flags = $1; 589 | $flags =~ s/\\Recent//; 590 | } 591 | 592 | if ( $response[$i] =~ /INTERNALDATE/) { 593 | $response[$i] =~ /INTERNALDATE (.+) BODY/; 594 | # $response[$i] =~ /INTERNALDATE "(.+)" BODY/; 595 | $date = $1; 596 | 597 | $date =~ /"(.+)"/; 598 | $date = $1; 599 | $date =~ s/"//g; 600 | } 601 | 602 | # if ( $response[$i] =~ /\* (.+) [^FETCH]/ ) { 603 | if ( $response[$i] =~ /\* (.+) FETCH/ ) { 604 | ($msgnum) = split(/\s+/, $1); 605 | } 606 | 607 | if ( $msgnum && $date ) { 608 | push (@$msgs, $msgnum); 609 | $msgnum = $date = ''; 610 | } 611 | } 612 | 613 | 614 | } 615 | 616 | sub fetchMsg { 617 | 618 | my $msgnum = shift; 619 | my $mbx = shift; 620 | my $conn = shift; 621 | my $message; 622 | 623 | Log(" Fetching msg $msgnum...") if $debug; 624 | sendCommand ($conn, "1 SELECT \"$mbx\""); 625 | while (1) { 626 | readResponse ($conn); 627 | last if ( $response =~ /1 OK/i ); 628 | } 629 | 630 | sendCommand( $conn, "1 FETCH $msgnum (rfc822)"); 631 | while (1) { 632 | readResponse ($conn); 633 | if ( $response =~ /1 OK/i ) { 634 | $size = length($message); 635 | last; 636 | } 637 | elsif ($response =~ /message number out of range/i) { 638 | Log ("Error fetching uid $uid: out of range",2); 639 | $stat=0; 640 | last; 641 | } 642 | elsif ($response =~ /Bogus sequence in FETCH/i) { 643 | Log ("Error fetching uid $uid: Bogus sequence in FETCH",2); 644 | $stat=0; 645 | last; 646 | } 647 | elsif ( $response =~ /message could not be processed/i ) { 648 | Log("Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)"); 649 | push(@errors,"Message could not be processed, skipping it ($user,msgnum $msgnum,$destMbx)"); 650 | $stat=0; 651 | last; 652 | } 653 | elsif 654 | ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{[0-9]+\}/i) { 655 | ($len) = ($response =~ /^\*\s+$msgnum\s+FETCH\s+\(.*RFC822\s+\{([0-9]+)\}/i); 656 | $cc = 0; 657 | $message = ""; 658 | while ( $cc < $len ) { 659 | $n = 0; 660 | $n = read ($conn, $segment, $len - $cc); 661 | if ( $n == 0 ) { 662 | Log ("unable to read $len bytes"); 663 | return 0; 664 | } 665 | $message .= $segment; 666 | $cc += $n; 667 | } 668 | } 669 | } 670 | 671 | return $message; 672 | 673 | } 674 | 675 | 676 | sub usage { 677 | 678 | print STDOUT "usage:\n"; 679 | print STDOUT " purgeMbx.pl -s host/user/pwd -m \n"; 680 | print STDOUT " Optional arguments:\n"; 681 | print STDOUT " -d debug\n"; 682 | print STDOUT " -L \n"; 683 | print STDOUT " -A \n"; 684 | print STDOUT "To use CRAM-MD5 for logins add /CRAM-MD5 like this: -s server/user/password/CRAM-MD5\n"; 685 | exit; 686 | 687 | } 688 | 689 | sub processArgs { 690 | 691 | if ( !getopts( "dIs:L:m:hA:" ) ) { 692 | usage(); 693 | } 694 | 695 | ($host,$user,$pwd) = split(/\//, $opt_s); 696 | 697 | $method = 'CRAM-MD5' if $opt_s =~ /CRAM-MD5/i; 698 | $host =~ s/\/CRAM-MD5//i; 699 | 700 | usage() if !$opt_m; 701 | 702 | $mbx = $opt_m; 703 | $admin_user = $opt_A; 704 | $logfile = $opt_L; 705 | $debug = $showIMAP = 1 if $opt_d; 706 | $showIMAP = 1 if $opt_I; 707 | usage() if $opt_h; 708 | 709 | } 710 | 711 | sub deleteMsg { 712 | 713 | my $msgnum = shift; 714 | my $conn = shift; 715 | my $rc; 716 | 717 | sendCommand ( $conn, "1 STORE $msgnum +FLAGS (\\Deleted)"); 718 | while (1) { 719 | readResponse ($conn); 720 | if ( $response =~ /^1 OK/i ) { 721 | $rc = 1; 722 | Log(" Marked msg number $msgnum for delete") if $debug; 723 | last; 724 | } 725 | 726 | if ( $response =~ /^1 BAD|^1 NO/i ) { 727 | Log("Error setting \Deleted flag for msg $msgnum: $response"); 728 | $rc = 0; 729 | last; 730 | } 731 | } 732 | 733 | return $rc; 734 | 735 | } 736 | 737 | sub expungeMbx { 738 | 739 | my $mbx = shift; 740 | my $conn = shift; 741 | 742 | print STDOUT "Purging mailbox $mbx..." if $debug; 743 | 744 | sendCommand ($conn, "1 SELECT \"$mbx\""); 745 | while (1) { 746 | readResponse ($conn); 747 | last if ( $response =~ /1 OK/i ); 748 | } 749 | 750 | sendCommand ( $conn, "1 EXPUNGE"); 751 | $expunged=0; 752 | while (1) { 753 | readResponse ($conn); 754 | $expunged++ if $response =~ /\* (.+) Expunge/i; 755 | last if $response =~ /^1 OK/; 756 | 757 | if ( $response =~ /^1 BAD|^1 NO/i ) { 758 | print STDOUT "Error purging messages: $response\n"; 759 | last; 760 | } 761 | } 762 | 763 | $totalExpunged += $expunged; 764 | 765 | # print STDOUT "$expunged messages purged\n" if $debug; 766 | 767 | } 768 | 769 | sub dieright { 770 | local($sig) = @_; 771 | print STDOUT "caught signal $sig\n"; 772 | logout( $conn ); 773 | exit(-1); 774 | } 775 | 776 | sub sigprc { 777 | 778 | $SIG{'HUP'} = 'dieright'; 779 | $SIG{'INT'} = 'dieright'; 780 | $SIG{'QUIT'} = 'dieright'; 781 | $SIG{'ILL'} = 'dieright'; 782 | $SIG{'TRAP'} = 'dieright'; 783 | $SIG{'IOT'} = 'dieright'; 784 | $SIG{'EMT'} = 'dieright'; 785 | $SIG{'FPE'} = 'dieright'; 786 | $SIG{'BUS'} = 'dieright'; 787 | $SIG{'SEGV'} = 'dieright'; 788 | $SIG{'SYS'} = 'dieright'; 789 | $SIG{'PIPE'} = 'dieright'; 790 | $SIG{'ALRM'} = 'dieright'; 791 | $SIG{'TERM'} = 'dieright'; 792 | $SIG{'URG'} = 'dieright'; 793 | } 794 | 795 | # getMailboxList 796 | # 797 | # get a list of the user's mailboxes 798 | # 799 | sub getMailboxList { 800 | 801 | my $conn = shift; 802 | my @mbxs; 803 | my $mbx; 804 | 805 | # Get a list of the user's mailboxes 806 | # 807 | Log("Get list of user's mailboxes") if $debug; 808 | 809 | sendCommand ($conn, "1 LIST \"\" *"); 810 | undef @response; 811 | while ( 1 ) { 812 | readResponse ($conn); 813 | if ( $response =~ /^1 OK/i ) { 814 | last; 815 | } 816 | elsif ( $response !~ /^\*/ ) { 817 | Log ("unexpected response: $response"); 818 | return 0; 819 | } 820 | } 821 | 822 | undef @mbxs; 823 | for $i (0 .. $#response) { 824 | $response[$i] =~ s/\s+/ /; 825 | ($dmy,$mbx) = split(/"\/"/,$response[$i]); 826 | $mbx =~ s/^\s+//; $mbx =~ s/\s+$//; 827 | $mbx =~ s/"//g; 828 | 829 | if ($response[$i] =~ /NOSELECT/i) { 830 | if ($debugMode) { Log("$mbx is set NOSELECT,skip it",2); } 831 | next; 832 | } 833 | if ($mbx =~ /^\./) { 834 | # Skip mailboxes starting with a dot 835 | next; 836 | } 837 | push ( @mbxs, $mbx ) if $mbx ne ''; 838 | } 839 | 840 | return @mbxs; 841 | } 842 | 843 | # listMailboxes 844 | # 845 | # Get a list of the user's mailboxes 846 | # 847 | sub listMailboxes { 848 | 849 | my $mbx = shift; 850 | my $conn = shift; 851 | my @mbxs; 852 | 853 | sendCommand ($conn, "1 LIST \"\" \"$mbx\""); 854 | undef @response; 855 | while ( 1 ) { 856 | &readResponse ($conn); 857 | if ( $response =~ /^1 OK/i ) { 858 | last; 859 | } 860 | elsif ( $response !~ /^\*/ ) { 861 | &Log ("unexpected response: $response"); 862 | return 0; 863 | } 864 | } 865 | 866 | @mbxs = (); 867 | for $i (0 .. $#response) { 868 | $response[$i] =~ s/\s+/ /; 869 | if ( $response[$i] =~ /"$/ ) { 870 | $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i; 871 | $mbx = $3; 872 | } elsif ( $response[$i] =~ /\* LIST \((.*)\) NIL (.+)/i ) { 873 | $mbx = $2; 874 | } else { 875 | $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i; 876 | $mbx = $3; 877 | } 878 | $mbx =~ s/^\s+//; $mbx =~ s/\s+$//; 879 | 880 | if ($response[$i] =~ /NOSELECT/i) { 881 | $nosel_mbxs{"$mbx"} = 1; 882 | } 883 | push ( @mbxs, $mbx ) if $mbx ne ''; 884 | } 885 | 886 | return @mbxs; 887 | } 888 | 889 | -------------------------------------------------------------------------------- /release_notes_1.291.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version 1.291. 2 | Changes since 2014/06/12: 3 | 4 | dumptoIMAP.pl 1.12 2014/06/21 5 | Fix handling of delimter and prefix when server does not supply NAMESPACE via -y argument. 6 | 7 | dumptoIMAP.pl 1.11 2014/06/20 8 | Fix problem in get_mbx_list caused by the path not being as expected and causing the filespec to not have a leading '/' 9 | 10 | imap_audit.pl 1.6 2014/07/24 11 | Added support for "before date" and "after date" audits. Also added building of "dummy" msgids for messages lacking them. 12 | 13 | imapcopy.pl 1.138 2014/07/21 14 | Added -O argument to tell imapcopy that both servers are Dovecot using the brain-dead mbox format where mailboxes can have messages or submailboxes but not both. 15 | 16 | imapcopy.pl 1.136 2014/07/21 17 | Added -o to permit all messages to be copied to a single "archive" mailbox on the destination (and not to the regular mailboxes.) 18 | Prompt the user for source/dest user password if the password = PROMPT 19 | 20 | imapcopy.pl 1.129 2014/07/02 21 | When building dummy msgids use the Date in the header rather than the INTERNALDATE. It seems that a server may adjust the internaldate according to its timezone. 22 | 23 | imapcopy.pl 1.128 2014/07/02 24 | Tweak detection of message size because gmail doesn't send it the way most servers do. 25 | 26 | imapcopy.pl 1.127 2014/06/27 27 | Two changes: If a message does not have a Message-ID then build one for it from the Sender, Subject, and INTERNALDATE fields. So the same for the source and destination servers. If -l is set (dont_copy_source_dups) then duplicates on the source will not be copied. 28 | 29 | imapcopy.pl 1.126 2014/06/16 30 | Add a 'special date' search function for a customer whose SEARCH command seems to be unreliable. This routine manually compares the INTERNALDATES with the value of -J 'SINCE|BEFORE ' argument. 31 | 32 | imapcopy.pl 1.125 2014/06/13 33 | Notify msg to dest user with Subject of messages excluded because they exceed the maximum size argument 34 | 35 | imapcopy.pl 1.123 2014/06/13 36 | Removed 'from the dest' from sub expunge() since the -r option can be used to purge messages on the source that have been copied. 37 | 38 | imapsync.pl 1.62 2014/07/19 39 | Add support for backslash as delimiter for -S and -D host/user/pwd 40 | 41 | imapsync.pl 1.60 2014/07/05 42 | Fix the getDatedMsg subroutine for built msgids. 43 | 44 | imapsync.pl 1.58 2014/07/05 45 | Include the subject in the constructed msgid. 46 | 47 | imapsync.pl 1.56 2014/07/05 48 | Build msgid from date,subject,sender if msgid is missing. 49 | 50 | migrateIMAP.pl 1.54 2014/07/11 51 | Use from+header_date+subject for msgid if message lacks one. 52 | 53 | pop3toimap.pl 1.8 2014/07/06 54 | Fix problem reading users file on Windows (last character was chopped off). 55 | 56 | thunderbird_to_imap.pl 1.12 2014/07/09 57 | Added a range selector to deal with out-of-memory errors 58 | 59 | thunderbird_to_imap.pl 1.11 2014/07/09 60 | Fix the way Tbird status codes are interpreted 61 | 62 | thunderbird_to_imap.pl 1.10 2014/07/07 63 | Fixed problem with CRLF on some Windows boxes, added complete set of Thunderbird Mozilla status flags. 64 | 65 | thunderbird_to_imap.pl 1.9 2014/07/01 66 | Don't print 'running in update mode' unless -U is set. 67 | 68 | thunderbird_to_imap.pl 1.8 2014/07/01 69 | Tweak the end-of-message check because some Thunderbird folders have just "From " instead of "From xxxxxxxx" 70 | 71 | thunderbird_to_imap.pl 1.6 2014/06/29 72 | Enhance the date-formatting code. 73 | 74 | thunderbird_to_imap.pl 1.5 2014/06/28 75 | Fix opt_x which was used for two purposes; add opt_X (CRLF control) in its place. 76 | 77 | -------------------------------------------------------------------------------- /release_notes_1.298.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version 1.298. 2 | Changes since 2014/07/25: 3 | 4 | The release notes for earlier versions can be found at http://www.athensfbc.com/release_notes 5 | 6 | imap_audit.pl 1.15 2014/08/25 7 | Added -n argument to compare only the message counts on src and dest. 8 | Add more loop detection code 9 | Open mbxs in RO mode 10 | 11 | imap_audit.pl 1.12 2014/07/27 12 | Strip off timezone offset when building dummy msgid 13 | 14 | imap_audit.pl 1.11 2014/07/26 15 | Added -g argument to force use of dummy msgids for all messages 16 | 17 | imap_audit.pl 1.10 2014/07/26 18 | If Message-ID line is wrapped get it from following line 19 | 20 | imapcopy.cgi 1.9 2014/08/18 21 | Make the 'Cannot redirect to STDERR' error message more informative. 22 | 23 | imapfilter.pl 1.46 2014/09/01 24 | Fixed 'test' mode counters. 25 | Add support for numeric date offsets instead of fixed dates in ISEARCH rules 26 | Fix issue with chunking of messages. Add -X argument for emptying the Trash folder at the end of the run. 27 | 28 | imapsync.pl 1.63 2014/08/26 29 | Added -t (dry run) feature. 30 | 31 | -------------------------------------------------------------------------------- /release_notes_1.300.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version 1.300. 2 | Changes since 2014/09/03: 3 | 4 | The release notes for earlier versions can be found at http://www.athensfbc.com/release_notes 5 | 6 | IMAPtoMbox.pl 1.11 2014/10/15 7 | Added support for oauth2 logins 8 | 9 | MboxtoIMAP.pl 1.21 2014/10/15 10 | Add 'use decode_base64' for OAUTH2 login error message 11 | 12 | MboxtoIMAP.pl 1.20 2014/10/15 13 | Added support for OAUTH2 logins 14 | 15 | delIMAPdups.pl 1.26 2014/10/15 16 | Added support for oauth2 logins 17 | 18 | delete_imap_mailboxes.pl 1.7 2014/10/17 19 | Mark INBOX messages for delete with single 1:* command instead of individually 20 | 21 | delete_imap_mailboxes.pl 1.6 2014/10/15 22 | Added support for oauth2 logins 23 | 24 | delete_imap_mailboxes.pl 1.5 2014/10/15 25 | Drop -i argument for purging the INBOX and make it automatic. 26 | 27 | delete_imap_mailboxes.pl 1.4 2014/10/14 28 | Added -i argument to purge the inbox. 29 | 30 | dumptoIMAP.pl 1.13 2014/10/15 31 | Added support for oauth2 logins 32 | 33 | imapCapability.pl 1.9 2014/10/15 34 | Added support for oauth2 logins 35 | 36 | imap_audit.pl 1.16 2014/10/15 37 | Added support for oauth2 logins 38 | 39 | imap_search.pl 1.3 2014/10/17 40 | Added support for oauth2 logins 41 | 42 | imap_to_maildir.pl 1.5 2014/10/15 43 | Added support for oauth2 logins 44 | 45 | imapcopy.pl 1.141 2014/10/14 46 | Added support for Gmail oauth2 tokens. 47 | 48 | imapcopy.pl 1.140 2014/10/09 49 | Openwave the source mailbox in EXAMINE mode since a few servers otherwise mark the messages as SEEN. 50 | 51 | imapdump.pl 1.29 2014/10/15 52 | Added support for oauth2 logins 53 | 54 | imapdump.pl 1.28 2014/09/06 55 | Improve logging in debug mode 56 | 57 | imapfilter.pl 1.47 2014/10/14 58 | Added support for oauth2 tokens 59 | 60 | imapsync.pl 1.65 2014/10/15 61 | Added support for OAUTH2 logins 62 | 63 | imapsync.pl 1.64 2014/09/05 64 | Added source_archive feature that moves messages from a source mailbox in an archive mailbox, also on the source. 65 | 66 | list_account_sizes.pl 1.9 2014/10/15 67 | Added support for oauth2 logins 68 | 69 | list_imap_folders.pl 1.15 2014/10/15 70 | Added support for oauth2 logins 71 | 72 | maildir_to_imap.pl 1.7 2014/10/15 73 | Added support for oauth2 logins 74 | 75 | mbxIMAPsync.pl 1.1 2014/10/16 76 | Added support for oauth2 logins 77 | 78 | mbxIMAPsync.pl 1.2 2014/10/16 79 | Added support for oauth2 logins 80 | 81 | migrateIMAP.pl 1.55 2014/10/16 82 | Added support for oauth2 logins 83 | 84 | pop3toimap.pl 1.10 2014/10/16 85 | Added support for oauth2 logins 86 | 87 | purgeMbx.pl 1.5 2014/10/16 88 | Added support for oauth2 logins 89 | 90 | thunderbird_to_imap.pl 1.13 2014/10/16 91 | Added support for oauth2 logins 92 | 93 | trash.pl 1.5 2014/10/16 94 | Added support for oauth2 logins 95 | 96 | -------------------------------------------------------------------------------- /release_notes_1.303.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version 1.303. 2 | Changes since 20141017: 3 | 4 | The release notes for earlier versions can be found at http://www.athensfbc.com/release_notes 5 | 6 | dumptoIMAP.pl 1.14 2014/11/10 7 | Correct -S host/user/pwd to -i host/user/pwd in the notes at the top of the script. 8 | 9 | imapcopy.pl 1.143 2014/11/18 10 | Added -V argument to handle the response from Zimbra 6.0.16 which is not sending a closing ')' line in its response to the FETCH header items. Instead of ')' imapcopy considers ' FLAGS xxxxx' as the end of the FETCHED data. 11 | 12 | imapcopy.pl 1.142 2014/11/06 13 | Removed 'server unvailable' error trap so that if that phrase appears in the text of a message it won't trigger a reconnect() action. 14 | 15 | list_imap_folders.pl 1.18 2014/11/18 16 | Added ability to process list of users, added message subject to large message report. 17 | 18 | list_imap_folders.pl 1.17 2014/11/18 19 | Added 'subject' field to large message report and fixed the -U argument. 20 | 21 | list_imap_folders.pl 1.16 2014/11/15 22 | Add support for UWash-imap style mailboxes (MH) 23 | 24 | maildir_to_imap.pl 1.9 2014/10/31 25 | Added -M argument so the user can change the name of the IMAP mailbox to be different than the maildir folder name. 26 | 27 | maildir_to_imap.pl 1.8 2014/10/30 28 | Require call to ctime() which is not needed. 29 | 30 | 31 | -------------------------------------------------------------------------------- /release_notes_1.309.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version V1.309. 2 | Changes since 2014/11/19: 3 | 4 | The release notes for earlier versions can be found at http://www.athensfbc.com/release_notes 5 | 6 | delIMAPdups.pl 1.27 2014/11/22 7 | Accept either a space or colon as separator in users file. 8 | 9 | imapdump.pl 1.31 2014/12/07 10 | Added parallel mode, multi-user mode, and extract-attachments-as-separate files option. 11 | 12 | list_imap_folders.pl 1.24 2014/11/22 13 | When writing large message report don't call UTF-7 mailboxname conversion if the server doesn't have Perl support for it. 14 | 15 | -------------------------------------------------------------------------------- /release_notes_1.313.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version 1.313. 2 | Changes since 2014/12/09: 3 | 4 | The release notes for earlier versions can be found at http://www.athensfbc.com/release_notes 5 | 6 | IMAPtoMbox.pl 1.12 2015/02/02 7 | Fixed IMAP FETCH parsing 8 | 9 | delIMAPdups.pl 1.28 2015/01/29 10 | Added -r argument for message range to check, eg -r 1:1000 11 | 12 | delIMAPdups.pl.files 1.2 2015/01/30 13 | -p argument was not being honored. 14 | 15 | imap_audit.pl 1.18 2015/02/02 16 | Fixed problem with IMAP FETCH parsing 17 | 18 | imap_audit.pl 1.17 2015/01/31 19 | Increase max loop counter 20 | 21 | imap_search.pl 1.4 2015/02/02 22 | Fixed IMAP FETCH parsing 23 | 24 | imapcopy.pl 1.146 2015/02/01 25 | Fixed FETCH parsing bug exposed by new Zimbra version. 26 | 27 | imapcopy.pl 1.145 2015/01/22 28 | Add a "skip message-id" option using imapcopy.skip to hold msgs to be skipped 29 | 30 | imapdump.pl 1.34 2015/02/02 31 | Fixed IMAP FETCH parsing 32 | 33 | imapfilter.pl 1.48 2015/01/23 34 | Added -T feature which processes a mailbox and its subfolders only. 35 | 36 | imapsync.pl 1.66 2015/02/02 37 | Fetch problem with IMAP FETCH parsing 38 | 39 | migrateIMAP.pl 1.58 2015/02/01 40 | Fixed FETCH parser bug 41 | 42 | migrateIMAP.pl 1.57 2015/01/27 43 | Skip the [Gmail]/All Mail folder 44 | 45 | migrateIMAP.pl 1.56 2015/01/21 46 | Detect a * BYE response from the server when fetching messages headers and exit. 47 | 48 | -------------------------------------------------------------------------------- /release_notes_1.326.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version 1.326. 2 | Changes since 2015/02/03: 3 | 4 | The release notes for earlier versions can be found at http://www.athensfbc.com/release_notes 5 | 6 | IMAPtoMbox.pl 1.13 2015/04/30 7 | The From address was missing from the first line in the message in the mbox file. 8 | 9 | delIMAPdups.pl 1.30 2015/03/07 10 | sub getDelimiter was missing 11 | 12 | delIMAPdups.pl 1.29 2015/03/07 13 | Fixed truncated line in code. 14 | 15 | delIMAPdups.pl.files 1.3 2015/02/04 16 | Added -g (global) option 17 | 18 | email_archive.pl 1.6 2015/02/21 19 | Clean up code for production release 20 | 21 | email_attachment_cleaner.pl 1.6 2015/03/04 22 | Add option to save attachments but not strip them. Add option to specify list of attachments types. 23 | 24 | email_attachment_cleaner.pl 1.5 2015/03/03 25 | Fix counter bug 26 | 27 | email_attachment_cleaner.pl 1.4 2015/03/03 28 | Call validate_date() after get_date() 29 | 30 | email_attachment_cleaner.pl 1.3 2015/03/03 31 | Fixes for test mode 32 | 33 | email_attachment_cleaner.pl 1.2 2015/03/02 34 | Added some error checking 35 | 36 | email_restore.cgi 1.1 2015/03/01 37 | Initial version ============================================================================= 38 | 39 | email_restore.cgi 1.4 2015/02/21 40 | Clean up code for production release 41 | 42 | imap_audit.pl 1.20 2015/04/03 43 | Fix for multi-line Message-ID in message header 44 | 45 | imap_audit.pl 1.19 2015/02/06 46 | Fixed a bug in the auth plain login routine 47 | 48 | imap_cleaner.pl 1.5 2015/02/27 49 | Add -O option to save attachments in the specified directory 50 | 51 | imap_cleaner.pl 1.4 2015/02/27 52 | Added -u and -p arguments for username and password. Removed list option. 53 | 54 | imap_cleaner.pl 1.3 2015/02/27 55 | Added -U argument 56 | 57 | imap_cleaner.pl 1.2 2015/02/25 58 | Comment out date fixup code (not needed). Added test option 59 | 60 | imapcopy.pl 1.157 2015/05/22 61 | Enhance reconnect() mode. 62 | 63 | imapcopy.pl 1.156 2015/05/19 64 | Workaround to rename mailboxes with INBOX. prefix that shouldn't be there on the destination. 65 | 66 | imapcopy.pl 1.155 2015/04/26 67 | Set the $exchange flag in AUTH PLAIN login mode if the destination is an Exchange server 68 | 69 | imapcopy.pl 1.154 2015/04/24 70 | Tweak the mailbox mapping rules for the case where the source delimiter is an '_' character. 71 | 72 | imapcopy.pl 1.153 2015/04/22 73 | Nested folders on destination not created correctly when source delimiter is a backslash character 74 | 75 | imapcopy.pl 1.152 2015/04/18 76 | Added some additional error handling for Exchange-related errors 77 | 78 | imapcopy.pl 1.151 2015/04/11 79 | Don't skip mailboxes starting with a dot. 80 | 81 | imapcopy.pl 1.150 2015/04/03 82 | Added fix for multi-line Message-IDs to dated message search routine. 83 | 84 | imapcopy.pl 1.149 2015/04/03 85 | Fix for multi-line Message-ID line in the header in update mode. 86 | 87 | imapcopy.pl 1.148 2015/04/01 88 | Don't let a child process try to launch another child process in Parallel mode. 89 | 90 | imapcopy.pl 1.147 2015/03/21 91 | Make -R argument apply to exclude-mailboxes as well as include-mailboxes 92 | 93 | imapdump.pl 1.36 2015/03/05 94 | Added option to include all flags (not just S = seen) in the dumped filename. Also option to include custom flags, not just standard IMAP flags. And option to update the flags when they change on the server. 95 | 96 | imapdump.pl 1.35 2015/03/04 97 | Build dummy msgid if the message lacks one. 98 | 99 | imapsync.pl 1.67 2015/04/03 100 | Fix for multi-line msgids in message header 101 | 102 | list_imap_folders.pl 1.25 2015/02/16 103 | Put a space between "fields" and "(Subject)" in body.peek command. The Rocklife MailSite IMAP server wants it that way. 104 | 105 | migrateIMAP.pl 1.60 2015/05/20 106 | Handle the way that Domino responds to LIST command for nested mailboxes 107 | 108 | migrateIMAP.pl 1.59 2015/04/05 109 | Fix for multi-line message-id 110 | 111 | reload_archived_msgs.pl 1.1 2015/02/21 112 | Initial release ============================================================================= 113 | 114 | thunderbird_to_imap.pl 1.14 2015/03/15 115 | Use eval to protect against substr errors 116 | 117 | -------------------------------------------------------------------------------- /release_notes_1.335.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version 1.335. 2 | Changes since 2015/05/08: 3 | 4 | The release notes for earlier versions can be found at http://www.athensfbc.com/release_notes 5 | 6 | imap_to_maildir.pl 1.6 2015/07/07 7 | Added -G argument to strip [Gmail] from folder names. Also skip [Gmail]All Mail folder since its messages are duplicates of what's in the IMAP folders. 8 | 9 | imapcopy.pl 1.162 2015/08/03 10 | Update mode did not work when copying messages in a date range 11 | 12 | imapcopy.pl 1.161 2015/07/30 13 | Added -N argument to permit copying of [Gmail]/All Mail folder 14 | 15 | imapcopy.pl 1.160 2015/07/03 16 | Use eval to protect against bad dates in compare_dates() 17 | 18 | imapcopy.pl 1.159 2015/05/28 19 | More protection against destination sending unexpected APPEND response 20 | 21 | imapcopy.pl 1.158 2015/05/27 22 | Put INBOX under root mailbox when one is specified as well as all other mailboxes 23 | 24 | imapcopy.pl 1.157 2015/05/22 25 | Enhance reconnect() mode. 26 | 27 | imapcopy.pl 1.156 2015/05/19 28 | Workaround to rename mailboxes with INBOX. prefix that shouldn't be there on the destination. 29 | 30 | imapdump.pl 1.41 2015/08/02 31 | Added -Z IMAP_SEARCH_EXPRESSION argument 32 | 33 | imapdump.pl 1.40 2015/08/01 34 | On Windows adjust the line termination characters accordingly 35 | 36 | imapdump.pl 1.37 2015/07/30 37 | Added support for using header field as the dumped filename and setting the date on the dumped file to the header date 38 | 39 | imapsync.pl 1.75 2015/07/23 40 | Fix problem with supplied mailbox list and destination mbx creation 41 | 42 | imapsync.pl 1.74 2015/07/23 43 | Added support for CRAM-MD5 logins 44 | 45 | imapsync.pl 1.73 2015/07/22 46 | Put trimming leading and trailing spaces under control of -R argument which previously only compressed multiple embedded spaces to a single space. 47 | 48 | imapsync.pl 1.72 2015/07/06 49 | Fixed exchange_workaround(). 50 | 51 | imapsync.pl 1.70 2015/07/04 52 | Added workaround for Exchange's 10-error limitation. 53 | 54 | imapsync.pl 1.68 2015/07/02 55 | Standard IMAP flags were not getting set when a message was first added to the destination. 56 | 57 | migrateIMAP.pl 1.65 2015/06/24 58 | Added more timeout handling code. 59 | 60 | migrateIMAP.pl 1.64 2015/06/23 61 | Put an alarm() timer around the APPEND command to catch timeouts. 62 | 63 | migrateIMAP.pl 1.63 2015/06/15 64 | Added option to wrap long lines at 1,000 characters 65 | 66 | migrateIMAP.pl 1.61 2015/06/08 67 | Add support for Kerio master authentication 68 | 69 | migrateIMAP.pl 1.60 2015/05/20 70 | Handle the way that Domino responds to LIST command for nested mailboxes 71 | 72 | purgeMbx.pl 1.7 2015/06/05 73 | Add option to purge all mailboxes with -m '*' 74 | 75 | -------------------------------------------------------------------------------- /release_notes_1.347.txt: -------------------------------------------------------------------------------- 1 | Release notes for IMAP-Tools version 1.347. 2 | Changes since 2015/10/22: 3 | 4 | The release notes for earlier versions can be found at http://www.athensfbc.com/release_notes 5 | 6 | IMAPtoMbox.pl 1.17 2015/12/01 7 | Add CRAM-MD5 notes to usage() 8 | 9 | IMAPtoMbox.pl 1.14 2015/11/30 10 | Added support for CRAM-MD5 logins 11 | 12 | MboxtoIMAP.pl 1.22 2015/12/04 13 | Added support for CRAM-MD5 logins 14 | 15 | delIMAPdups.pl 1.31 2015/12/05 16 | Added support for CRAM-MD5 logins 17 | 18 | dumptoIMAP.pl 1.19 2015/12/04 19 | Added support for CRAM-MD5 logins 20 | 21 | imapCapability.pl 1.10 2015/12/05 22 | Added support for CRAM-MD5 logins 23 | 24 | imapPing.pl 1.5 2015/12/05 25 | Added support for CRAM-MD5 logins 26 | 27 | imap_audit.pl 1.22 2015/12/10 28 | Added support for CRAM-MD5 logins 29 | 30 | imap_search.pl 1.5 2015/12/10 31 | Added support for CRAM-MD5 logins 32 | 33 | imap_to_maildir.pl 1.7 2015/12/05 34 | Added support for CRAM-MD5 logins 35 | 36 | imapcopy.cgi 1.14 2016/02/08 37 | Bring list_imap_folders into the main code instead of calling it as an external program 38 | 39 | imapcopy.cgi 1.11 2016/01/21 40 | Added support for list_imap_folders in browser mode 41 | 42 | imapcopy.cgi 1.10 2016/01/08 43 | If destUser or destPwd equals '*' then use the source values 44 | 45 | imapcopy.pl 1.173 2016/01/08 46 | If destUser and destPwd are '*' then set them equal to sourceUser and sourcePwd. Added support for notifying an admin when a migration completes in browser mode 47 | 48 | imapcopy.pl 1.171 2015/12/24 49 | Add comments in usasge() about | as mbx separator 50 | 51 | imapcopy.pl 1.170 2015/12/24 52 | Use \Q with the mbx_delimiter fix for embedded commas in list of mailboxes 53 | 54 | imapcopy.pl 1.169 2015/12/24 55 | Use an alternative mailbox list delimiter, '|' as well as ',' with -m list 56 | 57 | imapcopy.pl 1.168 2015/12/18 58 | Added skip_deleted code to getDatedMsgList(). 59 | 60 | imapcopy.pl 1.167 2015/12/17 61 | Added -P argument for skipping source msgs that are marked for Delete. 62 | 63 | imapcopy.pl 1.166 2015/12/15 64 | Added -v argument for marking messages copied to the destination as SEEN 65 | 66 | imapdump.pl 1.54 2015/12/04 67 | Added support for CRAM-MD5 logins 68 | 69 | imapfilter.pl 1.49 2015/12/01 70 | Added support for CRAM-MD5 logins 71 | 72 | list_account_sizes.pl 1.13 2015/12/10 73 | Added support for CRAM-MD5 logins 74 | 75 | maildir_to_imap.pl 1.11 2015/12/04 76 | Added support for CRAM-MD5 77 | 78 | migrateIMAP.pl 1.75 2016/01/29 79 | Remove the space between SEARCH expressions. 80 | 81 | migrateIMAP.pl 1.73 2015/12/01 82 | Added support for CRAM-MD5 logins 83 | 84 | migrateIMAP.pl 1.72 2015/11/02 85 | Added -Y argument for removing messages from the source after copying them to the destination. In update mode this means messages already on the destination will also be removed from the source. 86 | 87 | pop3toimap.pl 1.11 2015/12/04 88 | Added support for CRAM-MD5 logins. 89 | 90 | purgeMbx.pl 1.9 2015/12/24 91 | Quote the username and password in LOGIN command. 92 | 93 | purgeMbx.pl 1.8 2015/12/06 94 | Added support for CRAM-MD5 95 | 96 | thunderbird_to_imap.pl 1.23 2015/12/05 97 | Added support for CRAM-MD5 logins 98 | 99 | trash.pl 1.6 2015/12/06 100 | Added support for CRAM-MD5 logins 101 | 102 | -------------------------------------------------------------------------------- /test_admin_login: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use Socket; 4 | use FileHandle; 5 | use Fcntl; 6 | use Getopt::Std; 7 | use IO::Socket; 8 | 9 | # This is a simple script to test whether an IMAP server 10 | # works with AUTHENTICATE PLAIN to permit admin login to 11 | # user accounts. 12 | 13 | unless ( $ARGV[0] and $ARGV[1] and $ARGV[2] and $ARGV[3] ) { 14 | print "\nUsage: $0 \n"; 15 | exit; 16 | } 17 | 18 | $sourceHost = $ARGV[0]; 19 | $sourceUser = $ARGV[1]; 20 | $adminUser = $ARGV[2]; 21 | $adminPwd = $ARGV[3]; 22 | connectToHost($sourceHost, \$src) or exit; 23 | 24 | login_plain( $sourceUser, $adminUser, $adminPwd, $src ); 25 | namespace( $src, \$srcPrefix, \$srcDelim, $opt_x ); 26 | 27 | exit; 28 | 29 | @mbxs = getMailboxList( '', $src); 30 | foreach $_ ( @mbxs ) { 31 | print "$_\n"; 32 | } 33 | logout( $src ); 34 | exit; 35 | 36 | 37 | sub init { 38 | 39 | $os = $ENV{'OS'}; 40 | 41 | processArgs(); 42 | 43 | if ($timeout eq '') { $timeout = 60; } 44 | 45 | # Open the logFile 46 | # 47 | if ( $logfile ) { 48 | if ( !open(LOG, ">> $logfile")) { 49 | print STDOUT "Can't open $logfile: $!\n"; 50 | exit; 51 | } 52 | select(LOG); $| = 1; 53 | } 54 | 55 | # Determine whether we have SSL support via openSSL and IO::Socket::SSL 56 | $ssl_installed = 1; 57 | eval 'use IO::Socket::SSL'; 58 | if ( $@ ) { 59 | $ssl_installed = 0; 60 | } 61 | 62 | $utf = 1; 63 | eval 'use Unicode::IMAPUtf7'; 64 | if ( $@ ) { 65 | $utf = 0; 66 | } 67 | 68 | # Set up signal handling 69 | $SIG{'ALRM'} = 'signalHandler'; 70 | $SIG{'HUP'} = 'signalHandler'; 71 | $SIG{'INT'} = 'signalHandler'; 72 | $SIG{'TERM'} = 'signalHandler'; 73 | $SIG{'URG'} = 'signalHandler'; 74 | 75 | } 76 | 77 | # 78 | # sendCommand 79 | # 80 | # This subroutine formats and sends an IMAP protocol command to an 81 | # IMAP server on a specified connection. 82 | # 83 | 84 | sub sendCommand { 85 | 86 | my $fd = shift; 87 | my $cmd = shift; 88 | 89 | print $fd "$cmd\r\n"; 90 | Log( $cmd ) if $showIMAP; 91 | 92 | } 93 | 94 | # 95 | # readResponse 96 | # 97 | # This subroutine reads and formats an IMAP protocol response from an 98 | # IMAP server on a specified connection. 99 | # 100 | 101 | sub readResponse { 102 | 103 | my $fd = shift; 104 | 105 | $response = <$fd>; 106 | chop $response; 107 | $response =~ s/\r//g; 108 | push (@response,$response); 109 | Log( $response ) if $showIMAP; 110 | } 111 | 112 | # Make a connection to an IMAP host 113 | 114 | sub connectToHost { 115 | 116 | my $host = shift; 117 | my $conn = shift; 118 | 119 | ($host,$port) = split(/:/, $host); 120 | $port = 143 unless $port; 121 | 122 | # We know whether to use SSL for ports 143 and 993. For any 123 | # other ones we'll have to figure it out. 124 | $mode = sslmode( $host, $port ); 125 | 126 | $ssl_installed = 1; 127 | use IO::Socket::SSL; 128 | if ( $mode eq 'SSL' ) { 129 | unless( $ssl_installed == 1 ) { 130 | warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 131 | Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 132 | exit; 133 | } 134 | Log("Attempting an SSL connection") if $debug; 135 | $$conn = IO::Socket::SSL->new( 136 | Proto => "tcp", 137 | SSL_verify_mode => 0x00, 138 | PeerAddr => $host, 139 | PeerPort => $port, 140 | ); 141 | 142 | unless ( $$conn ) { 143 | $error = IO::Socket::SSL::errstr(); 144 | Log("Error connecting to $host: $error"); 145 | exit; 146 | } 147 | } else { 148 | # Non-SSL connection 149 | Log("Attempting a non-SSL connection") if $debug; 150 | $$conn = IO::Socket::INET->new( 151 | Proto => "tcp", 152 | PeerAddr => $host, 153 | PeerPort => $port, 154 | ); 155 | 156 | unless ( $$conn ) { 157 | Log("Error connecting to $host:$port: $@"); 158 | warn "Error connecting to $host:$port: $@"; 159 | exit; 160 | } 161 | } 162 | 163 | } 164 | 165 | sub sslmode { 166 | 167 | my $host = shift; 168 | my $port = shift; 169 | my $mode; 170 | 171 | # Determine whether to make an SSL connection 172 | # to the host. Return 'SSL' if so. 173 | 174 | if ( $port == 143 ) { 175 | # Standard non-SSL port 176 | return ''; 177 | } elsif ( $port == 993 ) { 178 | # Standard SSL port 179 | return 'SSL'; 180 | } 181 | 182 | unless ( $ssl_installed ) { 183 | # We don't have SSL installed on this machine 184 | return ''; 185 | } 186 | 187 | # For any other port we need to determine whether it supports SSL 188 | 189 | my $conn = IO::Socket::SSL->new( 190 | Proto => "tcp", 191 | SSL_verify_mode => 0x00, 192 | PeerAddr => $host, 193 | PeerPort => $port, 194 | ); 195 | 196 | if ( $conn ) { 197 | close( $conn ); 198 | $mode = 'SSL'; 199 | } else { 200 | $mode = ''; 201 | } 202 | 203 | return $mode; 204 | } 205 | 206 | # trim 207 | # 208 | # remove leading and trailing spaces from a string 209 | sub trim { 210 | 211 | local (*string) = @_; 212 | 213 | $string =~ s/^\s+//; 214 | $string =~ s/\s+$//; 215 | 216 | return; 217 | } 218 | 219 | # login_plain 220 | # 221 | # login in at the source host with the user's name and password. If provided 222 | # with administrator credential, use them as this eliminates the need for the 223 | # user's password. 224 | # 225 | sub login_plain { 226 | 227 | my $user = shift; 228 | my $admin = shift; 229 | my $pwd = shift; 230 | my $conn = shift; 231 | 232 | # Do an AUTHENTICATE = PLAIN. 233 | 234 | $showIMAP = 1; 235 | 236 | print "user $user\n"; 237 | print "admin $admin\n"; 238 | print "pwd $pwd\n"; 239 | my $login_str = sprintf("%s\x00%s\x00%s", $user,$admin,$pwd); 240 | $login_str = encode_base64("$login_str", ""); 241 | 242 | sendCommand ($conn, "1 AUTHENTICATE PLAIN" ); 243 | 244 | my $loops; 245 | while (1) { 246 | readResponse ( $conn ); 247 | last if $response =~ /^\+/; 248 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 249 | Log("Admin login failed: $response"); 250 | exit; 251 | } 252 | $last if $loops++ > 5; 253 | } 254 | 255 | sendCommand ($conn, $login_str ); 256 | my $loops; 257 | while (1) { 258 | readResponse ( $conn ); 259 | last if $response =~ /^1 OK/i; 260 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 261 | Log ("Admin login to $user account failed: $response"); 262 | exit; 263 | } 264 | $last if $loops++ > 5; 265 | } 266 | 267 | return 1; 268 | 269 | } 270 | 271 | 272 | sub login_plain_2 { 273 | 274 | my $user = shift; 275 | my $admin = shift; 276 | my $pwd = shift; 277 | my $conn = shift; 278 | 279 | # Do an AUTHENTICATE = PLAIN. 280 | 281 | $showIMAP = 1; 282 | 283 | my $login_str = sprintf("%s\x00%s\x00%s", $user,$admin,$pwd); 284 | $login_str = encode_base64("$login_str", ""); 285 | 286 | sendCommand ($conn, "1 AUTHENTICATE PLAIN $login_str" ); 287 | 288 | my $loops; 289 | while (1) { 290 | readResponse ( $conn ); 291 | last if $response =~ /^\+/; 292 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 293 | Log ("unexpected LOGIN response: $response"); 294 | return 0; 295 | } 296 | $last if $loops++ > 5; 297 | } 298 | 299 | return; 300 | 301 | sendCommand ($conn, $login_str ); 302 | my $loops; 303 | while (1) { 304 | readResponse ( $conn ); 305 | last if $response =~ /^1 OK/i; 306 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 307 | Log ("unexpected LOGIN response: $response"); 308 | return 0; 309 | } 310 | $last if $loops++ > 5; 311 | } 312 | 313 | return 1; 314 | 315 | } 316 | 317 | 318 | 319 | sub login_cram_md5 { 320 | 321 | my $user = shift; 322 | my $pwd = shift; 323 | my $conn = shift; 324 | 325 | sendCommand ($conn, "1 AUTHENTICATE CRAM-MD5"); 326 | while (1) { 327 | readResponse ( $conn ); 328 | last if $response =~ /^\+/; 329 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 330 | return 0; 331 | } 332 | } 333 | 334 | my ($challenge) = $response =~ /^\+ (.+)/; 335 | 336 | $response = cram_md5( $challenge, $user, $pwd ); 337 | 338 | sendCommand ($conn, $response); 339 | while (1) { 340 | readResponse ( $conn ); 341 | last if $response =~ /^1 OK/i; 342 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 343 | return 0; 344 | } 345 | } 346 | 347 | return 1; 348 | } 349 | 350 | # logout 351 | # 352 | # log out from the host 353 | # 354 | sub logout { 355 | 356 | my $conn = shift; 357 | 358 | undef @response; 359 | sendCommand ($conn, "1 LOGOUT"); 360 | while ( 1 ) { 361 | readResponse ($conn); 362 | if ( $response =~ /^1 OK/i ) { 363 | last; 364 | } 365 | elsif ( $response !~ /^\*/ ) { 366 | Log ("unexpected LOGOUT response: $response"); 367 | last; 368 | } 369 | } 370 | close $conn; 371 | return; 372 | } 373 | 374 | # getMailboxList 375 | # 376 | # get a list of the user's mailboxes from the source host 377 | # 378 | sub getMailboxList { 379 | 380 | my $prefix = shift; 381 | my $conn = shift; 382 | my @mbxs; 383 | 384 | # Get a list of the user's mailboxes 385 | # 386 | 387 | Log("Get list of user's mailboxes",2) if $debugMode; 388 | 389 | if ( $mbxList ) { 390 | foreach $mbx ( split(/,/, $mbxList) ) { 391 | $mbx = $prefix . $mbx if $prefix; 392 | if ( $opt_R ) { 393 | # Get all submailboxes under the ones specified 394 | $mbx .= '*'; 395 | @mailboxes = listMailboxes( $mbx, $conn); 396 | push( @mbxs, @mailboxes ); 397 | } else { 398 | push( @mbxs, $mbx ); 399 | } 400 | } 401 | } else { 402 | # Get all mailboxes 403 | @mbxs = listMailboxes( '*', $conn); 404 | } 405 | 406 | return @mbxs; 407 | } 408 | 409 | # listMailboxes 410 | # 411 | # Get a list of the user's mailboxes 412 | # 413 | sub listMailboxes { 414 | 415 | my $mbx = shift; 416 | my $conn = shift; 417 | 418 | sendCommand ($conn, "1 LIST \"\" \"$mbx\""); 419 | undef @response; 420 | while ( 1 ) { 421 | &readResponse ($conn); 422 | if ( $response =~ /^1 OK/i ) { 423 | last; 424 | } 425 | elsif ( $response !~ /^\*/ ) { 426 | &Log ("unexpected response: $response"); 427 | return 0; 428 | } 429 | } 430 | 431 | @mbxs = (); 432 | for $i (0 .. $#response) { 433 | $response[$i] =~ s/\s+/ /; 434 | if ( $response[$i] =~ /"$/ ) { 435 | $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i; 436 | $mbx = $3; 437 | } elsif ( $response[$i] =~ /\* LIST \((.*)\) NIL (.+)/i ) { 438 | $mbx = $2; 439 | } else { 440 | $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i; 441 | $mbx = $3; 442 | } 443 | $mbx =~ s/^\s+//; $mbx =~ s/\s+$//; 444 | 445 | if ($response[$i] =~ /NOSELECT/i) { 446 | next; 447 | } 448 | push ( @mbxs, $mbx ) if $mbx ne ''; 449 | } 450 | 451 | return @mbxs; 452 | } 453 | 454 | sub processArgs { 455 | 456 | if ( !getopts( "dS:L:O:u:hHsU:T:A:I" ) ) { 457 | usage(); 458 | } 459 | $sourceHost = $opt_S; 460 | $showIMAP = 1 if $opt_I; 461 | $timeout = 45 unless $timeout; 462 | $output_file = $opt_O; 463 | $user_list = $opt_u; 464 | $administrator = $opt_A; 465 | 466 | if ( $opt_h or $opt_H ) { 467 | usage(); 468 | } 469 | 470 | if( !-e $user_list or !$sourceHost ) { 471 | usage(); 472 | } 473 | 474 | } 475 | 476 | sub namespace { 477 | 478 | my $conn = shift; 479 | my $prefix = shift; 480 | my $delimiter = shift; 481 | my $mbx_delim = shift; 482 | 483 | # Query the server with NAMESPACE so we can determine its 484 | # mailbox prefix (if any) and hierachy delimiter. 485 | 486 | if ( $mbx_delim ) { 487 | # The user has supplied a mbx delimiter and optionally a prefix. 488 | Log("Using user-supplied mailbox hierarchy delimiter $mbx_delim"); 489 | ($$delimiter,$$prefix) = split(/\s+/, $mbx_delim); 490 | return; 491 | } 492 | 493 | @response = (); 494 | sendCommand( $conn, "1 NAMESPACE"); 495 | while ( 1 ) { 496 | readResponse( $conn ); 497 | if ( $response =~ /^1 OK/i ) { 498 | last; 499 | } elsif ( $response =~ /^1 NO|^1 BAD|^\* BYE/i ) { 500 | Log("Unexpected response to NAMESPACE command: $response"); 501 | last; 502 | } 503 | } 504 | 505 | foreach $_ ( @response ) { 506 | if ( /NAMESPACE/i ) { 507 | my $i = index( $_, '((' ); 508 | my $j = index( $_, '))' ); 509 | my $val = substr($_,$i+2,$j-$i-3); 510 | ($val) = split(/\)/, $val); 511 | ($$prefix,$$delimiter) = split( / /, $val ); 512 | $$prefix =~ s/"//g; 513 | $$delimiter =~ s/"//g; 514 | 515 | # Experimental 516 | if ( $public_mbxs ) { 517 | # Figure out the public mailbox settings 518 | /\(\((.+)\)\)\s+\(\((.+)\s+\(\((.+)\)\)/; 519 | $public = $3; 520 | $public =~ /"(.+)"\s+"(.+)"/; 521 | $src_public_prefix = $1 if $conn eq $src; 522 | $src_public_delim = $2 if $conn eq $src; 523 | $dst_public_prefix = $1 if $conn eq $dst; 524 | $dst_public_delim = $2 if $conn eq $dst; 525 | } 526 | last; 527 | } 528 | last if /^1 NO|^1 BAD|^\* BYE/; 529 | } 530 | 531 | unless ( $$delimiter ) { 532 | # NAMESPACE command is not supported by the server 533 | # so we will have to figure it out another way. 534 | $delim = getDelimiter( $conn ); 535 | $$delimiter = $delim; 536 | $$prefix = ''; 537 | } 538 | 539 | if ( $debug ) { 540 | Log("prefix >$$prefix<"); 541 | Log("delim >$$delimiter<"); 542 | } 543 | } 544 | 545 | sub mailboxName { 546 | 547 | my $srcmbx = shift; 548 | my $srcPrefix = shift; 549 | my $srcDelim = shift; 550 | my $dstPrefix = shift; 551 | my $dstDelim = shift; 552 | my $dstmbx; 553 | my $substChar = '_'; 554 | 555 | if ( $public_mbxs ) { 556 | my ($public_src,$public_dst) = split(/:/, $public_mbxs ); 557 | # If the mailbox starts with the public mailbox prefix then 558 | # map it to the public mailbox destination prefix 559 | 560 | if ( $srcmbx =~ /^$public_src/ ) { 561 | Log("src: $srcmbx is a public mailbox") if $debug; 562 | $dstmbx = $srcmbx; 563 | $dstmbx =~ s/$public_src/$public_dst/; 564 | Log("dst: $dstmbx") if $debug; 565 | return $dstmbx; 566 | } 567 | } 568 | 569 | # Change the mailbox name if the user has supplied mapping rules. 570 | 571 | if ( $mbx_map{"$srcmbx"} ) { 572 | $srcmbx = $mbx_map{"$srcmbx"} 573 | } 574 | 575 | # Adjust the mailbox name if the source and destination server 576 | # have different mailbox prefixes or hierarchy delimiters. 577 | 578 | if ( ($srcmbx =~ /[$dstDelim]/) and ($dstDelim ne $srcDelim) ) { 579 | # The mailbox name has a character that is used on the destination 580 | # as a mailbox hierarchy delimiter. We have to replace it. 581 | $srcmbx =~ s^[$dstDelim]^$substChar^g; 582 | } 583 | 584 | if ( $debug ) { 585 | Log("src mbx $srcmbx"); 586 | Log("src prefix $srcPrefix"); 587 | Log("src delim $srcDelim"); 588 | Log("dst prefix $dstPrefix"); 589 | Log("dst delim $dstDelim"); 590 | } 591 | 592 | $srcmbx =~ s/^$srcPrefix//; 593 | $srcmbx =~ s/\\$srcDelim/\//g; 594 | 595 | if ( ($srcPrefix eq $dstPrefix) and ($srcDelim eq $dstDelim) ) { 596 | # No adjustments necessary 597 | # $dstmbx = $srcmbx; 598 | if ( lc( $srcmbx ) eq 'inbox' ) { 599 | $dstmbx = $srcmbx; 600 | } else { 601 | $dstmbx = $srcPrefix . $srcmbx; 602 | } 603 | if ( $root_mbx ) { 604 | # Put folders under a 'root' folder on the dst 605 | $dstmbx =~ s/^$dstPrefix//; 606 | $dstDelim =~ s/\./\\./g; 607 | $dstmbx =~ s/^$dstDelim//; 608 | $dstmbx = $dstPrefix . $root_mbx . $dstDelim . $dstmbx; 609 | if ( uc($srcmbx) eq 'INBOX' ) { 610 | # Special case for the INBOX 611 | $dstmbx =~ s/INBOX$//i; 612 | $dstmbx =~ s/$dstDelim$//; 613 | } 614 | $dstmbx =~ s/\\//g; 615 | } 616 | return $dstmbx; 617 | } 618 | 619 | $srcmbx =~ s#^$srcPrefix##; 620 | $dstmbx = $srcmbx; 621 | 622 | if ( $srcDelim ne $dstDelim ) { 623 | # Need to substitute the dst's hierarchy delimiter for the src's one 624 | $srcDelim = '\\' . $srcDelim if $srcDelim eq '.'; 625 | $dstDelim = "\\" . $dstDelim if $dstDelim eq '.'; 626 | $dstmbx =~ s#$srcDelim#$dstDelim#g; 627 | $dstmbx =~ s/\\//g; 628 | } 629 | if ( $srcPrefix ne $dstPrefix ) { 630 | # Replace the source prefix with the dest prefix 631 | $dstmbx =~ s#^$srcPrefix## if $srcPrefix; 632 | if ( $dstPrefix ) { 633 | $dstmbx = "$dstPrefix$dstmbx" unless uc($srcmbx) eq 'INBOX'; 634 | } 635 | $dstDelim = "\\$dstDelim" if $dstDelim eq '.'; 636 | $dstmbx =~ s#^$dstDelim##; 637 | } 638 | 639 | if ( $root_mbx ) { 640 | # Put folders under a 'root' folder on the dst 641 | $dstDelim =~ s/\./\\./g; 642 | $dstmbx =~ s/^$dstPrefix//; 643 | $dstmbx =~ s/^$dstDelim//; 644 | $dstmbx = $dstPrefix . $root_mbx . $dstDelim . $dstmbx; 645 | if ( uc($srcmbx) eq 'INBOX' ) { 646 | # Special case for the INBOX 647 | $dstmbx =~ s/INBOX$//i; 648 | $dstmbx =~ s/$dstDelim$//; 649 | } 650 | $dstmbx =~ s/\\//g; 651 | } 652 | 653 | return $dstmbx; 654 | } 655 | 656 | sub isAscii { 657 | 658 | my $str = shift; 659 | my $ascii = 1; 660 | 661 | # Determine whether a string contains non-ASCII characters 662 | 663 | my $test = $str; 664 | $test=~s/\P{IsASCII}/?/g; 665 | $ascii = 0 unless $test eq $str; 666 | 667 | return $ascii; 668 | 669 | } 670 | 671 | sub getDelimiter { 672 | 673 | my $conn = shift; 674 | my $delimiter; 675 | 676 | # Issue a 'LIST "" ""' command to find out what the 677 | # mailbox hierarchy delimiter is. 678 | 679 | sendCommand ($conn, '1 LIST "" ""'); 680 | @response = ''; 681 | while ( 1 ) { 682 | readResponse ($conn); 683 | if ( $response =~ /^1 OK/i ) { 684 | last; 685 | } 686 | elsif ( $response !~ /^\*/ ) { 687 | Log ("unexpected response: $response"); 688 | return 0; 689 | } 690 | } 691 | 692 | for $i (0 .. $#response) { 693 | $response[$i] =~ s/\s+/ /; 694 | if ( $response[$i] =~ /\* LIST \((.*)\) "(.*)" "(.*)"/i ) { 695 | $delimiter = $2; 696 | } 697 | } 698 | 699 | return $delimiter; 700 | } 701 | 702 | # Reconnect to the servers after a timeout error. 703 | # 704 | sub reconnect { 705 | 706 | my $checkpoint = shift; 707 | my $conn = shift; 708 | 709 | Log("Attempting to reconnect"); 710 | 711 | my ($mbx,$shost,$suser,$spwd,$dhost,$duser,$dpwd) = split(/\|/, $checkpoint); 712 | 713 | close $src; 714 | close $dst; 715 | 716 | connectToHost($shost,\$src); 717 | login($suser,$spwd,$shost,$src); 718 | 719 | connectToHost($dhost,\$dst); 720 | login($duser,$dpwd,$dhost,$dst); 721 | 722 | selectMbx( $mbx, $src ); 723 | createMbx( $mbx, $dst ); # Just in case 724 | 725 | } 726 | 727 | # Handle signals 728 | 729 | sub signalHandler { 730 | 731 | my $sig = shift; 732 | 733 | if ( $sig eq 'ALRM' ) { 734 | Log("Caught a SIG$sig signal, timeout error"); 735 | $conn_timed_out = 1; 736 | } else { 737 | Log("Caught a SIG$sig signal, shutting down"); 738 | exit; 739 | } 740 | Log("Resuming"); 741 | } 742 | 743 | sub fixup_date { 744 | 745 | my $date = shift; 746 | 747 | # Make sure the hrs part of the date is 2 digits. At least 748 | # one IMAP server expects this. 749 | 750 | $$date =~ s/^\s+//; 751 | $$date =~ /(.+) (.+):(.+):(.+) (.+)/; 752 | my $hrs = $2; 753 | 754 | return if length( $hrs ) == 2; 755 | 756 | my $newhrs = '0' . $hrs if length( $hrs ) == 1; 757 | $$date =~ s/ $hrs/ $newhrs/; 758 | 759 | } 760 | 761 | sub count_msgs { 762 | 763 | my $mbx = shift; 764 | my $conn = shift; 765 | my @msgs; 766 | 767 | # Get the msg count and size 768 | 769 | getMsgList( $mbx, \@msgs, $conn, 'SELECT' ); 770 | my $msgcount = $#msgs + 1; 771 | 772 | my $total = 0; 773 | foreach my $size ( @msgs ) { 774 | $total += $size; 775 | } 776 | $total = sprintf("%.2f", $total/1000000); 777 | $total .= ' MB'; 778 | my $count = scalar @msgs; 779 | 780 | return ($count,$total); 781 | 782 | } 783 | 784 | sub cram_md5 { 785 | 786 | my $challenge = shift; 787 | my $user = shift; 788 | my $password = shift; 789 | 790 | eval 'use Digest::HMAC_MD5 qw(hmac_md5_hex)'; 791 | use MIME::Base64 qw(decode_base64 encode_base64); 792 | 793 | # Adapated from script by Paul Makepeace , 2002-10-12 794 | # Takes user, key, and base-64 encoded challenge and returns base-64 795 | # encoded CRAM. See, 796 | # IMAP/POP AUTHorize Extension for Simple Challenge/Response: 797 | # RFC 2195 http://www.faqs.org/rfcs/rfc2195.html 798 | # SMTP Service Extension for Authentication: 799 | # RFC 2554 http://www.faqs.org/rfcs/rfc2554.html 800 | # Args: tim tanstaaftanstaaf PDE4OTYuNjk3MTcwOTUyQHBvc3RvZmZpY2UucmVzdG9uLm1jaS5uZXQ+ 801 | # should yield: dGltIGI5MTNhNjAyYzdlZGE3YTQ5NWI0ZTZlNzMzNGQzODkw 802 | 803 | my $challenge_data = decode_base64($challenge); 804 | my $hmac_digest = hmac_md5_hex($challenge_data, $password); 805 | my $response = encode_base64("$user $hmac_digest"); 806 | chomp $response; 807 | 808 | if ( $debug ) { 809 | Log("Challenge: $challenge_data"); 810 | Log("HMAC digest: $hmac_digest"); 811 | Log("CRAM Base64: $response"); 812 | } 813 | 814 | return $response; 815 | } 816 | 817 | sub validate_date { 818 | 819 | my $date = shift; 820 | my $invalid; 821 | 822 | # Make sure the "after" date is in DD-MMM-YYYY format 823 | 824 | my ($day,$month,$year) = split(/-/, $date); 825 | $invalid = 1 unless ( $day > 0 and $day < 32 ); 826 | $invalid = 1 unless $month =~ /Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec/i; 827 | $invalid = 1 unless $year > 1900 and $year < 2999; 828 | if ( $invalid ) { 829 | Log("The 'Sent after' date $date must be in DD-MMM-YYYY format"); 830 | exit; 831 | } 832 | } 833 | 834 | sub commafy { 835 | 836 | my $number = shift; 837 | 838 | $_ = $$number; 839 | 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; 840 | 841 | $$number = $_; 842 | 843 | } 844 | 845 | sub usage { 846 | 847 | print STDERR "Usage: $0 -S // [-O ]\n"; 848 | print STDERR " [-u \n"; 849 | print STDERR " [-A \n"; 850 | print STDERR " [-I] log IMAP commands and responses\n"; 851 | print STDERR " [-t ] time out a session (default is 45 seconds)\n"; 852 | exit; 853 | 854 | } 855 | 856 | sub Log { 857 | 858 | my $str = shift; 859 | 860 | print STDERR "$str\n"; 861 | 862 | } 863 | 864 | sub getMsgList { 865 | 866 | my $mailbox = shift; 867 | my $msgs = shift; 868 | my $conn = shift; 869 | my $mode = shift; 870 | my $seen; 871 | my $empty; 872 | my $msgnum; 873 | my $from; 874 | my $flags; 875 | my $msgid; 876 | 877 | @$msgs = (); 878 | $mode = 'EXAMINE' unless $mode; 879 | sendCommand ($conn, "1 $mode \"$mailbox\""); 880 | undef @response; 881 | $empty=0; 882 | while ( 1 ) { 883 | readResponse ( $conn ); 884 | if ( $response =~ / 0 EXISTS/i ) { $empty=1; } 885 | if ( $response =~ /^1 OK/i ) { 886 | last; 887 | } 888 | elsif ( $response !~ /^\*/ ) { 889 | Log ("unexpected response: $response"); 890 | return 0; 891 | } 892 | } 893 | 894 | return (0, 0) if $empty; 895 | 896 | my $start = 1; 897 | my $end = '*'; 898 | $start = $start_fetch if $start_fetch; 899 | $end = $end_fetch if $end_fetch; 900 | 901 | sendCommand ( $conn, "1 FETCH $start:$end (RFC822.SIZE)"); 902 | 903 | @response = (); 904 | while ( 1 ) { 905 | readResponse ( $conn ); 906 | 907 | if ( $response =~ /^1 OK/i ) { 908 | last; 909 | } 910 | last if $response =~ /^1 NO|^1 BAD|^\* BYE/; 911 | 912 | if ( $response =~ /^\* BYE/ ) { 913 | Log("The server terminated our connection: $response"); 914 | exit; 915 | } 916 | } 917 | 918 | $flags = ''; 919 | for $i (0 .. $#response) { 920 | $response = $response[$i]; 921 | last if $response[$i] =~ /^1 OK FETCH complete/i; 922 | 923 | if ( $response =~ /^\* BYE/ ) { 924 | Log("The server terminated our connection: $response[$i]"); 925 | Log("msgnum $msgnum"); 926 | exit; 927 | } 928 | 929 | if ( $response[$i] =~ /INTERNALDATE (.+) RFC822\.SIZE/i ) { 930 | $date = $1; 931 | $date =~ /"(.+)"/; 932 | $date = $1; 933 | $date =~ s/"//g; 934 | } 935 | 936 | if ( $response[$i] =~ /\(RFC822\.SIZE (.+)\)/i) { 937 | $size = $1; 938 | 939 | if ( $report_large_msgs == 1 ) { 940 | push( @large_msgs, "$size $mailbox") if $size > $large_msg_threshold; 941 | } 942 | } 943 | 944 | if ( $size ) { 945 | push (@$msgs,$size); 946 | $size = ''; 947 | } 948 | } 949 | 950 | return 1; 951 | 952 | } 953 | 954 | sub get_user_list { 955 | 956 | my @users; 957 | 958 | if ( !open(F, "<$user_list") ) { 959 | print STDERR "Fatal error opening user_list $user_list: $!\n"; 960 | exit; 961 | } 962 | while( ) { 963 | chomp; 964 | s/^\s+//g; 965 | next if /^#/; # Skip comments 966 | push( @users, $_ ); 967 | } 968 | close F; 969 | 970 | return @users; 971 | 972 | } 973 | 974 | sub capability { 975 | 976 | my $conn = shift; 977 | my @response; 978 | my $capability; 979 | my $quota_ext = 'not enabled'; 980 | 981 | sendCommand ($conn, "1 CAPABILITY"); 982 | while (1) { 983 | readResponse ( $conn ); 984 | $capability = $response if $response =~ /\* CAPABILITY/i; 985 | last if $response =~ /^1 OK/i; 986 | if ($response =~ /^1 NO|^1 BAD/i) { 987 | print "Unexpected response: $response\n"; 988 | return 0; 989 | } 990 | } 991 | 992 | $quota_ext = 'enabled' if $capability =~ / QUOTA /i; 993 | 994 | return $quota_ext; 995 | print STDERR "quota $quota\n"; 996 | 997 | } 998 | 999 | sub get_quota { 1000 | 1001 | my $conn = shift; 1002 | 1003 | # sendCommand ($conn, "1 getQuotaroot index"); 1004 | sendCommand ($conn, "1 getquotaroot \"Inbox\""); 1005 | while (1) { 1006 | readResponse ( $conn ); 1007 | # if ( $response =~ /\* QUOTA "#Account" \(STORAGE (.+) (.+)\)/i ) { 1008 | if ( $response =~ /\(STORAGE (.+) (.+)\)/i ) { 1009 | $quota = $1; 1010 | } 1011 | last if $response =~ /^1 OK/i; 1012 | if ($response =~ /^1 NO|^1 BAD/i) { 1013 | print "Unexpected response: $response\n"; 1014 | return 0; 1015 | } 1016 | } 1017 | 1018 | # Normalize to MB 1019 | $quota = sprintf( "%.2f", $quota/1000 ); 1020 | 1021 | return $quota; 1022 | } 1023 | 1024 | sub login { 1025 | 1026 | my $user = shift; 1027 | my $pwd = shift; 1028 | my $conn = shift; 1029 | 1030 | print "This is login\n"; 1031 | print "user $user\n"; 1032 | print "pwd $pwd\n"; 1033 | print "conn $conn\n"; 1034 | $showIMAP = 1; 1035 | sendCommand ($conn, "1 LOGIN $user \"$pwd\""); 1036 | while (1) { 1037 | readResponse ( $conn ); 1038 | 1039 | if ( $response =~ /Cyrus/i and $conn eq $dst ) { 1040 | Log("Destination is a Cyrus server"); 1041 | $cyrus = 1; 1042 | } 1043 | 1044 | if ( $response =~ /Microsoft Exchange/i and $conn eq $dst ) { 1045 | # The destination is an Exchange server 1046 | unless ( $exchange_override ) { 1047 | $exchange = 1; 1048 | Log("The destination is an Exchange server"); 1049 | } 1050 | } 1051 | last if $response =~ /^1 OK/i; 1052 | 1053 | if ($response =~ /^1 NO|^1 BAD|^\* BYE/i) { 1054 | Log ("unexpected LOGIN response: $response"); 1055 | return 0; 1056 | } 1057 | } 1058 | Log("Logged in as $user") if $debug; 1059 | 1060 | } 1061 | -------------------------------------------------------------------------------- /test_oauth2_login.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # $Header: /mhub4/sources/imap-tools/test_oauth2_login.pl,v 1.1 2015/07/11 13:33:45 rick Exp $ 4 | 5 | ####################################################################### 6 | # Program name test_oauth2_login.pl # 7 | # Written by Rick Sanders, IMAP Tools # 8 | # Date 11-July-2015 # 9 | # # 10 | # This short script can be used to test OAUTH2 login into Gmail # 11 | # Usage: ./test_oauth2_login.pl # 12 | ####################################################################### 13 | 14 | use Socket; 15 | use Getopt::Std; 16 | use Encode qw/encode decode/; 17 | use MIME::Base64 qw(decode_base64 encode_base64); 18 | 19 | init(); 20 | get_info( \$user, \$token ); 21 | connectToHost( 'imap.gmail.com:993', \$conn ) or exit; 22 | login_xoauth2( $user, $token, $conn ) or exit; 23 | 24 | print "\nLogin was successful\n\n"; 25 | 26 | logout( $conn ); 27 | 28 | exit; 29 | 30 | 31 | sub init { 32 | 33 | # Determine whether we have SSL support via openSSL and IO::Socket::SSL 34 | 35 | $ssl_installed = 1; 36 | eval 'use IO::Socket::SSL'; 37 | if ( $@ ) { 38 | $ssl_installed = 0; 39 | } 40 | } 41 | 42 | sub get_info { 43 | 44 | my $user = shift; 45 | my $token = shift; 46 | 47 | if ( $ARGV[0] and $ARGV[1] ) { 48 | $$user = $ARGV[0]; 49 | $$token = $ARGV[1]; 50 | } else { 51 | print "User: "; 52 | $$user = <>; 53 | chomp $$user; 54 | print "Token: "; 55 | $$token = <>; 56 | chomp $$token; 57 | } 58 | 59 | } 60 | 61 | # 62 | # sendCommand 63 | # 64 | # This subroutine formats and sends an IMAP protocol command to an 65 | # IMAP server on a specified connection. 66 | # 67 | 68 | sub sendCommand { 69 | 70 | my $fd = shift; 71 | my $cmd = shift; 72 | 73 | # If we've had to reconnect use the new connection 74 | if ( $CONNECTIONS{"$fd"} ) { 75 | $fd = $CONNECTIONS{"$fd"}; 76 | Log("Using the new connection $fd"); 77 | } 78 | 79 | print $fd "$cmd\r\n"; 80 | 81 | Log (">> $cmd") if $showIMAP; 82 | } 83 | 84 | # 85 | # readResponse 86 | # 87 | # This subroutine reads and formats an IMAP protocol response from an 88 | # IMAP server on a specified connection. 89 | # 90 | 91 | sub readResponse { 92 | 93 | my $fd = shift; 94 | 95 | # If we've had to reconnect use the new connection 96 | if ( $CONNECTIONS{"$fd"} ) { 97 | $fd = $CONNECTIONS{"$fd"}; 98 | Log("Using the new connection $fd"); 99 | } 100 | 101 | $response = <$fd>; 102 | chop $response; 103 | $response =~ s/\r//g; 104 | push (@response,$response); 105 | Log ("<< $response") if $showIMAP; 106 | 107 | if ( $response =~ /\* BAD internal server error/i ) { 108 | Log("Fatal IMAP server error: $response"); 109 | exit; 110 | } 111 | 112 | if ( $exchange and $response =~ /^1 NO|^1 BAD/ ) { 113 | $errors++; 114 | exchange_workaround() if $errors == 9; 115 | } 116 | 117 | if ( $response =~ /connection closed/i ) { 118 | ($src,$dst) = reconnect(); 119 | } 120 | } 121 | 122 | # Make a connection to an IMAP host 123 | 124 | sub connectToHost { 125 | 126 | my $host = shift; 127 | my $conn = shift; 128 | 129 | Log("Connecting to $host") if $debug; 130 | 131 | ($host,$port) = split(/:/, $host); 132 | $port = 143 unless $port; 133 | 134 | # We know whether to use SSL for ports 143 and 993. For any 135 | # other ones we'll have to figure it out. 136 | $mode = sslmode( $host, $port ); 137 | 138 | if ( $mode eq 'SSL' ) { 139 | unless( $ssl_installed == 1 ) { 140 | warn("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 141 | Log("You must have openSSL and IO::Socket::SSL installed to use an SSL connection"); 142 | exit; 143 | } 144 | Log("Attempting an SSL connection") if $debug; 145 | $$conn = IO::Socket::SSL->new( 146 | Proto => "tcp", 147 | SSL_verify_mode => 0x00, 148 | PeerAddr => $host, 149 | PeerPort => $port, 150 | Domain => AF_INET, 151 | ); 152 | 153 | unless ( $$conn ) { 154 | $error = IO::Socket::SSL::errstr(); 155 | Log("Error connecting to $host: $error"); 156 | exit; 157 | } 158 | } else { 159 | # Non-SSL connection 160 | Log("Attempting a non-SSL connection") if $debug; 161 | $$conn = IO::Socket::INET->new( 162 | Proto => "tcp", 163 | PeerAddr => $host, 164 | PeerPort => $port, 165 | ); 166 | 167 | unless ( $$conn ) { 168 | Log("Error connecting to $host:$port: $@"); 169 | warn "Error connecting to $host:$port: $@"; 170 | exit; 171 | } 172 | } 173 | # Log("Connected to $host on port $port"); 174 | 175 | } 176 | 177 | sub sslmode { 178 | 179 | my $host = shift; 180 | my $port = shift; 181 | my $mode; 182 | 183 | # Determine whether to make an SSL connection 184 | # to the host. Return 'SSL' if so. 185 | 186 | if ( $port == 143 ) { 187 | # Standard non-SSL port 188 | return ''; 189 | } elsif ( $port == 993 ) { 190 | # Standard SSL port 191 | return 'SSL'; 192 | } 193 | 194 | unless ( $ssl_installed ) { 195 | # We don't have SSL installed on this machine 196 | return ''; 197 | } 198 | 199 | # For any other port we need to determine whether it supports SSL 200 | 201 | my $conn = IO::Socket::SSL->new( 202 | Proto => "tcp", 203 | SSL_verify_mode => 0x00, 204 | PeerAddr => $host, 205 | PeerPort => $port, 206 | ); 207 | 208 | if ( $conn ) { 209 | close( $conn ); 210 | $mode = 'SSL'; 211 | } else { 212 | $mode = ''; 213 | } 214 | 215 | return $mode; 216 | } 217 | 218 | # login_xoauth2 219 | # 220 | # login in at the source host with the user's name and an XOAUTH2 token. 221 | # 222 | sub login_xoauth2 { 223 | 224 | my $user = shift; 225 | my $token = shift; 226 | my $conn = shift; 227 | 228 | # Do an AUTHENTICATE = XOAUTH2 login 229 | 230 | $showIMAP = 1; 231 | $login_str = encode_base64("user=". $user ."\x01auth=Bearer ". $token ."\x01\x01", ''); 232 | sendCommand ($conn, "1 AUTHENTICATE XOAUTH2 $login_str" ); 233 | 234 | my $loops; 235 | while (1) { 236 | readResponse ( $conn ); 237 | if ( $response =~ /^\+ (.+)/ ) { 238 | $error = decode_base64( $1 ); 239 | Log("XOAUTH authentication as $user failed: $error"); 240 | exit; 241 | } 242 | last if $response =~ /^1 OK/; 243 | if ($response =~ /^1 NO|^1 BAD|^\* BYE|failed/i) { 244 | Log ("unexpected LOGIN response: $response"); 245 | exit; 246 | } 247 | $last if $loops++ > 5; 248 | } 249 | 250 | Log("login complete") if $debug; 251 | 252 | return 1; 253 | 254 | } 255 | 256 | # logout 257 | # 258 | # log out from the host 259 | # 260 | sub logout { 261 | 262 | my $conn = shift; 263 | 264 | undef @response; 265 | sendCommand ($conn, "1 LOGOUT"); 266 | while ( 1 ) { 267 | readResponse ($conn); 268 | if ( $response =~ /^1 OK/i ) { 269 | last; 270 | } 271 | elsif ( $response !~ /^\*/ ) { 272 | Log ("unexpected LOGOUT response: $response"); 273 | last; 274 | } 275 | } 276 | close $conn; 277 | return; 278 | } 279 | 280 | sub Log { 281 | 282 | my $string = shift; 283 | 284 | print "$string\n"; 285 | 286 | } 287 | --------------------------------------------------------------------------------