File Coverage

blib/lib/Test/Smoke/Util.pm
Criterion Covered Total %
statement 410 534 76.7
branch 238 364 65.3
condition 59 108 54.6
subroutine 29 33 87.8
pod 24 24 100.0
total 760 1063 71.5


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 is used.
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