File Coverage

blib/lib/IMAP/Admin.pm

Criterion	Covered	Total	%
statement	31	434	7.1
branch	2	158	1.2
condition	0	12	0.0
subroutine	8	28	28.5
pod	0	18	0.0
total	41	650	6.3

# IMAP::Admin - perl module for helping ease the administration of imap servers

package IMAP::Admin;

use strict;
use Carp;
use IO::Select;
use IO::Socket;
#use IO::Socket::INET;
use Cwd;

use vars qw($VERSION);

$VERSION = '1.6.7';

sub new {
  my $class = shift;
  my $self = {};
  my @defaults = (
                  'Port' => 143,
                  'Separator' => '.',
                  'CRAM' => 0,
                  );

  bless $self, $class;
  if ((scalar(@_) % 2) != 0) {
    croak "$class called with incorrect number of arguments";
  }
  unshift @_, @defaults;
  %{$self} = @_; # set up parameters;
  $self->{'CLASS'} = $class;
  $self->_initialize;
  return $self;
}

sub _initialize {
  my $self = shift;

  if (!defined($self->{'Server'})) {
    croak "$self->{'CLASS'} not initialized properly : Server parameter missing";
  }
  if (!defined($self->{'Login'})) {
    croak "$self->{'CLASS'} not initialized properly : Login parameter missing";
  }
  if (!defined($self->{'Password'})) {
    croak "$self->{'CLASS'} not initialized properly : Password parameter missing";
  }
  if ($self->{'CRAM'} != 0) {
      my $cram_try = "use Digest::HMAC; use Digest::MD5; use MIME::Base64;";
      eval $cram_try;
  }
  if (defined($self->{'SSL'})) { # attempt SSL connection instead
    # construct array of ssl options
    my $cwd = cwd;
    my %ssl_defaults = (
                        'SSL_use_cert' => 0,
                        'SSL_verify_mode' => 0x00,
                        'SSL_key_file' => $cwd."/certs/client-key.pem",
                        'SSL_cert_file' => $cwd."/certs/client-cert.pem",
                        'SSL_ca_path' => $cwd."/certs",
                        'SSL_ca_file' => $cwd."/certs/ca-cert.pem",
                        );
    my @ssl_options;
    my $ssl_key;
    my $key;
    foreach $ssl_key (keys(%ssl_defaults)) {
	    if (!defined($self->{$ssl_key})) {
        $self->{$ssl_key} = $ssl_defaults{$ssl_key};
	    }
    }
    foreach $ssl_key (keys(%{$self})) {
	    if ($ssl_key =~ /^SSL_/) {
        push @ssl_options, $ssl_key, $self->{$ssl_key};
	    }
    }
    my $SSL_try = "use IO::Socket::SSL";

    eval $SSL_try;
#	$IO::Socket::SSL::DEBUG = 1;
    if (!eval {
	    $self->{'Socket'} =
      IO::Socket::SSL->new(PeerAddr => $self->{'Server'},
                           PeerPort => $self->{'Port'},
                           Proto => 'tcp',
                           Reuse => 1,
                           Timeout => 5,
                           @ssl_options); }) {
	    $self->_error("initialize", "couldn't establish SSL connection to",
                    $self->{'Server'}, "[$!]");
	    delete $self->{'Socket'};
	    return;
    }
  } else {
    if ($self->{'Server'} =~ /^\//) {
        if (!eval {
            $self->{'Socket'} =
        IO::Socket::UNIX->new(Peer => $self->{'Server'}); })
        {
            delete $self->{'Socket'};
            $self->_error("initialize", "couldn't establish connection to",
                        $self->{'Server'});
            return;
        }
      } else {
          if (!eval {
              $self->{'Socket'} =
          IO::Socket::INET->new(PeerAddr => $self->{'Server'},
                                  PeerPort => $self->{'Port'},
                                  Proto => 'tcp',
                                  Reuse => 1,
                                  Timeout => 5); })
          {
              delete $self->{'Socket'};
              $self->_error("initialize", "couldn't establish connection to",
                          $self->{'Server'});
              return;
          }
      }
  }
  my $fh = $self->{'Socket'};
  my $try = $self->_read; # get Banner
  if ($try !~ /\* OK/) {
    $self->close;
    $self->_error("initialize", "bad response from", $self->{'Server'},
                  "[", $try, "]");
    return;
  }
  # this section was changed to accomodate motd's
  print $fh "try CAPABILITY\n";
  $try = $self->_read;
  while ($try !~ /^\* CAPABILITY/) { # we have a potential lockup, should alarm this
    $try = $self->_read;
  }
  $self->{'Capability'} = $try;
  $try = $self->_read;
  if ($try !~ /^try OK/) {
    $self->close;
    $self->_error("initialize", "Couldn't do a capabilites check [",
                  $try, "]");
    return;
  }
  if ($self->{'CRAM'} > 0) {
    if ($self->{'Capability'} =~ /CRAM-MD5/) {
      _do_cram_login($self);
    } else {
      if ($self->{'CRAM'} > 1) {
        print $fh qq{try LOGIN "$self->{'Login'}" "$self->{'Password'}"\n};
      } else {
        $self->close;
        $self->_error("initialize","CRAM not reported in Capability check and fallback to PLAIN not selected", $self->{'Server'}, "[", $self->{'Capability'}, "]");
        return;
      }
    }
  } else {
    print $fh qq{try LOGIN "$self->{'Login'}" "$self->{'Password'}"\n};
  }
  $try = $self->_read;
  if ($try !~ /^try OK/) { # should tr this response
    $self->close;
    $self->_error("initialize", $try);
    return;
  } else {
    $self->{'Error'} = "No Errors";
    return;
  }
  # fall thru, can it be hit ?
  $self->{'Error'} = "No Errors";
  return;
}

# this routine uses evals to prevent errors regarding missing modules
sub _do_cram_login {
  my $self = shift;
  my $fh = $self->{'Socket'};
  my $ans;

  print $fh "try AUTHENTICATE CRAM-MD5\n";
  my $try = $self->_read; # gets back the postal string
  ($ans) = (split(' ', $try, 2))[1];
  my $cram_eval = "
   my \$hmac = Digest::HMAC->new(\$self->{'Password'}, 'Digest::MD5');
   \$hmac->add(decode_base64(\$ans));
   \$ans = encode_base64(\$self->{'Login'}.' '.\$hmac->hexdigest, '');
  ";
  eval $cram_eval;
  print $fh "$ans\n";
  return;
}

sub _error {
  my $self = shift;
  my $func = shift;
  my @error = @_;

  $self->{'Error'} = join(" ",$self->{'CLASS'}, "[", $func, "]:", @error);
  return;
}

sub error {
  my $self = shift;
  return $self->{'Error'};
}

sub _read {
  my $self = shift;
  my $buffer = "";
  my $char = "";
  my $bytes = 1;
  while ($bytes == 1) {
    $bytes = sysread $self->{'Socket'}, $char, 1;
    if ($bytes == 0) {
      if (length ($buffer) != 0) {
        return $buffer;
      } else {
        return;
      }
    } else {
      if (($char eq "\n") or ($char eq "\r")) {
        if (length($buffer) == 0) {
          # cr or nl left over, just eat it
        } else {
          return $buffer;
        }
      } else {
#		print "got char [$char]\n";
        $buffer .= $char;
      }
    }
  }
}

sub close {
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return 0;
  }
  my $fh = $self->{'Socket'};
  print $fh "try logout\n";
  my $try = $self->_read;
  close($self->{'Socket'});
  delete $self->{'Socket'};
  return 0;
}

sub create {
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if ((scalar(@_) != 1) && (scalar(@_) != 2)) {
    $self->_error("create", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  if (scalar(@_) == 1) { # a partition exists
    print $fh qq{try CREATE "$mailbox" $_[0]\n};
  } else {
    print $fh qq{try CREATE "$mailbox"\n};
  }
  my $try = $self->_read;
  if ($try =~ /^try OK/) {
    $self->{'Error'} = 'No Errors';
    return 0;
  } else {
    $self->_error("create", "couldn't create", $mailbox, ":", $try);
    return 1;
  }
}

sub rename {
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if ((scalar(@_) != 2) && (scalar(@_) != 3)) {
    $self->_error("rename", "incorrect number of arguments");
    return 1;
  }
  my $old_name = shift;
  my $new_name = shift;
  my $partition = shift;

  my $fh = $self->{'Socket'};
  if (defined $partition) {
    print $fh qq{try RENAME "$old_name" "$new_name" $partition\n};
  } else {
    print $fh qq{try RENAME "$old_name" "$new_name"\n};
  }
  my $try = $self->_read;
  if (($try =~ /^try OK/) || ($try =~ /^\* OK/)) {
    $self->{'Error'} = 'No Errors';
    return 0;
  } else {
    $self->_error("rename", "couldn't rename", $old_name, "to", $new_name,
                  ":", $try);
    return 1;
  }
}

sub delete {
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (scalar(@_) != 1) {
    $self->_error("delete", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try DELETE "$mailbox"\n};
  my $try = $self->_read;
  if ($try =~ /^try OK/) {
    $self->{'Error'} = 'No Errors';
    return 0;
  } else {
    $self->_error("delete", "couldn't delete", $mailbox, ":", $try);
    return 1;
  }
}

sub h_delete {
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (scalar(@_) != 1) {
    $self->_error("h_delete", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  # first get a list of all sub boxes then nuke them, accumulate errors
  # then do something intelligent with them (hmmmmm)
  my $box = join($self->{'Separator'}, $mailbox, "*");
  my @sub_boxes = $self->list($box);
  push @sub_boxes, $mailbox;
  # uncomment following line if you are sanity checking h_delete
  # print "h_delete: got this list of sub boxes [@sub_boxes]\n";
  foreach $box (@sub_boxes) {
    print $fh qq{try DELETE "$box"\n};
    my $try = $self->_read;
    if ($try =~ /^try OK/) {
      $self->{'Error'} = 'No Errors';
    } else {
       $self->_error("h_delete", "couldn't delete",
                     $mailbox, ":", $try);
       return 1; # or just return on the first encountered error ?
    }
  }
  return 0;
}

sub get_quotaroot { # returns an array or undef
  my $self = shift;
  my (@quota, @info);

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (!($self->{'Capability'} =~ /QUOTA/)) {
    $self->_error("get_quotaroot", "QUOTA not listed in server's capabilities");
    return 1;
  }
  if (scalar(@_) != 1) {
    $self->_error("get_quotaroot", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try GETQUOTAROOT "$mailbox"\n};
  my $try = $self->_read;
  while ($try =~ /^\* QUOTA/) {
    if ($try !~ /QUOTAROOT/) { # some imap servers give this extra line
      @info = ($try =~ /QUOTA\s(.*?)\s\(STORAGE\s(\d+)\s(\d+)/);
      push @quota, @info;
    }
    $try = $self->_read;
  }
  if ($try =~ /^try OK/) {
    return @quota;
  } else {
    $self->_error("get_quotaroot", "couldn't get quota for", $mailbox, ":", $try);
    return;
  }
}

sub get_quota { # returns an array or undef
  my $self = shift;
  my (@quota, @info);

  if (!defined($self->{'Socket'})) {
    return;
  }
  if (!($self->{'Capability'} =~ /QUOTA/)) {
    $self->_error("get_quota",
                  "QUOTA not listed in server's capabilities");
    return;
  }
  if (scalar(@_) != 1) {
    $self->_error("get_quota", "incorrect number of arguments");
    return;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try GETQUOTA "$mailbox"\n};
  my $try = $self->_read;
  while ($try =~ /^\* QUOTA/) {
    @info = ($try =~ /QUOTA\s(.*?)\s\(STORAGE\s(\d+)\s(\d+)/);
    push @quota, @info;
    $try = $self->_read;
  }
  if ($try =~ /^try OK/) {
    return @quota;
  } else {
    $self->_error("get_quota", "couldn't get quota for", $mailbox, ":", $try);
    return;
  }
}

sub set_quota {
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (!($self->{'Capability'} =~ /QUOTA/)) {
    $self->_error("set_quota", "QUOTA not listed in server's capabilities");
    return 1;
  }
  if (scalar(@_) != 2) {
    $self->_error("set_quota", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $quota = shift;
  my $fh = $self->{'Socket'};
  if ($quota eq "none") {
    print $fh qq{try SETQUOTA "$mailbox" ()\n};
  } else {
    print $fh qq{try SETQUOTA "$mailbox" (STORAGE $quota)\n};
  }
  my $try = $self->_read;
  if ($try =~ /^try OK/) {
    $self->{'Error'} = "No Errors";
    return 0;
  } else {
    $self->_error("set_quota", "couldn't set quota for", $mailbox, ":", $try);
    return 1;
  }
}

sub subscribe {
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (scalar(@_) != 1) {
    $self->_error("subscribe", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try SUBSCRIBE "$mailbox"\n};
  my $try = $self->_read;
  if ($try !~ /^try OK/) {
    $self->_error("subscribe", "couldn't suscribe ", $mailbox, ":",
                  $try);
    return 1;
  }
  $self->{'Error'} = 'No Errors';
  return 0;
}

sub unsubscribe {
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (scalar(@_) != 1) {
    $self->_error("unsubscribe", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try UNSUBSCRIBE "$mailbox"\n};
  my $try = $self->_read;
  if ($try !~ /^try OK/) {
    $self->_error("unsubscribe", "couldn't unsuscribe ", $mailbox, ":",
                  $try);
    return 1;
  }
  $self->{'Error'} = 'No Errors';
  return 0;
}

sub select { # returns an array or undef
  my $self = shift;
  my @info;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (scalar(@_) != 1) {
    $self->_error("select", "incorrect number of arguments");
    return;
  }

  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try SELECT "$mailbox"\n};
  my $try = $self->_read;
  while ($try =~ /^\* (.*)/) { # danger danger (could lock up needs timeout)
    push @info, $1;
    $try = $self->_read;
  }
  if ($try =~ /^try OK/) {
    return @info;
  } else {
    $self->_error("select", "couldn't select", $mailbox, ":", $try);
    return;
  }
}

sub expunge { # returns an array or undef
  my $self = shift;
  my @info;

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (scalar(@_) != 0) {
    $self->_error("expunge", "incorrect number of arguments");
    return;
  }

  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try EXPUNGE\n};
  my $try = $self->_read;
  while ($try =~ /^\* (.*)/) { # danger danger (could lock up needs timeout)
    push @info, $1;
    $try = $self->_read;
  }
  if ($try =~ /^try OK/) {
    return @info;
  } else {
    $self->_error("expunge", "couldn't expunge", $mailbox, ":", $try);
    return;
  }
}

sub get_acl { # returns an array or undef
  my $self = shift;

  if (!defined($self->{'Socket'})) {
    return;
  }
  if (!($self->{'Capability'} =~ /ACL/)) {
    $self->_error("get_acl", "ACL not listed in server's capabilities");
    return;
  }
  if (scalar(@_) != 1) {
    $self->_error("get_acl", "incorrect number of arguments");
    return;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try GETACL "$mailbox"\n};
  delete $self->{'acl'};
  my $try = $self->_read;
  while ($try =~ /^\*\s+ACL\s+/) {
    my $acls = ($try =~ /^\* ACL\s+(?:\".*?\"|\S*)\s+(.*)/)[0]; # separate out the acls
    my @acls = ($acls =~ /(\".*?\"|\S+)\s*/g); # split up over ws, unless quoted
    push @{$self->{'acl'}}, @acls;
    $try = $self->_read;
  }
  if ($try =~ /^try OK/) {
    return @{$self->{'acl'}};
  } else {
    $self->_error("get_acl", "couldn't get acl for", $mailbox, ":", $try);
    return;
  }
}

sub set_acl {
  my $self = shift;
  my ($id, $acl);

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (!($self->{'Capability'} =~ /ACL/)) {
    $self->_error("set_acl", "ACL not listed in server's capabilities");
    return 1;
  }
  if (scalar(@_) < 2) {
    $self->_error("set_acl", "too few arguments");
    return 1;
  }
  if ((scalar(@_) % 2) == 0) {
    $self->_error("set_acl", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  while(@_) {
    $id = shift;
    $acl = shift;
    print $fh qq{try SETACL "$mailbox" "$id" "$acl"\n};
    my $try = $self->_read;
    if ($try !~ /^try OK/) {
      $self->_error("set_acl", "couldn't set acl for", $mailbox, $id,
                    $acl, ":", $try);
      return 1;
    }
  }
  $self->{'Error'} = 'No Errors';
  return 0;
}

sub delete_acl {
  my $self = shift;
  my ($id, $acl);

  if (!defined($self->{'Socket'})) {
    return 1;
  }
  if (!($self->{'Capability'} =~ /ACL/)) {
    $self->_error("delete_acl", "ACL not listed in server's capabilities");
    return 1;
  }
  if (scalar(@_) < 1) {
    $self->_error("delete_acl", "incorrect number of arguments");
    return 1;
  }
  my $mailbox = shift;
  my $fh = $self->{'Socket'};
  while(@_) {
    $id = shift;
    print $fh qq{try DELETEACL "$mailbox" "$id"\n};
    my $try = $self->_read;
    if ($try !~ /^try OK/) {
      $self->_error("delete_acl", "couldn't delete acl for", $mailbox,
                    $id, $acl, ":", $try);
      return 1;
    }
  }
  return 0;
}

sub list { # wild cards are allowed, returns array or undef
  my $self = shift;
  my (@info, @mail);

  if (!defined($self->{'Socket'})) {
    return;
  }
  if (scalar(@_) != 1) {
    $self->_error("list", "incorrect number of arguments");
    return;
  }
  my $list = shift;
  my $fh = $self->{'Socket'};
  print $fh qq{try LIST "" "$list"\n};
  my $try = $self->_read;
  while ($try =~ /^\* LIST.*?\) \".\" \"*(.*?)\"*$/) { # danger danger (could lock up needs timeout) " <- this quote makes emacs happy
    push @mail, $1;
    $try = $self->_read;
  }
  if ($try =~ /^try OK/) {
    return @mail;
  } else {
    $self->_error("list", "couldn't get list for", $list, ":", $try);
    return;
  }
}


# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__