Testsuite: make it compatible with ancient Perl versions.

[users/jgh/exim.git] / test / runtest

diff --git a/test/runtest b/test/runtest
index 0d6bcd1d769a98ff0c34c46d386c3ebcdb1e32e9..8ef5d6409b5db522b7abac8ab8f85882397f1761 100755 (executable)
--- a/test/runtest
+++ b/test/runtest
@@ -1099,6 +1099,7 @@ RESET_AFTER_EXTRA_LINE_READ:
     next if /DNS lookup of \S+ \(AAAA\) using fakens/;
     next if / in dns_ipv4_lookup?/;
     next if / writing neg-cache entry for .*AAAA/;
+    next if /^faking res_search\(AAAA\) response length as 65535/;
 
     if (/DNS lookup of \S+ \(AAAA\) gave NO_DATA/)
       {
@@ -1621,26 +1622,25 @@ if (-e $sf_current)
         }
       }
 
-    open(MUNGED, '>', $mf) || tests_exit(-1, "Failed to open $mf: $!");
-    for ($i = 0; $i < @munged; $i++)
-      { print MUNGED $munged[$i]; }
-    close(MUNGED);
+    open(my $fh, '>', $mf) or tests_exit(-1, "Failed to open $mf: $!");
+    print $fh @munged;
     }
 
   # Deal with log sorting
 
   if ($sortfile)
     {
-    my(@munged, $i, $j);
 
-    open(MUNGED, $mf) || tests_exit(-1, "Failed to open $mf: $!");
-    @munged = <MUNGED>;
-    close(MUNGED);
+    my @munged = do {
+      open(my $fh, '<', $mf) or tests_exit(-1, "Failed to open $mf: $!");
+      <$fh>;
+    };
 
-    for ($i = 0; $i < @munged; $i++)
+    for (my $i = 0; $i < @munged; $i++)
       {
       if ($munged[$i] =~ /^[-\d]{10}\s[:\d]{8}\s[-A-Za-z\d]{16}\s[-=*]>/)
         {
+        my $j;
         for ($j = $i + 1; $j < @munged; $j++)
           {
           last if $munged[$j] !~
@@ -1652,11 +1652,9 @@ if (-e $sf_current)
         }
       }
 
-    open(MUNGED, ">$mf") || tests_exit(-1, "Failed to open $mf: $!");
-    print MUNGED "**NOTE: The delivery lines in this file have been sorted.\n";
-    for ($i = 0; $i < @munged; $i++)
-      { print MUNGED $munged[$i]; }
-    close(MUNGED);
+    open(my $fh, '>', $mf) or tests_exit(-1, "Failed to open $mf: $!");
+    print $fh "**NOTE: The delivery lines in this file have been sorted.\n";
+    print $fh @munged;
     }
 
   # Do the comparison
@@ -1697,8 +1695,7 @@ else
     # if we deal with a flavour file, we can't delete it, because next time the generic
     # file would be used again
     if ($sf_current eq $sf_flavour) {
-      open(FOO, ">$sf_current");
-      close(FOO);
+      open(my $fh, '>', $sf_current);
     }
     else {
       tests_exit(-1, "Failed to unlink $sf_current") if !unlink($sf_current);
@@ -1767,7 +1764,7 @@ $munges =
     },
 
     'debug_pid' =>
-    { 'stderr' => 's/(^\s{0,4}|(?<=Process )|(?<=child ))\d{1,5}/ppppp/g' },
+    { 'stderr' => 's/(^\s{0,4}|(?<=Process )|(?<=child ))\d+/ppppp/g' },
 
     'optional_dsn_info' =>
     { 'mail' => '/^(X-(Remote-MTA-(smtp-greeting|helo-response)|Exim-Diagnostic|(body|message)-linecount):|Remote-MTA: X-ip;)/'
@@ -2163,34 +2160,37 @@ if (/^dbmbuild\s+(\S+)\s+(\S+)/)
 
 if (/^dump\s+(\S+)/)
   {
-  my($which) = $1;
-  my(@temp);
+  my $which  = $1;
   print ">> ./eximdir/exim_dumpdb $parm_cwd/spool $which\n" if $debug;
-  open(IN, "./eximdir/exim_dumpdb $parm_cwd/spool $which |");
-  open(OUT, ">>test-stdout");
-  print OUT "+++++++++++++++++++++++++++\n";
+  open(my $in, "-|", './eximdir/exim_dumpdb', "$parm_cwd/spool", $which) or die "Can't run exim_dumpdb: $!";
+  open(my $out, ">>test-stdout");
+  print $out "+++++++++++++++++++++++++++\n";
 
   if ($which eq "retry")
     {
-    $/ = "\n  ";
-    @temp = <IN>;
-    $/ = "\n";
-
-    @temp = sort {
-                   my($aa) = split(' ', $a);
-                   my($bb) = split(' ', $b);
-                   return $aa cmp $bb;
-                 } @temp;
-
+    # the sort key is the first part of the retry db dump line, but for
+    # sorting we (temporarly) replace the own hosts ipv4 with a munged
+    # version, which matches the munging that is done later
+    # Why? We must ensure sure, that 127.0.0.1 always sorts first
+    # map-sort-map: Schwartz's transformation
+    # test 0099
+    my @temp = map  { $_->[1] }
+               sort { $a->[0] cmp $b->[0] }
+               #map  { [ (split)[0] =~ s/\Q$parm_ipv4/ip4.ip4.ip4.ip4/gr, $_ ] }  # this is too modern for 5.10.1
+               map  {
+                (my $k = (split)[0]) =~ s/\Q$parm_ipv4/ip4.ip4.ip4.ip4/g;
+                [ $k, $_ ]
+               }
+               do { local $/ = "\n  "; <$in> };
     foreach $item (@temp)
       {
       $item =~ s/^\s*(.*)\n(.*)\n?\s*$/$1\n$2/m;
-      print OUT "  $item\n";
+      print $out "  $item\n";
       }
     }
   else
     {
-    @temp = <IN>;
+    my @temp = <$in>;
     if ($which eq "callout")
       {
       @temp = sort {
@@ -2199,11 +2199,9 @@ if (/^dump\s+(\S+)/)
                    return $aa cmp $bb;
                    } @temp;
       }
-    print OUT @temp;
+    print $out @temp;
     }
-
-  close(IN);
-  close(OUT);
+  close($in); # close it explicitly, otherwise $? does not get set
   return 1;
   }
 
@@ -2546,9 +2544,24 @@ elsif (/^((?i:[A-Z\d_]+=\S+\s+)+)?(\d+)?\s*(sudo(?:\s+-u\s+(\w+))?\s+)?exim(_\S+
 
   if ($args =~ /\$msg/)
     {
-    my @listcmd  = ("$parm_cwd/eximdir/exim", '-bp',
+    my($queuespec);
+    if ($args =~ /-qG\w+/) { $queuespec = $&; }
+
+    my @listcmd;
+
+    if (defined $queuespec)
+      {
+      @listcmd  = ("$parm_cwd/eximdir/exim", '-bp',
+                  $queuespec,
+                   "-DEXIM_PATH=$parm_cwd/eximdir/exim",
+                   -C => "$parm_cwd/test-config");
+      }
+    else
+      {
+      @listcmd  = ("$parm_cwd/eximdir/exim", '-bp',
                    "-DEXIM_PATH=$parm_cwd/eximdir/exim",
                    -C => "$parm_cwd/test-config");
+      }
     print ">> Getting queue list from:\n>>    @listcmd\n" if $debug;
     # We need the message ids sorted in ascending order.
     # Message id is: <timestamp>-<pid>-<fractional-time>. On some systems (*BSD) the
@@ -3941,7 +3954,7 @@ if ($have_ipv4 && $parm_ipv4 ne "127.0.0.1")
       tests_exit(-1, "Failed  to open $parm_cwd/dnszones/db.ip4.$components[0]: $!");
     print OUT "$components[3].$components[2].$components[1]  PTR  $parm_hostname.\n\n";
     close(OUT);
-    } 
+    }
   else
     {
     open(OUT, ">$parm_cwd/dnszones/db.ip4.$components[0]") ||