Lookups: fix $local_part_data for a match on a filename list element. Bug 2691
[users/heiko/exim.git] / 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/ && 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