line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::Smoke::Util; |
2
|
39
|
|
|
39
|
|
1211130
|
use strict; |
|
39
|
|
|
|
|
306
|
|
|
39
|
|
|
|
|
1796
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
our $VERSION = '0.58'; |
5
|
|
|
|
|
|
|
|
6
|
39
|
|
|
39
|
|
226
|
use Exporter 'import'; |
|
39
|
|
|
|
|
88
|
|
|
39
|
|
|
|
|
3273
|
|
7
|
|
|
|
|
|
|
our @EXPORT = qw( |
8
|
|
|
|
|
|
|
&Configure_win32 |
9
|
|
|
|
|
|
|
&get_cfg_filename &get_config |
10
|
|
|
|
|
|
|
&get_patch |
11
|
|
|
|
|
|
|
&skip_config &skip_filter |
12
|
|
|
|
|
|
|
); |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
15
|
|
|
|
|
|
|
&grepccmsg &grepnonfatal &get_local_patches &set_local_patch |
16
|
|
|
|
|
|
|
&get_ncpu &get_smoked_Config &parse_report_Config |
17
|
|
|
|
|
|
|
&get_regen_headers &run_regen_headers |
18
|
|
|
|
|
|
|
&whereis &clean_filename &read_logfile |
19
|
|
|
|
|
|
|
&calc_timeout &time_in_hhmm |
20
|
|
|
|
|
|
|
&do_pod2usage |
21
|
|
|
|
|
|
|
&set_vms_rooted_logical |
22
|
|
|
|
|
|
|
); |
23
|
|
|
|
|
|
|
|
24
|
39
|
|
|
39
|
|
19442
|
use Text::ParseWords; |
|
39
|
|
|
|
|
53598
|
|
|
39
|
|
|
|
|
2602
|
|
25
|
39
|
|
|
39
|
|
11145
|
use File::Spec::Functions; |
|
39
|
|
|
|
|
21570
|
|
|
39
|
|
|
|
|
3106
|
|
26
|
39
|
|
|
39
|
|
19646
|
use Encode qw ( decode ); |
|
39
|
|
|
|
|
568412
|
|
|
39
|
|
|
|
|
2801
|
|
27
|
39
|
|
|
39
|
|
284
|
use File::Find; |
|
39
|
|
|
|
|
93
|
|
|
39
|
|
|
|
|
2839
|
|
28
|
39
|
|
|
39
|
|
297
|
use Cwd; |
|
39
|
|
|
|
|
102
|
|
|
39
|
|
|
|
|
2496
|
|
29
|
39
|
|
|
39
|
|
13810
|
use Test::Smoke::LogMixin; |
|
39
|
|
|
|
|
112
|
|
|
39
|
|
|
|
|
372817
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
our $NOCASE = $^O eq 'VMS'; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
=head1 NAME |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
Test::Smoke::Util - Take out some of the functions of the smoke suite. |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=head1 FUNCTIONS |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
I've taken out some of the general stuff and put it here. |
40
|
|
|
|
|
|
|
Now I can write some tests! |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=head2 Configure_win32( $command[, $win32_maker[, @args]] ) |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
C alters the settings of the makefile for MSWin32. |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
C<$command> is in the form of './Configure -des -Dusedevel ...' |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
C<$win32_maker> should either be C or C, the default |
49
|
|
|
|
|
|
|
is C. |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
C<@args> is a list of C<< option=value >> pairs that will (eventually) |
52
|
|
|
|
|
|
|
be passed to L. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
PLEASE read README.win32 and study the comments in the makefile. |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
It supports these options: |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=over 4 |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
=item * B<-Duseperlio> |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
set USE_PERLIO = define (default) [should be depricated] |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=item * B<-Dusethreads> |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
set USE_ITHREADS = define (also sets USE_MULTI and USE_IMP_SYS) |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=item * B<-Duseithreads> |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
set USE_ITHREADS = define (also sets USE_MULTI and USE_IMP_SYS) |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=item * B<-Dusemultiplicity> |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
sets USE_MULTI = define (also sets USE_ITHREADS and USE_IMP_SYS) |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=item * B<-Duseimpsys> |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sets USE_IMP_SYS = define (also sets USE_ITHREADS and USE_MULTI) |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
=item * B<-Uusethreads> or B<-Uuseithreads> |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
unset C, C and C |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
=item * B<-Dusemymalloc> |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
set C |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
=item * B<-Duselargefiles> |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
set C |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
=item * B<-Duse64bint> |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
set C (always for win64, needed for -UWIN64) |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=item * B<-Duselongdouble> |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
set C (GCC only) |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=item * B<-Dusequadmath> |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
set both C and C (GCC only) |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
=item * B<-Dusesitecustomize> |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
set C |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=item * B<-Udefault_inc_excludes_dot> |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
unsets C<# DEFAULT_INC_EXCLUDES_DOT := define> (comments out the line) |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
=item * B<-Dbccold> |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
set BCCOLD = define (this is for bcc32 <= 5.4) |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
=item * B<-Dgcc_v3_2> |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
set USE_GCC_V3_2 = define (this is for gcc >= 3.2) |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=item * B<-DDEBUGGING> |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sets CFG = Debug |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=item * B<-DINST_DRV=...> |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sets INST_DRV to a new value (default is "c:") |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=item * B<-DINST_TOP=...> |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sets INST_DRV to a new value (default is "$(INST_DRV)\perl"), this is |
131
|
|
|
|
|
|
|
where perl will be installed when C<< [ng]make install >> is run. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
=item * B<-DINST_VER=...> |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sets INST_VER to a new value (default is forced not set), this is also used |
136
|
|
|
|
|
|
|
as part of the installation path to get a more unixy installation. |
137
|
|
|
|
|
|
|
Without C and C you get an ActiveState like |
138
|
|
|
|
|
|
|
installation. |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=item * B<-DINST_ARCH=...> |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sets INST_ARCH to a new value (default is forced not set), this is also used |
143
|
|
|
|
|
|
|
as part of the installation path to get a more unixy installation. |
144
|
|
|
|
|
|
|
Without C and C you get an ActiveState like |
145
|
|
|
|
|
|
|
installation. |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=item * B<-DCCHOME=...> |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
Set the base directory for the C compiler. |
150
|
|
|
|
|
|
|
B<$(CCHOME)\bin> still needs to be in the path! |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
=item * B<-DIS_WIN95> |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sets IS_WIN95 to 'define' to indicate this is Win9[58] |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=item * B<-DCRYPT_SRC=...> |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
The file to use as source for des_fcrypt() |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=item * B<-DCRYPT_LIB=...> |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
The library to use for des_fcrypt() |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
=item * B<-Dcf_email=...> |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
Set the cf_email option (Config.pm) |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
=item * B<-Accflags=...> |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
Adds the option to BUILDOPT. This is implemented differently for |
171
|
|
|
|
|
|
|
B and B. |
172
|
|
|
|
|
|
|
Returns the name of the outputfile. |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
=back |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=cut |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
my %win32_makefile_map = ( |
179
|
|
|
|
|
|
|
nmake => "Makefile", |
180
|
|
|
|
|
|
|
gmake => "GNUmakefile", |
181
|
|
|
|
|
|
|
); |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub Configure_win32 { |
184
|
28
|
|
|
28
|
1
|
79046
|
my($command, $win32_maker, @args ) = @_; |
185
|
28
|
|
50
|
|
|
80
|
$win32_maker ||= 'nmake'; $win32_maker = lc $win32_maker; |
|
28
|
|
|
|
|
68
|
|
186
|
28
|
|
|
|
|
60
|
my $is_nmake = $win32_maker eq 'nmake'; |
187
|
28
|
|
|
|
|
47
|
my $is_gmake = $win32_maker eq 'gmake'; |
188
|
|
|
|
|
|
|
|
189
|
28
|
|
|
|
|
43
|
local $_; |
190
|
28
|
|
|
|
|
482
|
my %opt_map = ( |
191
|
|
|
|
|
|
|
"-Dusethreads" => "USE_ITHREADS", |
192
|
|
|
|
|
|
|
"-Duseithreads" => "USE_ITHREADS", |
193
|
|
|
|
|
|
|
"-Duseperlio" => "USE_PERLIO", |
194
|
|
|
|
|
|
|
"-Dusemultiplicity" => "USE_MULTI", |
195
|
|
|
|
|
|
|
"-Duseimpsys" => "USE_IMP_SYS", |
196
|
|
|
|
|
|
|
"-Uuseimpsys" => "USE_IMP_SYS", |
197
|
|
|
|
|
|
|
"-Dusemymalloc" => "PERL_MALLOC", |
198
|
|
|
|
|
|
|
"-Duselargefiles" => "USE_LARGE_FILES", |
199
|
|
|
|
|
|
|
"-Duse64bitint" => "USE_64_BIT_INT", |
200
|
|
|
|
|
|
|
"-Duselongdouble" => "USE_LONG_DOUBLE", |
201
|
|
|
|
|
|
|
"-Dusequadmath" => "USE_QUADMATH", |
202
|
|
|
|
|
|
|
"-Dusesitecustomize" => "USE_SITECUST", |
203
|
|
|
|
|
|
|
"-Uuseshrplib" => "BUILD_STATIC", |
204
|
|
|
|
|
|
|
"-Udefault_inc_excludes_dot" => "DEFAULT_INC_EXCLUDES_DOT", |
205
|
|
|
|
|
|
|
"-UWIN64" => "WIN64", |
206
|
|
|
|
|
|
|
"-Uusethreads" => "USE_ITHREADS", |
207
|
|
|
|
|
|
|
"-Uuseithreads" => "USE_ITHREADS", |
208
|
|
|
|
|
|
|
"-UUSE_MINGW_ANSI_STDIO" => "USE_MINGW_ANSI_STDIO", |
209
|
|
|
|
|
|
|
"-DDEBUGGING" => "USE_DEBUGGING", |
210
|
|
|
|
|
|
|
"-DINST_DRV" => "INST_DRV", |
211
|
|
|
|
|
|
|
"-DINST_TOP" => "INST_TOP", |
212
|
|
|
|
|
|
|
"-DINST_VER" => "INST_VER", |
213
|
|
|
|
|
|
|
"-DINST_ARCH" => "INST_ARCH", |
214
|
|
|
|
|
|
|
"-Dcf_email" => "EMAIL", |
215
|
|
|
|
|
|
|
"-DCCTYPE" => "CCTYPE", |
216
|
|
|
|
|
|
|
"-Dgcc_v3_2" => "USE_GCC_V3_2", |
217
|
|
|
|
|
|
|
"-DGCC_4XX" => "GCC_4XX", |
218
|
|
|
|
|
|
|
"-DGCCWRAPV" => "GCCWRAPV", |
219
|
|
|
|
|
|
|
"-DGCCHELPERDLL" => "GCCHELPERDLL", |
220
|
|
|
|
|
|
|
"-Dbccold" => "BCCOLD", |
221
|
|
|
|
|
|
|
"-DCCHOME" => "CCHOME", |
222
|
|
|
|
|
|
|
"-DIS_WIN95" => "IS_WIN95", |
223
|
|
|
|
|
|
|
"-DCRYPT_SRC" => "CRYPT_SRC", |
224
|
|
|
|
|
|
|
"-DCRYPT_LIB" => "CRYPT_LIB", |
225
|
|
|
|
|
|
|
"-DEXTRALIBDIRS" => "EXTRALIBDIRS", |
226
|
|
|
|
|
|
|
); |
227
|
|
|
|
|
|
|
# %opts hash-values: |
228
|
|
|
|
|
|
|
# undef => leave option as-is when no override (makefile default) |
229
|
|
|
|
|
|
|
# 0 => disable option when no override (forced default) |
230
|
|
|
|
|
|
|
# (true) => enable option when no override (change value, unless |
231
|
|
|
|
|
|
|
# $key =~ /^(?:PERL|USE)_/) (forced default) |
232
|
28
|
|
|
|
|
362
|
my %opts = ( |
233
|
|
|
|
|
|
|
USE_MULTI => 1, |
234
|
|
|
|
|
|
|
USE_ITHREADS => 1, |
235
|
|
|
|
|
|
|
USE_IMP_SYS => 1, |
236
|
|
|
|
|
|
|
USE_PERLIO => 1, |
237
|
|
|
|
|
|
|
USE_LARGE_FILES => 0, # default define |
238
|
|
|
|
|
|
|
PERL_MALLOC => 0, |
239
|
|
|
|
|
|
|
BUILD_STATIC => 0, |
240
|
|
|
|
|
|
|
USE_64_BIT_INT => 0, |
241
|
|
|
|
|
|
|
USE_LONG_DOUBLE => 0, |
242
|
|
|
|
|
|
|
USE_QUADMATH => 0, |
243
|
|
|
|
|
|
|
I_QUADMATH => 0, |
244
|
|
|
|
|
|
|
WIN64 => 1, |
245
|
|
|
|
|
|
|
USE_SITECUST => 0, |
246
|
|
|
|
|
|
|
DEFAULT_INC_EXCLUDES_DOT => 1, |
247
|
|
|
|
|
|
|
USE_MINGW_ANSI_STDIO => 1, |
248
|
|
|
|
|
|
|
USE_DEBUGGING => 0, |
249
|
|
|
|
|
|
|
INST_DRV => undef, |
250
|
|
|
|
|
|
|
INST_TOP => undef, |
251
|
|
|
|
|
|
|
INST_VER => '', |
252
|
|
|
|
|
|
|
INST_ARCH => '', |
253
|
|
|
|
|
|
|
EMAIL => undef, # used to be $smoker, |
254
|
|
|
|
|
|
|
CCTYPE => undef, # used to be $win32_cctype, |
255
|
|
|
|
|
|
|
USE_GCC_V3_2 => 0, |
256
|
|
|
|
|
|
|
GCC_4XX => 0, |
257
|
|
|
|
|
|
|
GCCWRAPV => 0, |
258
|
|
|
|
|
|
|
GCCHELPERDLL => undef, |
259
|
|
|
|
|
|
|
BCCOLD => 0, |
260
|
|
|
|
|
|
|
CCHOME => undef, |
261
|
|
|
|
|
|
|
IS_WIN95 => 0, |
262
|
|
|
|
|
|
|
CRYPT_SRC => undef, |
263
|
|
|
|
|
|
|
CRYPT_LIB => undef, |
264
|
|
|
|
|
|
|
EXTRALIBDIRS => undef, |
265
|
|
|
|
|
|
|
); |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
# $undef_re: regex for options that should be UNcommented for -Uxxx |
268
|
28
|
|
|
|
|
129
|
my $undef_re = qr/WIN64/; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# $def_re: regex for options that should be UNcommented for -Dxxx |
271
|
28
|
|
|
|
|
72
|
my $def_re = qr/((?:(?:DEFAULT|PERL|USE|IS|GCC|I)_\w+)|BCCOLD|GCCWRAPV)/; |
272
|
|
|
|
|
|
|
|
273
|
28
|
|
|
|
|
1454
|
my @w32_opts = grep ! /^$def_re/, keys %opts; |
274
|
28
|
|
|
|
|
184
|
my $config_args = join " ", |
275
|
|
|
|
|
|
|
grep /^-[DU][a-z_]+/, quotewords( '\s+', 1, $command ); |
276
|
28
|
|
|
|
|
3999
|
push @args, "config_args=$config_args"; |
277
|
|
|
|
|
|
|
|
278
|
28
|
|
|
|
|
55
|
my @buildopt; |
279
|
28
|
50
|
|
|
|
149
|
$command =~ m{^\s*\./Configure\s+(.*)} or die "unable to parse command"; |
280
|
28
|
|
|
|
|
73
|
my $cmdln = $1; |
281
|
28
|
|
|
|
|
75
|
foreach ( quotewords( '\s+', 1, $cmdln ) ) { |
282
|
72
|
100
|
|
|
|
2642
|
m/^-[des]{1,3}$/ and next; |
283
|
64
|
100
|
|
|
|
140
|
m/^-Dusedevel$/ and next; |
284
|
56
|
100
|
|
|
|
124
|
if ( /^-Accflags=(['"]?)(.+)\1/ ) { #emacs' syntaxhighlite |
285
|
6
|
|
|
|
|
20
|
push @buildopt, $2; |
286
|
6
|
|
|
|
|
15
|
next; |
287
|
|
|
|
|
|
|
} |
288
|
50
|
|
|
|
|
199
|
my( $option, $value ) = /^(-[DU]\w+)(?:=(.+))?$/; |
289
|
50
|
50
|
|
|
|
128
|
die "invalid option '$_'" unless exists $opt_map{$option}; |
290
|
50
|
100
|
|
|
|
122
|
$opts{$opt_map{$option}} = $value ? $value : 1; |
291
|
50
|
100
|
|
|
|
151
|
$option =~ /^-U/ and $opts{$opt_map{$option}} = 0; |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# Handle some switches that impact more make-vars |
295
|
28
|
100
|
|
|
|
113
|
if ( $cmdln =~ /-Uusei?threads\b/ ) { |
296
|
2
|
|
|
|
|
17
|
$opts{USE_MULTI} = $opts{USE_ITHREADS} = $opts{USE_IMP_SYS} = 0; |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
} |
299
|
28
|
50
|
|
|
|
69
|
if ( $cmdln =~ /-Dusequadmath\b/ ) { |
300
|
0
|
|
|
|
|
0
|
$opts{USE_QUADMATH} = $opts{I_QUADMATH} = 1; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
# If you set one, we do all, so you can have fork() |
303
|
|
|
|
|
|
|
# unless you set -Uuseimpsys |
304
|
28
|
100
|
|
|
|
73
|
if ( $cmdln !~ /-Uuseimpsys\b/ ) { |
305
|
26
|
50
|
66
|
|
|
78
|
if ( $opts{USE_MULTI} || $opts{USE_ITHREADS} || $opts{USE_IMP_SYS} ) { |
|
|
|
33
|
|
|
|
|
306
|
24
|
|
|
|
|
54
|
$opts{USE_MULTI} = $opts{USE_ITHREADS} = $opts{USE_IMP_SYS} = 1; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
else { |
310
|
2
|
50
|
33
|
|
|
28
|
if ( $opts{USE_MULTI} || $opts{USE_ITHREADS} ) { |
311
|
2
|
|
|
|
|
9
|
$opts{USE_MULTI} = $opts{USE_ITHREADS} = 1; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# If you -Dgcc_v3_2 you 'll *want* CCTYPE = GCC |
316
|
28
|
50
|
|
|
|
61
|
$opts{CCTYPE} = "GCC" if $opts{USE_GCC_V3_2}; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# If you -DGCC_4XX you 'll *want* CCTYPE = GCC |
319
|
28
|
50
|
|
|
|
56
|
$opts{CCTYPE} = "GCC" if $opts{GCC_4XX}; |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
# If you -Dbccold you 'll *want* CCTYPE = BORLAND |
322
|
28
|
50
|
|
|
|
49
|
$opts{CCTYPE} = "BORLAND" if $opts{BCCOLD}; |
323
|
|
|
|
|
|
|
|
324
|
28
|
|
|
|
|
2835
|
printf "* %-25s = %s\n", $_, $opts{$_} for grep $opts{$_}, sort keys %opts; |
325
|
|
|
|
|
|
|
|
326
|
28
|
|
|
|
|
185
|
local (*ORG, *NEW); |
327
|
28
|
50
|
|
|
|
101
|
my $maker = $win32_makefile_map{ $win32_maker } |
328
|
|
|
|
|
|
|
or die "no make file for $win32_maker"; |
329
|
28
|
|
|
|
|
59
|
my $in = "win32/$maker"; |
330
|
28
|
|
|
|
|
43
|
my $out = "win32/smoke.mk"; |
331
|
|
|
|
|
|
|
|
332
|
28
|
50
|
|
|
|
1120
|
open ORG, "<:crlf", $in or die "unable to open '$in': $!"; |
333
|
28
|
50
|
|
|
|
1640
|
open NEW, ">:crlf", $out or die "unable to open '$out': $!"; |
334
|
28
|
|
|
|
|
97
|
my $donot_change = 0; |
335
|
28
|
|
|
|
|
697
|
while () { |
336
|
2352
|
100
|
|
|
|
3909
|
if ( $donot_change ) { |
337
|
|
|
|
|
|
|
# need to help the Win95 build |
338
|
532
|
100
|
|
|
|
997
|
if (m/^\s*CFG_VARS\s*=/) { |
339
|
28
|
50
|
66
|
|
|
158
|
my( $extra_char, $quote ) = ($is_nmake || $is_gmake) |
340
|
|
|
|
|
|
|
? ( "\t", '"' ) : ("~", "" ); |
341
|
28
|
|
|
|
|
260
|
$_ .= join "", map "\t\t$quote$_$quote\t${extra_char}\t\\\n", |
342
|
|
|
|
|
|
|
grep /\w+=/, @args; |
343
|
|
|
|
|
|
|
} |
344
|
532
|
|
|
|
|
779
|
print NEW $_; |
345
|
532
|
|
|
|
|
1483
|
next; |
346
|
|
|
|
|
|
|
} else { |
347
|
1820
|
100
|
|
|
|
3862
|
if ( $donot_change = /^#+ CHANGE THESE ONLY IF YOU MUST #+/ ) { |
348
|
|
|
|
|
|
|
# We will now insert the BULDOPT lines |
349
|
28
|
100
|
|
|
|
102
|
my $bo_tmpl = $win32_maker eq 'nmake' |
350
|
|
|
|
|
|
|
? "BUILDOPT\t= \$(BUILDOPT) %s" : "BUILDOPT\t+= %s"; |
351
|
28
|
|
|
|
|
82
|
my $buildopt = join "\n", |
352
|
|
|
|
|
|
|
map sprintf( $bo_tmpl, $_ ) => @buildopt; |
353
|
28
|
100
|
|
|
|
72
|
$buildopt and $_ = "$buildopt\n$_\n" |
354
|
|
|
|
|
|
|
}; |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# Only change config stuff _above_ that line! |
358
|
1820
|
100
|
|
|
|
9712
|
if ( m/^\s*#?\s*$def_re(\s*[\*:]?=\s*define)$/ ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
359
|
266
|
100
|
|
|
|
1000
|
$_ = ($opts{$1} ? "" : "#") . $1 . $2 . "\n"; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
elsif (m/\s*#?\s*($undef_re)(\s*[*:]?=\s*undef)$/) { |
362
|
28
|
100
|
|
|
|
139
|
$_ = ($opts{$1} ? "#" : "") . "$1$2\n"; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
elsif (m/^\s*#?\s*(CFG\s*[*:]?=\s*Debug)$/) { |
365
|
28
|
50
|
|
|
|
111
|
$_ = ($opts{USE_DEBUGGING} ? "" : "#") . $1 . "\n"; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
elsif (m/^\s*#?\s*(BUILD_STATIC)\s*([*:]?=)\s*(.*)$/) { |
368
|
28
|
|
|
|
|
108
|
my( $macro, $op, $mval ) = ( $1, $2, $3); |
369
|
28
|
100
|
|
|
|
78
|
if ( $config_args =~ /-([UD])useshrplib\b/ ) { |
370
|
2
|
50
|
|
|
|
22
|
$_ = ( $1 eq 'D' ? "#" : "" ) . "$macro $op $mval\n"; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
else { |
374
|
1470
|
|
|
|
|
5685
|
foreach my $cfg_var ( grep defined $opts{ $_ }, @w32_opts ) { |
375
|
6210
|
100
|
|
|
|
131389
|
if ( m/^\s*#?\s*($cfg_var\s*(\*|:)?=)\s*(.*)$/ ) { |
376
|
72
|
|
|
|
|
267
|
my ($name, $val) = ($1, $2); |
377
|
72
|
100
|
100
|
|
|
328
|
next if $_ =~ /^#/ and !$opts{ $cfg_var }; |
378
|
46
|
100
|
|
|
|
144
|
$_ = $opts{ $cfg_var } ? |
379
|
|
|
|
|
|
|
"$name $opts{ $cfg_var }\n": |
380
|
|
|
|
|
|
|
"#$name $val\n"; |
381
|
46
|
|
|
|
|
96
|
last; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
} |
385
|
1820
|
|
|
|
|
9637
|
print NEW $_; |
386
|
|
|
|
|
|
|
} |
387
|
28
|
|
|
|
|
324
|
close ORG; |
388
|
28
|
|
|
|
|
1610
|
close NEW; |
389
|
28
|
|
|
|
|
610
|
return $out; |
390
|
|
|
|
|
|
|
} # Configure_win32 |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
=head2 set_vms_rooted_logical( $logical, $dir ) |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
This will set a VMS rooted logical like: |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
define/translation=concealed $logical $dir |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
=cut |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
sub set_vms_rooted_logical { |
401
|
0
|
|
|
0
|
1
|
0
|
my( $logical, $dir ) = @_; |
402
|
0
|
0
|
|
|
|
0
|
return unless $^O eq 'VMS'; |
403
|
|
|
|
|
|
|
|
404
|
0
|
|
|
|
|
0
|
my $cwd = cwd(); |
405
|
0
|
|
0
|
|
|
0
|
$dir ||= $cwd; |
406
|
|
|
|
|
|
|
|
407
|
0
|
0
|
|
|
|
0
|
-d $dir or do { |
408
|
0
|
|
|
|
|
0
|
require File::Path; |
409
|
0
|
|
|
|
|
0
|
File::Path::mkpath( $dir ); |
410
|
|
|
|
|
|
|
}; |
411
|
0
|
0
|
|
|
|
0
|
chdir $dir or die "Cannot chdir($dir): $!"; |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
# On older systems we might exceed the 8-level directory depth limit |
414
|
|
|
|
|
|
|
# imposed by RMS. We get around this with a rooted logical, but we |
415
|
|
|
|
|
|
|
# can't create logical names with attributes in Perl, so we do it |
416
|
|
|
|
|
|
|
# in a DCL subprocess and put it in the job table so the parent sees it. |
417
|
|
|
|
|
|
|
|
418
|
0
|
0
|
|
|
|
0
|
open TSBRL, '> tsbuildrl.com' or die "Error creating DCL-file; $!"; |
419
|
|
|
|
|
|
|
|
420
|
0
|
|
|
|
|
0
|
print TSBRL <
|
421
|
|
|
|
|
|
|
\$ $logical = F\$PARSE("SYS\$DISK:[]",,,,"NO_CONCEAL")-".][000000"-"]["-"].;"+".]" |
422
|
|
|
|
|
|
|
\$ DEFINE/JOB/NOLOG/TRANSLATION=CONCEALED $logical '$logical' |
423
|
|
|
|
|
|
|
COMMAND |
424
|
0
|
|
|
|
|
0
|
close TSBRL; |
425
|
|
|
|
|
|
|
|
426
|
0
|
|
|
|
|
0
|
my $result = system '@tsbuildrl.com'; |
427
|
0
|
|
|
|
|
0
|
1 while unlink 'tsbuildrl.com'; |
428
|
0
|
|
|
|
|
0
|
chdir $cwd; |
429
|
0
|
|
|
|
|
0
|
return $result == 0; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
=head2 get_cfg_filename( ) |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
C tries to find a B and returns it. |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
=cut |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
sub get_cfg_filename { |
439
|
5
|
|
|
5
|
1
|
1555
|
my( $cfg_name ) = @_; |
440
|
5
|
100
|
100
|
|
|
116
|
return $cfg_name if defined $cfg_name && -f $cfg_name; |
441
|
|
|
|
|
|
|
|
442
|
2
|
|
33
|
|
|
20
|
my( $base_dir ) = ( $0 =~ m|^(.*)/| ) || File::Spec->curdir; |
443
|
2
|
|
|
|
|
28
|
$cfg_name = File::Spec->catfile( $base_dir, 'smoke.cfg' ); |
444
|
2
|
50
|
33
|
|
|
46
|
return $cfg_name if -f $cfg_name && -s _; |
445
|
|
|
|
|
|
|
|
446
|
2
|
|
|
|
|
12
|
$base_dir = File::Spec->curdir; |
447
|
2
|
|
|
|
|
15
|
$cfg_name = File::Spec->catfile( $base_dir, 'smoke.cfg' ); |
448
|
2
|
50
|
33
|
|
|
32
|
return $cfg_name if -f $cfg_name && -s _; |
449
|
|
|
|
|
|
|
|
450
|
2
|
|
|
|
|
12
|
return undef; |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
=head2 read_logfile( ) |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
Read the logfile. If an argument is passed, force to (re)read the log |
456
|
|
|
|
|
|
|
If no argument is passed, return the stored log if available otherwise |
457
|
|
|
|
|
|
|
read the logfile |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
=cut |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
sub read_logfile { |
462
|
16
|
|
|
16
|
1
|
77
|
my ($logfile, $verbose) = @_; |
463
|
16
|
50
|
|
|
|
69
|
return if ! defined $logfile; |
464
|
|
|
|
|
|
|
|
465
|
16
|
50
|
|
|
|
782
|
open my $fh, "<", $logfile or return undef; |
466
|
16
|
|
|
|
|
56
|
my $log = do { local $/; <$fh> }; |
|
16
|
|
|
|
|
159
|
|
|
16
|
|
|
|
|
706
|
|
467
|
16
|
|
|
|
|
230
|
close $fh; |
468
|
|
|
|
|
|
|
|
469
|
16
|
|
|
|
|
70
|
my $es = eval { decode("utf-8", $log, Encode::FB_CROAK ) }; |
|
16
|
|
|
|
|
362
|
|
470
|
16
|
50
|
|
|
|
2759
|
$@ and eval { $es = decode("cp1252", $log, Encode::FB_CROAK ) }; |
|
0
|
|
|
|
|
0
|
|
471
|
16
|
50
|
|
|
|
60
|
$@ and eval { $es = decode("iso-8859-1", $log, Encode::FB_CROAK ) }; |
|
0
|
|
|
|
|
0
|
|
472
|
|
|
|
|
|
|
|
473
|
16
|
50
|
|
|
|
107
|
warn("Couldn't decode logfile($logfile): $@") if $@; |
474
|
16
|
50
|
|
|
|
132
|
return $@ ? $log : $es; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
=head2 grepccmsg( $cc, $logfile, $verbose ) |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
This is a port of Jarkko Hietaniemi's grepccerr script. |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
=cut |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
sub grepccmsg { |
484
|
70
|
|
|
70
|
1
|
30213
|
my( $cc, $smokelog, $verbose ) = @_; |
485
|
70
|
50
|
|
|
|
185
|
defined $smokelog or return; |
486
|
70
|
50
|
33
|
|
|
801
|
$cc = 'gcc' if !$cc || $cc eq 'g++' || $cc eq 'clang'; |
|
|
|
33
|
|
|
|
|
487
|
70
|
|
|
|
|
1722
|
my %OS2PAT = ( |
488
|
|
|
|
|
|
|
'aix' => |
489
|
|
|
|
|
|
|
# "foo.c", line n.c: pppp-qqq (W) ...error description... |
490
|
|
|
|
|
|
|
# "foo.c", line n.c: pppp-qqq (S) ...error description... |
491
|
|
|
|
|
|
|
'(^".+?", line \d+\.\d+: \d+-\d+ \([WS]\) .+?$)', |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
'dec_osf' => |
494
|
|
|
|
|
|
|
# DEC OSF/1, Digital UNIX, Tru64 (notice also VMS) |
495
|
|
|
|
|
|
|
# cc: Warning: foo.c, line nnn: ...error description...(error_tag) |
496
|
|
|
|
|
|
|
# ...error line... |
497
|
|
|
|
|
|
|
# ------^ |
498
|
|
|
|
|
|
|
# cc: Error: foo.c, line nnn: ...error description... (error_tag) |
499
|
|
|
|
|
|
|
# ...error line... |
500
|
|
|
|
|
|
|
# ------^ |
501
|
|
|
|
|
|
|
'(^cc: (?:Warning|Error): .+?^-*\^$)', |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
'hpux' => |
504
|
|
|
|
|
|
|
# cc: "foo.c"" line nnn: warning ppp: ...error description... |
505
|
|
|
|
|
|
|
# cc: "foo.c"" line nnn: error ppp: ...error description... |
506
|
|
|
|
|
|
|
'(^cc: ".+?", line \d+: (?:warning|error) \d+: .+?$)', |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
'irix' => |
509
|
|
|
|
|
|
|
# cc-pppp cc: WARNING File = foo.c, Line = nnnn |
510
|
|
|
|
|
|
|
# ...error description... |
511
|
|
|
|
|
|
|
# |
512
|
|
|
|
|
|
|
# ...error line... |
513
|
|
|
|
|
|
|
# ^ |
514
|
|
|
|
|
|
|
# cc-pppp cc: ERROR File = foo.c, Line = nnnn |
515
|
|
|
|
|
|
|
# ...error description... |
516
|
|
|
|
|
|
|
# |
517
|
|
|
|
|
|
|
# ...error line... |
518
|
|
|
|
|
|
|
# ^ |
519
|
|
|
|
|
|
|
'^(cc-\d+ cc: (?:WARNING|ERROR) File = .+?, ' . |
520
|
|
|
|
|
|
|
'Line = \d+.+?^\s*\^$)', |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
'solaris' => |
523
|
|
|
|
|
|
|
# "foo.c", line nnn: warning: ...error description... |
524
|
|
|
|
|
|
|
# "foo.c", line nnn: warning: ...: |
525
|
|
|
|
|
|
|
# ...error description... |
526
|
|
|
|
|
|
|
# "foo.c", line nnn: syntax error ... |
527
|
|
|
|
|
|
|
'(^".+?", line \d+: ' . |
528
|
|
|
|
|
|
|
'(?:warning: (?:(?:.+?:$)?.+?$)|syntax error.+?$))', |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
'vms' => # same compiler as Tru64, different message syntax |
531
|
|
|
|
|
|
|
# ...error line... |
532
|
|
|
|
|
|
|
# ......^ |
533
|
|
|
|
|
|
|
# %CC-W-MESSAGEID, ...error description... |
534
|
|
|
|
|
|
|
# at line number nnn in file foo.c |
535
|
|
|
|
|
|
|
'(^\n.+?\n^\.+?\^\n^\%CC-(?:I|W|E|F)-\w+, ' . |
536
|
|
|
|
|
|
|
'.+?\nat line number \d+ in file \S+?$)', |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
'gcc' => |
539
|
|
|
|
|
|
|
# foo.c: In function `foo': |
540
|
|
|
|
|
|
|
# foo.c:nnn: warning: ... |
541
|
|
|
|
|
|
|
# foo.c: In function `foo': |
542
|
|
|
|
|
|
|
# foo.c:nnn:ppp: warning: ... |
543
|
|
|
|
|
|
|
# Sometimes also the column is mentioned. |
544
|
|
|
|
|
|
|
# foo.c: In function `foo': |
545
|
|
|
|
|
|
|
# foo.c:nnn: error: ... |
546
|
|
|
|
|
|
|
# foo.c(:nn)?: undefined reference to ... |
547
|
|
|
|
|
|
|
'(^(?-s:.+?):(?: In function .+?:$|' . |
548
|
|
|
|
|
|
|
'(?: undefined reference to .+?$)|' . |
549
|
|
|
|
|
|
|
'\d+(?:\:\d+)?: ' . '(?:warning:|error:|note:|invalid) .+?$))', |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
'mswin32' => # MSVC(?:60)* |
552
|
|
|
|
|
|
|
# foo.c : error LNKnnn: error description |
553
|
|
|
|
|
|
|
# full\path\to\fooc.c : fatal error LNKnnn: error description |
554
|
|
|
|
|
|
|
# foo.c(nnn) : warning Cnnn: warning description |
555
|
|
|
|
|
|
|
'(^(?!NMAKE)(?-s:.+?) : (?-s:.+?)\d+: .+?$)', |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
'bcc32' => # BORLAND 5.5 on MSWin32 |
558
|
|
|
|
|
|
|
# Warning Wnnn filename line: warning description |
559
|
|
|
|
|
|
|
# Error Ennn:: error description |
560
|
|
|
|
|
|
|
'(^(?:(?:Warning W)|(?:Error E))\d+ .+? \d+: .+?$)', |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
'icc' => # Intel C on Linux |
563
|
|
|
|
|
|
|
# pp_sys.c(4412): warning #num: text |
564
|
|
|
|
|
|
|
# SETi( getpriority(which, who) ); |
565
|
|
|
|
|
|
|
# ^ |
566
|
|
|
|
|
|
|
'(^.*?\([0-9]+\): (?:warning #[0-9]+|error): .+$)', |
567
|
|
|
|
|
|
|
'icpc' => # Intel C++ |
568
|
|
|
|
|
|
|
'(^.*?\([0-9]+\): (?:warning #[0-9]+|error): .+$)', |
569
|
|
|
|
|
|
|
); |
570
|
70
|
50
|
|
|
|
284
|
exists $OS2PAT{ lc $cc } or $cc = 'gcc'; |
571
|
70
|
|
|
|
|
175
|
my $pat = $OS2PAT{ lc $cc }; |
572
|
|
|
|
|
|
|
|
573
|
70
|
|
|
|
|
151
|
my( $indx, %error ) = ( 1 ); |
574
|
70
|
50
|
|
|
|
168
|
if ($smokelog) { |
575
|
70
|
50
|
|
|
|
161
|
$verbose and print "Pattern($cc): /$pat/\n"; |
576
|
|
|
|
|
|
|
} else { |
577
|
0
|
|
|
|
|
0
|
$error{ "Couldn't examine logfile for compiler warnings." } = 1; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
70
|
|
|
|
|
104741
|
while ($smokelog =~ m/$pat/mg) { |
581
|
1260
|
|
|
|
|
2889
|
(my $msg = $1) =~ s/^\s+//; |
582
|
1260
|
|
|
|
|
6813
|
$msg =~ s/[\s\r\n]+\Z//; |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# Skip known junk from Configure |
585
|
1260
|
50
|
|
|
|
2481
|
$msg =~ m{^try\.c:[ :0-9]+\bwarning:} and next; |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
# We need to think about this IRIX/$Config{cc} thing |
588
|
|
|
|
|
|
|
# $cc eq "irix" && $Config{cc} =~ m/-n32|-64/ && |
589
|
|
|
|
|
|
|
# $msg =~ m/cc-(?:1009|1110|1047) / and next; |
590
|
|
|
|
|
|
|
|
591
|
1260
|
|
66
|
|
|
10832
|
$error{ $msg } ||= $indx++; |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
|
594
|
70
|
|
|
|
|
343
|
my @errors = sort { $error{ $a } <=> $error{ $b } } keys %error; |
|
272
|
|
|
|
|
484
|
|
595
|
|
|
|
|
|
|
|
596
|
70
|
100
|
|
|
|
979
|
return wantarray ? @errors : \@errors; |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
=head2 grepnonfatal( $cc, $logfile, $verbose ) |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
This is a way to find known failures that do not cause the tests to |
602
|
|
|
|
|
|
|
fail but are important enough to report, like being unable to install |
603
|
|
|
|
|
|
|
manual pages. |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
=cut |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
sub grepnonfatal { |
608
|
68
|
|
|
68
|
1
|
25705
|
my( $cc, $smokelog, $verbose ) = @_; |
609
|
68
|
50
|
|
|
|
148
|
$smokelog or return; |
610
|
|
|
|
|
|
|
|
611
|
68
|
|
|
|
|
125
|
my( $indx, %error ) = ( 1 ); |
612
|
|
|
|
|
|
|
|
613
|
68
|
|
|
|
|
324
|
my $kf = qr{ |
614
|
|
|
|
|
|
|
# Pod::Man is not available: Can't load module Encode, dynamic loading not available in this perl. |
615
|
|
|
|
|
|
|
(\b (\S+) (?-x: is not available: Can't load module ) |
616
|
|
|
|
|
|
|
(\S+?) , (?-x: dynamic loading not available) ) |
617
|
|
|
|
|
|
|
}xi; |
618
|
|
|
|
|
|
|
|
619
|
68
|
|
|
1
|
|
41309
|
while ($smokelog =~ m{$kf}g) { |
|
1
|
|
|
|
|
1127
|
|
|
1
|
|
|
|
|
23
|
|
|
1
|
|
|
|
|
26
|
|
620
|
24
|
|
|
|
|
77
|
my $fail = $1; # $2 = "Pod::Man", $3 = "Encode" |
621
|
|
|
|
|
|
|
|
622
|
24
|
|
66
|
|
|
35650
|
$error{ $fail } ||= $indx++; |
623
|
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
|
|
625
|
68
|
|
|
|
|
31493
|
my @errors = sort { $error{ $a } <=> $error{ $b } } keys %error; |
|
0
|
|
|
|
|
0
|
|
626
|
|
|
|
|
|
|
|
627
|
68
|
100
|
|
|
|
929
|
return wantarray ? @errors : \@errors; |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
=head2 get_local_patches( $ddir ) |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
C reads F to scan for the locally |
633
|
|
|
|
|
|
|
applied patches array. |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
=cut |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
sub get_local_patches { |
638
|
82
|
|
|
82
|
1
|
8288
|
my( $ddir, $verbose ) = @_; |
639
|
82
|
|
33
|
|
|
480
|
$ddir = shift || cwd(); |
640
|
82
|
|
|
|
|
555
|
my $plevel = catfile( $ddir, 'patchlevel.h' ); |
641
|
|
|
|
|
|
|
|
642
|
82
|
|
|
|
|
1706
|
my $logger = Test::Smoke::Logger->new(v => $verbose); |
643
|
|
|
|
|
|
|
|
644
|
82
|
|
|
|
|
207
|
my @lpatches = ( ); |
645
|
82
|
|
|
|
|
262
|
local *PLEVEL; |
646
|
82
|
|
|
|
|
812
|
$logger->log_info("Locally applied patches from '%s'", $plevel); |
647
|
82
|
100
|
|
|
|
2267
|
unless ( open PLEVEL, "< $plevel" ) { |
648
|
59
|
|
|
|
|
589
|
$logger->log_warn("open(%s) error: %s", $plevel, $!); |
649
|
59
|
|
|
|
|
953
|
return @lpatches; |
650
|
|
|
|
|
|
|
} |
651
|
23
|
|
|
|
|
123
|
my( $seen, $patchnum ); |
652
|
23
|
|
|
|
|
591
|
while ( ) { |
653
|
3945
|
100
|
|
|
|
6479
|
$patchnum = $1 if /#define PERL_PATCHNUM\s+(\d+)/; |
654
|
3945
|
100
|
100
|
|
|
6869
|
$seen && /^\s*,"(.+)"/ and push @lpatches, $1; |
655
|
3945
|
100
|
|
|
|
8927
|
/^\s*static.+?local_patches\[\]/ and $seen++; |
656
|
|
|
|
|
|
|
} |
657
|
23
|
|
|
|
|
249
|
close PLEVEL; |
658
|
23
|
100
|
|
|
|
79
|
if ( defined $patchnum ) { |
659
|
|
|
|
|
|
|
@lpatches = map { |
660
|
2
|
|
|
|
|
5
|
s/^(MAINT|DEVEL)$/$1$patchnum/; |
|
4
|
|
|
|
|
22
|
|
661
|
4
|
|
|
|
|
16
|
$_; |
662
|
|
|
|
|
|
|
} @lpatches; |
663
|
|
|
|
|
|
|
} |
664
|
23
|
|
|
|
|
152
|
$logger->log_info("Patches: '%s'", join(';', @lpatches)); |
665
|
23
|
|
|
|
|
160
|
return @lpatches; |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
=head2 set_local_patch( $ddir, @descr ) |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
Copy the code from F. Older (pre 5.8.1) perls do not |
671
|
|
|
|
|
|
|
have it and it doesn't work on MSWin32. |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
=cut |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
sub set_local_patch { |
676
|
17
|
|
|
17
|
1
|
11711
|
my( $ddir, @descr ) = @_; |
677
|
|
|
|
|
|
|
|
678
|
17
|
|
|
|
|
395
|
my $plh = catfile( $ddir, 'patchlevel.h' ); |
679
|
17
|
|
|
|
|
172
|
my $pln = catfile( $ddir, 'patchlevel.new' ); |
680
|
17
|
|
|
|
|
183
|
my $plb = catfile( $ddir, 'patchlevel.bak' ); |
681
|
17
|
|
|
|
|
227
|
local( *PLIN, *PLOUT ); |
682
|
17
|
50
|
|
|
|
1107
|
open PLIN, "< $plh" or return 0; |
683
|
17
|
50
|
|
|
|
1754
|
open PLOUT, "> $pln" or return 0; |
684
|
17
|
|
|
|
|
146
|
my $seen=0; |
685
|
17
|
|
|
|
|
74
|
my $done=0; |
686
|
17
|
|
|
|
|
751
|
while ( ) { |
687
|
2588
|
100
|
100
|
|
|
6630
|
if ( /^(\s+),NULL/ and $seen ) { |
688
|
17
|
|
|
|
|
52
|
$done++; |
689
|
17
|
|
|
|
|
140
|
while ( my $c = shift @descr ) { |
690
|
19
|
|
|
|
|
298
|
print PLOUT qq{$1,"$c"\n}; |
691
|
|
|
|
|
|
|
} |
692
|
|
|
|
|
|
|
} |
693
|
2588
|
100
|
|
|
|
5534
|
$seen++ if /local_patches\[\]/; |
694
|
2588
|
|
|
|
|
6857
|
print PLOUT; |
695
|
|
|
|
|
|
|
} |
696
|
17
|
|
|
|
|
290
|
close PLIN; |
697
|
17
|
50
|
|
|
|
1049
|
close PLOUT or return 0; |
698
|
|
|
|
|
|
|
|
699
|
17
|
50
|
|
|
|
100
|
if ( not $done ) { |
700
|
0
|
|
|
|
|
0
|
require Carp; |
701
|
0
|
|
|
|
|
0
|
Carp::carp("Failed to update patchlevel.h. Content not as expected?"); |
702
|
0
|
|
|
|
|
0
|
return 0; |
703
|
|
|
|
|
|
|
} |
704
|
|
|
|
|
|
|
|
705
|
17
|
|
33
|
|
|
1364
|
-e $plb and 1 while unlink $plb; |
706
|
17
|
|
|
|
|
283
|
my $errno = "$!"; |
707
|
17
|
50
|
|
|
|
223
|
if ( -e $plb ) { |
708
|
0
|
|
|
|
|
0
|
require Carp; |
709
|
0
|
|
|
|
|
0
|
Carp::carp( "Could not unlink $plb : $errno" ); |
710
|
0
|
|
|
|
|
0
|
return 0; |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
17
|
50
|
|
|
|
813
|
unless ( rename $plh, $plb ) { |
714
|
0
|
|
|
|
|
0
|
require Carp; |
715
|
0
|
|
|
|
|
0
|
Carp::carp( "Could not rename $plh to $plb : $!" ); |
716
|
0
|
|
|
|
|
0
|
return 0; |
717
|
|
|
|
|
|
|
} |
718
|
17
|
50
|
|
|
|
635
|
unless ( rename $pln, $plh ) { |
719
|
0
|
|
|
|
|
0
|
require Carp; |
720
|
0
|
|
|
|
|
0
|
Carp::carp( "Could not rename '$pln' to '$plh' : $!" ); |
721
|
0
|
|
|
|
|
0
|
return 0; |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
|
724
|
17
|
|
|
|
|
209
|
return 1; |
725
|
|
|
|
|
|
|
} |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
=head2 get_config( $filename ) |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
Read and parse the configuration from file, or return the default |
730
|
|
|
|
|
|
|
config. |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
=cut |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
sub get_config { |
735
|
3
|
|
|
3
|
1
|
726
|
my( $config_file ) = @_; |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
return ( |
738
|
3
|
100
|
|
|
|
29
|
[ "", |
739
|
|
|
|
|
|
|
"-Dusethreads -Duseithreads" |
740
|
|
|
|
|
|
|
], |
741
|
|
|
|
|
|
|
[ "", |
742
|
|
|
|
|
|
|
"-Duse64bitint", |
743
|
|
|
|
|
|
|
"-Duse64bitall", |
744
|
|
|
|
|
|
|
"-Duselongdouble", |
745
|
|
|
|
|
|
|
"-Dusemorebits", |
746
|
|
|
|
|
|
|
"-Duse64bitall -Duselongdouble" |
747
|
|
|
|
|
|
|
], |
748
|
|
|
|
|
|
|
{ policy_target => "-DDEBUGGING", |
749
|
|
|
|
|
|
|
args => [ "", "-DDEBUGGING" ] |
750
|
|
|
|
|
|
|
}, |
751
|
|
|
|
|
|
|
) unless defined $config_file; |
752
|
|
|
|
|
|
|
|
753
|
1
|
50
|
|
|
|
34
|
open CONF, "< $config_file" or do { |
754
|
0
|
|
|
|
|
0
|
warn "Can't open '$config_file': $!\nUsing standard configuration"; |
755
|
0
|
|
|
|
|
0
|
return get_config( undef ); |
756
|
|
|
|
|
|
|
}; |
757
|
1
|
|
|
|
|
5
|
my( @conf, @cnf_stack, @target ); |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
# Cheat. Force a break marker as a line after the last line. |
760
|
1
|
|
|
|
|
47
|
foreach (, "=") { |
761
|
14
|
100
|
|
|
|
33
|
m/^#/ and next; |
762
|
12
|
100
|
|
|
|
42
|
s/\s+$// if m/\s/; # Blanks, new-lines and carriage returns. M$ |
763
|
12
|
100
|
|
|
|
22
|
if (m:^/:) { |
764
|
1
|
|
|
|
|
4
|
m:^/(.*)/$:; |
765
|
1
|
50
|
|
|
|
4
|
defined $1 or die "Policy target line didn't end with '/': '$_'"; |
766
|
1
|
|
|
|
|
3
|
push @target, $1; |
767
|
1
|
|
|
|
|
2
|
next; |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
|
770
|
11
|
100
|
|
|
|
25
|
if (!m/^=/) { |
771
|
|
|
|
|
|
|
# Not a break marker |
772
|
7
|
|
|
|
|
12
|
push @conf, $_; |
773
|
7
|
|
|
|
|
12
|
next; |
774
|
|
|
|
|
|
|
} |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
# Break marker, so process the lines we have. |
777
|
4
|
50
|
|
|
|
8
|
if (@target > 1) { |
778
|
|
|
|
|
|
|
warn "Multiple policy target lines " . |
779
|
0
|
|
|
|
|
0
|
join (", ", map {"'$_'"} @target) . " - will use first"; |
|
0
|
|
|
|
|
0
|
|
780
|
|
|
|
|
|
|
} |
781
|
4
|
|
|
|
|
8
|
my %conf = map { $_ => 1 } @conf; |
|
7
|
|
|
|
|
32
|
|
782
|
4
|
50
|
66
|
|
|
20
|
if (keys %conf == 1 and exists $conf{""} and !@target) { |
|
|
|
33
|
|
|
|
|
783
|
|
|
|
|
|
|
# There are only blank lines - treat it as if there were no lines |
784
|
|
|
|
|
|
|
# (Lets people have blank sections in configuration files without |
785
|
|
|
|
|
|
|
# warnings.) |
786
|
|
|
|
|
|
|
# Unless there is a policy target. (substituting '' in place of |
787
|
|
|
|
|
|
|
# target is a valid thing to do.) |
788
|
1
|
|
|
|
|
3
|
@conf = (); |
789
|
|
|
|
|
|
|
} |
790
|
|
|
|
|
|
|
|
791
|
4
|
100
|
|
|
|
9
|
unless (@conf) { |
792
|
|
|
|
|
|
|
# They have no target lines |
793
|
1
|
50
|
|
|
|
5
|
@target and |
794
|
|
|
|
|
|
|
warn "Policy target '$target[0]' has no configuration lines, ". |
795
|
|
|
|
|
|
|
"so it will not be used"; |
796
|
1
|
|
|
|
|
4
|
@target = (); |
797
|
1
|
|
|
|
|
2
|
next; |
798
|
|
|
|
|
|
|
} |
799
|
|
|
|
|
|
|
|
800
|
3
|
|
|
|
|
12
|
while (my ($key, $val) = each %conf) { |
801
|
6
|
50
|
|
|
|
19
|
$val > 1 and |
802
|
|
|
|
|
|
|
warn "Configuration line '$key' duplicated $val times"; |
803
|
|
|
|
|
|
|
} |
804
|
3
|
|
|
|
|
7
|
my $args = [@conf]; |
805
|
3
|
|
|
|
|
5
|
@conf = (); |
806
|
3
|
100
|
|
|
|
7
|
if (@target) { |
807
|
1
|
|
|
|
|
7
|
push @cnf_stack, { policy_target => $target[0], args => $args }; |
808
|
1
|
|
|
|
|
2
|
@target = (); |
809
|
1
|
|
|
|
|
2
|
next; |
810
|
|
|
|
|
|
|
} |
811
|
|
|
|
|
|
|
|
812
|
2
|
|
|
|
|
15
|
push @cnf_stack, $args; |
813
|
|
|
|
|
|
|
} |
814
|
1
|
|
|
|
|
14
|
close CONF; |
815
|
1
|
|
|
|
|
6
|
return @cnf_stack; |
816
|
|
|
|
|
|
|
} |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=head2 get_patch( [$ddir] ) |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
Try to find the patchlevel, look for B<.patch> or try to get it from |
821
|
|
|
|
|
|
|
B as a fallback. |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
=cut |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
sub get_patch { |
826
|
12
|
|
|
12
|
1
|
7459
|
my( $ddir ) = @_; |
827
|
12
|
|
66
|
|
|
103
|
$ddir ||= File::Spec->curdir; |
828
|
|
|
|
|
|
|
|
829
|
12
|
|
|
|
|
264
|
my $dot_patch = File::Spec->catfile( $ddir, '.patch' ); |
830
|
12
|
|
|
|
|
71
|
local *DOTPATCH; |
831
|
12
|
|
|
|
|
30
|
my $patch_level = '?????'; |
832
|
12
|
100
|
|
|
|
367
|
if ( open DOTPATCH, "< $dot_patch" ) { |
833
|
3
|
|
50
|
|
|
94
|
chomp( $patch_level = || '' ); |
834
|
3
|
|
|
|
|
36
|
close DOTPATCH; |
835
|
|
|
|
|
|
|
|
836
|
3
|
50
|
|
|
|
16
|
if ( $patch_level ) { |
837
|
3
|
100
|
|
|
|
37
|
if ($patch_level =~ /\s/) { |
838
|
1
|
|
|
|
|
11
|
my ($branch, $sha, $describe) = (split ' ', $patch_level)[0, -2, -1]; |
839
|
1
|
|
|
|
|
14
|
(my $short_describe = $describe) =~ s/^GitLive-//; |
840
|
1
|
|
|
|
|
12
|
return [$sha, $short_describe, $branch]; |
841
|
|
|
|
|
|
|
} |
842
|
2
|
|
|
|
|
25
|
return [$patch_level]; |
843
|
|
|
|
|
|
|
} |
844
|
0
|
|
|
|
|
0
|
return [ '' ]; |
845
|
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
# There does not seem to be a '.patch', try 'git_version.h' |
848
|
|
|
|
|
|
|
# We are looking for the line: #define PERL_PATCHNUM "v5.21.6-224-g6324db4" |
849
|
9
|
|
|
|
|
122
|
my $git_version_h = File::Spec->catfile($ddir, 'git_version.h'); |
850
|
9
|
100
|
|
|
|
233
|
if (open my $gvh, '<', $git_version_h) { |
851
|
2
|
|
|
|
|
39
|
while (my $line = <$gvh>) { |
852
|
14
|
100
|
|
|
|
52
|
if ($line =~ /^#define PERL_PATCHNUM "(.+)"$/) { |
853
|
1
|
|
|
|
|
23
|
return [$1]; |
854
|
|
|
|
|
|
|
} |
855
|
|
|
|
|
|
|
} |
856
|
1
|
|
|
|
|
11
|
close $gvh; |
857
|
|
|
|
|
|
|
} |
858
|
|
|
|
|
|
|
# This only applies to |
859
|
|
|
|
|
|
|
# There does not seem to be a '.patch', and we couldn't find git_version.h |
860
|
|
|
|
|
|
|
# Now try 'patchlevel.h' |
861
|
|
|
|
|
|
|
# We are looking for the line: ,"DEVEL19999" (within local_patches[] = {} |
862
|
8
|
|
|
|
|
35
|
local *PATCHLEVEL_H; |
863
|
8
|
|
|
|
|
92
|
my $patchlevel_h = File::Spec->catfile( $ddir, 'patchlevel.h' ); |
864
|
8
|
100
|
|
|
|
220
|
if ( open PATCHLEVEL_H, "< $patchlevel_h" ) { |
865
|
5
|
|
|
|
|
33
|
my( $declaration_seen, $patchnum ) = ( 0, 0 ); |
866
|
5
|
|
|
|
|
110
|
while ( ) { |
867
|
299
|
100
|
|
|
|
565
|
$patchnum = $1 if /#define PERL_PATCHNUM\s+(\d+)/; |
868
|
299
|
|
100
|
|
|
861
|
$declaration_seen ||= /local_patches\[\]/; |
869
|
299
|
100
|
100
|
|
|
934
|
$declaration_seen && |
870
|
|
|
|
|
|
|
/^\s+,"(?:(?:DEVEL|MAINT)(\d+)?)|(RC\d+)"/ or next; |
871
|
5
|
|
50
|
|
|
29
|
$patch_level = $patchnum || $1 || $2 || '?????'; |
872
|
5
|
100
|
|
|
|
13
|
if ( $patch_level =~ /^RC/ ) { |
873
|
1
|
|
|
|
|
7
|
$patch_level = version_from_patchlevel_h( $ddir ) . |
874
|
|
|
|
|
|
|
"-$patch_level"; |
875
|
|
|
|
|
|
|
} else { |
876
|
4
|
100
|
|
|
|
15
|
$patch_level .= $patchnum ? "" : '(+)'; |
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
} |
879
|
|
|
|
|
|
|
} |
880
|
8
|
|
|
|
|
123
|
return [ $patch_level ]; |
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
=head2 version_from_patchlevel_h( $ddir ) |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
C returns a "dotted" version as derived |
886
|
|
|
|
|
|
|
from the F file in the distribution. |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
=cut |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
sub version_from_patchlevel_h { |
891
|
20
|
|
|
20
|
1
|
83
|
my( $ddir ) = @_; |
892
|
20
|
|
33
|
|
|
71
|
$ddir ||= File::Spec->curdir; |
893
|
20
|
|
|
|
|
385
|
my $file = File::Spec->catfile( $ddir, 'patchlevel.h' ); |
894
|
|
|
|
|
|
|
|
895
|
20
|
|
|
|
|
222
|
my( $revision, $version, $subversion ) = qw( 5 ? ? ); |
896
|
20
|
|
|
|
|
91
|
local *PATCHLEVEL; |
897
|
20
|
100
|
|
|
|
507
|
if ( open PATCHLEVEL, "< $file" ) { |
898
|
5
|
|
|
|
|
21
|
my $patchlevel = do { local $/; }; |
|
5
|
|
|
|
|
35
|
|
|
5
|
|
|
|
|
170
|
|
899
|
5
|
|
|
|
|
64
|
close PATCHLEVEL; |
900
|
|
|
|
|
|
|
|
901
|
5
|
100
|
|
|
|
82
|
if ( $patchlevel =~ /^#define PATCHLEVEL\s+(\d+)/m ) { |
902
|
|
|
|
|
|
|
# Also support perl < 5.6 |
903
|
1
|
|
|
|
|
9
|
$version = sprintf "%03u", $1; |
904
|
1
|
50
|
|
|
|
7
|
$subversion = $patchlevel =~ /^#define SUBVERSION\s+(\d+)/m |
905
|
|
|
|
|
|
|
? sprintf "%02u", $1 : '??'; |
906
|
1
|
|
|
|
|
8
|
return "$revision.$version$subversion"; |
907
|
|
|
|
|
|
|
} |
908
|
|
|
|
|
|
|
|
909
|
4
|
50
|
|
|
|
60
|
$revision = $patchlevel =~ /^#define PERL_REVISION\s+(\d+)/m |
910
|
|
|
|
|
|
|
? $1 : '?'; |
911
|
4
|
50
|
|
|
|
42
|
$version = $patchlevel =~ /^#define PERL_VERSION\s+(\d+)/m |
912
|
|
|
|
|
|
|
? $1 : '?'; |
913
|
4
|
50
|
|
|
|
49
|
$subversion = $patchlevel =~ /^#define PERL_SUBVERSION\s+(\d+)/m |
914
|
|
|
|
|
|
|
? $1 : '?'; |
915
|
|
|
|
|
|
|
} |
916
|
19
|
|
|
|
|
210
|
return "$revision.$version.$subversion"; |
917
|
|
|
|
|
|
|
} |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
=head2 get_ncpu( $osname ) |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
C returns the number of available (online/active/enabled) CPUs. |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
It does this by using some operating system specific trick (usually |
924
|
|
|
|
|
|
|
by running some external command and parsing the output). |
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
If it cannot recognize your operating system an empty string is returned. |
927
|
|
|
|
|
|
|
If it can recognize it but the external command failed, C<"? cpus"> |
928
|
|
|
|
|
|
|
is returned. |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
In the first case (where we really have no idea how to proceed), |
931
|
|
|
|
|
|
|
also a warning (C) is sent to STDERR. |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
=over |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
=item B |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
If you get the warning C, you will |
938
|
|
|
|
|
|
|
need to help us-- how does one tell the number of available CPUs in |
939
|
|
|
|
|
|
|
your operating system? Sometimes there are several different ways: |
940
|
|
|
|
|
|
|
please try to find the fastest one, and a one that does not require |
941
|
|
|
|
|
|
|
superuser (administrator) rights. |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
Thanks to Jarkko Hietaniemi for donating this! |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
=back |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
=cut |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
sub get_ncpu { |
950
|
|
|
|
|
|
|
# Only *nixy osses need this, so use ':' |
951
|
1
|
|
|
1
|
1
|
677
|
local $ENV{PATH} = "$ENV{PATH}:/usr/sbin:/sbin"; |
952
|
|
|
|
|
|
|
|
953
|
1
|
|
|
|
|
2
|
my $cpus = "?"; |
954
|
|
|
|
|
|
|
OS_CHECK: { |
955
|
1
|
50
|
|
|
|
2
|
local $_ = shift or return ""; |
|
1
|
|
|
|
|
24
|
|
956
|
|
|
|
|
|
|
|
957
|
1
|
50
|
|
|
|
6
|
/aix/i && do { |
958
|
0
|
|
|
|
|
0
|
my @output = `lsdev -C -c processor -S Available`; |
959
|
0
|
|
|
|
|
0
|
$cpus = scalar @output; |
960
|
0
|
|
|
|
|
0
|
last OS_CHECK; |
961
|
|
|
|
|
|
|
}; |
962
|
|
|
|
|
|
|
|
963
|
1
|
50
|
|
|
|
8
|
/(?:darwin|.*bsd)/i && do { |
964
|
0
|
|
|
|
|
0
|
chomp( my @output = `sysctl -n hw.ncpu` ); |
965
|
0
|
|
|
|
|
0
|
$cpus = $output[0]; |
966
|
0
|
|
|
|
|
0
|
last OS_CHECK; |
967
|
|
|
|
|
|
|
}; |
968
|
|
|
|
|
|
|
|
969
|
1
|
50
|
|
|
|
3
|
/hp-?ux/i && do { |
970
|
0
|
|
|
|
|
0
|
my @output = grep /^processor/ => `ioscan -fnkC processor`; |
971
|
0
|
|
|
|
|
0
|
$cpus = scalar @output; |
972
|
0
|
|
|
|
|
0
|
last OS_CHECK; |
973
|
|
|
|
|
|
|
}; |
974
|
|
|
|
|
|
|
|
975
|
1
|
50
|
|
|
|
4
|
/irix/i && do { |
976
|
0
|
|
|
|
|
0
|
my @output = grep /\s+processors?$/i => `hinv -c processor`; |
977
|
0
|
|
|
|
|
0
|
$cpus = (split " ", $output[0])[0]; |
978
|
0
|
|
|
|
|
0
|
last OS_CHECK; |
979
|
|
|
|
|
|
|
}; |
980
|
|
|
|
|
|
|
|
981
|
1
|
50
|
|
|
|
4
|
/linux/i && do { |
982
|
1
|
|
|
|
|
2
|
my @output; local *PROC; |
|
1
|
|
|
|
|
2
|
|
983
|
1
|
50
|
|
|
|
48
|
if ( open PROC, "< /proc/cpuinfo" ) { |
984
|
1
|
|
|
|
|
500
|
@output = grep /^processor/ => ; |
985
|
1
|
|
|
|
|
35
|
close PROC; |
986
|
|
|
|
|
|
|
} |
987
|
1
|
50
|
|
|
|
7
|
$cpus = @output ? scalar @output : ''; |
988
|
1
|
|
|
|
|
6
|
last OS_CHECK; |
989
|
|
|
|
|
|
|
}; |
990
|
|
|
|
|
|
|
|
991
|
0
|
0
|
|
|
|
0
|
/solaris|sunos|osf/i && do { |
992
|
0
|
|
|
|
|
0
|
my @output = grep /on-line/ => `psrinfo`; |
993
|
0
|
|
|
|
|
0
|
$cpus = scalar @output; |
994
|
0
|
|
|
|
|
0
|
last OS_CHECK; |
995
|
|
|
|
|
|
|
}; |
996
|
|
|
|
|
|
|
|
997
|
0
|
0
|
|
|
|
0
|
/mswin32|cygwin/i && do { |
998
|
|
|
|
|
|
|
$cpus = exists $ENV{NUMBER_OF_PROCESSORS} |
999
|
0
|
0
|
|
|
|
0
|
? $ENV{NUMBER_OF_PROCESSORS} : ''; |
1000
|
0
|
|
|
|
|
0
|
last OS_CHECK; |
1001
|
|
|
|
|
|
|
}; |
1002
|
|
|
|
|
|
|
|
1003
|
0
|
0
|
|
|
|
0
|
/vms/i && do { |
1004
|
0
|
|
|
|
|
0
|
my @output = grep /CPU \d+ is in RUN state/ => `show cpu/active`; |
1005
|
0
|
0
|
|
|
|
0
|
$cpus = @output ? scalar @output : ''; |
1006
|
0
|
|
|
|
|
0
|
last OS_CHECK; |
1007
|
|
|
|
|
|
|
}; |
1008
|
|
|
|
|
|
|
|
1009
|
0
|
0
|
|
|
|
0
|
/haiku/i && do { |
1010
|
0
|
|
|
|
|
0
|
eval { require Haiku::SysInfo }; |
|
0
|
|
|
|
|
0
|
|
1011
|
0
|
0
|
|
|
|
0
|
if (!$@) { |
1012
|
0
|
|
|
|
|
0
|
my $hsi = Haiku::SysInfo->new(); |
1013
|
0
|
|
|
|
|
0
|
$cpus = $hsi->cpu_count(); |
1014
|
0
|
|
|
|
|
0
|
last OS_CHECK; |
1015
|
|
|
|
|
|
|
} |
1016
|
|
|
|
|
|
|
}; |
1017
|
|
|
|
|
|
|
|
1018
|
0
|
|
|
|
|
0
|
$cpus = ""; |
1019
|
0
|
|
|
|
|
0
|
require Carp; |
1020
|
0
|
|
|
|
|
0
|
Carp::carp( "get_ncpu: unknown operationg system" ); |
1021
|
|
|
|
|
|
|
} |
1022
|
|
|
|
|
|
|
|
1023
|
1
|
50
|
|
|
|
15
|
return $cpus ? sprintf( "%s cpu%s", $cpus, $cpus ne "1" ? 's' : '' ) : ""; |
|
|
50
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
} |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
=head2 get_smoked_Config( $dir, @keys ) |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
C returns a hash (a listified hash) with the |
1029
|
|
|
|
|
|
|
specified keys. It will try to find F to get those |
1030
|
|
|
|
|
|
|
values, if that cannot be found (make error?) we can try F |
1031
|
|
|
|
|
|
|
which is used to build F. |
1032
|
|
|
|
|
|
|
If F is not there (./Configure error?) we try to get some |
1033
|
|
|
|
|
|
|
fallback information from C and F. |
1034
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
=cut |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
sub get_smoked_Config { |
1038
|
172
|
|
|
172
|
1
|
23189
|
my( $dir, @fields ) = @_; |
1039
|
172
|
|
|
|
|
453
|
my %Config = map { ( lc $_ => undef ) } @fields; |
|
428
|
|
|
|
|
2413
|
|
1040
|
|
|
|
|
|
|
|
1041
|
172
|
|
|
|
|
1222
|
my $perl_Config_heavy = catfile ($dir, "lib", "Config_heavy.pl"); |
1042
|
172
|
|
|
|
|
718
|
my $perl_Config_pm = catfile ($dir, "lib", "Config.pm"); |
1043
|
172
|
|
|
|
|
649
|
my $perl_config_sh = catfile( $dir, 'config.sh' ); |
1044
|
172
|
|
|
|
|
908
|
local *CONF; |
1045
|
172
|
100
|
|
|
|
4043
|
if ( open CONF, "< $perl_Config_heavy" ) { |
1046
|
|
|
|
|
|
|
|
1047
|
1
|
|
|
|
|
48
|
while () { |
1048
|
15
|
100
|
|
|
|
64
|
if ( m/^(?: |
1049
|
|
|
|
|
|
|
(?:our|my)\ \$[cC]onfig_[sS][hH].* |
1050
|
|
|
|
|
|
|
| |
1051
|
|
|
|
|
|
|
\$_ |
1052
|
|
|
|
|
|
|
)\ =\ <<'!END!';/x..m/^!END!/){ |
1053
|
8
|
100
|
|
|
|
48
|
m/!END!(?:';)?$/ and next; |
1054
|
6
|
100
|
|
|
|
25
|
m/^([^=]+)='([^']*)'/ or next; |
1055
|
5
|
50
|
|
|
|
26
|
exists $Config{lc $1} and $Config{lc $1} = $2; |
1056
|
|
|
|
|
|
|
} |
1057
|
|
|
|
|
|
|
} |
1058
|
1
|
|
|
|
|
30
|
close CONF; |
1059
|
|
|
|
|
|
|
} |
1060
|
|
|
|
|
|
|
my %conf2 = map { |
1061
|
423
|
|
|
|
|
1053
|
( $_ => undef ) |
1062
|
172
|
|
|
|
|
1307
|
} grep !defined $Config{ $_ } => keys %Config; |
1063
|
172
|
100
|
|
|
|
2492
|
if ( open CONF, "< $perl_Config_pm" ) { |
1064
|
|
|
|
|
|
|
|
1065
|
2
|
|
|
|
|
35
|
while () { |
1066
|
31
|
100
|
|
|
|
115
|
if ( m/^(?: |
1067
|
|
|
|
|
|
|
(?:our|my)\ \$[cC]onfig_[sS][hH].* |
1068
|
|
|
|
|
|
|
| |
1069
|
|
|
|
|
|
|
\$_ |
1070
|
|
|
|
|
|
|
)\ =\ <<'!END!';/x..m/^!END!/){ |
1071
|
16
|
100
|
|
|
|
45
|
m/!END!(?:';)?$/ and next; |
1072
|
12
|
100
|
|
|
|
42
|
m/^([^=]+)='([^']*)'/ or next; |
1073
|
10
|
50
|
|
|
|
49
|
exists $conf2{lc $1} and $Config{lc $1} = $2; |
1074
|
|
|
|
|
|
|
} |
1075
|
|
|
|
|
|
|
} |
1076
|
2
|
|
|
|
|
20
|
close CONF; |
1077
|
|
|
|
|
|
|
} |
1078
|
|
|
|
|
|
|
%conf2 = map { |
1079
|
413
|
|
|
|
|
947
|
( $_ => undef ) |
1080
|
172
|
|
|
|
|
875
|
} grep !defined $Config{ $_ } => keys %Config; |
1081
|
172
|
100
|
|
|
|
4970
|
if ( open CONF, "< $perl_config_sh" ) { |
1082
|
144
|
|
|
|
|
3252
|
while ( ) { |
1083
|
444
|
100
|
|
|
|
2582
|
m/^([^=]+)='([^']*)'/ or next; # ' |
1084
|
148
|
100
|
|
|
|
1985
|
exists $conf2{ $1} and $Config{ lc $1 } = $2; |
1085
|
|
|
|
|
|
|
} |
1086
|
144
|
|
|
|
|
1505
|
close CONF; |
1087
|
|
|
|
|
|
|
} |
1088
|
|
|
|
|
|
|
%conf2 = map { |
1089
|
312
|
|
|
|
|
1200
|
( $_ => undef ) |
1090
|
172
|
|
|
|
|
1018
|
} grep !defined $Config{ $_ } => keys %Config; |
1091
|
172
|
100
|
|
|
|
494
|
if ( keys %conf2 ) { |
1092
|
|
|
|
|
|
|
# Fall-back values from POSIX::uname() (not reliable) |
1093
|
119
|
|
|
|
|
1138
|
require POSIX; |
1094
|
119
|
|
|
|
|
1340
|
my( $osname, undef, $osvers, undef, $arch) = POSIX::uname(); |
1095
|
119
|
100
|
|
|
|
440
|
$Config{osname} = lc $osname if exists $conf2{osname}; |
1096
|
119
|
100
|
|
|
|
291
|
$Config{osvers} = lc $osvers if exists $conf2{osvers}; |
1097
|
119
|
100
|
|
|
|
243
|
$Config{archname} = lc $arch if exists $conf2{archname}; |
1098
|
|
|
|
|
|
|
$Config{version} = version_from_patchlevel_h( $dir ) |
1099
|
119
|
100
|
|
|
|
380
|
if exists $conf2{version}; |
1100
|
|
|
|
|
|
|
} |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
# There should be no under-bars in perl versions! |
1103
|
172
|
100
|
|
|
|
539
|
exists $Config{version} and $Config{version} =~ s/_/./g; |
1104
|
172
|
|
|
|
|
1378
|
return %Config; |
1105
|
|
|
|
|
|
|
} |
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
=head2 parse_report_Config( $report ) |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
C returns a list attributes from a smoke report. |
1110
|
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
my( $version, $plevel, $os, $osvers, $archname, $summary, $branch ) = |
1112
|
|
|
|
|
|
|
parse_report_Config( $rpt ); |
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
=cut |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
sub parse_report_Config { |
1117
|
10
|
|
|
10
|
1
|
7382
|
my( $report ) = @_; |
1118
|
|
|
|
|
|
|
|
1119
|
10
|
50
|
|
|
|
53
|
my $branch = $report =~ /^Automated.+branch (.+?) / ? $1 : 'blead'; |
1120
|
10
|
50
|
|
|
|
57
|
my $version = $report =~ /^Automated.*for(?: branch \S+)? (.+) patch/ ? $1 : ''; |
1121
|
10
|
50
|
|
|
|
88
|
my $plevel = $report =~ /^Automated.+?(\S+)$/m |
1122
|
|
|
|
|
|
|
? $1 : ''; |
1123
|
10
|
50
|
|
|
|
25
|
if ( !$plevel ) { |
1124
|
0
|
0
|
|
|
|
0
|
$plevel = $report =~ /^Auto.*patch\s+\S+\s+(\S+)/ ? $1 : ''; |
1125
|
|
|
|
|
|
|
} |
1126
|
10
|
50
|
|
|
|
52
|
my $osname = $report =~ /\bon\s+(.*) - / ? $1 : ''; |
1127
|
10
|
50
|
|
|
|
49
|
my $osvers = $report =~ /\bon\s+.* - (.*)/? $1 : ''; |
1128
|
10
|
|
|
|
|
26
|
$osvers =~ s/\s+\(.*//; |
1129
|
10
|
50
|
|
|
|
38
|
my $archname = $report =~ /:.* \((.*)\)/ ? $1 : ''; |
1130
|
10
|
50
|
|
|
|
41
|
my $summary = $report =~ /^Summary: (.*)/m ? $1 : ''; |
1131
|
|
|
|
|
|
|
|
1132
|
10
|
|
|
|
|
58
|
return ( $version, $plevel, $osname, $osvers, $archname, $summary, $branch ); |
1133
|
|
|
|
|
|
|
} |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
=head2 get_regen_headers( $ddir ) |
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
C looks in C<$ddir> to find either |
1138
|
|
|
|
|
|
|
F or F (change 18851). |
1139
|
|
|
|
|
|
|
|
1140
|
|
|
|
|
|
|
Returns undef if not found or a string like C<< $^X "$regen_headers_pl" >> |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
=cut |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
sub get_regen_headers { |
1145
|
14
|
|
|
14
|
1
|
25367
|
my( $ddir ) = @_; |
1146
|
|
|
|
|
|
|
|
1147
|
14
|
|
33
|
|
|
142
|
$ddir ||= File::Spec->curdir; # Don't smoke in a dir "0"! |
1148
|
|
|
|
|
|
|
|
1149
|
14
|
|
|
|
|
560
|
my $regen_headers_pl = File::Spec->catfile( $ddir, "regen_headers.pl" ); |
1150
|
|
|
|
|
|
|
|
1151
|
14
|
100
|
|
|
|
450
|
-f $regen_headers_pl and return qq[$^X "$regen_headers_pl"]; |
1152
|
|
|
|
|
|
|
|
1153
|
12
|
|
|
|
|
232
|
$regen_headers_pl = File::Spec->catfile( $ddir, "regen.pl" ); |
1154
|
12
|
100
|
|
|
|
271
|
-f $regen_headers_pl and return qq[$^X "$regen_headers_pl"]; |
1155
|
|
|
|
|
|
|
|
1156
|
10
|
|
|
|
|
74
|
return; # Should this be "make regen_headers"? |
1157
|
|
|
|
|
|
|
} |
1158
|
|
|
|
|
|
|
|
1159
|
|
|
|
|
|
|
=head2 run_regen_headers( $ddir, $verbose ); |
1160
|
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
|
C gets its executable from C |
1162
|
|
|
|
|
|
|
and opens a pipe from it. warn()s on error. |
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
=cut |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
sub run_regen_headers { |
1167
|
0
|
|
|
0
|
1
|
0
|
my( $ddir, $verbose ) = @_; |
1168
|
|
|
|
|
|
|
|
1169
|
0
|
|
|
|
|
0
|
my $regen_headers = get_regen_headers( $ddir ); |
1170
|
|
|
|
|
|
|
|
1171
|
0
|
0
|
|
|
|
0
|
defined $regen_headers or do { |
1172
|
0
|
|
|
|
|
0
|
warn "Cannot find a regen_headers script\n"; |
1173
|
0
|
|
|
|
|
0
|
return; |
1174
|
|
|
|
|
|
|
}; |
1175
|
|
|
|
|
|
|
|
1176
|
0
|
0
|
|
|
|
0
|
$verbose and print "Running [$regen_headers]\n"; |
1177
|
0
|
|
|
|
|
0
|
local *REGENH; |
1178
|
0
|
0
|
|
|
|
0
|
if ( open REGENH, "$regen_headers |" ) { |
1179
|
0
|
0
|
|
|
|
0
|
while ( ) { $verbose > 1 and print } |
|
0
|
|
|
|
|
0
|
|
1180
|
0
|
0
|
|
|
|
0
|
close REGENH or do { |
1181
|
0
|
|
|
|
|
0
|
warn "Error in pipe [$regen_headers]\n"; |
1182
|
0
|
|
|
|
|
0
|
return; |
1183
|
|
|
|
|
|
|
} |
1184
|
|
|
|
|
|
|
} else { |
1185
|
0
|
|
|
|
|
0
|
warn "Cannot fork [$regen_headers]\n"; |
1186
|
0
|
|
|
|
|
0
|
return; |
1187
|
|
|
|
|
|
|
} |
1188
|
0
|
|
|
|
|
0
|
return 1; |
1189
|
|
|
|
|
|
|
} |
1190
|
|
|
|
|
|
|
|
1191
|
|
|
|
|
|
|
=head2 whereis( $prog ) |
1192
|
|
|
|
|
|
|
|
1193
|
|
|
|
|
|
|
Try to find an executable instance of C<$prog> in $ENV{PATH}. |
1194
|
|
|
|
|
|
|
|
1195
|
|
|
|
|
|
|
Rreturns a full file-path (with extension) to it. |
1196
|
|
|
|
|
|
|
|
1197
|
|
|
|
|
|
|
=cut |
1198
|
|
|
|
|
|
|
|
1199
|
|
|
|
|
|
|
sub whereis { |
1200
|
30
|
|
|
30
|
1
|
44519
|
my $prog = shift; |
1201
|
30
|
50
|
|
|
|
147
|
return undef unless $prog; # you shouldn't call it '0'! |
1202
|
30
|
50
|
|
|
|
212
|
$^O eq 'VMS' and return vms_whereis( $prog ); |
1203
|
30
|
|
50
|
|
|
554
|
my $logger = Test::Smoke::Logger->new(v => shift || 0); |
1204
|
|
|
|
|
|
|
|
1205
|
30
|
|
|
|
|
664
|
my $p_sep = $Config::Config{path_sep}; |
1206
|
30
|
|
|
|
|
412
|
my @path = split /\Q$p_sep\E/, $ENV{PATH}; |
1207
|
30
|
|
50
|
|
|
319
|
my @pext = split /\Q$p_sep\E/, $ENV{PATHEXT} || ''; |
1208
|
30
|
|
|
|
|
112
|
unshift @pext, ''; |
1209
|
|
|
|
|
|
|
|
1210
|
30
|
|
|
|
|
106
|
foreach my $dir ( @path ) { |
1211
|
241
|
|
|
|
|
1094
|
$logger->log_debug("Looking in %s for %s", $dir, $prog); |
1212
|
241
|
|
|
|
|
492
|
foreach my $ext ( @pext ) { |
1213
|
241
|
|
|
|
|
1908
|
my $fname = File::Spec->catfile( $dir, "$prog$ext" ); |
1214
|
241
|
|
|
|
|
878
|
$logger->log_debug(" check executable %s", $fname); |
1215
|
241
|
100
|
|
|
|
4339
|
if ( -x $fname ) { |
1216
|
18
|
|
|
|
|
125
|
$logger->log_info("Found %s as %s", $prog, $fname); |
1217
|
18
|
50
|
|
|
|
282
|
return $fname =~ /\s/ ? qq/"$fname"/ : $fname; |
1218
|
|
|
|
|
|
|
} |
1219
|
|
|
|
|
|
|
} |
1220
|
|
|
|
|
|
|
} |
1221
|
12
|
|
|
|
|
92
|
$logger->log_info("Could not find %s", $prog); |
1222
|
12
|
|
|
|
|
128
|
return ''; |
1223
|
|
|
|
|
|
|
} |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
=head2 vms_whereis( $prog ) |
1226
|
|
|
|
|
|
|
|
1227
|
|
|
|
|
|
|
First look in the SYMBOLS to see if C<$prog> is there. |
1228
|
|
|
|
|
|
|
Next look in the KFE-table C if it is there. |
1229
|
|
|
|
|
|
|
As a last resort we can scan C like we do on *nix/Win32 |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
=cut |
1232
|
|
|
|
|
|
|
|
1233
|
|
|
|
|
|
|
sub vms_whereis { |
1234
|
0
|
|
|
0
|
1
|
0
|
my $prog = shift; |
1235
|
|
|
|
|
|
|
|
1236
|
|
|
|
|
|
|
# Check SYMBOLS |
1237
|
0
|
|
|
|
|
0
|
eval { require VMS::DCLsym }; |
|
0
|
|
|
|
|
0
|
|
1238
|
0
|
0
|
|
|
|
0
|
if ( $@ ) { |
1239
|
0
|
|
|
|
|
0
|
require Carp; |
1240
|
0
|
|
|
|
|
0
|
Carp::carp( "Oops, cannot load VMS::DCLsym: $@" ); |
1241
|
|
|
|
|
|
|
} else { |
1242
|
0
|
|
|
|
|
0
|
my $syms = VMS::DCLsym->new; |
1243
|
0
|
0
|
|
|
|
0
|
return $prog if scalar $syms->getsym( $prog ); |
1244
|
|
|
|
|
|
|
} |
1245
|
|
|
|
|
|
|
# Check Known File Entry table (INSTALL LIST) |
1246
|
0
|
|
|
|
|
0
|
my $img_re = '^\s+([\w\$]+);\d+'; |
1247
|
|
|
|
|
|
|
my %kfe = map { |
1248
|
0
|
0
|
|
|
|
0
|
my $img = /$img_re/ ? $1 : ''; |
|
0
|
|
|
|
|
0
|
|
1249
|
0
|
|
|
|
|
0
|
( uc $img => undef ) |
1250
|
|
|
|
|
|
|
} grep /$img_re/ => qx/INSTALL LIST/; |
1251
|
0
|
0
|
|
|
|
0
|
return $prog if exists $kfe{ uc $prog }; |
1252
|
|
|
|
|
|
|
|
1253
|
0
|
|
|
|
|
0
|
require Config; |
1254
|
0
|
|
|
|
|
0
|
my $dclp_env = 'DCL$PATH'; |
1255
|
0
|
|
0
|
|
|
0
|
my $p_sep = $Config::Config{path_sep} || '|'; |
1256
|
0
|
|
0
|
|
|
0
|
my @path = split /\Q$p_sep\E/, $ENV{ $dclp_env }||""; |
1257
|
0
|
|
0
|
|
|
0
|
my @pext = ( $Config::Config{exe_ext} || $Config::Config{_exe}, '.COM' ); |
1258
|
|
|
|
|
|
|
|
1259
|
0
|
|
|
|
|
0
|
foreach my $dir ( @path ) { |
1260
|
0
|
|
|
|
|
0
|
foreach my $ext ( @pext ) { |
1261
|
0
|
|
|
|
|
0
|
my $fname = File::Spec->catfile( $dir, "$prog$ext" ); |
1262
|
0
|
0
|
|
|
|
0
|
if ( -x $fname ) { |
1263
|
0
|
0
|
|
|
|
0
|
return $ext eq '.COM' ? "\@$fname" : "MCR $fname"; |
1264
|
|
|
|
|
|
|
} |
1265
|
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
|
} |
1267
|
0
|
|
|
|
|
0
|
return ''; |
1268
|
|
|
|
|
|
|
} |
1269
|
|
|
|
|
|
|
|
1270
|
|
|
|
|
|
|
=head2 clean_filename( $fname ) |
1271
|
|
|
|
|
|
|
|
1272
|
|
|
|
|
|
|
C basically returns a vmsify() type of filename for |
1273
|
|
|
|
|
|
|
VMS, and returns an upcase filename for case-ignorant filesystems. |
1274
|
|
|
|
|
|
|
|
1275
|
|
|
|
|
|
|
=cut |
1276
|
|
|
|
|
|
|
|
1277
|
|
|
|
|
|
|
sub clean_filename { |
1278
|
304
|
|
|
304
|
1
|
571
|
my $fname = shift; |
1279
|
|
|
|
|
|
|
|
1280
|
304
|
50
|
|
|
|
726
|
if ( $^O eq 'VMS' ) { |
1281
|
0
|
|
|
|
|
0
|
my @parts = split /[.@#]/, $fname; |
1282
|
0
|
0
|
|
|
|
0
|
if ( @parts > 1 ) { |
1283
|
0
|
|
0
|
|
|
0
|
my $ext = ( pop @parts ) || ''; |
1284
|
0
|
|
|
|
|
0
|
$fname = join( "_", @parts ) . ".$ext"; |
1285
|
|
|
|
|
|
|
} |
1286
|
|
|
|
|
|
|
} |
1287
|
304
|
50
|
|
|
|
1174
|
return $NOCASE ? uc $fname : $fname; |
1288
|
|
|
|
|
|
|
} |
1289
|
|
|
|
|
|
|
|
1290
|
|
|
|
|
|
|
=head2 calc_timeout( $killtime[, $from] ) |
1291
|
|
|
|
|
|
|
|
1292
|
|
|
|
|
|
|
C calculates the timeout in seconds. |
1293
|
|
|
|
|
|
|
C<$killtime> can be one of two formats: |
1294
|
|
|
|
|
|
|
|
1295
|
|
|
|
|
|
|
=over 8 |
1296
|
|
|
|
|
|
|
|
1297
|
|
|
|
|
|
|
=item B<+hh:mm> |
1298
|
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
|
This format represents a duration and is the easy format as we only need |
1300
|
|
|
|
|
|
|
to translate that to seconds. |
1301
|
|
|
|
|
|
|
|
1302
|
|
|
|
|
|
|
=item B |
1303
|
|
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
This format represents a clock time (localtime). Calculate minutes |
1305
|
|
|
|
|
|
|
from midnight for both C<$killtime> and C, and get |
1306
|
|
|
|
|
|
|
the difference. If C<$from> is omitted, C |
1307
|
|
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
If C<$killtime> is the actual time, the timeout will be 24 hours! |
1309
|
|
|
|
|
|
|
|
1310
|
|
|
|
|
|
|
=back |
1311
|
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
|
=cut |
1313
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
sub calc_timeout { |
1315
|
9
|
|
|
9
|
1
|
2466
|
my( $killtime, $from ) = @_; |
1316
|
9
|
|
|
|
|
16
|
my $timeout = 0; |
1317
|
9
|
100
|
|
|
|
71
|
if ( $killtime =~ /^\+(\d+):([0-5]?[0-9])$/ ) { |
|
|
100
|
|
|
|
|
|
1318
|
2
|
|
|
|
|
10
|
$timeout = 60 * (60 * $1 + $2 ); |
1319
|
|
|
|
|
|
|
} elsif ( $killtime =~ /^((?:[0-1]?[0-9])|(?:2[0-3])):([0-5]?[0-9])$/ ) { |
1320
|
6
|
100
|
|
|
|
21
|
defined $from or $from = time; |
1321
|
6
|
|
|
|
|
247
|
my $time_min = 60 * $1 + $2; |
1322
|
6
|
|
|
|
|
20
|
my( $now_m, $now_h ) = (localtime $from)[1, 2]; |
1323
|
6
|
|
|
|
|
461
|
my $now_min = 60 * $now_h + $now_m; |
1324
|
6
|
|
|
|
|
14
|
my $kill_min = $time_min - $now_min; |
1325
|
6
|
100
|
|
|
|
16
|
$kill_min += 60 * 24 if $kill_min <= 0; |
1326
|
6
|
|
|
|
|
10
|
$timeout = 60 * $kill_min; |
1327
|
|
|
|
|
|
|
} |
1328
|
9
|
|
|
|
|
51
|
return $timeout; |
1329
|
|
|
|
|
|
|
} |
1330
|
|
|
|
|
|
|
|
1331
|
|
|
|
|
|
|
=head2 time_in_hhmm( $diff ) |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
Create a string telling elapsed time in days, hours, minutes, seconds |
1334
|
|
|
|
|
|
|
from the number of seconds. |
1335
|
|
|
|
|
|
|
|
1336
|
|
|
|
|
|
|
=cut |
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
sub time_in_hhmm { |
1339
|
133
|
|
|
133
|
1
|
4986
|
my $diff = shift; |
1340
|
|
|
|
|
|
|
|
1341
|
|
|
|
|
|
|
# Only show decimal point for diffs < 5 minutes |
1342
|
133
|
100
|
|
|
|
1725
|
my $digits = $diff =~ /\./ ? $diff < 5*60 ? 3 : 0 : 0; |
|
|
100
|
|
|
|
|
|
1343
|
133
|
|
|
|
|
433
|
my $days = int( $diff / (24*60*60) ); |
1344
|
133
|
|
|
|
|
418
|
$diff -= 24*60*60 * $days; |
1345
|
133
|
|
|
|
|
295
|
my $hour = int( $diff / (60*60) ); |
1346
|
133
|
|
|
|
|
205
|
$diff -= 60*60 * $hour; |
1347
|
133
|
|
|
|
|
455
|
my $mins = int( $diff / 60 ); |
1348
|
133
|
|
|
|
|
260
|
$diff -= 60 * $mins; |
1349
|
133
|
|
|
|
|
514
|
$diff = sprintf "%.${digits}f", $diff; |
1350
|
|
|
|
|
|
|
|
1351
|
133
|
|
|
|
|
232
|
my @parts; |
1352
|
133
|
100
|
|
|
|
365
|
$days and push @parts, sprintf "%d day%s", $days, $days == 1 ? "" : 's'; |
|
|
100
|
|
|
|
|
|
1353
|
133
|
100
|
|
|
|
466
|
$hour and push @parts, sprintf "%d hour%s", $hour, $hour == 1 ? "" : 's'; |
|
|
100
|
|
|
|
|
|
1354
|
133
|
100
|
|
|
|
541
|
$mins and push @parts, sprintf "%d minute%s",$mins, $mins == 1 ? "" : 's'; |
|
|
100
|
|
|
|
|
|
1355
|
133
|
100
|
100
|
|
|
1147
|
$diff && !$days && !$hour and push @parts, "$diff seconds"; |
|
|
|
100
|
|
|
|
|
1356
|
|
|
|
|
|
|
|
1357
|
133
|
|
|
|
|
1021
|
return join " ", @parts; |
1358
|
|
|
|
|
|
|
} |
1359
|
|
|
|
|
|
|
|
1360
|
|
|
|
|
|
|
=head2 do_pod2usage( %pod2usage_options ) |
1361
|
|
|
|
|
|
|
|
1362
|
|
|
|
|
|
|
If L is there then call its C. |
1363
|
|
|
|
|
|
|
In the other case, print the general message passed with the C key. |
1364
|
|
|
|
|
|
|
|
1365
|
|
|
|
|
|
|
=cut |
1366
|
|
|
|
|
|
|
|
1367
|
|
|
|
|
|
|
sub do_pod2usage { |
1368
|
0
|
|
|
0
|
1
|
0
|
my %p2u_opt = @_; |
1369
|
0
|
|
|
|
|
0
|
eval { require Pod::Usage }; |
|
0
|
|
|
|
|
0
|
|
1370
|
0
|
0
|
|
|
|
0
|
if ( $@ ) { |
1371
|
0
|
|
0
|
|
|
0
|
my $usage = $p2u_opt{myusage} || <<__EO_USAGE__; |
1372
|
|
|
|
|
|
|
Usage: $0 [options] |
1373
|
|
|
|
|
|
|
__EO_USAGE__ |
1374
|
0
|
|
|
|
|
0
|
print <
|
1375
|
|
|
|
|
|
|
$usage |
1376
|
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
|
Use 'perldoc $0' for the documentation. |
1378
|
|
|
|
|
|
|
Please install 'Pod::Usage' for easy access to the docs. |
1379
|
|
|
|
|
|
|
|
1380
|
|
|
|
|
|
|
EO_MSG |
1381
|
0
|
0
|
|
|
|
0
|
exit( exists $p2u_opt{exitval} ? $p2u_opt{exitval} : 1 ); |
1382
|
|
|
|
|
|
|
} else { |
1383
|
0
|
0
|
|
|
|
0
|
exists $p2u_opt{myusage} and delete $p2u_opt{myusage}; |
1384
|
0
|
|
|
|
|
0
|
Pod::Usage::pod2usage( @_ ); |
1385
|
|
|
|
|
|
|
} |
1386
|
|
|
|
|
|
|
} |
1387
|
|
|
|
|
|
|
|
1388
|
|
|
|
|
|
|
=head2 skip_config( $config ) |
1389
|
|
|
|
|
|
|
|
1390
|
|
|
|
|
|
|
Returns true if this config should be skipped. |
1391
|
|
|
|
|
|
|
C<$config> should be a B object. |
1392
|
|
|
|
|
|
|
|
1393
|
|
|
|
|
|
|
=cut |
1394
|
|
|
|
|
|
|
|
1395
|
|
|
|
|
|
|
sub skip_config { |
1396
|
18
|
|
|
18
|
1
|
77
|
my( $config ) = @_; |
1397
|
|
|
|
|
|
|
|
1398
|
18
|
|
100
|
|
|
52
|
my $skip = $config->has_arg(qw( -Uuseperlio -Dusethreads )) || |
1399
|
|
|
|
|
|
|
$config->has_arg(qw( -Uuseperlio -Duseithreads )) || |
1400
|
|
|
|
|
|
|
( $^O eq 'MSWin32' && |
1401
|
|
|
|
|
|
|
(( $config->has_arg(qw( -Duseithreads -Dusemymalloc )) && |
1402
|
|
|
|
|
|
|
!$config->has_arg( '-Uuseimpsys' ) ) || |
1403
|
|
|
|
|
|
|
( $config->has_arg(qw( -Dusethreads -Dusemymalloc )) && |
1404
|
|
|
|
|
|
|
!$config->has_arg( '-Uuseimpsys' ) )) |
1405
|
|
|
|
|
|
|
); |
1406
|
18
|
|
|
|
|
100
|
return $skip; |
1407
|
|
|
|
|
|
|
} |
1408
|
|
|
|
|
|
|
|
1409
|
|
|
|
|
|
|
=head2 skip_filter( $line ) |
1410
|
|
|
|
|
|
|
|
1411
|
|
|
|
|
|
|
C returns true if the filter rules apply to C<$line>. |
1412
|
|
|
|
|
|
|
|
1413
|
|
|
|
|
|
|
=cut |
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
sub skip_filter { |
1416
|
2339
|
|
|
2339
|
1
|
19530
|
local( $_ ) = @_; |
1417
|
|
|
|
|
|
|
# Still to be extended |
1418
|
2339
|
|
100
|
|
|
55866
|
return m,^ *$, || |
1419
|
|
|
|
|
|
|
m,^\t, || |
1420
|
|
|
|
|
|
|
m,^PERL=./perl\s+./runtests choose, || |
1421
|
|
|
|
|
|
|
m,^\s+AutoSplitting, || |
1422
|
|
|
|
|
|
|
m,^\./miniperl , || |
1423
|
|
|
|
|
|
|
m,^\s*autosplit_lib, || |
1424
|
|
|
|
|
|
|
m,^\s*PATH=\S+\s+./miniperl, || |
1425
|
|
|
|
|
|
|
m,^\s+Making , || |
1426
|
|
|
|
|
|
|
m,^make\[[12], || |
1427
|
|
|
|
|
|
|
m,make( TEST_ARGS=)? (_test|TESTFILE=|lib/\w+.pm), || |
1428
|
|
|
|
|
|
|
m,^make:.*Error\s+\d, || |
1429
|
|
|
|
|
|
|
m,^\s+make\s+lib/, || |
1430
|
|
|
|
|
|
|
m,^ *cd t &&, || |
1431
|
|
|
|
|
|
|
m,^if \(true, || |
1432
|
|
|
|
|
|
|
m,^else \\, || |
1433
|
|
|
|
|
|
|
m,^fi$, || |
1434
|
|
|
|
|
|
|
m,^lib/ftmp-security....File::Temp::_gettemp: Parent directory \((\.|/tmp/)\) is not safe, || |
1435
|
|
|
|
|
|
|
m,^File::Temp::_gettemp: Parent directory \((\.|/tmp/)\) is not safe, || |
1436
|
|
|
|
|
|
|
m,^ok$, || |
1437
|
|
|
|
|
|
|
m,^[-a-zA-Z0-9_/.]+\s*\.*\s*(ok|skipped|skipping test on this platform)$, || |
1438
|
|
|
|
|
|
|
m,^(xlc|cc_r) -c , || |
1439
|
|
|
|
|
|
|
# m,^\s+$testdir/, || |
1440
|
|
|
|
|
|
|
m,^sh mv-if-diff\b, || |
1441
|
|
|
|
|
|
|
m,File \S+ not changed, || |
1442
|
|
|
|
|
|
|
m,^(not\s+)?ok\s+\d+\s+[-#]\s+(?i:skip\S*[: ]),i || |
1443
|
|
|
|
|
|
|
# cygwin |
1444
|
|
|
|
|
|
|
m,^dllwrap: no export definition file provided, || |
1445
|
|
|
|
|
|
|
m,^dllwrap: creating one. but that may not be what you want, || |
1446
|
|
|
|
|
|
|
m,^(GNUm|M)akefile:\d+: warning: overriding commands for target `perlmain.o', || |
1447
|
|
|
|
|
|
|
m,^(GNUm|M)akefile:\d+: warning: ignoring old commands for target `perlmain.o', || |
1448
|
|
|
|
|
|
|
m,^\s+CCCMD\s+=\s+, || |
1449
|
|
|
|
|
|
|
# Don't know why BSD's make does this |
1450
|
|
|
|
|
|
|
m,^Extracting .*with variable substitutions, || |
1451
|
|
|
|
|
|
|
# Or these |
1452
|
|
|
|
|
|
|
m,cc\s+-o\s+perl.*perlmain.o\s+lib/auto/DynaLoader/DynaLoader\.a\s+libperl\.a, || |
1453
|
|
|
|
|
|
|
m,^\S+ is up to date, || |
1454
|
|
|
|
|
|
|
m,^( )?### , || |
1455
|
|
|
|
|
|
|
# Clean up Win32's output |
1456
|
|
|
|
|
|
|
m,^(?:\.\.[/\\])?[\w/\\-]+\.*ok$, || |
1457
|
|
|
|
|
|
|
m,^(?:\.\.[/\\])?[\w/\\-]+\.*ok\s+\d+(\.\d+)?\s*m?s$, || |
1458
|
|
|
|
|
|
|
m,^(?:\.\.[/\\])?[\w/\\-]+\.*ok\,\s+\d+/\d+\s+skipped:, || |
1459
|
|
|
|
|
|
|
m,^(?:\.\.[/\\])?[\w/\\-]+\.*skipped[: ], || |
1460
|
|
|
|
|
|
|
m,^\t?x?copy , || |
1461
|
|
|
|
|
|
|
m,\d+\s+[Ff]ile\(s\) copied, || |
1462
|
|
|
|
|
|
|
m,[/\\](?:mini)?perl\.exe ,|| |
1463
|
|
|
|
|
|
|
m,^\t?cd , || |
1464
|
|
|
|
|
|
|
m,^\b[ng]make\b, || |
1465
|
|
|
|
|
|
|
m,^\s+\d+/\d+ skipped: , || |
1466
|
|
|
|
|
|
|
m,^\s+all skipped: , || |
1467
|
|
|
|
|
|
|
m,^\s*pl2bat\.bat [\w\\]+, || |
1468
|
|
|
|
|
|
|
m,^Making , || |
1469
|
|
|
|
|
|
|
m,^Skip , || |
1470
|
|
|
|
|
|
|
m,^Creating library file: libExtTest\.dll\.a, || |
1471
|
|
|
|
|
|
|
m,^cc: warning 983: , |
1472
|
|
|
|
|
|
|
} |
1473
|
|
|
|
|
|
|
|
1474
|
|
|
|
|
|
|
1; |
1475
|
|
|
|
|
|
|
|
1476
|
|
|
|
|
|
|
=head1 COPYRIGHT |
1477
|
|
|
|
|
|
|
|
1478
|
|
|
|
|
|
|
(c) 2001-2014, All rights reserved. |
1479
|
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
|
* H. Merijn Brand |
1481
|
|
|
|
|
|
|
* Nicholas Clark |
1482
|
|
|
|
|
|
|
* Jarkko Hietaniemi |
1483
|
|
|
|
|
|
|
* Abe Timmerman |
1484
|
|
|
|
|
|
|
|
1485
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
1486
|
|
|
|
|
|
|
it under the same terms as Perl itself. |
1487
|
|
|
|
|
|
|
|
1488
|
|
|
|
|
|
|
See: |
1489
|
|
|
|
|
|
|
|
1490
|
|
|
|
|
|
|
* , |
1491
|
|
|
|
|
|
|
* |
1492
|
|
|
|
|
|
|
|
1493
|
|
|
|
|
|
|
This program is distributed in the hope that it will be useful, |
1494
|
|
|
|
|
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of |
1495
|
|
|
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. |
1496
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
=cut |