Fix bounce generation under RFC 3461 request. Bug 2411

[exim.git] / src / src / exipick.src

diff --git a/src/src/exipick.src b/src/src/exipick.src
index 931ff51aa83a6900f54672712a967561f9657aad..7959d754c81cdc077bb27fb6c411ae35d501e5a8 100644 (file)
--- a/src/src/exipick.src
+++ b/src/src/exipick.src
@@ -1,8 +1,12 @@
 #!PERL_COMMAND
 #!PERL_COMMAND

-# $Cambridge: exim/src/src/exipick.src,v 1.15 2010/01/04 18:16:54 jetmore Exp $
+# Copyright (c) 1995 - 2018 University of Cambridge.
+# See the file NOTICE for conditions of use and distribution.
+
+
+# This variables should be set by the building process
+my $spool = 'SPOOL_DIRECTORY'; # may be overridden later
+my $exim  = 'BIN_DIRECTORY/exim';

 
 

-# This variable should be set by the building process to Exim's spool directory.
-my $spool = 'SPOOL_DIRECTORY';

 # Need to set this dynamically during build, but it's not used right now anyway.
 my $charset = 'ISO-8859-1';
 
 # Need to set this dynamically during build, but it's not used right now anyway.
 my $charset = 'ISO-8859-1';
 


@@ -11,10 +15,12 @@ my $charset = 'ISO-8859-1';
 #       http://www.exim.org/eximwiki/ToolExipickManPage
 
 use strict;
 #       http://www.exim.org/eximwiki/ToolExipickManPage
 
 use strict;

+BEGIN { pop @INC if $INC[-1] eq '.' };

 use Getopt::Long;
 use Getopt::Long;

+use File::Basename;

 
 my($p_name)   = $0 =~ m|/?([^/]+)$|;
 
 my($p_name)   = $0 =~ m|/?([^/]+)$|;

-my $p_version = "20100104.1";
+my $p_version = "20100323.0";

 my $p_usage   = "Usage: $p_name [--help|--version] (see --help for details)";
 my $p_cp      = <<EOM;
         Copyright (c) 2003-2010 John Jetmore <jj33\@pobox.com>
 my $p_usage   = "Usage: $p_name [--help|--version] (see --help for details)";
 my $p_cp      = <<EOM;
         Copyright (c) 2003-2010 John Jetmore <jj33\@pobox.com>


@@ -40,6 +46,9 @@ $| = 1; # unbuffer STDOUT
 Getopt::Long::Configure("bundling_override");
 GetOptions(
   'spool=s'     => \$G::spool,      # exim spool dir
 Getopt::Long::Configure("bundling_override");
 GetOptions(
   'spool=s'     => \$G::spool,      # exim spool dir

+  'C|Config=s'  => \$G::config,     # use alternative Exim configuration file
+  'input-dir=s' => \$G::input_dir,  # name of the "input" dir
+  'finput'      => \$G::finput,     # same as "--input-dir Finput"

   'bp'          => \$G::mailq_bp,   # List the queue (noop - default)
   'bpa'         => \$G::mailq_bpa,  # ... with generated address as well
   'bpc'         => \$G::mailq_bpc,  # ... but just show a count of messages
   'bp'          => \$G::mailq_bp,   # List the queue (noop - default)
   'bpa'         => \$G::mailq_bpa,  # ... with generated address as well
   'bpc'         => \$G::mailq_bpc,  # ... but just show a count of messages


@@ -75,10 +84,16 @@ GetOptions(
   'show-vars=s' => \$G::show_vars,  # display the contents of these vars
   'just-vars'   => \$G::just_vars,  # only display vars, no other info
   'show-rules'  => \$G::show_rules, # display compiled match rules
   'show-vars=s' => \$G::show_vars,  # display the contents of these vars
   'just-vars'   => \$G::just_vars,  # only display vars, no other info
   'show-rules'  => \$G::show_rules, # display compiled match rules

-  'show-tests'  => \$G::show_tests  # display tests as applied to each message
+  'show-tests'  => \$G::show_tests, # display tests as applied to each message
+  'version'     => sub {
+        print basename($0) . ": $0\n",
+            "build: EXIM_RELEASE_VERSIONEXIM_VARIANT_VERSION\n",
+            "perl(runtime): $]\n";
+            exit 0;
+  },

 ) || exit(1);
 
 ) || exit(1);
 

-# if both freeze and thaw specified, only thaw as it is less desctructive
+# if both freeze and thaw specified, only thaw as it is less destructive

 $G::freeze = undef               if ($G::freeze && $G::thaw);
 freeze_start()                   if ($G::freeze);
 thaw_start()                     if ($G::thaw);
 $G::freeze = undef               if ($G::freeze && $G::thaw);
 freeze_start()                   if ($G::freeze);
 thaw_start()                     if ($G::thaw);


@@ -110,12 +125,15 @@ $G::and             = $G::and;             # shut up -w
 $G::msg_ids         = {};                  # short circuit when crit is only MID
 $G::caseless        = $G::caseful ? 0 : 1; # nocase by default, case if both
 @G::recipients_crit = ();                  # holds per-recip criteria
 $G::msg_ids         = {};                  # short circuit when crit is only MID
 $G::caseless        = $G::caseful ? 0 : 1; # nocase by default, case if both
 @G::recipients_crit = ();                  # holds per-recip criteria

-$spool              = $G::spool if ($G::spool);
+$spool              = defined $G::spool ? $G::spool
+                     : do { chomp($_ = `$exim @{[defined $G::config ? "-C $G::config" : '']} -n -bP spool_directory`)
+                             and $_ or $spool };
+my $input_dir       = $G::input_dir || ($G::finput ? "Finput" : "input");

 my $count_only      = 1 if ($G::mailq_bpc  || $G::qgrep_c);
 my $unsorted        = 1 if ($G::mailq_bpr  || $G::mailq_bpra ||
                             $G::mailq_bpru || $G::unsorted);
 my $msg             = $G::thaw ? thaw_message_list()
 my $count_only      = 1 if ($G::mailq_bpc  || $G::qgrep_c);
 my $unsorted        = 1 if ($G::mailq_bpr  || $G::mailq_bpra ||
                             $G::mailq_bpru || $G::unsorted);
 my $msg             = $G::thaw ? thaw_message_list()

-                               : get_all_msgs($spool, $unsorted,
+                               : get_all_msgs($spool, $input_dir, $unsorted,

                                               $G::reverse, $G::random);
 die "Problem accessing thaw file\n" if ($G::thaw && !$msg);
 my $crit            = process_criteria(\@ARGV);
                                               $G::reverse, $G::random);
 die "Problem accessing thaw file\n" if ($G::thaw && !$msg);
 my $crit            = process_criteria(\@ARGV);


@@ -131,7 +149,7 @@ $e->output_brief()               if ($G::qgrep_b);
 $e->output_flatq()               if ($G::flatq);
 $e->output_vars_only()           if ($G::just_vars && $G::show_vars);
 $e->set_show_vars($G::show_vars) if ($G::show_vars);
 $e->output_flatq()               if ($G::flatq);
 $e->output_vars_only()           if ($G::just_vars && $G::show_vars);
 $e->set_show_vars($G::show_vars) if ($G::show_vars);

-$e->set_spool($spool);
+$e->set_spool($spool, $input_dir);

 
 MSG:
 foreach my $m (@$msg) {
 
 MSG:
 foreach my $m (@$msg) {


@@ -379,7 +397,7 @@ sub process_criteria {
     } else {
       $c[-1]{cmp} .= $G::negate ? " ? 0 : 1" : " ? 1 : 0";
     }
     } else {
       $c[-1]{cmp} .= $G::negate ? " ? 0 : 1" : " ? 1 : 0";
     }

-    # support the each_* psuedo variables.  Steal the criteria off of the
+    # support the each_* pseudo variables.  Steal the criteria off of the

     # queue for special processing later
     if ($c[-1]{var} =~ /^each_(recipients(_(un)?del)?)$/) {
       my $var = $1;
     # queue for special processing later
     if ($c[-1]{var} =~ /^each_(recipients(_(un)?del)?)$/) {
       my $var = $1;


@@ -396,12 +414,15 @@ sub process_criteria {
 }
 
 sub get_all_msgs {
 }
 
 sub get_all_msgs {

-  my $d = shift() . '/input';
+  my $d = shift();
+  my $i = shift();

   my $u = shift; # don't sort
   my $r = shift; # right before returning, reverse order
   my $o = shift; # if true, randomize list order before returning
   my @m = ();
 
   my $u = shift; # don't sort
   my $r = shift; # right before returning, reverse order
   my $o = shift; # if true, randomize list order before returning
   my @m = ();
 

+  if ($i =~ m|^/|) { $d = $i; } else { $d = $d . '/' . $i; }
+

   opendir(D, "$d") || die "Couldn't opendir $d: $!\n";
   foreach my $e (grep !/^\./, readdir(D)) {
     if ($e =~ /^[a-zA-Z0-9]$/) {
   opendir(D, "$d") || die "Couldn't opendir $d: $!\n";
   foreach my $e (grep !/^\./, readdir(D)) {
     if ($e =~ /^[a-zA-Z0-9]$/) {


@@ -446,6 +467,7 @@ sub new {
   bless($self, $class);
 
   $self->{_spool_dir}        = '';
   bless($self, $class);
 
   $self->{_spool_dir}        = '';

+  $self->{_input_path}       = '';

   $self->{_undelivered_only} = 0;
   $self->{_show_generated}   = 0;
   $self->{_output_long}      = 1;
   $self->{_undelivered_only} = 0;
   $self->{_show_generated}   = 0;
   $self->{_output_long}      = 1;


@@ -563,7 +585,7 @@ sub parse_message {
   $self->_reset();
   $self->{_message} = shift || return(0);
   $self->{_path}    = shift; # optional path to message
   $self->_reset();
   $self->{_message} = shift || return(0);
   $self->{_path}    = shift; # optional path to message

-  return(0) if (!$self->{_spool_dir});
+  return(0) if (!$self->{_input_path});

   if (!$self->{_path} && !$self->_find_path()) {
     # assume the message was delivered from under us and ignore
     $self->{_delivered} = 1;
   if (!$self->{_path} && !$self->_find_path()) {
     # assume the message was delivered from under us and ignore
     $self->{_delivered} = 1;


@@ -584,7 +606,7 @@ sub restore_state {
   return(1) if ($h->{_delivered});
   $self->_reset();
   $self->{_message} = $h->{_message} || return(0);
   return(1) if ($h->{_delivered});
   $self->_reset();
   $self->{_message} = $h->{_message} || return(0);

-  return(0) if (!$self->{_spool_dir});
+  return(0) if (!$self->{_input_path});

 
   $self->{_path}      = $h->{_path};
   $self->{_vars}      = $h->{_vars};
 
   $self->{_path}      = $h->{_path};
   $self->{_vars}      = $h->{_vars};


@@ -630,13 +652,13 @@ sub _find_path {
   my $self = shift;
 
   return(0) if (!$self->{_message});
   my $self = shift;
 
   return(0) if (!$self->{_message});

-  return(0) if (!$self->{_spool_dir});
+  return(0) if (!$self->{_input_path});

 
   # test split spool first on the theory that people concerned about
   # performance will have split spool set =).
   foreach my $f (substr($self->{_message}, 5, 1).'/', '') {
 
   # test split spool first on the theory that people concerned about
   # performance will have split spool set =).
   foreach my $f (substr($self->{_message}, 5, 1).'/', '') {

-    if (-f "$self->{_spool_dir}/input/$f$self->{_message}-H") {
-      $self->{_path} = $self->{_spool_dir} . "/input/$f";
+    if (-f "$self->{_input_path}/$f$self->{_message}-H") {
+      $self->{_path} = "$self->{_input_path}}/$f";

       return(1);
     }
   }
       return(1);
     }
   }


@@ -646,6 +668,10 @@ sub _find_path {
 sub set_spool {
   my $self = shift;
   $self->{_spool_dir} = shift;
 sub set_spool {
   my $self = shift;
   $self->{_spool_dir} = shift;

+  $self->{_input_path} = shift;
+  if ($self->{_input_path} !~ m|^/|) {
+    $self->{_input_path} = $self->{_spool_dir} . '/' . $self->{_input_path};
+  }

 }
 
 sub get_matching_vars {
 }
 
 sub get_matching_vars {


@@ -747,7 +773,7 @@ sub _decode_2047 {
               $i += 2;
             }
           }
               $i += 2;
             }
           }

-          elsif ($ow[$i] =~ /\s/) { # whitspace is illegal
+          elsif ($ow[$i] =~ /\s/) { # whitespace is illegal

             $e = 1;
             last;
           }
             $e = 1;
             last;
           }


@@ -945,6 +971,8 @@ sub _parse_header {
         $self->{_vars}{tls_cipher} = $arg;
       } elsif ($tag eq '-tls_peerdn') {
         $self->{_vars}{tls_peerdn} = $arg;
         $self->{_vars}{tls_cipher} = $arg;
       } elsif ($tag eq '-tls_peerdn') {
         $self->{_vars}{tls_peerdn} = $arg;

+      } elsif ($tag eq '-tls_sni') {
+        $self->{_vars}{tls_sni} = $arg;

       } elsif ($tag eq '-host_address') {
         $self->{_vars}{sender_host_port} = $self->_get_host_and_port(\$arg);
         $self->{_vars}{sender_host_address} = $arg;
       } elsif ($tag eq '-host_address') {
         $self->{_vars}{sender_host_port} = $self->_get_host_and_port(\$arg);
         $self->{_vars}{sender_host_address} = $arg;


@@ -1008,6 +1036,12 @@ sub _parse_header {
       return($self->_error("incorrect format: $_")) if (length($2) != $3);
       $self->{_recips}{$1} = { pno => $4, errors_to => $2 };
       $addr = $1;
       return($self->_error("incorrect format: $_")) if (length($2) != $3);
       $self->{_recips}{$1} = { pno => $4, errors_to => $2 };
       $addr = $1;

+    } elsif (/^(\S*)\s(\S*)\s(\d+),(\d+)\s(\S*)\s(\d+),(-?\d+)#3$/) {
+      #print STDERR "exim4 new type #3 DSN (untested): $_\n";
+      return($self->_error("incorrect format: $_"))
+        if ((length($2) != $3) || (length($5) != $6));
+      $self->{_recips}{$1} = { pno => $7, errors_to => $5 };
+      $addr = $1;

     } elsif (/^.*#(\d+)$/) {
       #print STDERR "exim4 #$1 style (unimplemented): $_\n";
       $self->_error("exim4 #$1 style (unimplemented): $_");
     } elsif (/^.*#(\d+)$/) {
       #print STDERR "exim4 #$1 style (unimplemented): $_\n";
       $self->_error("exim4 #$1 style (unimplemented): $_");


@@ -1321,7 +1355,7 @@ Same as '-bp --unsorted' (exim)
 
 =item -bpra
 
 
 =item -bpra
 

-Same as '-bpr --unsorted' (exim)
+Same as '-bpa --unsorted' (exim)

 
 =item -bpru
 
 
 =item -bpru
 


@@ -1331,6 +1365,11 @@ Same as '-bpu --unsorted' (exim)
 
 Same as -bp, but only show undelivered messages (exim)
 
 
 Same as -bp, but only show undelivered messages (exim)
 

+=item -C | --config <config>
+
+Use <config> to determine the proper spool directory. (See C<--spool>
+or C<--input> for alternative ways to specify the directories to operate on.)
+

 =item -c
 
 Show a count of matching messages (exiqgrep)
 =item -c
 
 Show a count of matching messages (exiqgrep)


@@ -1347,6 +1386,10 @@ Override the default local character set for $header_ decoding
 
 Same as '$sender_address =~ /<regexp>/' (exiqgrep).  Note that this preserves the default case sensitivity of exiqgrep's interface.
 
 
 Same as '$sender_address =~ /<regexp>/' (exiqgrep).  Note that this preserves the default case sensitivity of exiqgrep's interface.
 

+=item --finput
+
+Same as '--input-dir Finput'.  'Finput' is where exim copies frozen messages when compiled with SUPPORT_MOVE_FROZEN_MESSAGES.
+

 =item --flatq
 
 Use a single-line output format
 =item --flatq
 
 Use a single-line output format


@@ -1363,6 +1406,10 @@ Display this output
 
 Display only the message IDs (exiqgrep)
 
 
 Display only the message IDs (exiqgrep)
 

+=item --input-dir <inputname>
+
+Set the name of the directory under the spool directory.  By default this is "input".  If this starts with '/', the value of --spool is ignored.  See also --finput.
+

 =item -l
 
 Same as -bp (exiqgrep)
 =item -l
 
 Same as -bp (exiqgrep)


@@ -1401,7 +1448,7 @@ Same as '$shown_message_size eq <string>' (exiqgrep)
 
 =item --spool <path>
 
 
 =item --spool <path>
 

-Set the path to the exim spool to use
+Set the path to the exim spool to use.  This value will have the argument to --input or 'input' appended, or be ignored if --input is a full path. If not specified, exipick uses the value from C<exim [-C config] -n -bP spool_directory>, and if this call fails, the  F</opt/exim/spool> from build time (F<Local/Makefile>) is used. See also --config.

 
 =item --show-rules
 
 
 =item --show-rules
 


@@ -1469,7 +1516,7 @@ Boolean variables are checked simply by being true or false.  There is no real o
 
 =item NUMERIC
 
 
 =item NUMERIC
 

-Valid comparisons are <, <=, >, >=, ==, and !=.  Numbers can be integers or floats.  Any number in a test suffixed with d, h, m, s, M, K, or B will be mulitplied by 86400, 3600, 60, 1, 1048576, 1024, or 1 respectively.  Examples of valid numeric tests:
+Valid comparisons are <, <=, >, >=, ==, and !=.  Numbers can be integers or floats.  Any number in a test suffixed with d, h, m, s, M, K, or B will be multiplied by 86400, 3600, 60, 1, 1048576, 1024, or 1 respectively.  Examples of valid numeric tests:

   '$message_age >= 3d'
   '$local_interface == 587'
   '$message_size < 30K'
   '$message_age >= 3d'
   '$local_interface == 587'
   '$message_size < 30K'


@@ -1483,7 +1530,7 @@ The string operators are =, eq, ne, =~, and !~.  With the exception of '=', the
 
 =item NEGATION
 
 
 =item NEGATION
 

-There are many ways to negate tests, each having a reason for existing.  Many tests can be negated using native operators.  For instance, >1 is the opposite of <=1 and eq and ne are opposites.  In addition, each individual test can be negated by adding a ! at the beginning of the test.  For instance, '!$acl_m1 =~ /^DENY$/' is the same as '$acl_m1 !~ /^DENY$/'.  Finally, every test can be specified by using the command line argument --not.  This is functionally equivilant to adding a ! to the beginning of every test.
+There are many ways to negate tests, each having a reason for existing.  Many tests can be negated using native operators.  For instance, >1 is the opposite of <=1 and eq and ne are opposites.  In addition, each individual test can be negated by adding a ! at the beginning of the test.  For instance, '!$acl_m1 =~ /^DENY$/' is the same as '$acl_m1 !~ /^DENY$/'.  Finally, every test can be specified by using the command line argument --not.  This is functionally equivalent to adding a ! to the beginning of every test.

 
 =back
 
 
 =back
 


@@ -1557,7 +1604,7 @@ TRUE if, under normal circumstances, Exim will not try to deliver the message.
 
 =item S + $each_recipients
 
 
 =item S + $each_recipients
 

-This is a psuedo variable which allows you to apply a test against each address in $recipients individually.  Whereas '$recipients =~ /@aol.com/' will match if any recipient address contains aol.com, '$each_recipients =~ /@aol.com$/' will only be true if every recipient matches that pattern.  Note that this obeys --and or --or being set.  Using it with --or is very similar to just matching against $recipients, but with the added benefit of being able to use anchors at the beginning and end of each recipient address.
+This is a pseudo variable which allows you to apply a test against each address in $recipients individually.  Whereas '$recipients =~ /@aol.com/' will match if any recipient address contains aol.com, '$each_recipients =~ /@aol.com$/' will only be true if every recipient matches that pattern.  Note that this obeys --and or --or being set.  Using it with --or is very similar to just matching against $recipients, but with the added benefit of being able to use anchors at the beginning and end of each recipient address.

 
 =item S + $each_recipients_del
 
 
 =item S + $each_recipients_del
 


@@ -1775,6 +1822,10 @@ The cipher suite that was negotiated for encrypted SMTP connections.
 
 The value of the Distinguished Name of the certificate if Exim is configured to request one
 
 
 The value of the Distinguished Name of the certificate if Exim is configured to request one
 

+=item S . $tls_sni
+
+The value of the Server Name Indication TLS extension sent by a client, if one was sent.
+

 =item N + $warning_count
 
 The number of delay warnings which have been sent for this message.
 =item N + $warning_count
 
 The number of delay warnings which have been sent for this message.