Testsuite: perl version oddity
[exim.git] / src / src / exim_msgdate.src
index e5c357bca4c024ebd7a71cf41bd7130083e2bd50..4efee04f8b22636659d20d3f6090377f53da1432 100755 (executable)
@@ -1,13 +1,13 @@
-#!PERL_COMMAND -WT
+#!PERL_COMMAND -T
+#
+# Copyright (c) The Exim Maintainers 2023
+# SPDX-License-Identifier: GPL-2.0-or-later
 #
 # Utility to convert an exim message-id to a human readable form
 #
 # https://bugs.exim.org/show_bug.cgi?id=2956
 # Written by Andrew C Aitchison
 #
-# Copyright (c) 2023 The Exim Maintainers 2023
-# SPDX-License-Identifier: GPL-2.0-or-later
-#
 # Portions taken from exicyclog.src, which is
 #   Copyright (c) University of Cambridge, 1995 - 2015
 #   See the file NOTICE for conditions of use and distribution.
 #
 # PROCESSED_FLAG
 
+# These match runtest
+use v5.10.1;
+use warnings;
+use if $^V >= v5.19.11, experimental => 'smartmatch';
+
 use strict;
 use File::Basename;
 use Getopt::Long;
@@ -48,28 +53,22 @@ if (defined $ENV{TZ}) {
 }
 
 my $localhost_number;  # An Exim config value
+my $nolocalhost_number;
 
 my $p_name    = basename $0;
-my $p_version = "20230203.0";
+my $p_version = "20230501.0";
 my $p_cp      = <<EOM;
  Copyright (c) 2023 The Exim Maintainers 2023
 
  Portions taken from exicyclog.src, which is
    Copyright (c) University of Cambridge, 1995 - 2015
  See the file NOTICE for conditions of use and distribution.
+ See the file NOTICE for conditions of use and distribution.
 EOM
 
 $ENV{PATH} = "/bin:/usr/bin:/usr/sbin";
 
 use POSIX qw(strftime);
 
-sub main::VERSION_MESSAGE()
-{
-    print basename($0), ": $0\n";
-    print "build: EXIM_RELEASE_VERSIONEXIM_VARIANT_VERSION\n";
-    print "perl(             runtime): $]\n";
-}
-
 my ($debug, $nodebug,
     $optbase, $optbase36, $optbase62,
     $optunix, $optgmt, $optlocal,
@@ -95,6 +94,9 @@ GetOptions (
     "base62" => \$optbase62,
 
     "localhost_number=s" => \$localhost_number,  # cf "local"
+    "nolocalhost_number" => \$nolocalhost_number,
+    "no-localhost_number" => \$nolocalhost_number,
+    "no_localhost_number" => \$nolocalhost_number,
 
     "unix" => \$optunix,
     "u" => \$optunix,
@@ -122,6 +124,12 @@ GetOptions (
             -noperldoc => system('perldoc -V 2>/dev/null 1>&2')
        );
     },
+    'version'  => sub {
+       print basename($0), ": $p_version $0\n";
+       print "exim build: EXIM_RELEASE_VERSIONEXIM_VARIANT_VERSION\n";
+       print "perl(runtime): $]\n";
+       exit 0;
+    },
 ) or pod2usage;
 # die("Error in command line arguments\n");
 
@@ -270,13 +278,27 @@ if ($debug) {
     } else {
         warn "localhost_number unset\n";
     }
+    if (defined $nolocalhost_number) {
+        warn "nolocalhost_number=$nolocalhost_number\n";
+    } else {
+        warn "nolocalhost_number unset\n";
+    }
 }
 
 if (defined $localhost_number) {
     if ($localhost_number eq "none") {
         $localhost_number = undef;
+        $nolocalhost_number = TRUE;
+    } else {
+       if ($nolocalhost_number) {
+           die "aborting: localhost_number and nolocalhost_number both set\n ";
+       }
+        $nolocalhost_number = FALSE;
     }
-} else {
+}
+
+unless (defined $nolocalhost_number) {
+    warn "Looking for config file\n" if $debug;
     my $config = get_configfilename();
     warn "Reading config $config to find localhost_number\n" if $debug;
 
@@ -296,6 +318,9 @@ if (defined $localhost_number) {
         warn "$config gives localhost_number $localhost_number\n"
             if $debug and defined $localhost_number;
     } else {
+       if ($debug) {
+           warn "cannot read config file $config\n";
+       }
         # This way we get the expanded value for localhost_number
         # directly from exim, but we have to guess which exim binary ...
         # On Debian and Ubuntu, /usr/sbin/exim is a link to exim4 so is OK.
@@ -315,10 +340,18 @@ if (defined $localhost_number) {
 }
 
 if (defined $localhost_number) {
-    die "localhost_number > 16\n"
-        if $localhost_number > 16;
-    die "localhost_number > 10\n"
-        if $localhost_number > 10 && ($base != 62);
+    if ($localhost_number =~ /\D/) {
+       die "localhost_number must be a number >=0\n";
+    } elsif ($localhost_number =~ /^\d*$/) {
+       die "localhost_number > 16\n"
+           if $localhost_number > 16;
+       die "localhost_number > 10\n"
+           if $localhost_number > 10 && ($base != 62);
+    } else {
+       warn "clearing localhost_number - was $localhost_number\n";
+       undef $localhost_number;
+       $nolocalhost_number=TRUE;
+    }
 }
 
 if ($debug) {
@@ -331,42 +364,44 @@ if ($debug) {
 
 sub unpack_time($$) {
     my ($seconds, $fractions) = @_;
-    # warn "encoded: seconds: $seconds fractions: $fractions\n";
+    #warn "encoded: seconds: $seconds fractions: $fractions\n";
+
+    my ($id_resolution, $lcl_hostnum, $new_format);
+
+    $new_format = 1 if (length $fractions) == 4;
+
     $seconds = decode62($seconds);
     $fractions = decode62($fractions) if $fractions;
-    my $id_resolution;
+
     if (defined $localhost_number && $localhost_number ne "none") {
         print "localhost_number $localhost_number\n" if $debug;
         if ($base != 62) {
             # MacOS/Darwin and Cygwin
-            $id_resolution = 100;
+            $id_resolution = defined($new_format) ? 4 : 10000;
         } else {
             # Standard UNIX etc.
-            $id_resolution = 200;
+            $id_resolution = defined($new_format) ? 2 : 5000;
         }
-        $fractions -= $localhost_number * $id_resolution;
+       my $frac_divisor = 1000000 / $id_resolution;
+       $lcl_hostnum = int($fractions / $frac_divisor);
+       warn "localhost $lcl_hostnum from message-id != given number $localhost_number"
+         if ($lcl_hostnum != $localhost_number);
+
+        $fractions -= $lcl_hostnum * $frac_divisor;
     } else {
         if ($base != 62) {
             # MacOS/Darwin and Cygwin
-            $id_resolution = 1000;
+            $id_resolution = defined($new_format) ? 2 : 1000;
         } else {
             # Standard UNIX etc.
-            $id_resolution = 2000;
+            $id_resolution = defined($new_format) ? 1 : 500;
         }
     }
-    while ($fractions > $id_resolution) {
-        $seconds++;
-        $fractions -= $id_resolution;
-    }
-    while ($fractions < -1e-7) {
-        $seconds--;
-        $fractions += $id_resolution;
-    }
-    # $seconds += $fractions / $id_resolution;
-
-    # warn "decoded: seconds: $seconds, fractions: $fractions/$id_resolution\n";
+    $fractions *= $id_resolution;
+    #warn "decoded: seconds: $seconds, fractions: $fractions";
+    ($fractions < 1000000) or die "bad microsecond count: $fractions\n";
 
-    return ($seconds, $fractions / $id_resolution);
+    return ($seconds, $fractions);
 } # sub unpack_time($$)
 
 sub print_time($$$$$$)
@@ -387,7 +422,7 @@ sub print_time($$$$$$)
     my $decimalstring = "";
     # if ($decimal>0)
     {
-        $decimalstring = sprintf(".%6.6d", 1000000*$decimal);
+        $decimalstring = sprintf(".%6.6d", $decimal);
     }
     my $secondsstring;
     unless (defined $unix or defined $zulu or defined $localtm) {
@@ -414,17 +449,31 @@ foreach my $msgid (@ARGV) {
     my ($seconds, $pid, $fractions, $decimal);
 
     if ($msgid =~
-        /(^|[\s<])E?([a-zA-Z0-9]{6})-([a-zA-Z0-9]{6})-([a-zA-Z0-9]{2})/)
+        /(?:(?:^|[\s<])E?
+           (?<seconds>[a-zA-Z0-9]{6})                  # new format
+           -(?<pid>[a-zA-Z0-9]{11})
+           -(?<fractions>[a-zA-Z0-9]{4})
+         |
+           (?<seconds>[a-zA-Z0-9]{6})                  # old format
+           -(?<pid>[a-zA-Z0-9]{6})
+           -(?<fractions>[a-zA-Z0-9]{2})
+        )/x)
     {
+print "saw full mesgid\n" if $debug;
+
         # Should take either the log form of timestamp,
         # the Message-ID: header form with the leading 'E', ...
-        ($seconds, $pid, $fractions) = ($2, $3, $4);
-        ($seconds, $decimal) = unpack_time($seconds, $fractions);
-        $pid = decode62($pid);
-        #warn "$seconds, $pid, $fractions\n";
-    } elsif ($msgid =~ /(^|[^0-9A-Za-z])([a-zA-Z0-9]{6})$/) {
+        ($seconds, $decimal) = unpack_time($+{seconds}, $+{fractions});
+        $pid = decode62($+{pid});
+        #warn "$seconds, $pid, $+{fractions}\n";
+    } elsif ($msgid =~ /(?:^|[^0-9A-Za-z])
+                       (?<seconds>
+                       [a-zA-Z0-9]{11}                 # new format
+                       |[a-zA-Z0-9]{6}                 # old format
+                       )$/x) {
         # ... or just the timecode section before the first '-'
-        ($seconds, $pid, $decimal) = (decode62($2), undef, 0);
+print "saw just timecode\n" if $debug;
+        ($seconds, $pid, $decimal) = (decode62($+{seconds}), undef, 0);
     } else {
         warn "$msgid not parsed\n";
         next;