Turn warnings into $qpsmtpd->log() calls

This can be convenient, especially when one wants to emit a warning that will
show up when running the test suite but still be properly logged in production

lib/Qpsmtpd.pm

@@ -93,6 +93,25 @@ sub log {
     $self->varlog($trace, join(" ", @log));
 }
 
+sub warn_handler {
+    my $self = shift;
+    $self->log( $self->warn_level(@_) );
+}
+
+sub warn_level {
+    my ( $self, @warnings ) = @_;
+    my @levels = ( keys %Qpsmtpd::Constants::log_levels,
+                   qw( LOGWARNING LOGCRITICAL LOGEMERGENCY ) );
+    my $levels = join '|', map { s/^LOG//; $_ } @levels;
+    $warnings[0] =~ s/^($levels):\s*//;
+    my $prefix = $1;
+    $prefix = 'WARN'  if ! $prefix;
+    $prefix = 'WARN'  if $prefix eq 'WARNING';
+    $prefix = 'CRIT'  if $prefix eq 'CRITICAL';
+    $prefix = 'EMERG' if $prefix eq 'EMERGENCY';
+    return log_level("LOG$prefix"), @warnings;
+}
+
 sub varlog {
     my ($self, $trace) = (shift, shift);
     my ($hook, $plugin, @log);

lib/Qpsmtpd/Constants.pm

@@ -3,7 +3,7 @@ use strict;
 require Exporter;
 
 # log levels
-my %log_levels = (
+our %log_levels = (
                   LOGDEBUG  => 7,
                   LOGINFO   => 6,
                   LOGNOTICE => 5,
@@ -54,7 +54,7 @@ sub return_code {
 sub log_level {
     my $test = shift;
     if ($test =~ /^\d+$/) {    # need to return the textural form
-        foreach (keys %log_levels) {
+        foreach (sort keys %log_levels) {
             return $_ if $log_levels{$_} =~ /$test/;
         }
     }

qpsmtpd

@@ -17,6 +17,7 @@ delete $ENV{ENV};
 $ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin';
 
 my $qpsmtpd = Qpsmtpd::TcpServer->new();
+$SIG{__WARN__} = sub { $qpsmtpd->warn_handler(@_) };
 $qpsmtpd->load_plugins();
 $qpsmtpd->start_connection();
 $qpsmtpd->run(\*STDIN);    # pass the "socket" like -prefork/-forkserver

qpsmtpd-forkserver

@@ -180,6 +180,7 @@ if ($PID_FILE) {
 
 # Load plugins here
 my $qpsmtpd = Qpsmtpd::TcpServer->new();
+$SIG{__WARN__} = sub { $qpsmtpd->warn_handler(@_) };
 
 # Drop privileges
 my (undef, undef, $quid, $qgid) = getpwnam $USER

qpsmtpd-prefork

@@ -290,6 +290,7 @@ sub run {
 
     # setup qpsmtpd_instance
     $qpsmtpd = qpsmtpd_instance();
+    $SIG{__WARN__} = sub { $qpsmtpd->warn_handler(@_) };
 
     if ($detach) {
         open STDIN,  '/dev/null'  or die "/dev/null: $!";

t/qpsmtpd.t

@@ -45,6 +45,8 @@ __load_logging();
 __config_dir();
 __config();
 
+__warn_level();
+
 done_testing();
 
 sub __run_hooks {
@@ -348,6 +350,24 @@ sub __config {
     }
 }
 
+sub __warn_level {
+    my ( $level, $msg ) = $qp->warn_level('qwerty');
+    is( log_level($level), 'LOGWARN', 'Correct log level with no prefix' );
+    is( $msg, 'qwerty', 'Correct message with no prefix' );
+
+    ( $level, $msg ) = $qp->warn_level('NOTICE:   asdf');
+    is( log_level($level), 'LOGNOTICE', 'Correct level with NOTICE prefix' );
+    is( $msg, 'asdf', 'Correct message with NOTICE prefix' );
+
+    ( $level, $msg ) = $qp->warn_level('EMERGENCY:foo');
+    is( log_level($level), 'LOGEMERG', 'Correct level with EMERGENCY prefix' );
+    is( $msg, 'foo', 'Correct message with EMERGENCY prefix' );
+
+    ( $level, $msg ) = $qp->warn_level('NOTICE != LOGNOTICE');
+    is( log_level($level), 'LOGWARN', 'Correct level with no colon' );
+    is( $msg, 'NOTICE != LOGNOTICE', 'Correct message with no colon' );
+}
+
 1;
 
 package FakeAddress;