[svn:qpsmtpd] r648 - in branches/0.3x: . lib lib/Qpsmtpd

Author: ask
Date: Wed Jun 28 13:05:04 2006
New Revision: 648

Modified:
   branches/0.3x/   (props changed)
   branches/0.3x/Changes
   branches/0.3x/lib/Qpsmtpd.pm
   branches/0.3x/lib/Qpsmtpd/Plugin.pm

Log:
 r3744@embla:  ask | 2006-06-28 13:04:50 -0700
 Support "module" plugins ("My::Plugin" in the config/plugins file)
 


Modified: branches/0.3x/Changes
==============================================================================
--- branches/0.3x/Changes	(original)
+++ branches/0.3x/Changes	Wed Jun 28 13:05:04 2006
@@ -1,5 +1,7 @@
 0.33
 
+  Support "module" plugins ("My::Plugin" in the config/plugins file)
+
   Add SSL encryption method to header to mirror other qmail/SSL patches.
   Add tls_before_auth to suppress AUTH unless TLS has already been 
   established (Robin Johnson).

Modified: branches/0.3x/lib/Qpsmtpd.pm
==============================================================================
--- branches/0.3x/lib/Qpsmtpd.pm	(original)
+++ branches/0.3x/lib/Qpsmtpd.pm	Wed Jun 28 13:05:04 2006
@@ -260,31 +260,49 @@
   my @ret;  
   for my $plugin_line (@plugins) {
     my ($plugin, @args) = split ' ', $plugin_line;
-    
-    my $plugin_name = $plugin;
-    $plugin =~ s/:\d+$//;       # after this point, only used for filename
 
-    # Escape everything into valid perl identifiers
-    $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
+    my $package;
 
-    # second pass cares for slashes and words starting with a digit
-    $plugin_name =~ s{
+    if ($plugin =~ m/::/) {
+      # "full" package plugin (My::Plugin)
+      $package = $plugin;
+      $package =~ s/[^_a-z0-9:]+//gi;
+      my $eval = qq[require $package;\n] 
+                .qq[sub ${plugin}::plugin_name { '$plugin' }];
+      $eval =~ m/(.*)/s;
+      $eval = $1;
+      eval $eval;
+      die "Failed loading $package - eval $@" if $@;
+      $self->log(LOGDEBUG, "Loading $package ($plugin_line)") 
+        unless $plugin_line =~ /logging/;
+    }
+    else {
+      # regular plugins/$plugin plugin
+      my $plugin_name = $plugin;
+      $plugin =~ s/:\d+$//;       # after this point, only used for filename
+
+      # Escape everything into valid perl identifiers
+      $plugin_name =~ s/([^A-Za-z0-9_\/])/sprintf("_%2x",unpack("C",$1))/eg;
+      
+      # second pass cares for slashes and words starting with a digit
+      $plugin_name =~ s{
 		      (/+)       # directory
 		      (\d?)      # package's first character
 		     }[
 		       "::" . (length $2 ? sprintf("_%2x",unpack("C",$2)) : "")
 		      ]egx;
-
-    my $package = "Qpsmtpd::Plugin::$plugin_name";
-
-    # don't reload plugins if they are already loaded
-    unless ( defined &{"${package}::plugin_name"} ) {
-      Qpsmtpd::Plugin->compile($plugin_name,
+      
+      $package = "Qpsmtpd::Plugin::$plugin_name";
+      
+      # don't reload plugins if they are already loaded
+      unless ( defined &{"${package}::plugin_name"} ) {
+        Qpsmtpd::Plugin->compile($plugin_name,
         $package, "$dir/$plugin", $self->{_test_mode});
-      $self->log(LOGDEBUG, "Loading $plugin_line") 
-        unless $plugin_line =~ /logging/;
+        $self->log(LOGDEBUG, "Loading $plugin_line") 
+          unless $plugin_line =~ /logging/;
+      }
     }
-    
+
     my $plug = $package->new();
     push @ret, $plug;
     $plug->_register($self, @args);

Modified: branches/0.3x/lib/Qpsmtpd/Plugin.pm
==============================================================================
--- branches/0.3x/lib/Qpsmtpd/Plugin.pm	(original)
+++ branches/0.3x/lib/Qpsmtpd/Plugin.pm	Wed Jun 28 13:05:04 2006
@@ -19,6 +19,10 @@
   bless ({}, $class);
 }
 
+sub hook_name { 
+  return shift->{_hook};
+}
+
 sub register_hook {
   my ($plugin, $hook, $method, $unshift) = @_;
 
@@ -29,11 +33,16 @@
 
   # I can't quite decide if it's better to parse this code ref or if
   # we should pass the plugin object and method name ... hmn.
-  $plugin->qp->_register_hook($hook, { code => sub { local $plugin->{_qp} = shift; local $plugin->{_hook} = $hook; $plugin->$method(@_) },
-				       name => $plugin->plugin_name,
-				     },
-				     $unshift,
-			     );
+  $plugin->qp->_register_hook
+    ($hook,
+     { code => sub { local $plugin->{_qp} = shift;
+                     local $plugin->{_hook} = $hook;
+                     $plugin->$method(@_)
+                   },
+       name => $plugin->plugin_name,
+     },
+     $unshift,
+    );
 }
 
 sub _register {
@@ -149,7 +158,6 @@
 		    '@ISA = qw(Qpsmtpd::Plugin);',
 		    ($test_mode ? 'use Test::More;' : ''),
 		    "sub plugin_name { qq[$plugin] }",
-		    "sub hook_name { return shift->{_hook}; }",
 		    $line,
 		    $sub,
 		    "\n", # last line comment without newline?