Permalink
Browse files

r483@dog: rspier | 2005-07-06 21:17:00 -0700

 The great plugin renaming in the name of inheritance and standardization commit.
 
 1. new concept of standard hook_ names.
 2. Plugin::init
 3. renamed many subroutines in plugins (and cleaned up register subs)
 4. updated README.plugins
 


git-svn-id: https://svn.perl.org/qpsmtpd/trunk@479 958fd67b-6ff1-0310-b445-bb7760255be9
  • Loading branch information...
1 parent 254b4fd commit 90daeb3786d9bb16ec5aec88378b070b4a0e3a1e @rspier rspier committed Jul 7, 2005
View
@@ -270,3 +270,82 @@ ended.
Returns the configured system-wide spool directory.
=back
+
+=head1 Naming Conventions
+
+Plugins should be written using standard named hook subroutines. This
+allows them to be overloaded and extended easily.
+
+Because some of our callback names have characters invalid in
+subroutine names, they must be translated. The current translation
+routine is: C< s/\W/_/g; >
+
+=head2 Naming Map
+
+ hook method
+ ---------- ------------
+ config hook_config
+ queue hook_queue
+ data hook_data
+ data_post hook_data_post
+ quit hook_quit
+ rcpt hook_rcpt
+ mail hook_mail
+ ehlo hook_ehlo
+ helo hook_helo
+ auth hook_auth
+ auth-plain hook_auth_plain
+ auth-login hook_auth_login
+ auth-cram-md5 hook_auth_cram_md5
+ connect hook_connect
+ reset_transaction hook_reset_transaction
+ unrecognized_command hook_unrecognized_command
+
+=head1 Register
+
+If you choose not to use the default naming convention, you need to
+register the hooks in your plugin. You do this with the C< register >
+method call on the plugin object.
+
+ sub register {
+ my ($self, $qp) = @_;
+
+ $self->register_hook('mail', 'mail_handler');
+ $self->register_hook('rcpt', 'rcpt_handler');
+ $self->register_hook('disconnect', 'disconnect_handler');
+ }
+
+ sub mail_handler { ... }
+ sub rcpt_handler { ... }
+ sub disconnect_handler { ... }
+
+A single plugin can register as many hooks as it wants, and can
+register a hook multiple times.
+
+The C< register > method is also often used for initialization and
+reading configuration.
+
+=head1 Init
+
+The 'init' method is the first method called after a plugin is
+loaded. It's mostly for inheritance, below.
+
+=head1 Inheritance
+
+Instead of modifying @ISA directly in your plugin, use the
+C< plugin_isa > method from the init subroutine.
+
+ # rcpt_ok_child
+ sub init {
+ my ($self, $qp) = @_;
+ $self->isa_plugin('rcpt_ok');
+ }
+
+ sub hook_rcpt {
+ my ($self, $transaction, $recipient) = @_;
+ # do something special here...
+ $self->SUPER::hook_rcpt( $transaction, $recipient );
+ }
+
+
+
View
@@ -1,4 +1,5 @@
package Qpsmtpd::Plugin;
+use Qpsmtpd::Constants;
use strict;
our %hooks = map { $_ => 1 } qw(
@@ -16,9 +17,11 @@ sub new {
sub register_hook {
my ($plugin, $hook, $method, $unshift) = @_;
-
+
die $plugin->plugin_name . " : Invalid hook: $hook" unless $hooks{$hook};
+ $plugin->{_qp}->varlog(LOGDEBUG, $plugin->plugin_name, " hooking ", $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(@_) },
@@ -32,7 +35,9 @@ sub _register {
my $self = shift;
my $qp = shift;
local $self->{_qp} = $qp;
- $self->register($qp, @_);
+ $self->init($qp, @_) if $self->can('init');
+ $self->_register_standard_hooks($qp, @_);
+ $self->register($qp, @_) if $self->can('register');
}
sub qp {
@@ -74,26 +79,31 @@ sub temp_dir {
# plugin inheritance:
# usage:
-# sub register {
+# sub init {
# my $self = shift;
# $self->isa_plugin("rhsbl");
# $self->SUPER::register(@_);
# }
sub isa_plugin {
my ($self, $parent) = @_;
my ($currentPackage) = caller;
- my $newPackage = $currentPackage."::_isa_";
+
+ my $cleanParent = $parent;
+ $cleanParent =~ s/\W/_/g;
+ my $newPackage = $currentPackage."::_isa_$cleanParent";
+
return if defined &{"${newPackage}::register"};
- Qpsmtpd::_compile($self->plugin_name . "_isa",
+ $self->compile($self->plugin_name . "_isa_$cleanParent",
$newPackage,
"plugins/$parent"); # assumes Cwd is qpsmtpd root
-
+ warn "---- $newPackage\n";
no strict 'refs';
push @{"${currentPackage}::ISA"}, $newPackage;
}
+# why isn't compile private? it's only called from Plugin and Qpsmtpd.
sub compile {
my ($class, $plugin, $package, $file, $test_mode) = @_;
@@ -141,4 +151,16 @@ sub compile {
die "eval $@" if $@;
}
+sub _register_standard_hooks {
+ my ($plugin, $qp) = @_;
+
+ for my $hook (keys %hooks) {
+ my $hooksub = "hook_$hook";
+ $hooksub =~ s/\W/_/g;
+ $plugin->register_hook( $hook, $hooksub )
+ if ($plugin->can($hooksub));
+ }
+}
+
+
1;
View
@@ -5,12 +5,7 @@
# the Qpsmtpd::Auth module. Don't run this in production!!!
#
-sub register {
- my ( $self, $qp ) = @_;
- $self->register_hook( "auth", "authdeny" );
-}
-
-sub authdeny {
+sub hook_auth {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
@_;
View
@@ -5,17 +5,7 @@
# the Qpsmtpd::Auth module. Don't run this in production!!!
#
-sub register {
- my ( $self, $qp ) = @_;
-
- # $self->register_hook("auth-plain", "authnull");
- # $self->register_hook("auth-login", "authnull");
- # $self->register_hook("auth-cram-md5", "authnull");
-
- $self->register_hook( "auth", "authnull" );
-}
-
-sub authnull {
+sub hook_auth {
my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
@_;
View
@@ -20,13 +20,7 @@ stage, so store it until later.
=cut
-sub register {
- my ($self, $qp) = @_;
- $self->register_hook("mail", "mail_handler");
- $self->register_hook("rcpt", "rcpt_handler");
-}
-
-sub mail_handler {
+sub hook_mail {
my ($self, $transaction, $sender) = @_;
my @badmailfrom = $self->qp->config("badmailfrom")
@@ -49,7 +43,7 @@ sub mail_handler {
return (DECLINED);
}
-sub rcpt_handler {
+sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $note = $transaction->notes('badmailfrom');
if ($note) {
@@ -16,13 +16,7 @@ Based heavily on check_badmailfrom.
=cut
-sub register {
- my ($self, $qp) = @_;
- $self->register_hook("mail", "mail_handler");
- $self->register_hook("rcpt", "rcpt_handler");
-}
-
-sub mail_handler {
+sub hook_mail {
my ($self, $transaction, $sender) = @_;
my @badmailfromto = $self->qp->config("badmailfromto")
@@ -46,7 +40,7 @@ sub mail_handler {
return (DECLINED);
}
-sub rcpt_handler {
+sub hook_rcpt {
my ($self, $transaction, $rcpt) = @_;
my $recipient = lc($rcpt->user) . '@' . lc($rcpt->host);
my $sender = $transaction->notes('badmailfromto');
View
@@ -1,11 +1,6 @@
# this plugin checks the badrcptto config (like badmailfrom for rcpt address)
-sub register {
- my ($self, $qp) = @_;
- $self->register_hook("rcpt", "check_for_badrcptto");
-}
-
-sub check_for_badrcptto {
+sub hook_rcpt {
my ($self, $transaction, $recipient) = @_;
my @badrcptto = $self->qp->config("badrcptto") or return (DECLINED);
return (DECLINED) unless $recipient->host && $recipient->user;
@@ -26,13 +26,7 @@ terms as Perl itself.
=cut
-sub register
-{
- my ($self, $qp) = @_;
- $self->register_hook("rcpt", "check_for_badrcptto_patterns");
-}
-
-sub check_for_badrcptto_patterns
+sub hook_rcpt
{
my ($self, $transaction, $recipient) = @_;
@@ -33,15 +33,14 @@ use Date::Parse qw(str2time);
sub register {
my ($self, $qp, @args) = @_;
- $self->register_hook("data_post", "check_basic_headers");
if (@args > 0) {
$self->{_days} = $args[0];
$self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 1);
}
}
-sub check_basic_headers {
+sub hook_data_post {
my ($self, $transaction) = @_;
return (DENY, "You have to send some data first")
View
@@ -28,7 +28,6 @@ Released to the public domain, 17 June 2005.
sub register {
my ($self, $qp, @args) = @_;
- $self->register_hook("data_post", "check_loop");
$self->{_max_hops} = $args[0] || 100;
@@ -38,7 +37,7 @@ sub register {
$self->log(LOGWARN, "Ignoring additional arguments") if @args > 1;
}
-sub check_loop {
+sub hook_data_post {
my ($self, $transaction) = @_;
my $hops = 0;
View
@@ -34,12 +34,7 @@ terms as Perl itself.
=cut
-sub register {
- my ($self, $qp) = @_;
- $self->register_hook("connect", "check_norelay");
-}
-
-sub check_norelay {
+sub hook_connect {
my ($self, $transaction) = @_;
my $connection = $self->qp->connection;
View
@@ -2,12 +2,7 @@
# $ENV{RELAYCLIENT} to see if relaying is allowed.
#
-sub register {
- my ($self, $qp) = @_;
- $self->register_hook("connect", "check_relay");
-}
-
-sub check_relay {
+sub hook_connect {
my ($self, $transaction) = @_;
my $connection = $self->qp->connection;
View
@@ -16,13 +16,7 @@ per line.
=cut
-sub register {
- my ($self, $qp) = @_;
- $self->register_hook("helo", "check_helo");
- $self->register_hook("ehlo", "check_helo");
-}
-
-sub check_helo {
+sub hook_helo {
my ($self, $transaction, $host) = @_;
($host = lc $host) or return DECLINED;
@@ -35,3 +29,5 @@ sub check_helo {
return DECLINED;
}
+# also support EHLO
+*hook_ehlo = \&hook_helo;
View
@@ -6,12 +6,7 @@
use POSIX qw:strftime:;
-sub register {
- my ($self, $qp) = @_;
- $self->register_hook("data_post", "mail_handler");
-}
-
-sub mail_handler {
+sub hook_data_post {
my ($self, $transaction) = @_;
# as a decent default, log on a per-day-basis
@@ -17,7 +17,6 @@ before we disconnect the client. Defaults to 4.
sub register {
my ($self, $qp, @args) = @_;
- $self->register_hook("unrecognized_command", "check_unrec_cmd");
if (@args > 0) {
$self->{_unrec_cmd_max} = $args[0];
@@ -30,7 +29,7 @@ sub register {
}
-sub check_unrec_cmd {
+sub hook_unrecognized_command {
my ($self, $cmd) = @_[0,2];
$self->log(LOGINFO, "Unrecognized command '$cmd'");
Oops, something went wrong.

0 comments on commit 90daeb3

Please sign in to comment.