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 | ||
87e93574 | 10 | use parent 'Exporter'; |
6336058c | 11 | our @EXPORT_OK = qw(mailgroup dynamic_socket exim_binary flavour flavours); |
87e93574 HSHR |
12 | our %EXPORT_TAGS = ( |
13 | all => \@EXPORT_OK, | |
14 | ); | |
15 | ||
1f187290 HSHR |
16 | use List::Util qw'shuffle'; |
17 | ||
10012250 HSHR |
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 | |
1f187290 | 33 | |
1f187290 | 34 | sub mailgroup { |
b1227303 | 35 | my $group = shift // croak "Need a default group name."; |
1f187290 HSHR |
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]; | |
b369d470 HSHR |
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 | } | |
1f187290 | 61 | |
fefe59d9 HSHR |
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 | ||
6336058c HSHR |
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 | } | |
fefe59d9 | 138 | |
1f187290 | 139 | 1; |
10012250 HSHR |
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 | ||
fefe59d9 HSHR |
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 | ||
6336058c HSHR |
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 | ||
10012250 HSHR |
175 | =back |
176 | ||
177 | =cut |