From bf2419df3354645d3679107d0049dd8aae6372b5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ask=20Bj=C3=B8rn=20Hansen?= <ask@develooper.com>
Date: Wed, 28 Jun 2006 20:05:04 +0000
Subject: [PATCH]  r3744@embla:  ask | 2006-06-28 13:04:50 -0700  Support
 "module" plugins ("My::Plugin" in the config/plugins file)

git-svn-id: https://svn.perl.org/qpsmtpd/branches/0.3x@648 958fd67b-6ff1-0310-b445-bb7760255be9
---
 Changes               |  2 ++
 lib/Qpsmtpd.pm        | 50 +++++++++++++++++++++++++++++--------------
 lib/Qpsmtpd/Plugin.pm | 20 +++++++++++------
 3 files changed, 50 insertions(+), 22 deletions(-)

diff --git a/Changes b/Changes
index 250d3a8..f1cbf6d 100644
--- a/Changes
+++ b/Changes
@@ -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).
diff --git a/lib/Qpsmtpd.pm b/lib/Qpsmtpd.pm
index a7ae15e..417dc85 100644
--- a/lib/Qpsmtpd.pm
+++ b/lib/Qpsmtpd.pm
@@ -260,31 +260,49 @@ sub _load_plugins {
   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);
diff --git a/lib/Qpsmtpd/Plugin.pm b/lib/Qpsmtpd/Plugin.pm
index 5947b77..b6357be 100644
--- a/lib/Qpsmtpd/Plugin.pm
+++ b/lib/Qpsmtpd/Plugin.pm
@@ -19,6 +19,10 @@ sub new {
   bless ({}, $class);
 }
 
+sub hook_name { 
+  return shift->{_hook};
+}
+
 sub register_hook {
   my ($plugin, $hook, $method, $unshift) = @_;
 
@@ -29,11 +33,16 @@ sub register_hook {
 
   # 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 @@ sub compile {
 		    '@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?