qpsmtpd/lib/Qpsmtpd/Plugin.pm

167 lines
3.8 KiB
Perl
Raw Normal View History

package Qpsmtpd::Plugin;
use Qpsmtpd::Constants;
use strict;
our %hooks = map { $_ => 1 } qw(
config queue data data_post quit rcpt mail ehlo helo
auth auth-plain auth-login auth-cram-md5
connect reset_transaction unrecognized_command disconnect
deny logging ok pre-connection post-connection
);
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
bless ({}, $class);
}
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.
Add plugable logging support include sample plugin which replicates the existing core code. Add OK hook. * lib/Qpsmtpd.pm (init_logger): replaced with log_level() (load_logging): NEW - load logging plugins without calling log() (log_level): NEW - set/get global $LogLevel scalar (log): now just a wrapper for varlog(); called only by core code (varlog): initializes logging if not already done, calls logging plugins in turn and falls back to interal logging unless plugins OK or DECLINED (_load_plugins): only display "Loading plugin" when actually loading one (run_hooks): load logging plugins without calling log(); add OK hook as else of the DENY* case (spool_dir): use global $Spool_dir scalar to cache location * lib/Qpsmtpd/Plugin.pm (%hooks): add "logging" and "ok" (register_hook): add local _hook to object cache (log): call varlog() with additional parameters hook and plugin_name except for logging hook (compile): add accessor sub for local _hook scalar * lib/Qpsmtpd/SMTP.pm (mail, rcpt): change loglevel to LOGALERT instead of LOGWARN for from/to * qpsmtpd-forkserver (REAPER): use package ::log() instead of warn() (main): defer calling log until $plugin_loader has been initialized (log): call logging using the $plugin_loader object * plugins/logging/warn NEW: sample plugin which replicates the core logging functionality * plugins/logging/devnull NEW: sample plugin which logs nothing (for testing multiple logging plugin functionality) * config.sample/logging sample configuration file for logging plugins * plugins/virus/uvscan plugins/virus/clamav Increase loglevel for non-serious warnings to LOGWARN from LOGERROR git-svn-id: https://svn.perl.org/qpsmtpd/trunk@398 958fd67b-6ff1-0310-b445-bb7760255be9
2005-03-24 22:16:35 +01:00
$plugin->qp->_register_hook($hook, { code => sub { local $plugin->{_qp} = shift; local $plugin->{_hook} = $hook; $plugin->$method(@_) },
name => $plugin->plugin_name,
},
$unshift,
);
}
sub _register {
my $self = shift;
my $qp = shift;
local $self->{_qp} = $qp;
$self->init($qp, @_) if $self->can('init');
$self->_register_standard_hooks($qp, @_);
$self->register($qp, @_) if $self->can('register');
}
sub qp {
shift->{_qp};
}
sub log {
my $self = shift;
Add plugable logging support include sample plugin which replicates the existing core code. Add OK hook. * lib/Qpsmtpd.pm (init_logger): replaced with log_level() (load_logging): NEW - load logging plugins without calling log() (log_level): NEW - set/get global $LogLevel scalar (log): now just a wrapper for varlog(); called only by core code (varlog): initializes logging if not already done, calls logging plugins in turn and falls back to interal logging unless plugins OK or DECLINED (_load_plugins): only display "Loading plugin" when actually loading one (run_hooks): load logging plugins without calling log(); add OK hook as else of the DENY* case (spool_dir): use global $Spool_dir scalar to cache location * lib/Qpsmtpd/Plugin.pm (%hooks): add "logging" and "ok" (register_hook): add local _hook to object cache (log): call varlog() with additional parameters hook and plugin_name except for logging hook (compile): add accessor sub for local _hook scalar * lib/Qpsmtpd/SMTP.pm (mail, rcpt): change loglevel to LOGALERT instead of LOGWARN for from/to * qpsmtpd-forkserver (REAPER): use package ::log() instead of warn() (main): defer calling log until $plugin_loader has been initialized (log): call logging using the $plugin_loader object * plugins/logging/warn NEW: sample plugin which replicates the core logging functionality * plugins/logging/devnull NEW: sample plugin which logs nothing (for testing multiple logging plugin functionality) * config.sample/logging sample configuration file for logging plugins * plugins/virus/uvscan plugins/virus/clamav Increase loglevel for non-serious warnings to LOGWARN from LOGERROR git-svn-id: https://svn.perl.org/qpsmtpd/trunk@398 958fd67b-6ff1-0310-b445-bb7760255be9
2005-03-24 22:16:35 +01:00
$self->qp->varlog(shift, $self->hook_name, $self->plugin_name, @_)
unless defined $self->hook_name and $self->hook_name eq 'logging';
}
sub transaction {
# not sure if this will work in a non-forking or a threaded daemon
shift->qp->transaction;
}
sub connection {
shift->qp->connection;
}
sub spool_dir {
shift->qp->spool_dir;
}
sub temp_file {
my $self = shift;
my $tempfile = $self->qp->temp_file;
push @{$self->qp->transaction->{_temp_files}}, $tempfile;
return $tempfile;
}
sub temp_dir {
my $self = shift;
my $tempdir = $self->qp->temp_dir();
push @{$self->qp->transaction->{_temp_dirs}}, $tempdir;
return $tempdir;
}
# plugin inheritance:
# usage:
# sub init {
# my $self = shift;
# $self->isa_plugin("rhsbl");
# $self->SUPER::register(@_);
# }
sub isa_plugin {
my ($self, $parent) = @_;
my ($currentPackage) = caller;
my $cleanParent = $parent;
$cleanParent =~ s/\W/_/g;
my $newPackage = $currentPackage."::_isa_$cleanParent";
return if defined &{"${newPackage}::register"};
$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) = @_;
my $sub;
open F, $file or die "could not open $file: $!";
{
local $/ = undef;
$sub = <F>;
}
close F;
my $line = "\n#line 0 $file\n";
if ($test_mode) {
if (open(F, "t/plugin_tests/$plugin")) {
local $/ = undef;
$sub .= "#line 1 t/plugin_tests/$plugin\n";
$sub .= <F>;
close F;
}
}
my $eval = join(
"\n",
"package $package;",
'use Qpsmtpd::Constants;',
"require Qpsmtpd::Plugin;",
'use vars qw(@ISA);',
'use strict;',
'@ISA = qw(Qpsmtpd::Plugin);',
($test_mode ? 'use Test::More;' : ''),
"sub plugin_name { qq[$plugin] }",
Add plugable logging support include sample plugin which replicates the existing core code. Add OK hook. * lib/Qpsmtpd.pm (init_logger): replaced with log_level() (load_logging): NEW - load logging plugins without calling log() (log_level): NEW - set/get global $LogLevel scalar (log): now just a wrapper for varlog(); called only by core code (varlog): initializes logging if not already done, calls logging plugins in turn and falls back to interal logging unless plugins OK or DECLINED (_load_plugins): only display "Loading plugin" when actually loading one (run_hooks): load logging plugins without calling log(); add OK hook as else of the DENY* case (spool_dir): use global $Spool_dir scalar to cache location * lib/Qpsmtpd/Plugin.pm (%hooks): add "logging" and "ok" (register_hook): add local _hook to object cache (log): call varlog() with additional parameters hook and plugin_name except for logging hook (compile): add accessor sub for local _hook scalar * lib/Qpsmtpd/SMTP.pm (mail, rcpt): change loglevel to LOGALERT instead of LOGWARN for from/to * qpsmtpd-forkserver (REAPER): use package ::log() instead of warn() (main): defer calling log until $plugin_loader has been initialized (log): call logging using the $plugin_loader object * plugins/logging/warn NEW: sample plugin which replicates the core logging functionality * plugins/logging/devnull NEW: sample plugin which logs nothing (for testing multiple logging plugin functionality) * config.sample/logging sample configuration file for logging plugins * plugins/virus/uvscan plugins/virus/clamav Increase loglevel for non-serious warnings to LOGWARN from LOGERROR git-svn-id: https://svn.perl.org/qpsmtpd/trunk@398 958fd67b-6ff1-0310-b445-bb7760255be9
2005-03-24 22:16:35 +01:00
"sub hook_name { return shift->{_hook}; }",
$line,
$sub,
"\n", # last line comment without newline?
);
#warn "eval: $eval";
$eval =~ m/(.*)/s;
$eval = $1;
eval $eval;
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;