File Coverage

blib/lib/Test/Smoke/Smoker.pm
Criterion Covered Total %
statement 206 592 34.8
branch 69 318 21.7
condition 12 81 14.8
subroutine 21 47 44.6
pod 22 22 100.0
total 330 1060 31.1


line stmt bran cond sub pod time code
1             package Test::Smoke::Smoker;
2 11     11   1224 use warnings;
  11         25  
  11         442  
3 11     11   91 use strict;
  11         25  
  11         396  
4              
5             our $VERSION = '0.047';
6              
7 11     11   78 use Config;
  11         37  
  11         477  
8 11     11   59 use Cwd;
  11         57  
  11         801  
9 11     11   80 use File::Spec::Functions qw( :DEFAULT abs2rel rel2abs );
  11         26  
  11         2262  
10 11     11   6376 use Capture::Tiny 'capture';
  11         220046  
  11         621  
11 11     11   95 use Test::Smoke::LogMixin;
  11         27  
  11         614  
12 11     11   70 use Test::Smoke::Util qw( get_smoked_Config skip_filter );
  11         54  
  11         480  
13              
14 11     11   626 BEGIN { eval q{ use Time::HiRes qw( time ) } }
  11     11   73  
  11         24  
  11         48  
15             { my $_orig_dft = select(STDERR); $|++; select(STDOUT); $|++; select($_orig_dft); $|++ }
16              
17             my %CONFIG = (
18             df_ddir => curdir(),
19             df_v => 0,
20             df_run => 1,
21             df_fdir => undef,
22             df_is56x => 0,
23             df_locale => '',
24             df_force_c_locale => 0,
25             df_defaultenv => 0,
26             df_perlio_only => 0,
27             df_harness_destruct => 2,
28              
29             df_is_vms => $^O eq 'VMS',
30             df_vmsmake => 'MMK',
31             df_harnessonly => scalar ($^O =~ /VMS/),
32             df_hasharness3 => 0,
33             df_harness3opts => '',
34              
35             df_is_win32 => $^O eq 'MSWin32',
36             df_w32cc => 'MSVC60',
37             df_w32make => 'nmake',
38             df_w32args => [ ],
39              
40             df_makeopt => "",
41             df_testmake => undef,
42              
43             df_skip_tests => undef,
44             );
45              
46             # Define some constants that we can use for
47             # specifying how far "make" got.
48             sub BUILD_MINIPERL() { -1 } # but no perl
49             sub BUILD_PERL () { 1 } # ok
50             sub BUILD_NOTHING () { 0 } # not ok
51              
52             sub HARNESS_RE1 () {
53             '(\S+\.t)(?:\s+[\d?]+){0,4}(?:\s+[\d?.]*%)?\s+([\d?]+(?:[-\s]+\d+-?)*)$'
54             }
55             sub HARNESS_RE2() { '^\s+(\d+(?:[-\s]+\d+)*-?)$' }
56              
57              
58             sub HARNESS3_RE_EXTRA() {
59             '^\s+(\d[0-9, -]*)'
60             }
61              
62             sub HARNESS3_RE_FAILED() {
63             '^(?:
64             (?:\ \ Failed\ tests?(?:\ number\(s\))?:\ \ )
65             )
66             (\d[0-9, -]*)'
67             }
68              
69             sub HARNESS3_RE_TODO() {
70             '^(?:
71             (?:\ \ TODO\ passed(?:\ number\(s\))?:\ \ \ )
72             )
73             (\d[0-9, -]*)'
74             }
75              
76              
77             =head1 NAME
78              
79             Test::Smoke::Smoker - OO interface to do one smoke cycle.
80              
81             =head1 SYNOPSIS
82              
83             use Test::Smoke;
84             use Test::Smoke::Smoker;
85              
86             open LOGFILE, "> mktest.out" or die "Cannot create 'mktest.out': $!";
87             my $buildcfg = Test::SmokeBuildCFG->new( $conf->{cfg} );
88             my $policy = Test::Smoke::Policy->new( '../', $conf->{v} );
89             my $smoker = Test::Smoke::Smoker->new( \*LOGFILE, $conf );
90              
91             foreach my $config ( $buildcfg->configurations ) {
92             $smoker->smoke( $config, $policy );
93             }
94              
95             =head1 DESCRIPTION
96              
97             The Test::Smoke::Smoker module, an OO interface to do one smoke cycle.
98              
99             =head1 CONSTANTS
100              
101             =over
102              
103             =item BUILD_MINIPERL
104              
105             =item BUILD_NOTHING
106              
107             =item BUILD_PERL
108              
109             =item HARNESS3_RE_EXTRA
110              
111             =item HARNESS3_RE_FAILED
112              
113             =item HARNESS3_RE_TODO
114              
115             =item HARNESS_RE1
116              
117             =item HARNESS_RE2
118              
119             =back
120              
121             =head1 METHODS
122              
123             =head2 Test::Smoke::Smoker->new( \*GLOB, %args )
124              
125             C takes a mandatory (opened) filehandle and some other options:
126              
127             ddir build directory
128             fdir The forest source
129             v verbose level: 0..2
130             defaultenv 'make test' without $ENV{PERLIO}
131             is56x skip the PerlIO stuff?
132             locale do another testrun with $ENV{LC_ALL}
133             force_c_locale set $ENV{LC_ALL} = 'C' for all smoke runs
134              
135             is_win32 is this MSWin32?
136             w32cc the CCTYPE for MSWin32 (MSVCxx BORLAND GCC)
137             w32make the maker to use for CCTYPE
138              
139             =cut
140              
141             sub new {
142 20     20 1 35082 my $proto = shift;
143 20   33     167 my $class = ref $proto || $proto;
144              
145 20         36 my $fh = shift;
146              
147 20 50       75 unless ( ref $fh eq 'GLOB' ) {
148 0         0 require Carp;
149 0         0 Carp::croak(sprintf "Usage: %s->new( \\*FH, %%args )", __PACKAGE__);
150             }
151              
152 20 50       162 my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();
  0 50       0  
153              
154             my %args = map {
155 20         69 ( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
  28         200  
  28         133  
156 28         121 ( $key => $args_raw{ $_ } );
157             } keys %args_raw;
158              
159             my %fields = map {
160 440 100       821 my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
161 440         760 ( $_ => $value )
162 20         44 } keys %{ Test::Smoke::Smoker->config( 'all_defaults' ) };
  20         60  
163              
164 20         122 $fields{logfh} = $fh;
165 20         145 select( ( select( $fh ), $|++ )[0] );
166 20 50       55 $fields{defaultenv} = 1 if $fields{is56x};
167 20 50       82 $^O =~ /VMS/i and $fields{is_vms} = 1;
168              
169 20 100       46 unless ( defined $fields{testmake} ) {
170 18         42 $fields{testmake} = 'make';
171 18 50       53 $fields{is_win32} and $fields{testmake} = $fields{w32make};
172 18 50       52 $fields{is_vms} and $fields{testmake} = $fields{vmsmake};
173             }
174 20         197 my $self = bless { %fields }, $class;
175              
176 20         159 return $self;
177             }
178              
179             =head2 $smoker->verbose
180              
181             Get verbosity.
182              
183             =cut
184              
185 332     332 1 1064 sub verbose { $_[0]->{v} }
186              
187             =head2 $smoker->mark_in()
188              
189             Write the current timestamp with 'Start' marker to the logfile.
190              
191             =cut
192              
193             sub mark_in {
194 0     0 1 0 my $self = shift;
195 0         0 $self->log( sprintf "Started smoke at %d\n", time() );
196             }
197              
198             =head2 $smoker->mark_out()
199              
200             Write the current timestamp with 'Stopped' marker to the logfile.
201              
202             =cut
203              
204             sub mark_out {
205 0     0 1 0 my $self = shift;
206 0         0 $self->log( sprintf "Stopped smoke at %d\n", time() );
207             }
208              
209             =head2 Test::Smoke::Smoker->config( $key[, $value] )
210              
211             C is an interface to the package lexical C<%CONFIG>,
212             which holds all the default values for the C arguments.
213              
214             With the special key B this returns a reference
215             to a hash holding all the default values.
216              
217             =cut
218              
219             sub config {
220 39     39 1 587 my $dummy = shift;
221              
222 39         70 my $key = lc shift;
223              
224 39 100       84 if ( $key eq 'all_defaults' ) {
225             my %default = map {
226 21         329 my( $pass_key ) = $_ =~ /^df_(.+)/;
  462         1448  
227 462         1125 ( $pass_key => $CONFIG{ $_ } );
228             } grep /^df_/ => keys %CONFIG;
229 21         166 return \%default;
230             }
231              
232 18 50       39 return undef unless exists $CONFIG{ "df_$key" };
233              
234 18 50       29 $CONFIG{ "df_$key" } = shift if @_;
235              
236 18         39 return $CONFIG{ "df_$key" };
237             }
238              
239             =head2 $smoker->tty( $message )
240              
241             Prints a message to the default filehandle.
242              
243             =cut
244              
245             sub tty {
246 0     0 1 0 my $self = shift;
247 0         0 my $message = join "", @_;
248 0         0 $self->log_warn($message);
249             }
250              
251             =head2 $smoker->log( $message )
252              
253             Prints a message to the logfile, filehandle.
254              
255             =cut
256              
257             sub log {
258 0     0 1 0 my $self = shift;
259 0         0 my $message = join "", @_;
260 0         0 print { $self->{logfh} } $message;
  0         0  
261             }
262              
263             =head2 $smoker->ttylog( $message )
264              
265             Prints a message to both the default and the logfile filehandles.
266              
267             =cut
268              
269             sub ttylog {
270 0     0 1 0 my $self = shift;
271 0         0 $self->log( @_ );
272 0         0 $self->tty( @_ );
273             }
274              
275             =head2 $smoker->smoke( $config[, $policy] )
276              
277             C takes a B object and runs all
278             the basic steps as (private) object methods.
279              
280             =cut
281              
282             sub smoke {
283 0     0 1 0 my( $self, $config, $policy ) = @_;
284              
285 0 0       0 $self->{is_vms} and $self->_vms_rooted_logical;
286              
287 0         0 $self->make_distclean;
288              
289 0 0       0 $self->{v} > 1 and $self->extra_manicheck;
290              
291 0         0 $self->handle_policy( $policy, $config->policy );
292              
293 0         0 my $c_result = $self->Configure( $config );
294             # Log the compiler info now, the last config could fail
295             { # can we config.sh without Configure success?
296 0         0 my %cinfo = get_smoked_Config( $self->{ddir} => qw(
  0         0  
297             cc ccversion gccversion
298             ));
299 0   0     0 my $version = $cinfo{gccversion} || $cinfo{ccversion};
300             $self->log( "\nCompiler info: $cinfo{cc} version $version\n" )
301 0 0       0 if $cinfo{cc};
302             }
303              
304 0 0       0 $c_result or do {
305 0         0 $self->ttylog( "Unable to configure perl in this configuration\n" );
306 0         0 return 0;
307             };
308              
309 0         0 my %sconf = get_smoked_Config( $self->{ddir} => 'ldlibpthname' );
310 0 0       0 exists $sconf{ldlibpthname} or $sconf{ldlibpthname} = "";
311             $sconf{ldlibpthname} and
312             local $ENV{ $sconf{ldlibpthname} } = $ENV{ $sconf{ldlibpthname} } || '',
313 0 0 0     0 substr( $ENV{ $sconf{ldlibpthname} }, 0, 0) =
314             "$self->{ddir}$Config{path_sep}";
315              
316 0         0 my $build_stat = $self->make_( $config );
317              
318 0 0       0 $build_stat == BUILD_MINIPERL and do {
319 0         0 $self->ttylog( "Unable to make anything but miniperl",
320             " in this configuration\n" );
321 0         0 return $self->make_minitest;
322             };
323              
324 0 0       0 $build_stat == BUILD_NOTHING and do {
325 0         0 $self->ttylog( "Unable to make perl in this configuration\n" );
326 0         0 return 0;
327             };
328              
329 0 0       0 $self->make_test_prep or do {
330 0         0 $self->ttylog( "Unable to test perl in this configuration\n" );
331 0         0 return 0;
332             };
333              
334 0         0 $self->make_test( $config );
335              
336             # $self->{is_vms} and $self->_unset_rooted_logical;
337 0         0 return 1;
338             }
339              
340             =head2 $smoker->make_distclean( )
341              
342             C runs C<< make -i distclean 2>/dev/null >>
343              
344             =cut
345              
346             sub make_distclean {
347 0     0 1 0 my $self = shift;
348              
349 0         0 $self->tty( "make distclean ..." );
350 0 0 0     0 if ( $self->{fdir} && -d $self->{fdir} ) {
351 0         0 require Test::Smoke::Syncer;
352             my %options = (
353             hdir => $self->{fdir},
354 0         0 ddir => cwd(),
355             v => 0,
356             );
357 0         0 my $distclean = Test::Smoke::Syncer->new( hardlink => %options );
358 0         0 $distclean->clean_from_directory( $self->{fdir}, 'mktest.out' );
359             } else {
360 0 0       0 my $target = $self->{is_vms} ? 'realclean' : '-i distclean';
361 0         0 $self->_make( "$target 2>/dev/null" );
362             }
363             }
364              
365             =head2 $smoker->extra_manicheck( )
366              
367             C will only work for C<< $self->{v} > 1 >> and does
368             an extra integrity check comparing F and the
369             source-tree. Output is send to the tty.
370              
371             =cut
372              
373             sub extra_manicheck {
374 0     0 1 0 my $self = shift;
375 0 0       0 $self->{v} > 1 or return;
376              
377 0         0 require Test::Smoke::SourceTree;
378 0         0 Test::Smoke::SourceTree->import( qw( :mani_const ) );
379 0         0 my $tree = Test::Smoke::SourceTree->new( $self->{ddir} );
380 0         0 my $mani_check = $tree->check_MANIFEST(qw( mktest.out mktest.rpt ));
381 0         0 foreach my $file ( sort keys %$mani_check ) {
382 0 0       0 if ( $mani_check->{ $file } == ST_MISSING() ) {
    0          
383 0         0 $self->tty( "manicheck: missing '$file' (not in source-tree)\n" );
384             } elsif ( $mani_check->{ $file } == ST_UNDECLARED() ) {
385 0         0 $self->tty( "manicheck: extra '$file' (not in MANIFEST)\n" );
386             }
387             }
388             }
389              
390             =head2 $smoker->handle_policy( $policy, @substs );
391              
392             C will try to apply the substition rules and then
393             write the file F.
394              
395             =cut
396              
397             sub handle_policy {
398 0     0 1 0 my $self = shift;
399 0         0 my( $policy, @substs ) = @_;
400              
401 0 0       0 return unless UNIVERSAL::isa( $policy, 'Test::Smoke::Policy' );
402              
403 0         0 $self->tty( "\nCopy Policy.sh ..." );
404 0         0 $policy->reset_rules;
405 0 0       0 if ( @substs ) {
406 0         0 $policy->set_rules( $_ ) foreach @substs;
407             }
408 0         0 $policy->write;
409             }
410              
411             =head2 $smoker->Configure( $config )
412              
413             C sorts out the MSWin32 mess and calls F<./Configure>
414              
415             returns true if a makefile was created
416              
417             =cut
418              
419             sub Configure {
420 0     0 1 0 my $self = shift;
421 0         0 my( $config, $policy ) = @_;
422              
423 0         0 $self->tty( "\nConfigure ..." );
424 0         0 my $makefile = '';
425 0 0       0 if ( $self->{is_win32} ) {
    0          
426 0         0 my @w32args = @{ $self->{w32args} };
  0         0  
427 0         0 @w32args = @w32args[ 4 .. $#w32args ];
428 0 0       0 my $w32_cfg = "$config" =~ /-DCCTYPE=/
429             ? "$config" : "$config -DCCTYPE=$self->{w32cc}";
430              
431             $makefile = $self->_run( "./Configure $w32_cfg",
432             \&Test::Smoke::Util::Configure_win32,
433 0         0 $self->{w32make}, @w32args );
434             } elsif ( $self->{is_vms} ) {
435 0         0 my $vms_cfg = $config->vms;
436 0         0 $self->_run( qq/\@configure -"des" $vms_cfg/ );
437 0         0 $makefile = 'DESCRIP.MMS';
438             } else {
439 0         0 $self->_run( "./Configure -des $config" );
440 0         0 $makefile = 'Makefile';
441             }
442 0         0 return -f $makefile;
443             }
444              
445             =head2 $smoker->make_( )
446              
447             C will run make.
448              
449             returns true if a perl executable is found
450              
451             =cut
452              
453             sub make_ {
454 0     0 1 0 my $self = shift;
455 0         0 my $config = shift;
456              
457 0         0 $self->tty( "\nmake ..." );
458 0         0 my $make_args = "";
459 0 0 0     0 $self->{is_vms} && $config->has_arg( '-Dusevmsdebug' ) and
460             $make_args = qq[/macro=("__DEBUG__=1")];
461              
462 0 0 0     0 $self->{is_win32} && $config->has_arg( '-Uuseshrplib' ) and
463             $make_args = "static";
464              
465 0         0 my $make_output = $self->_make( $make_args );
466              
467 0 0       0 if ( $self->{is_win32} ) { # Win32 creates config.sh during make
468 0         0 my %cinfo = get_smoked_Config( $self->{ddir} => qw(
469             cc ccversion gccversion
470             ));
471 0   0     0 my $version = $cinfo{gccversion} || $cinfo{ccversion};
472             $self->log( "\nCompiler info: $cinfo{cc} version $version\n" )
473 0 0       0 if $cinfo{cc};
474              
475 0 0       0 $self->{w32cc} =~ /MSVC|BORLAND|GCC/ and $self->tty( "\n$make_output\n" );
476             }
477              
478 0   0     0 my $exe_ext = $Config{_exe} || $Config{exe_ext};
479 0         0 my $miniperl = "miniperl$exe_ext";
480 0         0 my $perl = "perl$exe_ext";
481             $perl = "ndbg$perl"
482 0 0 0     0 if $self->{is_vms} && $config->has_arg( '-Dusevmsdebug' );
483             $perl = "perl-static$exe_ext"
484 0 0 0     0 if $self->{is_win32} && $config->has_arg( '-Uuseshrplib' );
485              
486 0         0 $self->{_miniperl_bin} = $miniperl;
487 0         0 $self->{_perl_bin} = $perl;
488              
489 0 0       0 -x $miniperl or return BUILD_NOTHING;
490             return -x $perl
491 0 0       0 ? $self->{_run_exit} ? BUILD_MINIPERL : BUILD_PERL
    0          
492             : BUILD_MINIPERL;
493             }
494              
495             =head2 make_test_prep( )
496              
497             Run C<< I >> and check if F exists.
498              
499             =cut
500              
501             sub make_test_prep {
502 0     0 1 0 my $self = shift;
503 0 0       0 $self->{harnessonly} and return 1; # no test-prep target
504              
505 0         0 my $perl = catfile( "t", $self->{_perl_bin} );
506              
507 0 0       0 $self->{run} and unlink $perl;
508 0         0 $self->_make( "test-prep" );
509              
510 0 0       0 return $self->{is_win32} ? -f $perl : -l $perl;
511             }
512              
513             =head2 $smoker->make_test( )
514              
515             =cut
516              
517             sub make_test {
518 0     0 1 0 my $self = shift;
519              
520 0         0 $self->set_skip_tests;
521              
522 0         0 my( $config ) = @_;
523 0         0 my $config_args = "$config";
524              
525 0         0 $self->tty( "\n Tests start here:\n" );
526              
527             # No use testing different io layers without PerlIO
528             # just output 'stdio' for mkovz.pl
529             my @layers = ( ($config_args =~ /-Uuseperlio\b/) || $self->{defaultenv} )
530             ? qw( stdio )
531             : $self->{perlio_only}
532 0 0 0     0 ? qw( perlio )
    0          
533             : qw( stdio perlio );
534              
535 0         0 my @locales;
536 0 0 0     0 if ( !($config_args =~ /-Uuseperlio\b/ || $self->{defaultenv}) &&
      0        
537             $self->{locale} ) {
538 0         0 @locales = split ' ', $self->{locale};
539 0         0 push @layers, ( 'locale' ) x @locales;
540             }
541              
542 0         0 delete $ENV{PERL_UNICODE};
543 0         0 foreach my $perlio ( @layers ) {
544 0         0 my $had_LC_ALL = exists $ENV{LC_ALL};
545             local( $ENV{PERLIO}, $ENV{LC_ALL} ) =
546 0 0       0 ( "", defined $ENV{LC_ALL} ? $ENV{LC_ALL} : "" );
547 0         0 my $perlio_logmsg = $perlio;
548 0 0       0 if ( $perlio ne 'locale' ) {
549 0         0 $ENV{PERLIO} = $perlio;
550 0 0       0 $self->{is_win32} and $ENV{PERLIO} .= " :crlf";
551 0 0       0 $ENV{LC_ALL} = 'C' if $self->{force_c_locale};
552 0 0       0 $ENV{LC_ALL} or delete $ENV{LC_ALL};
553             # make default 'make test' runs possible
554 0 0       0 delete $ENV{PERLIO} if $self->{defaultenv};
555             } else {
556 0         0 my $this_locale = pop(@locales);
557 0         0 $ENV{LC_ALL} = $this_locale;
558 0         0 $perlio_logmsg .= ":$this_locale";
559             }
560 0         0 $self->ttylog( "TSTENV = $perlio_logmsg\t" );
561              
562 0 0       0 unless ( $self->{run} ) {
563 0         0 $self->ttylog( "bailing out (--norun)...\n" );
564 0         0 next;
565             }
566              
567 0 0       0 if ( $self->{harnessonly} ) {
568 0         0 $self->log_debug("[make test] Test::Harness ONLY");
569              
570             $self->{harness3opts} and
571 0 0       0 local $ENV{HARNESS_OPTIONS} = $self->{harness3opts};
572              
573 0         0 $self->make_test_harness( $config );
574              
575             } else {
576             my $test_target = $self->{is_vms}
577 0 0       0 ? 'test' : $self->{is56x} ? 'test-notty' : '_test';
    0          
578              
579             # MSWin32 builds from its own directory
580 0 0       0 if ( $self->{is_win32} ) {
581             # $config->has_arg( '-Uuseshrplib' )
582             # and $test_target = 'static-test';
583             # $self->_run_harness_target( $test_target );
584 0         0 $self->make_test_harness( $config );
585             } else {
586 0         0 $self->_run_TEST_target( $test_target, 1 );
587             }
588 0         0 $self->tty( "\n" );
589             }
590 0 0 0     0 !$had_LC_ALL && exists $ENV{LC_ALL} and delete $ENV{LC_ALL};
591             }
592              
593 0         0 $self->unset_skip_tests;
594              
595 0         0 return 1;
596             }
597              
598             =head2 $self->extend_with_harness( @nok )
599              
600             =cut
601              
602             sub extend_with_harness {
603 0     0 1 0 my $self = shift;
604 0         0 my %inconsistent = $self->_transform_testnames( @_ );
605 0         0 my @harness = sort keys %inconsistent;
606 0         0 my $harness_re1 = HARNESS_RE1();
607 0         0 my $harness_re2 = HARNESS_RE2();
608 0 0       0 if ( @harness ) {
609              
610             # @20051016 By request of Nicholas Clark
611 0         0 local $ENV{PERL_DESTRUCT_LEVEL} = $self->{harness_destruct};
612 0         0 local $ENV{PERL_SKIP_TTY_TEST} = 1;
613              
614             # I'm not happy with this PERLSHR approach for VMS
615 0   0     0 local $ENV{PERLSHR} = $ENV{PERLSHR} || "";
616             $self->{is_vms} and
617             $ENV{PERLSHR} = catfile( $self->{ddir},
618 0 0       0 'PERLSHR' . $Config{_exe} );
619 0         0 my $harness = join " ", @harness;
620 0         0 $self->tty( "\nExtending failures with harness:\n\t$harness\n" );
621 0         0 my $changed_dir;
622 0 0       0 chdir 't' and $changed_dir = 1;
623 0         0 my $all_ok = 0;
624 0         0 my $tst_perl = catfile( curdir(), 'perl' );
625 0 0       0 my $verbose = $self->{v} > 1 ? "-v" : "";
626 0         0 my @run_harness = $self->_run( "$tst_perl harness $verbose $harness" );
627 0         0 my $harness_out = $self->_parse_harness_output( \%inconsistent, $all_ok,
628             @run_harness );
629              
630             # safeguard against empty results
631 0   0     0 $inconsistent{ $_ } ||= 'FAILED' for keys %inconsistent;
632 0         0 $harness_out =~ s/^\s*$//;
633 0 0       0 if ( $all_ok ) {
634             $harness_out .= scalar keys %inconsistent
635             ? "Inconsistent test results (between TEST and harness):\n" .
636             join "", map {
637 0 0       0 my $dots = '.' x (40 - length $_ );
  0 0       0  
638 0         0 " $_${dots}$inconsistent{ $_ }\n";
639             } keys %inconsistent
640             : $harness_out ? "" : "All tests successful.";
641             } else {
642             $harness_out .= scalar keys %inconsistent
643             ? "Inconsistent test results (between TEST and harness):\n" .
644             join "", map {
645 0 0       0 my $dots = '.' x (40 - length $_ );
  0         0  
646 0         0 " $_${dots}$inconsistent{ $_ }\n";
647             } keys %inconsistent
648             : "";
649             }
650 0         0 $self->ttylog("\n", $harness_out, "\n" );
651 0 0       0 $changed_dir and chdir updir();
652             }
653             }
654              
655             =head2 $smoker->make_test_harness
656              
657             Use Test::Harness (the test_harness target) to get the failing test
658             information and do not bother with TEST.
659              
660             =cut
661              
662             sub make_test_harness {
663 0     0 1 0 my( $self, $config ) = @_;
664              
665 0         0 my $target= "test_harness";
666 0         0 my $debugging = "";
667              
668 0 0       0 if ( $self->{is_vms} ) {
    0          
669              
670 0 0       0 $debugging = $config->has_arg( '-Dusevmsdebug' )
671             ? qq[/macro=("__DEBUG__=1")]
672             : "";
673              
674             } elsif ($self->{is_win32}) {
675 0 0       0 $target = $config->has_arg( '-Uuseshrplib' ) ? "static-test" : "test";
676             }
677              
678 0 0       0 if ( $self->{hasharness3} ) {
679 0         0 $self->log_debug("[make_test_harness] Test::Harness >= 3");
680 0         0 $self->_run_harness3_target( $target, $debugging );
681             } else {
682 0         0 $self->log_debug("[make_test_harness] Test::Harness < 3");
683 0         0 $self->_run_harness_target( $target, $debugging );
684             }
685             }
686              
687             =head2 $smoker->_run_harness_target( $target, $extra )
688              
689             The command to run C differs based on platform, so
690             the arguments have to be passed into general routine. C<$target>
691             specifies the makefile-target, C<$makeopt> specifies the extra options
692             for the make program.
693              
694             =cut
695              
696             sub _run_harness_target {
697 0     0   0 my( $self, $target, $extra ) = @_;
698              
699 0         0 my $seenheader = 0;
700 0         0 my @failed = ( );
701              
702 0         0 my $harness_re1 = HARNESS_RE1();
703 0         0 my $harness_re2 = HARNESS_RE2();
704              
705 0         0 my $tst = $self->_make_fork( $target, $extra );
706              
707 0         0 my ($line, $last);
708 0         0 while ( $line = <$tst> ) {
709             #$self->log_debug($line);
710              
711             # This line with timings only has to be logged to .out.
712 0 0       0 $line =~ / \b (?:Files | u) = .+ Tests = [0-9]+ /xi
713             and $self->log($line);
714              
715 0 0       0 $last and next;
716 0 0       0 $line =~ /All tests successful/
717             and push( @failed, $line ), $last++, next;
718              
719 0 0       0 $line =~ /Failed Test\s+Stat/
720             and $seenheader = 1, next;
721 0 0       0 $seenheader or next;
722              
723 0         0 my( $name, $fail ) = $line =~ m/$harness_re1/;
724 0 0       0 if ( $name ) {
725 0         0 my $dots = '.' x (40 - length $name );
726 0         0 $self->log_debug("[known failed test] $name");
727 0         0 push @failed, " $name${dots}FAILED $fail\n";
728             } else {
729 0         0 ( $fail ) = $line =~ m/$harness_re2/;
730 0 0       0 next unless $fail;
731 0         0 push @failed, " " x 51 . "$fail\n";
732             }
733             }
734 0         0 my @dump = <$tst>; # Read trailing output from pipe
735              
736 0 0       0 close $tst or do {
737 0   0     0 my $error = $! || ( $? >> 8);
738 0         0 require Carp;
739 0         0 Carp::carp("\nerror while running harness target '$target': $error");
740             };
741              
742 0         0 $self->ttylog( "\n", join( "", @failed ), "\n" );
743 0         0 $self->tty( "Archived results...\n" );
744             }
745              
746             =head2 $smoker->_run_harness3_target( $target, $extra )
747              
748             The command to run C differs based on platform, so
749             the arguments have to be passed into general routine. C<$target>
750             specifies the makefile-target, C<$makeopt> specifies the extra options
751             for the make program.
752              
753             =cut
754              
755             sub _run_harness3_target {
756 0     0   0 my( $self, $target, $extra ) = @_;
757              
758 0         0 my $harness3_failed = HARNESS3_RE_FAILED();
759 0         0 my $harness3_todo = HARNESS3_RE_TODO();
760 0         0 my $harness3_extra = HARNESS3_RE_EXTRA();
761 0         0 my $seenheader = 0;
762 0         0 my @failed = ( );
763              
764 0         0 my $tst = $self->_make_fork( $target, $extra );
765              
766 0         0 my $line;
767             my $file;
768 0         0 my $found = 0;
769 0         0 while ( $line = <$tst> ) {
770             #$self->log_debug($line);
771              
772             # This line with timings only has to be logged to .out.
773 0 0       0 $line =~ / \b (?:Files | u) = .+ Tests = [0-9]+ /xi
774             and $self->log($line);
775              
776 0 0       0 $line =~ /All tests successful/
777             and push( @failed, $line ), next;
778              
779 0 0       0 $line =~ /Test Summary Report/ and $seenheader = 1, next;
780 0 0       0 $seenheader or next;
781              
782 0         0 my( $tname ) = $line =~ /^\s*(.+(?:\.t)?)\s+\(Wstat/;
783 0 0       0 if ( $tname ) {
784 0 0 0     0 if ($file and not $found) {
785 0         0 $self->log_debug("[weird failed test] $file");
786 0         0 push @failed, "${file}??????\n";
787             }
788 0         0 my $ntest = $self->_normalize_testname( $tname );
789 0         0 my $dots = '.' x (60 - length $ntest);
790 0         0 $file = $ntest . $dots;
791 0         0 $found = 0;
792 0         0 next;
793             }
794              
795 0         0 my( $failed ) = $line =~ /$harness3_failed/x;
796 0 0       0 if ( $failed ) {
797 0         0 $self->log_debug("[known failed test] $file");
798 0         0 push @failed, "${file}FAILED\n";
799 0         0 push @failed, " $failed\n";
800 0         0 $found = 1;
801 0         0 next;
802             }
803              
804 0         0 my( $todo ) = $line =~ /$harness3_todo/x;
805 0 0       0 if ( $todo ) {
806 0         0 $self->log_debug("[todo test passed] $file");
807 0         0 push @failed, "${file}PASSED\n";
808 0         0 push @failed, " $todo\n";
809 0         0 $found = 1;
810 0         0 next;
811             }
812              
813 0         0 my ( $extra ) = $line =~ /$harness3_extra/x;
814 0 0       0 if ( $extra) {
815 0         0 push @failed, " $extra\n";
816 0         0 next;
817             }
818              
819 0         0 my( $parse_error ) = $line =~ /^ Parse errors: (.+)/;
820 0 0       0 if ( $parse_error ) {
821 0         0 $self->log_debug("[TAP-error test] $file");
822 0         0 push @failed, "${file}FAILED\n";
823 0         0 push @failed, " $parse_error\n";
824 0         0 $found = 1;
825 0         0 next;
826             }
827              
828 0         0 my( $exit_status ) = $line =~ /^ (Non-zero exit status: .+)/;
829 0 0       0 if ( $exit_status ) {
830 0         0 $self->log_debug("[died test] $file");
831 0         0 push @failed, "${file}FAILED\n";
832 0         0 push @failed, " $exit_status\n";
833 0         0 $found = 1;
834 0         0 next;
835             }
836             }
837 0 0 0     0 if ($file and not $found) {
838 0         0 $self->log_debug("[unknown failure] $file");
839 0         0 push @failed, "${file}??????\n";
840             }
841              
842 0         0 my @dump = <$tst>; # Read trailing output from pipe
843              
844 0 0       0 close $tst or do {
845 0   0     0 my $error = $! || ( $? >> 8);
846 0         0 require Carp;
847 0         0 Carp::carp("\nerror while running harness target '$target': $error" );
848             };
849              
850 0         0 $self->ttylog( "\n", join( "", @failed ), "\n" );
851 0         0 $self->tty( "Archived results...\n" );
852             }
853              
854             sub _run_TEST_target {
855 0     0   0 my( $self, $target, $extend ) = @_;
856 0 0       0 !$target and do {
857 0         0 require Carp;
858 0         0 Carp::confess("No target in _run_TEST_target");
859             };
860              
861 0         0 my @nok;
862 0         0 my $tst = $self->_make_fork( $target );
863 0         0 my $ok;
864              
865 0         0 while (<$tst>) {
866 0         0 $self->log_debug($_);
867 0 0       0 skip_filter( $_ ) and next;
868              
869             # make mkovz.pl's life easier
870 0         0 s/(.)(TSTENV\s+=\s+\w+)/$1\n$2/;
871              
872 0 0       0 if (m/^u=.*tests=/) {
873 0         0 s/(\d\.\d*) /sprintf "%.2f ", $1/ge;
  0         0  
874 0         0 $self->log( $_ );
875             } else {
876 0   0     0 $ok ||= m/^All tests successful/;
877 0         0 push @nok, $_;
878             }
879 0         0 $self->tty( $_ );
880             }
881 0 0       0 close $tst or do {
882 0   0     0 my $error = $! || ( $? >> 8);
883 0         0 $self->tty("\nError while reading test-results: $error");
884             };
885              
886             # $self->log( map { " $_" } @nok );
887 0 0       0 if ( grep m/^All tests successful/, @nok ) {
    0          
888 0         0 $self->log( "All tests successful.\n" );
889 0         0 $self->tty( "\nOK, archive results ..." );
890             $self->{patch} and
891 0 0       0 $nok[0] =~ s/\./ for .patch = $self->{patch}./;
892             } elsif ( !$extend ) {
893 0         0 $self->ttylog( map { " $_" } @nok );
  0         0  
894             } else {
895 0         0 $self->extend_with_harness( @nok );
896             }
897             }
898              
899             =head2 $self->make_minitest
900              
901             C was unable to build a I executable, but managed to build
902             I, so we do C<< S >>.
903              
904             =cut
905              
906             sub make_minitest {
907 0     0 1 0 my $self = shift;
908              
909 0         0 $self->ttylog( "TSTENV = minitest\t" );
910              
911 0 0       0 if ($self->{is_win32}) {
912 0         0 $self->_run_harness_target( "minitest" );
913             } else {
914 0         0 $self->_run_TEST_target( "minitest", 0 );
915             }
916              
917 0         0 $self->tty( "\n" );
918 0         0 return 1;
919             }
920              
921             =head2 $self->_parse_harness_output( $\%notok, $all_ok, @lines )
922              
923             Factor out the parsing of the Test::Harness output, as it seems subject
924             to change.
925              
926             =cut
927              
928             sub _parse_harness_output {
929 17     17   8496 my( $self, $notok, $all_ok, @lines ) = @_;
930              
931 17 100       141 grep m/^Test Summary Report/ => @lines
932             and return $self->_parse_harness3_output( $notok, $_[2], @lines );
933              
934 5         13 my $harness_re1 = HARNESS_RE1();
935 5         12 my $harness_re2 = HARNESS_RE2();
936              
937             my $output = join "", map {
938 16         164 my( $name, $fail ) = m/$harness_re1/;
939 16 100       43 if ( $name ) {
940 10         24 delete $notok->{ $name };
941 10         26 my $dots = '.' x (40 - length $name );
942 10         66 " $name${dots}FAILED $fail\n";
943             } else {
944 6         61 ( $fail ) = m/$harness_re2/;
945 6         27 " " x 51 . "$fail\n";
946             }
947             } grep m/$harness_re2/ || m/$harness_re1/ => map {
948 5 50 100     9 /All tests successful/ && $all_ok++;
  28         70  
949 28         88 $self->log_info( $_ );
950 28         403 $_;
951             } @lines;
952              
953 5         11 $_[2] = $all_ok;
954 5         36 return $output;
955             }
956              
957             =head2 $self->_parse_harness3_output( $\%notok, $all_ok, @lines )
958              
959             Fator out the parsing of the Test::Harness 3 output, as it seems subject
960             to change.
961              
962             =cut
963              
964             sub _parse_harness3_output {
965 12     12   59 my( $self, $notok, $all_ok, @lines ) = @_;
966              
967 12         22 my $harness3_failed = HARNESS3_RE_FAILED();
968 12         17 my $harness3_todo = HARNESS3_RE_TODO();
969 12         19 my $harness3_extra = HARNESS3_RE_EXTRA();
970 12         16 my $seenheader = 0;
971 12         18 my $ntest = "";
972 12         15 my $file = "";
973 12         15 my $found = 0;
974              
975             my @out = map {
976 130         194 my $line = $_;
977              
978 130         438 my( $tname ) = $line =~ /^\s*(.+(:?\.t)?)\s+\(Wstat/;
979 130         298 my( $failed ) = $line =~ /$harness3_failed/x;
980 130         250 my( $todo ) = $line =~ /$harness3_todo/x;
981 130         310 my( $extra ) = $line =~ /$harness3_extra/x;
982 130         205 my( $parse_error ) = $line =~ /^ Parse errors: (.+)/;
983 130         182 my( $exit_status ) = $line =~ /^ (Non-zero exit status: .+)/;
984              
985 130 100       327 if ( $tname ) {
    100          
    100          
    100          
    100          
    100          
986 22         33 my $r;
987 22 50 66     73 if ($file and not $found) {
988 0         0 $r = "${file}??????\n";
989             }
990              
991 22         54 $ntest = $self->_normalize_testname( $tname );
992 22         64 my $dots = '.' x (60 - length $ntest);
993 22         45 $file = " $ntest${dots}";
994 22         34 $found = 0;
995 22         48 $r;
996             } elsif ( $failed ) {
997 9         21 delete $notok->{ $ntest };
998 9         12 $found = 1;
999 9         29 ($file . "FAILED\n", " $failed\n");
1000             } elsif ( $todo ) {
1001 14         16 $found = 1;
1002 14         46 ($file . "PASSED\n", " $todo\n");
1003             } elsif ($extra) {
1004 23         63 " $extra\n"
1005             } elsif ( $parse_error ) {
1006 7         14 delete $notok->{ $ntest };
1007 7         19 $found = 1;
1008 7         23 ($file . "FAILED\n", " $parse_error\n");
1009             } elsif ( $exit_status ) {
1010 6         11 delete $notok->{ $ntest };
1011 6         14 $found = 1;
1012 6         33 ($file . "FAILED\n", " $exit_status\n");
1013             } else {
1014 49         101 undef;
1015             }
1016             } grep defined $_ && length $_ => map {
1017 12 100 66     24 $seenheader or $seenheader = $_ =~ /Test Summary Report/;
  296         571  
1018 296 100       540 /All tests successful/ && $all_ok++;
1019 296         677 $self->log_info($_);
1020 296 100       870 $seenheader ? $_ : '';
1021             } @lines;
1022 12 100 66     63 if ($file and not $found) {
1023 1         5 push @out, "${file}??????\n";
1024             }
1025 12         75 my $output = join "", grep defined $_ => @out;
1026              
1027 12         20 $_[2] = $all_ok;
1028 12         93 return $output;
1029             }
1030              
1031             =head2 $self->_transform_testnames( @notok )
1032              
1033             C<_transform_testnames()> takes a list of testnames, as found by
1034             C (testname without C<.t> suffix followed by dots and a reason)
1035             and returns a hash with the filenames relative to the C directory
1036             as keys and the reason as value.
1037              
1038             =cut
1039              
1040             sub _transform_testnames {
1041 1     1   33 my( $self, @notok ) = @_;
1042 1         6 my %inconsistent;
1043 1         6 for my $nok ( @notok ) {
1044 4 50       34 $nok =~ m!^((?:\.\.[\\/])?\w+[\\/][-\w/\\]+)\.*(.*)! or next;
1045 4         30 my( $test_name, $status ) = ( $1, $2 );
1046              
1047 4         34 my $test_path = $self->_normalize_testname( $test_name );
1048              
1049 4   33     55 $inconsistent{ $test_path } ||= $status;
1050             }
1051 1         24 return %inconsistent;
1052             }
1053              
1054             =head2 $smoker->_normalize_testname( $test )
1055              
1056             Normalize a testname...
1057              
1058             =cut
1059              
1060             sub _normalize_testname {
1061 30     30   3684 my( $self, $test_name ) = @_;
1062              
1063 30         69 $test_name =~ s/\s+$//;
1064 30 100       111 $test_name =~ /\.t$/ or $test_name .= '.t';
1065 30 100       78 if ( $test_name !~ m|^\Q../| ) {
1066 28 100       167 $test_name = $test_name =~ /^(?:cpan|dist|ext|lib|t)\b/
1067             ? catfile( updir(), $test_name )
1068             : catfile( updir(), 't', $test_name );
1069             }
1070              
1071 30         131 my $test_base = catdir( $self->{ddir}, 'pod' );
1072 30         116 $test_name = rel2abs( $test_name, $test_base );
1073              
1074 30         1038 my $test_path = abs2rel( $test_name, $test_base );
1075 30 50       2077 $test_path =~ tr!\\!/! if $self->{is_win32};
1076              
1077             # sometimes ../t is optimized away
1078 30 50       110 $test_path !~ m|^\.\.[\\/]| and $test_path = "../t/$test_path";
1079              
1080 30         85 return $test_path;
1081             }
1082              
1083             =head2 set_skip_tests( [$unset] )
1084              
1085             Read from a MANIFEST like file, set in C<< $self->{skip_tests} >>, and
1086             rename the files in it with the extension F<.tskip>. If C<$unset> is
1087             set, they will be renamed back.
1088              
1089             =head2 unset_skip_tests
1090              
1091             Calls C<< $self->set_skip_tests( 1 ) >>.
1092              
1093             =cut
1094              
1095             sub set_skip_tests {
1096 2     2 1 940 my( $self, $unset ) = @_;
1097              
1098 2 50       8 $self->{skip_tests} or return;
1099 2         6 local *SKIPTESTS;
1100              
1101 2 50       76 if ( open SKIPTESTS, "< $self->{skip_tests}" ) {
1102 2 100       17 my $action = $unset ? 'Unskip' : 'Skip';
1103 2         17 $self->log_info("$action tests from '$self->{skip_tests}'");
1104 2         19 my @libext;
1105             my $raw;
1106 2         34 while ( $raw = ) {
1107 10 50       29 $raw =~ m/^\s*#/ and next;
1108 10         49 $raw =~ s/(\S+).*/$1/s;
1109 10 0 33     35 if ($raw !~ m/\.t$/ and $raw !~ m/test\.pl$/) {
1110 0         0 next;
1111             }
1112 10 100       36 if ( $raw =~ m{^(?:lib|ext|cpan|dist)/} ) {
1113 8         16 push @libext, $raw;
1114 8         45 next;
1115             }
1116 2         26 my $tsrc = File::Spec->catfile( $self->{ddir}, $raw );
1117 2 50       34 next if !-f $tsrc;
1118 2         7 my $skip = qq[print "1..0 # SKIP Disabled by Test::Smoke\\n";\nexit 0;\n__END__\n];
1119 11     11   83006 use autodie;
  11         156557  
  11         60  
1120              
1121 2         26 open my $test_fh_r, "<:raw", $tsrc;
1122 2         3283 my $body = do { local $/; <$test_fh_r> };
  2         9  
  2         93  
1123 2         21 close $test_fh_r;
1124              
1125 2         1080 open my $test_fh_w, ">:raw", $tsrc;
1126 2 100       267 print $test_fh_w !$unset ? "$skip$body" : do { $body =~ s/^\Q$skip\E//; $body; };
  1         42  
  1         6  
1127 2         9 close $test_fh_w;
1128              
1129 2         323 $self->log_info("\t%s: %sok%s\n", $raw, '', "");
1130             }
1131 2         34 close SKIPTESTS;
1132 2 50       16 @libext and $self->change_manifest( \@libext, $unset );
1133             } else {
1134 0         0 require Carp;
1135 0         0 Carp::carp("Cannot open($self->{skip_tests}): $!");
1136             }
1137             }
1138              
1139 1     1 1 1461 sub unset_skip_tests { $_[0]->set_skip_tests( 1 ) }
1140              
1141             =head2 $self->change_manifest( \@tests, $unset )
1142              
1143             =cut
1144              
1145             sub change_manifest {
1146 2     2 1 6 my( $self, $tests, $unset ) = @_;
1147              
1148 2         13 my $mani_org = catfile $self->{ddir}, 'MANIFEST';
1149 2         9 my $mani_new = catfile $self->{ddir}, 'MANIFEST.ORG';
1150 2 100       7 if ( $unset ) {
1151 1 50       17 if ( -f $mani_new ) {
1152 1         19 my $perms = (stat $mani_new)[2] & 07777;
1153 1         17 chmod 0755, $mani_new;
1154 1         74 unlink $mani_org;
1155 1         32 rename $mani_new, $mani_org;
1156 1         23 chmod $perms, $mani_org;
1157             }
1158             } else {
1159 1         18 my $perms = (stat $mani_org)[2] & 07777;
1160 1         21 chmod 0755, $mani_org;
1161 1 50       52 rename $mani_org, $mani_new or do {
1162 0         0 chmod $perms, $mani_org;
1163 0         0 require Carp;
1164 0         0 Carp::carp("No skip of lib or ext tests [rename($mani_new): $!]");
1165 0         0 return;
1166             };
1167 1         7 local( *MANIO, *MANIN );
1168 1 50       42 if ( open MANIO, "< $mani_new" ) {
1169 1         5 binmode MANIO;
1170 1 50       75 if ( open MANIN, "> $mani_org" ) {
1171 1         9 binmode MANIN;
1172 1         8 my $mline;
1173 1         21 while ( $mline = ) {
1174 17         27 chomp $mline;
1175 17         77 ( my $fn = $mline ) =~ s/^(\S+).*/$1/;
1176 17 100       190 if ( ! grep /\Q$fn\E/ => @$tests ) {
1177 13         63 print MANIN "$mline\n";
1178             } else {
1179 4         25 $self->log_info("\t$fn");
1180             }
1181             }
1182 1         41 close MANIN;
1183             }
1184 1         11 close MANIO;
1185 1         34 chmod $perms, $mani_new;
1186             }
1187             }
1188             }
1189              
1190             =head2 $self->_run( $command[, $sub[, @args]] )
1191              
1192             C<_run()> returns C<< qx( $command ) >> unless C<$sub> is specified.
1193             If C<$sub> is defined (and a coderef) C<< $sub->( $command, @args ) >> will
1194             be called.
1195              
1196             =cut
1197              
1198             sub _run {
1199 0     0     my $self = shift;
1200 0           my( $command, $sub, @args ) = @_;
1201              
1202 0           $self->log_debug("[$command]");
1203 0 0         defined $sub and return &$sub( $command, @args );
1204              
1205 0     0     my ( $out, $err, $res ) = capture { system $command };
  0            
1206 0           $self->tty($out);
1207 0 0         $self->ttylog($err) if $err;
1208 0           $self->{_run_exit} = $res >> 8;
1209 0 0         return wantarray ? split /(\r\n|\r|\n)/, $out : $out;
1210             }
1211              
1212             =head2 $self->_make( $command )
1213              
1214             C<_make()> calls C<< run( "make $command" ) >>, and does some extra
1215             stuff to help MSWin32 (the right maker, the directory).
1216              
1217             =cut
1218              
1219             sub _make {
1220 0     0     my $self = shift;
1221 0           my $cmd = shift;
1222 0 0         $self->{makeopt} and $cmd = "$self->{makeopt} $cmd";
1223 0 0         $cmd =~ m/clean/ and $cmd =~ s/-j[0-9]+\s+//;
1224              
1225             return
1226             $self->{is_vms} ? $self->_make_vms($cmd)
1227 0 0         : $self->{is_win32} ? $self->_make_win32($cmd)
    0          
1228             : $self->_run("make $cmd");
1229             }
1230              
1231             sub _make_win32 {
1232 0     0     my $self = shift;
1233 0           my $cmd = shift;
1234              
1235 0           $cmd =~ s|2\s*>\s*/dev/null\s*$|2>nul|;
1236              
1237 0           $cmd = "$self->{w32make} -f smoke.mk $cmd";
1238 0 0         chdir "win32" or die "unable to chdir () into 'win32'";
1239 0           my @output = $self->_run($cmd);
1240 0 0         chdir ".." or die "unable to chdir() out of 'win32'";
1241 0 0         return wantarray ? @output : join "", @output;
1242             }
1243              
1244             sub _make_vms {
1245 0     0     my $self = shift;
1246 0           my $cmd = shift;
1247              
1248 0           my $kill_err;
1249             # don't capture STDERR
1250             # @ But why? and what if we do it DOSish? 2>NUL:
1251              
1252 0 0         $cmd =~ s|2\s*>\s*/dev/null\s*$|| and $kill_err = 1;
1253              
1254 0           $cmd = "$self->{vmsmake} $cmd";
1255 0 0         my @output = $self->_run(
1256             $kill_err ? qq{$^X -e "close STDERR; system '$cmd'"} : $cmd
1257             );
1258 0 0         return wantarray ? @output : join "", @output;
1259             }
1260              
1261             =head2 $smoker->_make_fork( $target, $extra )
1262              
1263             C<_make_fork()> opens a read pipe to the make command with C<$target>
1264             and C<$extra> arguments for the make command.
1265              
1266             =cut
1267              
1268             sub _make_fork {
1269 0     0     my( $self, $target, $extra ) = @_;
1270              
1271 0 0         !defined $extra and $extra = "";
1272              
1273 0           my( $ok, $err, $cmd );
1274 0           local *TST;
1275              
1276             # MSWin32 builds from its own directory
1277 0 0         if ( $self->{is_win32} ) {
1278 0 0         chdir "win32" or die "unable to chdir () into 'win32'";
1279             # Same as in make ()
1280 0           $cmd = "$self->{testmake}$extra -f smoke.mk $target |";
1281 0 0         $ok = open TST, $cmd or $err = $!;
1282 0 0         chdir ".." or die "unable to chdir () out of 'win32'";
1283             } else {
1284 0           local $ENV{PERL} = "./perl";
1285 0           $cmd = "$self->{testmake}$extra $target |";
1286 0 0         $ok = open TST, $cmd or $err = $!;
1287             }
1288 0 0         $ok or do {
1289 0           require Carp;
1290 0           Carp::carp("Cannot fork '$cmd': $err");
1291 0           return 0;
1292             };
1293 0           select ((select (*TST), $| = 1)[0]);
1294 0           return *TST;
1295             }
1296              
1297             =head2 $smoker->_vms__rooted_logical
1298              
1299             This code sets up a rooted logical C and changes the {ddir}
1300             to that root.
1301              
1302             =cut
1303              
1304             sub _vms_rooted_logical {
1305 0     0     my $self = shift;
1306 0 0         return unless $^O eq 'VMS';
1307              
1308 0           Test::Smoke::Util::set_vms_rooted_logical( TSP5SRC => $self->{ddir} );
1309 0           $self->{vms_ddir} = $self->{ddir};
1310 0           $self->{ddir} = 'TSP5SRC:[000000]';
1311              
1312             }
1313              
1314             1;
1315              
1316             =head1 SEE ALSO
1317              
1318             L
1319              
1320             =head1 COPYRIGHT
1321              
1322             (c) 2002-2003, All rights reserved.
1323              
1324             * Abe Timmerman
1325              
1326             This library is free software; you can redistribute it and/or modify
1327             it under the same terms as Perl itself.
1328              
1329             See:
1330              
1331             =over 4
1332              
1333             =item * L
1334              
1335             =item * L
1336              
1337             =back
1338              
1339             This program is distributed in the hope that it will be useful,
1340             but WITHOUT ANY WARRANTY; without even the implied warranty of
1341             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
1342              
1343             =cut