test/lib/Exim/Runtest.pm

   1 package Exim::Runtest;
   2 use 5.010;
   3 use strict;
   4 use warnings;
   5 use File::Basename;
   6 use IO::Socket::INET;
   7 use Cwd;
   8 use Carp;
   9
  10 use Exporter;
  11 our @ISA = qw(Exporter);
  12
  13 our @EXPORT_OK = qw(mailgroup dynamic_socket exim_binary flavour flavours);
  14 our %EXPORT_TAGS = (
  15     all => \@EXPORT_OK,
  16 );
  17
  18 use List::Util qw'shuffle';
  19
  20 =head1 NAME
  21
  22 Exim::Runtest - helper functions for the runtest script
  23
  24 =head1 SYNOPSIS
  25
  26  use Exim::Runtest;
  27  my $foo = Exim::Runtest::foo('foo');
  28
  29 =head1 DESCRIPTION
  30
  31 The B<Exim::Runtest> module provides some simple functions
  32 for the F<runtest> script. No functions are exported yet.
  33
  34 =cut
  35
  36 sub mailgroup {
  37     my $group = shift // croak "Need a default group name.";
  38
  39     croak "Need a group *name*, not a numeric group id."
  40         if $group =~ /^\d+$/;
  41
  42     return $group if getgrnam $group;
  43
  44     my @groups;
  45     setgrent or die "setgrent: $!\n";
  46     push @groups, $_ while defined($_ = getgrent);
  47     endgrent;
  48     return (shuffle @groups)[0];
  49 }
  50
  51 sub dynamic_socket {
  52     my $socket;
  53     for (my $port = 1024; $port < 65000; $port++) {
  54         $socket = IO::Socket::INET->new(
  55             LocalHost => '127.0.0.1',
  56             LocalPort => $port,
  57             Listen => 10,
  58             ReuseAddr => 1,
  59         ) and return $socket;
  60     }
  61     croak 'Can not allocate a free port.';
  62 }
  63
  64 sub exim_binary {
  65
  66     # two simple cases, absolute path or relative path and executable
  67     if (@_) {
  68         return @_ if $_[0] =~ /^\//;
  69         return Cwd::abs_path(shift), @_ if -x $_[0];
  70     }
  71
  72     # so we're still here, if the simple approach didn't help.
  73
  74     # if there is '../exim-snapshot/<build-dir>/exim', use this
  75     # if there is '../exim4/<build-dir>/exim', use this
  76     # if there is '../exim-*.*/<build-dir>/exim', use the one with the highest version
  77     #   4.84 < 4.85RC1 < 4.85RC2 < 4.85 < 4.86RC1 < … < 4.86
  78     # if there is '../src/<build-dir>', use this
  79     #
  80
  81     my $prefix = '..';  # was intended for testing.
  82
  83     # get a list of directories having the "scripts/{os,arch}-type"
  84     # scripts
  85     my @candidates = grep { -x "$_/scripts/os-type" and -x "$_/scripts/arch-type" }
  86         "$prefix/exim-snapshot", "$prefix/exim4", # highest priority
  87         (reverse sort {                           # list of exim-*.* directories
  88         # split version number from RC number
  89         my @a = ($a =~ /(\d+\.\d+)(?:RC(\d+))?/);
  90         my @b = ($b =~ /(\d+\.\d+)(?:RC(\d+))?/);
  91         # if the versions are not equal, we're fine,
  92         # but otherwise we've to compare the RC number, where an
  93         # empty RC number is better than a non-empty
  94         ($a[0] cmp $b[0]) || (defined $a[1] ? defined $b[1] ? $a[1] cmp $b[1] : -1 : 1)
  95         } glob "$prefix/exim-*.*"),
  96         "$prefix/src";                       # the "normal" source
  97
  98     # binaries should be found now depending on the os-type and
  99     # arch-type in the directories we got above
 100     my @binaries = grep { -x }
 101         map { ("$_/exim", "$_/exim4") }
 102         map {
 103             my $os = `$_/scripts/os-type`;
 104             my $arch = `$_/scripts/arch-type`;
 105             chomp($os, $arch);
 106             ($ENV{build} ? "$_/build-$ENV{build}" : ()),
 107             "$_/build-$os-$arch" . ($ENV{EXIM_BUILD_SUFFIX} ? ".$ENV{EXIM_BUILD_SUFFIX}" : '');
 108         } @candidates;
 109
 110     return $binaries[0], @_;
 111 }
 112
 113 sub flavour {
 114     my $etc = '/etc';
 115
 116     if (@_) {
 117         croak "do not pass a directory, it's for testing only"
 118             unless $ENV{HARNESS_ACTIVE};
 119         $etc = shift;
 120     }
 121
 122     if (open(my $f, '-|', 'openssl version')) {
 123         <$f> =~ /(1\.1\.1|3\.\d+\.\d+)/ && return "openssl_1_1_1";
 124     }
 125
 126     if (open(my $f, '<', "$etc/os-release")) {
 127         local $_ = join '', <$f>;
 128         my ($id) = /^ID="?(.*?)"?\s*$/m;
 129         my $version = /^VERSION_ID="?(.*?)"?\s*$/m ? $1 : '';
 130         return "$id$version";
 131     }
 132
 133     if (open(my $f, '<', "$etc/debian_version")) {
 134         chomp(local $_ = <$f>);
 135         $_ = int $_;
 136         return "debian$_";
 137     }
 138
 139     undef;
 140 }
 141
 142 sub flavours {
 143     my %h = map { /\.(\S+)$/, 1 }
 144             grep { !/\.orig$/ } glob('stdout/*.*'), glob('stderr/*.*'), glob('log/*.*');
 145     return sort keys %h;
 146 }
 147
 148 1;
 149
 150 __END__
 151
 152 =head1 FUNCTIONS
 153
 154 =over
 155
 156 =item B<mailgroup>(I<$default>)
 157
 158 Check if the mailgroup I<$default> exists. Return the checked
 159 group name or some other random but existing group.
 160
 161 =item B<dynamic_socket>()
 162
 163 Return a dynamically allocated listener socket in the range
 164 between 1024 and 65534;
 165
 166 =item ($binary, @argv) = B<exim_binary>(I<@argv>)
 167
 168 Find the Exim binary. Consider the first element of I<@argv>
 169 and remove it from I<@argv>, if it is an executable binary.
 170 Otherwise search the binary (while honouring C<EXIM_BUILD_SUFFIX>,
 171 C<../scripts/os-type> and C<../os-arch>) and return the
 172 the path to the binary and the unmodified I<@argv>.
 173
 174 =item B<flavour>()
 175
 176 Find a hint for the current flavour (Linux distro). It does so by checking
 177 typical files in the F</etc> directory.
 178
 179 =item B<flavours>()
 180
 181 Return a list of available flavours. It does so by scanning F<log/>, F<stdout/> and
 182 F<stderr/> for I<flavour> files (extensions after the numerical prefix.
 183
 184 =back
 185
 186 =cut