find plugins -type f -exec perltidy -b {} \;

plugins/async/dns_whitelist_soft

@@ -3,7 +3,7 @@
 use Qpsmtpd::Plugin::Async::DNSBLBase;
 
 sub init {
-    my $self = shift;
+    my $self  = shift;
     my $class = ref $self;
 
     no strict 'refs';

plugins/async/earlytalker

@@ -62,73 +62,80 @@ Note that defer-reject has no meaning if check-at is I<data>.
 my $MSG = 'Connecting host started transmitting before SMTP greeting';
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  if (@args % 2) {
+    if (@args % 2) {
-	$self->log(LOGERROR, "Unrecognized/mismatched arguments");
+        $self->log(LOGERROR, "Unrecognized/mismatched arguments");
-	return undef;
+        return undef;
-  }
+    }
-  $self->{_args} = {
+    $self->{_args} = {
-  	'wait' => 1,
+                      'wait'         => 1,
-	'action' => 'denysoft',
+                      'action'       => 'denysoft',
-	'defer-reject' => 0,
+                      'defer-reject' => 0,
-	'check-at' => 'connect',
+                      'check-at'     => 'connect',
-	@args,
+                      @args,
-  };
+                     };
-  print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n";
+    print STDERR "Check at: ", $self->{_args}{'check-at'}, "\n";
-  $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll');
+    $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_poll');
-  $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post');
+    $self->register_hook($self->{_args}->{'check-at'}, 'check_talker_post');
-  if ($self->{_args}{'check-at'} eq 'connect') {
+    if ($self->{_args}{'check-at'} eq 'connect') {
-    $self->register_hook('mail', 'hook_mail')
+        $self->register_hook('mail', 'hook_mail')
-      if $self->{_args}->{'defer-reject'};
+          if $self->{_args}->{'defer-reject'};
-  }
+    }
-  1;
+    1;
 }
 
 sub check_talker_poll {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  my $qp = $self->qp;
+    my $qp          = $self->qp;
-  my $conn = $qp->connection;
+    my $conn        = $qp->connection;
-  my $check_until = time + $self->{_args}{'wait'};
+    my $check_until = time + $self->{_args}{'wait'};
-  $qp->AddTimer(1, sub { read_now($qp, $conn, $check_until, $self->{_args}{'check-at'}) });
+    $qp->AddTimer(
-  return YIELD;
+        1,
+        sub {
+            read_now($qp, $conn, $check_until, $self->{_args}{'check-at'});
+        }
+    );
+    return YIELD;
 }
 
 sub read_now {
-  my ($qp, $conn, $until, $phase) = @_;
+    my ($qp, $conn, $until, $phase) = @_;
 
-  if ($qp->has_data) {
+    if ($qp->has_data) {
-    $qp->log(LOGNOTICE, 'remote host started talking after $phase before we responded');
+        $qp->log(LOGNOTICE,
-    $qp->clear_data if $phase eq 'data';
+                'remote host started talking after $phase before we responded');
-    $conn->notes('earlytalker', 1);
+        $qp->clear_data if $phase eq 'data';
-    $qp->run_continuation;
+        $conn->notes('earlytalker', 1);
-  }
+        $qp->run_continuation;
-  elsif (time >= $until) {
+    }
-    # no early talking
+    elsif (time >= $until) {
-    $qp->run_continuation;
+
-  }
+        # no early talking
-  else {
+        $qp->run_continuation;
-    $qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) });
+    }
-  }
+    else {
+        $qp->AddTimer(1, sub { read_now($qp, $conn, $until, $phase) });
+    }
 }
 
 sub check_talker_post {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  return DECLINED unless $self->connection->notes('earlytalker');
+    return DECLINED unless $self->connection->notes('earlytalker');
-  return DECLINED if $self->{'defer-reject'};
+    return DECLINED if $self->{'defer-reject'};
-  return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
+    return (DENY,     $MSG) if $self->{_args}->{'action'} eq 'deny';
-  return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
+    return (DENYSOFT, $MSG) if $self->{_args}->{'action'} eq 'denysoft';
-  return DECLINED; # assume action eq 'log'
+    return DECLINED;    # assume action eq 'log'
 }
 
 sub hook_mail {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  return DECLINED unless $self->connection->notes('earlytalker');
+    return DECLINED unless $self->connection->notes('earlytalker');
-  return (DENY,$MSG) if $self->{_args}->{'action'} eq 'deny';
+    return (DENY,     $MSG) if $self->{_args}->{'action'} eq 'deny';
-  return (DENYSOFT,$MSG) if $self->{_args}->{'action'} eq 'denysoft';
+    return (DENYSOFT, $MSG) if $self->{_args}->{'action'} eq 'denysoft';
-  return DECLINED;
+    return DECLINED;
 }
 

plugins/async/queue/smtp-forward

@@ -45,7 +45,8 @@ sub init {
             $self->{_smtp_port} = $1;
         }
 
-        $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2);
+        $self->log(LOGWARN, "WARNING: Ignoring additional arguments.")
+          if (@args > 2);
     }
     else {
         die("No SMTP server specified in smtp-forward config");
@@ -56,14 +57,17 @@ sub init {
 sub start_queue {
     my ($self, $transaction) = @_;
 
-    my $qp = $self->qp;
+    my $qp     = $self->qp;
     my $SERVER = $self->{_smtp_server};
     my $PORT   = $self->{_smtp_port};
     $self->log(LOGINFO, "forwarding to $SERVER:$PORT");
 
-    $transaction->notes('async_sender', 
+    $transaction->notes(
-        AsyncSMTPSender->new($SERVER, $PORT, $qp, $self, $transaction)
+                        'async_sender',
-    );
+                        AsyncSMTPSender->new(
+                                        $SERVER, $PORT, $qp, $self, $transaction
+                                            )
+                       );
 
     return YIELD;
 }
@@ -85,17 +89,17 @@ use IO::Socket;
 
 use base qw(Danga::Socket);
 use fields qw(
-    qp
+  qp
-    pkg
+  pkg
-    tran
+  tran
-    state
+  state
-    rcode
+  rcode
-    rmsg
+  rmsg
-    buf
+  buf
-    command
+  command
-    resp
+  resp
-    to
+  to
-    );
+  );
 
 use constant ST_CONNECTING => 0;
 use constant ST_CONNECTED  => 1;
@@ -109,26 +113,29 @@ sub new {
     $self = fields::new($self) unless ref $self;
 
     my $sock = IO::Socket::INET->new(
-        PeerAddr => $server,
+                                     PeerAddr => $server,
-        PeerPort => $port,
+                                     PeerPort => $port,
-        Blocking  => 0,
+                                     Blocking => 0,
-    ) or die "Error connecting to server $server:$port : $!\n";
+                                    )
+      or die "Error connecting to server $server:$port : $!\n";
 
     IO::Handle::blocking($sock, 0);
     binmode($sock, ':raw');
 
-    $self->{qp} = $qp;
+    $self->{qp}      = $qp;
-    $self->{pkg} = $pkg;
+    $self->{pkg}     = $pkg;
-    $self->{tran} = $transaction;
+    $self->{tran}    = $transaction;
-    $self->{state} = ST_CONNECTING;
+    $self->{state}   = ST_CONNECTING;
-    $self->{rcode} = DECLINED;
+    $self->{rcode}   = DECLINED;
     $self->{command} = 'connect';
-    $self->{buf} = '';
+    $self->{buf}     = '';
-    $self->{resp} = [];
+    $self->{resp}    = [];
+
     # copy the recipients so we can pop them off one by one
-    $self->{to} = [ $transaction->recipients ];
+    $self->{to} = [$transaction->recipients];
 
     $self->SUPER::new($sock);
+
     # Watch for write first, this is when the TCP session is established.
     $self->watch_write(1);
 
@@ -137,7 +144,7 @@ sub new {
 
 sub results {
     my AsyncSMTPSender $self = shift;
-    return ( $self->{rcode}, $self->{rmsg} );
+    return ($self->{rcode}, $self->{rmsg});
 }
 
 sub log {
@@ -157,8 +164,9 @@ sub command {
 
     $self->log(LOGDEBUG, ">> $command $params");
 
-    $self->write(($command =~ m/ / ? "$command:" : $command)
+    $self->write(  ($command =~ m/ / ? "$command:" : $command)
-      . ($params ? " $params" : "") . "\r\n");
+                 . ($params ? " $params" : "")
+                   . "\r\n");
     $self->watch_read(1);
     $self->{command} = ($command =~ /(\S+)/)[0];
 }
@@ -183,7 +191,8 @@ sub cmd_connect {
     else {
         my $host = $self->{qp}->config('me');
         print "HELOing with $host\n";
-        $self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO", $host);
+        $self->command((join '', @$response) =~ m/ ESMTP/ ? "EHLO" : "HELO",
+                       $host);
     }
 }
 
@@ -265,7 +274,7 @@ sub cmd_data {
         while (my $line = $self->{tran}->body_getline) {
             $line =~ s/\r?\n/\r\n/;
             $write_buf .= $line;
-            if (length($write_buf) >= 131072) { # 128KB, arbitrary value
+            if (length($write_buf) >= 131072) {    # 128KB, arbitrary value
                 $self->log(LOGDEBUG, ">> $write_buf");
                 $self->datasend($write_buf);
                 $write_buf = '';
@@ -299,7 +308,7 @@ sub cmd_quit {
     my ($code, $response) = @_;
 
     $self->{rcode} = OK;
-    $self->{rmsg} = "Queued!";
+    $self->{rmsg}  = "Queued!";
     $self->close;
     $self->cont;
 }
@@ -321,6 +330,7 @@ sub event_read {
     if ($self->{state} == ST_COMMANDS) {
         my $in = $self->read(1024);
         if (!$in) {
+
             # XXX: connection closed
             $self->close("lost connection");
             return;
@@ -329,12 +339,12 @@ sub event_read {
         my @lines = split /\r?\n/, $self->{buf} . $$in, -1;
         $self->{buf} = delete $lines[-1];
 
-        for(@lines) {
+        for (@lines) {
             if (my ($code, $cont, $rest) = /^([0-9]{3})([ -])(.*)/) {
                 $self->log(LOGDEBUG, "<< $code$cont$rest");
                 push @{$self->{resp}}, $rest;
 
-                if($cont eq ' ') {
+                if ($cont eq ' ') {
                     $self->handle_response($code, $self->{resp});
                     $self->{resp} = [];
                 }
@@ -363,6 +373,7 @@ sub event_write {
         $self->watch_read(1);
     }
     elsif (0 && $self->{state} == ST_DATA) {
+
         # send more data
         if (my $line = $self->{tran}->body_getline) {
             $self->log(LOGDEBUG, ">> $line");
@@ -383,8 +394,9 @@ sub event_write {
 
 sub event_err {
     my ($self) = @_;
-    eval { $self->read(1); }; # gives us the correct error in errno
+    eval { $self->read(1); };    # gives us the correct error in errno
     $self->{rmsg} = "Read error from remote server: $!";
+
     #print "lost connection: $!\n";
     $self->close;
     $self->cont;
@@ -392,8 +404,9 @@ sub event_err {
 
 sub event_hup {
     my ($self) = @_;
-    eval { $self->read(1); }; # gives us the correct error in errno
+    eval { $self->read(1); };    # gives us the correct error in errno
     $self->{rmsg} = "HUP error from remote server: $!";
+
     #print "lost connection: $!\n";
     $self->close;
     $self->cont;

plugins/async/resolvable_fromhost

@@ -14,45 +14,47 @@ my %invalid  = ();
 my $has_ipv6 = Qpsmtpd::TcpServer::has_ipv6();
 
 sub register {
-    my ( $self, $qp ) = @_;
+    my ($self, $qp) = @_;
 
-    foreach my $i ( $self->qp->config("invalid_resolvable_fromhost") ) {
+    foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) {
         $i =~ s/^\s*//;
         $i =~ s/\s*$//;
-        if ( $i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)# ) {
+        if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) {
             $invalid{$1} = $3;
         }
     }
 
     eval 'use ParaDNS';
-    if ( $@ ) {
+    if ($@) {
         warn "could not load ParaDNS, plugin disabled";
         return DECLINED;
-    };
+    }
-    $self->register_hook( mail => 'hook_mail_start' );
+    $self->register_hook(mail => 'hook_mail_start');
-    $self->register_hook( mail => 'hook_mail_done' );
+    $self->register_hook(mail => 'hook_mail_done');
 }
 
 sub hook_mail_start {
-    my ( $self, $transaction, $sender ) = @_;
+    my ($self, $transaction, $sender) = @_;
 
     return DECLINED
       if ($self->connection->notes('whitelisthost'));
 
-    if ( $sender ne '<>' ) {
+    if ($sender ne '<>') {
+
+        unless ($sender->host) {
 
-        unless ( $sender->host ) {
             # default of addr_bad_from_system is DENY, we use DENYSOFT here to
             # get the same behaviour as without Qpsmtpd::DSN...
-            return Qpsmtpd::DSN->addr_bad_from_system( DENYSOFT,
+            return
-                "FQDN required in the envelope sender" );
+              Qpsmtpd::DSN->addr_bad_from_system(DENYSOFT,
+                                        "FQDN required in the envelope sender");
         }
 
         return DECLINED if $sender->host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
 
-        unless ($self->check_dns( $sender->host )) {
+        unless ($self->check_dns($sender->host)) {
             return Qpsmtpd::DSN->temp_resolver_failed(
-                "Could not resolve " . $sender->host );
+                                          "Could not resolve " . $sender->host);
         }
 
         return YIELD;
@@ -62,76 +64,97 @@ sub hook_mail_start {
 }
 
 sub hook_mail_done {
-    my ( $self, $transaction, $sender ) = @_;
+    my ($self, $transaction, $sender) = @_;
 
     return DECLINED
-      if ( $self->connection->notes('whitelisthost') );
+      if ($self->connection->notes('whitelisthost'));
+
+    if ($sender ne "<>" && !$transaction->notes('resolvable_fromhost')) {
 
-    if ( $sender ne "<>" && !$transaction->notes('resolvable_fromhost') ) {
         # default of temp_resolver_failed is DENYSOFT
         return Qpsmtpd::DSN->temp_resolver_failed(
-            "Could not resolve " . $sender->host );
+                                          "Could not resolve " . $sender->host);
     }
     return DECLINED;
 }
 
 sub check_dns {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
     my @host_answers;
 
     my $qp = $self->qp;
     $qp->input_sock->pause_read;
 
-    my $a_records = [];
+    my $a_records   = [];
     my $num_queries = 1;    # queries in progress
-    my $mx_found = 0;
+    my $mx_found    = 0;
 
     ParaDNS->new(
-        callback  => sub {
+        callback => sub {
             my $mx = shift;
-            return if $mx =~ /^[A-Z]+$/; # error
+            return if $mx =~ /^[A-Z]+$/;    # error
 
             my $addr = $mx->[0];
             $mx_found = 1;
 
             $num_queries++;
             ParaDNS->new(
-                callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
+                callback => sub {
-                finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
+                    push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/;
-                host     => $addr,
+                },
-                type     => 'A',
+                finished => sub {
-            );
+                    $num_queries--;
+                    $self->finish_up($qp, $a_records, $num_queries);
+                },
+                host => $addr,
+                type => 'A',
+                        );
 
             if ($has_ipv6) {
                 $num_queries++;
                 ParaDNS->new(
-                    callback => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
+                    callback => sub {
-                    finished => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
+                        push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/;
-                    host     => $addr,
+                    },
-                    type     => 'AAAA',
+                    finished => sub {
-                );
+                        $num_queries--;
+                        $self->finish_up($qp, $a_records, $num_queries);
+                    },
+                    host => $addr,
+                    type => 'AAAA',
+                            );
             }
         },
-        finished  => sub {
+        finished => sub {
 
             unless ($mx_found) {
 
                 $num_queries++;
                 ParaDNS->new(
-                    callback  => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
+                    callback => sub {
-                    finished  => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
+                        push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/;
-                    host      => $host,
+                    },
-                    type      => 'A',
+                    finished => sub {
-                );
+                        $num_queries--;
+                        $self->finish_up($qp, $a_records, $num_queries);
+                    },
+                    host => $host,
+                    type => 'A',
+                            );
 
                 if ($has_ipv6) {
                     $num_queries++;
                     ParaDNS->new(
-                        callback  => sub { push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/; },
+                        callback => sub {
-                        finished  => sub { $num_queries--; $self->finish_up($qp, $a_records, $num_queries) },
+                            push @$a_records, $_[0] if $_[0] !~ /^[A-Z]+$/;
-                        host      => $host,
+                        },
-                        type      => 'AAAA',
+                        finished => sub {
-                   );
+                            $num_queries--;
+                            $self->finish_up($qp, $a_records, $num_queries);
+                        },
+                        host => $host,
+                        type => 'AAAA',
+                                );
                 }
 
             }
@@ -139,9 +162,10 @@ sub check_dns {
             $num_queries--;
             $self->finish_up($qp, $a_records, $num_queries);
         },
-        host      => $host,
+        host => $host,
-        type      => 'MX',
+        type => 'MX',
-    ) or $qp->input_sock->continue_read, return;
+                )
+      or $qp->input_sock->continue_read, return;
 
     return 1;
 }
@@ -161,6 +185,7 @@ sub finish_up {
     }
 
     unless ($num_queries) {
+
         # all queries returned no valid response
         $qp->transaction->notes('resolvable_fromhost', 0);
         $qp->input_sock->continue_read;
@@ -170,12 +195,12 @@ sub finish_up {
 
 sub is_valid {
     my $ip = shift;
-    my ( $net, $mask );
+    my ($net, $mask);
-    foreach $net ( keys %invalid ) {
+    foreach $net (keys %invalid) {
         $mask = $invalid{$net};
-        $mask = pack "B32", "1" x ($mask) . "0" x ( 32 - $mask );
+        $mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask);
         return 0
-          if join( ".", unpack( "C4", inet_aton($ip) & $mask ) ) eq $net;
+          if join(".", unpack("C4", inet_aton($ip) & $mask)) eq $net;
     }
     return 1;
 }

plugins/async/rhsbl

@@ -3,7 +3,7 @@
 use Qpsmtpd::Plugin::Async::DNSBLBase;
 
 sub init {
-    my $self = shift;
+    my $self  = shift;
     my $class = ref $self;
 
     no strict 'refs';

plugins/async/uribl

@@ -31,10 +31,13 @@ sub start_data_post {
 
     my @names;
 
-    my $queries = $self->lookup_start($transaction, sub {
+    my $queries = $self->lookup_start(
-        my ($self, $name) = @_;
+        $transaction,
-        push @names, $name;
+        sub {
-    });
+            my ($self, $name) = @_;
+            push @names, $name;
+        }
+    );
 
     my @hosts;
     foreach my $z (keys %{$self->{uribl_zones}}) {
@@ -42,10 +45,10 @@ sub start_data_post {
     }
 
     $transaction->notes(uribl_results => {});
-    $transaction->notes(uribl_zones => $self->{uribl_zones});
+    $transaction->notes(uribl_zones   => $self->{uribl_zones});
 
     return DECLINED
-        unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]);
+      unless @hosts && $class->lookup($self->qp, [@hosts], [@hosts]);
 
     return YIELD;
 }
@@ -58,9 +61,11 @@ sub finish_data_post {
         $self->log(LOGWARN, $_->{desc});
         if ($_->{action} eq 'add-header') {
             $transaction->header->add('X-URIBL-Match', $_->{desc});
-        } elsif ($_->{action} eq 'deny') {
+        }
+        elsif ($_->{action} eq 'deny') {
             return (DENY, $_->{desc});
-        } elsif ($_->{action} eq 'denysoft') {
+        }
+        elsif ($_->{action} eq 'denysoft') {
             return (DENYSOFT, $_->{desc});
         }
     }
@@ -73,8 +78,8 @@ sub process_a_result {
     my ($class, $qp, $result, $query) = @_;
 
     my $transaction = $qp->transaction;
-    my $results = $transaction->notes('uribl_results');
+    my $results     = $transaction->notes('uribl_results');
-    my $zones = $transaction->notes('uribl_zones');
+    my $zones       = $transaction->notes('uribl_zones');
 
     foreach my $z (keys %$zones) {
         if ($query =~ /^(.*)\.$z$/) {
@@ -88,8 +93,8 @@ sub process_txt_result {
     my ($class, $qp, $result, $query) = @_;
 
     my $transaction = $qp->transaction;
-    my $results = $transaction->notes('uribl_results');
+    my $results     = $transaction->notes('uribl_results');
-    my $zones = $transaction->notes('uribl_zones');
+    my $zones       = $transaction->notes('uribl_zones');
 
     foreach my $z (keys %$zones) {
         if ($query =~ /^(.*)\.$z$/) {
@@ -110,11 +115,15 @@ sub collect_results {
             if (exists $results->{$z}->{$n}->{a}) {
                 if ($self->evaluate($z, $results->{$z}->{$n}->{a})) {
                     $self->log(LOGDEBUG, "match $n in $z");
-                    push @matches, {
+                    push @matches,
+                      {
                         action => $self->{uribl_zones}->{$z}->{action},
-                        desc => "$n in $z: " .
+                        desc   => "$n in $z: "
-                            ($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}),
+                          . (
-                    };
+                                  $results->{$z}->{$n}->{txt}
+                               || $results->{$z}->{$n}->{a}
+                            ),
+                      };
                 }
             }
         }

plugins/auth/auth_checkpassword

@@ -106,12 +106,12 @@ Please see the LICENSE file included with qpsmtpd for details.
 =cut
 
 sub register {
-    my ($self, $qp, %args ) = @_;
+    my ($self, $qp, %args) = @_;
 
-    my ($checkpw, $true) = $self->get_checkpw( \%args );
+    my ($checkpw, $true) = $self->get_checkpw(\%args);
-    return DECLINED if ! $checkpw || ! $true;
+    return DECLINED if !$checkpw || !$true;
 
-    $self->connection->notes('auth_checkpassword_bin', $checkpw);
+    $self->connection->notes('auth_checkpassword_bin',  $checkpw);
     $self->connection->notes('auth_checkpassword_true', $true);
 
     $self->register_hook('auth-plain', 'auth_checkpassword');
@@ -123,8 +123,8 @@ sub auth_checkpassword {
       @_;
 
     my $binary = $self->connection->notes('auth_checkpassword_bin');
-    my $true = $self->connection->notes('auth_checkpassword_true');
+    my $true   = $self->connection->notes('auth_checkpassword_true');
-    chomp ($binary, $true);
+    chomp($binary, $true);
 
     my $sudo = get_sudo($binary);
 
@@ -138,7 +138,7 @@ sub auth_checkpassword {
     if ($status != 0) {
         $self->log(LOGNOTICE, "authentication failed ($status)");
         return (DECLINED);
-    };
+    }
 
     $self->connection->notes('authuser', $user);
     return (OK, "auth_checkpassword");
@@ -147,42 +147,43 @@ sub auth_checkpassword {
 sub get_checkpw {
     my ($self, $args) = @_;
 
-    my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw}; # untaint
+    my ($checkpw) = $args->{checkpw} =~ /^(.*)$/ if $args->{checkpw};  # untaint
-    my ($true)    = $args->{true} =~ /^(.*)$/ if $args->{true};       # untaint
+    my ($true)    = $args->{true} =~ /^(.*)$/    if $args->{true};     # untaint
 
-    return ( $checkpw, $true )
+    return ($checkpw, $true)
-        if ( $checkpw && $true && -x $checkpw && -x $true );
+      if ($checkpw && $true && -x $checkpw && -x $true);
 
-    my $missing_config = "disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure.";
+    my $missing_config =
+"disabled due to invalid configuration. See 'perldoc plugins/auth/auth_checkpassword' for how to configure.";
 
-    if ( ! $self->qp->config('smtpauth-checkpassword') ) {
+    if (!$self->qp->config('smtpauth-checkpassword')) {
-        $self->log(LOGERROR, $missing_config );
+        $self->log(LOGERROR, $missing_config);
         return;
-    };
+    }
 
     $self->log(LOGNOTICE, "reading config from smtpauth-checkpassword");
     my $config = $self->qp->config("smtpauth-checkpassword");
     ($checkpw, $true) = $config =~ /^(\S+)\s+(\S+)\s*$/;
 
-    if ( ! $checkpw || ! $true || ! -x $checkpw || ! -x $true ) {
+    if (!$checkpw || !$true || !-x $checkpw || !-x $true) {
-        $self->log(LOGERROR, $missing_config );
+        $self->log(LOGERROR, $missing_config);
         return;
-    };
+    }
     return ($checkpw, $true);
-};
+}
 
 sub get_sudo {
     my $binary = shift;
 
-    return '' if $> == 0;                            # running as root
+    return '' if $> == 0;                             # running as root
-    return '' if $> == 89 && $binary =~ /vchkpw$/;   # running as vpopmail
+    return '' if $> == 89 && $binary =~ /vchkpw$/;    # running as vpopmail
 
     my $mode = (stat($binary))[2];
     $mode = sprintf "%lo", $mode & 07777;
-    return '' if $mode eq '4711';                    # $binary is setuid
+    return '' if $mode eq '4711';                     # $binary is setuid
 
     my $sudo = `which sudo` || '/usr/local/bin/sudo';
-    return '' if ! -x $sudo;
+    return '' if !-x $sudo;
 
     $sudo .= ' -C4';    # prevent sudo from clobbering file descriptor 3
 

plugins/auth/auth_cvm_unix_local

@@ -46,24 +46,24 @@ use warnings;
 use Qpsmtpd::Constants;
 
 use Socket;
-use constant SMTP_PORT => getservbyname("smtp", "tcp") || 25;
+use constant SMTP_PORT  => getservbyname("smtp",  "tcp") || 25;
 use constant SSMTP_PORT => getservbyname("ssmtp", "tcp") || 465;
 
 sub register {
-    my ( $self, $qp, %arg ) = @_;
+    my ($self, $qp, %arg) = @_;
 
     unless ($arg{cvm_socket}) {
         $self->log(LOGERROR, "skip: requires cvm_socket argument");
         return 0;
-    };
+    }
 
-    $self->{_args} = { %arg };
+    $self->{_args}         = {%arg};
-    $self->{_enable_smtp} = $arg{enable_smtp} || 'no';
+    $self->{_enable_smtp}  = $arg{enable_smtp} || 'no';
     $self->{_enable_ssmtp} = $arg{enable_ssmtp} || 'yes';
 
     my $port = $ENV{PORT} || SMTP_PORT;
 
-    return 0 if ($port == SMTP_PORT && $arg{enable_smtp} ne 'yes');
+    return 0 if ($port == SMTP_PORT  && $arg{enable_smtp} ne 'yes');
     return 0 if ($port == SSMTP_PORT && $arg{enable_ssmtp} ne 'yes');
 
     if ($arg{cvm_socket} =~ /^([\w\/.-]+)$/) {
@@ -77,11 +77,12 @@ sub register {
 
     $self->register_hook("auth-plain", "authcvm_plain");
     $self->register_hook("auth-login", "authcvm_plain");
-#    $self->register_hook("auth-cram-md5", "authcvm_hash");
+
+    #    $self->register_hook("auth-cram-md5", "authcvm_hash");
 }
 
 sub authcvm_plain {
-    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
       @_;
 
     socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or do {
@@ -89,41 +90,43 @@ sub authcvm_plain {
         return (DENY, "authcvm");
     };
 
-# DENY, really? Should this plugin return a DENY when it cannot connect
+    # DENY, really? Should this plugin return a DENY when it cannot connect
-# to the cvs socket? I'd expect such a failure to return DECLINED, so
+    # to the cvs socket? I'd expect such a failure to return DECLINED, so
-# any other auth plugins could take a stab at authenticating the user
+    # any other auth plugins could take a stab at authenticating the user
 
     connect(SOCK, sockaddr_un($self->{_cvm_socket})) or do {
         $self->log(LOGERROR, "skip: socket connection attempt for: $user");
         return (DENY, "authcvm");
     };
 
-    my $o = select(SOCK); $| = 1; select($o);
+    my $o = select(SOCK);
+    $| = 1;
+    select($o);
 
     my ($u, $host) = split(/\@/, $user);
     $host ||= "localhost";
 
     print SOCK "\001$u\000$host\000$passClear\000\000";
 
-    shutdown SOCK, 1;   # tell remote we're finished
+    shutdown SOCK, 1;    # tell remote we're finished
 
     my $ret = <SOCK>;
-    my ($s) = unpack ("C", $ret);
+    my ($s) = unpack("C", $ret);
 
-    if ( ! defined $s ) {
+    if (!defined $s) {
         $self->log(LOGERROR, "skip: no response from cvm for $user");
         return (DECLINED);
-    };
+    }
 
-    if ( $s == 0 ) {
+    if ($s == 0) {
         $self->log(LOGINFO, "pass: authentication for: $user");
         return (OK, "auth success for $user");
-    };
+    }
 
-    if ( $s == 100 ) {
+    if ($s == 100) {
         $self->log(LOGINFO, "fail: authentication failure for: $user");
         return (DENY, 'auth failure (100)');
-    };
+    }
 
     $self->log(LOGERROR, "skip: unknown response from cvm for $user");
     return (DECLINED, "unknown result code ($s)");

plugins/auth/auth_flat_file

@@ -37,7 +37,7 @@ use Qpsmtpd::Auth;
 use Qpsmtpd::Constants;
 
 sub register {
-    my ( $self, $qp ) = @_;
+    my ($self, $qp) = @_;
 
     $self->register_hook('auth-plain',    'auth_flat_file');
     $self->register_hook('auth-login',    'auth_flat_file');
@@ -45,24 +45,25 @@ sub register {
 }
 
 sub auth_flat_file {
-    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
       @_;
 
-    if ( ! defined $passClear && ! defined $passHash ) {
+    if (!defined $passClear && !defined $passHash) {
         $self->log(LOGINFO, "fail: missing password");
-        return ( DENY, "authflat - missing password" );
+        return (DENY, "authflat - missing password");
     }
 
-    my ( $pw_name, $pw_domain ) = split /@/, lc($user);
+    my ($pw_name, $pw_domain) = split /@/, lc($user);
 
-    unless ( defined $pw_domain ) {
+    unless (defined $pw_domain) {
         $self->log(LOGINFO, "fail: missing domain");
         return DECLINED;
     }
 
-    my ($auth_line) = grep {/^$pw_name\@$pw_domain:/} $self->qp->config('flat_auth_pw');
+    my ($auth_line) =
+      grep { /^$pw_name\@$pw_domain:/ } $self->qp->config('flat_auth_pw');
 
-    if ( ! defined $auth_line) {
+    if (!defined $auth_line) {
         $self->log(LOGINFO, "fail: no such user: $user");
         return DECLINED;
     }
@@ -70,14 +71,16 @@ sub auth_flat_file {
     my ($auth_user, $auth_pass) = split(/:/, $auth_line, 2);
 
     # at this point we can assume the user name matched
-    return Qpsmtpd::Auth::validate_password( $self,
+    return
-            src_clear     => $auth_pass,
+      Qpsmtpd::Auth::validate_password(
-            src_crypt     => undef,
+                                       $self,
-            attempt_clear => $passClear,
+                                       src_clear     => $auth_pass,
-            attempt_hash  => $passHash,
+                                       src_crypt     => undef,
-            method        => $method,
+                                       attempt_clear => $passClear,
-            ticket        => $ticket,
+                                       attempt_hash  => $passHash,
-            deny          => DENY,
+                                       method        => $method,
-        );
+                                       ticket        => $ticket,
+                                       deny          => DENY,
+                                      );
 }
 

plugins/auth/auth_ldap_bind

@@ -136,7 +136,7 @@ sub authldap {
     unless ($ldbase) {
         $self->log(LOGERROR, "skip: please configure ldap_base");
         return (DECLINED, "authldap - temporary auth error");
-    };
+    }
     $ldwait  = $self->{"ldconf"}->{'ldap_timeout'};
     $ldmattr = $self->{"ldconf"}->{'ldap_auth_filter_attr'};
 
@@ -149,20 +149,23 @@ sub authldap {
     };
 
     # find the user's DN
-    $mesg = $ldh->search(   base      => $ldbase,
+    $mesg = $ldh->search(
-                            scope     => 'sub',
+                         base      => $ldbase,
-                            filter    => "$ldmattr=$pw_name",
+                         scope     => 'sub',
-                            attrs     => ['uid'],
+                         filter    => "$ldmattr=$pw_name",
-                            timeout   => $ldwait,
+                         attrs     => ['uid'],
-                            sizelimit => '1'
+                         timeout   => $ldwait,
-                        ) or do {
+                         sizelimit => '1'
+                        )
+      or do {
         $self->log(LOGALERT, "skip: err in search for user");
         return (DECLINED, "authldap - temporary auth error");
-    };
+      };
 
     # deal with errors if they exist
     if ($mesg->code) {
-        $self->log(LOGALERT, "skip: err " . $mesg->code . " in search for user");
+        $self->log(LOGALERT,
+                   "skip: err " . $mesg->code . " in search for user");
         return (DECLINED, "authldap - temporary auth error");
     }
 
@@ -170,10 +173,10 @@ sub authldap {
     $ldh->unbind if $ldh;
 
     # bind against directory as user with password supplied
-    if ( ! $mesg->count || $lduserdn = $mesg->entry->dn ) {
+    if (!$mesg->count || $lduserdn = $mesg->entry->dn) {
         $self->log(LOGALERT, "fail: user not found");
         return (DECLINED, "authldap - wrong username or password");
-    };
+    }
 
     $ldh = Net::LDAP->new($ldhost, port => $ldport, timeout => $ldwait) or do {
         $self->log(LOGALERT, "skip: err in user conn");

plugins/auth/auth_vpopmail

@@ -50,10 +50,10 @@ use Qpsmtpd::Constants;
 sub register {
     my ($self, $qp) = @_;
 
-    return (DECLINED) if ! $self->test_vpopmail_module();
+    return (DECLINED) if !$self->test_vpopmail_module();
 
-    $self->register_hook("auth-plain", "auth_vpopmail" );
+    $self->register_hook("auth-plain",    "auth_vpopmail");
-    $self->register_hook("auth-login", "auth_vpopmail" );
+    $self->register_hook("auth-login",    "auth_vpopmail");
     $self->register_hook("auth-cram-md5", "auth_vpopmail");
 }
 
@@ -61,41 +61,45 @@ sub auth_vpopmail {
     my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
       @_;
 
-    my $pw              = vauth_getpw( split /@/, lc($user) );
+    my $pw              = vauth_getpw(split /@/, lc($user));
     my $pw_clear_passwd = $pw->{pw_clear_passwd};
     my $pw_passwd       = $pw->{pw_passwd};
 
     if (!$pw || (!$pw_clear_passwd && !$pw_passwd)) {
         $self->log(LOGINFO, "fail: invalid user $user");
         return (DENY, "auth_vpopmail - invalid user");
+
         # change DENY to DECLINED to support multiple auth plugins
     }
 
-    return Qpsmtpd::Auth::validate_password( $self,
+    return
-        src_clear     => $pw->{pw_clear_passwd},
+      Qpsmtpd::Auth::validate_password(
-        src_crypt     => $pw->{pw_passwd},
+                                       $self,
-        attempt_clear => $passClear,
+                                       src_clear     => $pw->{pw_clear_passwd},
-        attempt_hash  => $passHash,
+                                       src_crypt     => $pw->{pw_passwd},
-        method        => $method,
+                                       attempt_clear => $passClear,
-        ticket        => $ticket,
+                                       attempt_hash  => $passHash,
-        deny          => DENY,
+                                       method        => $method,
-    );
+                                       ticket        => $ticket,
+                                       deny          => DENY,
+                                      );
 }
 
 sub test_vpopmail_module {
     my $self = shift;
+
 # vpopmail will not allow vauth_getpw to succeed unless the requesting user is vpopmail or root.
 # by default, qpsmtpd runs as the user 'qpsmtpd' and does not have permission.
     eval 'use vpopmail';
-    if ( $@ ) {
+    if ($@) {
         $self->log(LOGERROR, "skip: is vpopmail perl module installed?");
         return;
-    };
+    }
 
     my ($domain) = vpopmail::vlistdomains();
     my $r = vauth_getpw('postmaster', $domain) or do {
-            $self->log(LOGERROR, "skip: could not query vpopmail");
+        $self->log(LOGERROR, "skip: could not query vpopmail");
-            return;
+        return;
-        };
+    };
     return 1;
 }

plugins/auth/auth_vpopmail_sql

@@ -72,14 +72,14 @@ use Qpsmtpd::Constants;
 #use DBI;  # done in ->register
 
 sub register {
-    my ( $self, $qp ) = @_;
+    my ($self, $qp) = @_;
 
     eval 'use DBI';
-    if ( $@ ) {
+    if ($@) {
         warn "plugin disabled. is DBI installed?\n";
         $self->log(LOGERROR, "skip: plugin disabled. is DBI installed?\n");
         return;
-    };
+    }
 
     $self->register_hook('auth-plain',    'auth_vmysql');
     $self->register_hook('auth-login',    'auth_vmysql');
@@ -89,27 +89,28 @@ sub register {
 sub get_db_handle {
     my $self = shift;
 
-    my $dsn    = $self->qp->config("vpopmail_mysql_dsn") || "dbi:mysql:dbname=vpopmail;host=127.0.0.1";
+    my $dsn = $self->qp->config("vpopmail_mysql_dsn")
+      || "dbi:mysql:dbname=vpopmail;host=127.0.0.1";
     my $dbuser = $self->qp->config("vpopmail_mysql_user") || "vpopmailuser";
     my $dbpass = $self->qp->config("vpopmail_mysql_pass") || "vpoppasswd";
 
-    my $dbh = DBI->connect( $dsn, $dbuser, $dbpass ) or do {
+    my $dbh = DBI->connect($dsn, $dbuser, $dbpass) or do {
-            $self->log(LOGERROR, "skip: db connection failed");
+        $self->log(LOGERROR, "skip: db connection failed");
-            return;
-        };
-    $dbh->{ShowErrorStatement} = 1;
-    return $dbh;
-};
-
-sub get_vpopmail_user {
-    my ( $self, $dbh, $user ) = @_;
-
-    my ( $pw_name, $pw_domain ) = split /@/, lc($user);
-
-    if ( ! defined $pw_domain ) {
-        $self->log(LOGINFO, "skip: missing domain: " . lc $user );
         return;
     };
+    $dbh->{ShowErrorStatement} = 1;
+    return $dbh;
+}
+
+sub get_vpopmail_user {
+    my ($self, $dbh, $user) = @_;
+
+    my ($pw_name, $pw_domain) = split /@/, lc($user);
+
+    if (!defined $pw_domain) {
+        $self->log(LOGINFO, "skip: missing domain: " . lc $user);
+        return;
+    }
 
     $self->log(LOGDEBUG, "auth_vpopmail_sql: $user");
 
@@ -118,16 +119,17 @@ FROM vpopmail
   WHERE pw_name = ?
     AND pw_domain = ?";
 
-    my $sth = $dbh->prepare( $query );
+    my $sth = $dbh->prepare($query);
-    $sth->execute( $pw_name, $pw_domain );
+    $sth->execute($pw_name, $pw_domain);
     my $userd_ref = $sth->fetchrow_hashref;
     $sth->finish;
     $dbh->disconnect;
     return $userd_ref;
-};
+}
 
 sub auth_vmysql {
-    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) = @_;
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
+      @_;
 
     my $dbh = $self->get_db_handle() or return DECLINED;
     my $u = $self->get_vpopmail_user($dbh, $user) or return DECLINED;
@@ -136,21 +138,23 @@ sub auth_vmysql {
     # then pw_clear_passwd may not even exist
     # my $pw_clear_passwd = $db_user->{'pw_clear_passwd'};
 
-    if ( ! $u->{pw_passwd} && ! $u->{pw_clear_passwd} ) {
+    if (!$u->{pw_passwd} && !$u->{pw_clear_passwd}) {
         $self->log(LOGINFO, "fail: no such user");
-        return ( DENY, "auth_vmysql - no such user" );
+        return (DENY, "auth_vmysql - no such user");
-    };
+    }
 
     # at this point, the user name has matched
 
-    return Qpsmtpd::Auth::validate_password( $self,
+    return
-            src_clear     => $u->{pw_clear_passwd},
+      Qpsmtpd::Auth::validate_password(
-            src_crypt     => $u->{pw_passwd},
+                                       $self,
-            attempt_clear => $passClear,
+                                       src_clear     => $u->{pw_clear_passwd},
-            attempt_hash  => $passHash,
+                                       src_crypt     => $u->{pw_passwd},
-            method        => $method,
+                                       attempt_clear => $passClear,
-            ticket        => $ticket,
+                                       attempt_hash  => $passHash,
-            deny          => DENY,
+                                       method        => $method,
-        );
+                                       ticket        => $ticket,
+                                       deny          => DENY,
+                                      );
 }
 

plugins/auth/auth_vpopmaild

@@ -16,58 +16,63 @@ sub register {
 
     $self->register_hook('auth-plain', 'auth_vpopmaild');
     $self->register_hook('auth-login', 'auth_vpopmaild');
+
     #$self->register_hook('auth-cram-md5', 'auth_vpopmaild'); # not supported
 }
 
 sub auth_vpopmaild {
-    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) = @_;
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
+      @_;
 
-    if ( ! $passClear ) {
+    if (!$passClear) {
         $self->log(LOGINFO, "skip: vpopmaild does not support cram-md5");
         return DECLINED;
     }
 
     # create socket
-    my $vpopmaild_socket = IO::Socket::INET->new(
+    my $vpopmaild_socket =
+      IO::Socket::INET->new(
                             PeerAddr => $self->{_vpopmaild_host},
                             PeerPort => $self->{_vpopmaild_port},
                             Proto    => 'tcp',
                             Type     => SOCK_STREAM
-                           ) or do {
+                           )
+      or do {
         $self->log(LOGERROR, "skip: socket connection to vpopmaild failed");
         return DECLINED;
-    };
+      };
 
     $self->log(LOGDEBUG, "attempting $method");
 
     # Get server greeting (+OK)
     my $connect_response = <$vpopmaild_socket>;
-    if ( ! $connect_response ) {
+    if (!$connect_response) {
         $self->log(LOGERROR, "skip: no connection response");
         close($vpopmaild_socket);
         return DECLINED;
-    };
+    }
 
-    if ( $connect_response !~ /^\+OK/ ) {
+    if ($connect_response !~ /^\+OK/) {
-        $self->log(LOGERROR, "skip: bad connection response: $connect_response");
+        $self->log(LOGERROR,
+                   "skip: bad connection response: $connect_response");
         close($vpopmaild_socket);
         return DECLINED;
-    };
+    }
 
-    print $vpopmaild_socket "login $user $passClear\n\r"; # send login details
+    print $vpopmaild_socket "login $user $passClear\n\r";   # send login details
-    my $login_response = <$vpopmaild_socket>;       # get response from server
+    my $login_response = <$vpopmaild_socket>;    # get response from server
     close($vpopmaild_socket);
 
-    if ( ! $login_response ) {
+    if (!$login_response) {
         $self->log(LOGERROR, "skip: no login response");
         return DECLINED;
-    };
+    }
 
     # check for successful login (single line (+OK) or multiline (+OK+))
-    if ( $login_response =~ /^\+OK/ ) {
+    if ($login_response =~ /^\+OK/) {
         $self->log(LOGINFO, "pass: clear");
         return (OK, 'auth_vpopmaild');
-    };
+    }
 
     chomp $login_response;
     $self->log(LOGNOTICE, "fail: $login_response");

plugins/auth/authdeny

@@ -13,11 +13,11 @@ the Qpsmtpd::Auth module.  Don't run this in production!!!
 =cut
 
 sub hook_auth {
-    my ( $self, $transaction, $method, $user, $passClear, $passHash, $ticket ) =
+    my ($self, $transaction, $method, $user, $passClear, $passHash, $ticket) =
       @_;
 
-    $self->log( LOGWARN, "fail: cannot authenticate" );
+    $self->log(LOGWARN, "fail: cannot authenticate");
 
-    return ( DECLINED, "$user is not free to abuse my relay" );
+    return (DECLINED, "$user is not free to abuse my relay");
 }
 

plugins/badmailfrom

@@ -59,11 +59,11 @@ anywhere in the string.
 =cut
 
 sub register {
-    my ($self,$qp) = (shift, shift);
+    my ($self, $qp) = (shift, shift);
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
 
-    $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
+    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
-};
+}
 
 sub hook_mail {
     my ($self, $transaction, $sender, %param) = @_;
@@ -71,22 +71,22 @@ sub hook_mail {
     return DECLINED if $self->is_immune();
 
     my @badmailfrom = $self->qp->config('badmailfrom');
-    if ( defined $self->{_badmailfrom_config} ) {       # testing
+    if (defined $self->{_badmailfrom_config}) {    # testing
         @badmailfrom = @{$self->{_badmailfrom_config}};
-    };
+    }
-    return DECLINED if $self->is_immune_sender( $sender, \@badmailfrom );
+    return DECLINED if $self->is_immune_sender($sender, \@badmailfrom);
 
     my $host = lc $sender->host;
     my $from = lc($sender->user) . '@' . $host;
 
     for my $config (@badmailfrom) {
-        $config =~ s/^\s+//g;   # trim leading whitespace
+        $config =~ s/^\s+//g;                      # trim leading whitespace
         my ($bad, $reason) = split /\s+/, $config, 2;
         next unless $bad;
-        next unless $self->is_match( $from, $bad, $host );
+        next unless $self->is_match($from, $bad, $host);
         $reason ||= "Your envelope sender is in my badmailfrom list";
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
-        return $self->get_reject( $reason );
+        return $self->get_reject($reason);
     }
 
     $self->log(LOGINFO, "pass");
@@ -94,46 +94,46 @@ sub hook_mail {
 }
 
 sub is_match {
-    my ( $self, $from, $bad, $host ) = @_;
+    my ($self, $from, $bad, $host) = @_;
 
-    if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) {  # it's a regexp
+    if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) {    # it's a regexp
-        if ( $from =~ /$bad/ ) {
+        if ($from =~ /$bad/) {
             $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $from");
             return 1;
-        };
+        }
         return;
-    };
+    }
 
     $bad = lc $bad;
-    if ( $bad !~ m/\@/ ) {
+    if ($bad !~ m/\@/) {
         $self->log(LOGWARN, "badmailfrom: bad config: no \@ sign in $bad");
         return;
-    };
+    }
-    if ( substr($bad,0,1) eq '@' ) {
+    if (substr($bad, 0, 1) eq '@') {
         return 1 if $bad eq "\@$host";
         return;
-    };
+    }
     return if $bad ne $from;
     return 1;
-};
+}
 
 sub is_immune_sender {
-    my ($self, $sender, $badmf ) = @_;
+    my ($self, $sender, $badmf) = @_;
 
-    if ( ! scalar @$badmf ) {
+    if (!scalar @$badmf) {
         $self->log(LOGDEBUG, 'skip, empty list');
         return 1;
-    };
+    }
 
-    if ( ! $sender || $sender->format eq '<>' ) {
+    if (!$sender || $sender->format eq '<>') {
         $self->log(LOGDEBUG, 'skip, null sender');
         return 1;
-    };
+    }
 
-    if ( ! $sender->host || ! $sender->user ) {
+    if (!$sender->host || !$sender->user) {
         $self->log(LOGDEBUG, 'skip, missing user or host');
         return 1;
-    };
+    }
 
     return;
-};
+}

plugins/badmailfromto

@@ -21,27 +21,27 @@ use strict;
 use Qpsmtpd::Constants;
 
 sub hook_mail {
-  my ($self, $transaction, $sender, %param) = @_;
+    my ($self, $transaction, $sender, %param) = @_;
 
     my @badmailfromto = $self->qp->config("badmailfromto");
-    return DECLINED if $self->is_sender_immune( $sender, \@badmailfromto );
+    return DECLINED if $self->is_sender_immune($sender, \@badmailfromto);
 
-  my $host = lc $sender->host;
+    my $host = lc $sender->host;
-  my $from = lc($sender->user) . '@' . $host;
+    my $from = lc($sender->user) . '@' . $host;
 
-  for my $bad (@badmailfromto) {
+    for my $bad (@badmailfromto) {
-    $bad =~ s/^\s*(\S+).*/$1/;
+        $bad =~ s/^\s*(\S+).*/$1/;
-    next unless $bad;
+        next unless $bad;
-    $bad = lc $bad;
+        $bad = lc $bad;
-    if ( $bad !~ m/\@/ ) {
+        if ($bad !~ m/\@/) {
-        $self->log(LOGWARN, 'bad config, no @ sign in '. $bad);
+            $self->log(LOGWARN, 'bad config, no @ sign in ' . $bad);
-        next;
+            next;
-    };
+        }
-    if ( $bad eq $from || (substr($bad,0,1) eq '@' && $bad eq "\@$host") ) {
+        if ($bad eq $from || (substr($bad, 0, 1) eq '@' && $bad eq "\@$host")) {
-        $transaction->notes('badmailfromto', $bad);
+            $transaction->notes('badmailfromto', $bad);
-    };
+        }
-  }
+    }
-  return (DECLINED);
+    return (DECLINED);
 }
 
 sub hook_rcpt {
@@ -52,32 +52,32 @@ sub hook_rcpt {
         return (DECLINED);
     };
 
-    foreach ( $self->qp->config("badmailfromto") ) {
+    foreach ($self->qp->config("badmailfromto")) {
         my ($from, $to) = m/^\s*(\S+)\t(\S+).*/;
         return (DENY, "mail to $recipient not accepted here")
-            if lc($from) eq $sender && lc($to) eq $recipient;
+          if lc($from) eq $sender && lc($to) eq $recipient;
     }
     $self->log(LOGDEBUG, "pass, recipient not listed");
     return (DECLINED);
 }
 
 sub is_sender_immune {
-    my ($self, $sender, $badmf ) = @_;
+    my ($self, $sender, $badmf) = @_;
 
-    if ( ! scalar @$badmf ) {
+    if (!scalar @$badmf) {
         $self->log(LOGDEBUG, 'skip, empty list');
         return 1;
-    };
+    }
 
-    if ( ! $sender || $sender->format eq '<>' ) {
+    if (!$sender || $sender->format eq '<>') {
         $self->log(LOGDEBUG, 'skip, null sender');
         return 1;
-    };
+    }
 
-    if ( ! $sender->host || ! $sender->user ) {
+    if (!$sender->host || !$sender->user) {
         $self->log(LOGDEBUG, 'skip, missing user or host');
         return 1;
-    };
+    }
 
     return;
-};
+}

plugins/badrcptto

@@ -51,8 +51,8 @@ sub hook_rcpt {
 
     return (DECLINED) if $self->is_immune();
 
-    my ($host, $to) = $self->get_host_and_to( $recipient )
+    my ($host, $to) = $self->get_host_and_to($recipient)
-        or return (DECLINED);
+      or return (DECLINED);
 
     my @badrcptto = $self->qp->config("badrcptto") or do {
         $self->log(LOGINFO, "skip, empty config");
@@ -60,71 +60,72 @@ sub hook_rcpt {
     };
 
     for my $line (@badrcptto) {
-        $line =~ s/^\s+//g; # trim leading whitespace
+        $line =~ s/^\s+//g;    # trim leading whitespace
         my ($bad, $reason) = split /\s+/, $line, 2;
-        next if ! $bad;
+        next if !$bad;
-        if ( $self->is_match( $to, lc($bad), $host ) ) {
+        if ($self->is_match($to, lc($bad), $host)) {
-            $self->adjust_karma( -2 );
+            $self->adjust_karma(-2);
-            if ( $reason ) {
+            if ($reason) {
                 return (DENY, "mail to $bad not accepted here");
             }
             else {
-                return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here");
+                return Qpsmtpd::DSN->no_such_user(
+                                              "mail to $bad not accepted here");
             }
-        };
+        }
     }
     $self->log(LOGINFO, 'pass');
     return (DECLINED);
 }
 
 sub is_match {
-    my ( $self, $to, $bad, $host ) = @_;
+    my ($self, $to, $bad, $host) = @_;
 
-    if ( $bad =~ /[\/\^\$\*\+\!\%\?\\]/ ) {  # it's a regexp
+    if ($bad =~ /[\/\^\$\*\+\!\%\?\\]/) {    # it's a regexp
         $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to");
-        if ( $to =~ /$bad/i ) {
+        if ($to =~ /$bad/i) {
             $self->log(LOGINFO, 'fail: pattern match');
             return 1;
-        };
+        }
         return;
-    };
+    }
 
-    if ( $bad !~ m/\@/ ) {
+    if ($bad !~ m/\@/) {
         $self->log(LOGERROR, "badrcptto: bad config: no \@ sign in $bad");
         return;
-    };
+    }
 
     $bad = lc $bad;
     $to  = lc $to;
 
-    if ( substr($bad,0,1) eq '@' ) {
+    if (substr($bad, 0, 1) eq '@') {
-        if ( $bad eq "\@$host" ) {
+        if ($bad eq "\@$host") {
             $self->log(LOGINFO, 'fail: host match');
             return 1;
-        };
+        }
         return;
-    };
+    }
 
-    if ( $bad eq $to ) {
+    if ($bad eq $to) {
         $self->log(LOGINFO, 'fail: rcpt match');
         return 1;
     }
     return;
-};
+}
 
 sub get_host_and_to {
-    my ( $self, $recipient ) = @_;
+    my ($self, $recipient) = @_;
 
-    if ( ! $recipient ) {
+    if (!$recipient) {
         $self->log(LOGERROR, 'skip: no recipient!');
         return;
-    };
+    }
 
-    if ( ! $recipient->host || ! $recipient->user ) {
+    if (!$recipient->host || !$recipient->user) {
         $self->log(LOGINFO, 'skip: missing host or user');
         return;
-    };
+    }
 
     my $host = lc $recipient->host;
-    return ( $host, lc($recipient->user) . '@' . $host );
+    return ($host, lc($recipient->user) . '@' . $host);
-};
+}

plugins/bogus_bounce

@@ -40,23 +40,22 @@ Deny with a soft error code.
 
 =cut
 
-
 sub register {
     my ($self, $qp) = (shift, shift);
 
-    if ( @_ % 2 ) {
+    if (@_ % 2) {
         $self->{_args}{action} = shift;
     }
     else {
-        $self->{_args} = { @_ };
+        $self->{_args} = {@_};
-    };
+    }
 
-    if ( ! defined $self->{_args}{reject} ) {
+    if (!defined $self->{_args}{reject}) {
-        $self->{_args}{reject} = 0;     # legacy default
+        $self->{_args}{reject} = 0;    # legacy default
-    };
+    }
 
     # we only need to check for deferral, default is DENY
-    if ( $self->{_args}{action} && $self->{_args}{action} =~ /soft/i ) {
+    if ($self->{_args}{action} && $self->{_args}{action} =~ /soft/i) {
         $self->{_args}{reject_type} = 'temp';
     }
 }
@@ -68,10 +67,10 @@ sub hook_data_post {
     # Find the sender, quit processing if this isn't a bounce.
     #
     my $sender = $transaction->sender->address || undef;
-    if ( $sender && $sender ne '<>') {
+    if ($sender && $sender ne '<>') {
         $self->log(LOGINFO, "pass, not a null sender");
         return DECLINED;
-    };
+    }
 
     #  at this point we know it is a bounce, via the null-envelope.
     #
@@ -80,16 +79,19 @@ sub hook_data_post {
     my @to = $transaction->recipients || ();
     if (scalar @to != 1) {
         $self->log(LOGINFO, "fail, bogus bounce to: " . join(',', @to));
-        return $self->get_reject( "fail, this bounce message does not have 1 recipient" );
+        return $self->get_reject(
-    };
+                         "fail, this bounce message does not have 1 recipient");
+    }
 
     # validate that Return-Path is empty, RFC 3834
 
     my $rp = $transaction->header->get('Return-Path');
-    if ( $rp && $rp ne '<>' ) {
+    if ($rp && $rp ne '<>') {
-        $self->log(LOGINFO, "fail, bounce messages must not have a Return-Path");
+        $self->log(LOGINFO,
-        return $self->get_reject( "a bounce return path must be empty (RFC 3834)" );
+                   "fail, bounce messages must not have a Return-Path");
-    };
+        return $self->get_reject(
+                               "a bounce return path must be empty (RFC 3834)");
+    }
 
     $self->log(LOGINFO, "pass, single recipient, empty Return-Path");
     return DECLINED;

plugins/connection_time

@@ -32,44 +32,47 @@ use Time::HiRes qw(gettimeofday tv_interval);
 
 sub register {
     my ($self, $qp) = (shift, shift);
-    if ( @_ == 1 ) {              # backwards compatible
+    if (@_ == 1) {    # backwards compatible
         $self->{_args}{loglevel} = shift;
-        if ( $self->{_args}{loglevel} =~ /\D/ ) {
+        if ($self->{_args}{loglevel} =~ /\D/) {
-            $self->{_args}{loglevel} = Qpsmtpd::Constants::log_level($self->{_args}{loglevel});
+            $self->{_args}{loglevel} =
-        };
+              Qpsmtpd::Constants::log_level($self->{_args}{loglevel});
+        }
         $self->{_args}{loglevel} ||= 6;
     }
-    elsif ( @_ % 2 ) {
+    elsif (@_ % 2) {
-       $self->log(LOGERROR, "invalid arguments");
+        $self->log(LOGERROR, "invalid arguments");
     }
     else {
-        $self->{_args} = { @_ };     # named args, inherits loglevel
+        $self->{_args} = {@_};    # named args, inherits loglevel
-    };
+    }
-# pre-connection is not available in the tcpserver deployment model.
+
-# duplicate the handler, so it works both ways with no redudant methods
+    # pre-connection is not available in the tcpserver deployment model.
+    # duplicate the handler, so it works both ways with no redudant methods
     $self->register_hook('pre-connection', 'connect_handler');
     $self->register_hook('connect',        'connect_handler');
 }
 
 sub connect_handler {
     my $self = shift;
-    return DECLINED if ( $self->hook_name eq 'connect' && defined $self->{_connection_start} );
+    return DECLINED
+      if ($self->hook_name eq 'connect' && defined $self->{_connection_start});
     $self->{_connection_start} = [gettimeofday];
-    $self->log(LOGDEBUG, "started at " . scalar gettimeofday );
+    $self->log(LOGDEBUG, "started at " . scalar gettimeofday);
     return (DECLINED);
 }
 
 sub hook_post_connection {
     my $self = shift;
 
-    if ( ! $self->{_connection_start} ) {
+    if (!$self->{_connection_start}) {
         $self->log(LOGERROR, "Start time not set?!");
         return (DECLINED);
-    };
+    }
 
-    my $elapsed = tv_interval( $self->{_connection_start}, [gettimeofday] );
+    my $elapsed = tv_interval($self->{_connection_start}, [gettimeofday]);
 
-    $self->log(LOGINFO, sprintf "%.3f s.", $elapsed );
+    $self->log(LOGINFO, sprintf "%.3f s.", $elapsed);
     return (DECLINED);
 }
 

plugins/content_log

@@ -6,20 +6,20 @@
 use POSIX qw:strftime:;
 
 sub hook_data_post {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  # as a decent default, log on a per-day-basis
+    # as a decent default, log on a per-day-basis
-  my $date = strftime("%Y%m%d",localtime(time));
+    my $date = strftime("%Y%m%d", localtime(time));
-  open(my $out,">>mail/$date")
+    open(my $out, ">>mail/$date")
-    or return(DECLINED,"Could not open log file.. continuing anyway");
+      or return (DECLINED, "Could not open log file.. continuing anyway");
 
-  $transaction->header->print($out);
+    $transaction->header->print($out);
-  $transaction->body_resetpos;
+    $transaction->body_resetpos;
-  while (my $line = $transaction->body_getline) {
+    while (my $line = $transaction->body_getline) {
-    print $out $line;
+        print $out $line;
-  }
+    }
 
-  close $out;
+    close $out;
 
-  return (DECLINED, "successfully saved message.. continuing");
+    return (DECLINED, "successfully saved message.. continuing");
 }

plugins/count_unrecognized_commands

@@ -22,28 +22,30 @@ use warnings;
 use Qpsmtpd::Constants;
 
 sub register {
-    my ($self, $qp ) = (shift, shift);
+    my ($self, $qp) = (shift, shift);
 
     $self->{_unrec_cmd_max} = shift || 4;
 
-    if ( scalar @_ ) {
+    if (scalar @_) {
         $self->log(LOGWARN, "Ignoring additional arguments.");
     }
 }
 
 sub hook_unrecognized_command {
-  my ($self, $cmd) = @_[0,2];
+    my ($self, $cmd) = @_[0, 2];
 
     my $count = $self->connection->notes('unrec_cmd_count') || 0;
-       $count = $count + 1;
+    $count = $count + 1;
-                $self->connection->notes('unrec_cmd_count', $count);
+    $self->connection->notes('unrec_cmd_count', $count);
 
-    if ( $count < $self->{_unrec_cmd_max} ) {
+    if ($count < $self->{_unrec_cmd_max}) {
         $self->log(LOGINFO, "'$cmd', ($count)");
         return DECLINED;
-    };
+    }
 
     $self->log(LOGINFO, "fail, '$cmd' ($count)");
-    return (DENY_DISCONNECT, "Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?" );
+    return (DENY_DISCONNECT,
+"Closing connection, $count unrecognized commands. Perhaps you should read RFC 2821?"
+    );
 }
 

plugins/dkim

@@ -172,8 +172,8 @@ use Socket qw(:DEFAULT :crlf);
 
 sub init {
     my ($self, $qp) = (shift, shift);
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
-    $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
+    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
     $self->{_args}{reject_type} ||= 'perm';
 }
 
@@ -181,52 +181,55 @@ sub register {
     my $self = shift;
 
     #  Mail::DKIM::TextWrap - nice idea, clients get mangled headers though
-    foreach my $mod ( qw/ Mail::DKIM::Verifier Mail::DKIM::Signer / ) {
+    foreach my $mod (qw/ Mail::DKIM::Verifier Mail::DKIM::Signer /) {
         eval "use $mod";
-        if ( $@ ) {
+        if ($@) {
             warn "error, plugin disabled, could not load $mod\n";
-            $self->log(LOGERROR, "skip, plugin disabled, is Mail::DKIM installed?");
+            $self->log(LOGERROR,
+                       "skip, plugin disabled, is Mail::DKIM installed?");
             return;
-        };
+        }
-    };
+    }
 
     $self->register_hook('data_post', 'data_post_handler');
-};
+}
 
 sub data_post_handler {
     my ($self, $transaction) = @_;
 
-    if ( $self->qp->connection->relay_client() ) {
+    if ($self->qp->connection->relay_client()) {
+
         # this is an authenticated user sending a message.
-        return $self->sign_it( $transaction );
+        return $self->sign_it($transaction);
-    };
+    }
 
     return DECLINED if $self->is_immune();
 
-    return $self->validate_it( $transaction );
+    return $self->validate_it($transaction);
-};
+}
 
 sub validate_it {
     my ($self, $transaction) = @_;
 
     # Incoming message, perform DKIM validation
     my $dkim = Mail::DKIM::Verifier->new() or do {
-        $self->log(LOGERROR, "error, could not instantiate a new Mail::DKIM::Verifier");
+        $self->log(LOGERROR,
+                   "error, could not instantiate a new Mail::DKIM::Verifier");
         return DECLINED;
     };
 
-    $self->send_message_to_dkim( $dkim, $transaction );
+    $self->send_message_to_dkim($dkim, $transaction);
     my $result = $dkim->result;
-    my $mess   = $self->get_details( $dkim );
+    my $mess   = $self->get_details($dkim);
 
-    foreach my $t ( qw/ pass fail invalid temperror none / ) {
+    foreach my $t (qw/ pass fail invalid temperror none /) {
         next if $t ne $result;
         my $handler = 'handle_sig_' . $t;
         $self->log(LOGDEBUG, "dispatching $result to $handler");
-        return $self->$handler( $dkim, $mess );
+        return $self->$handler($dkim, $mess);
-    };
+    }
 
-    $self->log( LOGERROR, "error, unknown result: $result, $mess" );
+    $self->log(LOGERROR, "error, unknown result: $result, $mess");
     return DECLINED;
 }
 
@@ -237,277 +240,276 @@ sub sign_it {
     my $selector = $self->get_selector($keydir);
 
     my $dkim = Mail::DKIM::Signer->new(
-            Algorithm => "rsa-sha256",
+                                       Algorithm => "rsa-sha256",
-            Method    => "relaxed",
+                                       Method    => "relaxed",
-            Domain    => $domain,
+                                       Domain    => $domain,
-            Selector  => $selector,
+                                       Selector  => $selector,
-            KeyFile   => "$keydir/private",
+                                       KeyFile   => "$keydir/private",
-            );
+                                      );
 
-    $self->send_message_to_dkim( $dkim, $transaction );
+    $self->send_message_to_dkim($dkim, $transaction);
 
-    my $signature = $dkim->signature;  # what is the signature result?
+    my $signature = $dkim->signature;    # what is the signature result?
-    $self->qp->transaction->header->add(
+    $self->qp->transaction->header->add('DKIM-Signature',
-        'DKIM-Signature', $signature->as_string, 0 );
+                                        $signature->as_string, 0);
 
-    $self->log(LOGINFO, "pass, we signed the message" );
+    $self->log(LOGINFO, "pass, we signed the message");
     return DECLINED;
-};
+}
 
 sub get_details {
-    my ($self, $dkim ) = @_;
+    my ($self, $dkim) = @_;
 
     my @data;
     my $string;
-    push @data, "domain: "   . $dkim->signature->domain   if $dkim->signature;
+    push @data, "domain: " . $dkim->signature->domain     if $dkim->signature;
     push @data, "selector: " . $dkim->signature->selector if $dkim->signature;
-    push @data, "result: "   . $dkim->result_detail       if $dkim->result_detail;
+    push @data, "result: " . $dkim->result_detail if $dkim->result_detail;
 
-    foreach my $policy ( $dkim->policies ) {
+    foreach my $policy ($dkim->policies) {
-        next if ! $policy;
+        next if !$policy;
         push @data, "policy: " . $policy->as_string;
-        push @data, "name: "   . $policy->name;
+        push @data, "name: " . $policy->name;
-        push @data, "policy_location: " . $policy->location if $policy->location;
+        push @data, "policy_location: " . $policy->location
+          if $policy->location;
 
         my $policy_result;
         $policy_result = $policy->apply($dkim);
         $policy_result or next;
         push @data, "policy_result: " . $policy_result if $policy_result;
-    };
+    }
 
     return join(', ', @data);
-};
+}
 
 sub handle_sig_fail {
-    my ( $self, $dkim, $mess ) = @_;
+    my ($self, $dkim, $mess) = @_;
 
-    $self->adjust_karma( -1 );
+    $self->adjust_karma(-1);
-    return $self->get_reject( "DKIM signature invalid: " . $dkim->result_detail, $mess );
+    return
-};
+      $self->get_reject("DKIM signature invalid: " . $dkim->result_detail,
+                        $mess);
+}
 
 sub handle_sig_temperror {
-    my ( $self, $dkim, $mess ) = @_;
+    my ($self, $dkim, $mess) = @_;
 
-    $self->log(LOGINFO, "error, $mess" );
+    $self->log(LOGINFO, "error, $mess");
-    return ( DENYSOFT, "Please try again later - $dkim->result_detail" );
+    return (DENYSOFT, "Please try again later - $dkim->result_detail");
-};
+}
 
 sub handle_sig_invalid {
-    my ( $self, $dkim, $mess ) = @_;
+    my ($self, $dkim, $mess) = @_;
 
-    my ( $prs, $policies) = $self->get_policy_results( $dkim );
+    my ($prs, $policies) = $self->get_policy_results($dkim);
 
-    foreach my $policy ( @$policies ) {
+    foreach my $policy (@$policies) {
-        if ( $policy->signall && ! $policy->is_implied_default_policy ) {
+        if ($policy->signall && !$policy->is_implied_default_policy) {
-            $self->log(LOGINFO, $mess );
+            $self->log(LOGINFO, $mess);
-            return $self->get_reject(
+            return
-                "invalid DKIM signature with sign-all policy",
+              $self->get_reject("invalid DKIM signature with sign-all policy",
-                "invalid signature, sign-all policy"
+                                "invalid signature, sign-all policy");
-            );
         }
-    };
+    }
 
-    $self->adjust_karma( -1 );
+    $self->adjust_karma(-1);
-    $self->log(LOGINFO, $mess );
+    $self->log(LOGINFO, $mess);
 
-    if ( $prs->{accept} ) {
+    if ($prs->{accept}) {
-        $self->add_header( $mess );
+        $self->add_header($mess);
-        $self->log( LOGERROR, "error, invalid signature but accept policy!?" );
+        $self->log(LOGERROR, "error, invalid signature but accept policy!?");
         return DECLINED;
     }
-    elsif ( $prs->{neutral} ) {
+    elsif ($prs->{neutral}) {
-        $self->add_header( $mess );
+        $self->add_header($mess);
-        $self->log( LOGERROR, "error, invalid signature but neutral policy?!" );
+        $self->log(LOGERROR, "error, invalid signature but neutral policy?!");
         return DECLINED;
     }
-    elsif ( $prs->{reject} ) {
+    elsif ($prs->{reject}) {
-        return $self->get_reject(
+        return
-                "invalid DKIM signature: " . $dkim->result_detail,
+          $self->get_reject("invalid DKIM signature: " . $dkim->result_detail,
-                "fail, invalid signature, reject policy"
+                            "fail, invalid signature, reject policy");
-            );
     }
 
     # this should never happen
-    $self->log( LOGINFO, "error, invalid signature, unhandled" );
+    $self->log(LOGINFO, "error, invalid signature, unhandled");
-    $self->add_header( $mess );
+    $self->add_header($mess);
     return DECLINED;
-};
+}
 
 sub handle_sig_pass {
-    my ( $self, $dkim, $mess ) = @_;
+    my ($self, $dkim, $mess) = @_;
 
-    $self->save_signatures_to_note( $dkim );
+    $self->save_signatures_to_note($dkim);
 
-    my ($prs) = $self->get_policy_results( $dkim );
+    my ($prs) = $self->get_policy_results($dkim);
 
-    if ( $prs->{accept} ) {
+    if ($prs->{accept}) {
-        $self->add_header( $mess );
+        $self->add_header($mess);
         $self->log(LOGINFO, "pass, valid signature, accept policy");
-        $self->adjust_karma( 1 );
+        $self->adjust_karma(1);
         return DECLINED;
     }
-    elsif ( $prs->{neutral} ) {
+    elsif ($prs->{neutral}) {
-        $self->add_header( $mess );
+        $self->add_header($mess);
         $self->log(LOGINFO, "pass, valid signature, neutral policy");
-        $self->log(LOGINFO, $mess );
+        $self->log(LOGINFO, $mess);
         return DECLINED;
     }
-    elsif ( $prs->{reject} ) {
+    elsif ($prs->{reject}) {
-        $self->log(LOGINFO, $mess );
+        $self->log(LOGINFO, $mess);
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
-        return $self->get_reject(
+        return
-                "DKIM signature valid but fails policy, $mess",
+          $self->get_reject("DKIM signature valid but fails policy, $mess",
-                "fail, valid sig, reject policy"
+                            "fail, valid sig, reject policy");
-            );
+    }
-    };
 
     # this should never happen
-    $self->add_header( $mess );
+    $self->add_header($mess);
-    $self->log(LOGERROR, "pass, valid sig, no policy results" );
+    $self->log(LOGERROR, "pass, valid sig, no policy results");
-    $self->log(LOGINFO, $mess );
+    $self->log(LOGINFO,  $mess);
     return DECLINED;
-};
+}
 
 sub handle_sig_none {
-    my ( $self, $dkim, $mess ) = @_;
+    my ($self, $dkim, $mess) = @_;
 
-    my ( $prs, $policies) = $self->get_policy_results( $dkim );
+    my ($prs, $policies) = $self->get_policy_results($dkim);
 
-    foreach my $policy ( @$policies ) {
+    foreach my $policy (@$policies) {
-        if ( $policy->signall && ! $policy->is_implied_default_policy ) {
+        if ($policy->signall && !$policy->is_implied_default_policy) {
-            $self->log(LOGINFO, $mess );
+            $self->log(LOGINFO, $mess);
-            return $self->get_reject(
+            return
-                "no DKIM signature with sign-all policy",
+              $self->get_reject("no DKIM signature with sign-all policy",
-                "no signature, sign-all policy"
+                                "no signature, sign-all policy");
-            );
         }
-    };
+    }
 
-    if ( $prs->{accept} ) {
+    if ($prs->{accept}) {
-        $self->log( LOGINFO, "pass, no signature, accept policy" );
+        $self->log(LOGINFO, "pass, no signature, accept policy");
         return DECLINED;
     }
-    elsif ( $prs->{neutral} ) {
+    elsif ($prs->{neutral}) {
-        $self->log( LOGINFO, "pass, no signature, neutral policy" );
+        $self->log(LOGINFO, "pass, no signature, neutral policy");
         return DECLINED;
     }
-    elsif ( $prs->{reject} ) {
+    elsif ($prs->{reject}) {
-        $self->log(LOGINFO, $mess );
+        $self->log(LOGINFO, $mess);
         $self->get_reject(
-            "no DKIM signature, policy says reject: " . $dkim->result_detail,
+               "no DKIM signature, policy says reject: " . $dkim->result_detail,
-            "no signature, reject policy"
+               "no signature, reject policy");
-        );
+    }
-    };
 
     # should never happen
-    $self->log( LOGINFO, "error, no signature, no policy" );
+    $self->log(LOGINFO, "error, no signature, no policy");
-    $self->log(LOGINFO, $mess );
+    $self->log(LOGINFO, $mess);
     return DECLINED;
-};
+}
 
 sub get_keydir {
     my ($self, $transaction) = @_;
 
     my $domain = $transaction->sender->host;
-    my $dir = "config/dkim/$domain";
+    my $dir    = "config/dkim/$domain";
 
-    if ( ! -e $dir ) {                      # the dkim key dir doesn't exist
+    if (!-e $dir) {    # the dkim key dir doesn't exist
-        my @labels = split /\./, $domain;   # split the domain into labels
+        my @labels = split /\./, $domain;    # split the domain into labels
-        while ( @labels > 1 ) {
+        while (@labels > 1) {
-            shift @labels;                  # remove the first label (ie: www)
+            shift @labels;                   # remove the first label (ie: www)
-            my $zone = join '.', @labels;   # reassemble the labels
+            my $zone = join '.', @labels;    # reassemble the labels
-            if ( -e "config/dkim/$zone" ) { # if the directory exists
+            if (-e "config/dkim/$zone") {    # if the directory exists
-                $dir = "config/dkim/$zone"; # use the parent domain's key
+                $dir = "config/dkim/$zone";    # use the parent domain's key
                 $self->log(LOGINFO, "info, using $zone key for $domain");
-            };
+            }
-        };
+        }
-    };
+    }
 
-    if ( -l $dir ) {
+    if (-l $dir) {
         $dir = readlink($dir);
-        $dir = "config/dkim/$dir" if $dir !~ /\//;  # no /, relative path
+        $dir = "config/dkim/$dir" if $dir !~ /\//;    # no /, relative path
         ($domain) = (split /\//, $dir)[-1];
-    };
+    }
 
-    if ( ! -d $dir ) {
+    if (!-d $dir) {
         $self->log(LOGINFO, "skip, DKIM not configured for $domain");
         return;
-    };
+    }
-    if ( ! -r $dir ) {
+    if (!-r $dir) {
         $self->log(LOGINFO, "error, unable to read key from $dir");
         return;
-    };
+    }
-    if ( ! -r "$dir/private" ) {
+    if (!-r "$dir/private") {
         $self->log(LOGINFO, "error, unable to read dkim key from $dir/private");
         return;
-    };
+    }
     return ($domain, $dir);
-};
+}
 
 sub save_signatures_to_note {
-    my ( $self, $dkim ) = @_;
+    my ($self, $dkim) = @_;
 
-    foreach my $sig ( $dkim->signatures ) {
+    foreach my $sig ($dkim->signatures) {
         next if $sig->result ne 'pass';
         my $doms = $self->connection->notes('dkim_pass_domains') || [];
         push @$doms, $sig->domain;
         $self->connection->notes('dkim_pass_domains', $doms);
-        $self->log(LOGINFO, "info, added " . $sig->domain );
+        $self->log(LOGINFO, "info, added " . $sig->domain);
-    };
+    }
-};
+}
 
 sub send_message_to_dkim {
     my ($self, $dkim, $transaction) = @_;
 
-    foreach ( split ( /\n/s, $transaction->header->as_string ) ) {
+    foreach (split(/\n/s, $transaction->header->as_string)) {
         $_ =~ s/\r?$//s;
-        eval { $dkim->PRINT ( $_ . CRLF ); };
+        eval { $dkim->PRINT($_ . CRLF); };
-        $self->log(LOGERROR, $@ ) if $@;
+        $self->log(LOGERROR, $@) if $@;
     }
 
     $transaction->body_resetpos;
     while (my $line = $transaction->body_getline) {
         chomp $line;
         $line =~ s/\015$//;
-        eval { $dkim->PRINT($line . CRLF ); };
+        eval { $dkim->PRINT($line . CRLF); };
-        $self->log(LOGERROR, $@ ) if $@;
+        $self->log(LOGERROR, $@) if $@;
-    };
+    }
 
     $dkim->CLOSE;
-};
+}
 
 sub get_policies {
     my ($self, $dkim) = @_;
 
     my @policies;
     eval { @policies = $dkim->policies };
-    $self->log(LOGERROR, $@ ) if $@;
+    $self->log(LOGERROR, $@) if $@;
     return @policies;
-};
+}
 
 sub get_policy_results {
-    my ( $self, $dkim ) = @_;
+    my ($self, $dkim) = @_;
 
     my %prs;
-    my @policies = $self->get_policies( $dkim );
+    my @policies = $self->get_policies($dkim);
 
-    foreach my $policy ( @policies ) {
+    foreach my $policy (@policies) {
         my $policy_result;
         eval { $policy_result = $policy->apply($dkim); }; # accept, reject, neutral
-        if ( $@ ) {
+        if ($@) {
-            $self->log(LOGERROR, $@ );
+            $self->log(LOGERROR, $@);
-        };
+        }
         $prs{$policy_result}++ if $policy_result;
-    };
+    }
 
     return \%prs, \@policies;
-};
+}
 
 sub get_selector {
     my ($self, $keydir) = @_;
 
     open my $SFH, '<', "$keydir/selector" or do {
-        $self->log(LOGINFO, "error, unable to read selector from $keydir/selector");
+        $self->log(LOGINFO,
+                   "error, unable to read selector from $keydir/selector");
         return DECLINED;
     };
     my $selector = <$SFH>;
@@ -515,13 +517,13 @@ sub get_selector {
     close $SFH;
     $self->log(LOGINFO, "info, selector: $selector");
     return $selector;
-};
+}
 
 sub add_header {
     my $self = shift;
     my $header = shift or return;
 
-# consider adding Authentication-Results header, (RFC 5451)
+    # consider adding Authentication-Results header, (RFC 5451)
-    $self->qp->transaction->header->add( 'X-DKIM-Authentication', $header, 0 );
+    $self->qp->transaction->header->add('X-DKIM-Authentication', $header, 0);
 }
 

plugins/dmarc

@@ -104,261 +104,267 @@ use Qpsmtpd::Constants;
 
 sub init {
     my ($self, $qp) = (shift, shift);
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
-    $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
+    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
     $self->{_args}{reject_type} ||= 'perm';
-    $self->{_args}{p_vals} = { map { $_ => 1 } qw/ none reject quarantine / };
+    $self->{_args}{p_vals} = {map { $_ => 1 } qw/ none reject quarantine /};
 }
 
 sub register {
     my $self = shift;
 
     $self->register_hook('data_post', 'data_post_handler');
-};
+}
 
 sub data_post_handler {
     my ($self, $transaction) = @_;
 
     return DECLINED if $self->is_immune();
 
-# 11.1.  Extract Author Domain
+    # 11.1.  Extract Author Domain
 
 # TODO: check exists_in_dns result, and possibly reject here if domain non-exist
-    my $from_host = $self->get_from_host( $transaction ) or return DECLINED;
+    my $from_host = $self->get_from_host($transaction) or return DECLINED;
-    if ( ! $self->exists_in_dns( $from_host ) ) {
+    if (!$self->exists_in_dns($from_host)) {
-        my $org_host = $self->get_organizational_domain( $from_host );
+        my $org_host = $self->get_organizational_domain($from_host);
-        if ( ! $self->exists_in_dns( $org_host ) ) {
+        if (!$self->exists_in_dns($org_host)) {
-            $self->log( LOGINFO, "fail, domain/org not in DNS" );
+            $self->log(LOGINFO, "fail, domain/org not in DNS");
+
             #return $self->get_reject();
             return DECLINED;
-        };
+        }
-    };
+    }
 
-# 11.2.  Determine Handling Policy
+    # 11.2.  Determine Handling Policy
-    my $policy = $self->discover_policy( $from_host )
+    my $policy = $self->discover_policy($from_host)
-         or return DECLINED;
+      or return DECLINED;
 
-#   3.  Perform DKIM signature verification checks.  A single email may
+    #   3.  Perform DKIM signature verification checks.  A single email may
-#       contain multiple DKIM signatures.  The results of this step are
+    #       contain multiple DKIM signatures.  The results of this step are
-#       passed to the remainder of the algorithm and MUST include the
+    #       passed to the remainder of the algorithm and MUST include the
-#       value of the "d=" tag from all DKIM signatures that successfully
+    #       value of the "d=" tag from all DKIM signatures that successfully
-#       validated.
+    #       validated.
     my $dkim_sigs = $self->connection->notes('dkim_pass_domains') || [];
 
-#   4.  Perform SPF validation checks.  The results of this step are
+    #   4.  Perform SPF validation checks.  The results of this step are
-#       passed to the remainder of the algorithm and MUST include the
+    #       passed to the remainder of the algorithm and MUST include the
-#       domain name from the RFC5321.MailFrom if SPF evaluation returned
+    #       domain name from the RFC5321.MailFrom if SPF evaluation returned
-#       a "pass" result.
+    #       a "pass" result.
     my $spf_dom = $transaction->notes('spf_pass_host');
 
-#   5.  Conduct identifier alignment checks.  With authentication checks
+    #   5.  Conduct identifier alignment checks.  With authentication checks
-#       and policy discovery performed, the Mail Receiver checks if
+    #       and policy discovery performed, the Mail Receiver checks if
-#       Authenticated Identifiers fall into alignment as decribed in
+    #       Authenticated Identifiers fall into alignment as decribed in
-#       Section 4.  If one or more of the Authenticated Identifiers align
+    #       Section 4.  If one or more of the Authenticated Identifiers align
-#       with the RFC5322.From domain, the message is considered to pass
+    #       with the RFC5322.From domain, the message is considered to pass
-#       the DMARC mechanism check.  All other conditions (authentication
+    #       the DMARC mechanism check.  All other conditions (authentication
-#       failures, identifier mismatches) are considered to be DMARC
+    #       failures, identifier mismatches) are considered to be DMARC
-#       mechanism check failures.
+    #       mechanism check failures.
-    foreach ( @$dkim_sigs ) {
+    foreach (@$dkim_sigs) {
-        if ( $_ eq $from_host ) {      # strict alignment
+        if ($_ eq $from_host) {    # strict alignment
             $self->log(LOGINFO, "pass, DKIM alignment");
-            $self->adjust_karma( 2 );  # big karma boost
+            $self->adjust_karma(2);    # big karma boost
             return DECLINED;
-        };
+        }
-    };
+    }
 
-    if ( $spf_dom && $spf_dom eq $from_host ) {
+    if ($spf_dom && $spf_dom eq $from_host) {
-        $self->adjust_karma( 2 );  # big karma boost
+        $self->adjust_karma(2);        # big karma boost
         $self->log(LOGINFO, "pass, SPF alignment");
         return DECLINED;
-    };
+    }
 
-#   6.  Apply policy.  Emails that fail the DMARC mechanism check are
+    #   6.  Apply policy.  Emails that fail the DMARC mechanism check are
-#       disposed of in accordance with the discovered DMARC policy of the
+    #       disposed of in accordance with the discovered DMARC policy of the
-#       Domain Owner.  See Section 6.2 for details.
+    #       Domain Owner.  See Section 6.2 for details.
 
     $self->log(LOGINFO, "skip, NEED RELAXED alignment");
     return DECLINED;
-};
+}
 
 sub discover_policy {
     my ($self, $from_host) = @_;
 
-# 1.  Mail Receivers MUST query the DNS for a DMARC TXT record at the
+    # 1.  Mail Receivers MUST query the DNS for a DMARC TXT record at the
-#     DNS domain matching the one found in the RFC5322.From domain in
+    #     DNS domain matching the one found in the RFC5322.From domain in
-#     the message. A possibly empty set of records is returned.
+    #     the message. A possibly empty set of records is returned.
-    my @matches = $self->fetch_dmarc_record($from_host);  # 2. within
+    my @matches = $self->fetch_dmarc_record($from_host);    # 2. within
-    if ( 0 == scalar @matches ) {
+    if (0 == scalar @matches) {
-#   3.  If the set is now empty, the Mail Receiver MUST query the DNS for
-#       a DMARC TXT record at the DNS domain matching the Organizational
-#       Domain in place of the RFC5322.From domain in the message (if
-#       different).  This record can contain policy to be asserted for
-#       subdomains of the Organizational Domain.
 
-        my $org_dom = $self->get_organizational_domain( $from_host ) or return;
+       #   3.  If the set is now empty, the Mail Receiver MUST query the DNS for
-        if ( $org_dom eq $from_host ) {
+       #       a DMARC TXT record at the DNS domain matching the Organizational
-            $self->log( LOGINFO, "skip, no policy for $from_host (same org)" );
+       #       Domain in place of the RFC5322.From domain in the message (if
+       #       different).  This record can contain policy to be asserted for
+       #       subdomains of the Organizational Domain.
+
+        my $org_dom = $self->get_organizational_domain($from_host) or return;
+        if ($org_dom eq $from_host) {
+            $self->log(LOGINFO, "skip, no policy for $from_host (same org)");
             return;
-        };
+        }
         @matches = $self->fetch_dmarc_record($org_dom);
 
-        if ( 0 == scalar @matches ) {
+        if (0 == scalar @matches) {
-            $self->log( LOGINFO, "skip, no policy for $from_host" );
+            $self->log(LOGINFO, "skip, no policy for $from_host");
             return;
-        };
+        }
-    };
+    }
 
-# 4.  Records that do not include a "v=" tag that identifies the
+    # 4.  Records that do not include a "v=" tag that identifies the
-#     current version of DMARC are discarded.
+    #     current version of DMARC are discarded.
     @matches = grep /v=DMARC1/i, @matches;
-    if ( 0 == scalar @matches ) {
+    if (0 == scalar @matches) {
-        $self->log( LOGINFO, "skip, no valid record for $from_host" );
+        $self->log(LOGINFO, "skip, no valid record for $from_host");
         return;
-    };
+    }
 
-# 5.  If the remaining set contains multiple records, processing
+    # 5.  If the remaining set contains multiple records, processing
-#     terminates and the Mail Receiver takes no action.
+    #     terminates and the Mail Receiver takes no action.
-    if ( @matches > 1 ) {
+    if (@matches > 1) {
-        $self->log( LOGINFO, "skip, too many records" );
+        $self->log(LOGINFO, "skip, too many records");
         return;
-    };
+    }
 
-# 6.  If a retrieved policy record does not contain a valid "p" tag, or
+    # 6.  If a retrieved policy record does not contain a valid "p" tag, or
-#     contains an "sp" tag that is not valid, then:
+    #     contains an "sp" tag that is not valid, then:
-    my %policy = $self->parse_policy( $matches[0] );
+    my %policy = $self->parse_policy($matches[0]);
-    if ( ! $self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy) ) {
+    if (!$self->has_valid_p(\%policy) || $self->has_invalid_sp(\%policy)) {
 
-#   A.  if an "rua" tag is present and contains at least one
+        #   A.  if an "rua" tag is present and contains at least one
-#       syntactically valid reporting URI, the Mail Receiver SHOULD
+        #       syntactically valid reporting URI, the Mail Receiver SHOULD
-#       act as if a record containing a valid "v" tag and "p=none"
+        #       act as if a record containing a valid "v" tag and "p=none"
-#       was retrieved, and continue processing;
+        #       was retrieved, and continue processing;
-#   B.  otherwise, the Mail Receiver SHOULD take no action.
+        #   B.  otherwise, the Mail Receiver SHOULD take no action.
         my $rua = $policy{rua};
-        if ( ! $rua || ! $self->has_valid_reporting_uri($rua) ) {
+        if (!$rua || !$self->has_valid_reporting_uri($rua)) {
-            $self->log( LOGINFO, "skip, no valid reporting rua" );
+            $self->log(LOGINFO, "skip, no valid reporting rua");
             return;
-        };
+        }
         $policy{v} = 'DMARC1';
         $policy{p} = 'none';
-    };
+    }
 
     return \%policy;
-};
+}
 
 sub has_valid_p {
     my ($self, $policy) = @_;
     return 1 if $self->{_args}{p_vals}{$policy};
     return 0;
-};
+}
 
 sub has_invalid_sp {
     my ($self, $policy) = @_;
-    return 0 if ! $self->{_args}{p_vals}{$policy};
+    return 0 if !$self->{_args}{p_vals}{$policy};
     return 1;
-};
+}
 
 sub has_valid_reporting_uri {
     my ($self, $rua) = @_;
     return 1 if 'mailto:' eq lc substr($rua, 0, 7);
     return 0;
-};
+}
 
 sub get_organizational_domain {
     my ($self, $from_host) = @_;
 
-# 1.  Acquire a "public suffix" list, i.e., a list of DNS domain
+    # 1.  Acquire a "public suffix" list, i.e., a list of DNS domain
-#     names reserved for registrations. http://publicsuffix.org/list/
+    #     names reserved for registrations. http://publicsuffix.org/list/
-#         $self->qp->config('public_suffix_list')
+    #         $self->qp->config('public_suffix_list')
 
-# 2.  Break the subject DNS domain name into a set of "n" ordered
+    # 2.  Break the subject DNS domain name into a set of "n" ordered
-#     labels.  Number these labels from right-to-left; e.g. for
+    #     labels.  Number these labels from right-to-left; e.g. for
-#     "example.com", "com" would be label 1 and "example" would be
+    #     "example.com", "com" would be label 1 and "example" would be
-#     label 2.;
+    #     label 2.;
     my @labels = reverse split /\./, $from_host;
 
-# 3.  Search the public suffix list for the name that matches the
+    # 3.  Search the public suffix list for the name that matches the
-#     largest number of labels found in the subject DNS domain.  Let
+    #     largest number of labels found in the subject DNS domain.  Let
-#     that number be "x".
+    #     that number be "x".
     my $greatest = 0;
-    for ( my $i = 0; $i <= scalar @labels; $i++ ) {
+    for (my $i = 0 ; $i <= scalar @labels ; $i++) {
-        next if ! $labels[$i];
+        next if !$labels[$i];
-        my $tld = join '.', reverse( (@labels)[0..$i] );
+        my $tld = join '.', reverse((@labels)[0 .. $i]);
-# $self->log( LOGINFO, "i: $i, $tld" );
+
-#warn "i: $i -  tld: $tld\n";
+        # $self->log( LOGINFO, "i: $i, $tld" );
-        if ( grep /$tld/, $self->qp->config('public_suffix_list') ) {
+        #warn "i: $i -  tld: $tld\n";
+        if (grep /$tld/, $self->qp->config('public_suffix_list')) {
             $greatest = $i + 1;
-        };
+        }
-    };
+    }
 
-    return $from_host if $greatest == scalar @labels;  # same
+    return $from_host if $greatest == scalar @labels;    # same
 
-# 4.  Construct a new DNS domain name using the name that matched
+    # 4.  Construct a new DNS domain name using the name that matched
-#     from the public suffix list and prefixing to it the "x+1"th
+    #     from the public suffix list and prefixing to it the "x+1"th
-#     label from the subject domain. This new name is the
+    #     label from the subject domain. This new name is the
-#     Organizational Domain.
+    #     Organizational Domain.
-    return join '.', reverse( (@labels)[0..$greatest]);
+    return join '.', reverse((@labels)[0 .. $greatest]);
-};
+}
 
 sub exists_in_dns {
     my ($self, $domain) = @_;
     my $res = $self->init_resolver();
-    my $query = $res->send( $domain, 'NS' ) or do {
+    my $query = $res->send($domain, 'NS') or do {
-        if ( $res->errorstring eq 'NXDOMAIN' ) {
+        if ($res->errorstring eq 'NXDOMAIN') {
-            $self->log( LOGDEBUG, "fail, non-existent domain: $domain" );
+            $self->log(LOGDEBUG, "fail, non-existent domain: $domain");
             return;
-        };
+        }
-        $self->log( LOGINFO, "error, looking up NS for $domain: " . $res->errorstring );
+        $self->log(LOGINFO,
+                   "error, looking up NS for $domain: " . $res->errorstring);
         return;
     };
     my @matches;
     for my $rr ($query->answer) {
         next if $rr->type ne 'NS';
         push @matches, $rr->nsdname;
-    };
+    }
-    if ( 0 == scalar @matches ) {
+    if (0 == scalar @matches) {
-        $self->log( LOGDEBUG, "fail, zero NS for $domain" );
+        $self->log(LOGDEBUG, "fail, zero NS for $domain");
-    };
+    }
     return @matches;
-};
+}
 
 sub fetch_dmarc_record {
     my ($self, $zone) = @_;
     my $res = $self->init_resolver();
-    my $query = $res->send( '_dmarc.' . $zone, 'TXT' );
+    my $query = $res->send('_dmarc.' . $zone, 'TXT');
     my @matches;
     for my $rr ($query->answer) {
         next if $rr->type ne 'TXT';
-#   2.  Records that do not start with a "v=" tag that identifies the
+
-#       current version of DMARC are discarded.
+        #   2.  Records that do not start with a "v=" tag that identifies the
-        next if 'v=' ne substr( $rr->txtdata, 0, 2);
+        #       current version of DMARC are discarded.
-        $self->log( LOGINFO, $rr->txtdata );
+        next if 'v=' ne substr($rr->txtdata, 0, 2);
+        $self->log(LOGINFO, $rr->txtdata);
         push @matches, join('', $rr->txtdata);
-    };
+    }
     return @matches;
-};
+}
 
 sub get_from_host {
     my ($self, $transaction) = @_;
 
     my $from = $transaction->header->get('From') or do {
-        $self->log( LOGINFO, "error, unable to retrieve From header!" );
+        $self->log(LOGINFO, "error, unable to retrieve From header!");
         return;
     };
-    my ($from_host) = (split /@/, $from)[-1]; # grab everything after the @
+    my ($from_host) = (split /@/, $from)[-1];    # grab everything after the @
-    ($from_host) = split /\s+/, $from_host;   # remove any trailing cruft
+    ($from_host) = split /\s+/, $from_host;      # remove any trailing cruft
     chomp $from_host;
-    chop $from_host if '>' eq substr($from_host,-1,1);
+    chop $from_host if '>' eq substr($from_host, -1, 1);
-    $self->log( LOGDEBUG, "info, from_host is $from_host" );
+    $self->log(LOGDEBUG, "info, from_host is $from_host");
     return $from_host;
-};
+}
 
 sub parse_policy {
     my ($self, $str) = @_;
-    $str =~ s/\s//g;   # remove all whitespace
+    $str =~ s/\s//g;                             # remove all whitespace
     my %dmarc = map { split /=/, $_ } split /;/, $str;
-#warn Data::Dumper::Dumper(\%dmarc);
+
+    #warn Data::Dumper::Dumper(\%dmarc);
     return %dmarc;
-};
+}
 
 sub verify_external_reporting {
 
@@ -396,4 +402,4 @@ sub verify_external_reporting {
 
 =cut
 
-};
+}

plugins/dns_whitelist_soft

@@ -55,56 +55,58 @@ use warnings;
 use Qpsmtpd::Constants;
 
 sub register {
-    my ( $self, $qp ) = (shift, shift);
+    my ($self, $qp) = (shift, shift);
     $self->log(LOGERROR, "Bad arguments") if @_ % 2;
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
 }
 
 sub hook_connect {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  my $remote_ip = $self->qp->connection->remote_ip;
+    my $remote_ip = $self->qp->connection->remote_ip;
 
-  my %whitelist_zones = map { (split /\s+/, $_, 2)[0,1] }
+    my %whitelist_zones =
-				$self->qp->config('whitelist_zones');
+      map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones');
 
-  return DECLINED unless %whitelist_zones;
+    return DECLINED unless %whitelist_zones;
 
-  my $reversed_ip = join('.', reverse(split(/\./, $remote_ip)));
+    my $reversed_ip = join('.', reverse(split(/\./, $remote_ip)));
 
-  # we queue these lookups in the background and just fetch the
+    # we queue these lookups in the background and just fetch the
-  # results in the first rcpt handler
+    # results in the first rcpt handler
 
-  my $res = new Net::DNS::Resolver;
+    my $res = new Net::DNS::Resolver;
-  my $sel = IO::Select->new();
+    my $sel = IO::Select->new();
 
-  for my $dnsbl (keys %whitelist_zones) {
+    for my $dnsbl (keys %whitelist_zones) {
-    $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl in the background");
+        $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl in the background");
-    $sel->add($res->bgsend("$reversed_ip.$dnsbl", 'TXT'));
+        $sel->add($res->bgsend("$reversed_ip.$dnsbl", 'TXT'));
-  }
+    }
 
-  $self->connection->notes('whitelist_sockets', $sel);
+    $self->connection->notes('whitelist_sockets', $sel);
-  return DECLINED;
+    return DECLINED;
 }
 
 sub process_sockets {
-  my ($self) = @_;
+    my ($self) = @_;
 
-  my $conn = $self->connection;
+    my $conn = $self->connection;
 
-  return $conn->notes('whitelisthost') if $conn->notes('whitelisthost');
+    return $conn->notes('whitelisthost') if $conn->notes('whitelisthost');
 
-  my $res = new Net::DNS::Resolver;
+    my $res = new Net::DNS::Resolver;
-  my $sel = $conn->notes('whitelist_sockets') or return '';
+    my $sel = $conn->notes('whitelist_sockets') or return '';
 
-  $self->log(LOGDEBUG, "waiting for whitelist dns");
+    $self->log(LOGDEBUG, "waiting for whitelist dns");
 
-  # don't wait more than 4 seconds here
+    # don't wait more than 4 seconds here
-  my @ready = $sel->can_read(4);
+    my @ready = $sel->can_read(4);
 
-  $self->log(LOGDEBUG, "done waiting for whitelist dns, got ",
+    $self->log(LOGDEBUG,
-  scalar @ready, " answers ...");
+               "done waiting for whitelist dns, got ",
-  return '' unless @ready;
+               scalar @ready,
+               " answers ...");
+    return '' unless @ready;
 
     my $result;
 
@@ -131,36 +133,38 @@ sub process_sockets {
         }
         else {
             $self->log(LOGERROR, "$whitelist query failed: ", $res->errorstring)
-                if $res->errorstring ne "NXDOMAIN";
+              if $res->errorstring ne "NXDOMAIN";
         }
 
         if ($result) {
+
             # kill any other pending I/O
             $conn->notes('whitelist_sockets', undef);
             return $conn->notes('whitelisthost', $result);
         }
     }
 
-  if ($sel->count) {
+    if ($sel->count) {
-    # loop around if we have dns blacklists left to see results from
-    return $self->process_sockets();
-  }
 
-  # er, the following code doesn't make much sense anymore...
+        # loop around if we have dns blacklists left to see results from
+        return $self->process_sockets();
+    }
 
-  # if there was more to read; then forget it
+    # er, the following code doesn't make much sense anymore...
-  $conn->notes('whitelist_sockets', undef);
 
-  return $conn->notes('whitelisthost', $result);
+    # if there was more to read; then forget it
+    $conn->notes('whitelist_sockets', undef);
+
+    return $conn->notes('whitelisthost', $result);
 }
 
 sub hook_rcpt {
-  my ($self, $transaction, $rcpt, %param) = @_;
+    my ($self, $transaction, $rcpt, %param) = @_;
-  my $ip = $self->qp->connection->remote_ip or return (DECLINED);
+    my $ip = $self->qp->connection->remote_ip or return (DECLINED);
-  my $note = $self->process_sockets;
+    my $note = $self->process_sockets;
-  if ( $note ) {
+    if ($note) {
-    $self->log(LOGNOTICE,"Host $ip is whitelisted: $note");
+        $self->log(LOGNOTICE, "Host $ip is whitelisted: $note");
-  }
+    }
-  return DECLINED;
+    return DECLINED;
 }
 

plugins/dnsbl

@@ -135,20 +135,20 @@ See: https://github.com/smtpd/qpsmtpd/commits/master/plugins/dnsbl
 sub register {
     my ($self, $qp) = (shift, shift);
 
-    if ( @_ % 2 ) {
+    if (@_ % 2) {
-        $self->{_args}{reject_type} = shift;   # backwards compatibility
+        $self->{_args}{reject_type} = shift;    # backwards compatibility
     }
     else {
-        $self->{_args} = { @_ };
+        $self->{_args} = {@_};
-    };
+    }
 
     # explicitly state legacy reject behavior
-    if ( ! defined $self->{_args}{reject_type} ) {
+    if (!defined $self->{_args}{reject_type}) {
         $self->{_args}{reject_type} = 'perm';
-    };
+    }
-    if ( ! defined $self->{_args}{reject} ) {
+    if (!defined $self->{_args}{reject}) {
         $self->{_args}{reject} = 1;
-    };
+    }
 }
 
 sub hook_connect {
@@ -156,76 +156,79 @@ sub hook_connect {
 
     # perform RBLSMTPD checks to mimic DJB's rblsmtpd
     # RBLSMTPD being non-empty means it contains the failure message to return
-    if ( defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '' ) {
+    if (defined $ENV{'RBLSMTPD'} && $ENV{'RBLSMTPD'} ne '') {
         my $reject = $self->{_args}{reject};
         return $self->return_env_message() if $reject && $reject eq 'connect';
-    };
+    }
 
     return DECLINED if $self->is_immune();
     return DECLINED if $self->is_set_rblsmtpd();
     return DECLINED if $self->ip_whitelisted();
 
     my $dnsbl_zones = $self->get_dnsbl_zones() or return DECLINED;
-    my $resolv      = $self->get_resolver() or return DECLINED;
+    my $resolv      = $self->get_resolver()    or return DECLINED;
 
-    for my $dnsbl ( keys %$dnsbl_zones ) {
+    for my $dnsbl (keys %$dnsbl_zones) {
 
-        my $query = $self->get_query( $dnsbl ) or do {
+        my $query = $self->get_query($dnsbl) or do {
-            if ( $resolv->errorstring ne 'NXDOMAIN' ) {
+            if ($resolv->errorstring ne 'NXDOMAIN') {
-                $self->log(LOGERROR, "$dnsbl query failed: ", $resolv->errorstring);
+                $self->log(LOGERROR, "$dnsbl query failed: ",
-            };
+                           $resolv->errorstring);
+            }
             next;
         };
 
         my $a_record = 0;
         my $result;
         foreach my $rr ($query->answer) {
-            if ( $rr->type eq 'A' ) {
+            if ($rr->type eq 'A') {
                 $result = $rr->name;
-                $self->log(LOGDEBUG, "found A for $result with IP " . $rr->address);
+                $self->log(LOGDEBUG,
+                           "found A for $result with IP " . $rr->address);
             }
             elsif ($rr->type eq 'TXT') {
                 $self->log(LOGDEBUG, "found TXT, " . $rr->txtdata);
                 $result = $rr->txtdata;
-            };
+            }
 
-            next if ! $result;
+            next if !$result;
 
-            $self->adjust_karma( -1 );
+            $self->adjust_karma(-1);
 
-            if ( ! $dnsbl ) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); };
+            if (!$dnsbl) { ($dnsbl) = ($result =~ m/(?:\d+\.){4}(.*)/); }
-            if ( ! $dnsbl ) {  $dnsbl = $result; };
+            if (!$dnsbl) { $dnsbl = $result; }
 
             if ($a_record) {
                 if (defined $dnsbl_zones->{$dnsbl}) {
-                    my $smtp_msg = $dnsbl_zones->{$dnsbl};
+                    my $smtp_msg  = $dnsbl_zones->{$dnsbl};
-                    my $remote_ip= $self->qp->connection->remote_ip;
+                    my $remote_ip = $self->qp->connection->remote_ip;
                     $smtp_msg =~ s/%IP%/$remote_ip/g;
-                    return $self->get_reject( $smtp_msg, $dnsbl );
+                    return $self->get_reject($smtp_msg, $dnsbl);
                 }
-                return $self->get_reject( "Blocked by $dnsbl" );
+                return $self->get_reject("Blocked by $dnsbl");
             }
 
-            return $self->get_reject( $result, $dnsbl );
+            return $self->get_reject($result, $dnsbl);
         }
     }
 
     $self->log(LOGINFO, 'pass');
     return DECLINED;
-};
+}
 
 sub get_dnsbl_zones {
     my $self = shift;
 
-    my %dnsbl_zones = map { (split /:/, $_, 2)[0,1] } $self->qp->config('dnsbl_zones');
+    my %dnsbl_zones =
-    if ( ! %dnsbl_zones ) {
+      map { (split /:/, $_, 2)[0, 1] } $self->qp->config('dnsbl_zones');
-        $self->log( LOGDEBUG, "skip, no zones");
+    if (!%dnsbl_zones) {
+        $self->log(LOGDEBUG, "skip, no zones");
         return;
-    };
+    }
 
     $self->{_dnsbl}{zones} = \%dnsbl_zones;
     return \%dnsbl_zones;
-};
+}
 
 sub get_query {
     my ($self, $dnsbl) = @_;
@@ -234,24 +237,24 @@ sub get_query {
     my $reversed_ip = join('.', reverse(split(/\./, $remote_ip)));
 
 # fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
-    if ( defined $self->{_dnsbl}{zones}{$dnsbl} ) {
+    if (defined $self->{_dnsbl}{zones}{$dnsbl}) {
         $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for A record");
         return $self->{_resolver}->query("$reversed_ip.$dnsbl");
-    };
+    }
 
     $self->log(LOGDEBUG, "Checking $reversed_ip.$dnsbl for TXT record");
     return $self->{_resolver}->query("$reversed_ip.$dnsbl", 'TXT');
-};
+}
 
 sub is_set_rblsmtpd {
     my $self = shift;
 
     my $remote_ip = $self->qp->connection->remote_ip;
 
-    if ( ! defined $ENV{'RBLSMTPD'} ) {
+    if (!defined $ENV{'RBLSMTPD'}) {
         $self->log(LOGDEBUG, "RBLSMTPD not set for $remote_ip");
         return;
-    };
+    }
 
     if ($ENV{'RBLSMTPD'} ne '') {
         $self->log(LOGINFO, "RBLSMTPD=\"$ENV{'RBLSMTPD'}\" for $remote_ip");
@@ -259,38 +262,39 @@ sub is_set_rblsmtpd {
     }
 
     $self->log(LOGINFO, "RBLSMTPD set, but empty for $remote_ip");
-    return 1;  # don't return empty string, it evaluates to false
+    return 1;    # don't return empty string, it evaluates to false
-};
+}
 
 sub ip_whitelisted {
     my ($self) = @_;
 
     my $remote_ip = $self->qp->connection->remote_ip;
 
-    return grep { s/\.?$/./;
+    return grep {
-            $_ eq substr($remote_ip . '.', 0, length $_)
+        s/\.?$/./;
-        }
+        $_ eq substr($remote_ip . '.', 0, length $_)
-        $self->qp->config('dnsbl_allow');
+    } $self->qp->config('dnsbl_allow');
-};
+}
 
 sub return_env_message {
-    my $self = shift;
+    my $self      = shift;
-    my $result = $ENV{'RBLSMTPD'};
+    my $result    = $ENV{'RBLSMTPD'};
     my $remote_ip = $self->qp->connection->remote_ip;
     $result =~ s/%IP%/$remote_ip/g;
-    my $msg =  $self->qp->config('dnsbl_rejectmsg');
+    my $msg = $self->qp->config('dnsbl_rejectmsg');
     $self->log(LOGINFO, "fail, $msg");
-    return ( $self->get_reject_type(), join(' ', $msg, $result));
+    return ($self->get_reject_type(), join(' ', $msg, $result));
 }
 
 sub hook_rcpt {
     my ($self, $transaction, $rcpt, %param) = @_;
 
-    if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) {
+    if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) {
-        $self->log(LOGWARN, "skip, don't blacklist special account: ".$rcpt->user);
+        $self->log(LOGWARN,
+                   "skip, don't blacklist special account: " . $rcpt->user);
 
         # clear the naughty connection note here, if desired.
-        $self->connection->notes('naughty', 0 );
+        $self->connection->notes('naughty', 0);
     }
 
     return DECLINED;
@@ -299,11 +303,11 @@ sub hook_rcpt {
 sub get_resolver {
     my $self = shift;
     return $self->{_resolver} if $self->{_resolver};
-    $self->log( LOGDEBUG, "initializing Net::DNS::Resolver");
+    $self->log(LOGDEBUG, "initializing Net::DNS::Resolver");
     $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
     my $timeout = $self->{_args}{timeout} || 30;
     $self->{_resolver}->tcp_timeout($timeout);
     $self->{_resolver}->udp_timeout($timeout);
     return $self->{_resolver};
-};
+}
 

plugins/domainkeys

@@ -57,68 +57,69 @@ use Qpsmtpd::Constants;
 sub init {
     my ($self, $qp, %args) = @_;
 
-    foreach my $key ( %args ) {
+    foreach my $key (%args) {
         $self->{$key} = $args{$key};
     }
-    $self->{reject} = 1 if ! defined $self->{reject};  # default reject
+    $self->{reject} = 1 if !defined $self->{reject};    # default reject
-    $self->{reject_type} = 'perm' if ! defined $self->{reject_type};
+    $self->{reject_type} = 'perm' if !defined $self->{reject_type};
 
-    if ( $args{'warn_only'} ) {
+    if ($args{'warn_only'}) {
         $self->log(LOGNOTICE, "warn_only is deprecated. Use reject instead");
         $self->{'reject'} = 0;
-    };
+    }
 }
 
 sub register {
     my $self = shift;
 
-    for my $m ( qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy / ) {
+    for my $m (qw/ Mail::DomainKeys::Message Mail::DomainKeys::Policy /) {
         eval "use $m";
-        if ( $@ ) {
+        if ($@) {
             warn "skip: plugin disabled, could not load $m\n";
             $self->log(LOGERROR, "skip: plugin disabled, is $m installed?");
             return;
-        };
+        }
-    };
+    }
 
     $self->register_hook('data_post', 'data_post_handler');
-};
+}
 
 sub data_post_handler {
     my ($self, $transaction) = @_;
 
     return DECLINED if $self->is_immune();
 
-    if ( ! $transaction->header->get('DomainKey-Signature') ) {
+    if (!$transaction->header->get('DomainKey-Signature')) {
         $self->log(LOGINFO, "skip, unsigned");
         return DECLINED;
-    };
+    }
 
-    my $body = $self->assemble_body( $transaction );
+    my $body = $self->assemble_body($transaction);
 
-    my $message = load Mail::DomainKeys::Message(
+    my $message =
-        HeadString => $transaction->header->as_string,
+      load Mail::DomainKeys::Message(
-        BodyReference => $body) or do {
+                                  HeadString => $transaction->header->as_string,
-            $self->log(LOGWARN, "skip, unable to load message"),
+                                  BodyReference => $body)
-            return DECLINED;
+      or do {
-        };
+        $self->log(LOGWARN, "skip, unable to load message"), return DECLINED;
+      };
 
     # no sender domain means no verification
-    if ( ! $message->senderdomain ) {
+    if (!$message->senderdomain) {
         $self->log(LOGINFO, "skip, failed to parse sender domain"),
-        return DECLINED;
+          return DECLINED;
-    };
+    }
 
-    my $status = $self->get_message_status( $message );
+    my $status = $self->get_message_status($message);
 
-    if ( defined $status ) {
+    if (defined $status) {
         $transaction->header->add("DomainKey-Status", $status, 0);
         $self->log(LOGINFO, "pass, $status");
         return DECLINED;
-    };
+    }
 
     $self->log(LOGERROR, "fail, signature invalid");
-    return DECLINED if ! $self->{reject};
+    return DECLINED if !$self->{reject};
     my $deny = $self->{reject_type} eq 'temp' ? DENYSOFT : DENY;
     return ($deny, "DomainKeys signature validation failed");
 }
@@ -126,45 +127,44 @@ sub data_post_handler {
 sub get_message_status {
     my ($self, $message) = @_;
 
-    if ( $message->testing ) {
+    if ($message->testing) {
-        return "testing";   # key testing, don't do anything else
+        return "testing";    # key testing, don't do anything else
-    };
+    }
 
-    if ( $message->signed && $message->verify ) {
+    if ($message->signed && $message->verify) {
-        return $message->signature->status; # verified: add good header
+        return $message->signature->status;    # verified: add good header
-    };
+    }
 
     # not signed or not verified
-    my $policy = fetch Mail::DomainKeys::Policy(
+    my $policy =
-        Protocol => 'dns',
+      fetch Mail::DomainKeys::Policy(Protocol => 'dns',
-        Domain => $message->senderdomain
+                                     Domain   => $message->senderdomain);
-    );
 
-    if ( ! $policy ) {
+    if (!$policy) {
         return $message->signed ? "non-participant" : "no signature";
-    };
+    }
 
-    if ( $policy->testing ) {
+    if ($policy->testing) {
-        return "testing";  # Don't do anything else
+        return "testing";    # Don't do anything else
-    };
+    }
 
-    if ( $policy->signall ) {
+    if ($policy->signall) {
-        return undef;      # policy requires all mail to be signed
+        return undef;        # policy requires all mail to be signed
-    };
+    }
 
     # $policy->signsome
-    return "no signature"; # not signed and domain doesn't sign all
+    return "no signature";    # not signed and domain doesn't sign all
-};
+}
 
 sub assemble_body {
     my ($self, $transaction) = @_;
 
     $transaction->body_resetpos;
-    $transaction->body_getline; # \r\n seperator is NOT part of the body
+    $transaction->body_getline;    # \r\n seperator is NOT part of the body
 
     my @body;
     while (my $line = $transaction->body_getline) {
         push @body, $line;
     }
     return \@body;
-};
+}

plugins/dont_require_anglebrackets

@@ -22,19 +22,19 @@ MAIL FROM:user@example.com
 =cut
 
 sub hook_mail_pre {
-    my ($self,$transaction, $addr) = @_;
+    my ($self, $transaction, $addr) = @_;
     unless ($addr =~ /^<.*>$/) {
         $self->log(LOGINFO, "added MAIL angle brackets");
-        $addr = '<'.$addr.'>';
+        $addr = '<' . $addr . '>';
     }
     return (OK, $addr);
 }
 
 sub hook_rcpt_pre {
-    my ($self,$transaction, $addr) = @_;
+    my ($self, $transaction, $addr) = @_;
     unless ($addr =~ /^<.*>$/) {
         $self->log(LOGINFO, "added RCPT angle brackets");
-        $addr = '<'.$addr.'>';
+        $addr = '<' . $addr . '>';
     }
     return (OK, $addr);
 }

plugins/dspam

@@ -212,10 +212,10 @@ sub register {
 
     $self->log(LOGERROR, "Bad parameters for the dspam plugin") if @_ % 2;
 
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
-    $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
+    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
     $self->{_args}{reject_type} ||= 'perm';
-    $self->{_args}{dspam_bin} ||= '/usr/local/bin/dspam';
+    $self->{_args}{dspam_bin}   ||= '/usr/local/bin/dspam';
 
     $self->get_dspam_bin() or return DECLINED;
 
@@ -226,16 +226,18 @@ sub get_dspam_bin {
     my $self = shift;
 
     my $bin = $self->{_args}{dspam_bin};
-    if ( ! -e $bin ) {
+    if (!-e $bin) {
-        $self->log(LOGERROR, "error, dspam CLI binary not found: install dspam and/or set dspam_bin");
+        $self->log(LOGERROR,
+"error, dspam CLI binary not found: install dspam and/or set dspam_bin"
+        );
         return;
-    };
+    }
-    if ( ! -x $bin ) {
+    if (!-x $bin) {
         $self->log(LOGERROR, "error, no permission to run $bin");
         return;
-    };
+    }
     return $bin;
-};
+}
 
 sub data_post_handler {
     my $self = shift;
@@ -243,29 +245,30 @@ sub data_post_handler {
 
     return (DECLINED) if $self->is_immune();
 
-    if ( $transaction->data_size > 500_000 ) {
+    if ($transaction->data_size > 500_000) {
-        $self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")" );
+        $self->log(LOGINFO, "skip, too big (" . $transaction->data_size . ")");
         return (DECLINED);
-    };
+    }
 
-    my $user = $self->select_username( $transaction );
+    my $user = $self->select_username($transaction);
     my $bin  = $self->{_args}{dspam_bin};
-    my $filtercmd = "$bin --user $user --mode=tum --process --deliver=summary --stdout";
+    my $filtercmd =
+      "$bin --user $user --mode=tum --process --deliver=summary --stdout";
     $self->log(LOGDEBUG, $filtercmd);
 
-    my $response = $self->dspam_process( $filtercmd, $transaction );
+    my $response = $self->dspam_process($filtercmd, $transaction);
-    if ( ! $response->{result} ) {
+    if (!$response->{result}) {
         $self->log(LOGWARN, "error, no dspam response. Check logs for errors.");
         return (DECLINED);
-    };
+    }
 
     $transaction->notes('dspam', $response);
 
-    $self->attach_headers( $response, $transaction );
+    $self->attach_headers($response, $transaction);
-    $self->autolearn( $response, $transaction );
+    $self->autolearn($response, $transaction);
 
-    return $self->log_and_return( $transaction );
+    return $self->log_and_return($transaction);
-};
+}
 
 sub select_username {
     my ($self, $transaction) = @_;
@@ -273,34 +276,36 @@ sub select_username {
     my $recipient_count = scalar $transaction->recipients;
     $self->log(LOGDEBUG, "Message has $recipient_count recipients");
 
-    if ( $recipient_count > 1 ) {
+    if ($recipient_count > 1) {
-        $self->log(LOGINFO, "multiple recipients ($recipient_count), ignoring user prefs");
+        $self->log(LOGINFO,
+                 "multiple recipients ($recipient_count), ignoring user prefs");
         return getpwuid($>);
-    };
+    }
 
-# use the recipients email address as username. This enables user prefs
+    # use the recipients email address as username. This enables user prefs
     my $username = ($transaction->recipients)[0]->address;
     return lc($username);
-};
+}
 
 sub assemble_message {
     my ($self, $transaction) = @_;
 
-    my $message = "X-Envelope-From: "
+    my $message =
-        . $transaction->sender->format . "\n"
+        "X-Envelope-From: "
-        . $transaction->header->as_string . "\n\n";
+      . $transaction->sender->format . "\n"
+      . $transaction->header->as_string . "\n\n";
 
     $transaction->body_resetpos;
-    while (my $line = $transaction->body_getline) { $message .= $line; };
+    while (my $line = $transaction->body_getline) { $message .= $line; }
 
     $message = join(CRLF, split /\n/, $message);
     return $message . CRLF;
-};
+}
 
 sub parse_response {
     my $self = shift;
     my $response = shift or do {
-        $self->log( LOGDEBUG, "missing dspam response!" );
+        $self->log(LOGDEBUG, "missing dspam response!");
         return;
     };
 
@@ -313,22 +318,22 @@ sub parse_response {
     my ($user, $result, $class, $prob, $conf, $sig) = split /; /, $response;
 
     (undef, $result) = split /=/, $result;
-    (undef, $class ) = split /=/, $class;
+    (undef, $class)  = split /=/, $class;
-    (undef, $prob  ) = split /=/, $prob;
+    (undef, $prob)   = split /=/, $prob;
-    (undef, $conf  ) = split /=/, $conf;
+    (undef, $conf)   = split /=/, $conf;
-    (undef, $sig   ) = split /=/, $sig;
+    (undef, $sig)    = split /=/, $sig;
 
-    $result = substr($result, 1, -1);  # strip off quotes
+    $result = substr($result, 1, -1);    # strip off quotes
     $class  = substr($class,  1, -1);
 
     return {
-        class       => $class,
+            class       => $class,
-        result      => $result,
+            result      => $result,
-        probability => $prob,
+            probability => $prob,
-        confidence  => $conf,
+            confidence  => $conf,
-        signature   => $sig,
+            signature   => $sig,
-    };
+           };
-};
+}
 
 sub parse_response_regexp {
     my ($self, $response) = @_;
@@ -342,107 +347,114 @@ sub parse_response_regexp {
             /x;
 
     return {
-        class       => $class,
+            class       => $class,
-        result      => $result,
+            result      => $result,
-        probability => $prob,
+            probability => $prob,
-        confidence  => $conf,
+            confidence  => $conf,
-        signature   => $sig,
+            signature   => $sig,
-    };
+           };
-};
+}
 
 sub dspam_process {
-    my ( $self, $filtercmd, $transaction ) = @_;
+    my ($self, $filtercmd, $transaction) = @_;
+
+    my $response = $self->dspam_process_backticks($filtercmd);
 
-    my $response = $self->dspam_process_backticks( $filtercmd );
     #my $response = $self->dspam_process_open2( $filtercmd, $transaction );
     #my $response = $self->dspam_process_fork( $filtercmd );
 
-    return $self->parse_response( $response );
+    return $self->parse_response($response);
-};
+}
 
 sub dspam_process_fork {
-    my ( $self, $filtercmd, $transaction ) = @_;
+    my ($self, $filtercmd, $transaction) = @_;
 
     # yucky. This method (which forks) exercises a bug in qpsmtpd. When the
     # child exits, the Transaction::DESTROY method is called, which deletes
     # the spooled file from disk. The contents of $self->qp->transaction
     # needed to spool it again are also destroyed. Don't use this.
-    my $message  = $self->assemble_message( $transaction );
+    my $message = $self->assemble_message($transaction);
     my $in_fh;
-    if (! open($in_fh, '-|')) {    # forks child for writing
+    if (!open($in_fh, '-|')) {    # forks child for writing
         open(my $out_fh, "|$filtercmd") or die "Can't run $filtercmd: $!\n";
         print $out_fh $message;
         close $out_fh;
         exit(0);
-    };
+    }
     my $response = <$in_fh>;
     close $in_fh;
     chomp $response;
     $self->log(LOGDEBUG, $response);
     return $response;
-};
+}
 
 sub dspam_process_backticks {
-    my ( $self, $filtercmd ) = @_;
+    my ($self, $filtercmd) = @_;
 
     my $transaction = $self->qp->transaction;
 
     my $message = $self->temp_file();
     open my $fh, '>', $message;
     print $fh "X-Envelope-From: "
-        . $transaction->sender->format . CRLF
+      . $transaction->sender->format
-        . $transaction->header->as_string . CRLF . CRLF;
+      . CRLF
+      . $transaction->header->as_string
+      . CRLF
+      . CRLF;
 
     $transaction->body_resetpos;
-    while (my $line = $transaction->body_getline) { print $fh $line; };
+    while (my $line = $transaction->body_getline) { print $fh $line; }
 
     close $fh;
 
     my ($line1) = split /[\r|\n]/, `$filtercmd < $message`;
     $self->log(LOGDEBUG, $line1);
     return $line1;
-};
+}
 
 sub dspam_process_open2 {
-    my ( $self, $filtercmd, $transaction ) = @_;
+    my ($self, $filtercmd, $transaction) = @_;
 
-    my $message  = $self->assemble_message( $transaction );
+    my $message = $self->assemble_message($transaction);
 
-# not sure why, but this is not as reliable as I'd like. What's a dspam
+    # not sure why, but this is not as reliable as I'd like. What's a dspam
-# error -5 mean anyway?
+    # error -5 mean anyway?
     use FileHandle;
     use IPC::Open3;
     my ($read, $write, $err);
-    use Symbol 'gensym'; $err = gensym;
+    use Symbol 'gensym';
+    $err = gensym;
     my $pid = open3($write, $read, $err, $filtercmd);
     print $write $message;
     close $write;
+
     #my $response = join('', <$dspam_out>);  # get full response
-    my $response = <$read>;             # get first line only
+    my $response = <$read>;    # get first line only
     waitpid $pid, 0;
     my $child_exit_status = $? >> 8;
+
     #$self->log(LOGINFO, "exit status: $child_exit_status");
-    if ( $response ) {
+    if ($response) {
         chomp $response;
         $self->log(LOGDEBUG, $response);
-    };
+    }
     my $err_msg = <$err>;
-    if ( $err_msg ) {
+    if ($err_msg) {
-        $self->log(LOGDEBUG, $err_msg );
+        $self->log(LOGDEBUG, $err_msg);
-    };
+    }
     return $response;
-};
+}
 
 sub log_and_return {
     my $self = shift;
     my $transaction = shift || $self->qp->transaction;
 
-    my $d = $self->get_dspam_results( $transaction ) or return DECLINED;
+    my $d = $self->get_dspam_results($transaction) or return DECLINED;
 
-    if ( ! $d->{class} ) {
+    if (!$d->{class}) {
         $self->log(LOGWARN, "skip, no dspam class detected");
         return DECLINED;
-    };
+    }
 
     my $status = "$d->{class}, $d->{confidence} c.";
     my $reject = $self->{_args}{reject} or do {
@@ -450,26 +462,30 @@ sub log_and_return {
         return DECLINED;
     };
 
-    if ( $reject eq 'agree' ) {
+    if ($reject eq 'agree') {
-        return $self->reject_agree( $transaction );
+        return $self->reject_agree($transaction);
-    };
+    }
 
-    if ( $d->{class} eq 'Innocent' ) {
+    if ($d->{class} eq 'Innocent') {
         $self->log(LOGINFO, "pass, $status");
         return DECLINED;
-    };
+    }
-    if ( $self->qp->connection->relay_client ) {
+    if ($self->qp->connection->relay_client) {
-        $self->log(LOGINFO, "skip, allowing spam, user authenticated ($status)");
+        $self->log(LOGINFO,
+                   "skip, allowing spam, user authenticated ($status)");
         return DECLINED;
-    };
+    }
-    if ( $d->{probability} <= $reject ) {
+    if ($d->{probability} <= $reject) {
-        $self->log(LOGINFO, "pass, $d->{class} probability is too low ($d->{probability} < $reject)");
+        $self->log(LOGINFO,
+"pass, $d->{class} probability is too low ($d->{probability} < $reject)"
+        );
         return DECLINED;
-    };
+    }
-    if ( $d->{confidence} != 1 ) {
+    if ($d->{confidence} != 1) {
-        $self->log(LOGINFO, "pass, $d->{class} confidence is too low ($d->{confidence})");
+        $self->log(LOGINFO,
+                  "pass, $d->{class} confidence is too low ($d->{confidence})");
         return DECLINED;
-    };
+    }
 
     # dspam is more than $reject percent sure this message is spam
     $self->log(LOGINFO, "fail, $d->{class}, ($d->{confidence} confident)");
@@ -478,82 +494,84 @@ sub log_and_return {
 }
 
 sub reject_agree {
-    my ($self, $transaction ) = @_;
+    my ($self, $transaction) = @_;
 
-    my $sa = $transaction->notes('spamassassin' );
+    my $sa = $transaction->notes('spamassassin');
-    my $d  = $transaction->notes('dspam' );
+    my $d  = $transaction->notes('dspam');
 
     my $status = "$d->{class}, $d->{confidence} c";
 
-    if ( ! $sa->{is_spam} ) {
+    if (!$sa->{is_spam}) {
         $self->log(LOGINFO, "pass, cannot agree, SA results missing ($status)");
         return DECLINED;
-    };
+    }
 
-    if ( $d->{class} eq 'Spam' ) {
+    if ($d->{class} eq 'Spam') {
-        if ( $sa->{is_spam} eq 'Yes' ) {
+        if ($sa->{is_spam} eq 'Yes') {
-            $self->adjust_karma( -2 );
+            $self->adjust_karma(-2);
             $self->log(LOGINFO, "fail, agree, $status");
             my $reject = $self->get_reject_type();
             return ($reject, 'we agree, no spam please');
-        };
+        }
 
         $self->log(LOGINFO, "fail, disagree, $status");
         return DECLINED;
-    };
+    }
 
-    if ( $d->{class} eq 'Innocent' ) {
+    if ($d->{class} eq 'Innocent') {
-        if ( $sa->{is_spam} eq 'No' ) {
+        if ($sa->{is_spam} eq 'No') {
-            if ( $d->{confidence} > .9 ) {
+            if ($d->{confidence} > .9) {
-                $self->adjust_karma( 1 );
+                $self->adjust_karma(1);
-            };
+            }
             $self->log(LOGINFO, "pass, agree, $status");
             return DECLINED;
-        };
+        }
         $self->log(LOGINFO, "pass, disagree, $status");
         return DECLINED;
-    };
+    }
 
     $self->log(LOGINFO, "pass, other $status");
     return DECLINED;
-};
+}
 
 sub get_dspam_results {
     my $self = shift;
     my $transaction = shift || $self->qp->transaction;
 
-    if ( $transaction->notes('dspam') ) {
+    if ($transaction->notes('dspam')) {
         return $transaction->notes('dspam');
-    };
+    }
 
     my $string = $transaction->header->get('X-DSPAM-Result') or do {
         $self->log(LOGWARN, "get_dspam_results: failed to find the header");
         return;
     };
 
-    my @bits  = split /,\s+/, $string; chomp @bits;
+    my @bits = split /,\s+/, $string;
+    chomp @bits;
     my $class = shift @bits;
     my %d;
     foreach (@bits) {
-        my ($key,$val) = split /=/, $_;
+        my ($key, $val) = split /=/, $_;
         $d{$key} = $val;
-    };
+    }
     $d{class} = $class;
 
     my $message = $d{class};
-    if ( defined $d{probability} && defined $d{confidence} ) {
+    if (defined $d{probability} && defined $d{confidence}) {
         $message .= ", prob: $d{probability}, conf: $d{confidence}";
-    };
+    }
     $self->log(LOGDEBUG, $message);
     $transaction->notes('dspam', \%d);
     return \%d;
-};
+}
 
 sub attach_headers {
     my ($self, $r, $transaction) = @_;
     $transaction ||= $self->qp->transaction;
 
-    my $header_str = "$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}";
+    my $header_str =
+"$r->{result}, probability=$r->{probability}, confidence=$r->{confidence}";
     $self->log(LOGDEBUG, $header_str);
     my $name = 'X-DSPAM-Result';
     $transaction->header->delete($name) if $transaction->header->get($name);
@@ -562,135 +580,160 @@ sub attach_headers {
     # the signature header is required if you intend to train dspam later.
     # In dspam.conf, set: Preference "signatureLocation=headers"
     $transaction->header->add('X-DSPAM-Signature', $r->{signature}, 0);
-};
+}
 
 sub train_error_as_ham {
-    my $self = shift;
+    my $self        = shift;
     my $transaction = shift;
 
-    my $user = $self->select_username( $transaction );
+    my $user = $self->select_username($transaction);
     my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam';
-    my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout";
+    my $cmd =
-    my $response = $self->dspam_process( $cmd, $transaction );
+"$dspam_bin --user $user --mode=toe --source=error --class=innocent --deliver=summary --stdout";
-    if ( $response ) {
+    my $response = $self->dspam_process($cmd, $transaction);
+    if ($response) {
         $transaction->notes('dspam', $response);
     }
     else {
-        $transaction->notes('dspam', { class => 'Innocent', result => 'Innocent', confidence=>1 } );
+        $transaction->notes(
-    };
+                            'dspam',
-};
+                            {
+                             class      => 'Innocent',
+                             result     => 'Innocent',
+                             confidence => 1
+                            }
+                           );
+    }
+}
 
 sub train_error_as_spam {
-    my $self = shift;
+    my $self        = shift;
     my $transaction = shift;
 
-    my $user = $self->select_username( $transaction );
+    my $user = $self->select_username($transaction);
     my $dspam_bin = $self->{_args}{dspam_bin} || '/usr/local/bin/dspam';
-    my $cmd = "$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout";
+    my $cmd =
-    my $response = $self->dspam_process( $cmd, $transaction );
+"$dspam_bin --user $user --mode=toe --source=error --class=spam --deliver=summary --stdout";
-    if ( $response ) {
+    my $response = $self->dspam_process($cmd, $transaction);
+    if ($response) {
         $transaction->notes('dspam', $response);
     }
     else {
-        $transaction->notes('dspam', { class => 'Spam', result => 'Spam', confidence=>1 } );
+        $transaction->notes(
-    };
+                            'dspam',
-};
+                            {
+                             class      => 'Spam',
+                             result     => 'Spam',
+                             confidence => 1
+                            }
+                           );
+    }
+}
 
 sub autolearn {
-    my ( $self, $response, $transaction ) = @_;
+    my ($self, $response, $transaction) = @_;
 
     defined $self->{_args}{autolearn} or return;
 
     if (   $self->{_args}{autolearn} ne 'any'
         && $self->{_args}{autolearn} ne 'karma'
         && $self->{_args}{autolearn} ne 'naughty'
-        && $self->{_args}{autolearn} ne 'spamassassin'
+        && $self->{_args}{autolearn} ne 'spamassassin')
-        ) {
+    {
-        $self->log(LOGERROR, "bad autolearn setting! Read 'perldoc plugins/dspam' again!");
+        $self->log(LOGERROR,
+                  "bad autolearn setting! Read 'perldoc plugins/dspam' again!");
         return;
-    };
+    }
 
     # only train once.
-    $self->autolearn_naughty( $response, $transaction ) and return;
+    $self->autolearn_naughty($response, $transaction) and return;
-    $self->autolearn_karma( $response, $transaction ) and return;
+    $self->autolearn_karma($response, $transaction) and return;
-    $self->autolearn_spamassassin( $response, $transaction ) and return;
+    $self->autolearn_spamassassin($response, $transaction) and return;
-};
+}
 
 sub autolearn_naughty {
-    my ( $self, $response, $transaction ) = @_;
+    my ($self, $response, $transaction) = @_;
 
     my $learn = $self->{_args}{autolearn} or return;
 
-    if ( $learn ne 'naughty' && $learn ne 'any' ) {
+    if ($learn ne 'naughty' && $learn ne 'any') {
         $self->log(LOGDEBUG, "skipping naughty autolearn");
         return;
-    };
+    }
 
-    if ( $self->connection->notes('naughty') && $response->{result} eq 'Innocent' ) {
+    if (   $self->connection->notes('naughty')
+        && $response->{result} eq 'Innocent')
+    {
         $self->log(LOGINFO, "training naughty FN message as spam");
-        $self->train_error_as_spam( $transaction );
+        $self->train_error_as_spam($transaction);
         return 1;
-    };
+    }
 
     $self->log(LOGDEBUG, "falling through naughty autolearn");
     return;
-};
+}
 
 sub autolearn_karma {
-    my ( $self, $response, $transaction ) = @_;
+    my ($self, $response, $transaction) = @_;
 
     my $learn = $self->{_args}{autolearn} or return;
 
-    return if ( $learn ne 'karma' && $learn ne 'any' );
+    return if ($learn ne 'karma' && $learn ne 'any');
 
     my $karma = $self->connection->notes('karma');
-    return if ! defined $karma;
+    return if !defined $karma;
 
-    if ( $karma < -2  && $response->{result} eq 'Innocent' ) {
+    if ($karma < -2 && $response->{result} eq 'Innocent') {
         $self->log(LOGINFO, "training bad karma ($karma) FN as spam");
-        $self->train_error_as_spam( $transaction );
+        $self->train_error_as_spam($transaction);
         return 1;
-    };
+    }
 
-    if ( $karma > 2 && $response->{result} eq 'Spam' ) {
+    if ($karma > 2 && $response->{result} eq 'Spam') {
         $self->log(LOGINFO, "training good karma ($karma) FP as ham");
-        $self->train_error_as_ham( $transaction );
+        $self->train_error_as_ham($transaction);
         return 1;
-    };
+    }
 
     return;
-};
+}
 
 sub autolearn_spamassassin {
-    my ( $self, $response, $transaction ) = @_;
+    my ($self, $response, $transaction) = @_;
 
     my $learn = $self->{_args}{autolearn} or return;
 
-    return if ( $learn ne 'spamassassin' && $learn ne 'any' );
+    return if ($learn ne 'spamassassin' && $learn ne 'any');
 
-    my $sa = $transaction->notes('spamassassin' );
+    my $sa = $transaction->notes('spamassassin');
-    if ( ! $sa || ! $sa->{is_spam} ) {
+    if (!$sa || !$sa->{is_spam}) {
-        if ( ! $self->connection->notes('naughty') ) {
+        if (!$self->connection->notes('naughty')) {
-            $self->log(LOGERROR, "SA results missing"); # SA skips naughty
+            $self->log(LOGERROR, "SA results missing");    # SA skips naughty
-        };
+        }
         return;
-    };
+    }
 
-    if ( ! $sa->{autolearn} ) {
+    if (!$sa->{autolearn}) {
         $self->log(LOGERROR, "SA autolearn unset");
         return;
-    };
+    }
 
-    if ( $sa->{is_spam} eq 'Yes' && $sa->{autolearn} eq 'spam' && $response->{result} eq 'Innocent' ) {
+    if (   $sa->{is_spam} eq 'Yes'
+        && $sa->{autolearn} eq 'spam'
+        && $response->{result} eq 'Innocent')
+    {
         $self->log(LOGINFO, "training SA FN as spam");
-        $self->train_error_as_spam( $transaction );
+        $self->train_error_as_spam($transaction);
         return 1;
     }
-    elsif ( $sa->{is_spam} eq 'No' && $sa->{autolearn} eq 'ham' && $response->{result} eq 'Spam' ) {
+    elsif (   $sa->{is_spam} eq 'No'
+           && $sa->{autolearn} eq 'ham'
+           && $response->{result} eq 'Spam')
+    {
         $self->log(LOGINFO, "training SA FP as ham");
-        $self->train_error_as_ham( $transaction );
+        $self->train_error_as_ham($transaction);
         return 1;
-    };
+    }
 
     return;
-};
+}

plugins/earlytalker

@@ -70,52 +70,57 @@ use IO::Select;
 use Qpsmtpd::Constants;
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  if (@args % 2) {
+    if (@args % 2) {
         $self->log(LOGERROR, "Unrecognized/mismatched arguments");
         return;
-  }
-  my %check_at;
-  for (0..$#args) {
-    next if $_ % 2;
-    if (lc($args[$_]) eq 'check-at') {
-      my $val = $args[$_ + 1];
-      $check_at{uc($val)}++;
     }
-  }
+    my %check_at;
-  if (!%check_at) {
+    for (0 .. $#args) {
-    $check_at{CONNECT} = 1;
+        next if $_ % 2;
-  }
+        if (lc($args[$_]) eq 'check-at') {
-  $self->{_args} = {
+            my $val = $args[$_ + 1];
-        'wait' => 1,
+            $check_at{uc($val)}++;
-        @args,
+        }
-        'check-at' => \%check_at,
+    }
-  };
+    if (!%check_at) {
-# backwards compat with old 'action' argument
+        $check_at{CONNECT} = 1;
-  if ( defined $self->{_args}{action} && ! defined $self->{_args}{reject} ) {
+    }
-       $self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0;
+    $self->{_args} = {
-  };
+                      'wait' => 1,
-  if ( defined $self->{_args}{'defer-reject'} && ! defined $self->{_args}{reject_type} ) {
+                      @args,
-       $self->{_args}{reject_type} = $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm';
+                      'check-at' => \%check_at,
-  };
+                     };
-  if ( ! defined $self->{_args}{reject_type} ) {
+
-       $self->{_args}{reject_type} = 'perm';
+    # backwards compat with old 'action' argument
-  };
+    if (defined $self->{_args}{action} && !defined $self->{_args}{reject}) {
-# /end compat
+        $self->{_args}{reject} = $self->{_args}{action} =~ /^deny/i ? 1 : 0;
-  if ( $qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) {
+    }
-      require APR::Const;
+    if (defined $self->{_args}{'defer-reject'}
-      APR::Const->import(qw(POLLIN SUCCESS));
+        && !defined $self->{_args}{reject_type})
-      $self->register_hook('connect', 'apr_connect_handler');
+    {
-      $self->register_hook('data', 'apr_data_handler');
+        $self->{_args}{reject_type} =
-  }
+          $self->{_args}{action} == 'denysoft' ? 'temp' : 'perm';
-  else {
+    }
-      $self->register_hook('connect', 'connect_handler');
+    if (!defined $self->{_args}{reject_type}) {
-      $self->register_hook('data', 'data_handler');
+        $self->{_args}{reject_type} = 'perm';
-  }
+    }
-  $self->register_hook('mail', 'mail_handler')
+
-    if $self->{_args}{'defer-reject'};
+    # /end compat
-  $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
+    if ($qp->{conn} && $qp->{conn}->isa('Apache2::Connection')) {
+        require APR::Const;
+        APR::Const->import(qw(POLLIN SUCCESS));
+        $self->register_hook('connect', 'apr_connect_handler');
+        $self->register_hook('data',    'apr_data_handler');
+    }
+    else {
+        $self->register_hook('connect', 'connect_handler');
+        $self->register_hook('data',    'data_handler');
+    }
+    $self->register_hook('mail', 'mail_handler')
+      if $self->{_args}{'defer-reject'};
+    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
 }
 
 sub apr_connect_handler {
@@ -124,7 +129,7 @@ sub apr_connect_handler {
     return DECLINED unless $self->{_args}{'check-at'}{CONNECT};
     return DECLINED if $self->is_immune();
 
-    my $c = $self->qp->{conn} or return DECLINED;
+    my $c      = $self->qp->{conn} or return DECLINED;
     my $socket = $c->client_socket or return DECLINED;
     my $timeout = $self->{_args}{'wait'} * 1_000_000;
 
@@ -133,9 +138,9 @@ sub apr_connect_handler {
         if ($self->{_args}{'defer-reject'}) {
             $self->connection->notes('earlytalker', 1);
             return DECLINED;
-        };
+        }
         return $self->log_and_deny();
-    };
+    }
     return $self->log_and_pass();
 }
 
@@ -145,14 +150,14 @@ sub apr_data_handler {
     return DECLINED unless $self->{_args}{'check-at'}{DATA};
     return DECLINED if $self->is_immune();
 
-    my $c = $self->qp->{conn} or return DECLINED;
+    my $c      = $self->qp->{conn} or return DECLINED;
     my $socket = $c->client_socket or return DECLINED;
     my $timeout = $self->{_args}{'wait'} * 1_000_000;
 
     my $rc = $socket->poll($c->pool, $timeout, APR::Const::POLLIN());
     if ($rc == APR::Const::SUCCESS()) {
         return $self->log_and_deny();
-    };
+    }
     return $self->log_and_pass();
 }
 
@@ -168,19 +173,19 @@ sub connect_handler {
     if (defined $karma && $karma > 5) {
         $self->log(LOGINFO, "skip, karma $karma");
         return DECLINED;
-    };
+    }
 
     $in->add(\*STDIN) or return DECLINED;
-    if (! $in->can_read($self->{_args}{'wait'})) {
+    if (!$in->can_read($self->{_args}{'wait'})) {
         return $self->log_and_pass();
-    };
+    }
 
-    if ( ! $self->{_args}{'defer-reject'}) {
+    if (!$self->{_args}{'defer-reject'}) {
         return $self->log_and_deny();
-    };
+    }
 
     $self->connection->notes('earlytalker', 1);
-    $self->adjust_karma( -1 );
+    $self->adjust_karma(-1);
     return DECLINED;
 }
 
@@ -192,12 +197,12 @@ sub data_handler {
     return DECLINED if $self->is_immune();
 
     $in->add(\*STDIN) or return DECLINED;
-    if ( ! $in->can_read($self->{_args}{'wait'})) {
+    if (!$in->can_read($self->{_args}{'wait'})) {
         return $self->log_and_pass();
-    };
+    }
 
     return $self->log_and_deny();
-};
+}
 
 sub log_and_pass {
     my $self = shift;
@@ -212,18 +217,18 @@ sub log_and_deny {
     my $ip = $self->qp->connection->remote_ip || 'remote host';
 
     $self->connection->notes('earlytalker', 1);
-    $self->adjust_karma( -1 );
+    $self->adjust_karma(-1);
 
     my $log_mess = "remote started talking before we said hello";
     my $smtp_msg = 'Connecting host started transmitting before SMTP greeting';
 
-    return $self->get_reject( $smtp_msg, $log_mess );
+    return $self->get_reject($smtp_msg, $log_mess);
 }
 
 sub mail_handler {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  return DECLINED unless $self->connection->notes('earlytalker');
+    return DECLINED unless $self->connection->notes('earlytalker');
-  return $self->log_and_deny();
+    return $self->log_and_deny();
 }
 

plugins/fcrdns

@@ -102,20 +102,20 @@ use Qpsmtpd::Constants;
 
 sub register {
     my ($self, $qp) = (shift, shift);
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
     $self->{_args}{reject_type} = 'temp';
     $self->{_args}{timeout} ||= 5;
     $self->{_args}{ptr_hosts} = {};
 
-    if ( ! defined $self->{_args}{reject} ) {
+    if (!defined $self->{_args}{reject}) {
         $self->{_args}{reject} = 0;
-    };
+    }
 
     $self->init_resolver() or return;
 
     $self->register_hook('connect',   'connect_handler');
     $self->register_hook('data_post', 'data_post_handler');
-};
+}
 
 sub connect_handler {
     my ($self) = @_;
@@ -123,9 +123,9 @@ sub connect_handler {
     return DECLINED if $self->is_immune();
 
     # run a couple cheap tests before the more expensive DNS tests
-    foreach my $test ( qw/ invalid_localhost is_not_fqdn / ) {
+    foreach my $test (qw/ invalid_localhost is_not_fqdn /) {
         $self->$test() or return DECLINED;
-    };
+    }
 
     $self->has_reverse_dns() or return DECLINED;
     $self->has_forward_dns() or return DECLINED;
@@ -138,91 +138,93 @@ sub data_post_handler {
     my ($self, $transaction) = @_;
 
     my $match = $self->connection->notes('fcrdns_match') || 0;
-    $transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0 );
+    $transaction->header->add('X-Fcrdns', $match ? 'Yes' : 'No', 0);
     return (DECLINED);
-};
+}
 
 sub invalid_localhost {
-    my ( $self ) = @_;
+    my ($self) = @_;
     return 1 if lc $self->qp->connection->remote_host ne 'localhost';
     if (   $self->qp->connection->remote_ip ne '127.0.0.1'
-        && $self->qp->connection->remote_ip ne '::1' ) {
+        && $self->qp->connection->remote_ip ne '::1')
-        $self->adjust_karma( -1 );
+    {
-        $self->log( LOGINFO, "fail, not localhost" );
+        $self->adjust_karma(-1);
+        $self->log(LOGINFO, "fail, not localhost");
         return;
-    };
+    }
-    $self->adjust_karma( 1 );
+    $self->adjust_karma(1);
-    $self->log( LOGDEBUG, "pass, is localhost" );
+    $self->log(LOGDEBUG, "pass, is localhost");
     return 1;
-};
+}
 
 sub is_not_fqdn {
     my ($self) = @_;
     my $host = $self->qp->connection->remote_host or return 1;
-    return 1 if $host eq 'Unknown'; # QP assigns this to a "no DNS result"
+    return 1 if $host eq 'Unknown';    # QP assigns this to a "no DNS result"
 
     # Since QP looked it up, perform some quick validation
-    if ( $host !~ /\./ ) { # has no dots
+    if ($host !~ /\./) {               # has no dots
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
         $self->log(LOGINFO, "fail, not FQDN");
         return;
-    };
+    }
-    if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) {
+    if ($host =~ /[^a-zA-Z0-9\-\.]/) {
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
         $self->log(LOGINFO, "fail, invalid FQDN chars");
         return;
-    };
+    }
     return 1;
-};
+}
 
 sub has_reverse_dns {
-    my ( $self ) = @_;
+    my ($self) = @_;
 
     my $res = $self->init_resolver();
     my $ip  = $self->qp->connection->remote_ip;
 
-    my $query = $res->query( $ip ) or do {
+    my $query = $res->query($ip) or do {
-        if ( $res->errorstring eq 'NXDOMAIN' ) {
+        if ($res->errorstring eq 'NXDOMAIN') {
-            $self->adjust_karma( -1 );
+            $self->adjust_karma(-1);
-            $self->log( LOGINFO, "fail, no rDNS: ".$res->errorstring );
+            $self->log(LOGINFO, "fail, no rDNS: " . $res->errorstring);
             return;
-        };
+        }
-        $self->log( LOGINFO, "fail, error getting rDNS: ".$res->errorstring );
+        $self->log(LOGINFO, "fail, error getting rDNS: " . $res->errorstring);
         return;
     };
 
     my $hits = 0;
-    $self->{_args}{ptr_hosts} = {};  # reset hash
+    $self->{_args}{ptr_hosts} = {};    # reset hash
     for my $rr ($query->answer) {
         next if $rr->type ne 'PTR';
         $hits++;
-        $self->{_args}{ptr_hosts}{ $rr->ptrdname } = 1;
+        $self->{_args}{ptr_hosts}{$rr->ptrdname} = 1;
-        $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname );
+        $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname);
-    };
+    }
-    if ( ! $hits ) {
+    if (!$hits) {
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
-        $self->log( LOGINFO, "fail, no PTR records");
+        $self->log(LOGINFO, "fail, no PTR records");
         return;
-    };
+    }
 
     $self->log(LOGDEBUG, "has rDNS");
     return 1;
-};
+}
 
 sub has_forward_dns {
-    my ( $self ) = @_;
+    my ($self) = @_;
 
     my $res = $self->init_resolver();
 
-    foreach my $host ( keys %{ $self->{_args}{ptr_hosts} } ) {
+    foreach my $host (keys %{$self->{_args}{ptr_hosts}}) {
 
-        $host .= '.' if '.' ne substr( $host, -1, 1); # fully qualify name
+        $host .= '.' if '.' ne substr($host, -1, 1);    # fully qualify name
         my $query = $res->search($host) or do {
-            if ( $res->errorstring eq 'NXDOMAIN' ) {
+            if ($res->errorstring eq 'NXDOMAIN') {
-                $self->log(LOGDEBUG, "host $host does not exist" );
+                $self->log(LOGDEBUG, "host $host does not exist");
                 next;
             }
-            $self->log(LOGDEBUG, "query for $host failed (", $res->errorstring, ")" );
+            $self->log(LOGDEBUG, "query for $host failed (",
+                       $res->errorstring, ")");
             next;
         };
 
@@ -230,38 +232,39 @@ sub has_forward_dns {
         foreach my $rr ($query->answer) {
             next unless $rr->type =~ /^(?:A|AAAA)$/;
             $hits++;
-            $self->check_ip_match( $rr->address ) and return 1;
+            $self->check_ip_match($rr->address) and return 1;
         }
-        if ( $hits ) {
+        if ($hits) {
             $self->log(LOGDEBUG, "PTR host has forward DNS") if $hits;
             return 1;
-        };
+        }
-    };
+    }
-    $self->adjust_karma( -1 );
+    $self->adjust_karma(-1);
     $self->log(LOGINFO, "fail, no PTR hosts have forward DNS");
     return;
-};
+}
 
 sub check_ip_match {
     my $self = shift;
     my $ip = shift or return;
 
-    if ( $ip eq $self->qp->connection->remote_ip ) {
+    if ($ip eq $self->qp->connection->remote_ip) {
-        $self->log( LOGDEBUG, "forward ip match" );
+        $self->log(LOGDEBUG, "forward ip match");
         $self->connection->notes('fcrdns_match', 1);
-        $self->adjust_karma( 1 );
+        $self->adjust_karma(1);
         return 1;
-    };
+    }
 
-# TODO: make this IPv6 compatible
+    # TODO: make this IPv6 compatible
-    my $dns_net = join('.', (split(/\./, $ip))[0,1,2] );
+    my $dns_net = join('.', (split(/\./, $ip))[0, 1, 2]);
-    my $rem_net = join('.', (split(/\./, $self->qp->connection->remote_ip))[0,1,2] );
+    my $rem_net =
+      join('.', (split(/\./, $self->qp->connection->remote_ip))[0, 1, 2]);
 
-    if ( $dns_net eq $rem_net ) {
+    if ($dns_net eq $rem_net) {
-        $self->log( LOGNOTICE, "forward network match" );
+        $self->log(LOGNOTICE, "forward network match");
         $self->connection->notes('fcrdns_match', 1);
         return 1;
-    };
+    }
     return;
-};
+}
 

plugins/greylisting

@@ -176,47 +176,51 @@ use AnyDBM_File;
 use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
 use Net::IP;
 
-my $DENYMSG  = "This mail is temporarily denied";
+my $DENYMSG        = "This mail is temporarily denied";
-my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
+my ($QPHOME)       = ($0 =~ m!(.*?)/([^/]+)$!);
-my $DB       = "greylist.dbm";
+my $DB             = "greylist.dbm";
 my %PERMITTED_ARGS = map { $_ => 1 } qw(per_recipient remote_ip sender
   recipient black_timeout grey_timeout white_timeout deny_late db_dir
   nfslock p0f reject loglevel geoip upgrade );
 
 my %DEFAULTS = (
-    remote_ip => 1,
+                remote_ip     => 1,
-    sender    => 0,
+                sender        => 0,
-    recipient => 0,
+                recipient     => 0,
-    reject    => 1,
+                reject        => 1,
-    black_timeout => 50 * 60,             # 50m
+                black_timeout => 50 * 60,               # 50m
-    grey_timeout  =>  3 * 3600 + 20 * 60, # 3h:20m
+                grey_timeout  => 3 * 3600 + 20 * 60,    # 3h:20m
-    white_timeout => 36 * 3600 * 24,      # 36 days
+                white_timeout => 36 * 3600 * 24,        # 36 days
-    nfslock => 0,
+                nfslock       => 0,
-    p0f  => undef,
+                p0f           => undef,
-);
+               );
 
 sub register {
     my ($self, $qp, %arg) = @_;
-    my $config = { %DEFAULTS,
+    my $config = {
-        map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'),
+              %DEFAULTS,
-        %arg };
+              map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist'),
-    if (my @bad = grep { ! exists $PERMITTED_ARGS{$_} } sort keys %$config) {
+              %arg
-        $self->log(LOGALERT, "invalid parameter(s): " . join(',',@bad));
-    }
-    # backwards compatibility with deprecated 'mode' setting
-    if ( defined $config->{mode} && ! defined $config->{reject} ) {
-        $config->{reject} = $config->{mode} =~ /testonly|off/i ? 0 : 1;
     };
+    if (my @bad = grep { !exists $PERMITTED_ARGS{$_} } sort keys %$config) {
+        $self->log(LOGALERT, "invalid parameter(s): " . join(',', @bad));
+    }
+
+    # backwards compatibility with deprecated 'mode' setting
+    if (defined $config->{mode} && !defined $config->{reject}) {
+        $config->{reject} = $config->{mode} =~ /testonly|off/i ? 0 : 1;
+    }
     $self->{_args} = $config;
     unless ($config->{recipient} || $config->{per_recipient}) {
         $self->register_hook('mail', 'mail_handler');
-    } else {
+    }
+    else {
         $self->register_hook('rcpt', 'rcpt_handler');
     }
     $self->prune_db();
-    if ( $self->{_args}{upgrade} ) {
+    if ($self->{_args}{upgrade}) {
         $self->convert_db();
-    };
+    }
 }
 
 sub mail_handler {
@@ -226,144 +230,159 @@ sub mail_handler {
 
     return DECLINED if $status != DENYSOFT;
 
-    if ( ! $self->{_args}{deny_late} ) {
+    if (!$self->{_args}{deny_late}) {
         return (DENYSOFT, $msg);
-    };
+    }
 
     $transaction->notes('greylist', $msg);
     return DECLINED;
 }
 
 sub rcpt_handler {
-  my ($self, $transaction, $rcpt) = @_;
+    my ($self, $transaction, $rcpt) = @_;
-  # Load per_recipient configs
+
-  my $config = { %{$self->{_args}},
+    # Load per_recipient configs
-    map { split /\s+/, $_, 2 } $self->qp->config('denysoft_greylist', { rcpt => $rcpt }) };
+    my $config = {
-  # Check greylisting
+                  %{$self->{_args}},
-  my $sender = $transaction->sender;
+                  map { split /\s+/, $_, 2 }
-  my ($status, $msg) = $self->greylist($transaction, $sender, $rcpt, $config);
+                    $self->qp->config('denysoft_greylist', {rcpt => $rcpt})
-  if ($status == DENYSOFT) {
+                 };
-    # Deny here (per-rcpt) unless this is a <> sender, for smtp probes
+
-    return DENYSOFT, $msg if $sender->address;
+    # Check greylisting
-    $transaction->notes('greylist', $msg);
+    my $sender = $transaction->sender;
-  }
+    my ($status, $msg) = $self->greylist($transaction, $sender, $rcpt, $config);
-  return DECLINED;
+    if ($status == DENYSOFT) {
+
+        # Deny here (per-rcpt) unless this is a <> sender, for smtp probes
+        return DENYSOFT, $msg if $sender->address;
+        $transaction->notes('greylist', $msg);
+    }
+    return DECLINED;
 }
 
 sub hook_data {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
-  return DECLINED unless $transaction->notes('greylist');
+    return DECLINED unless $transaction->notes('greylist');
-  # Decline if ALL recipients are whitelisted
+
-  if (($transaction->notes('whitelistrcpt')||0) == scalar($transaction->recipients)) {
+    # Decline if ALL recipients are whitelisted
-    $self->log(LOGWARN,"skip: all recipients whitelisted");
+    if (($transaction->notes('whitelistrcpt') || 0) ==
-    return DECLINED;
+        scalar($transaction->recipients))
-  }
+    {
-  return DENYSOFT, $transaction->notes('greylist');
+        $self->log(LOGWARN, "skip: all recipients whitelisted");
+        return DECLINED;
+    }
+    return DENYSOFT, $transaction->notes('greylist');
 }
 
 sub greylist {
     my ($self, $transaction, $sender, $rcpt, $config) = @_;
     $config ||= $self->{_args};
-    $self->log(LOGDEBUG, "config: " .
+    $self->log(LOGDEBUG,
-        join(',',map { $_ . '=' . $config->{$_} } sort keys %$config));
+               "config: "
+                 . join(',',
+                        map { $_ . '=' . $config->{$_} } sort keys %$config)
+              );
 
     return DECLINED if $self->is_immune();
-    return DECLINED if ! $self->is_p0f_match();
+    return DECLINED if !$self->is_p0f_match();
     return DECLINED if $self->geoip_match();
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $lock = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
-    my $key  = $self->get_db_key( $sender, $rcpt ) or return DECLINED;
+    my $key  = $self->get_db_key($sender, $rcpt) or return DECLINED;
 
-    my $fmt  = "%s:%d:%d:%d";
+    my $fmt = "%s:%d:%d:%d";
 
-# new IP or entry timed out - record new
+    # new IP or entry timed out - record new
-    if ( ! $tied->{$key} ) {
+    if (!$tied->{$key}) {
         $tied->{$key} = sprintf $fmt, time, 1, 0, 0;
         $self->log(LOGWARN, "fail: initial DENYSOFT, unknown");
-        return $self->cleanup_and_return( $tied, $lock );
+        return $self->cleanup_and_return($tied, $lock);
-    };
+    }
 
     my ($ts, $new, $black, $white) = split /:/, $tied->{$key};
     $self->log(LOGDEBUG, "ts: " . localtime($ts) . ", now: " . localtime);
 
-    if ( $white ) {
+    if ($white) {
-# white IP - accept unless timed out
+
+        # white IP - accept unless timed out
         if (time - $ts < $config->{white_timeout}) {
             $tied->{$key} = sprintf $fmt, time, $new, $black, ++$white;
             $self->log(LOGINFO, "pass: white, $white deliveries");
-            return $self->cleanup_and_return( $tied, $lock, DECLINED );
+            return $self->cleanup_and_return($tied, $lock, DECLINED);
         }
         else {
             $self->log(LOGINFO, "key $key has timed out (white)");
         }
-    };
-
-# Black IP - deny, but don't update timestamp
-    if (time - $ts < $config->{black_timeout}) {
-        $tied->{$key} = sprintf $fmt, $ts, $new, ++$black, 0;
-        $self->log(LOGWARN, "fail: black DENYSOFT - $black deferred connections");
-        return $self->cleanup_and_return( $tied, $lock );
     }
 
-# Grey IP - accept unless timed out
+    # Black IP - deny, but don't update timestamp
+    if (time - $ts < $config->{black_timeout}) {
+        $tied->{$key} = sprintf $fmt, $ts, $new, ++$black, 0;
+        $self->log(LOGWARN,
+                   "fail: black DENYSOFT - $black deferred connections");
+        return $self->cleanup_and_return($tied, $lock);
+    }
+
+    # Grey IP - accept unless timed out
     elsif (time - $ts < $config->{grey_timeout}) {
         $tied->{$key} = sprintf $fmt, time, $new, $black, 1;
         $self->log(LOGWARN, "pass: updated grey->white");
-        return $self->cleanup_and_return( $tied, $lock, DECLINED );
+        return $self->cleanup_and_return($tied, $lock, DECLINED);
     }
 
     $self->log(LOGWARN, "pass: timed out (grey)");
-    return $self->cleanup_and_return( $tied, $lock, DECLINED );
+    return $self->cleanup_and_return($tied, $lock, DECLINED);
 }
 
 sub cleanup_and_return {
-    my ($self, $tied, $lock, $return_val ) = @_;
+    my ($self, $tied, $lock, $return_val) = @_;
 
     untie $tied;
     close $lock;
-    return $return_val if defined $return_val;  # explicit override
+    return $return_val if defined $return_val;    # explicit override
-    return DECLINED if defined $self->{_args}{reject} && ! $self->{_args}{reject};
+    return DECLINED
+      if defined $self->{_args}{reject} && !$self->{_args}{reject};
     return (DENYSOFT, $DENYMSG);
-};
+}
 
 sub get_db_key {
-    my $self = shift;
+    my $self   = shift;
     my $sender = shift || $self->qp->transaction->sender;
-    my $rcpt = shift || ($self->qp->transaction->recipients)[0];
+    my $rcpt   = shift || ($self->qp->transaction->recipients)[0];
 
     my @key;
-    if ( $self->{_args}{remote_ip} ) {
+    if ($self->{_args}{remote_ip}) {
-        my $nip = Net::IP->new( $self->qp->connection->remote_ip );
+        my $nip = Net::IP->new($self->qp->connection->remote_ip);
-        push @key, $nip->intip;             # convert IP to integer
+        push @key, $nip->intip;    # convert IP to integer
-    };
+    }
 
     push @key, $sender->address || '' if $self->{_args}{sender};
-    push @key, $rcpt->address         if $rcpt && $self->{_args}{recipient};
+    push @key, $rcpt->address if $rcpt && $self->{_args}{recipient};
-    if ( ! scalar @key ) {
+    if (!scalar @key) {
         $self->log(LOGERROR, "enable one of remote_ip, sender, or recipient!");
         return;
-    };
+    }
     return join ':', @key;
-};
+}
 
 sub get_db_tie {
-    my ( $self, $db, $lock ) = @_;
+    my ($self, $db, $lock) = @_;
 
-    tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do {
+    tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
         $self->log(LOGCRIT, "tie to database $db failed: $!");
         close $lock;
         return;
     };
     return \%db;
-};
+}
 
 sub get_db_location {
     my $self = shift;
 
     my $transaction = $self->qp->transaction;
-    my $config = $self->{_args};
+    my $config      = $self->{_args};
 
     if ($config->{db_dir} && $config->{db_dir} =~ m{^([-a-zA-Z0-9./_]+)$}) {
         $config->{db_dir} = $1;
@@ -371,25 +390,28 @@ sub get_db_location {
 
     # Setup database location
     my $dbdir;
-    if ( $config->{per_recipient_db} ) {
+    if ($config->{per_recipient_db}) {
         $dbdir = $transaction->notes('per_rcpt_configdir');
-    };
+    }
 
-    my @candidate_dirs = ( $dbdir, $config->{db_dir},
+    my @candidate_dirs = (
-        "/var/lib/qpsmtpd/greylisting", "$QPHOME/var/db", "$QPHOME/config", '.' );
+                          $dbdir, $config->{db_dir},
+                          "/var/lib/qpsmtpd/greylisting",
+                          "$QPHOME/var/db", "$QPHOME/config", '.'
+                         );
 
-    for my $d ( @candidate_dirs ) {
+    for my $d (@candidate_dirs) {
-        next if ! $d || ! -d $d;   # impossible
+        next if !$d || !-d $d;    # impossible
         $dbdir = $d;
-        last;   # first match wins
+        last;                     # first match wins
     }
     my $db = "$dbdir/$DB";
-    if ( ! -f $db && -f "$dbdir/denysoft_greylist.dbm" ) {
+    if (!-f $db && -f "$dbdir/denysoft_greylist.dbm") {
-        $db = "$dbdir/denysoft_greylist.dbm";  # old DB name
+        $db = "$dbdir/denysoft_greylist.dbm";    # old DB name
     }
-    $self->log(LOGDEBUG,"using $db as greylisting database");
+    $self->log(LOGDEBUG, "using $db as greylisting database");
     return $db;
-};
+}
 
 sub get_db_lock {
     my ($self, $db) = @_;
@@ -397,12 +419,12 @@ sub get_db_lock {
     return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock};
 
     # Check denysoft db
-    open( my $lock, ">$db.lock" ) or do {
+    open(my $lock, ">$db.lock") or do {
         $self->log(LOGCRIT, "opening lockfile failed: $!");
         return;
     };
 
-    flock( $lock, LOCK_EX ) or do {
+    flock($lock, LOCK_EX) or do {
         $self->log(LOGCRIT, "flock of lockfile failed: $!");
         close $lock;
         return;
@@ -418,110 +440,111 @@ sub get_db_lock_nfs {
 
     ### set up a lock - lasts until object looses scope
     my $nfslock = new File::NFSLock {
-        file      => "$db.lock",
+                             file               => "$db.lock",
-        lock_type => LOCK_EX|LOCK_NB,
+                             lock_type          => LOCK_EX | LOCK_NB,
-        blocking_timeout   => 10,      # 10 sec
+                             blocking_timeout   => 10,                  # 10 sec
-        stale_lock_timeout => 30 * 60, # 30 min
+                             stale_lock_timeout => 30 * 60,             # 30 min
-    } or do {
+                                    }
+      or do {
         $self->log(LOGCRIT, "nfs lockfile failed: $!");
         return;
-    };
+      };
 
-    open( my $lock, "+<$db.lock") or do {
+    open(my $lock, "+<$db.lock") or do {
         $self->log(LOGCRIT, "opening nfs lockfile failed: $!");
         return;
     };
 
     return $lock;
-};
+}
 
 sub convert_db {
     my $self = shift;
 
-    my $db   = $self->get_db_location();
+    my $db    = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $lock  = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $tied  = $self->get_db_tie($db, $lock) or return DECLINED;
     my $count = keys %$tied;
 
     my $converted = 0;
-    foreach my $key ( keys %$tied ) {
+    foreach my $key (keys %$tied) {
-        my ( @parts ) = split /:/, $key;
+        my (@parts) = split /:/, $key;
-        next if $parts[0] =~ /^[\d]+$/;      # already converted
+        next if $parts[0] =~ /^[\d]+$/;    # already converted
         $converted++;
-        my $nip = Net::IP->new( $parts[0] );
+        my $nip = Net::IP->new($parts[0]);
-        $parts[0] = $nip->intip;             # convert IP to integer
+        $parts[0] = $nip->intip;           # convert IP to integer
         my $new_key = join ':', @parts;
         $tied->{$new_key} = $tied->{$key};
         delete $tied->{$key};
-    };
+    }
     untie $tied;
     close $lock;
-    $self->log( LOGINFO, "converted $converted of $count DB entries" );
+    $self->log(LOGINFO, "converted $converted of $count DB entries");
-    return $self->cleanup_and_return( $tied, $lock, DECLINED );
+    return $self->cleanup_and_return($tied, $lock, DECLINED);
-};
+}
 
 sub prune_db {
     my $self = shift;
 
-    my $db   = $self->get_db_location();
+    my $db    = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $lock  = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $tied  = $self->get_db_tie($db, $lock) or return DECLINED;
     my $count = keys %$tied;
 
     my $pruned = 0;
-    foreach my $key ( keys %$tied ) {
+    foreach my $key (keys %$tied) {
         my ($ts, $new, $black, $white) = split /:/, $tied->{$key};
         my $age = time - $ts;
         next if $age < $self->{_args}{white_timeout};
         $pruned++;
         delete $tied->{$key};
-    };
+    }
     untie $tied;
     close $lock;
-    $self->log( LOGINFO, "pruned $pruned of $count DB entries" );
+    $self->log(LOGINFO, "pruned $pruned of $count DB entries");
-    return $self->cleanup_and_return( $tied, $lock, DECLINED );
+    return $self->cleanup_and_return($tied, $lock, DECLINED);
-};
+}
 
 sub p0f_match {
     my $self = shift;
 
-    return if ! $self->{_args}{p0f};
+    return if !$self->{_args}{p0f};
 
     my $p0f = $self->connection->notes('p0f');
-    if ( !$p0f || !ref $p0f ) {   # p0f fingerprint info not found
+    if (!$p0f || !ref $p0f) {    # p0f fingerprint info not found
         $self->LOGINFO(LOGERROR, "p0f info missing");
         return;
-    };
+    }
 
     my %valid_matches = map { $_ => 1 } qw( genre detail uptime link distance );
-    my %requested_matches = split(/\,/, $self->{_args}{p0f} );
+    my %requested_matches = split(/\,/, $self->{_args}{p0f});
 
     foreach my $key (keys %requested_matches) {
-        next if ! $key;
+        next if !$key;
-        if ( ! defined $valid_matches{$key} ) {
+        if (!defined $valid_matches{$key}) {
-            $self->log(LOGERROR, "discarding invalid match key ($key)" );
+            $self->log(LOGERROR, "discarding invalid match key ($key)");
             next;
-        };
+        }
         my $value = $requested_matches{$key};
-        next if ! defined $value;       # bad config setting?
+        next if !defined $value;          # bad config setting?
-        next if ! defined $p0f->{$key}; # p0f didn't detect the value
+        next if !defined $p0f->{$key};    # p0f didn't detect the value
 
-        if ( $key eq 'distance' && $p0f->{$key} > $value ) {
+        if ($key eq 'distance' && $p0f->{$key} > $value) {
             $self->log(LOGDEBUG, "p0f distance match ($value)");
             return 1;
-        };
+        }
-        if ( $key eq 'genre'    && $p0f->{$key} =~ /$value/i ) {
+        if ($key eq 'genre' && $p0f->{$key} =~ /$value/i) {
             $self->log(LOGDEBUG, "p0f genre match ($value)");
             return 1;
-        };
+        }
-        if ( $key eq 'uptime'   && $p0f->{$key} < $value ) {
+        if ($key eq 'uptime' && $p0f->{$key} < $value) {
             $self->log(LOGDEBUG, "p0f uptime match ($value)");
             return 1;
-        };
+        }
-        if ( $key eq 'link'     && $p0f->{$key} =~ /$value/i ) {
+        if ($key eq 'link' && $p0f->{$key} =~ /$value/i) {
             $self->log(LOGDEBUG, "p0f link match ($value)");
             return 1;
-        };
+        }
     }
     $self->log(LOGINFO, "skip: no p0f match");
     return;
@@ -530,21 +553,21 @@ sub p0f_match {
 sub geoip_match {
     my $self = shift;
 
-    return if ! $self->{_args}{geoip};
+    return if !$self->{_args}{geoip};
 
     my $country = $self->connection->notes('geoip_country');
-    my $c_name  = $self->connection->notes('geoip_country_name') || '';
+    my $c_name = $self->connection->notes('geoip_country_name') || '';
 
-    if ( !$country ) {
+    if (!$country) {
         $self->LOGINFO(LOGNOTICE, "skip: no geoip country");
         return;
-    };
+    }
 
     my @countries = split /,/, $self->{_args}{geoip};
-    foreach ( @countries ) {
+    foreach (@countries) {
         $self->LOGINFO(LOGINFO, "pass: geoip country match ($_, $c_name)");
         return 1 if lc $_ eq lc $country;
-    };
+    }
 
     $self->LOGINFO(LOGINFO, "skip: no geoip match ($c_name)");
     return;

plugins/headers

@@ -97,71 +97,73 @@ use Qpsmtpd::Constants;
 use Date::Parse qw(str2time);
 
 my @required_headers = qw/ From /;  # <- to be RFC 5322 compliant, add Date here
+
 #my @should_headers   = qw/ Message-ID /;
 my @singular_headers = qw/ Date From Sender Reply-To To Cc Bcc
-                           Message-Id In-Reply-To References
+  Message-Id In-Reply-To References
-                           Subject /;
+  Subject /;
 
 sub register {
-    my ($self, $qp ) = (shift, shift);
+    my ($self, $qp) = (shift, shift);
 
     $self->log(LOGWARN, "invalid arguments") if @_ % 2;
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
 
-    $self->{_args}{reject_type} ||= 'perm';   # set default
+    $self->{_args}{reject_type} ||= 'perm';    # set default
-    if ( ! defined $self->{_args}{reject} ) {
+    if (!defined $self->{_args}{reject}) {
-         $self->{_args}{reject} = 1;          # set default
+        $self->{_args}{reject} = 1;            # set default
-    };
+    }
 
-    if ( $self->{_args}{require} ) {
+    if ($self->{_args}{require}) {
         @required_headers = split /,/, $self->{_args}{require};
-    };
+    }
 }
 
 sub hook_data_post {
     my ($self, $transaction) = @_;
 
-    if ( $transaction->data_size == 0 ) {
+    if ($transaction->data_size == 0) {
-        return $self->get_reject( "You must send some data first", "no data" );
+        return $self->get_reject("You must send some data first", "no data");
-    };
+    }
 
     my $header = $transaction->header or do {
-        return $self->get_reject( "Headers are missing", "missing headers" );
+        return $self->get_reject("Headers are missing", "missing headers");
     };
 
     return (DECLINED, "immune") if $self->is_immune();
 
-    foreach my $h ( @required_headers ) {
+    foreach my $h (@required_headers) {
         next if $header->get($h);
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
-        return $self->get_reject( "We require a valid $h header", "no $h header");
+        return $self->get_reject("We require a valid $h header",
-    };
+                                 "no $h header");
+    }
 
-    foreach my $h ( @singular_headers ) {
+    foreach my $h (@singular_headers) {
-        next if ! $header->get($h);          # doesn't exist
+        next if !$header->get($h);    # doesn't exist
         my @qty = $header->get($h);
-        next if @qty == 1;                   # only 1 header
+        next if @qty == 1;            # only 1 header
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
-        return $self->get_reject(
+        return
-            "Only one $h header allowed. See RFC 5322, Section 3.6",
+          $self->get_reject(
-            "too many $h headers",
+                        "Only one $h header allowed. See RFC 5322, Section 3.6",
-        );
+                        "too many $h headers",);
-    };
+    }
 
     my $err_msg = $self->invalid_date_range();
-    if ( $err_msg ) {
+    if ($err_msg) {
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
         return $self->get_reject($err_msg, $err_msg);
-    };
+    }
 
-    $self->log( LOGINFO, 'pass' );
+    $self->log(LOGINFO, 'pass');
     return (DECLINED);
-};
+}
 
 sub invalid_date_range {
     my $self = shift;
 
-    return if ! $self->transaction->header;
+    return if !$self->transaction->header;
     my $date = shift || $self->transaction->header->get('Date') or return;
     chomp $date;
 
@@ -171,16 +173,16 @@ sub invalid_date_range {
     };
 
     my $past = $self->{_args}{past};
-    if ( $past && $ts < time - ($past*24*3600) ) {
+    if ($past && $ts < time - ($past * 24 * 3600)) {
         $self->log(LOGINFO, "fail, date too old ($date)");
         return "The Date header is too far in the past";
-    };
+    }
 
     my $future = $self->{_args}{future};
-    if ( $future && $ts > time + ($future*24*3600) ) {
+    if ($future && $ts > time + ($future * 24 * 3600)) {
         $self->log(LOGINFO, "fail, date in future ($date)");
         return "The Date header is too far in the future";
-    };
+    }
 
     return;
 }

plugins/helo

@@ -225,40 +225,40 @@ use Qpsmtpd::Constants;
 
 sub register {
     my ($self, $qp) = (shift, shift);
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
 
     $self->{_args}{reject_type} = 'disconnect';
     $self->{_args}{policy} ||= 'lenient';
     $self->{_args}{dns_timeout} ||= $self->{_args}{timeout} || 5;
 
-    if ( ! defined $self->{_args}{reject} ) {
+    if (!defined $self->{_args}{reject}) {
         $self->{_args}{reject} = 1;
-    };
+    }
     $self->populate_tests();
     $self->init_resolver() or return;
 
-    $self->register_hook('helo', 'helo_handler');
+    $self->register_hook('helo',      'helo_handler');
-    $self->register_hook('ehlo', 'helo_handler');
+    $self->register_hook('ehlo',      'helo_handler');
     $self->register_hook('data_post', 'data_post_handler');
-};
+}
 
 sub helo_handler {
     my ($self, $transaction, $host) = @_;
 
-    if ( ! $host ) {
+    if (!$host) {
         $self->log(LOGINFO, "fail, no helo host");
         return DECLINED;
-    };
+    }
 
     return DECLINED if $self->is_immune();
 
-    foreach my $test ( @{ $self->{_helo_tests} } ) {
+    foreach my $test (@{$self->{_helo_tests}}) {
-        my @err = $self->$test( $host );
+        my @err = $self->$test($host);
-        if ( scalar @err ) {
+        if (scalar @err) {
-            $self->adjust_karma( -1 );
+            $self->adjust_karma(-1);
-            return $self->get_reject( @err );
+            return $self->get_reject(@err);
-        };
+        }
-    };
+    }
 
     $self->log(LOGINFO, "pass");
     return DECLINED;
@@ -268,239 +268,249 @@ sub data_post_handler {
     my ($self, $transaction) = @_;
 
     $transaction->header->delete('X-HELO');
-    $transaction->header->add('X-HELO', $self->qp->connection->hello_host, 0 );
+    $transaction->header->add('X-HELO', $self->qp->connection->hello_host, 0);
 
     return (DECLINED);
-};
+}
 
 sub populate_tests {
     my $self = shift;
 
     my $policy = $self->{_args}{policy};
-    @{ $self->{_helo_tests} } = qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /;
+    @{$self->{_helo_tests}} =
+      qw/ is_in_badhelo invalid_localhost is_forged_literal is_plain_ip /;
 
-    if ( $policy eq 'rfc' || $policy eq 'strict' ) {
+    if ($policy eq 'rfc' || $policy eq 'strict') {
-        push @{ $self->{_helo_tests} }, qw/ is_not_fqdn no_forward_dns no_reverse_dns /;
+        push @{$self->{_helo_tests}},
-    };
+          qw/ is_not_fqdn no_forward_dns no_reverse_dns /;
+    }
 
-    if ( $policy eq 'strict' ) {
+    if ($policy eq 'strict') {
-        push @{ $self->{_helo_tests} }, qw/ is_address_literal no_matching_dns /;
+        push @{$self->{_helo_tests}}, qw/ is_address_literal no_matching_dns /;
-    };
+    }
-};
+}
 
 sub is_in_badhelo {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
 
     my $error = "I do not believe you are $host.";
 
     $host = lc $host;
     foreach my $bad ($self->qp->config('badhelo')) {
-        if ( $bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/ ) { # it's a regexp
+        if ($bad =~ /[\{\}\[\]\(\)\^\$\|\*\+\?\\\!]/) {    # it's a regexp
-            return $self->is_regex_match( $host, $bad );
+            return $self->is_regex_match($host, $bad);
-        };
+        }
-        if ( $host eq lc $bad) {
+        if ($host eq lc $bad) {
             return ($error, "in badhelo");
         }
     }
     return;
-};
+}
 
 sub is_regex_match {
-    my ( $self, $host, $pattern ) = @_;
+    my ($self, $host, $pattern) = @_;
 
     my $error = "Your HELO hostname is not allowed";
 
     #$self->log( LOGDEBUG, "is regex ($pattern)");
-    if ( substr( $pattern, 0, 1) eq '!' ) {
+    if (substr($pattern, 0, 1) eq '!') {
         $pattern = substr $pattern, 1;
-        if ( $host !~ /$pattern/ ) {
+        if ($host !~ /$pattern/) {
+
             #$self->log( LOGDEBUG, "matched ($pattern)");
             return ($error, "badhelo pattern match ($pattern)");
-        };
+        }
         return;
     }
-    if ( $host =~ /$pattern/ ) {
+    if ($host =~ /$pattern/) {
+
         #$self->log( LOGDEBUG, "matched ($pattern)");
         return ($error, "badhelo pattern match ($pattern)");
-    };
+    }
     return;
 }
 
 sub invalid_localhost {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
     return if lc $host ne 'localhost';
-    if ( $self->qp->connection->remote_ip ne '127.0.0.1' ) {
+    if ($self->qp->connection->remote_ip ne '127.0.0.1') {
+
         #$self->log( LOGINFO, "fail, not localhost" );
         return ("You are not localhost", "invalid localhost");
-    };
+    }
-    $self->log( LOGDEBUG, "pass, is localhost" );
+    $self->log(LOGDEBUG, "pass, is localhost");
     return;
-};
+}
 
 sub is_plain_ip {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
-    return if $host =~ /[^\d\.]+/;  # has chars other than digits and a dot
+    return if $host =~ /[^\d\.]+/;    # has chars other than digits and a dot
     return if $host !~ m/^(\d{1,3}\.){3}\d{1,3}$/;
 
-    $self->log( LOGDEBUG, "fail, plain IP" );
+    $self->log(LOGDEBUG, "fail, plain IP");
     return ("Plain IP is invalid HELO hostname (RFC 2821)", "plain IP");
-};
+}
 
 sub is_address_literal {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
     return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
 
-    $self->log( LOGDEBUG, "fail, bracketed IP" );
+    $self->log(LOGDEBUG, "fail, bracketed IP");
-    return ("RFC 2821 allows an address literal, but we do not", "bracketed IP");
+    return ("RFC 2821 allows an address literal, but we do not",
-};
+            "bracketed IP");
+}
 
 sub is_forged_literal {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
     return if $host !~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;
 
-# should we add exceptions for reserved internal IP space? (192.168,10., etc?)
+  # should we add exceptions for reserved internal IP space? (192.168,10., etc?)
     $host = substr $host, 1, -1;
     return if $host eq $self->qp->connection->remote_ip;
     return ("Forged IPs not accepted here", "forged IP literal");
-};
+}
 
 sub is_not_fqdn {
     my ($self, $host) = @_;
-    return if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;  # address literal, skip
+    return if $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/;   # address literal, skip
-    if ( $host !~ /\./ ) { # has no dots
+    if ($host !~ /\./) {                                 # has no dots
         return ("HELO name is not fully qualified. Read RFC 2821", "not FQDN");
-    };
+    }
-    if ( $host =~ /[^a-zA-Z0-9\-\.]/ ) {
+    if ($host =~ /[^a-zA-Z0-9\-\.]/) {
-        return ("HELO name contains invalid FQDN characters. Read RFC 1035", "invalid FQDN chars");
+        return ("HELO name contains invalid FQDN characters. Read RFC 1035",
-    };
+                "invalid FQDN chars");
+    }
     return;
-};
+}
 
 sub no_forward_dns {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
 
-    return if $self->is_address_literal( $host );
+    return if $self->is_address_literal($host);
 
     my $res = $self->init_resolver();
 
-    $host = "$host." if $host !~ /\.$/;   # fully qualify name
+    $host = "$host." if $host !~ /\.$/;    # fully qualify name
     my $query = $res->search($host);
 
-    if (! $query) {
+    if (!$query) {
-        if ( $res->errorstring eq 'NXDOMAIN' ) {
+        if ($res->errorstring eq 'NXDOMAIN') {
             return ("HELO hostname does not exist", "no such host");
         }
-        $self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")" );
+        $self->log(LOGERROR, "skip, query failed (", $res->errorstring, ")");
         return;
-    };
+    }
     my $hits = 0;
     foreach my $rr ($query->answer) {
         next unless $rr->type =~ /^(?:A|AAAA)$/;
-        $self->check_ip_match( $rr->address );
+        $self->check_ip_match($rr->address);
         $hits++;
         last if $self->connection->notes('helo_forward_match');
     }
-    if ( $hits ) {
+    if ($hits) {
         $self->log(LOGDEBUG, "pass, forward DNS") if $hits;
         return;
-    };
+    }
     return ("HELO hostname did not resolve", "no forward DNS");
-};
+}
 
 sub no_reverse_dns {
-    my ( $self, $host, $ip ) = @_;
+    my ($self, $host, $ip) = @_;
 
     my $res = $self->init_resolver();
     $ip ||= $self->qp->connection->remote_ip;
 
-    my $query = $res->query( $ip ) or do {
+    my $query = $res->query($ip) or do {
-        if ( $res->errorstring eq 'NXDOMAIN' ) {
+        if ($res->errorstring eq 'NXDOMAIN') {
             return ("no rDNS for $ip", "no rDNS");
-        };
+        }
-        $self->log( LOGINFO, $res->errorstring );
+        $self->log(LOGINFO, $res->errorstring);
-        return ("error getting reverse DNS for $ip", "rDNS " . $res->errorstring);
+        return ("error getting reverse DNS for $ip",
+                "rDNS " . $res->errorstring);
     };
 
     my $hits = 0;
     for my $rr ($query->answer) {
         next if $rr->type ne 'PTR';
-        $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname );
+        $self->log(LOGDEBUG, "PTR: " . $rr->ptrdname);
-        $self->check_name_match( lc $rr->ptrdname, lc $host );
+        $self->check_name_match(lc $rr->ptrdname, lc $host);
         $hits++;
-    };
+    }
-    if ( $hits ) {
+    if ($hits) {
         $self->log(LOGDEBUG, "has rDNS");
         return;
-    };
+    }
     return ("no reverse DNS for $ip", "no rDNS");
-};
+}
 
 sub no_matching_dns {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
 
-# this is called iprev, or "Forward-confirmed reverse DNS" and is discussed
+    # this is called iprev, or "Forward-confirmed reverse DNS" and is discussed
-# in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here
+    # in RFC 5451. FCrDNS is done for the remote IP in the fcrdns plugin. Here
-# we do it on the HELO hostname.
+    # we do it on the HELO hostname.
-# consider adding status to Authentication-Results header
+    # consider adding status to Authentication-Results header
 
-    if ( $self->connection->notes('helo_forward_match') &&
+    if (   $self->connection->notes('helo_forward_match')
-         $self->connection->notes('helo_reverse_match') ) {
+        && $self->connection->notes('helo_reverse_match'))
-        $self->log( LOGDEBUG, "foward and reverse match" );
+    {
-        $self->adjust_karma( 1 );  # a perfect match
+        $self->log(LOGDEBUG, "foward and reverse match");
-        return;
+        $self->adjust_karma(1);    # a perfect match
-    };
-
-    if ( $self->connection->notes('helo_forward_match') ) {
-        $self->log( LOGDEBUG, "name matches IP" );
         return;
     }
-    if ( $self->connection->notes('helo_reverse_match') ) {
-        $self->log( LOGDEBUG, "reverse matches name" );
-        return;
-    };
 
-    $self->log( LOGINFO, "fail, no forward or reverse DNS match" );
+    if ($self->connection->notes('helo_forward_match')) {
+        $self->log(LOGDEBUG, "name matches IP");
+        return;
+    }
+    if ($self->connection->notes('helo_reverse_match')) {
+        $self->log(LOGDEBUG, "reverse matches name");
+        return;
+    }
+
+    $self->log(LOGINFO, "fail, no forward or reverse DNS match");
     return ("That HELO hostname fails FCrDNS", "no matching DNS");
-};
+}
 
 sub check_ip_match {
     my $self = shift;
     my $ip = shift or return;
 
-    if ( $ip eq $self->qp->connection->remote_ip ) {
+    if ($ip eq $self->qp->connection->remote_ip) {
-        $self->log( LOGDEBUG, "forward ip match" );
+        $self->log(LOGDEBUG, "forward ip match");
         $self->connection->notes('helo_forward_match', 1);
         return;
-    };
+    }
 
-    my $dns_net = join('.', (split(/\./, $ip))[0,1,2] );
+    my $dns_net = join('.', (split(/\./, $ip))[0, 1, 2]);
-    my $rem_net = join('.', (split(/\./, $self->qp->connection->remote_ip))[0,1,2] );
+    my $rem_net =
+      join('.', (split(/\./, $self->qp->connection->remote_ip))[0, 1, 2]);
 
-    if ( $dns_net eq $rem_net ) {
+    if ($dns_net eq $rem_net) {
-        $self->log( LOGNOTICE, "forward network match" );
+        $self->log(LOGNOTICE, "forward network match");
         $self->connection->notes('helo_forward_match', 1);
-    };
+    }
-};
+}
 
 sub check_name_match {
     my $self = shift;
     my ($dns_name, $helo_name) = @_;
 
-    return if ! $dns_name;
+    return if !$dns_name;
-    return if split(/\./, $dns_name) < 2;  # not a FQDN
+    return if split(/\./, $dns_name) < 2;    # not a FQDN
 
-    if ( $dns_name eq $helo_name ) {
+    if ($dns_name eq $helo_name) {
-        $self->log( LOGDEBUG, "reverse name match" );
+        $self->log(LOGDEBUG, "reverse name match");
         $self->connection->notes('helo_reverse_match', 1);
         return;
-    };
+    }
 
-    my $dns_dom  = join('.', (split(/\./, $dns_name ))[-2,-1] );
+    my $dns_dom  = join('.', (split(/\./, $dns_name))[-2,  -1]);
-    my $helo_dom = join('.', (split(/\./, $helo_name))[-2,-1] );
+    my $helo_dom = join('.', (split(/\./, $helo_name))[-2, -1]);
 
-    if ( $dns_dom eq $helo_dom ) {
+    if ($dns_dom eq $helo_dom) {
-        $self->log( LOGNOTICE, "reverse domain match" );
+        $self->log(LOGNOTICE, "reverse domain match");
         $self->connection->notes('helo_reverse_match', 1);
-    };
+    }
-};
+}
 

plugins/help

@@ -42,15 +42,15 @@ The hard coded F<help/> path should be changed.
 my %config = ();
 
 sub register {
-    my ($self,$qp,%args) = @_;
+    my ($self, $qp, %args) = @_;
     my ($file, $cmd);
     unless (%args) {
         $config{help_dir} = './help/';
     }
     foreach (keys %args) {
-        /^(\w+)$/ or
+        /^(\w+)$/
-            $self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"), 
+          or $self->log(LOGWARN, "Invalid argument for the 'help' plugin $_"),
-            next;
+          next;
         $cmd = $1;
         if ($cmd eq 'not_implemented') {
             $config{'not_implemented'} = $args{'not_implemented'};
@@ -60,7 +60,7 @@ sub register {
             $file =~ m#^([\w\.\-/]+)$#
               or $self->log(LOGERROR,
                             "Invalid charachters in filename for command $cmd"),
-                next; 
+              next;
             $config{'help_dir'} = $1;
         }
         else {
@@ -68,16 +68,16 @@ sub register {
             $file =~ m#^([\w\.\-/]+)$#
               or $self->log(LOGERROR,
                             "Invalid charachters in filename for command $cmd"),
-                 next;
+              next;
             $file = $1;
             if ($file =~ m#/#) {
                 -e $file
                   or $self->log(LOGWARN, "No help file for command '$cmd'"),
-                     next;
+                  next;
             }
             else {
                 $file = "help/$file";
-                if (-e "help/$file") { ## FIXME: path
+                if (-e "help/$file") {    ## FIXME: path
                     $file = "help/$file";
                 }
                 else {
@@ -105,8 +105,8 @@ sub hook_help {
 
     $cmd = lc $args[0];
 
-    unless ($cmd =~ /^(\w+)$/) { # else someone could request 
+    unless ($cmd =~ /^(\w+)$/) {    # else someone could request
-                                 # "HELP ../../../../../../../../etc/passwd"
+                                    # "HELP ../../../../../../../../etc/passwd"
         $self->qp->respond(502, "Invalid command name");
         return DONE;
     }
@@ -114,24 +114,24 @@ sub hook_help {
 
     if (exists $config{$cmd}) {
         $help = read_helpfile($config{$cmd}, $cmd)
-            or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
+          or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
-               return OK, "No help available for SMTP command: $cmd";
+          return OK, "No help available for SMTP command: $cmd";
     }
-    elsif (exists $config{'help_dir'} && -e $config{'help_dir'}."/$cmd") {
+    elsif (exists $config{'help_dir'} && -e $config{'help_dir'} . "/$cmd") {
-        $help = read_helpfile($config{help_dir}."/$cmd", $cmd)
+        $help = read_helpfile($config{help_dir} . "/$cmd", $cmd)
-            or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
+          or $self->log(LOGERROR, "failed to open help file for $cmd: $!"),
-               return OK, "No help available for SMTP command: $cmd";
+          return OK, "No help available for SMTP command: $cmd";
     }
-    $help = "No help available for SMTP command: $cmd" # empty file
+    $help = "No help available for SMTP command: $cmd"    # empty file
       unless $help;
     return OK, split(/\n/, $help);
 }
 
 sub read_helpfile {
-    my ($file,$cmd) = @_;
+    my ($file, $cmd) = @_;
     my $help;
     open HELP, $file
-        or return undef;
+      or return undef;
     {
         local $/ = undef;
         $help = <HELP>;

plugins/hosts_allow

@@ -57,7 +57,7 @@ use Qpsmtpd::Constants;
 use Socket;
 
 sub hook_pre_connection {
-    my ($self,$transaction,%args) = @_;
+    my ($self, $transaction, %args) = @_;
 
     # remote_ip    => inet_ntoa($iaddr),
     # remote_port  => $port,
@@ -70,62 +70,62 @@ sub hook_pre_connection {
     my $max    = $args{max_conn_ip};
     my $karma  = $self->connection->notes('karma_history');
 
-    if ( $max ) {
+    if ($max) {
-        my $num_conn = 1; # seed with current value
+        my $num_conn = 1;                    # seed with current value
         my $raddr    = inet_aton($remote);
         foreach my $rip (@{$args{child_addrs}}) {
             ++$num_conn if (defined $rip && $rip eq $raddr);
         }
-        $max = $self->karma_bump( $karma, $max ) if defined $karma;
+        $max = $self->karma_bump($karma, $max) if defined $karma;
-        if ($num_conn > $max ) {
+        if ($num_conn > $max) {
             my $err_mess = "too many connections from $remote";
             $self->log(LOGINFO, "fail: $err_mess ($num_conn > $max)");
             return (DENYSOFT, "$err_mess, try again later");
         }
     }
 
-    my @r = $self->in_hosts_allow( $remote );
+    my @r = $self->in_hosts_allow($remote);
     return @r if scalar @r;
 
-    $self->log(LOGDEBUG, "pass" );
+    $self->log(LOGDEBUG, "pass");
     return (DECLINED);
 }
 
 sub in_hosts_allow {
-    my $self = shift;
+    my $self   = shift;
     my $remote = shift;
 
-    foreach ( $self->qp->config('hosts_allow') ) {
+    foreach ($self->qp->config('hosts_allow')) {
         s/^\s*//;    # trim leading whitespace
         my ($ipmask, $const, $message) = split /\s+/, $_, 3;
         next unless defined $const;
 
-        my ($net,$mask) = split /\//, $ipmask, 2;
+        my ($net, $mask) = split /\//, $ipmask, 2;
-        $mask = 32 if ! defined $mask;
+        $mask = 32 if !defined $mask;
-        $mask = pack "B32", "1"x($mask)."0"x(32-$mask);
+        $mask = pack "B32", "1" x ($mask) . "0" x (32 - $mask);
         if (join('.', unpack('C4', inet_aton($remote) & $mask)) eq $net) {
             $const = Qpsmtpd::Constants::return_code($const) || DECLINED;
-            if ( $const =~ /deny/i ) {
+            if ($const =~ /deny/i) {
-                $self->log( LOGINFO, "fail, $message" );
+                $self->log(LOGINFO, "fail, $message");
-            };
+            }
-            $self->log( LOGDEBUG, "pass, $const, $message" );
+            $self->log(LOGDEBUG, "pass, $const, $message");
-            return($const, $message);
+            return ($const, $message);
         }
     }
 
     return;
-};
+}
 
 sub karma_bump {
     my ($self, $karma, $max) = @_;
 
-    if ( $karma  > 5 ) {
+    if ($karma > 5) {
         $self->log(LOGDEBUG, "connect limit +3 for positive karma");
         return $max + 3;
-    };
+    }
-    if ( $karma <= 0 ) {
+    if ($karma <= 0) {
         $self->log(LOGINFO, "connect limit 1, karma $karma");
         return 1;
-    };
+    }
     return $max;
-};
+}

plugins/http_config

@@ -1,4 +1,5 @@
 #!perl -w
+
 =head1 NAME
 
 http_config
@@ -30,21 +31,22 @@ use LWP::Simple qw(get);
 my @urls;
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
-  @urls = @args;
+    @urls = @args;
 }
 
 sub hook_config {
-  my ($self, $transaction, $config) = @_; 
+    my ($self, $transaction, $config) = @_;
-  $self->log(LOGNOTICE, "http_config called with $config");
+    $self->log(LOGNOTICE, "http_config called with $config");
-  for my $url (@urls) {
+    for my $url (@urls) {
-    $self->log(LOGDEBUG, "http_config loading from $url");
+        $self->log(LOGDEBUG, "http_config loading from $url");
-    my @config = split /[\r\n]+/, (get "$url$config" || "");
+        my @config = split /[\r\n]+/, (get "$url$config" || "");
-    chomp @config;
+        chomp @config;
-    @config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config;
+        @config = grep { $_ and $_ !~ m/^\s*#/ and $_ =~ m/\S/ } @config;
-    close CF;
+        close CF;
-    # $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
+
-    return (OK, @config) if @config;
+# $self->log(LOGNOTICE, "returning http_config for $config ",Data::Dumper->Dump([\@config], [qw(config)]));
-  }
+        return (OK, @config) if @config;
-  return DECLINED;
+    }
+    return DECLINED;
 }

plugins/ident/geoip

@@ -111,22 +111,23 @@ use strict;
 use warnings;
 
 use Qpsmtpd::Constants;
+
 #use Geo::IP;     # eval'ed in register()
 #use Math::Trig;  # eval'ed in set_distance_gc
 
 sub register {
-    my ($self, $qp ) = shift, shift;
+    my ($self, $qp) = shift, shift;
 
     $self->log(LOGERROR, "Bad arguments") if @_ % 2;
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
-    $self->{_args}{db_dir}   ||= '/usr/local/share/GeoIP';
+    $self->{_args}{db_dir} ||= '/usr/local/share/GeoIP';
 
     eval 'use Geo::IP';
-    if ( $@ ) {
+    if ($@) {
         warn "could not load Geo::IP";
-        $self->log( LOGERROR, "could not load Geo::IP" );
+        $self->log(LOGERROR, "could not load Geo::IP");
         return;
-    };
+    }
 
 # Note that opening the GeoIP DB only in register has caused problems before:
 # https://github.com/smtpd/qpsmtpd/commit/29ea9516806e9a8ca6519fcf987dbd684793ebdd#plugins/ident/geoip
@@ -136,8 +137,8 @@ sub register {
 
     $self->init_my_country_code();
 
-    $self->register_hook( 'connect', 'connect_handler' );
+    $self->register_hook('connect', 'connect_handler');
-};
+}
 
 sub connect_handler {
     my $self = shift;
@@ -146,7 +147,7 @@ sub connect_handler {
     $self->open_geoip_db();
 
     my $c_code = $self->set_country_code() or do {
-        $self->log( LOGINFO, "skip, no results" );
+        $self->log(LOGINFO, "skip, no results");
         return DECLINED;
     };
     $self->qp->connection->notes('geoip_country', $c_code);
@@ -154,24 +155,26 @@ sub connect_handler {
     my $c_name = $self->set_country_name();
     my ($city, $continent_code, $distance) = '';
 
-    if ( $self->{_my_country_code} ) {
+    if ($self->{_my_country_code}) {
-        $continent_code = $self->set_continent( $c_code );
+        $continent_code = $self->set_continent($c_code);
-        $city     = $self->set_city_gc();
+        $city           = $self->set_city_gc();
-        $distance = $self->set_distance_gc();
+        $distance       = $self->set_distance_gc();
-    };
+    }
 
     my @msg_parts;
-    push @msg_parts, $continent_code  if $continent_code && $continent_code ne '--';
+    push @msg_parts, $continent_code
-    push @msg_parts, $c_code          if $c_code;
+      if $continent_code && $continent_code ne '--';
+    push @msg_parts, $c_code if $c_code;
+
     #push @msg_parts, $c_name          if $c_name;
-    push @msg_parts, $city            if $city;
+    push @msg_parts, $city if $city;
-    if ( $distance ) {
+    if ($distance) {
         push @msg_parts, "\t$distance km";
-        if ( $self->{_args}{too_far} && $distance > $self->{_args}{too_far} ) {
+        if ($self->{_args}{too_far} && $distance > $self->{_args}{too_far}) {
-            $self->adjust_karma( -1 );
+            $self->adjust_karma(-1);
-        };
+        }
-    };
+    }
-    $self->log(LOGINFO, join( ", ", @msg_parts) );
+    $self->log(LOGINFO, join(", ", @msg_parts));
 
     return DECLINED;
 }
@@ -181,156 +184,159 @@ sub open_geoip_db {
 
     # this might detect if the DB connection failed. If not, this is where
     # to add more code to do it.
-    return if ( defined $self->{_geoip_city} || defined $self->{_geoip} );
+    return if (defined $self->{_geoip_city} || defined $self->{_geoip});
 
     # The methods for using GeoIP work differently for the City vs Country DB
     # save the handles in different locations
     my $db_dir = $self->{_args}{db_dir};
-    foreach my $db ( qw/ GeoIPCity GeoLiteCity / ) {
+    foreach my $db (qw/ GeoIPCity GeoLiteCity /) {
-        if ( -f "$db_dir/$db.dat" ) {
+        if (-f "$db_dir/$db.dat") {
             $self->log(LOGDEBUG, "using db $db");
-            $self->{_geoip_city} = Geo::IP->open( "$db_dir/$db.dat" );
+            $self->{_geoip_city} = Geo::IP->open("$db_dir/$db.dat");
         }
-    };
+    }
 
     # can't think of a good reason to load country if city data is present
-    if ( ! $self->{_geoip_city} ) {
+    if (!$self->{_geoip_city}) {
         $self->log(LOGDEBUG, "using default db");
-        $self->{_geoip} = Geo::IP->new();  # loads default Country DB
+        $self->{_geoip} = Geo::IP->new();    # loads default Country DB
-    };
+    }
-};
+}
 
 sub init_my_country_code {
     my $self = shift;
     my $ip = $self->{_args}{distance} or return;
-    $self->{_my_country_code} = $self->get_country_code( $ip );
+    $self->{_my_country_code} = $self->get_country_code($ip);
-};
+}
 
 sub set_country_code {
     my $self = shift;
     return $self->get_country_code_gc() if $self->{_geoip_city};
     my $remote_ip = $self->qp->connection->remote_ip;
-    my $code = $self->get_country_code();
+    my $code      = $self->get_country_code();
     $self->qp->connection->notes('geoip_country', $code);
     return $code;
-};
+}
 
 sub get_country_code {
     my $self = shift;
     my $ip = shift || $self->qp->connection->remote_ip;
-    return $self->get_country_code_gc( $ip ) if $self->{_geoip_city};
+    return $self->get_country_code_gc($ip) if $self->{_geoip_city};
-    return $self->{_geoip}->country_code_by_addr( $ip );
+    return $self->{_geoip}->country_code_by_addr($ip);
-};
+}
 
 sub get_country_code_gc {
     my $self = shift;
-    my $ip   = shift || $self->qp->connection->remote_ip;
+    my $ip = shift || $self->qp->connection->remote_ip;
-    $self->{_geoip_record} = $self->{_geoip_city}->record_by_addr($ip) or return;
+    $self->{_geoip_record} = $self->{_geoip_city}->record_by_addr($ip)
+      or return;
     return $self->{_geoip_record}->country_code;
-};
+}
 
 sub set_country_name {
     my $self = shift;
     return $self->set_country_name_gc() if $self->{_geoip_city};
     my $remote_ip = $self->qp->connection->remote_ip;
-    my $name = $self->{_geoip}->country_name_by_addr( $remote_ip ) or return;
+    my $name = $self->{_geoip}->country_name_by_addr($remote_ip) or return;
     $self->qp->connection->notes('geoip_country_name', $name);
     return $name;
-};
+}
 
 sub set_country_name_gc {
     my $self = shift;
-    return if ! $self->{_geoip_record};
+    return if !$self->{_geoip_record};
     my $remote_ip = $self->qp->connection->remote_ip;
     my $name = $self->{_geoip_record}->country_name() or return;
     $self->qp->connection->notes('geoip_country_name', $name);
     return $name;
-};
+}
 
 sub set_continent {
     my $self = shift;
     return $self->set_continent_gc() if $self->{_geoip_city};
     my $c_code = shift or return;
-    my $continent = $self->{_geoip}->continent_code_by_country_code( $c_code )
+    my $continent = $self->{_geoip}->continent_code_by_country_code($c_code)
-        or return;
+      or return;
     $self->qp->connection->notes('geoip_continent', $continent);
     return $continent;
-};
+}
 
 sub set_continent_gc {
     my $self = shift;
-    return if ! $self->{_geoip_record};
+    return if !$self->{_geoip_record};
     my $continent = $self->{_geoip_record}->continent_code() or return;
     $self->qp->connection->notes('geoip_continent', $continent);
     return $continent;
-};
+}
 
 sub set_city_gc {
     my $self = shift;
-    return if ! $self->{_geoip_record};
+    return if !$self->{_geoip_record};
     my $remote_ip = $self->qp->connection->remote_ip;
     my $city = $self->{_geoip_record}->city() or return;
     $self->qp->connection->notes('geoip_city', $city);
     return $city;
-};
+}
 
 sub set_distance_gc {
     my $self = shift;
-    return if ! $self->{_geoip_record};
+    return if !$self->{_geoip_record};
 
-    my ($self_lat, $self_lon) = $self->get_my_lat_lon() or return;
+    my ($self_lat,   $self_lon)   = $self->get_my_lat_lon()     or return;
     my ($sender_lat, $sender_lon) = $self->get_sender_lat_lon() or return;
 
     eval 'use Math::Trig qw(great_circle_distance deg2rad)';
-    if ( $@ ) {
+    if ($@) {
-        $self->log( LOGERROR, "can't calculate distance, Math::Trig not installed");
+        $self->log(LOGERROR,
+                   "can't calculate distance, Math::Trig not installed");
         return;
-    };
+    }
 
     # Notice the 90 - latitude: phi zero is at the North Pole.
-    sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) };
+    sub NESW { deg2rad($_[0]), deg2rad(90 - $_[1]) }
-    my @me     = NESW($self_lon, $self_lat );
+    my @me     = NESW($self_lon,   $self_lat);
     my @sender = NESW($sender_lon, $sender_lat);
-    my $km     = great_circle_distance(@me, @sender, 6378);
+    my $km = great_circle_distance(@me, @sender, 6378);
     $km = sprintf("%.0f", $km);
 
     $self->qp->connection->notes('geoip_distance', $km);
+
     #$self->log( LOGINFO, "distance $km km");
     return $km;
-};
+}
 
 sub get_my_lat_lon {
     my $self = shift;
-    return if ! $self->{_geoip_city};
+    return if !$self->{_geoip_city};
 
-    if ( $self->{_latitude} && $self->{_longitude} ) {
+    if ($self->{_latitude} && $self->{_longitude}) {
-        return ( $self->{_latitude}, $self->{_longitude} ); # cached
+        return ($self->{_latitude}, $self->{_longitude});    # cached
-    };
+    }
 
-    my $ip     = $self->{_args}{distance} or return;
+    my $ip = $self->{_args}{distance} or return;
     my $record = $self->{_geoip_city}->record_by_addr($ip) or do {
-        $self->log( LOGERROR, "no record for my Geo::IP location");
+        $self->log(LOGERROR, "no record for my Geo::IP location");
         return;
     };
 
     $self->{_latitude}  = $record->latitude();
     $self->{_longitude} = $record->longitude();
 
-    if ( ! $self->{_latitude} || ! $self->{_longitude} ) {
+    if (!$self->{_latitude} || !$self->{_longitude}) {
-        $self->log( LOGNOTICE, "could not get my lat/lon");
+        $self->log(LOGNOTICE, "could not get my lat/lon");
-    };
+    }
-    return ( $self->{_latitude}, $self->{_longitude} );
+    return ($self->{_latitude}, $self->{_longitude});
-};
+}
 
 sub get_sender_lat_lon {
     my $self = shift;
 
     my $lat = $self->{_geoip_record}->latitude();
     my $lon = $self->{_geoip_record}->longitude();
-    if ( ! $lat || ! $lon ) {
+    if (!$lat || !$lon) {
-        $self->log( LOGNOTICE, "could not get sender lat/lon");
+        $self->log(LOGNOTICE, "could not get sender lat/lon");
         return;
-    };
+    }
     return ($lat, $lon);
-};
+}
 

plugins/ident/p0f

@@ -140,7 +140,7 @@ use Net::IP;
 
 my $QUERY_MAGIC_V2 = 0x0defaced;
 my $QUERY_MAGIC_V3 = 0x50304601;
-my  $RESP_MAGIC_V3 = 0x50304602;
+my $RESP_MAGIC_V3  = 0x50304602;
 
 my $P0F_STATUS_BADQUERY = 0x00;
 my $P0F_STATUS_OK       = 0x10;
@@ -149,7 +149,7 @@ my $P0F_STATUS_NOMATCH  = 0x20;
 sub register {
     my ($self, $qp, $p0f_socket, %args) = @_;
 
-    $p0f_socket =~ /(.*)/; # untaint
+    $p0f_socket =~ /(.*)/;    # untaint
     $self->{_args}->{p0f_socket} = $1;
     foreach (keys %args) {
         $self->{_args}->{$_} = $args{$_};
@@ -157,18 +157,18 @@ sub register {
 }
 
 sub hook_connect {
-    my($self, $qp) = @_;
+    my ($self, $qp) = @_;
 
     my $p0f_version = $self->{_args}{version} || 3;
-    if ( $p0f_version == 3 ) {
+    if ($p0f_version == 3) {
         my $response = $self->query_p0f_v3() or return DECLINED;
-        $self->test_v3_response( $response ) or return DECLINED;
+        $self->test_v3_response($response) or return DECLINED;
-        $self->store_v3_results( $response );
+        $self->store_v3_results($response);
     }
     else {
         my $response = $self->query_p0f_v2() or return DECLINED;
-        $self->test_v2_response( $response ) or return DECLINED;
+        $self->test_v2_response($response) or return DECLINED;
-        $self->store_v2_results( $response );
+        $self->store_v2_results($response);
     }
 
     return DECLINED;
@@ -179,38 +179,41 @@ sub get_v2_query {
 
     my $local_ip = $self->{_args}{local_ip} || $self->qp->connection->local_ip;
 
-    my $src = new Net::IP ($self->qp->connection->remote_ip)
+    my $src = new Net::IP($self->qp->connection->remote_ip)
-        or $self->log(LOGERROR, "skip, ".Net::IP::Error()), return;
+      or $self->log(LOGERROR, "skip, " . Net::IP::Error()), return;
 
     my $dst = new Net::IP($local_ip)
-        or $self->log(LOGERROR, "skip, ".NET::IP::Error()), return;
+      or $self->log(LOGERROR, "skip, " . NET::IP::Error()), return;
 
-    return pack("L L L N N S S",
+    return
-                   $QUERY_MAGIC_V2,
+      pack("L L L N N S S",
-                   1,
+           $QUERY_MAGIC_V2,
-                   rand ^ 42 ^ time,
+           1,
-                   $src->intip(),
+           rand ^ 42 ^ time,
-                   $dst->intip(),
+           $src->intip(),
-                   $self->qp->connection->remote_port,
+           $dst->intip(),
-                   $self->qp->connection->local_port);
+           $self->qp->connection->remote_port,
-};
+           $self->qp->connection->local_port);
+}
 
 sub get_v3_query {
     my $self = shift;
 
     my $src_ip = $self->qp->connection->remote_ip or do {
-        $self->log( LOGERROR, "skip, unable to determine remote IP");
+        $self->log(LOGERROR, "skip, unable to determine remote IP");
         return;
     };
 
-    if ( $src_ip =~ /:/ ) {   # IPv6
+    if ($src_ip =~ /:/) {    # IPv6
-        my @bits = split(/\:/, $src_ip );
+        my @bits = split(/\:/, $src_ip);
-        return pack( "L C C C C C C C C C C C C C C C C C", $QUERY_MAGIC_V3, 0x06, @bits );
+        return
-    };
+          pack("L C C C C C C C C C C C C C C C C C",
+               $QUERY_MAGIC_V3, 0x06, @bits);
+    }
 
     my @octets = split(/\./, $src_ip);
-    return pack( "L C C16", $QUERY_MAGIC_V3, 0x04, @octets );
+    return pack("L C C16", $QUERY_MAGIC_V3, 0x04, @octets);
-};
+}
 
 sub query_p0f_v3 {
     my $self = shift;
@@ -221,38 +224,39 @@ sub query_p0f_v3 {
     };
     my $query = $self->get_v3_query() or return;
 
-# Open the connection to p0f
+    # Open the connection to p0f
     my $sock;
     eval {
-        $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM );
+        $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM);
     };
-    if ( ! $sock ) {
+    if (!$sock) {
         $self->log(LOGERROR, "skip, could not open socket: $@");
         return;
+    }
+
+    $sock->autoflush(1);    # paranoid redundancy
+    $sock->connected or do {
+        $self->log(LOGERROR, "skip, socket not connected: $!");
+        return;
     };
 
-    $sock->autoflush(1);  # paranoid redundancy
-    $sock->connected or do {
-            $self->log(LOGERROR, "skip, socket not connected: $!");
-            return;
-        };
-
     my $sent = $sock->send($query, 0) or do {
-            $self->log(LOGERROR, "skip, send failed: $!");
+        $self->log(LOGERROR, "skip, send failed: $!");
-            return;
+        return;
-        };
+    };
 
-    print $sock $query;  # yes, this is redundant, but I get no response from p0f otherwise
+    print $sock $query
+      ;    # yes, this is redundant, but I get no response from p0f otherwise
 
     $self->log(LOGDEBUG, "sent $sent byte request");
 
     my $response;
-    $sock->recv( $response, 232 );
+    $sock->recv($response, 232);
     my $length = length $response;
     $self->log(LOGDEBUG, "received $length byte response");
     close $sock;
     return $response;
-};
+}
 
 sub query_p0f_v2 {
     my $self = shift;
@@ -262,24 +266,24 @@ sub query_p0f_v2 {
 
     # Open the connection to p0f
     socket(SOCK, PF_UNIX, SOCK_STREAM, 0)
-        or $self->log(LOGERROR, "socket: $!"), return;
+      or $self->log(LOGERROR, "socket: $!"), return;
     connect(SOCK, sockaddr_un($p0f_socket))
-        or $self->log(LOGERROR, "connect: $! ($p0f_socket)"), return;
+      or $self->log(LOGERROR, "connect: $! ($p0f_socket)"), return;
     defined syswrite SOCK, $query
-        or $self->log(LOGERROR, "write: $!"), close SOCK, return;
+      or $self->log(LOGERROR, "write: $!"), close SOCK, return;
 
     my $response;
     defined sysread SOCK, $response, 1024
-        or $self->log(LOGERROR, "read: $!"), close SOCK, return;
+      or $self->log(LOGERROR, "read: $!"), close SOCK, return;
     close SOCK;
     return $response;
-};
+}
 
 sub test_v2_response {
-    my ($self, $response ) = @_;
+    my ($self, $response) = @_;
 
     # Extract part of the p0f response
-    my ($magic, $id, $type) = unpack ("L L C", $response);
+    my ($magic, $id, $type) = unpack("L L C", $response);
 
     # $self->log(LOGERROR, $response);
     if ($magic != $QUERY_MAGIC_V2) {
@@ -296,84 +300,87 @@ sub test_v2_response {
         return;
     }
     return 1;
-};
+}
 
 sub test_v3_response {
-    my ($self, $response ) = @_;
+    my ($self, $response) = @_;
 
-    my ($magic,$status) = unpack ("L L", $response);
+    my ($magic, $status) = unpack("L L", $response);
 
     # check the magic response value (a p0f constant)
-    if ($magic != $RESP_MAGIC_V3 ) {
+    if ($magic != $RESP_MAGIC_V3) {
         $self->log(LOGERROR, "skip, Bad response magic.");
         return;
     }
 
     # check the response status
-    if ($status == $P0F_STATUS_BADQUERY ) {
+    if ($status == $P0F_STATUS_BADQUERY) {
         $self->log(LOGERROR, "skip, bad query");
         return;
     }
-    elsif ($status == $P0F_STATUS_NOMATCH ) {
+    elsif ($status == $P0F_STATUS_NOMATCH) {
         $self->log(LOGINFO, "skip, no match");
         return;
     }
-    if ($status == $P0F_STATUS_OK ) {
+    if ($status == $P0F_STATUS_OK) {
         $self->log(LOGDEBUG, "pass, query ok");
         return 1;
     }
     return;
-};
+}
 
 sub store_v2_results {
-    my ($self, $response ) = @_;
+    my ($self, $response) = @_;
 
-    my ($magic, $id, $type, $genre, $detail, $dist, $link, $tos, $fw,
+    my (
-        $nat, $real, $score, $mflags, $uptime) =
+        $magic, $id, $type, $genre, $detail, $dist,   $link,
-            unpack ("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);
+        $tos,   $fw, $nat,  $real,  $score,  $mflags, $uptime
+       )
+      = unpack("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);
 
     my $p0f = {
-        genre    => $genre,
+               genre    => $genre,
-        detail   => $detail,
+               detail   => $detail,
-        distance => $dist,
+               distance => $dist,
-        link     => $link,
+               link     => $link,
-        uptime   => $uptime,
+               uptime   => $uptime,
-    };
+              };
 
     $self->connection->notes('p0f', $p0f);
-    $self->log(LOGINFO, $genre." (".$detail.")");
+    $self->log(LOGINFO, $genre . " (" . $detail . ")");
-    $self->log(LOGERROR,"error: $@") if $@;
+    $self->log(LOGERROR, "error: $@") if $@;
     return $p0f;
-};
+}
 
 sub store_v3_results {
-    my ($self, $response ) = @_;
+    my ($self, $response) = @_;
 
     my @labels = qw/ magic status first_seen last_seen total_conn uptime_min
-        up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor
+      up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor
-        http_name http_flavor link_type language /;
+      http_name http_flavor link_type language /;
-    my @values = unpack ("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response);
+    my @values =
+      unpack("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response);
 
     my %r;
-    foreach my $i ( 0 .. ( scalar @labels -1 ) ) {
+    foreach my $i (0 .. (scalar @labels - 1)) {
-        next if ! defined $values[$i];
+        next if !defined $values[$i];
-        next if ! defined $values[$i];
+        next if !defined $values[$i];
-        $r{ $labels[$i] } = $values[$i];
+        $r{$labels[$i]} = $values[$i];
-    };
+    }
-    if ( $r{os_name} ) {                             # compat with p0f v2
+    if ($r{os_name}) {    # compat with p0f v2
         $r{genre}  = "$r{os_name} $r{os_flavor}";
         $r{link}   = $r{link_type} if $r{link_type};
         $r{uptime} = $r{uptime_min} if $r{uptime_min};
-    };
+    }
 
-    if ( $r{genre} && $self->{_args}{smite_os} ) {
+    if ($r{genre} && $self->{_args}{smite_os}) {
         my $sos = $self->{_args}{smite_os};
-        $self->adjust_karma( -1 ) if $r{genre} =~ /$sos/i;
+        $self->adjust_karma(-1) if $r{genre} =~ /$sos/i;
-    };
+    }
     $self->connection->notes('p0f', \%r);
-    $self->log(LOGINFO, "$r{os_name} $r{os_flavor}");
+    $self->log(LOGINFO,  "$r{os_name} $r{os_flavor}");
-    $self->log(LOGDEBUG, join(' ', @values ));
+    $self->log(LOGDEBUG, join(' ', @values));
-    $self->log(LOGERROR,"error: $@") if $@;
+    $self->log(LOGERROR, "error: $@") if $@;
     return \%r;
-};
+}
 

plugins/karma

@@ -231,113 +231,117 @@ use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
 use Net::IP;
 
 sub register {
-    my ($self, $qp ) = (shift, shift);
+    my ($self, $qp) = (shift, shift);
     $self->log(LOGERROR, "Bad arguments") if @_ % 2;
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
     $self->{_args}{negative}     ||= 1;
     $self->{_args}{penalty_days} ||= 1;
     $self->{_args}{reject_type}  ||= 'disconnect';
 
-    if ( ! defined $self->{_args}{reject} ) {
+    if (!defined $self->{_args}{reject}) {
         $self->{_args}{reject} = 'naughty';
-    };
+    }
+
     #$self->prune_db();    # keep the DB compact
-    $self->register_hook('connect',           'connect_handler');
+    $self->register_hook('connect',       'connect_handler');
-    $self->register_hook('data',              'data_handler'   );
+    $self->register_hook('data',          'data_handler');
-    $self->register_hook('disconnect',        'disconnect_handler');
+    $self->register_hook('disconnect',    'disconnect_handler');
-    $self->register_hook('received_line',     'rcpt_handler');
+    $self->register_hook('received_line', 'rcpt_handler');
 }
 
 sub hook_pre_connection {
-    my ($self,$transaction,%args) = @_;
+    my ($self, $transaction, %args) = @_;
 
     $self->connection->notes('karma_history', 0);
 
     my $remote_ip = $args{remote_ip};
+
     #my $max_conn = $args{max_conn_ip};
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $lock = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
-    my $key  = $self->get_db_key( $remote_ip ) or do {
+    my $key  = $self->get_db_key($remote_ip) or do {
-        $self->log( LOGINFO, "skip, unable to get DB key" );
+        $self->log(LOGINFO, "skip, unable to get DB key");
         return DECLINED;
     };
 
-    if ( ! $tied->{$key} ) {
+    if (!$tied->{$key}) {
         $self->log(LOGDEBUG, "pass, no record");
-        return $self->cleanup_and_return($tied, $lock );
+        return $self->cleanup_and_return($tied, $lock);
-    };
+    }
 
-    my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
+    my ($penalty_start_ts, $naughty, $nice, $connects) =
+      $self->parse_value($tied->{$key});
     $self->calc_karma($naughty, $nice);
-    return $self->cleanup_and_return($tied, $lock );
+    return $self->cleanup_and_return($tied, $lock);
-};
+}
 
 sub connect_handler {
     my $self = shift;
 
-    $self->connection->notes('karma', 0);  # default
+    $self->connection->notes('karma', 0);    # default
 
     return DECLINED if $self->is_immune();
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $lock = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
     my $key  = $self->get_db_key() or do {
-        $self->log( LOGINFO, "skip, unable to get DB key" );
+        $self->log(LOGINFO, "skip, unable to get DB key");
         return DECLINED;
     };
 
-    if ( ! $tied->{$key} ) {
+    if (!$tied->{$key}) {
         $self->log(LOGINFO, "pass, no record");
-        return $self->cleanup_and_return($tied, $lock );
+        return $self->cleanup_and_return($tied, $lock);
-    };
+    }
 
-    my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
+    my ($penalty_start_ts, $naughty, $nice, $connects) =
+      $self->parse_value($tied->{$key});
     my $summary = "$naughty naughty, $nice nice, $connects connects";
     my $karma = $self->calc_karma($naughty, $nice);
 
-    if ( ! $penalty_start_ts ) {
+    if (!$penalty_start_ts) {
         $self->log(LOGINFO, "pass, no penalty ($summary)");
-        return $self->cleanup_and_return($tied, $lock );
+        return $self->cleanup_and_return($tied, $lock);
-    };
+    }
 
     my $days_old = (time - $penalty_start_ts) / 86400;
-    if ( $days_old >= $self->{_args}{penalty_days} ) {
+    if ($days_old >= $self->{_args}{penalty_days}) {
         $self->log(LOGINFO, "pass, penalty expired ($summary)");
-        return $self->cleanup_and_return($tied, $lock );
+        return $self->cleanup_and_return($tied, $lock);
-    };
+    }
 
     $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
-    $self->cleanup_and_return($tied, $lock );
+    $self->cleanup_and_return($tied, $lock);
 
     my $left = sprintf "%.2f", $self->{_args}{penalty_days} - $days_old;
     my $mess = "You were naughty. You cannot connect for $left more days.";
 
-    return $self->get_reject( $mess, $karma );
+    return $self->get_reject($mess, $karma);
 }
 
 sub rcpt_handler {
     my ($self, $transaction, $recipient, %args) = @_;
 
     my $recipients = scalar $self->transaction->recipients;
-    return DECLINED if $recipients < 2;   # only one recipient
+    return DECLINED if $recipients < 2;    # only one recipient
 
     my $karma = $self->connection->notes('karma_history');
-    return DECLINED if $karma > 0;    # good karma, no limit
+    return DECLINED if $karma > 0;         # good karma, no limit
 
-#  limit # of recipients if host has negative or unknown karma
+    #  limit # of recipients if host has negative or unknown karma
-    return $self->get_reject( "too many recipients");
+    return $self->get_reject("too many recipients");
-};
+}
 
 sub data_handler {
     my ($self, $transaction) = @_;
-    return DECLINED if ! $self->qp->connection->relay_client;
+    return DECLINED if !$self->qp->connection->relay_client;
 
-    $self->adjust_karma( 5 ); # big karma boost for authenticated user/IP
+    $self->adjust_karma(5);    # big karma boost for authenticated user/IP
     return DECLINED;
-};
+}
 
 sub disconnect_handler {
     my $self = shift;
@@ -348,30 +352,31 @@ sub disconnect_handler {
     };
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $lock = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $tied = $self->get_db_tie($db, $lock) or return DECLINED;
     my $key  = $self->get_db_key();
 
-    my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
+    my ($penalty_start_ts, $naughty, $nice, $connects) =
-    my $history  = ($nice || 0) - $naughty;
+      $self->parse_value($tied->{$key});
+    my $history = ($nice || 0) - $naughty;
     my $log_mess = '';
 
-    if ( $karma < -1 ) {   # they achieved at least 2 strikes
+    if ($karma < -1) {    # they achieved at least 2 strikes
         $history--;
         my $negative_limit = 0 - $self->{_args}{negative};
-        if ( $history <= $negative_limit ) {
+        if ($history <= $negative_limit) {
-            if ( $nice == 0 && $history < -5 ) {
+            if ($nice == 0 && $history < -5) {
                 $log_mess = ", penalty box bonus!";
                 $penalty_start_ts = sprintf "%s", time + abs($history) * 86400;
             }
             else {
                 $penalty_start_ts = sprintf "%s", time;
-            };
+            }
             $log_mess = "negative, sent to penalty box" . $log_mess;
         }
         else {
             $log_mess = "negative";
-        };
+        }
     }
     elsif ($karma > 1) {
         $nice++;
@@ -380,84 +385,87 @@ sub disconnect_handler {
     else {
         $log_mess = "neutral";
     }
-    $self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)" );
+    $self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)");
 
     $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
-    return $self->cleanup_and_return($tied, $lock );
+    return $self->cleanup_and_return($tied, $lock);
 }
 
 sub parse_value {
     my ($self, $value) = @_;
 
     my $penalty_start_ts = my $naughty = my $nice = my $connects = 0;
-    if ( $value  ) {
+    if ($value) {
         ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $value;
         $penalty_start_ts ||= 0;
-        $nice    ||= 0;
+        $nice             ||= 0;
-        $naughty ||= 0;
+        $naughty          ||= 0;
-        $connects ||= 0;
+        $connects         ||= 0;
-    };
+    }
-    return ($penalty_start_ts, $naughty, $nice, $connects );
+    return ($penalty_start_ts, $naughty, $nice, $connects);
-};
+}
 
 sub calc_karma {
     my ($self, $naughty, $nice) = @_;
-    return 0 if ( ! $naughty && ! $nice );
+    return 0 if (!$naughty && !$nice);
 
-    my $karma = ( $nice || 0 ) - ( $naughty || 0 );
+    my $karma = ($nice || 0) - ($naughty || 0);
-    $self->connection->notes('karma_history', $karma );
+    $self->connection->notes('karma_history', $karma);
-    $self->adjust_karma( 1 ) if $karma > 10;
+    $self->adjust_karma(1) if $karma > 10;
     return $karma;
-};
+}
 
 sub cleanup_and_return {
-    my ($self, $tied, $lock, $return_val ) = @_;
+    my ($self, $tied, $lock, $return_val) = @_;
 
     untie $tied;
     close $lock;
-    return ($return_val) if defined $return_val;  # explicit override
+    return ($return_val) if defined $return_val;    # explicit override
     return (DECLINED);
-};
+}
 
 sub get_db_key {
     my $self = shift;
-    my $ip = shift || $self->qp->connection->remote_ip;
+    my $ip   = shift || $self->qp->connection->remote_ip;
-    my $nip = Net::IP->new( $ip ) or do {
+    my $nip  = Net::IP->new($ip) or do {
         $self->log(LOGERROR, "skip, unable to determine remote IP");
         return;
     };
-    return $nip->intip;   # convert IP to an int
+    return $nip->intip;                             # convert IP to an int
-};
+}
 
 sub get_db_tie {
-    my ( $self, $db, $lock ) = @_;
+    my ($self, $db, $lock) = @_;
 
-    tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do {
+    tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
         $self->log(LOGCRIT, "error, tie to database $db failed: $!");
         close $lock;
         return;
     };
     return \%db;
-};
+}
 
 sub get_db_location {
     my $self = shift;
 
     # Setup database location
     my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
-    my @candidate_dirs = ( $self->{args}{db_dir},
+    my @candidate_dirs = (
-        "/var/lib/qpsmtpd/karma", "$QPHOME/var/db", "$QPHOME/config", '.' );
+                          $self->{args}{db_dir},
+                          "/var/lib/qpsmtpd/karma", "$QPHOME/var/db",
+                          "$QPHOME/config", '.'
+                         );
 
     my $dbdir;
-    for my $d ( @candidate_dirs ) {
+    for my $d (@candidate_dirs) {
-        next if ! $d || ! -d $d;   # impossible
+        next if !$d || !-d $d;    # impossible
         $dbdir = $d;
-        last;   # first match wins
+        last;                     # first match wins
     }
     my $db = "$dbdir/karma.dbm";
-    $self->log(LOGDEBUG,"using $db as karma database");
+    $self->log(LOGDEBUG, "using $db as karma database");
     return $db;
-};
+}
 
 sub get_db_lock {
     my ($self, $db) = @_;
@@ -465,12 +473,12 @@ sub get_db_lock {
     return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock};
 
     # Check denysoft db
-    open( my $lock, ">$db.lock" ) or do {
+    open(my $lock, ">$db.lock") or do {
         $self->log(LOGCRIT, "error, opening lockfile failed: $!");
         return;
     };
 
-    flock( $lock, LOCK_EX ) or do {
+    flock($lock, LOCK_EX) or do {
         $self->log(LOGCRIT, "error, flock of lockfile failed: $!");
         close $lock;
         return;
@@ -486,42 +494,43 @@ sub get_db_lock_nfs {
 
     ### set up a lock - lasts until object looses scope
     my $nfslock = new File::NFSLock {
-        file      => "$db.lock",
+                             file               => "$db.lock",
-        lock_type => LOCK_EX|LOCK_NB,
+                             lock_type          => LOCK_EX | LOCK_NB,
-        blocking_timeout   => 10,      # 10 sec
+                             blocking_timeout   => 10,                  # 10 sec
-        stale_lock_timeout => 30 * 60, # 30 min
+                             stale_lock_timeout => 30 * 60,             # 30 min
-    } or do {
+                                    }
+      or do {
         $self->log(LOGCRIT, "error, nfs lockfile failed: $!");
         return;
-    };
+      };
 
-    open( my $lock, "+<$db.lock") or do {
+    open(my $lock, "+<$db.lock") or do {
         $self->log(LOGCRIT, "error, opening nfs lockfile failed: $!");
         return;
     };
 
     return $lock;
-};
+}
 
 sub prune_db {
     my $self = shift;
 
-    my $db   = $self->get_db_location();
+    my $db    = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $lock  = $self->get_db_lock($db) or return DECLINED;
-    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $tied  = $self->get_db_tie($db, $lock) or return DECLINED;
     my $count = keys %$tied;
 
     my $pruned = 0;
-    foreach my $key ( keys %$tied ) {
+    foreach my $key (keys %$tied) {
-        my $ts = $tied->{$key};
+        my $ts       = $tied->{$key};
-        my $days_old = ( time - $ts ) / 86400;
+        my $days_old = (time - $ts) / 86400;
         next if $days_old < $self->{_args}{penalty_days} * 2;
         delete $tied->{$key};
         $pruned++;
-    };
+    }
     untie $tied;
     close $lock;
-    $self->log( LOGINFO, "pruned $pruned of $count DB entries" );
+    $self->log(LOGINFO, "pruned $pruned of $count DB entries");
-    return $self->cleanup_and_return( $tied, $lock, DECLINED );
+    return $self->cleanup_and_return($tied, $lock, DECLINED);
-};
+}
 

plugins/karma_tool

@@ -11,27 +11,27 @@ use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
 use Net::IP qw(:PROC);
 use POSIX qw(strftime);
 
-my $self = bless( { args => { db_dir => 'config' }, }, 'Karma' );
+my $self = bless({args => {db_dir => 'config'},}, 'Karma');
 my $command = $ARGV[0];
 
-if ( ! $command ) {
+if (!$command) {
     $self->usage();
 }
-elsif ( $command eq 'capture' ) {
+elsif ($command eq 'capture') {
-    $self->capture( $ARGV[1] );
+    $self->capture($ARGV[1]);
 }
-elsif ( $command eq 'release' ) {
+elsif ($command eq 'release') {
-    $self->release( $ARGV[1] );
+    $self->release($ARGV[1]);
 }
-elsif ( $command eq 'prune' ) {
+elsif ($command eq 'prune') {
-    $self->prune_db( $ARGV[1] || 7 );
+    $self->prune_db($ARGV[1] || 7);
 }
-elsif ( $command eq 'search' && is_ip( $ARGV[1] ) ) {
+elsif ($command eq 'search' && is_ip($ARGV[1])) {
-    $self->show_ip( $ARGV[1] );
+    $self->show_ip($ARGV[1]);
 }
-elsif ( $command eq 'list' | $command eq 'search' ) {
+elsif ($command eq 'list' | $command eq 'search') {
     $self->main();
-};
+}
 
 exit(0);
 
@@ -54,157 +54,170 @@ prune takes no arguments.
   prunes database of entries older than 7 days
 
 EO_HELP
-;
+      ;
-};
+}
 
 sub capture {
     my $self = shift;
     my $ip = shift or return;
-    is_ip( $ip ) or do {
+    is_ip($ip) or do {
         warn "not an IP: $ip\n";
         return;
     };
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return;
+    my $lock = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $tied = $self->get_db_tie($db, $lock) or return;
-    my $key  = $self->get_db_key( $ip );
+    my $key  = $self->get_db_key($ip);
 
-    my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key};
+    my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
+      $tied->{$key};
 
-    $tied->{$key} = join(':', time, $naughty+1, $nice, $connects);
+    $tied->{$key} = join(':', time, $naughty + 1, $nice, $connects);
-    return $self->cleanup_and_return( $tied, $lock );
+    return $self->cleanup_and_return($tied, $lock);
-};
+}
 
 sub release {
     my $self = shift;
     my $ip = shift or return;
-    is_ip( $ip ) or do { warn "not an IP: $ip\n"; return; };
+    is_ip($ip) or do { warn "not an IP: $ip\n"; return; };
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return;
+    my $lock = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $tied = $self->get_db_tie($db, $lock) or return;
-    my $key  = $self->get_db_key( $ip );
+    my $key  = $self->get_db_key($ip);
 
-    my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key};
+    my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
+      $tied->{$key};
 
     $tied->{$key} = join(':', 0, 0, $nice, $connects);
-    return $self->cleanup_and_return( $tied, $lock );
+    return $self->cleanup_and_return($tied, $lock);
-};
+}
 
 sub show_ip {
     my $self = shift;
-    my $ip = shift or return;
+    my $ip   = shift or return;
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return;
+    my $lock = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $tied = $self->get_db_tie($db, $lock) or return;
-    my $key  = $self->get_db_key( $ip );
+    my $key  = $self->get_db_key($ip);
 
-    my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$key};
+    my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-    $naughty ||= 0;
+      $tied->{$key};
-    $nice    ||= 0;
+    $naughty  ||= 0;
+    $nice     ||= 0;
     $connects ||= 0;
     my $time_human = '';
-    if ( $penalty_start_ts ) {
+    if ($penalty_start_ts) {
         $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts;
-    };
+    }
-    my $hostname = `dig +short -x $ip` || ''; chomp $hostname;
+    my $hostname = `dig +short -x $ip` || '';
-    print "      IP Address                 Penalty        Naughty  Nice  Connects  Hostname\n";
+    chomp $hostname;
-    printf(" %-18s  %24s    %3s     %3s     %3s    %-30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname);
+    print
-};
+"      IP Address                 Penalty        Naughty  Nice  Connects  Hostname\n";
+    printf(" %-18s  %24s    %3s     %3s     %3s    %-30s\n",
+           $ip, $time_human, $naughty, $nice, $connects, $hostname);
+}
 
 sub main {
     my $self = shift;
 
     my $db   = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return;
+    my $lock = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $tied = $self->get_db_tie($db, $lock) or return;
     my %totals;
 
-    print "      IP Address                 Penalty        Naughty  Nice  Connects  Hostname\n";
+    print
-    foreach my $r ( sort keys %$tied ) {
+"      IP Address                 Penalty        Naughty  Nice  Connects  Hostname\n";
-        my $ip = ip_bintoip( ip_inttobin( $r, 4 ), 4);
+    foreach my $r (sort keys %$tied) {
-        my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$r};
+        my $ip = ip_bintoip(ip_inttobin($r, 4), 4);
-        $naughty ||= '';
+        my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-        $nice    ||= '';
+          $tied->{$r};
+        $naughty  ||= '';
+        $nice     ||= '';
         $connects ||= '';
         my $time_human = '';
-        if ( $command eq 'search' ) {
+        if ($command eq 'search') {
             my $search = $ARGV[1];
-            if ( $search eq 'nice' ) {
+            if ($search eq 'nice') {
-                next if ! $nice;
+                next if !$nice;
             }
-            elsif ( $search eq 'naughty' ) {
+            elsif ($search eq 'naughty') {
-                next if ! $naughty;
+                next if !$naughty;
             }
-            elsif ( $search eq 'both' ) {
+            elsif ($search eq 'both') {
-                next if ! $naughty || ! $nice;
+                next if !$naughty || !$nice;
             }
-            elsif ( is_ip( $ARGV[1] ) && $search ne $ip ) {
+            elsif (is_ip($ARGV[1]) && $search ne $ip) {
                 next;
             }
-        };
+        }
-        if ( $penalty_start_ts ) {
+        if ($penalty_start_ts) {
-            $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts;
+            $time_human = strftime "%a %b %e %H:%M",
-        };
+              localtime $penalty_start_ts;
+        }
         my $hostname = '';
-        if ( $naughty && $nice ) {
+        if ($naughty && $nice) {
+
             #$hostname = `dig +short -x $ip`; chomp $hostname;
-        };
+        }
-        printf(" %-18s  %24s    %3s     %3s     %3s    %30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname);
+        printf(" %-18s  %24s    %3s     %3s     %3s    %30s\n",
+               $ip, $time_human, $naughty, $nice, $connects, $hostname);
         $totals{naughty}  += $naughty  if $naughty;
         $totals{nice}     += $nice     if $nice;
         $totals{connects} += $connects if $connects;
-    };
+    }
     print Dumper(\%totals);
 }
 
 sub is_ip {
     my $ip = shift || $ARGV[0];
-    new Net::IP( $ip ) or return;
+    new Net::IP($ip) or return;
     return 1;
-};
+}
 
 sub cleanup_and_return {
-    my ($self, $tied, $lock ) = @_;
+    my ($self, $tied, $lock) = @_;
     untie $tied;
     close $lock;
-};
+}
 
 sub get_db_key {
     my $self = shift;
-    my $nip = Net::IP->new( shift ) or return;
+    my $nip = Net::IP->new(shift) or return;
-    return $nip->intip;   # convert IP to an int
+    return $nip->intip;    # convert IP to an int
-};
+}
 
 sub get_db_tie {
-    my ( $self, $db, $lock ) = @_;
+    my ($self, $db, $lock) = @_;
 
-    tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do {
+    tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
         warn "tie to database $db failed: $!";
         close $lock;
         return;
     };
     return \%db;
-};
+}
 
 sub get_db_location {
     my $self = shift;
 
     # Setup database location
-    my @candidate_dirs = ( $self->{args}{db_dir},
+    my @candidate_dirs = (
-        "/var/lib/qpsmtpd/karma", "./var/db", "./config", '.' );
+                          $self->{args}{db_dir},
+                          "/var/lib/qpsmtpd/karma", "./var/db", "./config", '.'
+                         );
 
     my $dbdir;
-    for my $d ( @candidate_dirs ) {
+    for my $d (@candidate_dirs) {
-        next if ! $d || ! -d $d;   # impossible
+        next if !$d || !-d $d;    # impossible
         $dbdir = $d;
-        last;   # first match wins
+        last;                     # first match wins
     }
     my $db = "$dbdir/karma.dbm";
     print "using karma db at $db\n";
     return $db;
-};
+}
 
 sub get_db_lock {
     my ($self, $db) = @_;
@@ -212,12 +225,12 @@ sub get_db_lock {
     return $self->get_db_lock_nfs($db) if $self->{_args}{nfslock};
 
     # Check denysoft db
-    open( my $lock, ">$db.lock" ) or do {
+    open(my $lock, ">$db.lock") or do {
         warn "opening lockfile failed: $!";
         return;
     };
 
-    flock( $lock, LOCK_EX ) or do {
+    flock($lock, LOCK_EX) or do {
         warn "flock of lockfile failed: $!";
         close $lock;
         return;
@@ -233,43 +246,44 @@ sub get_db_lock_nfs {
 
     ### set up a lock - lasts until object looses scope
     my $nfslock = new File::NFSLock {
-        file      => "$db.lock",
+                             file               => "$db.lock",
-        lock_type => LOCK_EX|LOCK_NB,
+                             lock_type          => LOCK_EX | LOCK_NB,
-        blocking_timeout   => 10,      # 10 sec
+                             blocking_timeout   => 10,                  # 10 sec
-        stale_lock_timeout => 30 * 60, # 30 min
+                             stale_lock_timeout => 30 * 60,             # 30 min
-    } or do {
+                                    }
+      or do {
         warn "nfs lockfile failed: $!";
         return;
-    };
+      };
 
-    open( my $lock, "+<$db.lock") or do {
+    open(my $lock, "+<$db.lock") or do {
         warn "opening nfs lockfile failed: $!";
         return;
     };
 
     return $lock;
-};
+}
 
 sub prune_db {
-    my $self = shift;
+    my $self       = shift;
     my $prune_days = shift;
 
-    my $db   = $self->get_db_location();
+    my $db    = $self->get_db_location();
-    my $lock = $self->get_db_lock( $db ) or return;
+    my $lock  = $self->get_db_lock($db) or return;
-    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $tied  = $self->get_db_tie($db, $lock) or return;
     my $count = keys %$tied;
 
     my $pruned = 0;
-    foreach my $key ( keys %$tied ) {
+    foreach my $key (keys %$tied) {
         my ($ts, $naughty, $nice, $connects) = split /:/, $tied->{$key};
-        my $days_old = ( time - $ts ) / 86400;
+        my $days_old = (time - $ts) / 86400;
         next if $days_old < $prune_days;
         delete $tied->{$key};
         $pruned++;
-    };
+    }
     untie $tied;
     close $lock;
     warn "pruned $pruned of $count DB entries";
-    return $self->cleanup_and_return( $tied, $lock );
+    return $self->cleanup_and_return($tied, $lock);
-};
+}
 

plugins/logging/adaptive

@@ -3,92 +3,93 @@
 # one level for DENY'd messages
 
 sub register {
-    my ( $self, $qp, %args ) = @_;
+    my ($self, $qp, %args) = @_;
 
     $self->{_minlevel} = LOGERROR;
-    if ( defined( $args{accept} ) ) {
+    if (defined($args{accept})) {
-        if ( $args{accept} =~ /^\d+$/ ) {
+        if ($args{accept} =~ /^\d+$/) {
             $self->{_minlevel} = $args{accept};
         }
         else {
-            $self->{_minlevel} = log_level( $args{accept} );
+            $self->{_minlevel} = log_level($args{accept});
         }
     }
 
     $self->{_maxlevel} = LOGWARN;
-    if ( defined( $args{reject} ) ) {
+    if (defined($args{reject})) {
-        if ( $args{reject} =~ /^\d+$/ ) {
+        if ($args{reject} =~ /^\d+$/) {
             $self->{_maxlevel} = $args{reject};
         }
         else {
-            $self->{_maxlevel} = log_level( $args{reject} );
+            $self->{_maxlevel} = log_level($args{reject});
         }
     }
 
     $self->{_prefix} = '`';
-    if ( defined $args{prefix} and $args{prefix} =~ /^(.+)$/ ) {
+    if (defined $args{prefix} and $args{prefix} =~ /^(.+)$/) {
         $self->{_prefix} = $1;
     }
 
     # If you want to capture this log entry with this plugin, you need to
     # wait until after you register the plugin
-    $self->log( LOGINFO, 'Initializing logging::adaptive plugin' );
+    $self->log(LOGINFO, 'Initializing logging::adaptive plugin');
 }
 
-sub hook_logging { # wlog
+sub hook_logging {    # wlog
-    my ( $self, $transaction, $trace, $hook, $plugin, @log ) = @_;
+    my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
 
     # Don't log your own log entries!  If this is the only logging plugin
     # then these lines will not be logged at all.  You can safely comment
     # out this line and it will not cause an infinite loop.
     return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
 
-    if ( defined $self->{_maxlevel} && $trace <= $self->{_maxlevel} ) {
+    if (defined $self->{_maxlevel} && $trace <= $self->{_maxlevel}) {
         warn join(
-            " ", $$.
+                  " ",
-            (
+                  $$
-                  defined $plugin ? " $plugin plugin:"
+                    . (
-                : defined $hook   ? " running plugin ($hook):"
+                         defined $plugin ? " $plugin plugin:"
-                : ""
+                       : defined $hook   ? " running plugin ($hook):"
-            ),
+                       :                   ""
-            @log
+                      ),
-          ),
+                  @log
+                 ),
           "\n"
           unless $log[0] =~ /logging::adaptive/;
-        push @{ $transaction->{_log} }, [ $trace, $hook, $plugin, @log ]
+        push @{$transaction->{_log}}, [$trace, $hook, $plugin, @log]
-          if ( defined $self->{_minlevel} && $trace <= $self->{_minlevel} );
+          if (defined $self->{_minlevel} && $trace <= $self->{_minlevel});
     }
 
     return DECLINED;
 }
 
-sub hook_deny { # dlog
+sub hook_deny {    # dlog
-    my ( $self, $transaction, $prev_hook, $return, $return_text ) = @_;
+    my ($self, $transaction, $prev_hook, $return, $return_text) = @_;
     $self->{_denied} = 1;
 }
 
-sub hook_reset_transaction { # slog
+sub hook_reset_transaction {    # slog
 
     # fires when a message is accepted
-    my ( $self, $transaction, @args ) = @_;
+    my ($self, $transaction, @args) = @_;
 
     return DECLINED if $self->{_denied};
 
-    foreach my $row ( @{ $transaction->{_log} } ) {
+    foreach my $row (@{$transaction->{_log}}) {
         next unless scalar @$row;    # skip over empty log lines
-        my ( $trace, $hook, $plugin, @log ) = @$row;
+        my ($trace, $hook, $plugin, @log) = @$row;
         warn join(
-            " ", $$,
+                  " ", $$,
-            $self->{_prefix}.
+                  $self->{_prefix}
-            (
+                    . (
-                  defined $plugin ? " $plugin plugin:"
+                         defined $plugin ? " $plugin plugin:"
-                : defined $hook   ? " running plugin ($hook):"
+                       : defined $hook   ? " running plugin ($hook):"
-                : ""
+                       :                   ""
-            ),
+                      ),
-            @log
+                  @log
-          ),
+                 ),
           "\n"
-          if ( $trace <= $self->{_minlevel} );
+          if ($trace <= $self->{_minlevel});
     }
 
     return DECLINED;

plugins/logging/apache

@@ -64,7 +64,7 @@ sub hook_logging {
                         . (
                              defined $plugin ? " $plugin plugin:"
                            : defined $hook   ? " running plugin ($hook):"
-                           : ""
+                           :                   ""
                           ),
                       @log
                      )

plugins/logging/connection_id

@@ -5,41 +5,48 @@
 # as how to ignore log entries from itself
 
 sub register {
-  my ($self, $qp, $loglevel) = @_;
+    my ($self, $qp, $loglevel) = @_;
-  die "The connection ID feature is currently unsupported";
+    die "The connection ID feature is currently unsupported";
-  $self->{_level} = LOGWARN;
+    $self->{_level} = LOGWARN;
-  if ( defined($loglevel) ) {
+    if (defined($loglevel)) {
-      if ($loglevel =~ /^\d+$/) {
+        if ($loglevel =~ /^\d+$/) {
-	  $self->{_level} = $loglevel;
+            $self->{_level} = $loglevel;
-      }
+        }
-      else {
+        else {
-	  $self->{_level} = log_level($loglevel);
+            $self->{_level} = log_level($loglevel);
-      }
+        }
-  }
+    }
 
-  # If you want to capture this log entry with this plugin, you need to
+    # If you want to capture this log entry with this plugin, you need to
-  # wait until after you register the plugin
+    # wait until after you register the plugin
-  $self->log(LOGINFO,'Initializing logging::connection_id plugin');
+    $self->log(LOGINFO, 'Initializing logging::connection_id plugin');
 }
 
 sub hook_logging {
-  my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
+    my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
 
-  # Don't log your own log entries!  If this is the only logging plugin
+    # Don't log your own log entries!  If this is the only logging plugin
-  # then these lines will not be logged at all.  You can safely comment
+    # then these lines will not be logged at all.  You can safely comment
-  # out this line and it will not cause an infinite loop.
+    # out this line and it will not cause an infinite loop.
-  return DECLINED if defined $plugin and $plugin eq $self->plugin_name; 
+    return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
 
-  my $connection = $self->qp && $self->qp->connection;
+    my $connection = $self->qp && $self->qp->connection;
-  # warn "connection = $connection\n";
-  warn 
-    join(" ", ($connection ? $connection->id : "???") .
-         (defined $plugin ? " $plugin plugin:" :
-          defined $hook   ? " running plugin ($hook):"  : ""),
-         @log), "\n"
-    if ($trace <= $self->{_level});
 
-  return DECLINED;
+    # warn "connection = $connection\n";
+    warn join(
+              " ",
+              ($connection ? $connection->id : "???")
+                . (
+                     defined $plugin ? " $plugin plugin:"
+                   : defined $hook   ? " running plugin ($hook):"
+                   :                   ""
+                  ),
+              @log
+             ),
+      "\n"
+      if ($trace <= $self->{_level});
+
+    return DECLINED;
 }
 
 =head1 NAME

plugins/logging/devnull

@@ -2,6 +2,6 @@
 # this is a simple 'drop packets on the floor' plugin
 
 sub hook_logging {
-  return DECLINED;
+    return DECLINED;
 }
 

plugins/logging/file

@@ -128,11 +128,11 @@ sub register {
     my %args;
 
     $self->{_loglevel} = LOGWARN;
-    $self->{_tsformat} = '%a %b %d %T %Y'; # same as scalar localtime
+    $self->{_tsformat} = '%a %b %d %T %Y';    # same as scalar localtime
 
     while (1) {
-    	last if !@args;
+        last if !@args;
-    	if (lc $args[0] eq 'loglevel') {
+        if (lc $args[0] eq 'loglevel') {
             shift @args;
             my $ll = shift @args;
             if (!defined $ll) {
@@ -147,19 +147,19 @@ sub register {
                 defined $self->{_loglevel} or $self->{_loglevel} = LOGWARN;
             }
         }
-	elsif (lc $args[0] eq 'nosplit') {
+        elsif (lc $args[0] eq 'nosplit') {
-		shift @args;
+            shift @args;
-		$self->{_nosplit} = 1;
+            $self->{_nosplit} = 1;
-	}
+        }
-	elsif (lc $args[0] eq 'reopen') {
+        elsif (lc $args[0] eq 'reopen') {
-		shift @args;
+            shift @args;
-		$self->{_reopen} = 1;
+            $self->{_reopen} = 1;
-	}
+        }
-	    elsif (lc $args[0] eq 'tsformat') {
+        elsif (lc $args[0] eq 'tsformat') {
-	        shift @args;
+            shift @args;
-	        my $format = shift @args;
+            my $format = shift @args;
-	        $self->{_tsformat} = $format;
+            $self->{_tsformat} = $format;
-	    }
+        }
         else { last }
     }
 
@@ -171,13 +171,14 @@ sub register {
     my $output = join(' ', @args);
 
     if ($output =~ /^\s*\|(.*)/) {
-    	$self->{_log_pipe} = 1;
+        $self->{_log_pipe}   = 1;
-        $self->{_log_format} = $1;
-    } else {
-        $output =~ /^(.*)/; # detaint
         $self->{_log_format} = $1;
     }
-    $self->{_current_output} = '';
+    else {
+        $output =~ /^(.*)/;    # detaint
+        $self->{_log_format} = $1;
+    }
+    $self->{_current_output}  = '';
     $self->{_session_counter} = 0;
     1;
 }
@@ -191,14 +192,15 @@ sub log_output {
 }
 
 sub open_log {
-    my ($self,$output,$qp) = @_;
+    my ($self, $output, $qp) = @_;
 
     if ($self->{_log_pipe}) {
         unless ($self->{_f} = new IO::File "|$output") {
             warn "Error opening log output to command $output: $!";
             return undef;
         }
-    } else {
+    }
+    else {
         unless ($self->{_f} = new IO::File ">>$output") {
             warn "Error opening log output to path $output: $!";
             return undef;
@@ -209,7 +211,6 @@ sub open_log {
     1;
 }
 
-
 # Reopen the output iff the interpolated output filename has changed
 # from the one currently open, or if reopening was selected and we haven't
 # yet done so during this session.
@@ -219,10 +220,13 @@ sub maybe_reopen {
     my ($self, $transaction) = @_;
 
     my $new_output = $self->log_output($transaction);
-    if (!$self->{_current_output} ||
+    if (
-        $self->{_current_output} ne $new_output ||
+          !$self->{_current_output}
-        ($self->{_reopen} &&
+        || $self->{_current_output} ne $new_output
-         !$transaction->notes('file-reopened-this-session'))) {
+        || ($self->{_reopen}
+            && !$transaction->notes('file-reopened-this-session'))
+       )
+    {
         unless ($self->open_log($new_output, $transaction)) {
             return undef;
         }
@@ -235,11 +239,14 @@ sub maybe_reopen {
 sub hook_connect {
     my ($self, $transaction) = @_;
 
-    $transaction->notes('file-logged-this-session', 0);
+    $transaction->notes('file-logged-this-session',   0);
     $transaction->notes('file-reopened-this-session', 0);
-    $transaction->notes('logging-session-id',
+    $transaction->notes(
-                sprintf("%08d-%04d-%d",
+                        'logging-session-id',
-                        scalar time, $$, ++$self->{_session_counter}));
+                        sprintf("%08d-%04d-%d",
+                                scalar time, $$,
+                                ++$self->{_session_counter})
+                       );
     return DECLINED;
 }
 
@@ -255,8 +262,9 @@ sub hook_disconnect {
 sub hook_logging {
     my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
 
-    return DECLINED if !defined $self->{_loglevel} or
+    return DECLINED
-                       $trace > $self->{_loglevel};
+      if !defined $self->{_loglevel}
+      or $trace > $self->{_loglevel};
     return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
 
     # Possibly reopen the log iff:
@@ -264,10 +272,11 @@ sub hook_logging {
     # - We're allowed to split sessions across logfiles
     # - We haven't logged anything yet this session
     # - We aren't in a session
-    if (!$self->{_f} ||
+    if (   !$self->{_f}
-        !$self->{_nosplit} ||
+        || !$self->{_nosplit}
-        !$transaction ||
+        || !$transaction
-        !$transaction->notes('file-logged-this-session')) {
+        || !$transaction->notes('file-logged-this-session'))
+    {
         unless (defined $self->maybe_reopen($transaction)) {
             return DECLINED;
         }
@@ -276,7 +285,7 @@ sub hook_logging {
 
     my $f = $self->{_f};
     print $f strftime($self->{_tsformat}, localtime), ' ',
-             hostname(), '[', $$, ']: ', @log, "\n";
+      hostname(), '[', $$, ']: ', @log, "\n";
     return DECLINED;
 }
 

plugins/logging/syslog

@@ -116,13 +116,14 @@ sub register {
 
     if (@args % 2 == 0) {
         %args = @args;
-    } else {
+    }
+    else {
         warn "Malformed arguments to syslog plugin";
         return;
     }
 
-    my $ident = 'qpsmtpd';
+    my $ident    = 'qpsmtpd';
-    my $logopt = 'pid';
+    my $logopt   = 'pid';
     my $facility = 'LOG_MAIL';
 
     $self->{_loglevel} = LOGWARN;
@@ -150,8 +151,8 @@ sub register {
     }
 
     if ($args{logsock}) {
-       my @logopt = split(/,/, $args{logsock});
+        my @logopt = split(/,/, $args{logsock});
-       setlogsock(@logopt);
+        setlogsock(@logopt);
     }
 
     unless (openlog $ident, $logopt, $facility) {
@@ -161,15 +162,15 @@ sub register {
 }
 
 my %priorities_ = (
-    0 => 'LOG_EMERG',
+                   0 => 'LOG_EMERG',
-    1 => 'LOG_ALERT',
+                   1 => 'LOG_ALERT',
-    2 => 'LOG_CRIT',
+                   2 => 'LOG_CRIT',
-    3 => 'LOG_ERR',
+                   3 => 'LOG_ERR',
-    4 => 'LOG_WARNING',
+                   4 => 'LOG_WARNING',
-    5 => 'LOG_NOTICE',
+                   5 => 'LOG_NOTICE',
-    6 => 'LOG_INFO',
+                   6 => 'LOG_INFO',
-    7 => 'LOG_DEBUG',
+                   7 => 'LOG_DEBUG',
-);
+                  );
 
 sub hook_logging {
     my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
@@ -177,8 +178,8 @@ sub hook_logging {
     return DECLINED if $trace > $self->{_loglevel};
     return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
 
-    my $priority = $self->{_priority} ?
+    my $priority =
-                   $self->{_priority} : $priorities_{$trace};
+      $self->{_priority} ? $self->{_priority} : $priorities_{$trace};
 
     syslog $priority, '%s', join(' ', @log);
     return DECLINED;

plugins/logging/transaction_id

@@ -5,40 +5,46 @@
 # as how to ignore log entries from itself
 
 sub register {
-  my ($self, $qp, $loglevel) = @_;
+    my ($self, $qp, $loglevel) = @_;
-  die "The transaction ID feature is currently unsupported";
+    die "The transaction ID feature is currently unsupported";
 
-  $self->{_level} = LOGWARN;
+    $self->{_level} = LOGWARN;
-  if ( defined($loglevel) ) {
+    if (defined($loglevel)) {
-      if ($loglevel =~ /^\d+$/) {
+        if ($loglevel =~ /^\d+$/) {
-	  $self->{_level} = $loglevel;
+            $self->{_level} = $loglevel;
-      }
+        }
-      else {
+        else {
-	  $self->{_level} = log_level($loglevel);
+            $self->{_level} = log_level($loglevel);
-      }
+        }
-  }
+    }
 
-  # If you want to capture this log entry with this plugin, you need to
+    # If you want to capture this log entry with this plugin, you need to
-  # wait until after you register the plugin
+    # wait until after you register the plugin
-  $self->log(LOGINFO,'Initializing logging::transaction_id plugin');
+    $self->log(LOGINFO, 'Initializing logging::transaction_id plugin');
 }
 
 sub hook_logging {
-  my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
+    my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
 
-  # Don't log your own log entries!  If this is the only logging plugin
+    # Don't log your own log entries!  If this is the only logging plugin
-  # then these lines will not be logged at all.  You can safely comment
+    # then these lines will not be logged at all.  You can safely comment
-  # out this line and it will not cause an infinite loop.
+    # out this line and it will not cause an infinite loop.
-  return DECLINED if defined $plugin and $plugin eq $self->plugin_name; 
+    return DECLINED if defined $plugin and $plugin eq $self->plugin_name;
 
-  warn 
+    warn join(
-    join(" ", ($transaction ? $transaction->id : "???") .
+              " ",
-         (defined $plugin ? " $plugin plugin:" :
+              ($transaction ? $transaction->id : "???")
-          defined $hook   ? " running plugin ($hook):"  : ""),
+                . (
-         @log), "\n"
+                     defined $plugin ? " $plugin plugin:"
-    if ($trace <= $self->{_level});
+                   : defined $hook   ? " running plugin ($hook):"
+                   :                   ""
+                  ),
+              @log
+             ),
+      "\n"
+      if ($trace <= $self->{_level});
 
-  return DECLINED;
+    return DECLINED;
 }
 
 =head1 NAME

plugins/logging/warn

@@ -38,36 +38,38 @@ Please see the LICENSE file included with qpsmtpd for details.
 =cut
 
 sub register {
-  my ($self, $qp, $loglevel) = @_;
+    my ($self, $qp, $loglevel) = @_;
 
-  $self->{_level} = LOGWARN;
+    $self->{_level} = LOGWARN;
-  if ( defined($loglevel) ) {
+    if (defined($loglevel)) {
-      if ($loglevel =~ /^\d+$/) {
+        if ($loglevel =~ /^\d+$/) {
-	  $self->{_level} = $loglevel;
+            $self->{_level} = $loglevel;
-      }
+        }
-      else {
+        else {
-	  $self->{_level} = log_level($loglevel);
+            $self->{_level} = log_level($loglevel);
-      }
+        }
-  }
+    }
 
-  # If you want to capture this log entry with this plugin, you need to
+    # If you want to capture this log entry with this plugin, you need to
-  # wait until after you register the plugin
+    # wait until after you register the plugin
-  $self->log(LOGINFO,'Initializing logging::warn plugin');
+    $self->log(LOGINFO, 'Initializing logging::warn plugin');
 }
 
 sub hook_logging {
-  my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
+    my ($self, $transaction, $trace, $hook, $plugin, @log) = @_;
 
-  # Don't log your own log entries!  If this is the only logging plugin
+    # Don't log your own log entries!  If this is the only logging plugin
-  # then these lines will not be logged at all.  You can safely comment
+    # then these lines will not be logged at all.  You can safely comment
-  # out this line and it will not cause an infinite loop.
+    # out this line and it will not cause an infinite loop.
     return DECLINED if defined $plugin && $plugin eq $self->plugin_name;
 
     return DECLINED if $trace > $self->{_level};
 
-    my $prefix = defined $plugin && defined $hook ? " ($hook) $plugin:" :
+    my $prefix =
-                 defined $plugin ? " $plugin:" :
+        defined $plugin && defined $hook ? " ($hook) $plugin:"
-                 defined $hook   ? " ($hook) running plugin:" : '';
+      : defined $plugin ? " $plugin:"
+      : defined $hook   ? " ($hook) running plugin:"
+      :                   '';
 
     warn join(' ', $$ . $prefix, @log), "\n";
 

plugins/loop

@@ -29,28 +29,30 @@ Released to the public domain, 17 June 2005.
 use Qpsmtpd::DSN;
 
 sub init {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  $self->{_max_hops} = $args[0] || 100;
+    $self->{_max_hops} = $args[0] || 100;
 
-  if ( $self->{_max_hops} !~ /^\d+$/ ) {
+    if ($self->{_max_hops} !~ /^\d+$/) {
-    $self->log(LOGWARN, "Invalid max_hops value -- using default");
+        $self->log(LOGWARN, "Invalid max_hops value -- using default");
-    $self->{_max_hops} = 100;
+        $self->{_max_hops} = 100;
-  }
+    }
-  $self->log(LOGWARN, "Ignoring additional arguments") if @args > 1;
+    $self->log(LOGWARN, "Ignoring additional arguments") if @args > 1;
 }
 
 sub hook_data_post {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  my $hops = 0;
+    my $hops = 0;
-  $hops++ for $transaction->header->get('Received'),
+    $hops++
-    $transaction->header->get('Delivered-To');
+      for $transaction->header->get('Received'),
+      $transaction->header->get('Delivered-To');
 
-  if ( $hops >= $self->{_max_hops} ) {
+    if ($hops >= $self->{_max_hops}) {
-    # default of too_many_hops is DENY, see comment in POD of Qpsmtpd::DSN
-    return Qpsmtpd::DSN->too_many_hops();
-  }
 
-  return DECLINED;
+        # default of too_many_hops is DENY, see comment in POD of Qpsmtpd::DSN
+        return Qpsmtpd::DSN->too_many_hops();
+    }
+
+    return DECLINED;
 }

plugins/milter

@@ -1,4 +1,5 @@
 #!perl -w
+
 =head1 NAME
 
 milter
@@ -31,18 +32,18 @@ use Qpsmtpd::Constants;
 no warnings;
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  die "Invalid milter setup args: '@args'" unless @args > 1;
+    die "Invalid milter setup args: '@args'" unless @args > 1;
-  my ($name, $port) = @args;
+    my ($name, $port) = @args;
-  my $host = '127.0.0.1';
+    my $host = '127.0.0.1';
-  if ($port =~ s/^(.*)://) {
+    if ($port =~ s/^(.*)://) {
-    $host = $1;
+        $host = $1;
-  }
+    }
 
-  $self->{name} = $name;
+    $self->{name} = $name;
-  $self->{host} = $host;
+    $self->{host} = $host;
-  $self->{port} = $port;
+    $self->{port} = $port;
 
 }
 
@@ -52,7 +53,7 @@ sub hook_disconnect {
     my $milter = $self->connection->notes('milter') || return DECLINED;
     $milter->send_quit();
 
-    $self->connection->notes('spam', undef);
+    $self->connection->notes('spam',   undef);
     $self->connection->notes('milter', undef);
 
     return DECLINED;
@@ -62,9 +63,11 @@ sub check_results {
     my ($self, $transaction, $where, @results) = @_;
     foreach my $result (@results) {
         next if $result->{action} eq 'continue';
-        $self->log(LOGINFO, "milter $self->{name} result action: $result->{action}");
+        $self->log(LOGINFO,
+                   "milter $self->{name} result action: $result->{action}");
         if ($result->{action} eq 'reject') {
-            die("Rejected at $where by $self->{name} milter ($result->{explanation})");
+            die(
+"Rejected at $where by $self->{name} milter ($result->{explanation})");
         }
         elsif ($result->{action} eq 'add') {
             if ($result->{header} eq 'body') {
@@ -72,19 +75,20 @@ sub check_results {
             }
             else {
                 push @{$transaction->notes('milter_header_changes')->{add}},
-                        [$result->{header}, $result->{value}];
+                  [$result->{header}, $result->{value}];
             }
         }
         elsif ($result->{action} eq 'delete') {
             push @{$transaction->notes('milter_header_changes')->{delete}},
-                $result->{header};
+              $result->{header};
         }
         elsif ($result->{action} eq 'accept') {
+
             # TODO - figure out what this is used for
         }
         elsif ($result->{action} eq 'replace') {
             push @{$transaction->notes('milter_header_changes')->{replace}},
-                    [$result->{header}, $result->{value}];
+              [$result->{header}, $result->{value}];
         }
     }
 }
@@ -92,7 +96,8 @@ sub check_results {
 sub hook_connect {
     my ($self, $transaction) = @_;
 
-    $self->log(LOGDEBUG, "milter $self->{name} opening connection to milter backend");
+    $self->log(LOGDEBUG,
+               "milter $self->{name} opening connection to milter backend");
     my $milter = Net::Milter->new();
     $milter->open($self->{host}, $self->{port}, 'tcp');
     $milter->protocol_negotiation();
@@ -100,15 +105,21 @@ sub hook_connect {
     $self->connection->notes(milter => $milter);
 
     $self->connection->notes(
-        milter_header_changes => { add => [], delete => [], replace => [], }
+            milter_header_changes => {add => [], delete => [], replace => [],});
-    );    
+    my $remote_ip   = $self->qp->connection->remote_ip;
-    my $remote_ip = $self->qp->connection->remote_ip;
     my $remote_host = $self->qp->connection->remote_host;
-    $self->log(LOGDEBUG, "milter $self->{name} checking connect from $remote_host\[$remote_ip\]");
+    $self->log(LOGDEBUG,
+         "milter $self->{name} checking connect from $remote_host\[$remote_ip\]"
+    );
 
     eval {
-        $self->check_results($transaction, "connection",
+        $self->check_results(
-            $milter->send_connect($remote_host, 'tcp4', 0, $remote_ip));
+                             $transaction,
+                             "connection",
+                             $milter->send_connect(
+                                             $remote_host, 'tcp4', 0, $remote_ip
+                                                  )
+                            );
     };
     $self->connection->notes('spam', $@) if $@;
 
@@ -129,9 +140,10 @@ sub hook_helo {
 
     $self->log(LOGDEBUG, "milter $self->{name} checking HELO $host");
 
-    eval { $self->check_results($transaction, "HELO",
+    eval {
-                                $milter->send_helo($host)) };
+        $self->check_results($transaction, "HELO", $milter->send_helo($host));
-    return(DENY, $@) if $@;
+    };
+    return (DENY, $@) if $@;
 
     return DECLINED;
 }
@@ -141,10 +153,13 @@ sub hook_mail {
 
     my $milter = $self->connection->notes('milter');
 
-    $self->log(LOGDEBUG, "milter $self->{name} checking MAIL FROM " . $address->format);
+    $self->log(LOGDEBUG,
-    eval { $self->check_results($transaction, "MAIL FROM",
+               "milter $self->{name} checking MAIL FROM " . $address->format);
-                                $milter->send_mail_from($address->format)) };
+    eval {
-    return(DENY, $@) if $@;
+        $self->check_results($transaction, "MAIL FROM",
+                             $milter->send_mail_from($address->format));
+    };
+    return (DENY, $@) if $@;
 
     return DECLINED;
 }
@@ -154,11 +169,14 @@ sub hook_rcpt {
 
     my $milter = $self->connection->notes('milter');
 
-    $self->log(LOGDEBUG, "milter $self->{name} checking RCPT TO " . $address->format);
+    $self->log(LOGDEBUG,
+               "milter $self->{name} checking RCPT TO " . $address->format);
 
-    eval { $self->check_results($transaction, "RCPT TO",
+    eval {
-                                $milter->send_rcpt_to($address->format)) };
+        $self->check_results($transaction, "RCPT TO",
-    return(DENY, $@) if $@;
+                             $milter->send_rcpt_to($address->format));
+    };
+    return (DENY, $@) if $@;
 
     return DECLINED;
 }
@@ -170,22 +188,28 @@ sub hook_data_post {
 
     $self->log(LOGDEBUG, "milter $self->{name} checking headers");
 
-    my $headers = $transaction->header(); # Mail::Header object
+    my $headers = $transaction->header();    # Mail::Header object
     foreach my $h ($headers->tags) {
+
         # munge these headers because milters prefer them this way
         $h =~ s/\b(\w)/\U$1/g;
         $h =~ s/\bid\b/ID/g;
         foreach my $val ($headers->get($h)) {
-            # $self->log(LOGDEBUG, "milter $self->{name} checking header: $h: $val");
+
-            eval { $self->check_results($transaction, "header $h",
+       # $self->log(LOGDEBUG, "milter $self->{name} checking header: $h: $val");
-                                $milter->send_header($h, $val)) };
+            eval {
-            return(DENY, $@) if $@;
+                $self->check_results($transaction, "header $h",
+                                     $milter->send_header($h, $val));
+            };
+            return (DENY, $@) if $@;
         }
     }
 
-    eval { $self->check_results($transaction, "end headers",
+    eval {
-                                $milter->send_end_headers()) };
+        $self->check_results($transaction, "end headers",
-    return(DENY, $@) if $@;
+                             $milter->send_end_headers());
+    };
+    return (DENY, $@) if $@;
 
     $transaction->body_resetpos;
 
@@ -202,23 +226,29 @@ sub hook_data_post {
     while (my $line = $transaction->body_getline) {
         $data .= $line;
         if (length($data) > 60000) {
-            eval { $self->check_results($transaction, "body",
+            eval {
-                                $milter->send_body($data)) };
+                $self->check_results($transaction, "body",
-            return(DENY, $@) if $@;
+                                     $milter->send_body($data));
+            };
+            return (DENY, $@) if $@;
             $data = '';
         }
     }
 
     if (length($data)) {
-        eval { $self->check_results($transaction, "body",
+        eval {
-                                $milter->send_body($data)) };
+            $self->check_results($transaction, "body",
-        return(DENY, $@) if $@;
+                                 $milter->send_body($data));
+        };
+        return (DENY, $@) if $@;
         $data = '';
     }
 
-    eval { $self->check_results($transaction, "end of DATA",
+    eval {
-                                $milter->send_end_body()) };
+        $self->check_results($transaction, "end of DATA",
-    return(DENY, $@) if $@;
+                             $milter->send_end_body());
+    };
+    return (DENY, $@) if $@;
 
     my $milter_header_changes = $transaction->notes('milter_header_changes');
 

plugins/naughty

@@ -109,28 +109,28 @@ use Qpsmtpd::Constants;
 sub register {
     my ($self, $qp) = (shift, shift);
     $self->log(LOGERROR, "Bad arguments") if @_ % 2;
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
-    $self->{_args}{reject} ||= 'rcpt';
+    $self->{_args}{reject}      ||= 'rcpt';
     $self->{_args}{reject_type} ||= 'disconnect';
 
     my $reject = lc $self->{_args}{reject};
-    my %hooks  = map { $_ => 1 }
+    my %hooks =
-        qw/ connect mail rcpt data data_post hook_queue_post /;
+      map { $_ => 1 } qw/ connect mail rcpt data data_post hook_queue_post /;
 
-    if ( ! $hooks{$reject} ) {
+    if (!$hooks{$reject}) {
-        $self->log( LOGERROR, "fail, invalid hook $reject" );
+        $self->log(LOGERROR, "fail, invalid hook $reject");
-        $self->register_hook( 'data_post', 'naughty');
+        $self->register_hook('data_post', 'naughty');
         return;
-    };
+    }
 
     # just in case naughty doesn't disconnect, which can happen if a plugin
     # with the same hook returned OK before naughty ran, or ....
-    if ( $reject ne 'data_post' && $reject ne 'hook_queue_post' ) {
+    if ($reject ne 'data_post' && $reject ne 'hook_queue_post') {
-        $self->register_hook( 'data_post', 'naughty');
+        $self->register_hook('data_post', 'naughty');
-    };
+    }
 
     $self->log(LOGDEBUG, "registering hook $reject");
-    $self->register_hook( $reject, 'naughty');
+    $self->register_hook($reject, 'naughty');
 }
 
 sub naughty {
@@ -140,8 +140,11 @@ sub naughty {
         return DECLINED;
     };
     $self->log(LOGINFO, "disconnecting");
-    my $type = $self->get_reject_type( 'disconnect',
+    my $type = $self->get_reject_type(
-        $self->connection->notes('naughty_reject_type') );
+                                      'disconnect',
-    return ( $type, $naughty );
+                                      $self->connection->notes(
-};
+                                                          'naughty_reject_type')
+                                     );
+    return ($type, $naughty);
+}
 

plugins/noop_counter

@@ -40,23 +40,23 @@ sub hook_noop {
 
     if ($self->{_noop_count} >= $self->{_max_noop}) {
         return (DENY_DISCONNECT,
-		"Stop wasting my time, too many consecutive NOOPs");
+                "Stop wasting my time, too many consecutive NOOPs");
     }
     return (DECLINED);
 }
 
 sub reset_noop_counter {
-   $_[0]->{_noop_count} = 0;
+    $_[0]->{_noop_count} = 0;
-   return (DECLINED);
+    return (DECLINED);
 }
 
 # and bind the counter reset to the hooks, QUIT not useful here:
-*hook_helo = *hook_ehlo =       # HELO / EHLO
+*hook_helo = *hook_ehlo =      # HELO / EHLO
-    *hook_mail =                # MAIL FROM: 
+  *hook_mail =                 # MAIL FROM:
-    *hook_rcpt =                # RCPT TO:
+  *hook_rcpt =                 # RCPT TO:
-    *hook_data =                # DATA
+  *hook_data =                 # DATA
-    *hook_reset_transaction =   # RSET
+  *hook_reset_transaction =    # RSET
-    *hook_vrfy =                # VRFY
+  *hook_vrfy =                 # VRFY
-    *hook_help =                # HELP
+  *hook_help =                 # HELP
-        \&reset_noop_counter;
+  \&reset_noop_counter;
 

plugins/parse_addr_withhelo

@@ -35,20 +35,20 @@ sub hook_rcpt_parse {
 }
 
 sub _parse {
-    my ($self,$cmd,$line) = @_;
+    my ($self, $cmd, $line) = @_;
     $self->log(LOGDEBUG, "_parse() cmd=[$cmd], line=[$line]");
     if ($cmd eq 'mail') {
-        return(DENY, "Syntax error in command")
+        return (DENY, "Syntax error in command")
           unless ($line =~ s/^from:\s*//i);
     }
-    else { # cmd eq 'rcpt'
+    else {    # cmd eq 'rcpt'
-        return(DENY, "Syntax error in command")
+        return (DENY, "Syntax error in command")
           unless ($line =~ s/^to:\s*//i);
     }
 
     if ($line =~ s/^(<.*>)\s*//) {
         my $addr = $1;
-        return (DENY, "No parameters allowed in ".uc($cmd))
+        return (DENY, "No parameters allowed in " . uc($cmd))
           if ($line =~ /^\S/);
         return (OK, $addr, ());
     }
@@ -56,13 +56,13 @@ sub _parse {
     ## now, no <> are given
     $line =~ s/\s*$//;
     if ($line =~ /\@/) {
-        return (DENY, "No parameters allowed in ".uc($cmd))
+        return (DENY, "No parameters allowed in " . uc($cmd))
           if ($line =~ /\@\S+\s+\S/);
         return (OK, $line, ());
     }
 
     if ($cmd eq "mail") {
-        return (OK, "<>") unless $line; # 'MAIL FROM:' -> 'MAIL FROM:<>'
+        return (OK, "<>") unless $line;    # 'MAIL FROM:' -> 'MAIL FROM:<>'
         return (DENY, "Could not parse your MAIL FROM command");
     }
     else {

plugins/qmail_deliverable

@@ -90,21 +90,21 @@ BEGIN {
     if (not $INC{'Qpsmtpd.pm'}) {
         my $dir = '$PLUGINS_DIRECTORY';
         -d and $dir = $_ for qw(
-            /home/qpsmtpd/plugins
+          /home/qpsmtpd/plugins
-            /home/smtp/qpsmtpd/plugins
+          /home/smtp/qpsmtpd/plugins
-            /usr/local/qpsmtpd/plugins
+          /usr/local/qpsmtpd/plugins
-            /usr/local/share/qpsmtpd/plugins
+          /usr/local/share/qpsmtpd/plugins
-            /usr/share/qpsmtpd/plugins
+          /usr/share/qpsmtpd/plugins
-        );
+          );
 
         my $file = "the 'plugins' configuration file";
         -f and $file = $_ for qw(
-            /home/qpsmtpd/config/plugins
+          /home/qpsmtpd/config/plugins
-            /home/smtp/qpsmtpd/config/plugins
+          /home/smtp/qpsmtpd/config/plugins
-            /usr/local/qpsmtpd/config/plugins
+          /usr/local/qpsmtpd/config/plugins
-            /usr/local/etc/qpsmtpd/plugins
+          /usr/local/etc/qpsmtpd/plugins
-            /etc/qpsmtpd/plugins
+          /etc/qpsmtpd/plugins
-        );
+          );
 
         # "die" would print "BEGIN failed" garbage
         print STDERR <<"END";
@@ -135,20 +135,21 @@ use Qpsmtpd::Constants;
 use Qmail::Deliverable::Client qw(deliverable);
 
 my %smtproutes;
-my $shared_domain;  # global variable to be closed over by the SERVER callback
+my $shared_domain;    # global variable to be closed over by the SERVER callback
 
 sub register {
     my ($self, $qp, @args) = @_;
     if (@args % 2) {
         $self->log(LOGWARN, "Odd number of arguments, using default config");
-    } else {
+    }
+    else {
         my %args = @args;
         if ($args{server} && $args{server} =~ /^smtproutes:/) {
 
             my ($fallback, $port) = $args{server} =~ /:(?:(.*?):?)(\d+)/;
 
             open my $fh, "/var/qmail/control/smtproutes"
-                or warn "Could not read smtproutes";
+              or warn "Could not read smtproutes";
             for (readline $fh) {
                 my ($domain, $mx) = /^(.*?) : \[? ( [^\]:\s]* )/x;
                 $smtproutes{$domain} = $mx;
@@ -161,16 +162,17 @@ sub register {
                 return;
             };
 
-        } elsif ($args{server}) {
+        }
+        elsif ($args{server}) {
             $Qmail::Deliverable::Client::SERVER = $args{server};
         }
 
-        if ( $args{vpopmail_ext} ) {
+        if ($args{vpopmail_ext}) {
             $Qmail::Deliverable::VPOPMAIL_EXT = $args{vpopmail_ext};
-        };
+        }
-        if ( $args{reject} ) {
+        if ($args{reject}) {
             $self->{_args}{reject} = $args{reject};
-        };
+        }
     }
     $self->register_hook("rcpt", "rcpt_handler");
 }
@@ -178,7 +180,7 @@ sub register {
 sub rcpt_handler {
     my ($self, $transaction, $rcpt) = @_;
 
-    return DECLINED if $self->is_immune(); # requires QP 0.90+
+    return DECLINED if $self->is_immune();    # requires QP 0.90+
 
     my $address = $rcpt->address;
     $self->log(LOGDEBUG, "Checking deliverability for recipient '$address'");
@@ -192,38 +194,41 @@ sub rcpt_handler {
         return DECLINED;
     }
 
-    my $k = 0;  # known status code
+    my $k = 0;    # known status code
-    $self->log(LOGINFO, "error, permission failure"),       $k++ if $rv == 0x11;
+    $self->log(LOGINFO, "error, permission failure"), $k++ if $rv == 0x11;
-    $self->log(LOGINFO, "pass, qmail-command in dot-qmail"),$k++ if $rv == 0x12;
+    $self->log(LOGINFO, "pass, qmail-command in dot-qmail"), $k++
+      if $rv == 0x12;
     $self->log(LOGINFO, "pass, bouncesaying with program"), $k++ if $rv == 0x13;
-    if ( $rv == 0x14 ) {
+    if ($rv == 0x14) {
         my $s = $transaction->sender->address;
         return (DENY, "mailing lists do not accept null senders")
-            if ( ! $s || $s eq '<>');
+          if (!$s || $s eq '<>');
-        $self->log(LOGINFO, "pass, ezmlm list"); $k++;
+        $self->log(LOGINFO, "pass, ezmlm list");
-    };
+        $k++;
+    }
     $self->log(LOGINFO, "Temporarily undeliverable: group/world writable"), $k++
-                                                                 if $rv == 0x21;
+      if $rv == 0x21;
-    $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),$k++
+    $self->log(LOGINFO, "Temporarily undeliverable: sticky home directory"),
-                                                                 if $rv == 0x22;
+      $k++
+      if $rv == 0x22;
     $self->log(LOGINFO, "error, $Qmail::Deliverable::Client::ERROR"), $k++
-                                                                 if $rv == 0x2f;
+      if $rv == 0x2f;
-    $self->log(LOGINFO, "pass, normal delivery"),           $k++ if $rv == 0xf1;
+    $self->log(LOGINFO, "pass, normal delivery"),    $k++ if $rv == 0xf1;
-    $self->log(LOGINFO, "pass, vpopmail dir"),              $k++ if $rv == 0xf2;
+    $self->log(LOGINFO, "pass, vpopmail dir"),       $k++ if $rv == 0xf2;
-    $self->log(LOGINFO, "pass, vpopmail alias"),            $k++ if $rv == 0xf3;
+    $self->log(LOGINFO, "pass, vpopmail alias"),     $k++ if $rv == 0xf3;
-    $self->log(LOGINFO, "pass, vpopmail catchall"),         $k++ if $rv == 0xf4;
+    $self->log(LOGINFO, "pass, vpopmail catchall"),  $k++ if $rv == 0xf4;
-    $self->log(LOGINFO, "pass, vpopmail vuser"),            $k++ if $rv == 0xf5;
+    $self->log(LOGINFO, "pass, vpopmail vuser"),     $k++ if $rv == 0xf5;
-    $self->log(LOGINFO, "pass, vpopmail qmail-ext"),        $k++ if $rv == 0xf6;
+    $self->log(LOGINFO, "pass, vpopmail qmail-ext"), $k++ if $rv == 0xf6;
-    $self->log(LOGINFO, "error, SHOULD NOT HAPPEN"),        $k++ if $rv == 0xfe;
+    $self->log(LOGINFO, "error, SHOULD NOT HAPPEN"), $k++ if $rv == 0xfe;
-    $self->log(LOGINFO, "fail, address not local"),         $k++ if $rv == 0xff;
+    $self->log(LOGINFO, "fail, address not local"),  $k++ if $rv == 0xff;
 
-    if ( $rv ) {
+    if ($rv) {
         $self->log(LOGINFO, sprintf("error, unknown: 0x%02x", $rv)) if not $k;
         return DECLINED;
-    };
+    }
 
-    $self->adjust_karma( -1 );
+    $self->adjust_karma(-1);
-    return $self->get_reject( "Sorry, no mailbox by that name. qd (#5.1.1)" );
+    return $self->get_reject("Sorry, no mailbox by that name. qd (#5.1.1)");
 }
 
 sub _smtproute {

plugins/queue/exim-bsmtp

@@ -1,4 +1,5 @@
 #!perl -w
+
 =head1 NAME
 
 exim-bsmtp
@@ -69,8 +70,10 @@ sub register {
     $self->{_exim_path} = $args{exim_path} || '/usr/sbin/rsmtp';
     $self->{_exim_path} = $1 if $self->{_exim_path} =~ /(.*)/;
     unless (-x $self->{_exim_path}) {
-        $self->log(LOGERROR, "Could not find exim at $self->{_exim_path};".
+        $self->log(LOGERROR,
-                             " please set exim_path in config/plugins");
+                       "Could not find exim at $self->{_exim_path};"
+                     . " please set exim_path in config/plugins"
+                  );
         return undef;
     }
 }
@@ -91,14 +94,14 @@ sub hook_queue {
     }
 
     print $tmp "HELO ", hostname(), "\n",
-               "MAIL FROM:<", ($transaction->sender->address || ''), ">\n";
+      "MAIL FROM:<", ($transaction->sender->address || ''), ">\n";
     print $tmp "RCPT TO:<", ($_->address || ''), ">\n"
       for $transaction->recipients;
     print $tmp "DATA\n", $transaction->header->as_string;
     $transaction->body_resetpos;
     while (my $line = $transaction->body_getline) {
-      $line =~ s/^\./../;
+        $line =~ s/^\./../;
-      print $tmp $line;
+        print $tmp $line;
     }
     print $tmp ".\nQUIT\n";
     close $tmp;
@@ -111,6 +114,7 @@ sub hook_queue {
         unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!");
         return (DECLINED, "Internal error enqueuing mail");
     }
+
     # Normally exim produces no output in BSMTP mode; anything that
     # does come out is an error worth logging.
     my $start = time;
@@ -122,20 +126,23 @@ sub hook_queue {
             ($bsmtp_error, $bsmtp_msg) = ($1, $2);
         }
     }
-    $self->log(LOGDEBUG, "BSMTP finished (".(time - $start)." sec)");
+    $self->log(LOGDEBUG, "BSMTP finished (" . (time - $start) . " sec)");
     $exim->close;
     my $exit = $?;
     unlink $tmpfn or $self->log(LOGERROR, "unlink: $tmpfn: $!");
 
     $self->log(LOGDEBUG, "Exitcode from exim: $exit");
     if ($bsmtp_error && $bsmtp_error >= 400 && $bsmtp_error < 600) {
-        $self->log(LOGERROR, "BSMTP enqueue failed; response $bsmtp_error".
+        $self->log(LOGERROR,
-                             " ($bsmtp_msg)");
+               "BSMTP enqueue failed; response $bsmtp_error" . " ($bsmtp_msg)");
         return ($bsmtp_error < 400 ? DECLINED : DENY, $bsmtp_msg);
     }
     elsif (($exit >> 8) != 0 || $bsmtp_error) {
-        $self->log(LOGERROR, 'BSMTP enqueue failed; exitcode '.($exit >> 8).
+        $self->log(LOGERROR,
-                             " from $self->{_exim_path} -bS");
+                       'BSMTP enqueue failed; exitcode '
+                     . ($exit >> 8)
+                     . " from $self->{_exim_path} -bS"
+                  );
         return (DECLINED, 'Internal error enqueuing mail');
     }
 

plugins/queue/maildir

@@ -82,133 +82,145 @@ use Sys::Hostname qw(hostname);
 use Time::HiRes qw(gettimeofday);
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  if (@args > 0) {
+    if (@args > 0) {
-    ($self->{_maildir}) = ($args[0] =~ m!([-/\w\.]+)!);
+        ($self->{_maildir}) = ($args[0] =~ m!([-/\w\.]+)!);
-  }
+    }
+
+    if (@args > 1) {
+        ($self->{_subdirs}) = ($args[1] =~ m#^(.*\%[ldu].*)$#);
+        unless ($self->{_subdirs}) {
+            $self->log(LOGWARN,
+                           "WARNING: sub directory does not contain a "
+                         . "substitution parameter"
+                      );
+            return 0;
+        }
+    }
+
+    if (@args > 2) {
+        ($self->{_perms}) = ($args[2] =~ /^([0-7]{3})$/);
+        unless ($self->{_perms}) {    # 000 is unfortunately true ;-)
+            $self->log(LOGWARN, "WARNING: mode is not an octal number");
+            return 0;
+        }
+        $self->{_perms} = oct($self->{_perms});
+    }
+
+    $self->{_perms} = 0700
+      unless $self->{_perms};
+
+    unless ($self->{_maildir}) {
+        $self->log(LOGWARN, "WARNING: maildir directory not specified");
+        return 0;
+    }
 
-  if (@args > 1) {
-    ($self->{_subdirs}) = ($args[1] =~ m#^(.*\%[ldu].*)$#);
     unless ($self->{_subdirs}) {
-      $self->log(LOGWARN, "WARNING: sub directory does not contain a "
+
-                         ."substitution parameter");
+        # mkpath is influenced by umask...
-      return 0;
+        my $old_umask = umask 000;
+        map {
+            my $d = $self->{_maildir} . "/$_";
+            -e $d or mkpath $d, 0, $self->{_perms}
+        } qw(cur tmp new);
+        umask $old_umask;
     }
-  }
 
-  if (@args > 2) {
+    my $hostname = (hostname =~ m/([\w\._\-]+)/)[0];
-    ($self->{_perms}) = ($args[2] =~ /^([0-7]{3})$/);
+    $self->{_hostname} = $hostname;
-    unless ($self->{_perms}) { # 000 is unfortunately true ;-) 
-      $self->log(LOGWARN, "WARNING: mode is not an octal number");
-      return 0;
-    }
-    $self->{_perms} = oct($self->{_perms});
-  }
-
-  $self->{_perms} = 0700
-    unless $self->{_perms};
-
-  unless ($self->{_maildir}) {
-    $self->log(LOGWARN, "WARNING: maildir directory not specified");
-    return 0;
-  }
-
-  unless ($self->{_subdirs}) {
-    # mkpath is influenced by umask...
-    my $old_umask = umask 000;
-    map { my $d = $self->{_maildir} . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } qw(cur tmp new);
-    umask $old_umask;
-  }
-
-  my $hostname = (hostname =~ m/([\w\._\-]+)/)[0];
-  $self->{_hostname} = $hostname;
 
 }
 
 my $maildir_counter = 0;
 
 sub hook_queue {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
-  my ($rc, @msg);
+    my ($rc, @msg);
-  my $old_umask = umask($self->{_perms} ^ 0777);
+    my $old_umask = umask($self->{_perms} ^ 0777);
 
-  if ($self->{_subdirs}) {
+    if ($self->{_subdirs}) {
-    foreach my $addr ($transaction->recipients) {
+        foreach my $addr ($transaction->recipients) {
-      ($rc, @msg) = $self->deliver_user($transaction, $addr);
+            ($rc, @msg) = $self->deliver_user($transaction, $addr);
-      unless($rc == OK) {
+            unless ($rc == OK) {
+                umask $old_umask;
+                return ($rc, @msg);
+            }
+        }
         umask $old_umask;
-        return ($rc, @msg);
+        return (OK, @msg);    # last @msg is the same like any other before...
-      }
     }
-    umask $old_umask;
-    return (OK, @msg); # last @msg is the same like any other before...
-  }
 
-  $transaction->header->add('Delivered-To', $_->address, 0)
+    $transaction->header->add('Delivered-To', $_->address, 0)
-    for $transaction->recipients;
+      for $transaction->recipients;
-  ($rc, @msg) = $self->write_file($transaction, $self->{_maildir});
+    ($rc, @msg) = $self->write_file($transaction, $self->{_maildir});
-  umask $old_umask;
+    umask $old_umask;
-  return ($rc, @msg);
+    return ($rc, @msg);
 }
 
 sub write_file {
-  my ($self, $transaction, $maildir, $addr) = @_;
+    my ($self, $transaction, $maildir, $addr) = @_;
-  my ($time, $microseconds) = gettimeofday;
+    my ($time, $microseconds) = gettimeofday;
 
-  $time = ($time =~ m/(\d+)/)[0];
+    $time = ($time =~ m/(\d+)/)[0];
-  $microseconds =~ s/\D//g;
+    $microseconds =~ s/\D//g;
 
-  my $unique  = "P$$" . "M$microseconds" . "Q" . $maildir_counter++;
+    my $unique = "P$$" . "M$microseconds" . "Q" . $maildir_counter++;
-  my $file    = join ".", $time, $unique, $self->{_hostname};
+    my $file = join ".", $time, $unique, $self->{_hostname};
 
-  open (MF, ">$maildir/tmp/$file") or
+    open(MF, ">$maildir/tmp/$file")
-    $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"),
+      or $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"),
-    return(DECLINED, "queue error (open)");
+      return (DECLINED, "queue error (open)");
 
-  print MF "Return-Path: ", $transaction->sender->format , "\n";
+    print MF "Return-Path: ", $transaction->sender->format, "\n";
 
-  print MF "Delivered-To: ",$addr->address,"\n"
+    print MF "Delivered-To: ", $addr->address, "\n"
-    if $addr; # else it had been added before...
+      if $addr;    # else it had been added before...
 
-  $transaction->header->print(\*MF);
+    $transaction->header->print(\*MF);
-  $transaction->body_resetpos;
+    $transaction->body_resetpos;
-  while (my $line = $transaction->body_getline) {
+    while (my $line = $transaction->body_getline) {
-    print MF $line;
+        print MF $line;
-  }
+    }
-  close MF or
+    close MF
-    $self->log(LOGWARN, "could not close $maildir/tmp/$file: $!")
+      or $self->log(LOGWARN, "could not close $maildir/tmp/$file: $!")
-    and return(DECLINED, "queue error (close)");
+      and return (DECLINED, "queue error (close)");
 
-  link "$maildir/tmp/$file", "$maildir/new/$file" or
+    link "$maildir/tmp/$file",
-    $self->log(LOGWARN, "could not link $maildir/tmp/$file to $maildir/new/$file: $!")
+      "$maildir/new/$file"
-    and return(DECLINED, "queue error (link)");
+      or $self->log(LOGWARN,
+                  "could not link $maildir/tmp/$file to $maildir/new/$file: $!")
+      and return (DECLINED, "queue error (link)");
 
-  unlink "$maildir/tmp/$file";
+    unlink "$maildir/tmp/$file";
 
-  my $msg_id = $transaction->header->get('Message-Id') || '';
+    my $msg_id = $transaction->header->get('Message-Id') || '';
-  $msg_id =~ s/[\r\n].*//s;
+    $msg_id =~ s/[\r\n].*//s;
 
-  return (OK, "Queued! $msg_id");
+    return (OK, "Queued! $msg_id");
 }
 
 sub deliver_user {
-  my ($self, $transaction, $addr) = @_;
+    my ($self, $transaction, $addr) = @_;
-  my $user = $addr->user; $user =~ tr/-A-Za-z0-9+_.,@=/_/c;
+    my $user = $addr->user;
-  my $host = $addr->host; $host =~ tr/-A-Za-z0-9+_.,@=/_/c;
+    $user =~ tr/-A-Za-z0-9+_.,@=/_/c;
-  my $rcpt = $user.'@'.$host;
+    my $host = $addr->host;
+    $host =~ tr/-A-Za-z0-9+_.,@=/_/c;
+    my $rcpt = $user . '@' . $host;
 
-  my $subdir = $self->{_subdirs};
+    my $subdir = $self->{_subdirs};
-  $subdir =~ s/\%l/$user/g;
+    $subdir =~ s/\%l/$user/g;
-  $subdir =~ s/\%d/$host/g;
+    $subdir =~ s/\%d/$host/g;
-  $subdir =~ s/\%u/$rcpt/g;
+    $subdir =~ s/\%u/$rcpt/g;
-#  $subdir =~ s/\%%/%/g;
 
-  my $maildir = $self->{_maildir}."/$subdir";
+    #  $subdir =~ s/\%%/%/g;
-  my $old_umask = umask 000;
-  map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} } qw(cur tmp new);
-  umask $old_umask;
 
-  return $self->write_file($transaction, $maildir, $addr);
+    my $maildir   = $self->{_maildir} . "/$subdir";
+    my $old_umask = umask 000;
+    map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} }
+      qw(cur tmp new);
+    umask $old_umask;
+
+    return $self->write_file($transaction, $maildir, $addr);
 }
 

plugins/queue/postfix-queue

@@ -128,20 +128,22 @@ use Qpsmtpd::Postfix::Constants;
 sub register {
     my ($self, $qp, @args) = @_;
 
-    $self->log(LOGDEBUG, "using constants generated from Postfix"
+    $self->log(LOGDEBUG,
-                        ."v$postfix_version");
+               "using constants generated from Postfix" . "v$postfix_version");
     $self->{_queue_flags} = 0;
     if (@args > 0) {
         if ($args[0] =~ m#^(/.+)#) {
+
             # untaint socket path
             $self->{_queue_socket} = $1;
             shift @args;
         }
 
         foreach (@args) {
-            if ($self->can("CLEANUP_".$_) and /^(FLAG_[A-Z0-9_]+)$/) {
+            if ($self->can("CLEANUP_" . $_) and /^(FLAG_[A-Z0-9_]+)$/) {
                 $_ = $1;
                 $self->{_queue_flags} |= (eval "CLEANUP_$_;" || 0);
+
                 #print STDERR "queue flag: $_: ".$self->{_queue_flags}."\n";
             }
             else {
@@ -166,29 +168,32 @@ sub hook_queue {
     @queue = ($self->{_queue_socket} // ()) unless @queue;
     $transaction->notes('postfix-queue-sockets', \@queue) if @queue;
 
-    # $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags'));
+# $self->log(LOGDEBUG, "queue-flags=".$transaction->notes('postfix-queue-flags'));
     my ($status, $qid, $reason) = Qpsmtpd::Postfix->inject_mail($transaction);
     if ($status) {
-      # this split is needed, because if cleanup returns
+
-      # CLEANUP_STAT_MASK_INCOMPLETE we might return DENY (CLEANUP_STAT_SIZE)
+        # this split is needed, because if cleanup returns
-      # instead of DENYSOFT (CLEANUP_STAT_WRITE, CLEANUP_STAT_BAD, 
+        # CLEANUP_STAT_MASK_INCOMPLETE we might return DENY (CLEANUP_STAT_SIZE)
-      # CLEANUP_STAT_DEFER) ... n.b. this is the behaviour of 667.
+        # instead of DENYSOFT (CLEANUP_STAT_WRITE, CLEANUP_STAT_BAD,
-      foreach my $key (keys %cleanup_soft) {
+        # CLEANUP_STAT_DEFER) ... n.b. this is the behaviour of 667.
-        my $stat = eval $key # keys have the same names as the constants
+        foreach my $key (keys %cleanup_soft) {
-          or next;
+            my $stat = eval $key    # keys have the same names as the constants
-        if ($status & $stat) {
+              or next;
-          return (DENYSOFT, $reason || $cleanup_soft{$key});
+            if ($status & $stat) {
+                return (DENYSOFT, $reason || $cleanup_soft{$key});
+            }
         }
-      }
+        foreach my $key (keys %cleanup_hard) {
-      foreach my $key (keys %cleanup_hard) {
+            my $stat = eval $key    # keys have the same names as the constants
-        my $stat = eval $key # keys have the same names as the constants
+              or next;
-          or next;
+            if ($status & $stat) {
-        if ($status & $stat) {
+                return (DENY, $reason || $cleanup_hard{$key});
-          return (DENY, $reason || $cleanup_hard{$key});
+            }
         }
-      }
+
-      # we have no idea why we're here.
+        # we have no idea why we're here.
-      return (DECLINED, $reason || "Unable to queue message ($status, $reason)");
+        return (DECLINED,
+                $reason || "Unable to queue message ($status, $reason)");
     }
 
     my $msg_id = $transaction->header->get('Message-Id') || '';

plugins/queue/qmail-queue

@@ -20,7 +20,6 @@ If set the environment variable QMAILQUEUE overrides this setting.
 
 =cut
 
-
 use strict;
 use warnings;
 
@@ -32,7 +31,8 @@ sub register {
 
     if (@args > 0) {
         $self->{_queue_exec} = $args[0];
-        $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if @args > 1;
+        $self->log(LOGWARN, "WARNING: Ignoring additional arguments.")
+          if @args > 1;
     }
 
     $self->{_queue_exec} ||= ($ENV{QMAIL} || '/var/qmail') . "/bin/qmail-queue";
@@ -42,19 +42,23 @@ sub register {
 sub hook_queue {
     my ($self, $transaction) = @_;
 
-# these bits inspired by Peter Samuels "qmail-queue wrapper"
+    # these bits inspired by Peter Samuels "qmail-queue wrapper"
     pipe(MESSAGE_READER, MESSAGE_WRITER) or die "Could not create message pipe";
-    pipe(ENVELOPE_READER, ENVELOPE_WRITER) or die "Could not create envelope pipe";
+    pipe(ENVELOPE_READER, ENVELOPE_WRITER)
+      or die "Could not create envelope pipe";
 
     local $SIG{PIPE} = sub { die 'SIGPIPE' };
     my $child = fork();
 
-    ! defined $child and die "Could not fork";
+    !defined $child and die "Could not fork";
 
     if ($child) {
-# Parent
+
-        my $oldfh = select MESSAGE_WRITER; $| = 1;
+        # Parent
-        select ENVELOPE_WRITER; $| = 1;
+        my $oldfh = select MESSAGE_WRITER;
+        $| = 1;
+        select ENVELOPE_WRITER;
+        $| = 1;
         select $oldfh;
 
         close MESSAGE_READER  or die "close msg reader fault";
@@ -68,51 +72,59 @@ sub hook_queue {
         close MESSAGE_WRITER;
 
         my @rcpt = map { "T" . $_->address } $transaction->recipients;
-        my $from = "F".($transaction->sender->address|| "" );
+        my $from = "F" . ($transaction->sender->address || "");
-        print ENVELOPE_WRITER "$from\0", join("\0",@rcpt), "\0\0"
+        print ENVELOPE_WRITER "$from\0", join("\0", @rcpt), "\0\0"
-            or return(DECLINED,"Could not print addresses to queue");
+          or return (DECLINED, "Could not print addresses to queue");
 
         close ENVELOPE_WRITER;
         waitpid($child, 0);
         my $exit_code = $? >> 8;
-        $exit_code and return(DECLINED, "Unable to queue message ($exit_code)");
+        $exit_code
+          and return (DECLINED, "Unable to queue message ($exit_code)");
 
         my $msg_id = $transaction->header->get('Message-Id') || '';
         $msg_id =~ s/[\r\n].*//s;  # don't allow newlines in the Message-Id here
-            $msg_id = "<$msg_id>" unless $msg_id =~ /^<.*>$/;  # surround in <>'s
+        $msg_id = "<$msg_id>" unless $msg_id =~ /^<.*>$/;    # surround in <>'s
-            return (OK, "Queued! " . time . " qp $child $msg_id");
+        return (OK, "Queued! " . time . " qp $child $msg_id");
     }
     elsif (defined $child) {
-# Child
+
-        close MESSAGE_WRITER or exit 1;
+        # Child
+        close MESSAGE_WRITER  or exit 1;
         close ENVELOPE_WRITER or exit 2;
 
-# Untaint $self->{_queue_exec}
+        # Untaint $self->{_queue_exec}
         my $queue_exec = $self->{_queue_exec};
         if ($queue_exec =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
             $queue_exec = $1;
-        } else {
+        }
-            $self->log(LOGERROR, "FATAL ERROR: Unexpected characters in qmail-queue plugin argument");
+        else {
-# This exit is ok as we're exiting a forked child process.
+            $self->log(LOGERROR,
+"FATAL ERROR: Unexpected characters in qmail-queue plugin argument"
+            );
+
+            # This exit is ok as we're exiting a forked child process.
             exit 3;
         }
 
-# save the original STDIN and STDOUT in case exec() fails below
+        # save the original STDIN and STDOUT in case exec() fails below
-        open(SAVE_STDIN, "<&STDIN");
+        open(SAVE_STDIN,  "<&STDIN");
         open(SAVE_STDOUT, ">&STDOUT");
 
-        POSIX::dup2(fileno(MESSAGE_READER), 0) or die "Unable to dup MESSAGE_READER: $!";
+        POSIX::dup2(fileno(MESSAGE_READER), 0)
-        POSIX::dup2(fileno(ENVELOPE_READER), 1) or die "Unable to dup ENVELOPE_READER: $!";
+          or die "Unable to dup MESSAGE_READER: $!";
+        POSIX::dup2(fileno(ENVELOPE_READER), 1)
+          or die "Unable to dup ENVELOPE_READER: $!";
 
         my $ppid = getppid();
         $self->log(LOGNOTICE, "(for $ppid) Queuing to $queue_exec");
 
         my $rc = exec $queue_exec;
 
-# close the pipe
+        # close the pipe
         close(MESSAGE_READER);
         close(MESSAGE_WRITER);
 
-        exit 6; # we'll only get here if the exec fails
+        exit 6;    # we'll only get here if the exec fails
     }
 }

plugins/queue/smtp-forward

@@ -1,4 +1,5 @@
 #!perl -w
+
 =head1 NAME
 
 smtp-forward
@@ -23,48 +24,56 @@ Optionally you can also add a port:
 use Net::SMTP;
 
 sub init {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  if (@args > 0) {
+    if (@args > 0) {
-    if ($args[0] =~ /^([\.\w_-]+)$/) {
+        if ($args[0] =~ /^([\.\w_-]+)$/) {
-      $self->{_smtp_server} = $1;
+            $self->{_smtp_server} = $1;
+        }
+        else {
+            die "Bad data in smtp server: $args[0]";
+        }
+        $self->{_smtp_port} = 25;
+        if (@args > 1 and $args[1] =~ /^(\d+)$/) {
+            $self->{_smtp_port} = $1;
+        }
+        $self->log(LOGWARN, "WARNING: Ignoring additional arguments.")
+          if (@args > 2);
     }
     else {
-      die "Bad data in smtp server: $args[0]";
+        die("No SMTP server specified in smtp-forward config");
     }
-    $self->{_smtp_port} = 25;
-    if (@args > 1 and $args[1] =~ /^(\d+)$/) {
-      $self->{_smtp_port} = $1;
-    }
-    $self->log(LOGWARN, "WARNING: Ignoring additional arguments.") if (@args > 2);
-  } else {
-    die("No SMTP server specified in smtp-forward config");
-  }
 
 }
 
 sub hook_queue {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  $self->log(LOGINFO, "forwarding to $self->{_smtp_server}:$self->{_smtp_port}");
+    $self->log(LOGINFO,
-  my $smtp = Net::SMTP->new(
+               "forwarding to $self->{_smtp_server}:$self->{_smtp_port}");
-                            $self->{_smtp_server},
+    my $smtp = Net::SMTP->new(
-                            Port => $self->{_smtp_port},
+                              $self->{_smtp_server},
-                            Timeout => 60,
+                              Port    => $self->{_smtp_port},
-                            Hello => $self->qp->config("me"),
+                              Timeout => 60,
-                           ) || die $!;
+                              Hello   => $self->qp->config("me"),
-  $smtp->mail( $transaction->sender->address || "" ) or return(DECLINED, "Unable to queue message ($!)");
+                             )
-  for ($transaction->recipients) {
+      || die $!;
-    $smtp->to($_->address) or return(DECLINED, "Unable to queue message ($!)");
+    $smtp->mail($transaction->sender->address || "")
-  }
+      or return (DECLINED, "Unable to queue message ($!)");
-  $smtp->data() or return(DECLINED, "Unable to queue message ($!)");
+    for ($transaction->recipients) {
-  $smtp->datasend($transaction->header->as_string) or return(DECLINED, "Unable to queue message ($!)");
+        $smtp->to($_->address)
-  $transaction->body_resetpos;
+          or return (DECLINED, "Unable to queue message ($!)");
-  while (my $line = $transaction->body_getline) {
+    }
-    $smtp->datasend($line) or return(DECLINED, "Unable to queue message ($!)");
+    $smtp->data() or return (DECLINED, "Unable to queue message ($!)");
-  }
+    $smtp->datasend($transaction->header->as_string)
-  $smtp->dataend() or return(DECLINED, "Unable to queue message ($!)");
+      or return (DECLINED, "Unable to queue message ($!)");
-  $smtp->quit() or return(DECLINED, "Unable to queue message ($!)");
+    $transaction->body_resetpos;
-  $self->log(LOGINFO, "finished queueing");
+    while (my $line = $transaction->body_getline) {
-  return (OK, "Queued!");
+        $smtp->datasend($line)
+          or return (DECLINED, "Unable to queue message ($!)");
+    }
+    $smtp->dataend() or return (DECLINED, "Unable to queue message ($!)");
+    $smtp->quit()    or return (DECLINED, "Unable to queue message ($!)");
+    $self->log(LOGINFO, "finished queueing");
+    return (OK, "Queued!");
 }

plugins/quit_fortune

@@ -1,17 +1,17 @@
 #!perl -w
 
 sub hook_quit {
-  my $qp = shift->qp;
+    my $qp = shift->qp;
 
-  # if she talks EHLO she is probably too sophisticated to enjoy the
+    # if she talks EHLO she is probably too sophisticated to enjoy the
-  # fun, so skip it.
+    # fun, so skip it.
-  return (DECLINED) if ($qp->connection->hello || '') eq "ehlo";
+    return (DECLINED) if ($qp->connection->hello || '') eq "ehlo";
 
-  my $fortune = '/usr/games/fortune';
+    my $fortune = '/usr/games/fortune';
-  return DECLINED unless -e $fortune;
+    return DECLINED unless -e $fortune;
 
-  my @fortune = `$fortune -s`;
+    my @fortune = `$fortune -s`;
-  @fortune = map { chop; s/^/  \/ /; $_ } @fortune;
+    @fortune = map { chop; s/^/  \/ /; $_ } @fortune;
-  $qp->respond(221, $qp->config('me') . " closing connection.", @fortune);
+    $qp->respond(221, $qp->config('me') . " closing connection.", @fortune);
-  return DONE;
+    return DONE;
 }

plugins/random_error

@@ -27,17 +27,17 @@ For use with other plugins, scribble the revised failure rate to
 =cut
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  die "Invalid args: '@args'" unless @args < 2;
+    die "Invalid args: '@args'" unless @args < 2;
-  ($self->{__PACKAGE__.'_how'}) = $args[0] || 1;
+    ($self->{__PACKAGE__ . '_how'}) = $args[0] || 1;
 
 }
 
 sub NEXT() { DECLINED }
 
 sub random_fail {
-        my $fpct = $_[0]->connection->notes('random_fail_%');
+    my $fpct = $_[0]->connection->notes('random_fail_%');
 
 =head1 calculating the probability of failure
 
@@ -52,40 +52,41 @@ or
        x = 1 - ( (1 - input_number ) ** (1/6) )
 
 =cut
-        my $successp = 1 - ($fpct / 100);
+
-        $_[0]->log(LOGINFO, "to fail, rand(1) must be more than ". ($successp ** (1 / 6)) );
+    my $successp = 1 - ($fpct / 100);
-	rand(1) < ($successp ** (1 / 6)) and return NEXT;
+    $_[0]->log(LOGINFO,
-	rand(5) < 2 and return (DENYSOFT_DISCONNECT, "random failure");
+               "to fail, rand(1) must be more than " . ($successp**(1 / 6)));
-	return (DENYSOFT, "random failure");
+    rand(1) < ($successp**(1 / 6)) and return NEXT;
+    rand(5) < 2 and return (DENYSOFT_DISCONNECT, "random failure");
+    return (DENYSOFT, "random failure");
 }
 
-
 sub hook_connect {
-    $_[0]->connection->notes('random_fail_%', $_[0]->{__PACKAGE__.'_how'});
+    $_[0]->connection->notes('random_fail_%', $_[0]->{__PACKAGE__ . '_how'});
-    goto &random_fail
+    goto &random_fail;
 }
 
 sub hook_helo {
-    goto &random_fail
+    goto &random_fail;
 }
 
 sub hook_ehlo {
-    goto &random_fail
+    goto &random_fail;
 }
 
 sub hook_mail {
-    goto &random_fail
+    goto &random_fail;
 }
 
 sub hook_rcpt {
-    goto &random_fail
+    goto &random_fail;
 }
 
 sub hook_data {
-    goto &random_fail
+    goto &random_fail;
 }
 
 sub hook_data_post {
-    goto &random_fail
+    goto &random_fail;
 }
 

plugins/rcpt_map

@@ -121,9 +121,9 @@ sub register {
     $self->{_domain} = lc $self->{_domain};
 
     $self->log(LOGDEBUG,
-               "Using map ".$self->{_file}." for domain ".$self->{_domain});
+             "Using map " . $self->{_file} . " for domain " . $self->{_domain});
     %map = $self->read_map(1);
-    die "Empty map file ".$self->{_file}
+    die "Empty map file " . $self->{_file}
       unless keys %map;
 }
 
@@ -158,13 +158,13 @@ sub read_map {
 
         unless ($code) {
             $self->log(LOGERROR,
-                      "No constant in line $line in ".$self->{_file});
+                       "No constant in line $line in " . $self->{_file});
             next;
         }
         $code = Qpsmtpd::Constants::return_code($code);
         unless (defined $code) {
             $self->log(LOGERROR,
-                       "Not a valid constant in line $line in ".$self->{_file});
+                     "Not a valid constant in line $line in " . $self->{_file});
             next;
         }
         $msg or $msg = "No such user.";

plugins/rcpt_ok

@@ -28,16 +28,16 @@ use Qpsmtpd::Constants;
 use Qpsmtpd::DSN;
 
 sub hook_rcpt {
-  my ($self, $transaction, $recipient, %param) = @_;
+    my ($self, $transaction, $recipient, %param) = @_;
 
-  # Allow 'no @' addresses for 'postmaster' and 'abuse'
+    # Allow 'no @' addresses for 'postmaster' and 'abuse'
-  # qmail-smtpd will do this for all users without a domain, but we'll
+    # qmail-smtpd will do this for all users without a domain, but we'll
-  # be a bit more picky.  Maybe that's a bad idea.
+    # be a bit more picky.  Maybe that's a bad idea.
-    my $host = $self->get_rcpt_host( $recipient ) or return (OK);
+    my $host = $self->get_rcpt_host($recipient) or return (OK);
 
-    return (OK) if $self->is_in_rcpthosts( $host );
+    return (OK) if $self->is_in_rcpthosts($host);
-    return (OK) if $self->is_in_morercpthosts( $host );
+    return (OK) if $self->is_in_morercpthosts($host);
-    return (OK) if $self->qp->connection->relay_client;  # failsafe
+    return (OK) if $self->qp->connection->relay_client;    # failsafe
 
     # default of relaying_denied is obviously DENY,
     # we use the default "Relaying denied" message...
@@ -45,55 +45,55 @@ sub hook_rcpt {
 }
 
 sub is_in_rcpthosts {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
 
     my @rcpt_hosts = ($self->qp->config('me'), $self->qp->config('rcpthosts'));
 
     # Check if this recipient host is allowed
     for my $allowed (@rcpt_hosts) {
         $allowed =~ s/^\s*(\S+)/$1/;
-        if ( $host eq lc $allowed ) {
+        if ($host eq lc $allowed) {
-            $self->log( LOGINFO, "pass: $host in rcpthosts" );
+            $self->log(LOGINFO, "pass: $host in rcpthosts");
             return 1;
-        };
+        }
 
-        if ( substr($allowed,0,1) eq '.' and $host =~ m/\Q$allowed\E$/i ) {
+        if (substr($allowed, 0, 1) eq '.' and $host =~ m/\Q$allowed\E$/i) {
-            $self->log( LOGINFO, "pass: $host in rcpthosts as $allowed" );
+            $self->log(LOGINFO, "pass: $host in rcpthosts as $allowed");
             return 1;
-        };
+        }
     }
 
     return;
-};
+}
 
 sub is_in_morercpthosts {
-    my ( $self, $host ) = @_;
+    my ($self, $host) = @_;
 
     my $more_rcpt_hosts = $self->qp->config('morercpthosts', 'map');
 
-    if ( exists $more_rcpt_hosts->{$host} ) {
+    if (exists $more_rcpt_hosts->{$host}) {
-        $self->log( LOGINFO, "pass: $host found in morercpthosts" );
+        $self->log(LOGINFO, "pass: $host found in morercpthosts");
         return 1;
-    };
+    }
 
-    $self->log( LOGINFO, "fail: $host not in morercpthosts" );
+    $self->log(LOGINFO, "fail: $host not in morercpthosts");
     return;
-};
+}
 
 sub get_rcpt_host {
-    my ( $self, $recipient ) = @_;
+    my ($self, $recipient) = @_;
 
-    return if ! $recipient;  # Qpsmtpd::Address couldn't parse the recipient
+    return if !$recipient;    # Qpsmtpd::Address couldn't parse the recipient
 
-    if ( $recipient->host ) {
+    if ($recipient->host) {
         return lc $recipient->host;
-    };
+    }
 
     # no host portion exists
     my $user = $recipient->user or return;
-    if ( lc $user eq 'postmaster' || lc $user eq 'abuse' ) {
+    if (lc $user eq 'postmaster' || lc $user eq 'abuse') {
         return $self->qp->config('me');
-    };
+    }
     return;
-};
+}
 

plugins/rcpt_regexp

@@ -1,4 +1,5 @@
 #!perl -w
+
 =head1 NAME
 
 rcpt_regexp - check recipients against a list of regular expressions

plugins/relay

@@ -105,14 +105,14 @@ use Qpsmtpd::Constants;
 use Net::IP qw(:PROC);
 
 sub register {
-    my ($self, $qp) = ( shift, shift );
+    my ($self, $qp) = (shift, shift);
     $self->log(LOGERROR, "Bad arguments") if @_ % 2;
-    $self->{_args} = { @_ };
+    $self->{_args} = {@_};
 
-    if ( $self->{_args}{only} ) {
+    if ($self->{_args}{only}) {
         $self->register_hook('rcpt', 'relay_only');
-    };
+    }
-};
+}
 
 sub is_in_norelayclients {
     my $self = shift;
@@ -121,30 +121,30 @@ sub is_in_norelayclients {
 
     my $ip = $self->qp->connection->remote_ip;
 
-    while ( $ip ) {
+    while ($ip) {
-        if ( exists $no_relay_clients{$ip} ) {
+        if (exists $no_relay_clients{$ip}) {
             $self->log(LOGINFO, "$ip in norelayclients");
             return 1;
         }
-        $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet
+        $ip =~ s/(\d|\w)+(:|\.)?$// or last;    # strip off another octet
-    };
+    }
 
     $self->log(LOGDEBUG, "no match in norelayclients");
     return;
-};
+}
 
 sub populate_relayclients {
     my $self = shift;
 
-    foreach ( $self->qp->config('relayclients') ) {
+    foreach ($self->qp->config('relayclients')) {
         my ($network, $netmask) = ip_splitprefix($_);
-        if ( $netmask ) {
+        if ($netmask) {
-            push @{ $self->{_cidr_blocks} }, $_;
+            push @{$self->{_cidr_blocks}}, $_;
             next;
         }
-        $self->{_octets}{$_} = 1;   # no prefix, split
+        $self->{_octets}{$_} = 1;    # no prefix, split
     }
-};
+}
 
 sub is_in_cidr_block {
     my $self = shift;
@@ -154,20 +154,20 @@ sub is_in_cidr_block {
         return;
     };
     my $cversion = ip_get_version($ip);
-    for ( @{ $self->{_cidr_blocks} } ) {
+    for (@{$self->{_cidr_blocks}}) {
-        my ($network, $mask) = ip_splitprefix($_); # split IP & CIDR range
+        my ($network, $mask) = ip_splitprefix($_);    # split IP & CIDR range
-        my $rversion = ip_get_version($network);   # get IP version (4 vs 6)
+        my $rversion = ip_get_version($network);      # get IP version (4 vs 6)
-        my ($begin, $end) = ip_normalize($_, $rversion); # get pool start/end
+        my ($begin, $end) = ip_normalize($_, $rversion);    # get pool start/end
 
-# expand the client address (zero pad it) before converting to binary
+        # expand the client address (zero pad it) before converting to binary
         my $bin_ip = ip_iptobin(ip_expand_address($ip, $cversion), $cversion)
-            or next;
+          or next;
 
-        next if ! $begin || ! $end;  # probably not a netmask entry
+        next if !$begin || !$end;    # probably not a netmask entry
 
-        if (    ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion))
+        if (   ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion))
-             && ip_bincomp($bin_ip, 'lt', ip_iptobin($end,   $rversion))
+            && ip_bincomp($bin_ip, 'lt', ip_iptobin($end, $rversion)))
-           ) {
+        {
             $self->log(LOGINFO, "pass, cidr match ($ip)");
             return 1;
         }
@@ -175,75 +175,75 @@ sub is_in_cidr_block {
 
     $self->log(LOGDEBUG, "no cidr match");
     return;
-};
+}
 
 sub is_octet_match {
     my $self = shift;
 
     my $ip = $self->qp->connection->remote_ip;
 
-    if ( $ip eq '::1' ) {
+    if ($ip eq '::1') {
         $self->log(LOGINFO, "pass, octet matched localhost ($ip)");
         return 1;
-    };
+    }
 
     my $more_relay_clients = $self->qp->config('morerelayclients', 'map');
 
     my $ipv6 = $ip =~ /:/ ? 1 : 0;
 
-    if ( $ipv6 && $ip =~ /::/ ) {  # IPv6 compressed notation
+    if ($ipv6 && $ip =~ /::/) {    # IPv6 compressed notation
-        $ip = Net::IP::ip_expand_address($ip,6);
+        $ip = Net::IP::ip_expand_address($ip, 6);
-    };
+    }
 
     while ($ip) {
-        if ( exists $self->{_octets}{$ip} ) {
+        if (exists $self->{_octets}{$ip}) {
             $self->log(LOGINFO, "pass, octet match in relayclients ($ip)");
             return 1;
-        };
+        }
 
-        if ( exists $more_relay_clients->{$ip} ) {
+        if (exists $more_relay_clients->{$ip}) {
             $self->log(LOGINFO, "pass, octet match in morerelayclients ($ip)");
             return 1;
-        };
+        }
 
         # added IPv6 support (Michael Holzt - 2012-11-14)
-        if ( $ipv6 ) {
+        if ($ipv6) {
-            $ip =~ s/[0-9a-f]:?$//;       # strip off another nibble
+            $ip =~ s/[0-9a-f]:?$//;    # strip off another nibble
             chop $ip if ':' eq substr($ip, -1, 1);
         }
         else {
-            $ip =~ s/\d+\.?$// or last;   # strip off another 8 bits
+            $ip =~ s/\d+\.?$// or last;    # strip off another 8 bits
         }
     }
 
-    $self->log(LOGDEBUG, "no octet match" );
+    $self->log(LOGDEBUG, "no octet match");
     return;
 }
 
 sub hook_connect {
     my ($self, $transaction) = @_;
 
-    if ( $self->is_in_norelayclients() ) {
+    if ($self->is_in_norelayclients()) {
         $self->qp->connection->relay_client(0);
         delete $ENV{RELAYCLIENT};
         $self->log(LOGINFO, "fail, disabled by norelayclients");
         return (DECLINED);
     }
 
-    if ( $ENV{RELAYCLIENT} ) {
+    if ($ENV{RELAYCLIENT}) {
         $self->qp->connection->relay_client(1);
         $self->log(LOGINFO, "pass, enabled by env");
         return (DECLINED);
-    };
+    }
 
     $self->populate_relayclients();
 
-# 95586 (connect) relay: pass, octet match in relayclients (127.0.0.)
+    # 95586 (connect) relay: pass, octet match in relayclients (127.0.0.)
 
-    if ( $self->is_in_cidr_block() || $self->is_octet_match() ) {
+    if ($self->is_in_cidr_block() || $self->is_octet_match()) {
         $self->qp->connection->relay_client(1);
         return (DECLINED);
-    };
+    }
 
     $self->log(LOGINFO, "skip, no match");
     return (DECLINED);
@@ -251,9 +251,9 @@ sub hook_connect {
 
 sub relay_only {
     my $self = shift;
-    if ( $self->qp->connection->relay_client ) {
+    if ($self->qp->connection->relay_client) {
         return (OK);
-    };
+    }
     return (DENY);
 }
 

plugins/resolvable_fromhost

@@ -86,9 +86,9 @@ sub register {
     foreach (keys %args) {
         $self->{_args}->{$_} = $args{$_};
     }
-    if ( ! defined $self->{_args}{reject} ) {
+    if (!defined $self->{_args}{reject}) {
         $self->{_args}{reject} = 1;
-    };
+    }
     $self->{_args}{reject_type} ||= 'soft';
 }
 
@@ -97,82 +97,86 @@ sub hook_mail {
 
     return DECLINED if $self->is_immune();
 
-    if ( $sender eq '<>' ) {
+    if ($sender eq '<>') {
         $transaction->notes('resolvable_fromhost', 'null');
         $self->log(LOGINFO, "pass, null sender");
         return DECLINED;
-    };
+    }
 
     $self->populate_invalid_networks();
     my $resolved = $self->check_dns($sender->host, $transaction);
 
-    return DECLINED if $resolved;  # success, no need to continue
+    return DECLINED if $resolved;    # success, no need to continue
-    #return DECLINED if $sender->host;  # reject later
+         #return DECLINED if $sender->host;  # reject later
 
     my $result = $transaction->notes('resolvable_fromhost') or do {
-        if ( $self->{_args}{reject} ) {;
+        if ($self->{_args}{reject}) {
-            $self->log(LOGINFO, 'fail, missing result' );
+            ;
-            return Qpsmtpd::DSN->temp_resolver_failed( $self->get_reject_type(), '' );
+            $self->log(LOGINFO, 'fail, missing result');
-        };
+            return Qpsmtpd::DSN->temp_resolver_failed($self->get_reject_type(),
-        $self->log(LOGINFO, 'fail, missing result, reject disabled' );
+                                                      '');
+        }
+        $self->log(LOGINFO, 'fail, missing result, reject disabled');
         return DECLINED;
     };
 
-    return DECLINED if $result =~ /^(?:a|ip|mx)$/;         # success
+    return DECLINED if $result =~ /^(?:a|ip|mx)$/;                   # success
-    return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/; # immunity
+    return DECLINED if $result =~ /^(?:whitelist|null|naughty)$/;    # immunity
 
-    $self->adjust_karma( -1 );
+    $self->adjust_karma(-1);
 
-    if ( ! $self->{_args}{reject} ) {;
+    if (!$self->{_args}{reject}) {
-        $self->log(LOGINFO, "fail, reject disabled, $result" );
+        ;
+        $self->log(LOGINFO, "fail, reject disabled, $result");
         return DECLINED;
-    };
+    }
 
-    $self->log(LOGINFO, "fail, $result" ); # log error
+    $self->log(LOGINFO, "fail, $result");                            # log error
-    return Qpsmtpd::DSN->addr_bad_from_system( $self->get_reject_type(),
+    return
-                            "FQDN required in the envelope sender");
+      Qpsmtpd::DSN->addr_bad_from_system($self->get_reject_type(),
+                                        "FQDN required in the envelope sender");
 }
 
 sub check_dns {
     my ($self, $host, $transaction) = @_;
 
     # we can't even parse a hostname out of the address
-    if ( ! $host ) {
+    if (!$host) {
         $transaction->notes('resolvable_fromhost', 'unparsable host');
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
         return;
-    };
+    }
 
     $transaction->notes('resolvable_fromhost_host', $host);
 
-    if ( $host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/ ) {
+    if ($host =~ m/^\[(\d{1,3}\.){3}\d{1,3}\]$/) {
         $self->log(LOGINFO, "skip, $host is an IP");
         $transaction->notes('resolvable_fromhost', 'ip');
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
         return 1;
-    };
+    }
 
     my $res = new Net::DNS::Resolver(dnsrch => 0);
     $res->tcp_timeout(30);
     $res->udp_timeout(30);
 
-    my $has_mx = $self->get_and_validate_mx( $res, $host, $transaction );
+    my $has_mx = $self->get_and_validate_mx($res, $host, $transaction);
-    return 1 if $has_mx == 1;  # success, has MX!
+    return 1 if $has_mx == 1;     # success, has MX!
-    return if $has_mx == -1;   # has invalid MX records
+    return   if $has_mx == -1;    # has invalid MX records
-    # at this point, no MX for fh is resolvable
+                                  # at this point, no MX for fh is resolvable
 
-    my @host_answers = $self->get_host_records( $res, $host, $transaction );
+    my @host_answers = $self->get_host_records($res, $host, $transaction);
     foreach my $rr (@host_answers) {
-        if ( $rr->type eq 'A' || $rr->type eq 'AAAA' ) {
+        if ($rr->type eq 'A' || $rr->type eq 'AAAA') {
             $self->log(LOGINFO, "pass, found A for $host");
             $transaction->notes('resolvable_fromhost', 'a');
             return $self->ip_is_valid($rr->address);
-        };
+        }
-        if ( $rr->type eq 'MX' ) {
+        if ($rr->type eq 'MX') {
             $self->log(LOGINFO, "pass, found MX for $host");
             $transaction->notes('resolvable_fromhost', 'mx');
             return $self->mx_address_resolves($rr->exchange, $host);
-        };
+        }
     }
     return;
 }
@@ -193,33 +197,34 @@ sub ip_is_valid {
 }
 
 sub get_and_validate_mx {
-    my ($self, $res, $host, $transaction ) = @_;
+    my ($self, $res, $host, $transaction) = @_;
 
     my @mx = mx($res, $host);
-    if ( ! scalar @mx ) {    # no mx records
+    if (!scalar @mx) {    # no mx records
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
         $self->log(LOGINFO, "$host has no MX");
         return 0;
-    };
+    }
 
     foreach my $mx (@mx) {
+
         # if any MX is valid, then we consider the domain resolvable
-        if ( $self->mx_address_resolves($mx->exchange, $host) ) {
+        if ($self->mx_address_resolves($mx->exchange, $host)) {
             $self->log(LOGINFO, "pass, $host has MX at " . $mx->exchange);
             $transaction->notes('resolvable_fromhost', 'mx');
             return 1;
-        };
+        }
     }
 
     # if there are MX records, and we got here, none are valid
     #$self->log(LOGINFO, "fail, invalid MX for $host");
     $transaction->notes('resolvable_fromhost', "invalid MX for $host");
-    $self->adjust_karma( -1 );
+    $self->adjust_karma(-1);
     return -1;
-};
+}
 
 sub get_host_records {
-    my ($self, $res, $host, $transaction ) = @_;
+    my ($self, $res, $host, $transaction) = @_;
 
     my @answers;
     my $query = $res->search($host);
@@ -239,15 +244,15 @@ sub get_host_records {
         }
     }
 
-    if ( ! scalar @answers) {
+    if (!scalar @answers) {
-        if ( $res->errorstring ne 'NXDOMAIN' ) {
+        if ($res->errorstring ne 'NXDOMAIN') {
             $self->log(LOGWARN, "fail, query for $host, ", $res->errorstring);
-        };
+        }
         return;
-    };
+    }
 
     return @answers;
-};
+}
 
 sub mx_address_resolves {
     my ($self, $name, $fromhost) = @_;
@@ -271,15 +276,16 @@ sub mx_address_resolves {
             }
         }
     }
-    if (! @mx_answers) {
+    if (!@mx_answers) {
-        if ( $res->errorstring eq 'NXDOMAIN' ) {
+        if ($res->errorstring eq 'NXDOMAIN') {
-            $self->log(LOGWARN, "fail, query for $fromhost, ", $res->errorstring);
+            $self->log(LOGWARN, "fail, query for $fromhost, ",
-        };
+                       $res->errorstring);
+        }
         return;
     }
 
     foreach my $rr (@mx_answers) {
-        next if ( $rr->type ne 'A' && $rr->type ne 'AAAA' );
+        next if ($rr->type ne 'A' && $rr->type ne 'AAAA');
         return $self->ip_is_valid($rr->address);
     }
 
@@ -290,11 +296,11 @@ sub populate_invalid_networks {
     my $self = shift;
 
     foreach my $i ($self->qp->config("invalid_resolvable_fromhost")) {
-        $i =~ s/^\s*//;  # trim leading spaces
+        $i =~ s/^\s*//;    # trim leading spaces
-        $i =~ s/\s*$//;  # trim trailing spaces
+        $i =~ s/\s*$//;    # trim trailing spaces
         if ($i =~ m#^((\d{1,3}\.){3}\d{1,3})/(\d\d?)#) {
             $invalid{$1} = $3;
         }
     }
-};
+}
 

plugins/rhsbl

@@ -31,29 +31,29 @@ use warnings;
 use Qpsmtpd::Constants;
 
 sub register {
-    my ($self, $qp ) = (shift, shift);
+    my ($self, $qp) = (shift, shift);
 
-    if ( @_ == 1 ) {
+    if (@_ == 1) {
-        $self->legacy_positional_args( @_ );
+        $self->legacy_positional_args(@_);
     }
     else {
-        $self->{_args} = { @_ };
+        $self->{_args} = {@_};
-    };
+    }
 
-    $self->{_args}{reject} = 1 if ! defined $self->{_args}{reject};
+    $self->{_args}{reject} = 1 if !defined $self->{_args}{reject};
     $self->{_args}{reject_type} ||= 'perm';
 }
 
 sub legacy_positional_args {
     my ($self, $denial) = @_;
 
-    if ( defined $denial && $denial =~ /^disconnect$/i ) {
+    if (defined $denial && $denial =~ /^disconnect$/i) {
         $self->{_args}{reject_type} = 'disconnect';
     }
     else {
         $self->{_args}{reject_type} = 'perm';
     }
-};
+}
 
 sub hook_mail {
     my ($self, $transaction, $sender, %param) = @_;
@@ -63,7 +63,7 @@ sub hook_mail {
     if ($sender->format eq '<>') {
         $self->log(LOGINFO, 'pass, null sender');
         return DECLINED;
-    };
+    }
 
     my %rhsbl_zones = $self->populate_zones() or return DECLINED;
 
@@ -73,47 +73,53 @@ sub hook_mail {
     for my $host (@hosts) {
         for my $rhsbl (keys %rhsbl_zones) {
             my $query;
-# fix to find TXT records, if the rhsbl_zones line doesn't have second field
+
+    # fix to find TXT records, if the rhsbl_zones line doesn't have second field
             if (defined($rhsbl_zones{$rhsbl})) {
                 $self->log(LOGDEBUG, "Checking $host.$rhsbl for A record");
                 $query = $res->query("$host.$rhsbl");
-            } else {
+            }
+            else {
                 $self->log(LOGDEBUG, "Checking $host.$rhsbl for TXT record");
                 $query = $res->query("$host.$rhsbl", 'TXT');
             }
 
-            if ( ! $query) {
+            if (!$query) {
-                if  ( $res->errorstring ne 'NXDOMAIN' ) {
+                if ($res->errorstring ne 'NXDOMAIN') {
                     $self->log(LOGCRIT, "query failed: ", $res->errorstring);
-                };
+                }
                 next;
-            };
+            }
 
             my $result;
             foreach my $rr ($query->answer) {
-                $self->log(LOGDEBUG, 'got an ' . $rr->type . ' record ' . $rr->name);
+                $self->log(LOGDEBUG,
+                           'got an ' . $rr->type . ' record ' . $rr->name);
                 if ($rr->type eq 'A') {
-                    $self->log(LOGDEBUG, "A record found for $result with IP " . $rr->address);
+                    $self->log(LOGDEBUG,
+                          "A record found for $result with IP " . $rr->address);
                     $result = $rr->name;
                 }
                 elsif ($rr->type eq 'TXT') {
                     $result = $rr->txtdata;
                     $self->log(LOGDEBUG, "TXT record found: " . $rr->txtdata);
-                };
+                }
 
-                next if ! $result;
+                next if !$result;
 
                 $self->log(LOGINFO, "fail, $result");
 
-                if ( $transaction->sender ) {
+                if ($transaction->sender) {
                     my $host = $transaction->sender->host;
-                    if ($result =~ /^$host\./ ) {
+                    if ($result =~ /^$host\./) {
-                        return $self->get_reject( "Mail from $host rejected because it $result" );
+                        return $self->get_reject(
-                    };
+                                 "Mail from $host rejected because it $result");
-                };
+                    }
+                }
 
                 my $hello = $self->qp->connection->hello_host;
-                return $self->get_reject( "Mail from HELO $hello rejected because it $result" );
+                return $self->get_reject(
+                           "Mail from HELO $hello rejected because it $result");
             }
         }
     }
@@ -125,15 +131,14 @@ sub hook_mail {
 sub populate_zones {
     my $self = shift;
 
-    my %rhsbl_zones
+    my %rhsbl_zones =
-        = map { (split /\s+/, $_, 2)[0,1] }
+      map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones');
-            $self->qp->config('rhsbl_zones');
 
-    if ( ! keys %rhsbl_zones ) {
+    if (!keys %rhsbl_zones) {
         $self->log(LOGINFO, 'pass, no zones');
         return;
-    };
+    }
 
     return %rhsbl_zones;
-};
+}
 

plugins/sender_permitted_from

@@ -68,19 +68,19 @@ use Qpsmtpd::Constants;
 sub register {
     my ($self, $qp, %args) = @_;
     eval 'use Mail::SPF';
-    if ( $@ ) {
+    if ($@) {
         warn "skip: plugin disabled, is Mail::SPF installed?\n";
         $self->log(LOGERROR, "skip: plugin disabled, is Mail::SPF installed?");
         return;
-    };
+    }
-    $self->{_args} = { %args };
+    $self->{_args} = {%args};
-    if ( $self->{_args}{spf_deny} ) {
+    if ($self->{_args}{spf_deny}) {
         $self->{_args}{reject} = 3 if $self->{_args}{spf_deny} == 1;
         $self->{_args}{reject} = 4 if $self->{_args}{spf_deny} == 2;
-    };
+    }
-    if ( ! $self->{_args}{reject} && $self->qp->config('spfbehavior') ) {
+    if (!$self->{_args}{reject} && $self->qp->config('spfbehavior')) {
         $self->{_args}{reject} = $self->qp->config('spfbehavior');
-    };
+    }
     $self->register_hook('mail',      'mail_handler');
     $self->register_hook('data_post', 'data_post_handler');
 }
@@ -91,28 +91,29 @@ sub mail_handler {
     return (DECLINED) if $self->is_immune();
 
     my $format = $sender->format;
-    if ( $format eq '<>' || ! $sender->host || ! $sender->user ) {
+    if ($format eq '<>' || !$sender->host || !$sender->user) {
-        $self->log( LOGINFO, "skip, null sender" );
+        $self->log(LOGINFO, "skip, null sender");
         return (DECLINED, "SPF - null sender");
-    };
+    }
 
-    if ( $self->qp->connection->relay_client ) {
+    if ($self->qp->connection->relay_client) {
-        $self->log( LOGINFO, "skip, relay_client" );
+        $self->log(LOGINFO, "skip, relay_client");
         return (DECLINED, "SPF - relaying permitted");
-    };
+    }
 
-    if ( ! $self->{_args}{reject} ) {
+    if (!$self->{_args}{reject}) {
-        $self->log( LOGINFO, "skip, reject disabled" );
+        $self->log(LOGINFO, "skip, reject disabled");
         return (DECLINED);
-    };
+    }
 
-    my $client_ip  = $self->qp->connection->remote_ip;
+    my $client_ip = $self->qp->connection->remote_ip;
-    my $from       = $sender->user . '@' . lc($sender->host);
+    my $from      = $sender->user . '@' . lc($sender->host);
-    my $helo       = $self->qp->connection->hello_host;
+    my $helo      = $self->qp->connection->hello_host;
-    my $scope      = $from ? 'mfrom' : 'helo';
+    my $scope     = $from ? 'mfrom' : 'helo';
-    my %req_params = ( versions   => [1, 2],        # optional
+    my %req_params = (
-                       scope      => $scope,
+        versions => [1, 2],    # optional
-                       ip_address => $client_ip,
+        scope => $scope,
+        ip_address => $client_ip,
                      );
 
     if ($scope =~ /^mfrom|pra$/) {
@@ -127,7 +128,7 @@ sub mail_handler {
     my $spf_server = Mail::SPF::Server->new();
     my $request    = Mail::SPF::Request->new(%req_params);
     my $result     = $spf_server->process($request) or do {
-        $self->log( LOGINFO, "fail, no result" );
+        $self->log(LOGINFO, "fail, no result");
         return DECLINED;
     };
 
@@ -137,49 +138,49 @@ sub mail_handler {
     my $why    = $result->local_explanation;
     my $reject = $self->{_args}{reject};
 
-    if ( ! $code ) {
+    if (!$code) {
-        $self->log( LOGINFO, "fail, no response" );
+        $self->log(LOGINFO, "fail, no response");
         return (DENYSOFT, "SPF - no response") if $reject >= 2;
         return (DECLINED, "SPF - no response");
-    };
+    }
 
-    if ( ! $reject ) {
+    if (!$reject) {
-        $self->log( LOGINFO, "fail, no reject policy ($code: $why)" );
+        $self->log(LOGINFO, "fail, no reject policy ($code: $why)");
-        return (DECLINED, "SPF - $code: $why")
+        return (DECLINED, "SPF - $code: $why");
-    };
+    }
 
-# SPF result codes: pass fail softfail neutral none error permerror temperror
+   # SPF result codes: pass fail softfail neutral none error permerror temperror
     return $self->handle_code_none($reject, $why) if $code eq 'none';
-    if ( $code eq 'fail' ) {
+    if ($code eq 'fail') {
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
         return $self->handle_code_fail($reject, $why);
     }
-    elsif ( $code eq 'softfail' ) {
+    elsif ($code eq 'softfail') {
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
         return $self->handle_code_softfail($reject, $why);
     }
-    elsif ( $code eq 'pass' ) {
+    elsif ($code eq 'pass') {
-        $self->adjust_karma( 1 );
+        $self->adjust_karma(1);
         $transaction->notes('spf_pass_host', lc $sender->host);
-        $self->log(LOGINFO, "pass, $code: $why" );
+        $self->log(LOGINFO, "pass, $code: $why");
         return (DECLINED);
     }
-    elsif ( $code eq 'neutral' ) {
+    elsif ($code eq 'neutral') {
-        $self->log(LOGINFO, "fail, $code, $why" );
+        $self->log(LOGINFO, "fail, $code, $why");
         return (DENY, "SPF - $code: $why") if $reject >= 5;
     }
-    elsif ( $code eq 'error' ) {
+    elsif ($code eq 'error') {
-        $self->log(LOGINFO, "fail, $code, $why" );
+        $self->log(LOGINFO, "fail, $code, $why");
-        return (DENY, "SPF - $code: $why") if $reject >= 6;
+        return (DENY,     "SPF - $code: $why") if $reject >= 6;
         return (DENYSOFT, "SPF - $code: $why") if $reject > 3;
     }
-    elsif ( $code eq 'permerror' ) {
+    elsif ($code eq 'permerror') {
-        $self->log(LOGINFO, "fail, $code, $why" );
+        $self->log(LOGINFO, "fail, $code, $why");
-        return (DENY, "SPF - $code: $why") if $reject >= 6;
+        return (DENY,     "SPF - $code: $why") if $reject >= 6;
         return (DENYSOFT, "SPF - $code: $why") if $reject > 3;
     }
-    elsif ( $code eq 'temperror' ) {
+    elsif ($code eq 'temperror') {
-        $self->log(LOGINFO, "fail, $code, $why" );
+        $self->log(LOGINFO, "fail, $code, $why");
         return (DENYSOFT, "SPF - $code: $why") if $reject >= 2;
     }
 
@@ -188,60 +189,61 @@ sub mail_handler {
 }
 
 sub handle_code_none {
-    my ($self, $reject, $why ) = @_;
+    my ($self, $reject, $why) = @_;
 
-    if ( $reject >= 6 ) {
+    if ($reject >= 6) {
-        $self->log(LOGINFO, "fail, none, $why" );
+        $self->log(LOGINFO, "fail, none, $why");
         return (DENY, "SPF - none: $why");
-    };
+    }
 
-    $self->log(LOGINFO, "pass, none, $why" );
+    $self->log(LOGINFO, "pass, none, $why");
     return DECLINED;
-};
+}
 
 sub handle_code_fail {
-    my ($self, $reject, $why ) = @_;
+    my ($self, $reject, $why) = @_;
 
-    if ( $reject >= 2 ) {
+    if ($reject >= 2) {
-        $self->log(LOGINFO, "fail, $why" );
+        $self->log(LOGINFO, "fail, $why");
         return (DENY, "SPF - forgery: $why") if $reject >= 3;
-        return (DENYSOFT, "SPF - fail: $why")
+        return (DENYSOFT, "SPF - fail: $why");
-    };
+    }
 
-    $self->log(LOGINFO, "pass, fail tolerated, $why" );
+    $self->log(LOGINFO, "pass, fail tolerated, $why");
     return DECLINED;
-};
+}
 
 sub handle_code_softfail {
-    my ($self, $reject, $why ) = @_;
+    my ($self, $reject, $why) = @_;
 
-    if ( $reject >= 3 ) {
+    if ($reject >= 3) {
-        $self->log(LOGINFO, "fail, soft, $why" );
+        $self->log(LOGINFO, "fail, soft, $why");
-        return (DENY, "SPF - fail: $why") if $reject >= 4;
+        return (DENY,     "SPF - fail: $why") if $reject >= 4;
         return (DENYSOFT, "SPF - fail: $why") if $reject >= 3;
-    };
+    }
 
-    $self->log(LOGINFO, "pass, softfail tolerated, $why" );
+    $self->log(LOGINFO, "pass, softfail tolerated, $why");
     return DECLINED;
-};
+}
 
 sub data_post_handler {
     my ($self, $transaction) = @_;
 
     my $result = $transaction->notes('spfquery') or return DECLINED;
 
-# if we skipped processing in mail_handler, we should skip here too
+    # if we skipped processing in mail_handler, we should skip here too
     return (DECLINED) if $self->is_immune();
 
     $self->log(LOGDEBUG, "result was $result->code");
 
-    if ( ! $transaction->header ) {
+    if (!$transaction->header) {
         $self->log(LOGERROR, "missing headers!");
         return DECLINED;
-    };
+    }
 
     $transaction->header->add('Received-SPF', $result->received_spf_header, 0);
-# consider also adding SPF status to Authentication-Results header
+
+    # consider also adding SPF status to Authentication-Results header
 
     return DECLINED;
 }
@@ -249,20 +251,20 @@ sub data_post_handler {
 sub is_special_recipient {
     my ($self, $rcpt) = @_;
 
-    if ( ! $rcpt ) {
+    if (!$rcpt) {
         $self->log(LOGINFO, "skip: missing recipient");
         return 1;
-    };
+    }
-    if ( ! $rcpt->user ) {
+    if (!$rcpt->user) {
         $self->log(LOGINFO, "skip: missing user");
         return 1;
-    };
+    }
 
     # special addresses don't get SPF-tested.
-    if ( $rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i ) {
+    if ($rcpt->user =~ /^(?:postmaster|abuse|mailer-daemon|root)$/i) {
-        $self->log(LOGINFO, "skip: special user (".$rcpt->user.")");
+        $self->log(LOGINFO, "skip: special user (" . $rcpt->user . ")");
         return 1;
-    };
+    }
 
     return;
-};
+}

plugins/spamassassin

@@ -153,17 +153,20 @@ use IO::Handle;
 sub register {
     my ($self, $qp, %args) = @_;
 
-    $self->log(LOGERROR, "Bad parameters for the spamassassin plugin") if @_ % 2;
+    $self->log(LOGERROR, "Bad parameters for the spamassassin plugin")
+      if @_ % 2;
 
-    $self->{_args} = { %args };
+    $self->{_args} = {%args};
 
     # backwards compatibility with previous config syntax
-    if ( ! defined $self->{_args}{reject} && defined $self->{_args}{reject_threshold} ) {
+    if (  !defined $self->{_args}{reject}
+        && defined $self->{_args}{reject_threshold})
+    {
         $self->{_args}{reject} = $self->{_args}{reject_threshold};
-    };
+    }
-    if ( ! defined $self->{_args}{reject_type} ) {
+    if (!defined $self->{_args}{reject_type}) {
         $self->{_args}{reject_type} = 'perm';
-    };
+    }
 
     $self->register_hook('data_post', 'data_post_handler');
 }
@@ -173,24 +176,25 @@ sub data_post_handler {
 
     return (DECLINED) if $self->is_immune();
 
-    if ( $transaction->data_size > 500_000 ) {
+    if ($transaction->data_size > 500_000) {
-        $self->log(LOGINFO, "skip: too large (".$transaction->data_size.")");
+        $self->log(LOGINFO,
+                   "skip: too large (" . $transaction->data_size . ")");
         return (DECLINED);
-    };
+    }
 
     my $SPAMD    = $self->connect_to_spamd() or return (DECLINED);
-    my $username = $self->select_spamd_username( $transaction );
+    my $username = $self->select_spamd_username($transaction);
     my $message  = $self->assemble_message($transaction);
     my $length   = length $message;
 
-    $self->print_to_spamd( $SPAMD, $message, $length, $username );
+    $self->print_to_spamd($SPAMD, $message, $length, $username);
-    shutdown($SPAMD, 1); # close our side of the socket (tell spamd we're done)
+    shutdown($SPAMD, 1);  # close our side of the socket (tell spamd we're done)
-    my $headers = $self->parse_spamd_response( $SPAMD ) or return (DECLINED);
+    my $headers = $self->parse_spamd_response($SPAMD) or return (DECLINED);
 
-    $self->insert_spam_headers( $transaction, $headers, $username );
+    $self->insert_spam_headers($transaction, $headers, $username);
-    $self->munge_subject( $transaction );
+    $self->munge_subject($transaction);
-    return $self->reject( $transaction );
+    return $self->reject($transaction);
-};
+}
 
 sub select_spamd_username {
     my ($self, $transaction) = @_;
@@ -198,40 +202,41 @@ sub select_spamd_username {
     my $username = $self->{_args}{spamd_user} || getpwuid($>);
 
     my $recipient_count = scalar $transaction->recipients;
-    if ( $recipient_count > 1 ) {
+    if ($recipient_count > 1) {
         $self->log(LOGDEBUG, "Message has $recipient_count recipients");
         return $username;
-    };
+    }
 
-    if ( $username eq 'vpopmail' ) {
+    if ($username eq 'vpopmail') {
-# use the recipients email address as username. This enables per-user SA prefs
+
+  # use the recipients email address as username. This enables per-user SA prefs
         $username = ($transaction->recipients)[0]->address;
     }
     else {
         $self->log(LOGDEBUG, "skipping per-user SA prefs");
-    };
+    }
 
     return $username;
-};
+}
 
 sub parse_spamd_response {
-    my ( $self, $SPAMD ) = @_;
+    my ($self, $SPAMD) = @_;
 
-    my $line0 = <$SPAMD>; # get the first protocol line
+    my $line0 = <$SPAMD>;    # get the first protocol line
-        if ( $line0 !~ /EX_OK/ ) {
+    if ($line0 !~ /EX_OK/) {
-            $self->log(LOGERROR, "invalid response from spamd: $line0");
+        $self->log(LOGERROR, "invalid response from spamd: $line0");
-            return;
+        return;
-        };
+    }
 
     my (%new_headers, $last_header);
     while (<$SPAMD>) {
         s/[\r\n]//g;
-        if ( m/^(X-Spam-.*?): (.*)?/ ) {
+        if (m/^(X-Spam-.*?): (.*)?/) {
             $new_headers{$1} = $2 || '';
             $last_header = $1;
             next;
         }
-        if ( $last_header && m/^(\s+.*)/ ) { # a folded line, append to last
+        if ($last_header && m/^(\s+.*)/) {    # a folded line, append to last
             $new_headers{$last_header} .= CRLF . "\t" . $1;
             next;
         }
@@ -241,37 +246,41 @@ sub parse_spamd_response {
     $self->log(LOGDEBUG, "finished reading from spamd");
 
     return scalar keys %new_headers ? \%new_headers : undef;
-};
+}
 
 sub insert_spam_headers {
-    my ( $self, $transaction, $new_headers, $username ) = @_;
+    my ($self, $transaction, $new_headers, $username) = @_;
 
-    if ( $self->{_args}{headers} && $self->{_args}{headers} eq 'none' ) {
+    if ($self->{_args}{headers} && $self->{_args}{headers} eq 'none') {
-        my $r = $self->parse_spam_header( $new_headers->{'X-Spam-Status'} );
+        my $r = $self->parse_spam_header($new_headers->{'X-Spam-Status'});
         $transaction->notes('spamassassin', $r);
         return;
-    };
+    }
 
     my $recipient_count = scalar $transaction->recipients;
 
-    $self->_cleanup_spam_header($transaction, 'X-Spam-User'); # always clean up
+    $self->_cleanup_spam_header($transaction, 'X-Spam-User');  # always clean up
-    if ( $recipient_count > 1 ) {                 # add for multiple recipients
+    if ($recipient_count > 1) {    # add for multiple recipients
-        $transaction->header->add('X-Spam-User', $username . ", $recipient_count recipients", 0);
+        $transaction->header->add('X-Spam-User',
-    };
+                                  $username . ", $recipient_count recipients",
+                                  0);
+    }
 
-    foreach my $name ( keys %$new_headers ) {
+    foreach my $name (keys %$new_headers) {
-        next if $name eq 'X-Spam-Prev-Subject'; # might exist if SA rewrote subject
+        next
-        if ( $name eq 'X-Spam-Report' ) {
+          if $name eq 'X-Spam-Prev-Subject'; # might exist if SA rewrote subject
-            next;   # Mail::Header mangles this prefolded header
+        if ($name eq 'X-Spam-Report') {
-#           $self->log(LOGDEBUG, $new_headers->{$name} );
+            next;    # Mail::Header mangles this prefolded header
-        };
+
-        if ( $name eq 'X-Spam-Status' ) {
+            #           $self->log(LOGDEBUG, $new_headers->{$name} );
-            $self->parse_spam_header( $new_headers->{$name} );
+        }
-        };
+        if ($name eq 'X-Spam-Status') {
-        $new_headers->{$name} =~ s/\015//; # hack for outlook
+            $self->parse_spam_header($new_headers->{$name});
+        }
+        $new_headers->{$name} =~ s/\015//;    # hack for outlook
         $self->_cleanup_spam_header($transaction, $name);
         $transaction->header->add($name, $new_headers->{$name}, 0);
-    };
+    }
 }
 
 sub assemble_message {
@@ -279,39 +288,40 @@ sub assemble_message {
 
     $transaction->body_resetpos;
 
-    my $message = "X-Envelope-From: "
+    my $message =
-        . $transaction->sender->format . "\n"
+        "X-Envelope-From: "
-        . $transaction->header->as_string . "\n\n";
+      . $transaction->sender->format . "\n"
+      . $transaction->header->as_string . "\n\n";
 
-    while (my $line = $transaction->body_getline) { $message .= $line; };
+    while (my $line = $transaction->body_getline) { $message .= $line; }
 
-    $message = join(CRLF, split/\n/, $message);
+    $message = join(CRLF, split /\n/, $message);
     return $message . CRLF;
-};
+}
 
 sub connect_to_spamd {
-    my $self = shift;
+    my $self   = shift;
     my $socket = $self->{_args}{spamd_socket};
     my $SPAMD;
-    if ( $socket && $socket =~ /\// ) {  # file path
+    if ($socket && $socket =~ /\//) {    # file path
-        $SPAMD = $self->connect_to_spamd_socket( $socket );
+        $SPAMD = $self->connect_to_spamd_socket($socket);
     }
     else {
-        $SPAMD = $self->connect_to_spamd_tcpip( $socket );
+        $SPAMD = $self->connect_to_spamd_tcpip($socket);
-    };
+    }
 
-    return if ! $SPAMD;
+    return if !$SPAMD;
     $SPAMD->autoflush(1);
     return $SPAMD;
-};
+}
 
 sub connect_to_spamd_socket {
-    my ( $self, $socket ) = @_;
+    my ($self, $socket) = @_;
 
-    if ( ! $socket || $socket !~ /^([\w\/.-]+)$/ ) {   # Unix Domain Socket
+    if (!$socket || $socket !~ /^([\w\/.-]+)$/) {    # Unix Domain Socket
         $self->log(LOGERROR, "not a valid path");
         return;
-    };
+    }
 
     # Sanitize for use with taint mode
     $socket =~ /^([\w\/.-]+)$/;
@@ -321,7 +331,7 @@ sub connect_to_spamd_socket {
         $self->log(LOGERROR, "Could not open socket: $!");
         return;
     };
-    my $paddr = sockaddr_un( $socket );
+    my $paddr = sockaddr_un($socket);
 
     connect($SPAMD, $paddr) or do {
         $self->log(LOGERROR, "Could not connect to spamd socket: $!");
@@ -330,23 +340,23 @@ sub connect_to_spamd_socket {
 
     $self->log(LOGDEBUG, "connected to spamd");
     return $SPAMD;
-};
+}
 
 sub connect_to_spamd_tcpip {
-    my ( $self, $socket ) = @_;
+    my ($self, $socket) = @_;
 
-    my $remote  = 'localhost';
+    my $remote = 'localhost';
-    my $port    = 783;
+    my $port   = 783;
 
     if (defined $socket && $socket =~ /^([\w.-]+):(\d+)$/) {
-        $remote  = $1;
+        $remote = $1;
-        $port    = $2;
+        $port   = $2;
     }
-    if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') };
+    if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
-    if ( ! $port ) {
+    if (!$port) {
         $self->log(LOGERROR, "No spamd port, check your spamd_socket config.");
         return;
-    };
+    }
     my $iaddr = inet_aton($remote) or do {
         $self->log(LOGERROR, "Could not resolve host: $remote");
         return;
@@ -361,24 +371,25 @@ sub connect_to_spamd_tcpip {
 
     connect($SPAMD, $paddr) or do {
         $self->log(LOGERROR, "Could not connect to spamd: $!");
-         return;
+        return;
     };
 
     $self->log(LOGDEBUG, "connected to spamd");
     return $SPAMD;
-};
+}
 
 sub print_to_spamd {
-    my ( $self, $SPAMD, $message, $length, $username ) = @_;
+    my ($self, $SPAMD, $message, $length, $username) = @_;
 
     print $SPAMD "HEADERS SPAMC/1.4" . CRLF;
     print $SPAMD "Content-length: $length" . CRLF;
     print $SPAMD "User: $username" . CRLF;
     print $SPAMD CRLF;
-    print $SPAMD $message or $self->log(LOGWARN, "Could not print to spamd: $!");
+    print $SPAMD $message
+      or $self->log(LOGWARN, "Could not print to spamd: $!");
 
     $self->log(LOGDEBUG, "check_spam: finished sending to spamd");
-};
+}
 
 sub reject {
     my ($self, $transaction) = @_;
@@ -387,32 +398,32 @@ sub reject {
         $self->log(LOGNOTICE, "error, no results");
         return DECLINED;
     };
-    my $score  = $sa_results->{score};
+    my $score = $sa_results->{score};
-    if ( ! defined $score ) {
+    if (!defined $score) {
         $self->log(LOGERROR, "error, error getting score");
         return DECLINED;
-    };
+    }
 
     my $ham_or_spam = $sa_results->{is_spam} eq 'Yes' ? 'Spam' : 'Ham';
-    if ( $ham_or_spam eq 'Spam' ) {
+    if ($ham_or_spam eq 'Spam') {
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
-    };
+    }
     my $status = "$ham_or_spam, $score";
-    my $learn = '';
+    my $learn  = '';
-    my $al = $sa_results->{autolearn}; # subject to local SA learn scores
+    my $al     = $sa_results->{autolearn};    # subject to local SA learn scores
-    if ( $al ) {
+    if ($al) {
-        $self->adjust_karma( 1 )  if $al eq 'ham';
+        $self->adjust_karma(1)  if $al eq 'ham';
-        $self->adjust_karma( -1 ) if $al eq 'spam';
+        $self->adjust_karma(-1) if $al eq 'spam';
-        $learn = "learn=". $al;
+        $learn = "learn=" . $al;
-    };
+    }
 
     my $reject = $self->{_args}{reject} or do {
         $self->log(LOGERROR, "error, reject disabled ($status, $learn)");
         return DECLINED;
     };
 
-    if ( $score < $reject ) {
+    if ($score < $reject) {
-        if ( $ham_or_spam eq 'Spam' ) {
+        if ($ham_or_spam eq 'Spam') {
             $self->log(LOGINFO, "fail, $status < $reject, $learn");
             return DECLINED;
         }
@@ -440,20 +451,20 @@ sub munge_subject {
     };
     return unless $sa->{score} > $required;
 
-    my $subject_prefix = $self->qp->config('subject_prefix') || '*** SPAM ***';
+    my $subject_prefix = $self->qp->config('subject_prefix')  || '*** SPAM ***';
-    my $subject = $transaction->header->get('Subject') || '';
+    my $subject        = $transaction->header->get('Subject') || '';
     $transaction->header->replace('Subject', "$subject_prefix $subject");
 }
 
 sub get_spam_results {
     my ($self, $transaction) = @_;
 
-    if ( defined $transaction->notes('spamassassin') ) {
+    if (defined $transaction->notes('spamassassin')) {
         return $transaction->notes('spamassassin');
-    };
+    }
 
     my $header = $transaction->header->get('X-Spam-Status') or return;
-    my $r = $self->parse_spam_header( $header );
+    my $r = $self->parse_spam_header($header);
 
     $self->log(LOGDEBUG, "$r->{is_spam}, $r->{score}");
     $transaction->notes('spamassassin', $r);
@@ -464,44 +475,48 @@ sub get_spam_results {
 sub parse_spam_header {
     my ($self, $string) = @_;
 
-# the X-Spam-Score header contents vary based on the settings in
+    # the X-Spam-Score header contents vary based on the settings in
-# the spamassassin *.cf files. Rather than parse via regexp, split
+    # the spamassassin *.cf files. Rather than parse via regexp, split
-# on the consistent whitespace and = delimiters. More reliable and
+    # on the consistent whitespace and = delimiters. More reliable and
-# likely faster.
+    # likely faster.
     my @parts = split(/\s+/, $string);
     my $is_spam = shift @parts;
     chomp @parts;
-    chop $is_spam;  # remove trailing ,
+    chop $is_spam;    # remove trailing ,
 
     my %r;
-    foreach ( @parts ) {
+    foreach (@parts) {
-        my ($key,$val) = split(/=/, $_);
+        my ($key, $val) = split(/=/, $_);
         $r{$key} = $val;
     }
     $r{is_spam} = $is_spam;
 
     # compatibility for SA versions < 3
-    if ( defined $r{hits} && ! defined $r{score} ) {
+    if (defined $r{hits} && !defined $r{score}) {
         $r{score} = delete $r{hits};
-    };
+    }
     return \%r;
-};
+}
 
 sub _cleanup_spam_header {
     my ($self, $transaction, $header_name) = @_;
 
     my $action = 'rename';
-    if ( $self->{_args}->{leave_old_headers} ) {
+    if ($self->{_args}->{leave_old_headers}) {
         $action = lc($self->{_args}->{leave_old_headers});
-    };
+    }
 
     return unless $action eq 'drop' || $action eq 'rename';
 
     my $old_header_name = $header_name;
-    $old_header_name = ($old_header_name =~ s/^X-//) ? "X-Old-$old_header_name" : "Old-$old_header_name";
+    $old_header_name =
+      ($old_header_name =~ s/^X-//)
+      ? "X-Old-$old_header_name"
+      : "Old-$old_header_name";
 
-    for my $header ( $transaction->header->get($header_name) ) {
+    for my $header ($transaction->header->get($header_name)) {
-        $transaction->header->add($old_header_name, $header, 0) if $action eq 'rename';
+        $transaction->header->add($old_header_name, $header, 0)
+          if $action eq 'rename';
         $transaction->header->delete($header_name);
     }
 }

plugins/tls

@@ -67,8 +67,9 @@ sub init {
     $cert ||= "$dir/qpsmtpd-server.crt";
     $key  ||= "$dir/qpsmtpd-server.key";
     $ca   ||= "$dir/qpsmtpd-ca.crt";
-    unless ( -f $cert && -f $key && -f $ca ) {
+    unless (-f $cert && -f $key && -f $ca) {
-        $self->log(LOGERROR, "Cannot locate cert/key!  Run plugins/tls_cert to generate");
+        $self->log(LOGERROR,
+                   "Cannot locate cert/key!  Run plugins/tls_cert to generate");
         return;
     }
     $self->tls_cert($cert);
@@ -76,31 +77,34 @@ sub init {
     $self->tls_ca($ca);
     $self->tls_ciphers($self->qp->config('tls_ciphers') || 'HIGH');
 
-    $self->log(LOGDEBUG, "ciphers: ".$self->tls_ciphers);
+    $self->log(LOGDEBUG, "ciphers: " . $self->tls_ciphers);
+
+    local $^W;    # this bit is very noisy...
+    my $ssl_ctx =
+      IO::Socket::SSL::SSL_Context->new(
+                                        SSL_use_cert    => 1,
+                                        SSL_cert_file   => $self->tls_cert,
+                                        SSL_key_file    => $self->tls_key,
+                                        SSL_ca_file     => $self->tls_ca,
+                                        SSL_cipher_list => $self->tls_ciphers,
+                                        SSL_server      => 1
+                                       )
+      or die "Could not create SSL context: $!";
 
-    local $^W; # this bit is very noisy...
-    my $ssl_ctx = IO::Socket::SSL::SSL_Context->new(
-        SSL_use_cert => 1,
-        SSL_cert_file => $self->tls_cert,
-        SSL_key_file => $self->tls_key,
-        SSL_ca_file => $self->tls_ca,
-        SSL_cipher_list => $self->tls_ciphers,
-        SSL_server => 1
-    ) or die "Could not create SSL context: $!";
     # now extract the password...
 
     $self->ssl_context($ssl_ctx);
 
     # Check for possible AUTH mechanisms
-HOOK: foreach my $hook ( keys %{$qp->hooks} ) {
+  HOOK: foreach my $hook (keys %{$qp->hooks}) {
         no strict 'refs';
-        if ( $hook =~ m/^auth-?(.+)?$/ ) {
+        if ($hook =~ m/^auth-?(.+)?$/) {
-            if ( defined $1 ) {
+            if (defined $1) {
                 my $hooksub = "hook_$hook";
                 $hooksub =~ s/\W/_/g;
                 *$hooksub = \&bad_ssl_hook;
             }
-            else { # at least one polymorphous auth provider
+            else {    # at least one polymorphous auth provider
                 *hook_auth = \&bad_ssl_hook;
             }
         }
@@ -111,10 +115,11 @@ sub hook_ehlo {
     my ($self, $transaction) = @_;
     return DECLINED unless $self->can_do_tls;
     return DECLINED if $self->connection->notes('tls_enabled');
-    return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
+    return DENY, "Command refused due to lack of security"
+      if $transaction->notes('ssl_failed');
     my $cap = $transaction->notes('capabilities') || [];
     push @$cap, 'STARTTLS';
-    $transaction->notes('tls_enabled', 1);
+    $transaction->notes('tls_enabled',  1);
     $transaction->notes('capabilities', $cap);
     return DECLINED;
 }
@@ -126,9 +131,10 @@ sub hook_unrecognized_command {
     return DENY, "Syntax error (no parameters allowed)" if @args;
 
     # OK, now we setup TLS
-    $self->qp->respond (220, "Go ahead with TLS");
+    $self->qp->respond(220, "Go ahead with TLS");
+
+    unless (_convert_to_ssl($self)) {
 
-    unless ( _convert_to_ssl($self) ) {
         # SSL setup failed. Now we must respond to every command with 5XX
         warn("TLS failed: $@\n");
         $transaction->notes('ssl_failed', 1);
@@ -143,9 +149,9 @@ sub hook_connect {
     my ($self, $transaction) = @_;
 
     my $local_port = $self->qp->connection->local_port;
-    return DECLINED unless defined $local_port && $local_port == 465; # SMTPS
+    return DECLINED unless defined $local_port && $local_port == 465;    # SMTPS
 
-    unless ( _convert_to_ssl($self) ) {
+    unless (_convert_to_ssl($self)) {
         return (DENY_DISCONNECT, "Cannot establish SSL session");
     }
     $self->log(LOGWARN, "Connected via SMTPS");
@@ -156,9 +162,10 @@ sub hook_post_connection {
     my ($self, $transaction) = @_;
 
     my $tls_socket = $self->connection->notes('tls_socket');
-    if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped')) {
+    if (defined $tls_socket && $self->connection->notes('tls_socket_is_duped'))
+    {
         $tls_socket->close;
-        $self->connection->notes('tls_socket', undef);
+        $self->connection->notes('tls_socket',          undef);
         $self->connection->notes('tls_socked_is_duped', 0);
     }
 
@@ -173,34 +180,36 @@ sub _convert_to_ssl {
     }
 
     eval {
-        my $tlssocket = IO::Socket::SSL->new_from_fd(
+        my $tlssocket =
-            fileno(STDIN), '+>',
+          IO::Socket::SSL->new_from_fd(
-            SSL_use_cert => 1,
+                                       fileno(STDIN), '+>',
-            SSL_cert_file => $self->tls_cert,
+                                       SSL_use_cert    => 1,
-            SSL_key_file => $self->tls_key,
+                                       SSL_cert_file   => $self->tls_cert,
-            SSL_ca_file => $self->tls_ca,
+                                       SSL_key_file    => $self->tls_key,
-            SSL_cipher_list => $self->tls_ciphers,
+                                       SSL_ca_file     => $self->tls_ca,
-            SSL_server => 1,
+                                       SSL_cipher_list => $self->tls_ciphers,
-            SSL_reuse_ctx => $self->ssl_context,
+                                       SSL_server      => 1,
-        ) or die "Could not create SSL socket: $!";
+                                       SSL_reuse_ctx   => $self->ssl_context,
+                                      )
+          or die "Could not create SSL socket: $!";
 
         # Clone connection object (without data received from client)
         $self->qp->connection($self->connection->clone());
         $self->qp->reset_transaction;
         *STDIN = *STDOUT = $self->connection->notes('tls_socket', $tlssocket);
         $self->connection->notes('tls_socket_is_duped', 1);
-        $self->connection->notes('tls_enabled', 1);
+        $self->connection->notes('tls_enabled',         1);
     };
     if ($@) {
         return 0;
-    };
+    }
     return 1;
 }
 
 sub _convert_to_ssl_async {
     my ($self) = @_;
-    my $upgrader = $self->connection
+    my $upgrader =
-                        ->notes( 'tls_upgrader', UpgradeClientSSL->new($self) );
+      $self->connection->notes('tls_upgrader', UpgradeClientSSL->new($self));
     $upgrader->upgrade_socket();
     return 1;
 }
@@ -243,7 +252,8 @@ sub ssl_context {
 # Fulfill RFC 2487 secn 5.1
 sub bad_ssl_hook {
     my ($self, $transaction) = @_;
-    return DENY, "Command refused due to lack of security" if $transaction->notes('ssl_failed');
+    return DENY, "Command refused due to lack of security"
+      if $transaction->notes('ssl_failed');
     return DECLINED;
 }
 *hook_helo = *hook_data = *hook_rcpt = *hook_mail = \&bad_ssl_hook;
@@ -254,7 +264,7 @@ package UpgradeClientSSL;
 
 use strict;
 use warnings;
-no  warnings qw(deprecated);
+no warnings qw(deprecated);
 
 use IO::Socket::SSL 0.98;
 use Errno qw( EAGAIN );
@@ -265,27 +275,29 @@ sub new {
     my UpgradeClientSSL $self = shift;
     $self = fields::new($self) unless ref $self;
     $self->{_stashed_plugin} = shift;
-    $self->{_stashed_qp} = $self->{_stashed_plugin}->qp;
+    $self->{_stashed_qp}     = $self->{_stashed_plugin}->qp;
     return $self;
 }
 
 sub upgrade_socket {
     my UpgradeClientSSL $self = shift;
 
-    unless ( $self->{_ssl_started} ) {
+    unless ($self->{_ssl_started}) {
         $self->{_stashed_qp}->clear_data();
         IO::Socket::SSL->start_SSL(
-            $self->{_stashed_qp}->{sock}, {
+                      $self->{_stashed_qp}->{sock},
-                SSL_use_cert => 1,
+                      {
-                SSL_cert_file => $self->{_stashed_plugin}->tls_cert,
+                       SSL_use_cert    => 1,
-                SSL_key_file => $self->{_stashed_plugin}->tls_key,
+                       SSL_cert_file   => $self->{_stashed_plugin}->tls_cert,
-                SSL_ca_file => $self->{_stashed_plugin}->tls_ca,
+                       SSL_key_file    => $self->{_stashed_plugin}->tls_key,
-                SSL_cipher_list => $self->{_stashed_plugin}->tls_ciphers,
+                       SSL_ca_file     => $self->{_stashed_plugin}->tls_ca,
-                SSL_startHandshake => 0,
+                       SSL_cipher_list => $self->{_stashed_plugin}->tls_ciphers,
-                SSL_server => 1,
+                       SSL_startHandshake => 0,
-                SSL_reuse_ctx => $self->{_stashed_plugin}->ssl_context,
+                       SSL_server         => 1,
-            }
+                       SSL_reuse_ctx => $self->{_stashed_plugin}->ssl_context,
-        ) or die "Could not upgrade socket to SSL: $!";
+                      }
+          )
+          or die "Could not upgrade socket to SSL: $!";
         $self->{_ssl_started} = 1;
     }
 
@@ -296,14 +308,14 @@ sub event_read {
     my UpgradeClientSSL $self = shift;
     my $qp = shift;
 
-    $qp->watch_read( 0 );
+    $qp->watch_read(0);
 
     my $sock = $qp->{sock}->accept_SSL;
 
     if (defined $sock) {
-        $qp->connection( $qp->connection->clone );
+        $qp->connection($qp->connection->clone);
         $qp->reset_transaction;
-        $self->connection->notes('tls_socket', $sock);
+        $self->connection->notes('tls_socket',  $sock);
         $self->connection->notes('tls_enabled', 1);
         $qp->watch_read(1);
         return 1;
@@ -314,12 +326,15 @@ sub event_read {
         $qp->set_reader_object($self);
         if ($SSL_ERROR == SSL_WANT_READ) {
             $qp->watch_read(1);
-        } elsif ($SSL_ERROR == SSL_WANT_WRITE) {
+        }
+        elsif ($SSL_ERROR == SSL_WANT_WRITE) {
             $qp->watch_write(1);
-        } else {
+        }
+        else {
             $qp->disconnect();
         }
-    } else {
+    }
+    else {
         $qp->disconnect();
     }
 }

plugins/uribl

@@ -101,46 +101,47 @@ use IO::Select;
 # ccTLDs that allocate domain names within a strict two-level hierarchy,
 # as in *.co.uk
 my %strict_twolevel_cctlds = (
-    'ac' => 1,
+                              'ac' => 1,
-    'ae' => 1,
+                              'ae' => 1,
-    'uk' => 1,
+                              'uk' => 1,
-    'ai' => 1,
+                              'ai' => 1,
-    'ar' => 1,
+                              'ar' => 1,
-    'at' => 1,
+                              'at' => 1,
-    'au' => 1,
+                              'au' => 1,
-    'az' => 1,
+                              'az' => 1,
-    'bb' => 1,
+                              'bb' => 1,
-    'bh' => 1,
+                              'bh' => 1,
-    'bm' => 1,
+                              'bm' => 1,
-    'br' => 1,
+                              'br' => 1,
-    'bs' => 1,
+                              'bs' => 1,
-    'ca' => 1,
+                              'ca' => 1,
-    'ck' => 1,
+                              'ck' => 1,
-    'cn' => 1,
+                              'cn' => 1,
-    'co' => 1,
+                              'co' => 1,
-    'cr' => 1,
+                              'cr' => 1,
-    'cu' => 1,
+                              'cu' => 1,
-    'cy' => 1,
+                              'cy' => 1,
-    'do' => 1,
+                              'do' => 1,
-    'et' => 1,
+                              'et' => 1,
-    'ge' => 1,
+                              'ge' => 1,
-    'hk' => 1,
+                              'hk' => 1,
-    'id' => 1,
+                              'id' => 1,
-    'il' => 1,
+                              'il' => 1,
-    'jp' => 1,
+                              'jp' => 1,
-    'kr' => 1,
+                              'kr' => 1,
-    'kw' => 1,
+                              'kw' => 1,
-    'lv' => 1,
+                              'lv' => 1,
-    'sg' => 1,
+                              'sg' => 1,
-    'za' => 1,
+                              'za' => 1,
-);
+                             );
 
 # async version: OK
 sub init {
     my ($self, $qp, %args) = @_;
 
-    $self->{action} = $args{action} || 'add-header';
+    $self->{action}  = $args{action}  || 'add-header';
     $self->{timeout} = $args{timeout} || 30;
+
     # scan-headers was the originally documented name for this option, while
     # check-headers actually implements it, so tolerate both.
     $self->{check_headers} = $args{'check-headers'} || $args{'scan-headers'};
@@ -152,7 +153,7 @@ sub init {
     for (@zones) {
         chomp;
         next if !$_ or /^\s*#/;
-        my @z = split (/\s+/, $_);
+        my @z = split(/\s+/, $_);
         next unless $z[0];
 
         my $mask = 0;
@@ -171,16 +172,14 @@ sub init {
         }
 
         $self->{uribl_zones}->{$z[0]} = {
-            mask => $mask,
+                                         mask   => $mask,
-            action => $action,
+                                         action => $action,
-        };
+                                        };
     }
     keys %{$self->{uribl_zones}} or return 0;
 
     my @whitelist = $self->qp->config('uribl_whitelist_domains');
-    $self->{whitelist_zones} = {
+    $self->{whitelist_zones} = {(map { ($_ => 1) } @whitelist)};
-        ( map { ($_ => 1) } @whitelist )
-    };
 
     $self->init_resolver;
 }
@@ -194,17 +193,17 @@ sub register {
 
 # async version: not used
 sub send_query {
-    my $self = shift;
+    my $self  = shift;
-    my $name = shift || return undef;
+    my $name  = shift || return undef;
     my $count = 0;
 
     $self->{socket_select} ||= new IO::Select or return undef;
     for my $z (keys %{$self->{uribl_zones}}) {
         my ($s, $s1);
         my $index = {
-            zone => $z,
+                     zone => $z,
-            name => $name,
+                     name => $name,
-        };
+                    };
 
         next unless $z;
         next if exists $self->{sockets}->{$z}->{$name};
@@ -214,10 +213,12 @@ sub send_query {
             $self->{socket_select}->add($s);
             $self->{socket_idx}->{"$s"} = $index;
             $count++;
-        } else {
+        }
+        else {
             $self->log(LOGERROR,
-                       "Couldn't open socket for A record '$name.$z': ".
+                       "Couldn't open socket for A record '$name.$z': "
-                       ($self->{resolver}->errorstring || 'unknown error'));
+                         . ($self->{resolver}->errorstring || 'unknown error')
+                      );
         }
 
         $s1 = $self->{resolver}->bgsend("$name.$z", 'TXT');
@@ -226,10 +227,12 @@ sub send_query {
             $self->{socket_select}->add($s1);
             $self->{socket_idx}->{"$s1"} = $index;
             $count++;
-        } else {
+        }
+        else {
             $self->log(LOGERROR,
-                       "Couldn't open socket for TXT record '$name.$z': ".
+                       "Couldn't open socket for TXT record '$name.$z': "
-                       ($self->{resolver}->errorstring || 'unknown error'));
+                         . ($self->{resolver}->errorstring || 'unknown error')
+                      );
         }
 
         $self->{sockets}->{$z}->{$name} = {};
@@ -241,7 +244,7 @@ sub send_query {
 sub lookup_finish {
     my $self = shift;
     $self->{socket_idx} = {};
-    $self->{sockets} = {};
+    $self->{sockets}    = {};
     undef $self->{socket_select};
 }
 
@@ -249,14 +252,13 @@ sub lookup_finish {
 sub evaluate {
     my $self = shift;
     my $zone = shift || return undef;
-    my $a = shift || return undef;
+    my $a    = shift || return undef;
 
     my $mask = $self->{uribl_zones}->{$zone}->{mask} || $self->{mask};
     $a =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ or return undef;
-    my $v = (($1 & 0xff) << 24) |
+    my $v =
-        (($2 & 0xff) << 16) |
+      (($1 & 0xff) << 24) | (($2 & 0xff) << 16) | (($3 & 0xff) << 8) |
-        (($3 & 0xff) << 8) |
+      ($4 & 0xff);
-        ($4 & 0xff);
     return ($v & $mask);
 }
 
@@ -270,8 +272,9 @@ sub lookup_start {
     my @qp_continuations;
 
     $transaction->body_resetpos;
-	# if we're not looking for URIs in the headers, read past that point
+
-	# before starting to actually look for any
+    # if we're not looking for URIs in the headers, read past that point
+    # before starting to actually look for any
     while (!$self->{check_headers} and $l = $transaction->body_getline) {
         chomp $l;
         last if !$l;
@@ -281,51 +284,62 @@ sub lookup_start {
 
         if ($l =~ /(.*)=$/) {
             push @qp_continuations, $1;
-        } elsif (@qp_continuations) {
+        }
+        elsif (@qp_continuations) {
             $l = join('', @qp_continuations, $l);
             @qp_continuations = ();
         }
 
         # Undo URI escape munging
         $l =~ s/[=%]([0-9A-Fa-f]{2,2})/chr(hex($1))/ge;
+
         # Undo HTML entity munging (e.g. in parameterized redirects)
         $l =~ s/&#(\d{2,3});?/chr($1)/ge;
+
         # Dodge inserted-semicolon munging
         $l =~ tr/;//d;
 
-        while ($l =~ m{
+        while (
+            $l =~ m{
             \w{3,16}:/+            # protocol
             (?:\S+@)?            # user/pass
             (\d{7,})            # raw-numeric IP
             (?::\d*)?([/?\s]|$)        # port, slash
                             #  or EOL
-            }gx) {
+            }gx
+              )
+        {
             my @octets = (
-                (($1 >> 24) & 0xff),
+                          (($1 >> 24) & 0xff),
-                (($1 >> 16) & 0xff),
+                          (($1 >> 16) & 0xff),
-                (($1 >> 8) & 0xff),
+                          (($1 >> 8) & 0xff),
-                ($1 & 0xff)
+                          ($1 & 0xff)
-                );
+                         );
             my $fwd = join('.', @octets);
             my $rev = join('.', reverse @octets);
-            $self->log(LOGDEBUG, "uribl: matched pure-integer ipaddr $1 ($fwd)");
+            $self->log(LOGDEBUG,
+                       "uribl: matched pure-integer ipaddr $1 ($fwd)");
             unless (exists $pending{$rev}) {
                 $queries += $start_query->($self, $rev);
                 $pending{$rev} = 1;
             }
         }
-        while ($l =~ m{
+        while (
+            $l =~ m{
             \w{3,16}:/+                  # protocol
             (?:\S+@)?                    # user/pass
             (\d+|0[xX][0-9A-Fa-f]+)\.    # IP address
             (\d+|0[xX][0-9A-Fa-f]+)\.
             (\d+|0[xX][0-9A-Fa-f]+)\.
             (\d+|0[xX][0-9A-Fa-f]+)
-            }gx) {
+            }gx
-            my @octets = ($1,$2,$3,$4);
+              )
+        {
+            my @octets = ($1, $2, $3, $4);
+
             # return any octal/hex octets in the IP addr back
             # to decimal form (e.g. http://0x7f.0.0.00001)
-            for (0..$#octets) {
+            for (0 .. $#octets) {
                 $octets[$_] =~ s/^0([0-7]+)$/oct($1)/e;
                 $octets[$_] =~ s/^0x([0-9a-fA-F]+)$/hex($1)/e;
             }
@@ -337,7 +351,8 @@ sub lookup_start {
                 $pending{$rev} = 1;
             }
         }
-        while ($l =~ m{
+        while (
+            $l =~ m{
             ((?:www\.)?                             # www?
              [a-zA-Z0-9][a-zA-Z0-9\-.]+\.           # hostname
              (?:aero|arpa|asia|biz|cat|com|coop|    # tld
@@ -345,22 +360,33 @@ sub lookup_start {
                 museum|name|net|org|pro|tel|travel|
                 [a-zA-Z]{2})
             )(?!\w)        
-            }gix) {
+            }gix
+              )
+        {
             my $host = lc $1;
             my @host_domains = split /\./, $host;
             $self->log(LOGDEBUG, "uribl: matched 'www.' hostname $host");
 
-            my $cutoff = exists
+            my $cutoff =
-                $strict_twolevel_cctlds{$host_domains[$#host_domains]} ? 3 : 2;
+              exists $strict_twolevel_cctlds{$host_domains[$#host_domains]}
-            if (exists $self->{whitelist_zones}->{
+              ? 3
-		join('.', 
+              : 2;
-		     @host_domains[($#host_domains-$cutoff+1)..$#host_domains])}) {
+            if (
+                exists $self->{whitelist_zones}->{
+                    join('.',
+                         @host_domains[($#host_domains - $cutoff + 1)
+                           .. $#host_domains])
+                }
+               )
+            {
                 $self->log(LOGINFO, "Skipping whitelist URI domain '$host'");
-            } else {
+            }
+            else {
                 while (@host_domains >= $cutoff) {
                     my $subhost = join('.', @host_domains);
                     unless (exists $pending{$subhost}) {
-                        $self->log(LOGINFO, "URIBL: checking sub-host $subhost");
+                        $self->log(LOGINFO,
+                                   "URIBL: checking sub-host $subhost");
                         $queries += $start_query->($self, $subhost);
                         $pending{$subhost} = 1;
                     }
@@ -368,7 +394,8 @@ sub lookup_start {
                 }
             }
         }
-        while ($l =~ m{
+        while (
+            $l =~ m{
             \w{3,16}:/+                 # protocol
             (?:\S+@)?                   # user/pass
             (
@@ -378,22 +405,30 @@ sub lookup_start {
                 museum|name|net|org|pro|tel|travel|
                 [a-zA-Z]{2})
             )
-            }gix) {
+            }gix
+              )
+        {
             my $host = lc $1;
             my @host_domains = split /\./, $host;
             $self->log(LOGDEBUG, "uribl: matched full URI hostname $host");
 
-            my $cutoff = exists
+            my $cutoff =
-                $strict_twolevel_cctlds{$host_domains[$#host_domains]} ? 3 : 2;
+              exists $strict_twolevel_cctlds{$host_domains[$#host_domains]}
-            if (exists $self->{whitelist_zones}->{
+              ? 3
-                    join('.', @host_domains[($cutoff-1)..$#host_domains])}) {
+              : 2;
+            if (
+                exists $self->{whitelist_zones}
+                ->{join('.', @host_domains[($cutoff - 1) .. $#host_domains])})
+            {
 
                 $self->log(LOGINFO, "Skipping whitelist URI domain '$host'");
-            } else {
+            }
+            else {
                 while (@host_domains >= $cutoff) {
                     my $subhost = join('.', @host_domains);
                     unless (exists $pending{$subhost}) {
-                        $self->log(LOGINFO, "URIBL: checking sub-host $subhost");
+                        $self->log(LOGINFO,
+                                   "URIBL: checking sub-host $subhost");
                         $queries += $start_query->($self, $subhost);
                         $pending{$subhost} = 1;
                     }
@@ -411,8 +446,8 @@ sub lookup_start {
 sub collect_results {
     my ($self, $transaction) = @_;
 
-    my $matches = 0;
+    my $matches    = 0;
-    my $complete = 0;
+    my $complete   = 0;
     my $start_time = time;
     while ($self->{socket_select}->handles) {
         my $timeout = ($start_time + $self->{timeout}) - time;
@@ -420,16 +455,18 @@ sub collect_results {
 
         my @ready = $self->{socket_select}->can_read($timeout);
 
-        SOCK: for my $s (@ready) {
+      SOCK: for my $s (@ready) {
             $self->{socket_select}->remove($s);
             my $r = $self->{socket_idx}->{"$s"} or next SOCK;
-            $self->log(LOGDEBUG, "from $r: socket $s: ".
+            $self->log(LOGDEBUG,
-                join(', ', map { "$_=$r->{$_}" } keys %{$r}));
+                       "from $r: socket $s: "
-            my $zone = $r->{zone};
+                         . join(', ', map { "$_=$r->{$_}" } keys %{$r})
-            my $name = $r->{name};
+                      );
-            my $h = $self->{sockets}->{$zone}->{$name};
+            my $zone   = $r->{zone};
+            my $name   = $r->{name};
+            my $h      = $self->{sockets}->{$zone}->{$name};
             my $packet = $self->{resolver}->bgread($s)
-                or next SOCK;
+              or next SOCK;
 
             for my $a ($packet->answer) {
                 if ($a->type eq 'TXT') {
@@ -438,8 +475,7 @@ sub collect_results {
                 elsif ($a->type eq 'A') {
                     $h->{a} = $a->address;
                     if ($self->evaluate($zone, $h->{a})) {
-                        $self->log(LOGDEBUG,
+                        $self->log(LOGDEBUG, "match in $zone");
-                            "match in $zone");
                         $h->{match} = 1;
                         $matches++;
                     }
@@ -451,21 +487,23 @@ sub collect_results {
     }
     my $elapsed = time - $start_time;
     $self->log(LOGINFO,
-        sprintf("$complete lookup%s finished in %.2f sec (%d match%s)",
+               sprintf(
-            $complete == 1 ? '' : 's', $elapsed,
+                       "$complete lookup%s finished in %.2f sec (%d match%s)",
-            $matches, $matches == 1 ? '' : 'es'));
+                       $complete == 1 ? '' : 's', $elapsed,
+                       $matches, $matches == 1 ? '' : 'es'
+                      )
+              );
 
     my @matches = ();
     for my $z (keys %{$self->{sockets}}) {
         for my $n (keys %{$self->{sockets}->{$z}}) {
             my $h = $self->{sockets}->{$z}->{$n};
             next unless $h->{match};
-            push @matches, {
+            push @matches,
-                action =>
+              {
-                    $self->{uribl_zones}->{$z}->{action},
+                action => $self->{uribl_zones}->{$z}->{action},
-                desc => "$n in $z: ".
+                desc   => "$n in $z: " . ($h->{txt} || $h->{a}),
-                    ($h->{txt} || $h->{a}),
+              };
-            };
         }
     }
 
@@ -480,10 +518,13 @@ sub data_handler {
 
     return (DECLINED) if $self->is_immune();
 
-    my $queries = $self->lookup_start($transaction, sub {
+    my $queries = $self->lookup_start(
-        my ($self, $name) = @_;
+        $transaction,
-        return $self->send_query($name);
+        sub {
-    });
+            my ($self, $name) = @_;
+            return $self->send_query($name);
+        }
+    );
 
     unless ($queries) {
         $self->log(LOGINFO, "pass, No URIs found in mail");
@@ -495,9 +536,11 @@ sub data_handler {
         $self->log(LOGWARN, $_->{desc});
         if ($_->{action} eq 'add-header') {
             $transaction->header->add('X-URIBL-Match', $_->{desc}, 0);
-        } elsif ($_->{action} eq 'deny') {
+        }
+        elsif ($_->{action} eq 'deny') {
             return (DENY, $_->{desc});
-        } elsif ($_->{action} eq 'denysoft') {
+        }
+        elsif ($_->{action} eq 'denysoft') {
             return (DENYSOFT, $_->{desc});
         }
     }

plugins/virus/aveclient

@@ -1,4 +1,5 @@
 #!perl -w
+
 =head1 NAME
 
 aveclient
@@ -94,87 +95,110 @@ use File::Temp qw(tempfile);
 use Mail::Address;
 
 sub register {
-	my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-	# defaults to be used
+    # defaults to be used
-	$self->{_avclient_bin} 	= "/opt/kav/bin/aveclient";
+    $self->{_avclient_bin}  = "/opt/kav/bin/aveclient";
-	$self->{_avdaemon_sock} = "/var/run/aveserver";
+    $self->{_avdaemon_sock} = "/var/run/aveserver";
-	$self->{_blockonerror} 	= 0;
+    $self->{_blockonerror}  = 0;
 
-	# parse optional arguments
+    # parse optional arguments
-	my %args = @args;
+    my %args = @args;
-	foreach my $key (keys %args) {
+    foreach my $key (keys %args) {
-		my $arg = $key;
+        my $arg = $key;
-		$key =~ s/^/_/;
+        $key =~ s/^/_/;
-		$self->{$key} = $args{$arg};
+        $self->{$key} = $args{$arg};
-	}
+    }
 
-	# Untaint client location
+    # Untaint client location
-	# socket will be tested during scan (response-code)
+    # socket will be tested during scan (response-code)
-	if (exists $self->{_avclient_bin} && $self->{_avclient_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+    if (exists $self->{_avclient_bin}
-		$self->{_avclient_bin} = $1;
+        && $self->{_avclient_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/)
-	} else {
+    {
-		$self->log(LOGALERT, "FATAL ERROR: No binary aveclient found: '".$self->{_avclient_bin}."'");
+        $self->{_avclient_bin} = $1;
-		exit 3;
+    }
-	}
+    else {
+        $self->log(LOGALERT,
+                   "FATAL ERROR: No binary aveclient found: '"
+                     . $self->{_avclient_bin} . "'"
+                  );
+        exit 3;
+    }
 }
 
 sub hook_data_post {
-	my ($self, $transaction) = @_;
+    my ($self,    $transaction) = @_;
-	my ($temp_fh, $filename) = tempfile();
+    my ($temp_fh, $filename)    = tempfile();
-	my $description = 'clean';
+    my $description = 'clean';
 
-	# a temporary file is needed to be scanned
+    # a temporary file is needed to be scanned
-	print $temp_fh $transaction->header->as_string;
+    print $temp_fh $transaction->header->as_string;
-	print $temp_fh "\n";
+    print $temp_fh "\n";
 
-	$transaction->body_resetpos;
+    $transaction->body_resetpos;
 
-	while (my $line = $transaction->body_getline) {
+    while (my $line = $transaction->body_getline) {
-		print $temp_fh $line;
+        print $temp_fh $line;
-	}
+    }
-	seek($temp_fh, 0, 0);
+    seek($temp_fh, 0, 0);
 
-	# Now scan this file
+    # Now scan this file
-	my $cmd = $self->{_avclient_bin}." -p ".$self->{_avdaemon_sock}." -s $filename 2>&1";
+    my $cmd =
+        $self->{_avclient_bin} . " -p "
+      . $self->{_avdaemon_sock}
+      . " -s $filename 2>&1";
 
-	my @output = `$cmd`;
+    my @output = `$cmd`;
-	chomp(@output);
+    chomp(@output);
 
-	my $result = ($? >> 8);
+    my $result = ($? >> 8);
-	my $signal = ($? & 127);
+    my $signal = ($? & 127);
 
-	# tidy up a bit
+    # tidy up a bit
-	unlink($filename);
+    unlink($filename);
-	close $temp_fh;
+    close $temp_fh;
 
-	# check if something went wrong
+    # check if something went wrong
-	if ($signal) {
+    if ($signal) {
-		$self->log(LOGERROR, "kavscanner exited with signal: $signal");
+        $self->log(LOGERROR, "kavscanner exited with signal: $signal");
-		return (DECLINED);
+        return (DECLINED);
-	}
+    }
 
-	# either we found a virus or something went wrong
+    # either we found a virus or something went wrong
-	if ($result > 0) {
+    if ($result > 0) {
-		if ($result =~ /^(2|3|4|6|8)$/) {
+        if ($result =~ /^(2|3|4|6|8)$/) {
 
-			# ok a somewhat virus was found
+            # ok a somewhat virus was found
-			shift @output;
+            shift @output;
-			$description = "REPORT: ".join(", ",@output);
+            $description = "REPORT: " . join(", ", @output);
-			$self->log(LOGWARN, "Virus found! ($description)");
+            $self->log(LOGWARN, "Virus found! ($description)");
 
-			# we don't want to be disturbed be these, so block mail and DENY connection
+     # we don't want to be disturbed be these, so block mail and DENY connection
-			return(DENY, "Virus found: $description");
+            return (DENY, "Virus found: $description");
 
-		} else {
+        }
-			$self->log(LOGCRIT, "aveserver: no viruses have been detected.") if($result =~ /^0$/);
+        else {
-			$self->log(LOGCRIT, "aveserver: system error launching the application (file not found, unable to read the file).") if($result =~ /^0$/);
+            $self->log(LOGCRIT, "aveserver: no viruses have been detected.")
-			$self->log(LOGCRIT, "aveserver: some of the required parameters are missing from the command line.") if($result =~ /^9$/);
+              if ($result =~ /^0$/);
-			return(DENY, "Unable to scan for virus, please contact admin of ".$self->qp->config("me").", if you feel this is an error!") if $self->{_blockonerror};
+            $self->log(LOGCRIT,
-		}
+"aveserver: system error launching the application (file not found, unable to read the file)."
-	}
+              )
+              if ($result =~ /^0$/);
+            $self->log(LOGCRIT,
+"aveserver: some of the required parameters are missing from the command line."
+              )
+              if ($result =~ /^9$/);
+            return (DENY,
+                        "Unable to scan for virus, please contact admin of "
+                      . $self->qp->config("me")
+                      . ", if you feel this is an error!"
+                   )
+              if $self->{_blockonerror};
+        }
+    }
 
-	$self->log(LOGINFO, "kavscanner results: $description");
+    $self->log(LOGINFO, "kavscanner results: $description");
-	$transaction->header->add('X-Virus-Checked', 'Checked by Kaspersky on '.$self->qp->config("me"));
+    $transaction->header->add('X-Virus-Checked',
-	return (DECLINED);
+                          'Checked by Kaspersky on ' . $self->qp->config("me"));
+    return (DECLINED);
 }

plugins/virus/bitdefender

@@ -67,10 +67,10 @@ use File::Path;
 use Qpsmtpd::Constants;
 
 sub register {
-    my ( $self, $qp, @args ) = @_;
+    my ($self, $qp, @args) = @_;
 
     while (@args) {
-        $self->{"_bitd"}->{ pop @args } = pop @args;
+        $self->{"_bitd"}->{pop @args} = pop @args;
     }
     $self->{"_bitd"}->{"bitdefender_location"} ||= "/opt/bdc/bdc";
     $self->{"_bitd"}->{"deny_viruses"}         ||= "yes";
@@ -79,31 +79,31 @@ sub register {
 }
 
 sub hook_data_post {
-    my ( $self, $transaction ) = @_;
+    my ($self, $transaction) = @_;
 
-    if ( $transaction->data_size > $self->{"_bitd"}->{"max_size"} ) {
+    if ($transaction->data_size > $self->{"_bitd"}->{"max_size"}) {
-        $self->log( LOGWARN,
+        $self->log(LOGWARN,
-                'Mail too large to scan ('
+                       'Mail too large to scan ('
-              . $transaction->data_size . " vs "
+                     . $transaction->data_size . " vs "
-              . $self->{"_bitd"}->{"max_size"}
+                     . $self->{"_bitd"}->{"max_size"} . ")"
-              . ")" );
+                  );
         return (DECLINED);
     }
 
     # Ignore non-multipart emails
     my $content_type = $transaction->header->get('Content-Type');
     $content_type =~ s/\s/ /g if defined $content_type;
-    unless ( $content_type
+    unless (   $content_type
-        && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
+            && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i)
     {
-        $self->log( LOGERROR, "non-multipart mail - skipping" );
+        $self->log(LOGERROR, "non-multipart mail - skipping");
         return DECLINED;
     }
 
     my $filename = $transaction->body_filename;
     unless (defined $filename) {
-	$self->log(LOGERROR, "didn't get a filename");
+        $self->log(LOGERROR, "didn't get a filename");
-	return DECLINED;
+        return DECLINED;
     }
 
     # Now do the actual scanning!
@@ -121,9 +121,9 @@ sub hook_data_post {
     close $bdc;
 
     if ($output) {
-        $self->log( LOGINFO, "Virus(es) found: $output" );
+        $self->log(LOGINFO, "Virus(es) found: $output");
-        if ( $self->{"_bitd"}->{"deny_viruses"} eq "yes" ) {
+        if ($self->{"_bitd"}->{"deny_viruses"} eq "yes") {
-            return ( DENY, "Virus Found: $output" );
+            return (DENY, "Virus Found: $output");
         }
     }
 

plugins/virus/clamav

@@ -112,120 +112,126 @@ use warnings;
 use Qpsmtpd::Constants;
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
-  my %args;
+    my %args;
 
-  if ($args[0] && $args[0] =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/ && -x $1) {
+    if ($args[0] && $args[0] =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/ && -x $1) {
-    $self->{_clamscan_loc} = $1;
-    shift @args;
-  }
-
-  for (@args) {
-    if (/^max_size=(\d+)$/) {
-        $self->{_max_size} = $1;
-    }
-    elsif (/^clamscan_path=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
         $self->{_clamscan_loc} = $1;
+        shift @args;
     }
-    elsif (/^clamd_conf=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
-        $self->{_clamd_conf} = "$1";
-    }
-    elsif (/^tmp_dir=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
-        $self->{_spool_dir} = $1;
-    }
-    elsif (/^action=(add-header|reject)$/) {
-        $self->{_action} = $1;
-    }
-    elsif (/back_compat/) {
-	$self->{_back_compat} = '-i --max-recursion=50';
-    }
-    elsif (/declined_on_fail/) {
-       $self->{_declined_on_fail} = 1;
-    }
-    else {
-        $self->log(LOGERROR, "Unrecognized argument '$_' to clamav plugin");
-        return undef;
-    }
-  }
 
-  $self->{_max_size} ||= 512 * 1024;
+    for (@args) {
-  $self->{_spool_dir} ||= $self->spool_dir();
+        if (/^max_size=(\d+)$/) {
-  $self->{_back_compat} ||= ''; # make sure something is set
+            $self->{_max_size} = $1;
-  $self->{_clamd_conf} ||= '/etc/clamd.conf'; # make sure something is set
+        }
-  $self->{_declined_on_fail} ||= 0; # decline the message on clamav failure
+        elsif (/^clamscan_path=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+            $self->{_clamscan_loc} = $1;
+        }
+        elsif (/^clamd_conf=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+            $self->{_clamd_conf} = "$1";
+        }
+        elsif (/^tmp_dir=(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+            $self->{_spool_dir} = $1;
+        }
+        elsif (/^action=(add-header|reject)$/) {
+            $self->{_action} = $1;
+        }
+        elsif (/back_compat/) {
+            $self->{_back_compat} = '-i --max-recursion=50';
+        }
+        elsif (/declined_on_fail/) {
+            $self->{_declined_on_fail} = 1;
+        }
+        else {
+            $self->log(LOGERROR, "Unrecognized argument '$_' to clamav plugin");
+            return undef;
+        }
+    }
 
-  unless ($self->{_spool_dir}) {
+    $self->{_max_size}    ||= 512 * 1024;
+    $self->{_spool_dir}   ||= $self->spool_dir();
+    $self->{_back_compat} ||= '';                   # make sure something is set
+    $self->{_clamd_conf}  ||= '/etc/clamd.conf';    # make sure something is set
+    $self->{_declined_on_fail} ||= 0;    # decline the message on clamav failure
+
+    unless ($self->{_spool_dir}) {
         $self->log(LOGERROR, "No spool dir configuration found");
         return undef;
-  }
+    }
-  unless (-d $self->{_spool_dir}) {
+    unless (-d $self->{_spool_dir}) {
         $self->log(LOGERROR, "Spool dir $self->{_spool_dir} does not exist");
         return undef;
-  }
+    }
 
 }
 
 sub hook_data_post {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  if ($transaction->data_size > $self->{_max_size}) {
+    if ($transaction->data_size > $self->{_max_size}) {
-	$self->log(LOGWARN, 'Mail too large to scan ('.
+        $self->log(LOGWARN,
-		$transaction->data_size . " vs $self->{_max_size})" );
+                       'Mail too large to scan ('
-	return (DECLINED);
+                     . $transaction->data_size
-  }
+                     . " vs $self->{_max_size})"
+                  );
+        return (DECLINED);
+    }
 
-  my $filename = $transaction->body_filename;
+    my $filename = $transaction->body_filename;
-  unless (defined $filename) {
+    unless (defined $filename) {
         $self->log(LOGWARN, "didn't get a filename");
         return DECLINED;
-  }
-  my $mode = (stat($self->{_spool_dir}))[2];
-  if ( $mode & 07077  ) { # must be sharing spool directory with external app
-      $self->log(LOGWARN,
-        "Changing permissions on file to permit scanner access");
-      chmod $mode, $filename;
-  }
- 
-  # Now do the actual scanning!
-  my $cmd = $self->{_clamscan_loc}
-    . " --stdout "
-    . $self->{_back_compat}
-    . " --config-file=" . $self->{_clamd_conf}
-    . " --no-summary $filename 2>&1";
-  $self->log(LOGDEBUG, "Running: $cmd");
-  my $output = `$cmd`;
- 
-  my $result = ($? >> 8);
-  my $signal = ($? & 127);
- 
-  chomp($output);
- 
-  $output =~ s/^.* (.*) FOUND$/$1 /mg;
- 
-  $self->log(LOGINFO, "clamscan results: $output");
- 
-  if ($signal) {
-    $self->log(LOGINFO, "clamscan exited with signal: $signal");
-    return (DENYSOFT) if (!$self->{_declined_on_fail});
-    return (DECLINED);
-  }
-  if ($result == 1) {
-    $self->log(LOGINFO, "Virus(es) found: $output");
-    if ($self->{_action} eq 'add-header') {
-        $transaction->header->add('X-Virus-Found', 'Yes');
-        $transaction->header->add('X-Virus-Details', $output);
-    } else {
-        return (DENY, "Virus Found: $output");
     }
-  }
+    my $mode = (stat($self->{_spool_dir}))[2];
-  elsif ($result) {
+    if ($mode & 07077) {    # must be sharing spool directory with external app
-    $self->log(LOGERROR, "ClamAV error: $cmd: $result\n");
+        $self->log(LOGWARN,
-    return (DENYSOFT) if (!$self->{_declined_on_fail});
+                   "Changing permissions on file to permit scanner access");
-  }
+        chmod $mode, $filename;
-  else {
+    }
-    $transaction->header->add( 'X-Virus-Checked',
+
-        "Checked by ClamAV on " . $self->qp->config("me") );
+    # Now do the actual scanning!
-  }
+    my $cmd =
-  return (DECLINED);
+        $self->{_clamscan_loc}
+      . " --stdout "
+      . $self->{_back_compat}
+      . " --config-file="
+      . $self->{_clamd_conf}
+      . " --no-summary $filename 2>&1";
+    $self->log(LOGDEBUG, "Running: $cmd");
+    my $output = `$cmd`;
+
+    my $result = ($? >> 8);
+    my $signal = ($? & 127);
+
+    chomp($output);
+
+    $output =~ s/^.* (.*) FOUND$/$1 /mg;
+
+    $self->log(LOGINFO, "clamscan results: $output");
+
+    if ($signal) {
+        $self->log(LOGINFO, "clamscan exited with signal: $signal");
+        return (DENYSOFT) if (!$self->{_declined_on_fail});
+        return (DECLINED);
+    }
+    if ($result == 1) {
+        $self->log(LOGINFO, "Virus(es) found: $output");
+        if ($self->{_action} eq 'add-header') {
+            $transaction->header->add('X-Virus-Found',   'Yes');
+            $transaction->header->add('X-Virus-Details', $output);
+        }
+        else {
+            return (DENY, "Virus Found: $output");
+        }
+    }
+    elsif ($result) {
+        $self->log(LOGERROR, "ClamAV error: $cmd: $result\n");
+        return (DENYSOFT) if (!$self->{_declined_on_fail});
+    }
+    else {
+        $transaction->header->add('X-Virus-Checked',
+                             "Checked by ClamAV on " . $self->qp->config("me"));
+    }
+    return (DECLINED);
 }
 

plugins/virus/clamdscan

@@ -109,17 +109,17 @@ use warnings;
 use Qpsmtpd::Constants;
 
 sub register {
-    my ( $self, $qp ) = shift, shift;
+    my ($self, $qp) = shift, shift;
 
     $self->log(LOGERROR, "Bad parameters for the clamdscan plugin") if @_ % 2;
-    $self->{'_args'} = { @_ };
+    $self->{'_args'} = {@_};
 
     eval 'use ClamAV::Client';
-    if ( $@ ) {
+    if ($@) {
         warn "unable to load ClamAV::Client\n";
         $self->log(LOGERROR, "unable to load ClamAV::Client");
         return;
-    };
+    }
 
     # Set some sensible defaults
     $self->{'_args'}{'deny_viruses'} ||= 'yes';
@@ -127,73 +127,75 @@ sub register {
     $self->{'_args'}{'scan_all'}     ||= 0;
     for my $setting ('deny_viruses', 'defer_on_error') {
         next unless $self->{'_args'}{$setting};
-        if ( lc $self->{'_args'}{$setting} eq 'no' ) {
+        if (lc $self->{'_args'}{$setting} eq 'no') {
             $self->{'_args'}{$setting} = 0;
-        };
+        }
     }
 
     $self->register_hook('data_post', 'data_post_handler');
 }
 
 sub data_post_handler {
-    my ( $self, $transaction ) = @_;
+    my ($self, $transaction) = @_;
 
-    my $filename = $self->get_filename( $transaction ) or return DECLINED;
+    my $filename = $self->get_filename($transaction) or return DECLINED;
 
-    if ( $self->connection->notes('naughty') ) {
+    if ($self->connection->notes('naughty')) {
-        $self->log( LOGINFO, "skip, naughty" );
+        $self->log(LOGINFO, "skip, naughty");
         return (DECLINED);
-    };
+    }
-    return (DECLINED) if $self->is_too_big( $transaction );
+    return (DECLINED) if $self->is_too_big($transaction);
-    return (DECLINED) if $self->is_not_multipart( $transaction );
+    return (DECLINED) if $self->is_not_multipart($transaction);
 
-    $self->set_permission( $filename ) or return DECLINED;
+    $self->set_permission($filename) or return DECLINED;
 
     my $clamd = $self->get_clamd()
-        or return $self->err_and_return( "Cannot instantiate ClamAV::Client" );
+      or return $self->err_and_return("Cannot instantiate ClamAV::Client");
 
-    unless ( eval { $clamd->ping() } ) {
+    unless (eval { $clamd->ping() }) {
-        return $self->err_and_return( "Cannot ping clamd server: $@" );
+        return $self->err_and_return("Cannot ping clamd server: $@");
     }
 
     my ($version) = split(/\//, $clamd->version);
     $version ||= 'ClamAV';
 
-    my ( $path, $found ) = eval { $clamd->scan_path( $filename ) };
+    my ($path, $found) = eval { $clamd->scan_path($filename) };
     if ($@) {
-        return $self->err_and_return( "Error scanning mail: $@" );
+        return $self->err_and_return("Error scanning mail: $@");
-    };
+    }
 
-    if ( $found ) {
+    if ($found) {
-        $self->log( LOGNOTICE, "fail, found virus $found" );
+        $self->log(LOGNOTICE, "fail, found virus $found");
 
-        $self->connection->notes('naughty', 1); # see plugins/naughty
+        $self->connection->notes('naughty', 1);    # see plugins/naughty
-        $self->adjust_karma( -1 );
+        $self->adjust_karma(-1);
 
-        if ( $self->{_args}{deny_viruses} ) {
+        if ($self->{_args}{deny_viruses}) {
-            return ( DENY, "Virus found: $found" );
+            return (DENY, "Virus found: $found");
         }
 
-        $transaction->header->add( 'X-Virus-Found',   'Yes', 0 );
+        $transaction->header->add('X-Virus-Found',   'Yes',  0);
-        $transaction->header->add( 'X-Virus-Details', $found, 0 );
+        $transaction->header->add('X-Virus-Details', $found, 0);
         return (DECLINED);
     }
 
-    $self->log( LOGINFO, "pass, clean");
+    $self->log(LOGINFO, "pass, clean");
-    $transaction->header->add( 'X-Virus-Found',   'No', 0 );
+    $transaction->header->add('X-Virus-Found', 'No', 0);
-    $transaction->header->add( 'X-Virus-Checked', "by $version on " . $self->qp->config('me'), 0);
+    $transaction->header->add('X-Virus-Checked',
+                              "by $version on " . $self->qp->config('me'), 0);
     return (DECLINED);
 }
 
 sub err_and_return {
-    my $self = shift;
+    my $self    = shift;
     my $message = shift;
-    if ( $message ) {
+    if ($message) {
-        $self->log( LOGERROR, $message );
+        $self->log(LOGERROR, $message);
-    };
+    }
-    return (DENYSOFT, "Unable to scan for viruses") if $self->{_args}{defer_on_error};
+    return (DENYSOFT, "Unable to scan for viruses")
+      if $self->{_args}{defer_on_error};
     return (DECLINED, "skip");
-};
+}
 
 sub get_filename {
     my $self = shift;
@@ -201,25 +203,25 @@ sub get_filename {
 
     my $filename = $transaction->body_filename;
 
-    if ( ! $filename ) {
+    if (!$filename) {
-        $self->log( LOGWARN, "Cannot process due to lack of filename" );
+        $self->log(LOGWARN, "Cannot process due to lack of filename");
         return;
     }
 
-    if ( ! -f $filename ) {
+    if (!-f $filename) {
-        $self->log( LOGERROR, "spool file missing! Attempting to respool" );
+        $self->log(LOGERROR, "spool file missing! Attempting to respool");
         $transaction->body_spool;
         $filename = $transaction->body_filename;
-        if ( ! -f $filename ) {
+        if (!-f $filename) {
-            $self->log( LOGERROR, "skip: failed spool to $filename! Giving up" );
+            $self->log(LOGERROR, "skip: failed spool to $filename! Giving up");
             return;
-        };
+        }
         my $size = (stat($filename))[7];
-        $self->log( LOGDEBUG, "Spooled $size bytes to $filename" );
+        $self->log(LOGDEBUG, "Spooled $size bytes to $filename");
     }
 
     return $filename;
-};
+}
 
 sub set_permission {
     my ($self, $filename) = @_;
@@ -227,26 +229,28 @@ sub set_permission {
     # the spool directory must be readable and executable by the scanner;
     # this generally means either group or world exec; if
     # neither of these is set, issue a warning but try to proceed anyway
-    my $dir_mode = ( stat( $self->spool_dir() ) )[2];
+    my $dir_mode = (stat($self->spool_dir()))[2];
-    $self->log( LOGDEBUG, "spool dir mode: $dir_mode" );
+    $self->log(LOGDEBUG, "spool dir mode: $dir_mode");
+
+    if ($dir_mode & 0010 || $dir_mode & 0001) {
 
-    if ( $dir_mode & 0010 || $dir_mode & 0001 ) {
         # match the spool file mode with the mode of the directory -- add
         # the read bit for group, world, or both, depending on what the
         # spool dir had, and strip all other bits, especially the sticky bit
-        my $fmode = ($dir_mode & 0044) |
+        my $fmode =
-                    ($dir_mode & 0010 ? 0040 : 0) |
+          ($dir_mode & 0044) | ($dir_mode & 0010 ? 0040 : 0) |
-                    ($dir_mode & 0001 ? 0004 : 0);
+          ($dir_mode & 0001 ? 0004 : 0);
 
-        unless ( chmod $fmode, $filename ) {
+        unless (chmod $fmode, $filename) {
-            $self->log( LOGERROR, "chmod: $filename: $!" );
+            $self->log(LOGERROR, "chmod: $filename: $!");
             return;
         }
         return 1;
     }
-    $self->log( LOGWARN, "spool directory permissions do not permit scanner access" );
+    $self->log(LOGWARN,
+               "spool directory permissions do not permit scanner access");
     return 1;
-};
+}
 
 sub get_clamd {
     my $self = shift;
@@ -254,34 +258,34 @@ sub get_clamd {
     my $port = $self->{'_args'}{'clamd_port'};
     my $host = $self->{'_args'}{'clamd_host'} || 'localhost';
 
-    if ( $port && $port =~ /^(\d+)/ ) {
+    if ($port && $port =~ /^(\d+)/) {
-        return new ClamAV::Client( socket_host => $host, socket_port => $1 );
+        return new ClamAV::Client(socket_host => $host, socket_port => $1);
-    };
+    }
 
     my $socket = $self->{'_args'}{'clamd_socket'};
-    if ( $socket ) {
+    if ($socket) {
-        if ( $socket =~ /([\w\/.]+)/ ) {
+        if ($socket =~ /([\w\/.]+)/) {
-            return new ClamAV::Client( socket_name => $1 );
+            return new ClamAV::Client(socket_name => $1);
         }
-        $self->log( LOGERROR, "invalid characters in socket name" );
+        $self->log(LOGERROR, "invalid characters in socket name");
     }
 
     return new ClamAV::Client;
-};
+}
 
 sub is_too_big {
     my $self = shift;
     my $transaction = shift || $self->qp->transaction;
 
     my $size = $transaction->data_size;
-    if ( $size > $self->{_args}{max_size} * 1024 ) {
+    if ($size > $self->{_args}{max_size} * 1024) {
-        $self->log( LOGINFO, "skip, too big ($size)" );
+        $self->log(LOGINFO, "skip, too big ($size)");
         return 1;
     }
 
-    $self->log( LOGDEBUG, "data_size, $size" );
+    $self->log(LOGDEBUG, "data_size, $size");
     return;
-};
+}
 
 sub is_not_multipart {
     my $self = shift;
@@ -289,15 +293,15 @@ sub is_not_multipart {
 
     return if $self->{'_args'}{'scan_all'};
 
-    return 1 if ! $transaction->header;
+    return 1 if !$transaction->header;
 
     # Ignore non-multipart emails
     my $content_type = $transaction->header->get('Content-Type') or return 1;
     $content_type =~ s/\s/ /g;
-    if ( $content_type !~ m!\bmultipart/.*\bboundary="?([^"]+)!i ) {
+    if ($content_type !~ m!\bmultipart/.*\bboundary="?([^"]+)!i) {
-        $self->log( LOGNOTICE, "skip, not multipart" );
+        $self->log(LOGNOTICE, "skip, not multipart");
         return 1;
     }
 
     return;
-};
+}

plugins/virus/hbedv

@@ -51,108 +51,118 @@ The B<hbedv> plugin is published under the same licence as qpsmtpd itself.
 =cut 
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  if (@args % 2) {
+    if (@args % 2) {
-     $self->log(LOGERROR, "FATAL ERROR: odd number of arguments");
+        $self->log(LOGERROR, "FATAL ERROR: odd number of arguments");
-     exit 3;
+        exit 3;
-  } 
+    }
-  my %args = @args;
+    my %args = @args;
-  if (!exists $args{hbedvscanner}) {
+    if (!exists $args{hbedvscanner}) {
-    $self->{_hbedvscan_loc} = "/usr/bin/antivir";
+        $self->{_hbedvscan_loc} = "/usr/bin/antivir";
-  } else {
+    }
-    if ($args{hbedvscanner} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+    else {
-      $self->{_hbedvscan_loc} = $1;
+        if ($args{hbedvscanner} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
-    } else {
+            $self->{_hbedvscan_loc} = $1;
-      $self->log(LOGERROR, "FATAL ERROR: Unexpected characters in hbedvscanner argument");
+        }
-      exit 3;
+        else {
+            $self->log(LOGERROR,
+                 "FATAL ERROR: Unexpected characters in hbedvscanner argument");
+            exit 3;
+        }
     }
-  }
 }
 
 sub hook_data_post {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  my $filename = $transaction->body_filename;
+    my $filename = $transaction->body_filename;
-  unless (defined $filename) {
+    unless (defined $filename) {
-    $self->log(LOGWARN, "didn't get a file name"); 
+        $self->log(LOGWARN, "didn't get a file name");
-    return (DECLINED);
+        return (DECLINED);
-  }
- 
-  # Now do the actual scanning!
-  my $cmd = $self->{_hbedvscan_loc}." --archive-max-recursion=50 --alltypes -z -noboot -nombr -rs $filename 2>&1";
-  $self->log(LOGDEBUG, "Running: $cmd");
-  my @output = `$cmd`;
- 
-  my $result = ($? >> 8);
-  my $signal = ($? & 127);
- 
-  chomp(@output);
-  my @virii = ();
-  foreach my $line (@output) {
-    next unless $line =~ /^ALERT: \[([^\]]+)\s+(\w+)?\]/; # $2 =~ /^(virus|worm)$/;
-    push @virii, $1;
-  }
-  @virii = unique(@virii);
-
-  $self->log(LOGDEBUG, "results: ".join("//",@output));
- 
-  if ($signal) {
-    $self->log(LOGWARN, "scanner exited with signal: $signal");
-    return (DECLINED);
-  }
-  my $output = join(", ", @virii);
-  $output = substr($output, 0, 60);
-  if ($result == 1 || $result == 3) {
-    $self->log(LOGWARN, "Virus(es) found: $output");
-    # return (DENY, "Virus Found: $output");
-    # $transaction->header->add('X-Virus-Found', 'Yes', 0);
-    # $transaction->header->add('X-Virus-Details', $output, 0);
-    $transaction->header->add('X-H+BEDV-Virus-Found', 'Yes', 0);
-    $transaction->header->add('X-H+BEDV-Virus-Details', $output, 0);
-  }
-  elsif ($result == 200) {
-    $self->log(LOGWARN, "Program aborted, not enough memory available");
-  } 
-  elsif ($result == 211) {
-    $self->log(LOGWARN, "Programm aborted, because the self check failed");
-  }
-  elsif ($result == 214) {
-    $self->log(LOGWARN, "License key not found");
-  }
-  elsif ($result) {
-    $self->log(LOGWARN, "Error: $result, look for exit codes in the output of '"
-                        .$self->{_hbedvscan_loc}." --help' for more info\n");
-  } 
-
-  # $transaction->header->add('X-Virus-Checked', 'Checked', 0);
-  $transaction->header->add('X-H+BEDV-Virus-Checked', 'Checked', 0);
-  return (DECLINED) unless $result;
-
-  if (@virii) {
-    return(DENY, "Virus found: $output")
-      unless $self->qp->config("hbedv_deny");
-    foreach my $d ($self->qp->config("hbedv_deny")) {
-      foreach my $v (@virii) {
-        if ($v =~ /^$d$/i) {
-          $self->log(LOGWARN, "Denying mail with virus '$v'");
-          return(DENY, "Virus found: $output");
-        }
-      }
     }
-  }
+
-  return (DECLINED);
+    # Now do the actual scanning!
+    my $cmd = $self->{_hbedvscan_loc}
+      . " --archive-max-recursion=50 --alltypes -z -noboot -nombr -rs $filename 2>&1";
+    $self->log(LOGDEBUG, "Running: $cmd");
+    my @output = `$cmd`;
+
+    my $result = ($? >> 8);
+    my $signal = ($? & 127);
+
+    chomp(@output);
+    my @virii = ();
+    foreach my $line (@output) {
+        next
+          unless $line =~
+          /^ALERT: \[([^\]]+)\s+(\w+)?\]/;    # $2 =~ /^(virus|worm)$/;
+        push @virii, $1;
+    }
+    @virii = unique(@virii);
+
+    $self->log(LOGDEBUG, "results: " . join("//", @output));
+
+    if ($signal) {
+        $self->log(LOGWARN, "scanner exited with signal: $signal");
+        return (DECLINED);
+    }
+    my $output = join(", ", @virii);
+    $output = substr($output, 0, 60);
+    if ($result == 1 || $result == 3) {
+        $self->log(LOGWARN, "Virus(es) found: $output");
+
+        # return (DENY, "Virus Found: $output");
+        # $transaction->header->add('X-Virus-Found', 'Yes', 0);
+        # $transaction->header->add('X-Virus-Details', $output, 0);
+        $transaction->header->add('X-H+BEDV-Virus-Found',   'Yes',   0);
+        $transaction->header->add('X-H+BEDV-Virus-Details', $output, 0);
+    }
+    elsif ($result == 200) {
+        $self->log(LOGWARN, "Program aborted, not enough memory available");
+    }
+    elsif ($result == 211) {
+        $self->log(LOGWARN, "Programm aborted, because the self check failed");
+    }
+    elsif ($result == 214) {
+        $self->log(LOGWARN, "License key not found");
+    }
+    elsif ($result) {
+        $self->log(LOGWARN,
+                       "Error: $result, look for exit codes in the output of '"
+                     . $self->{_hbedvscan_loc}
+                     . " --help' for more info\n"
+                  );
+    }
+
+    # $transaction->header->add('X-Virus-Checked', 'Checked', 0);
+    $transaction->header->add('X-H+BEDV-Virus-Checked', 'Checked', 0);
+    return (DECLINED) unless $result;
+
+    if (@virii) {
+        return (DENY, "Virus found: $output")
+          unless $self->qp->config("hbedv_deny");
+        foreach my $d ($self->qp->config("hbedv_deny")) {
+            foreach my $v (@virii) {
+                if ($v =~ /^$d$/i) {
+                    $self->log(LOGWARN, "Denying mail with virus '$v'");
+                    return (DENY, "Virus found: $output");
+                }
+            }
+        }
+    }
+    return (DECLINED);
 }
 
 sub unique {
-  ## This is the short version, I haven't tried if any warnings
+    ## This is the short version, I haven't tried if any warnings
-  ## are generated by perl if you use just this... if you need 
+    ## are generated by perl if you use just this... if you need
-  ## every cpu cycle, try this:
+    ## every cpu cycle, try this:
-  ## my %h;foreach (@_) { ++$h{$_}; }; return keys(%h);
+    ## my %h;foreach (@_) { ++$h{$_}; }; return keys(%h);
-  my @list = @_;
+    my @list = @_;
-  my %hash;
+    my %hash;
-  foreach my $item (@list) {
+    foreach my $item (@list) {
-    exists $hash{$item} || ($hash{$item} = 1); 
+        exists $hash{$item} || ($hash{$item} = 1);
-  }
+    }
-  return keys(%hash)
+    return keys(%hash);
 }

plugins/virus/kavscanner

@@ -56,121 +56,137 @@ use File::Temp qw(tempfile);
 use Mail::Address;
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  if (@args % 2) {
+    if (@args % 2) {
-    $self->log(LOGWARN, "kavscanner: Wrong number of arguments");
+        $self->log(LOGWARN, "kavscanner: Wrong number of arguments");
-    $self->{_kavscanner_bin} = "/opt/AVP/kavscanner";
+        $self->{_kavscanner_bin} = "/opt/AVP/kavscanner";
-  } else {
-    my %args = @args;
-    foreach my $key (keys %args) {
-      my $arg = $key;
-      $key =~ s/^/_/;
-      $self->{$key} = $args{$arg};
     }
-    # Untaint scanner location
+    else {
-    if (exists $self->{_kavscanner_bin} && 
+        my %args = @args;
-        $self->{_kavscanner_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/) {
+        foreach my $key (keys %args) {
-      $self->{_kavscanner_bin} = $1;
+            my $arg = $key;
-    } else {
+            $key =~ s/^/_/;
-      $self->log(LOGALERT, "FATAL ERROR: Unexpected characters in kavscanner argument");
+            $self->{$key} = $args{$arg};
-      exit 3;
+        }
+
+        # Untaint scanner location
+        if (exists $self->{_kavscanner_bin}
+            && $self->{_kavscanner_bin} =~ /^(\/[\/\-\_\.a-z0-9A-Z]*)$/)
+        {
+            $self->{_kavscanner_bin} = $1;
+        }
+        else {
+            $self->log(LOGALERT,
+                   "FATAL ERROR: Unexpected characters in kavscanner argument");
+            exit 3;
+        }
     }
-  } 
 }
 
 sub hook_data_post {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  my ($temp_fh, $filename) = tempfile();
+    my ($temp_fh, $filename) = tempfile();
-  print $temp_fh $transaction->header->as_string;
+    print $temp_fh $transaction->header->as_string;
-  print $temp_fh "\n";
+    print $temp_fh "\n";
-  $transaction->body_resetpos;
+    $transaction->body_resetpos;
-  while (my $line = $transaction->body_getline) {
+    while (my $line = $transaction->body_getline) {
-    print $temp_fh $line;
+        print $temp_fh $line;
-  }
-  seek($temp_fh, 0, 0);
- 
-  # Now do the actual scanning!
-  my $cmd = $self->{_kavscanner_bin}." -Y -P -B -MP -MD -* $filename 2>&1";
-  $self->log(LOGNOTICE, "Running: $cmd");
-  my @output = `$cmd`;
-  chomp(@output);
- 
-  my $result = ($? >> 8);
-  my $signal = ($? & 127);
- 
-  unlink($filename);
-  close $temp_fh;
-
-  if ($signal) {
-    $self->log(LOGWARN, "kavscanner exited with signal: $signal");
-    return (DECLINED);
-  }
-
-  my $description = 'clean';
-  my @infected    = ();
-  my @suspicious  = ();
-  if ($result > 0) {
-    if ($result =~ /^(2|3|4|8)$/) {
-      foreach (@output) {
-        if (/^.* infected: (.*)$/) {
-          # This covers the specific
-          push @infected, $1;
-        } elsif (/^\s*.* suspicion: (.*)$/) {
-          # This covers the potential viruses
-          push @suspicious, $1;
-        }
-      }
-      $description = "infected by: ".join(", ",@infected)."; "
-                    ."suspicions: ".join(", ", @suspicious);
-      # else we may get a veeeery long X-Virus-Details: line or log entry
-      $description = substr($description,0,60); 
-      $self->log(LOGWARN, "There be a virus! ($description)");
-      ### Untested by now, need volunteers ;-)
-      #if ($self->qp->config("kav_deny")) {
-      #  foreach my $d (keys %{$self->qp->config("kav_deny", "map")}) {
-      #    foreach my $v (@infected) {
-      #      return(DENY, "Virus found: $description")
-      #        if ($v =~ /^$d$/i); 
-      #    }
-      #    foreach my $s (@suspicious) {
-      #      return(DENY, "Virus found: $description")
-      #        if ($s =~ /^$d$/i); 
-      #    }
-      #  }
-      #}
-      $transaction->header->add('X-Virus-Found', 'Yes');
-      $transaction->header->add('X-Virus-Details', $description);
-      ### maybe the spamassassin plugin can skip this mail if a virus
-      ### was found (and $transaction->notes('virus_flag') exists :))
-      ### ...ok, works with our spamassassin plugin version 
-      ###   -- hah
-      $transaction->notes('virus', $description);
-      $transaction->notes('virus_flag', 'Yes');
-
-      #### requires modification of Qpsmtpd/Transaction.pm:
-      # if ($self->{_to_virusadmin}) {
-      #   my @addrs = ();
-      #   foreach (@{$transaction->recipients}) {
-      #     push @addr, $_->address;
-      #   }
-      #   $transaction->header->add('X-Virus-Orig-RcptTo', join(", ", @addrs));
-      #   $transaction->set_recipients(@{ Mail::Address->parse($self->{_to_virusadmin}) });
-      # } elsif ($self->{_bcc_virusadmin}) {
-      if ($self->{_bcc_virusadmin}) {
-        foreach ( @{ Mail::Address->parse($self->{_bcc_virusadmin}) } ) {
-          $transaction->add_recipient($_);
-        }
-      }
-    } else {
-      $self->log(LOGEMERG, "corrupt or unknown Kaspersky scanner/resource problems - exit status $result");
     }
-  }
+    seek($temp_fh, 0, 0);
 
-  $self->log(LOGINFO, "kavscanner results: $description");
+    # Now do the actual scanning!
+    my $cmd = $self->{_kavscanner_bin} . " -Y -P -B -MP -MD -* $filename 2>&1";
+    $self->log(LOGNOTICE, "Running: $cmd");
+    my @output = `$cmd`;
+    chomp(@output);
 
-  $transaction->header->add('X-Virus-Checked', 'Checked by '.$self->qp->config("me"));
+    my $result = ($? >> 8);
-  return (DECLINED);
+    my $signal = ($? & 127);
+
+    unlink($filename);
+    close $temp_fh;
+
+    if ($signal) {
+        $self->log(LOGWARN, "kavscanner exited with signal: $signal");
+        return (DECLINED);
+    }
+
+    my $description = 'clean';
+    my @infected    = ();
+    my @suspicious  = ();
+    if ($result > 0) {
+        if ($result =~ /^(2|3|4|8)$/) {
+            foreach (@output) {
+                if (/^.* infected: (.*)$/) {
+
+                    # This covers the specific
+                    push @infected, $1;
+                }
+                elsif (/^\s*.* suspicion: (.*)$/) {
+
+                    # This covers the potential viruses
+                    push @suspicious, $1;
+                }
+            }
+            $description =
+                "infected by: "
+              . join(", ", @infected) . "; "
+              . "suspicions: "
+              . join(", ", @suspicious);
+
+            # else we may get a veeeery long X-Virus-Details: line or log entry
+            $description = substr($description, 0, 60);
+            $self->log(LOGWARN, "There be a virus! ($description)");
+            ### Untested by now, need volunteers ;-)
+            #if ($self->qp->config("kav_deny")) {
+            #  foreach my $d (keys %{$self->qp->config("kav_deny", "map")}) {
+            #    foreach my $v (@infected) {
+            #      return(DENY, "Virus found: $description")
+            #        if ($v =~ /^$d$/i);
+            #    }
+            #    foreach my $s (@suspicious) {
+            #      return(DENY, "Virus found: $description")
+            #        if ($s =~ /^$d$/i);
+            #    }
+            #  }
+            #}
+            $transaction->header->add('X-Virus-Found',   'Yes');
+            $transaction->header->add('X-Virus-Details', $description);
+            ### maybe the spamassassin plugin can skip this mail if a virus
+            ### was found (and $transaction->notes('virus_flag') exists :))
+            ### ...ok, works with our spamassassin plugin version
+            ###   -- hah
+            $transaction->notes('virus',      $description);
+            $transaction->notes('virus_flag', 'Yes');
+
+            #### requires modification of Qpsmtpd/Transaction.pm:
+# if ($self->{_to_virusadmin}) {
+#   my @addrs = ();
+#   foreach (@{$transaction->recipients}) {
+#     push @addr, $_->address;
+#   }
+#   $transaction->header->add('X-Virus-Orig-RcptTo', join(", ", @addrs));
+#   $transaction->set_recipients(@{ Mail::Address->parse($self->{_to_virusadmin}) });
+# } elsif ($self->{_bcc_virusadmin}) {
+            if ($self->{_bcc_virusadmin}) {
+                foreach (@{Mail::Address->parse($self->{_bcc_virusadmin})}) {
+                    $transaction->add_recipient($_);
+                }
+            }
+        }
+        else {
+            $self->log(LOGEMERG,
+"corrupt or unknown Kaspersky scanner/resource problems - exit status $result"
+            );
+        }
+    }
+
+    $self->log(LOGINFO, "kavscanner results: $description");
+
+    $transaction->header->add('X-Virus-Checked',
+                              'Checked by ' . $self->qp->config("me"));
+    return (DECLINED);
 }
 

plugins/virus/klez_filter

@@ -1,34 +1,36 @@
 #!perl -w
 
 sub hook_data_post {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  # klez files are always sorta big .. how big?  Dunno. 
+    # klez files are always sorta big .. how big?  Dunno.
-  return (DECLINED)
+    return (DECLINED)
-    if $transaction->data_size < 60_000;
+      if $transaction->data_size < 60_000;
-   #   220k was too little, so let's just disable the "big size check"
-   #   or $transaction->data_size > 1_000_000;
 
-  # maybe it would be worthwhile to add a check for
+    #   220k was too little, so let's just disable the "big size check"
-  # Content-Type: multipart/alternative; here?
+    #   or $transaction->data_size > 1_000_000;
 
-  # make sure we read from the beginning;
+    # maybe it would be worthwhile to add a check for
-  $transaction->body_resetpos;
+    # Content-Type: multipart/alternative; here?
 
-  my $line_number = 0; 
+    # make sure we read from the beginning;
-  my $seen_klez_signature = 0;
+    $transaction->body_resetpos;
 
-  while ($_ = $transaction->body_getline) {
+    my $line_number         = 0;
-    last if $line_number++ > 40;
+    my $seen_klez_signature = 0;
 
-    m/^Content-type:.*(?:audio|application)/i
+    while ($_ = $transaction->body_getline) {
-      and ++$seen_klez_signature and next;
+        last if $line_number++ > 40;
 
-    return (DENY, "Klez Virus Detected")
+        m/^Content-type:.*(?:audio|application)/i
-      if $seen_klez_signature 
+          and ++$seen_klez_signature
-	and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!;
+          and next;
 
-  }
+        return (DENY, "Klez Virus Detected")
+          if $seen_klez_signature
+          and m!^TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQA!;
 
-  return (DECLINED);
+    }
+
+    return (DECLINED);
 }

plugins/virus/sophie

@@ -2,9 +2,9 @@
 use IO::Socket;
 
 sub register {
-    my ( $self, $qp, @args ) = @_;
+    my ($self, $qp, @args) = @_;
 
-    %{ $self->{"_sophie"} } = @args;
+    %{$self->{"_sophie"}} = @args;
 
     # Set some sensible defaults
     $self->{"_sophie"}->{"sophie_socket"} ||= "/var/run/sophie";
@@ -13,68 +13,66 @@ sub register {
 }
 
 sub hook_data_post {
-    my ( $self, $transaction ) = @_;
+    my ($self, $transaction) = @_;
     $DB::single = 1;
 
-    if ( $transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024 ) {
+    if ($transaction->data_size > $self->{"_sophie"}->{"max_size"} * 1024) {
-        $self->log( LOGNOTICE, "Declining due to data_size" );
+        $self->log(LOGNOTICE, "Declining due to data_size");
         return (DECLINED);
     }
 
     # Ignore non-multipart emails
     my $content_type = $transaction->header->get('Content-Type');
     $content_type =~ s/\s/ /g if defined $content_type;
-    unless ( $content_type
+    unless (   $content_type
-        && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
+            && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i)
     {
-        $self->log( LOGWARN, "non-multipart mail - skipping" );
+        $self->log(LOGWARN, "non-multipart mail - skipping");
         return DECLINED;
     }
 
     my $filename = $transaction->body_filename;
     unless ($filename) {
-        $self->log( LOGWARN, "Cannot process due to lack of filename" );
+        $self->log(LOGWARN, "Cannot process due to lack of filename");
         return (DECLINED);    # unless $filename;
     }
 
-    my $mode = ( stat( $self->spool_dir() ) )[2];
+    my $mode = (stat($self->spool_dir()))[2];
-    if ( $mode & 07077 ) {   # must be sharing spool directory with external app
+    if ($mode & 07077) {    # must be sharing spool directory with external app
-        $self->log( LOGWARN,
+        $self->log(LOGWARN,
-            "Changing permissions on file to permit scanner access" );
+                   "Changing permissions on file to permit scanner access");
         chmod $mode, $filename;
     }
 
     my ($SOPHIE, $response);
     socket(\*SOPHIE, AF_UNIX, SOCK_STREAM, 0)
-    	|| die "Couldn't create socket ($!)\n";
+      || die "Couldn't create socket ($!)\n";
 
     connect(\*SOPHIE, pack_sockaddr_un $self->{"_sophie"}->{"sophie_socket"})
-	|| die "Couldn't connect() to the socket ($!)\n";
+      || die "Couldn't connect() to the socket ($!)\n";
 
-    syswrite(\*SOPHIE, $filename."\n", length($filename)+1);
+    syswrite(\*SOPHIE, $filename . "\n", length($filename) + 1);
     sysread(\*SOPHIE, $response, 256);
-    close (\*SOPHIE);
+    close(\*SOPHIE);
 
     my $virus;
 
-    if ( ($virus) = ( $response =~ m/^1:?(.*)?$/ ) ) {
+    if (($virus) = ($response =~ m/^1:?(.*)?$/)) {
-        $self->log( LOGERROR, "One or more virus(es) found: $virus" );
+        $self->log(LOGERROR, "One or more virus(es) found: $virus");
 
-        if ( lc( $self->{"_sophie"}->{"deny_viruses"} ) eq "yes" ) {
+        if (lc($self->{"_sophie"}->{"deny_viruses"}) eq "yes") {
-            return ( DENY,
+            return (DENY,
-                    "Virus"
+                    "Virus" . ($virus =~ /,/ ? "es " : " ") . "Found: $virus");
-                  . ( $virus =~ /,/ ? "es " : " " )
-                  . "Found: $virus" );
         }
         else {
-            $transaction->header->add( 'X-Virus-Found',   'Yes' );
+            $transaction->header->add('X-Virus-Found',   'Yes');
-            $transaction->header->add( 'X-Virus-Details', $virus );
+            $transaction->header->add('X-Virus-Details', $virus);
             return (DECLINED);
         }
     }
 
-    $transaction->header->add( 'X-Virus-Checked',
+    $transaction->header->add('X-Virus-Checked',
-        "Checked by SOPHIE on " . $self->qp->config("me") );
+                             "Checked by SOPHIE on " . $self->qp->config("me"));
 
     return (DECLINED);
 }

plugins/virus/uvscan

@@ -44,91 +44,99 @@ Please see the LICENSE file included with qpsmtpd for details.
 =cut
 
 sub register {
-  my ($self, $qp, @args) = @_;
+    my ($self, $qp, @args) = @_;
 
-  while (@args) {
+    while (@args) {
-  	$self->{"_uvscan"}->{pop @args}=pop @args;
+        $self->{"_uvscan"}->{pop @args} = pop @args;
-  }
+    }
-  $self->{"_uvscan"}->{"uvscan_location"}||="/usr/local/bin/uvscan";
+    $self->{"_uvscan"}->{"uvscan_location"} ||= "/usr/local/bin/uvscan";
 }
 
 sub hook_data_post {
-  my ($self, $transaction) = @_;
+    my ($self, $transaction) = @_;
 
-  return (DECLINED)
+    return (DECLINED)
-    if $transaction->data_size > 250_000;
+      if $transaction->data_size > 250_000;
 
-  # Ignore non-multipart emails
+    # Ignore non-multipart emails
-  my $content_type = $transaction->header->get('Content-Type');
+    my $content_type = $transaction->header->get('Content-Type');
-  $content_type =~ s/\s/ /g if defined $content_type;
+    $content_type =~ s/\s/ /g if defined $content_type;
-  unless ( $content_type
+    unless (   $content_type
-      && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i )
+            && $content_type =~ m!\bmultipart/.*\bboundary="?([^"]+)!i)
-  {
+    {
-      $self->log( LOGWARN, "non-multipart mail - skipping" );
+        $self->log(LOGWARN, "non-multipart mail - skipping");
-      return DECLINED;
+        return DECLINED;
-  }
-
-  my $filename = $transaction->body_filename;
-  return (DECLINED) unless $filename;
-
-  # Now do the actual scanning!
-  my @cmd =($self->{"_uvscan"}->{"uvscan_location"},
-	'--mime', '--unzip', '--secure', '--noboot',
-	$filename, '2>&1 |');
-  $self->log(LOGINFO, "Running: ",join(' ', @cmd));
-  open(FILE, join(' ', @cmd)); #perl 5.6 doesn't properly support the pipe
-  # mode list form of open, but this is basically the same thing. This form
-  # of exec is safe(ish).
-  my $output;
-  while (<FILE>) { $output.=$_; }
-  close FILE;
-
-  my $result = ($? >> 8);
-  my $signal = ($? & 127);
- 
-  my $virus;
-  if ($output && $output =~ m/.*\W+Found (.*)\n/m) {
-    $virus=$1;
-  }
-  if ($output && $output =~ m/password-protected/m) {
-    return (DENY, 'We do not accept password-protected zip files!');
-  }
-
-  if ($signal) {
-    $self->log(LOGWARN, "uvscan exited with signal: $signal");
-    return (DECLINED);
-  }
-  if ($result == 2) {
-      $self->log(LOGERROR, "Integrity check for a DAT file failed.");
-      return (DECLINED);
-  } elsif ($result == 6) {
-      $self->log(LOGERROR, "A general problem has occurred.");
-      return (DECLINED);
-  } elsif ($result == 8) {
-      $self->log(LOGERROR, "The program could not find a DAT file.");
-      return (DECLINED);
-  } elsif ($result == 15) {
-      $self->log(LOGERROR, "The program self-check failed");
-      return (DECLINED);
-  } elsif ( $result ) { # all of the possible virus returns
-    if ($result == 12) {
-      $self->log(LOGERROR, "The program tried to clean a file but failed.");
-    } elsif ($result == 13) {
-      $self->log(LOGERROR, "One or more virus(es) found");
-    } elsif ($result == 19) {
-      $self->log(LOGERROR, "Successfully cleaned the file");
     }
 
-    if (lc($self->{"_uvscan"}->{"deny_viruses"}) eq "yes") {
+    my $filename = $transaction->body_filename;
-       return (DENY, "Virus Found: $virus");
+    return (DECLINED) unless $filename;
+
+    # Now do the actual scanning!
+    my @cmd = (
+               $self->{"_uvscan"}->{"uvscan_location"},
+               '--mime', '--unzip', '--secure', '--noboot', $filename, '2>&1 |'
+              );
+    $self->log(LOGINFO, "Running: ", join(' ', @cmd));
+    open(FILE, join(' ', @cmd));    #perl 5.6 doesn't properly support the pipe
+       # mode list form of open, but this is basically the same thing. This form
+       # of exec is safe(ish).
+    my $output;
+    while (<FILE>) { $output .= $_; }
+    close FILE;
+
+    my $result = ($? >> 8);
+    my $signal = ($? & 127);
+
+    my $virus;
+    if ($output && $output =~ m/.*\W+Found (.*)\n/m) {
+        $virus = $1;
     }
-    $transaction->header->add('X-Virus-Found', 'Yes');
+    if ($output && $output =~ m/password-protected/m) {
-    $transaction->header->add('X-Virus-Details', $virus);
+        return (DENY, 'We do not accept password-protected zip files!');
+    }
+
+    if ($signal) {
+        $self->log(LOGWARN, "uvscan exited with signal: $signal");
+        return (DECLINED);
+    }
+    if ($result == 2) {
+        $self->log(LOGERROR, "Integrity check for a DAT file failed.");
+        return (DECLINED);
+    }
+    elsif ($result == 6) {
+        $self->log(LOGERROR, "A general problem has occurred.");
+        return (DECLINED);
+    }
+    elsif ($result == 8) {
+        $self->log(LOGERROR, "The program could not find a DAT file.");
+        return (DECLINED);
+    }
+    elsif ($result == 15) {
+        $self->log(LOGERROR, "The program self-check failed");
+        return (DECLINED);
+    }
+    elsif ($result) {    # all of the possible virus returns
+        if ($result == 12) {
+            $self->log(LOGERROR,
+                       "The program tried to clean a file but failed.");
+        }
+        elsif ($result == 13) {
+            $self->log(LOGERROR, "One or more virus(es) found");
+        }
+        elsif ($result == 19) {
+            $self->log(LOGERROR, "Successfully cleaned the file");
+        }
+
+        if (lc($self->{"_uvscan"}->{"deny_viruses"}) eq "yes") {
+            return (DENY, "Virus Found: $virus");
+        }
+        $transaction->header->add('X-Virus-Found',   'Yes');
+        $transaction->header->add('X-Virus-Details', $virus);
+        return (DECLINED);
+    }
+
+    $transaction->header->add('X-Virus-Checked',
+                      "Checked by McAfee uvscan on " . $self->qp->config("me"));
+
     return (DECLINED);
-  }
-  
-  $transaction->header->add('X-Virus-Checked',
-    "Checked by McAfee uvscan on ".$self->qp->config("me"));
-
-  return (DECLINED);
 }

plugins/whitelist

@@ -139,7 +139,7 @@ sub check_host {
     if (exists $ENV{WHITELISTCLIENT}) {
         $self->qp->connection->notes('whitelistclient', 1);
         $self->log(2, "pass, is whitelisted client");
-        $self->adjust_karma( 5 );
+        $self->adjust_karma(5);
         return OK;
     }
 
@@ -148,7 +148,7 @@ sub check_host {
         if ($h eq $ip or $ip =~ /^\Q$h\E/) {
             $self->qp->connection->notes('whitelisthost', 1);
             $self->log(2, "pass, is a whitelisted host");
-            $self->adjust_karma( 5 );
+            $self->adjust_karma(5);
             return OK;
         }
     }