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