[Bps-public-commit] r18740 - in Net-IMAP-Server: lib/Net/IMAP lib/Net/IMAP/Server

[alexmv at bestpractical.com]

Author: alexmv
Date: Sun Mar  8 15:31:40 2009
New Revision: 18740

Modified:
   Net-IMAP-Server/   (props changed)
   Net-IMAP-Server/lib/Net/IMAP/Server.pm
   Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm

Log:
 r43062 at kohr-ah:  chmrr | 2009-03-08 15:31:12 -0400
 Support for adding new commands


Modified: Net-IMAP-Server/lib/Net/IMAP/Server.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server.pm	(original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server.pm	Sun Mar  8 15:31:40 2009
@@ -55,7 +55,13 @@
 =cut
 
 __PACKAGE__->mk_accessors(
-    qw/port ssl_port auth_class model_class connection_class user group poll_every unauth_idle auth_idle unauth_commands/
+    qw/port ssl_port
+       auth_class model_class connection_class
+       command_class
+       user group
+       poll_every
+       unauth_idle auth_idle unauth_commands
+      /
 );
 
 =head2 new PARAMHASH
@@ -149,6 +155,7 @@
             auth_idle        => 60*60,
             unauth_commands  => 10,
             @_,
+            command_class    => {},
             connection       => {},
         }
     );
@@ -331,6 +338,26 @@
     );
 }
 
+=head2 add_command NAME => PACKAGE
+
+Adds the given command C<NAME> to the server's list of known commands.
+C<PACKAGE> should be the name of a class which inherits from
+L<Net::IMAP::Server::Command>.
+
+=cut
+
+sub add_command {
+    my $self = shift;
+    my ($name, $package) = @_;
+    if (not $package->require) {
+        warn $@;
+    } elsif (not $package->isa('Net::IMAP::Server::Command')) {
+        warn "$package is not a Net::IMAP::Server::Command!";
+    } else {
+        $self->command_class->{uc $name} = $package;
+    }
+}
+
 1;    # Magic true value required at end of module
 __END__
 

Modified: Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm
==============================================================================
--- Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm	(original)
+++ Net-IMAP-Server/lib/Net/IMAP/Server/Connection.pm	Sun Mar  8 15:31:40 2009
@@ -225,12 +225,7 @@
     my ( $id, $cmd, $options ) = $self->parse_command($content);
     return unless defined $id;
 
-    my $cmd_class = "Net::IMAP::Server::Command::$cmd";
-    $cmd_class->require() || warn $@;
-    unless ( $cmd_class->can('run') ) {
-        $cmd_class = "Net::IMAP::Server::Command";
-    }
-    my $handler = $cmd_class->new(
+    my $handler = $self->class_for($cmd)->new(
         {   server      => $self->server,
             connection  => $self,
             options_str => $options,
@@ -255,6 +250,22 @@
     }
 }
 
+=head2 class_for COMMAND
+
+Returns the package name that implements the given C<COMMAND>.
+
+=cut
+
+sub class_for {
+    my $self = shift;
+    my $cmd = shift;
+    my $classref = $self->server->command_class;
+    my $cmd_class = $classref->{lc $cmd} || $classref->{$cmd} || $classref->{uc $cmd}
+         || "Net::IMAP::Server::Command::$cmd";
+    $cmd_class->require() || ($@ =~ /^Can't locate \S+ in \@INC/) || warn $@;
+    return $cmd_class->can('run') ? $cmd_class : "Net::IMAP::Server::Command";
+}
+
 =head2 pending
 
 If a connection has pending state, contains the callback that will