Commit | Line | Data |
---|---|---|
1f187290 | 1 | package Exim::Runtest; |
87e93574 | 2 | use 5.010; |
1f187290 HSHR |
3 | use strict; |
4 | use warnings; | |
b369d470 | 5 | use IO::Socket::INET; |
fefe59d9 | 6 | use Cwd; |
1f187290 HSHR |
7 | use Carp; |
8 | ||
87e93574 | 9 | use parent 'Exporter'; |
fefe59d9 | 10 | our @EXPORT_OK = qw(mailgroup dynamic_socket exim_binary); |
87e93574 HSHR |
11 | our %EXPORT_TAGS = ( |
12 | all => \@EXPORT_OK, | |
13 | ); | |
14 | ||
1f187290 HSHR |
15 | use List::Util qw'shuffle'; |
16 | ||
10012250 HSHR |
17 | =head1 NAME |
18 | ||
19 | Exim::Runtest - helper functions for the runtest script | |
20 | ||
21 | =head1 SYNOPSIS | |
22 | ||
23 | use Exim::Runtest; | |
24 | my $foo = Exim::Runtest::foo('foo'); | |
25 | ||
26 | =head1 DESCRIPTION | |
27 | ||
28 | The B<Exim::Runtest> module provides some simple functions | |
29 | for the F<runtest> script. No functions are exported yet. | |
30 | ||
31 | =cut | |
1f187290 | 32 | |
1f187290 | 33 | sub mailgroup { |
b1227303 | 34 | my $group = shift // croak "Need a default group name."; |
1f187290 HSHR |
35 | |
36 | croak "Need a group *name*, not a numeric group id." | |
37 | if $group =~ /^\d+$/; | |
38 | ||
39 | return $group if getgrnam $group; | |
40 | ||
41 | my @groups; | |
42 | setgrent or die "setgrent: $!\n"; | |
43 | push @groups, $_ while defined($_ = getgrent); | |
44 | endgrent; | |
45 | return (shuffle @groups)[0]; | |
b369d470 HSHR |
46 | } |
47 | ||
48 | sub dynamic_socket { | |
49 | my $socket; | |
50 | for (my $port = 1024; $port < 65000; $port++) { | |
51 | $socket = IO::Socket::INET->new( | |
52 | LocalHost => '127.0.0.1', | |
53 | LocalPort => $port, | |
54 | Listen => 10, | |
55 | ReuseAddr => 1, | |
56 | ) and return $socket; | |
57 | } | |
58 | croak 'Can not allocate a free port.'; | |
59 | } | |
1f187290 | 60 | |
fefe59d9 HSHR |
61 | sub exim_binary { |
62 | ||
63 | # two simple cases, absolute path or relative path and executable | |
64 | return @_ if $_[0] =~ /^\//; | |
65 | return Cwd::abs_path(shift), @_ if -x $_[0]; | |
66 | ||
67 | # so we're still here, if the simple approach didn't help. | |
68 | ||
69 | # if there is '../exim-snapshot/<build-dir>/exim', use this | |
70 | # if there is '../exim4/<build-dir>/exim', use this | |
71 | # if there is '../exim-*.*/<build-dir>/exim', use the one with the highest version | |
72 | # 4.84 < 4.85RC1 < 4.85RC2 < 4.85 < 4.86RC1 < … < 4.86 | |
73 | # if there is '../src/<build-dir>', use this | |
74 | # | |
75 | ||
76 | my $prefix = '..'; # was intended for testing. | |
77 | ||
78 | # get a list of directories having the "scripts/{os,arch}-type" | |
79 | # scripts | |
80 | my @candidates = grep { -x "$_/scripts/os-type" and -x "$_/scripts/arch-type" } | |
81 | "$prefix/exim-snapshot", "$prefix/exim4", # highest priority | |
82 | (reverse sort { # list of exim-*.* directories | |
83 | # split version number from RC number | |
84 | my @a = ($a =~ /(\d+\.\d+)(?:RC(\d+))?/); | |
85 | my @b = ($b =~ /(\d+\.\d+)(?:RC(\d+))?/); | |
86 | # if the versions are not equal, we're fine, | |
87 | # but otherwise we've to compare the RC number, where an | |
88 | # empty RC number is better than a non-empty | |
89 | ($a[0] cmp $b[0]) || (defined $a[1] ? defined $b[1] ? $a[1] cmp $b[1] : -1 : 1) | |
90 | } glob "$prefix/exim-*.*"), | |
91 | "$prefix/src"; # the "normal" source | |
92 | ||
93 | # binaries should be found now depending on the os-type and | |
94 | # arch-type in the directories we got above | |
95 | my @binaries = grep { -x } | |
96 | map { ("$_/exim", "$_/exim4") } | |
97 | map { | |
98 | my $os = `$_/scripts/os-type`; | |
99 | my $arch = `$_/scripts/arch-type`; | |
100 | chomp($os, $arch); | |
101 | "$_/build-$os-$arch" . ($ENV{EXIM_BUILD_SUFFIX} ? ".$ENV{EXIM_BUILD_SUFFIX}" : ''); | |
102 | } @candidates; | |
103 | ||
104 | return $binaries[0], @_; | |
105 | } | |
106 | ||
107 | ||
1f187290 | 108 | 1; |
10012250 HSHR |
109 | |
110 | __END__ | |
111 | ||
112 | =head1 FUNCTIONS | |
113 | ||
114 | =over | |
115 | ||
116 | =item B<mailgroup>(I<$default>) | |
117 | ||
118 | Check if the mailgroup I<$default> exists. Return the checked | |
119 | group name or some other random but existing group. | |
120 | ||
121 | =item B<dynamic_socket>() | |
122 | ||
123 | Return a dynamically allocated listener socket in the range | |
124 | between 1024 and 65534; | |
125 | ||
fefe59d9 HSHR |
126 | =item ($binary, @argv) = B<exim_binary>(I<@argv>) |
127 | ||
128 | Find the Exim binary. Consider the first element of I<@argv> | |
129 | and remove it from I<@argv>, if it is an executable binary. | |
130 | Otherwise search the binary (while honouring C<EXIM_BUILD_SUFFIX>, | |
131 | C<../scripts/os-type> and C<../os-arch>) and return the | |
132 | the path to the binary and the unmodified I<@argv>. | |
133 | ||
10012250 HSHR |
134 | =back |
135 | ||
136 | =cut |