Commit | Line | Data |
---|---|---|
1f187290 | 1 | package Exim::Runtest; |
87e93574 | 2 | use 5.010; |
1f187290 HSHR |
3 | use strict; |
4 | use warnings; | |
6336058c | 5 | use File::Basename; |
b369d470 | 6 | use IO::Socket::INET; |
fefe59d9 | 7 | use Cwd; |
1f187290 HSHR |
8 | use Carp; |
9 | ||
d54f9577 HSHR |
10 | use Exporter; |
11 | our @ISA = qw(Exporter); | |
12 | ||
6336058c | 13 | our @EXPORT_OK = qw(mailgroup dynamic_socket exim_binary flavour flavours); |
87e93574 HSHR |
14 | our %EXPORT_TAGS = ( |
15 | all => \@EXPORT_OK, | |
16 | ); | |
17 | ||
1f187290 HSHR |
18 | use List::Util qw'shuffle'; |
19 | ||
10012250 HSHR |
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 | |
1f187290 | 35 | |
1f187290 | 36 | sub mailgroup { |
b1227303 | 37 | my $group = shift // croak "Need a default group name."; |
1f187290 HSHR |
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]; | |
b369d470 HSHR |
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 | } | |
1f187290 | 63 | |
fefe59d9 HSHR |
64 | sub exim_binary { |
65 | ||
66 | # two simple cases, absolute path or relative path and executable | |
c9eab729 HSHR |
67 | if (@_) { |
68 | return @_ if $_[0] =~ /^\//; | |
69 | return Cwd::abs_path(shift), @_ if -x $_[0]; | |
70 | } | |
fefe59d9 HSHR |
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); | |
7495ef81 | 106 | ($ENV{build} ? "$_/build-$ENV{build}" : ()), |
fefe59d9 HSHR |
107 | "$_/build-$os-$arch" . ($ENV{EXIM_BUILD_SUFFIX} ? ".$ENV{EXIM_BUILD_SUFFIX}" : ''); |
108 | } @candidates; | |
109 | ||
110 | return $binaries[0], @_; | |
111 | } | |
112 | ||
6336058c HSHR |
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 | ||
fd3cf789 JH |
122 | if (open(my $f, '-|', 'openssl version')) { |
123 | <$f> =~ /1.1.1/ && return "openssl_1_1_1"; | |
124 | } | |
125 | ||
6336058c HSHR |
126 | if (open(my $f, '<', "$etc/os-release")) { |
127 | local $_ = join '', <$f>; | |
128 | my ($id) = /^ID="?(.*?)"?\s*$/m; | |
9214c762 | 129 | my $version = /^VERSION_ID="?(.*?)"?\s*$/m ? $1 : ''; |
6336058c HSHR |
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 } | |
fd3cf789 | 144 | grep { !/\.orig$/ } glob('stdout/*.*'), glob('stderr/*.*'), glob('log/*.*'); |
6336058c HSHR |
145 | return sort keys %h; |
146 | } | |
fefe59d9 | 147 | |
1f187290 | 148 | 1; |
10012250 HSHR |
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 | ||
fefe59d9 HSHR |
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 | ||
6336058c HSHR |
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 | ||
fd3cf789 | 181 | Return a list of available flavours. It does so by scanning F<log/>, F<stdout/> and |
6336058c HSHR |
182 | F<stderr/> for I<flavour> files (extensions after the numerical prefix. |
183 | ||
10012250 HSHR |
184 | =back |
185 | ||
186 | =cut |