debian experimental exim-daemon-heavy config
[exim.git] / test / lib / Exim / Runtest.pm
... / ...
CommitLineData
1package Exim::Runtest;
2use 5.010;
3use strict;
4use warnings;
5use File::Basename;
6use IO::Socket::INET;
7use Cwd;
8use Carp;
9
10use Exporter;
11our @ISA = qw(Exporter);
12
13our @EXPORT_OK = qw(mailgroup dynamic_socket exim_binary flavour flavours);
14our %EXPORT_TAGS = (
15 all => \@EXPORT_OK,
16);
17
18use List::Util qw'shuffle';
19
20=head1 NAME
21
22Exim::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
31The B<Exim::Runtest> module provides some simple functions
32for the F<runtest> script. No functions are exported yet.
33
34=cut
35
36sub 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
51sub 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
64sub 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
113sub 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
142sub flavours {
143 my %h = map { /\.(\S+)$/, 1 }
144 grep { !/\.orig$/ } glob('stdout/*.*'), glob('stderr/*.*'), glob('log/*.*');
145 return sort keys %h;
146}
147
1481;
149
150__END__
151
152=head1 FUNCTIONS
153
154=over
155
156=item B<mailgroup>(I<$default>)
157
158Check if the mailgroup I<$default> exists. Return the checked
159group name or some other random but existing group.
160
161=item B<dynamic_socket>()
162
163Return a dynamically allocated listener socket in the range
164between 1024 and 65534;
165
166=item ($binary, @argv) = B<exim_binary>(I<@argv>)
167
168Find the Exim binary. Consider the first element of I<@argv>
169and remove it from I<@argv>, if it is an executable binary.
170Otherwise search the binary (while honouring C<EXIM_BUILD_SUFFIX>,
171C<../scripts/os-type> and C<../os-arch>) and return the
172the path to the binary and the unmodified I<@argv>.
173
174=item B<flavour>()
175
176Find a hint for the current flavour (Linux distro). It does so by checking
177typical files in the F</etc> directory.
178
179=item B<flavours>()
180
181Return a list of available flavours. It does so by scanning F<log/>, F<stdout/> and
182F<stderr/> for I<flavour> files (extensions after the numerical prefix.
183
184=back
185
186=cut