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