1# IMAP::Admin - perl module for helping ease the administration of imap servers 2 3package IMAP::Admin; 4 5use strict; 6use Carp; 7use IO::Select; 8use IO::Socket; 9#use IO::Socket::INET; 10use Cwd; 11 12use vars qw($VERSION); 13 14$VERSION = '1.6.8'; 15 16sub new { 17 my $class = shift; 18 my $self = {}; 19 my @defaults = ( 20 'Port' => 143, 21 'Separator' => '.', 22 'CRAM' => 0, 23 ); 24 25 bless $self, $class; 26 if ((scalar(@_) % 2) != 0) { 27 croak "$class called with incorrect number of arguments"; 28 } 29 unshift @_, @defaults; 30 %{$self} = @_; # set up parameters; 31 $self->{'CLASS'} = $class; 32 $self->_initialize; 33 return $self; 34} 35 36sub _initialize { 37 my $self = shift; 38 39 if (!defined($self->{'Server'})) { 40 croak "$self->{'CLASS'} not initialized properly : Server parameter missing"; 41 } 42 if (!defined($self->{'Login'})) { 43 croak "$self->{'CLASS'} not initialized properly : Login parameter missing"; 44 } 45 if (!defined($self->{'Password'})) { 46 croak "$self->{'CLASS'} not initialized properly : Password parameter missing"; 47 } 48 if ($self->{'CRAM'} != 0) { 49 my $cram_try = "use Digest::HMAC; use Digest::MD5; use MIME::Base64;"; 50 eval $cram_try; 51 } 52 if (defined($self->{'SSL'})) { # attempt SSL connection instead 53 # construct array of ssl options 54 my $cwd = cwd; 55 my %ssl_defaults = ( 56 'SSL_use_cert' => 0, 57 'SSL_verify_mode' => 0x00, 58 'SSL_key_file' => $cwd."/certs/client-key.pem", 59 'SSL_cert_file' => $cwd."/certs/client-cert.pem", 60 'SSL_ca_path' => $cwd."/certs", 61 'SSL_ca_file' => $cwd."/certs/ca-cert.pem", 62 ); 63 my @ssl_options; 64 my $ssl_key; 65 my $key; 66 foreach $ssl_key (keys(%ssl_defaults)) { 67 if (!defined($self->{$ssl_key})) { 68 $self->{$ssl_key} = $ssl_defaults{$ssl_key}; 69 } 70 } 71 foreach $ssl_key (keys(%{$self})) { 72 if ($ssl_key =~ /^SSL_/) { 73 push @ssl_options, $ssl_key, $self->{$ssl_key}; 74 } 75 } 76 my $SSL_try = "use IO::Socket::SSL"; 77 78 eval $SSL_try; 79# $IO::Socket::SSL::DEBUG = 1; 80 if (!eval { 81 $self->{'Socket'} = 82 IO::Socket::SSL->new(PeerAddr => $self->{'Server'}, 83 PeerPort => $self->{'Port'}, 84 Proto => 'tcp', 85 Reuse => 1, 86 Timeout => 5, 87 @ssl_options); }) { 88 $self->_error("initialize", "couldn't establish SSL connection to", 89 $self->{'Server'}, "[$!]"); 90 delete $self->{'Socket'}; 91 return; 92 } 93 } else { 94 if ($self->{'Server'} =~ /^\//) { 95 if (!eval { 96 $self->{'Socket'} = 97 IO::Socket::UNIX->new(Peer => $self->{'Server'}); }) 98 { 99 delete $self->{'Socket'}; 100 $self->_error("initialize", "couldn't establish connection to", 101 $self->{'Server'}); 102 return; 103 } 104 } else { 105 if (!eval { 106 $self->{'Socket'} = 107 IO::Socket::INET->new(PeerAddr => $self->{'Server'}, 108 PeerPort => $self->{'Port'}, 109 Proto => 'tcp', 110 Reuse => 1, 111 Timeout => 5); }) 112 { 113 delete $self->{'Socket'}; 114 $self->_error("initialize", "couldn't establish connection to", 115 $self->{'Server'}); 116 return; 117 } 118 } 119 } 120 my $fh = $self->{'Socket'}; 121 my $try = $self->_read; # get Banner 122 if ($try !~ /\* OK/) { 123 $self->close; 124 $self->_error("initialize", "bad response from", $self->{'Server'}, 125 "[", $try, "]"); 126 return; 127 } 128 # this section was changed to accomodate motd's 129 print $fh "try CAPABILITY\n"; 130 $try = $self->_read; 131 while ($try !~ /^\* CAPABILITY/) { # we have a potential lockup, should alarm this 132 $try = $self->_read; 133 } 134 $self->{'Capability'} = $try; 135 $try = $self->_read; 136 if ($try !~ /^try OK/) { 137 $self->close; 138 $self->_error("initialize", "Couldn't do a capabilites check [", 139 $try, "]"); 140 return; 141 } 142 if ($self->{'CRAM'} > 0) { 143 if ($self->{'Capability'} =~ /CRAM-MD5/) { 144 _do_cram_login($self); 145 } else { 146 if ($self->{'CRAM'} > 1) { 147 print $fh qq{try LOGIN "$self->{'Login'}" "$self->{'Password'}"\n}; 148 } else { 149 $self->close; 150 $self->_error("initialize","CRAM not reported in Capability check and fallback to PLAIN not selected", $self->{'Server'}, "[", $self->{'Capability'}, "]"); 151 return; 152 } 153 } 154 } else { 155 print $fh qq{try LOGIN "$self->{'Login'}" "$self->{'Password'}"\n}; 156 } 157 $try = $self->_read; 158 if ($try !~ /^try OK/) { # should tr this response 159 $self->close; 160 $self->_error("initialize", $try); 161 return; 162 } else { 163 $self->{'Error'} = "No Errors"; 164 return; 165 } 166 # fall thru, can it be hit ? 167 $self->{'Error'} = "No Errors"; 168 return; 169} 170 171# this routine uses evals to prevent errors regarding missing modules 172sub _do_cram_login { 173 my $self = shift; 174 my $fh = $self->{'Socket'}; 175 my $ans; 176 177 print $fh "try AUTHENTICATE CRAM-MD5\n"; 178 my $try = $self->_read; # gets back the postal string 179 ($ans) = (split(' ', $try, 2))[1]; 180 my $cram_eval = " 181 my \$hmac = Digest::HMAC->new(\$self->{'Password'}, 'Digest::MD5'); 182 \$hmac->add(decode_base64(\$ans)); 183 \$ans = encode_base64(\$self->{'Login'}.' '.\$hmac->hexdigest, ''); 184 "; 185 eval $cram_eval; 186 print $fh "$ans\n"; 187 return; 188} 189 190sub _error { 191 my $self = shift; 192 my $func = shift; 193 my @error = @_; 194 195 $self->{'Error'} = join(" ",$self->{'CLASS'}, "[", $func, "]:", @error); 196 return; 197} 198 199sub error { 200 my $self = shift; 201 return $self->{'Error'}; 202} 203 204sub _read { 205 my $self = shift; 206 my $buffer = ""; 207 my $char = ""; 208 my $bytes = 1; 209 while ($bytes == 1) { 210 $bytes = sysread $self->{'Socket'}, $char, 1; 211 if ($bytes == 0) { 212 if (length ($buffer) != 0) { 213 return $buffer; 214 } else { 215 return; 216 } 217 } else { 218 if (($char eq "\n") or ($char eq "\r")) { 219 if (length($buffer) == 0) { 220 # cr or nl left over, just eat it 221 } else { 222 return $buffer; 223 } 224 } else { 225# print "got char [$char]\n"; 226 $buffer .= $char; 227 } 228 } 229 } 230} 231 232sub close { 233 my $self = shift; 234 235 if (!defined($self->{'Socket'})) { 236 return 0; 237 } 238 my $fh = $self->{'Socket'}; 239 print $fh "try logout\n"; 240 my $try = $self->_read; 241 close($self->{'Socket'}); 242 delete $self->{'Socket'}; 243 return 0; 244} 245 246sub create { 247 my $self = shift; 248 249 if (!defined($self->{'Socket'})) { 250 return 1; 251 } 252 if ((scalar(@_) != 1) && (scalar(@_) != 2)) { 253 $self->_error("create", "incorrect number of arguments"); 254 return 1; 255 } 256 my $mailbox = shift; 257 my $fh = $self->{'Socket'}; 258 if (scalar(@_) == 1) { # a partition exists 259 print $fh qq{try CREATE "$mailbox" $_[0]\n}; 260 } else { 261 print $fh qq{try CREATE "$mailbox"\n}; 262 } 263 my $try = $self->_read; 264 if ($try =~ /^try OK/) { 265 $self->{'Error'} = 'No Errors'; 266 return 0; 267 } else { 268 $self->_error("create", "couldn't create", $mailbox, ":", $try); 269 return 1; 270 } 271} 272 273sub rename { 274 my $self = shift; 275 276 if (!defined($self->{'Socket'})) { 277 return 1; 278 } 279 if ((scalar(@_) != 2) && (scalar(@_) != 3)) { 280 $self->_error("rename", "incorrect number of arguments"); 281 return 1; 282 } 283 my $old_name = shift; 284 my $new_name = shift; 285 my $partition = shift; 286 287 my $fh = $self->{'Socket'}; 288 if (defined $partition) { 289 print $fh qq{try RENAME "$old_name" "$new_name" $partition\n}; 290 } else { 291 print $fh qq{try RENAME "$old_name" "$new_name"\n}; 292 } 293 my $try = $self->_read; 294 if (($try =~ /^try OK/) || ($try =~ /^\* OK/)) { 295 $self->{'Error'} = 'No Errors'; 296 return 0; 297 } else { 298 $self->_error("rename", "couldn't rename", $old_name, "to", $new_name, 299 ":", $try); 300 return 1; 301 } 302} 303 304sub delete { 305 my $self = shift; 306 307 if (!defined($self->{'Socket'})) { 308 return 1; 309 } 310 if (scalar(@_) != 1) { 311 $self->_error("delete", "incorrect number of arguments"); 312 return 1; 313 } 314 my $mailbox = shift; 315 my $fh = $self->{'Socket'}; 316 print $fh qq{try DELETE "$mailbox"\n}; 317 my $try = $self->_read; 318 if ($try =~ /^try OK/) { 319 $self->{'Error'} = 'No Errors'; 320 return 0; 321 } else { 322 $self->_error("delete", "couldn't delete", $mailbox, ":", $try); 323 return 1; 324 } 325} 326 327sub h_delete { 328 my $self = shift; 329 330 if (!defined($self->{'Socket'})) { 331 return 1; 332 } 333 if (scalar(@_) != 1) { 334 $self->_error("h_delete", "incorrect number of arguments"); 335 return 1; 336 } 337 my $mailbox = shift; 338 my $fh = $self->{'Socket'}; 339 # first get a list of all sub boxes then nuke them, accumulate errors 340 # then do something intelligent with them (hmmmmm) 341 my $box = join($self->{'Separator'}, $mailbox, "*"); 342 my @sub_boxes = $self->list($box); 343 push @sub_boxes, $mailbox; 344 # uncomment following line if you are sanity checking h_delete 345 # print "h_delete: got this list of sub boxes [@sub_boxes]\n"; 346 foreach $box (@sub_boxes) { 347 print $fh qq{try DELETE "$box"\n}; 348 my $try = $self->_read; 349 if ($try =~ /^try OK/) { 350 $self->{'Error'} = 'No Errors'; 351 } else { 352 $self->_error("h_delete", "couldn't delete", 353 $mailbox, ":", $try); 354 return 1; # or just return on the first encountered error ? 355 } 356 } 357 return 0; 358} 359 360sub get_quotaroot { # returns an array or undef 361 my $self = shift; 362 my (@quota, @info); 363 364 if (!defined($self->{'Socket'})) { 365 return 1; 366 } 367 if (!($self->{'Capability'} =~ /QUOTA/)) { 368 $self->_error("get_quotaroot", "QUOTA not listed in server's capabilities"); 369 return 1; 370 } 371 if (scalar(@_) != 1) { 372 $self->_error("get_quotaroot", "incorrect number of arguments"); 373 return 1; 374 } 375 my $mailbox = shift; 376 my $fh = $self->{'Socket'}; 377 print $fh qq{try GETQUOTAROOT "$mailbox"\n}; 378 my $try = $self->_read; 379 while ($try =~ /^\* QUOTA/) { 380 if ($try !~ /QUOTAROOT/) { # some imap servers give this extra line 381 @info = ($try =~ /QUOTA\s(.*?)\s\(STORAGE\s(\d+)\s(\d+)/); 382 push @quota, @info; 383 } 384 $try = $self->_read; 385 } 386 if ($try =~ /^try OK/) { 387 return @quota; 388 } else { 389 $self->_error("get_quotaroot", "couldn't get quota for", $mailbox, ":", $try); 390 return; 391 } 392} 393 394sub get_quota { # returns an array or undef 395 my $self = shift; 396 my (@quota, @info); 397 398 if (!defined($self->{'Socket'})) { 399 return; 400 } 401 if (!($self->{'Capability'} =~ /QUOTA/)) { 402 $self->_error("get_quota", 403 "QUOTA not listed in server's capabilities"); 404 return; 405 } 406 if (scalar(@_) != 1) { 407 $self->_error("get_quota", "incorrect number of arguments"); 408 return; 409 } 410 my $mailbox = shift; 411 my $fh = $self->{'Socket'}; 412 print $fh qq{try GETQUOTA "$mailbox"\n}; 413 my $try = $self->_read; 414 while ($try =~ /^\* QUOTA/) { 415 @info = ($try =~ /QUOTA\s(.*?)\s\(STORAGE\s(\d+)\s(\d+)/); 416 push @quota, @info; 417 $try = $self->_read; 418 } 419 if ($try =~ /^try OK/) { 420 return @quota; 421 } else { 422 $self->_error("get_quota", "couldn't get quota for", $mailbox, ":", $try); 423 return; 424 } 425} 426 427sub set_quota { 428 my $self = shift; 429 430 if (!defined($self->{'Socket'})) { 431 return 1; 432 } 433 if (!($self->{'Capability'} =~ /QUOTA/)) { 434 $self->_error("set_quota", "QUOTA not listed in server's capabilities"); 435 return 1; 436 } 437 if (scalar(@_) != 2) { 438 $self->_error("set_quota", "incorrect number of arguments"); 439 return 1; 440 } 441 my $mailbox = shift; 442 my $quota = shift; 443 my $fh = $self->{'Socket'}; 444 if ($quota eq "none") { 445 print $fh qq{try SETQUOTA "$mailbox" ()\n}; 446 } else { 447 print $fh qq{try SETQUOTA "$mailbox" (STORAGE $quota)\n}; 448 } 449 my $try = $self->_read; 450 if ($try =~ /^try OK/) { 451 $self->{'Error'} = "No Errors"; 452 return 0; 453 } else { 454 $self->_error("set_quota", "couldn't set quota for", $mailbox, ":", $try); 455 return 1; 456 } 457} 458 459sub subscribe { 460 my $self = shift; 461 462 if (!defined($self->{'Socket'})) { 463 return 1; 464 } 465 if (scalar(@_) != 1) { 466 $self->_error("subscribe", "incorrect number of arguments"); 467 return 1; 468 } 469 my $mailbox = shift; 470 my $fh = $self->{'Socket'}; 471 print $fh qq{try SUBSCRIBE "$mailbox"\n}; 472 my $try = $self->_read; 473 if ($try !~ /^try OK/) { 474 $self->_error("subscribe", "couldn't suscribe ", $mailbox, ":", 475 $try); 476 return 1; 477 } 478 $self->{'Error'} = 'No Errors'; 479 return 0; 480} 481 482sub unsubscribe { 483 my $self = shift; 484 485 if (!defined($self->{'Socket'})) { 486 return 1; 487 } 488 if (scalar(@_) != 1) { 489 $self->_error("unsubscribe", "incorrect number of arguments"); 490 return 1; 491 } 492 my $mailbox = shift; 493 my $fh = $self->{'Socket'}; 494 print $fh qq{try UNSUBSCRIBE "$mailbox"\n}; 495 my $try = $self->_read; 496 if ($try !~ /^try OK/) { 497 $self->_error("unsubscribe", "couldn't unsuscribe ", $mailbox, ":", 498 $try); 499 return 1; 500 } 501 $self->{'Error'} = 'No Errors'; 502 return 0; 503} 504 505sub select { # returns an array or undef 506 my $self = shift; 507 my @info; 508 509 if (!defined($self->{'Socket'})) { 510 return 1; 511 } 512 if (scalar(@_) != 1) { 513 $self->_error("select", "incorrect number of arguments"); 514 return; 515 } 516 517 my $mailbox = shift; 518 my $fh = $self->{'Socket'}; 519 print $fh qq{try SELECT "$mailbox"\n}; 520 my $try = $self->_read; 521 while ($try =~ /^\* (.*)/) { # danger danger (could lock up needs timeout) 522 push @info, $1; 523 $try = $self->_read; 524 } 525 if ($try =~ /^try OK/) { 526 return @info; 527 } else { 528 $self->_error("select", "couldn't select", $mailbox, ":", $try); 529 return; 530 } 531} 532 533sub expunge { # returns an array or undef 534 my $self = shift; 535 my @info; 536 537 if (!defined($self->{'Socket'})) { 538 return 1; 539 } 540 if (scalar(@_) != 0) { 541 $self->_error("expunge", "incorrect number of arguments"); 542 return; 543 } 544 545 my $mailbox = shift; 546 my $fh = $self->{'Socket'}; 547 print $fh qq{try EXPUNGE\n}; 548 my $try = $self->_read; 549 while ($try =~ /^\* (.*)/) { # danger danger (could lock up needs timeout) 550 push @info, $1; 551 $try = $self->_read; 552 } 553 if ($try =~ /^try OK/) { 554 return @info; 555 } else { 556 $self->_error("expunge", "couldn't expunge", $mailbox, ":", $try); 557 return; 558 } 559} 560 561sub get_acl { # returns an array or undef 562 my $self = shift; 563 564 if (!defined($self->{'Socket'})) { 565 return; 566 } 567 if (!($self->{'Capability'} =~ /ACL/)) { 568 $self->_error("get_acl", "ACL not listed in server's capabilities"); 569 return; 570 } 571 if (scalar(@_) != 1) { 572 $self->_error("get_acl", "incorrect number of arguments"); 573 return; 574 } 575 my $mailbox = shift; 576 my $fh = $self->{'Socket'}; 577 print $fh qq{try GETACL "$mailbox"\n}; 578 delete $self->{'acl'}; 579 my $try = $self->_read; 580 while ($try =~ /^\*\s+ACL\s+/) { 581 my $acls = ($try =~ /^\* ACL\s+(?:\".*?\"|\S*)\s+(.*)/)[0]; # separate out the acls 582 my @acls = ($acls =~ /(\".*?\"|\S+)\s*/g); # split up over ws, unless quoted 583 push @{$self->{'acl'}}, @acls; 584 $try = $self->_read; 585 } 586 if ($try =~ /^try OK/) { 587 return @{$self->{'acl'}}; 588 } else { 589 $self->_error("get_acl", "couldn't get acl for", $mailbox, ":", $try); 590 return; 591 } 592} 593 594sub set_acl { 595 my $self = shift; 596 my ($id, $acl); 597 598 if (!defined($self->{'Socket'})) { 599 return 1; 600 } 601 if (!($self->{'Capability'} =~ /ACL/)) { 602 $self->_error("set_acl", "ACL not listed in server's capabilities"); 603 return 1; 604 } 605 if (scalar(@_) < 2) { 606 $self->_error("set_acl", "too few arguments"); 607 return 1; 608 } 609 if ((scalar(@_) % 2) == 0) { 610 $self->_error("set_acl", "incorrect number of arguments"); 611 return 1; 612 } 613 my $mailbox = shift; 614 my $fh = $self->{'Socket'}; 615 while(@_) { 616 $id = shift; 617 $acl = shift; 618 print $fh qq{try SETACL "$mailbox" "$id" "$acl"\n}; 619 my $try = $self->_read; 620 if ($try !~ /^try OK/) { 621 $self->_error("set_acl", "couldn't set acl for", $mailbox, $id, 622 $acl, ":", $try); 623 return 1; 624 } 625 } 626 $self->{'Error'} = 'No Errors'; 627 return 0; 628} 629 630sub delete_acl { 631 my $self = shift; 632 my ($id, $acl); 633 634 if (!defined($self->{'Socket'})) { 635 return 1; 636 } 637 if (!($self->{'Capability'} =~ /ACL/)) { 638 $self->_error("delete_acl", "ACL not listed in server's capabilities"); 639 return 1; 640 } 641 if (scalar(@_) < 1) { 642 $self->_error("delete_acl", "incorrect number of arguments"); 643 return 1; 644 } 645 my $mailbox = shift; 646 my $fh = $self->{'Socket'}; 647 while(@_) { 648 $id = shift; 649 print $fh qq{try DELETEACL "$mailbox" "$id"\n}; 650 my $try = $self->_read; 651 if ($try !~ /^try OK/) { 652 $self->_error("delete_acl", "couldn't delete acl for", $mailbox, 653 $id, $acl, ":", $try); 654 return 1; 655 } 656 } 657 return 0; 658} 659 660sub list { # wild cards are allowed, returns array or undef 661 my $self = shift; 662 my (@info, @mail); 663 664 if (!defined($self->{'Socket'})) { 665 return; 666 } 667 if (scalar(@_) != 1) { 668 $self->_error("list", "incorrect number of arguments"); 669 return; 670 } 671 my $list = shift; 672 my $fh = $self->{'Socket'}; 673 print $fh qq{try LIST "" "$list"\n}; 674 my $try = $self->_read; 675 while ($try =~ /^\* LIST.*?\) \".\" \"*(.*?)\"*$/) { # danger danger (could lock up needs timeout) " <- this quote makes emacs happy 676 push @mail, $1; 677 $try = $self->_read; 678 } 679 if ($try =~ /^try OK/) { 680 return @mail; 681 } else { 682 $self->_error("list", "couldn't get list for", $list, ":", $try); 683 return; 684 } 685} 686 687 688# Autoload methods go after =cut, and are processed by the autosplit program. 689 6901; 691__END__ 692 693=head1 NAME 694 695IMAP::Admin - Perl module for basic IMAP server administration 696 697=head1 SYNOPSIS 698 699 use IMAP::Admin; 700 701 $imap = IMAP::Admin->new('Server' => 'name.of.server.com', 702 'Login' => 'login_of_imap_administrator', 703 'Password' => 'password_of_imap_adminstrator', 704 'Port' => port# (143 is default), 705 'Separator' => ".", # default is a period 706 'CRAM' => 1, # off by default, can be 0,1,2 707 'SSL' => 1, # off by default 708 # and any of the SSL_ options from IO::Socket::SSL 709 ); 710 711 $err = $imap->create("user.bob"); 712 if ($err != 0) { 713 print "$imap->{'Error'}\n"; 714 } 715 if ($err != 0) { 716 print $imap->error; 717 } 718 $err = $imap->create("user.bob", "green"); 719 $err = $imap->delete("user.bob"); 720 $err = $imap->h_delete("user.bob"); 721 722 $err = $imap->subscribe("user.bob"); 723 $err = $imap->unsubscribe("user.bob"); 724 725 $err = $imap->rename("bboard", "newbboard"); 726 $err = $imap->rename("bboard", "newbboard", "partition"); 727 728 @quota = $imap->get_quotaroot("user.bob"); 729 @quota = $imap->get_quota("user.bob"); 730 $err = $imap->set_quota("user.bob", 10000); 731 732 @acl = $imap->get_acl("user.bob"); 733 %acl = $imap->get_acl("user.bob"); 734 $err = $imap->set_acl("user.bob", "admin", "lrswipdca", "joe", "lrs"); 735 $err = $imap->delete_acl("user.bob", "joe", "admin"); 736 737 @list = $imap->list("user.bob"); 738 @list = $imap->list("user.b*"); 739 740 $imap->{'Capability'} # this contains the Capabilities reply from the IMAP server 741 742 $imap->close; # close open imap connection 743 744=head1 DESCRIPTION 745 746IMAP::Admin provides basic IMAP server adminstration. It provides functions for creating and deleting mailboxes and setting various information such as quotas and access rights. 747 748It's interface should, in theory, work with any RFC compliant IMAP server, but I currently have only tested it against Carnegie Mellon University's Cyrus IMAP and Mirapoint's IMAP servers. It does a CAPABILITY check for specific extensions to see if they are supported. 749 750Operationally it opens a socket connection to the IMAP server and logs in with the supplied login and password. You then can call any of the functions to perform their associated operation. 751 752Separator on the new call is the hiearchical separator used by the imap server. It is defaulted to a period ("/" might be another popular one). 753 754CRAM on the new call will attempt to use CRAM-MD5 as the login type of choice. A value of 0 means off, 1 means on, 2 means on with fallback to login. *Note* this options requires these perl modules: Digest::MD5, Digest::HMAC, MIME::Base64 755 756SSL on the new call will attempt to make an SSL connection to the imap server. It does not fallback to a regular connection if it fails. It is off by default. IO::Socket::SSL requires a ca certificate, a client certificate, and a client private key. By default these are in current_directory/certs, respectively named ca-cert.pem, client-cert.pem, and client-key.pem. The location of this can be overridden by setting SSL_ca_file, SSL_cert_file, and SSL_key_file (you'll probably want to also set SSL_ca_path). 757 758If you start the name of the server with a / instead of using tcp/ip it'll attempt to use a unix socket. 759 760I generated my ca cert and ca key with openssl: 761 openssl req -x509 -newkey rsa:1024 -keyout ca-key.pem -out ca-cert.pem 762 763I generated my client key and cert with openssl: 764 openssl req -new -newkey rsa:1024 -keyout client-key.pem -out req.pem -nodes 765 openssl x509 -CA ca-cert.pem -CAkey ca-key.pem -req -in req.pem -out client-cert.pem -addtrust clientAuth -days 600 766 767Setting up SSL Cyrus IMAP v 2.x (completely unofficial, but it worked for me) 768 add these to your /etc/imapd.conf (remember to change /usr/local/cyrus/tls to wherever yours is) 769 tls_ca_path: /usr/local/cyrus/tls 770 tls_ca_file: /usr/local/cyrus/tls/ca-cert.pem 771 tls_key_file: /usr/local/cyrus/tls/serv-key.pem 772 tls_cert_file: /usr/local/cyrus/tls/serv-cert.pem 773 774For my server key I used a self signed certificate: 775 openssl req -x509 -newkey rsa:1024 -keyout serv-key.pem -out serv-cert.pem -nodes -extensions usr_cert (in openssl.cnf I have nsCertType set to server) 776 777I also added this to my /etc/cyrus.conf, it shouldn't strictly be necessary as clients that are RFC2595 compliant can issue a STARTTLS to initiate the secure layer, but currently IMAP::Admin doesn't issue this command (in SERVICES section): 778 imap2 cmd="imapd -s" listen="simap" prefork=0 779 780where simap in /etc/services is: 781 simap 993/tcp # IMAP over SSL 782 783=head2 MAILBOX FUNCTIONS 784 785RFC2060 commands. These should work with any RFC2060 compliant IMAP mail servers. 786 787create makes new mailboxes. Cyrus IMAP, for normal mailboxes, has the user. prefix. 788create returns a 0 on success or a 1 on failure. An error message is placed in the object->{'Error'} variable on failure. create takes an optional second argument that is the partition to create the mailbox in (I don't know if partition is rfc or not, but it is supported by Cyrus IMAP and Mirapoint). 789 790delete destroys mailboxes. 791The action delete takes varies from server to server depending on it's implementation. On some servers this is a hierarchical delete and on others this will delete only the mailbox specified and only if it has no subfolders that are marked \Noselect. If you wish to insure a hierarchical delete use the h_delete command as it deletes starting with the subfolders and back up to the specified mailbox. delete returns a 0 on success or a 1 on failure. An error message is placed in the object->{'Error'} variable on failure. 792 793h_delete hierarchical delete (I don't believe this is RFC anything) 794deletes a mailbox and all sub-mailboxes/subfolders that belong to it. It basically gets a subfolder list and does multiple delete calls. It returns 0 on sucess or a 1 on failure with the error message from delete being put into the object->{'Error'} variable. Don't forget to set your Separator if it's not a period. 795 796list lists mailboxes. list accepts wildcard matching 797 798subscribe/unsubscribe does this action on given mailbox. 799 800rename renames a mailbox. IMAP servers seem to be peculiar about how they implement this, so I wouldn't necessarily expect it to do what you think it should. The Cyrus IMAP server will move a renamed mailbox to the default partition unless a partition is given. You can optionally supply a partition name as an extra argument to this function. 801 802select selects a mailbox to work on. You need the 'r' acl to select a mailbox. 803This command selects a mailbox that mailbox related commands will be performed on. This is not a recursive command so sub-mailboxes/folders will not be affected unless for some bizarre reason the IMAP server has it implemented as recursive. It returns an error or an array that contains information about the mailbox. For example: 804FLAGS (\Answered \Flagged \Draft \Deleted \Seen $Forwarded $MDNSent NonJunk Junk $Label7) 805OK [PERMANENTFLAGS (\Deleted)] 8062285 EXISTS 8072285 RECENT 808OK [UNSEEN 1] 809OK [UIDVALIDITY 1019141395] 810OK [UIDNEXT 293665] 811OK [READ-WRITE] Completed 812 813expunge permanently removes messages flagged with \Deleted out of the current selected mailbox. 814It returns a list of message sequence numbers that it deleted. You need to select a mailbox before you expunge. You need to read section 7.4.1 of RFC2060 to interpret the output. Essentially each time a message is deleted the sequence numbers all get decremented so you can see the same message sequence number several times in the list of deleted messages. In the following example (taken from the RFC) messages 3, 4, 7, and 11 were deleted: 815* 3 EXPUNGE 816* 3 EXPUNGE 817* 5 EXPUNGE 818* 8 EXPUNGE 819. OK EXPUNGE completed 820 821 822=head2 QUOTA FUNCTIONS 823 824RFC2087 imap extensions. These are supported by Cyrus IMAP and Mirapoint. 825 826get_quotaroot and get_quota retrieve quota information. They return an array on success and undef on failure. In the event of a failure the error is place in the object->{'Error'} variable. The array has three elements for each item in the quota. 827$quota[0] <- mailbox name 828$quota[1] <- quota amount used in kbytes 829$quota[2] <- quota in kbytes 830 831set_quota sets the quota. The number is in kilobytes so 10000 is approximately 10Meg. 832set_quota returns a 0 on success or a 1 on failure. An error message is placed in the object->{'Error'} variable on failure. 833 834To delete a quota do a set_quota($mailbox, "none"); 835 836 837=head2 ACCESS CONTROL FUNCTIONS 838 839RFC2086 imap extensions. These are supported by Cyrus IMAP, Mirapoint and probably many others. 840 841get_acl retrieves acl information. It returns an array on success and under on failure. In the event of a failure the error is placed in the object->{'Error'} variable. The array contains a pair for each person who has an acl on this mailbox 842$acl[0] user who has acl information 843$acl[1] acl information 844$acl[2] next user ... 845 846You could also treat the return from get_acl as a hash, in which case the user is the key and the acl information is the value. 847 848set_acl set acl information for a single mailbox. You can specify more the one user's rights on the same set call. It returns a 0 on success or a 1 on failure. An error message is placed in the object->{'Error'} variable on failure. 849 850delete_acl removes acl information on a single mailbox for the given users. You can specify more the one users rights to be removed in the same delete_acl call. It returns a 0 on success or a 1 on failure. An error message is placed int the object->{'Error'} variable on failure. 851 852standard rights (rfc2086): 853 l - lookup (mailbox is visible to LIST/LSUB commands) 854 r - read (SELECT the mailbox, perform CHECK, FETCH, PARTIAL, SEARCH, and COPY) 855 s - keep seen/unssen information across sessions (STORE SEEN flag) 856 w - write (STORE flags other then SEEN and DELETED) 857 i - insert (perform APPEND and COPY into mailbox) 858 p - post (send mail to submission address for mailbox) 859 c - create (CREATE new sub-mailboxes) (*note* allows for delete of sub mailboxes as well) 860 d - delete (STORE DELETED flag, perform EXPUNGE) 861 a - administer (perform SETACL) 862 863The access control information is from Cyrus IMAP. 864 read = "lrs" 865 post = "lrsp" 866 append = "lrsip" 867 write = "lrswipcd" 868 all = "lrswipcda" 869 870=head1 KNOWN BUGS 871 872Currently all the of the socket traffic is handled via prints and _read. This means that some of the calls could hang if the socket connection is broken. Eventually the will be properly selected and timed. 873 874=head1 LICENSE 875 876This is licensed under the Artistic license (same as perl). A copy of the license is included in this package. The file is called Artistic. If you use this in a product or distribution drop me a line, 'cause I am always curious about that... 877 878=head1 AUTHOR 879 880Eric Estabrooks, eric@urbanrage.com 881 882=head1 SEE ALSO 883 884perl(1). 885 886=cut 887