File Coverage

blib/lib/Test/Smoke/App/RunSmoke.pm
Criterion Covered Total %
statement 124 147 84.3
branch 24 50 48.0
condition 2 5 40.0
subroutine 22 23 95.6
pod 8 8 100.0
total 180 233 77.2


line stmt bran cond sub pod time code
1             package Test::Smoke::App::RunSmoke;
2 2     2   132379 use warnings;
  2         16  
  2         67  
3 2     2   12 use strict;
  2         4  
  2         36  
4 2     2   9 use Carp;
  2         4  
  2         118  
5              
6             our $VERSION = '0.001';
7              
8 2     2   13 use base 'Test::Smoke::App::Base';
  2         3  
  2         548  
9              
10 2     2   56 use Cwd 'cwd';
  2         6  
  2         103  
11 2     2   22 use Config;
  2         5  
  2         68  
12 2     2   11 use File::Spec::Functions;
  2         7  
  2         180  
13 2     2   596 use Test::Smoke::BuildCFG;
  2         5  
  2         79  
14 2     2   564 use Test::Smoke::Policy;
  2         6  
  2         54  
15 2     2   13 use Test::Smoke::Smoker;
  2         4  
  2         44  
16 2     2   461 use Test::Smoke::SourceTree qw/ST_MISSING ST_UNDECLARED/;
  2         4  
  2         125  
17 2         100 use Test::Smoke::Util qw/
18             calc_timeout
19             get_local_patches
20             get_patch
21             set_local_patch
22             skip_config
23 2     2   16 /;
  2         4  
24 2     2   843 use Test::Smoke::Util::Execute;
  2         6  
  2         3445  
25              
26             =head1 NAME
27              
28             Test::Smoke::App::RunSmoke - The tsrunsmoke.pl application.
29              
30             =head1 DESCRIPTION
31              
32             This applet takes care of running the "smoke-mantra" for all
33             build-configurations.
34              
35             =head2 $smoker->run();
36              
37             reimplemention of the old C.
38              
39             =cut
40              
41             sub run {
42 3     3 1 8292 my $self = shift;
43              
44 3         12709 my $cwd = cwd();
45 3         155 $self->log_info("[%s] chdir(%s)", $0, $self->option('ddir'));
46 3 100       23 chdir $self->option('ddir') or
47             die sprintf("Cannot chdir(%s): %s", $self->option('ddir'), $!);
48              
49 2         14 my $timeout = 0;
50 2 50 33     229 if ($Config{d_alarm} && $self->option('killtime')) {
51 0         0 $timeout = calc_timeout($self->option('killtime'));
52 0         0 $self->log_info(
53             "Setup alarm: %s", scalar localtime(time + $timeout)
54             );
55             }
56             $timeout and local $SIG{ALRM} = sub {
57 0     0   0 warn "This smoke is aborted (@{[$self->option('killtime')]})\n";
  0         0  
58 0         0 exit;
59 2 50       15 };
60 2 50       62 $Config{d_alarm} and alarm $timeout;
61              
62 2 50       25 if ($self->option('is_win32')) {
63 0         0 require Test::Smoke::Util::Win32ErrorMode;
64 0         0 $self->log_info("Changing ErrorMode settings to prevent popups");
65 0         0 Test::Smoke::Util::Win32ErrorMode::lower_error_settings();
66             }
67              
68 2         14 $self->run_smoke(@{ $self->option('pass_option') });
  2         22  
69 2         58 chdir $cwd;
70             }
71              
72             =head2 $smoker->run_smoke();
73              
74             =cut
75              
76             sub run_smoke {
77 1     1   26 my $self = shift;
78              
79 1         27 my $BuildCFG = $self->{_BuildCFG} = $self->create_buildcfg(@_);
80              
81 1 50       7 my $mode = $self->option('continue') ? ">>" : ">";
82 1         8 my $logfile = catfile($self->option('ddir'), $self->option('outfile'));
83 1 50       156 open my $log, $mode, $logfile or die "Cannot create($logfile): $!";
84              
85 1         14 my $policy = $self->{_policy} = $self->create_policy;
86              
87 1         5 my $smoker = $self->{_smoker} = $self->create_smoker($log);
88              
89 1         35 $smoker->mark_in;
90              
91 1 50       7 $self->log_info("Running smoke tests without \$ENV{PERLIO}")
92             if $self->option('defaultenv');
93 1         6 $self->log_harness_message();
94              
95 1 50       5 if (! chdir($self->option('ddir'))) {
96 0         0 die sprintf("Cannot chdir(%s): %s", $self->option('ddir'), $!);
97             }
98              
99 1         9 my $patch = get_patch($self->option('ddir'));
100 1         12 $self->log_debug("[get_patch] found: '%s'", join("', '", @$patch));
101 1 50       4 if (!$self->option('continue')) {
102 1         6 $smoker->make_distclean();
103 1   50     6 $smoker->ttylog("Smoking patch $patch->[0] @{[$patch->[1]||'']}\n");
  1         22  
104 1 50       7 $smoker->ttylog("Smoking branch $patch->[2]\n") if $patch->[2];
105 1         5 $self->do_manifest_check();
106 1         6 $self->add_smoke_patchlevel($patch->[0]);
107             }
108              
109 1         24 foreach my $this_cfg ( $BuildCFG->configurations ) {
110 8         2930 $smoker->mark_out; $smoker->mark_in;
  8         32  
111 8 50       40 if ( skip_config( $this_cfg ) ) {
112 0         0 $smoker->ttylog( "Skipping: '$this_cfg'\n" );
113 0         0 next;
114             }
115              
116 8         65 $smoker->ttylog( join "\n",
117             "", "Configuration: $this_cfg", "-" x 78, "" );
118 8         30 $smoker->smoke( $this_cfg, $policy );
119             }
120              
121 1         304 $smoker->mark_out;
122 1         10 $smoker->ttylog("Finished smoking @$patch\n" );
123              
124 1 50       39 close $log or $self->log_warn("Error on closing logfile: $!");
125             }
126              
127             =head2 $smoker->log_harness_message()
128              
129             Log stuff about Test::Harness...
130              
131             =cut
132              
133             sub log_harness_message {
134 1     1 1 3 my $self = shift;
135 1         2 my $harness_msg;
136 1 50       6 if ( $self->option('harnessonly') ) {
137 0         0 $harness_msg = "Running test suite only with 'harness'";
138 0 0       0 if ($self->option('harness3opts')) {
139 0         0 $harness_msg .= " with HARNESS_OPTIONS="
140             . $self->option('harness3opts');
141             }
142             }
143 1 50       5 $self->log_info($harness_msg) if $harness_msg;
144             }
145              
146             =head2 $smoker->check_for_harness3()
147              
148             Determine the version of L shipped with this perl and set
149             B accordingly.
150              
151             =cut
152              
153             sub check_for_harness3 {
154 1     1 1 3 my $self = shift;
155              
156 1         13 my @mod_dirs = (
157             [qw/ ext Test-Harness lib Test /],
158             [qw/ cpan Test-Harness lib Test /],
159             [qw/ lib Test /],
160             );
161             my @harnesses = grep {
162 3 100       164 $self->log_debug("[filetest] %s: %s", $_, (-f $_ ? 'Y' : 'N'));
163 3         41 -f $_;
164             } map {
165 1         5 catfile(catdir($self->option('ddir'), @$_), 'Harness.pm')
  3         17  
166             } @mod_dirs;
167              
168 1         8 my $chk = Test::Smoke::Util::Execute->new(
169             command => $^X,
170             verbose => $self->option('verbose')
171             );
172              
173 1 50       6 if (!@harnesses) {
174 0         0 $self->log_warn("No Test::Harness found, incomplete source-tree, abandon!");
175 0         0 die "No Test::Harness found, incomplete sourc-tree, abandon!";
176             }
177              
178 1         8 my $version = '0.00';
179 1         4 for my $th_candidate (@harnesses) {
180 1         10 $self->log_debug("Test::Harness candidate '%s'", $th_candidate);
181 1         9 $version = eval {
182 1         10 $chk->run(
183             "-e",
184             "require q[$th_candidate];print Test::Harness->VERSION",
185             "2>&1",
186             );
187             };
188 1 50       29 if ($chk->exitcode != 0) {
189 0         0 $self->log_warn("Error with Test::Harness->VERSION: $version");
190 0         0 $version = '0.00';
191 0         0 next;
192             }
193             }
194 1         34 $self->log_info("Found: Test::Harness version %s.", $version);
195              
196 1         157 return $self->{_hasharness3} = (eval("$version") >= 3);
197             }
198              
199             =head2 $smoker->create_buildcfg()
200              
201             Returns an appropriate L instance.
202              
203             =cut
204              
205             sub create_buildcfg {
206 1     1 1 18 my $self = shift;
207              
208 1 50       36 my @df_buildopts = @_ ? grep /^-[DUA]/ => @_ : ();
209             # We *always* want -Dusedevel!
210 1 50       19 push @df_buildopts, '-Dusedevel'
211             unless grep /^-Dusedevel$/ => @df_buildopts;
212              
213 1         69 Test::Smoke::BuildCFG->config(dfopts => join(" ", @df_buildopts));
214              
215 1         9 my $patch = Test::Smoke::Util::get_patch($self->option('ddir'));
216              
217 1         16 $self->check_for_harness3();
218              
219 1         14 my $logfile = catfile($self->option('ddir'), $self->option('outfile'));
220              
221 1 50       21 if ($self->option('continue')) {
222 0         0 return Test::Smoke::BuildCFG->continue(
223             $logfile,
224             $self->option('cfg'),
225             v => $self->option('verbose')
226             );
227             }
228 1         13 return Test::Smoke::BuildCFG->new(
229             $self->option('cfg'),
230             v => $self->option('verbose')
231             );
232             }
233              
234             =head2 $smoker->create_policy()
235              
236             Create the L instance.
237              
238             =cut
239              
240             sub create_policy {
241 1     1 1 4 my $self = shift;
242 1         6 return Test::Smoke::Policy->new(
243             updir(),
244             $self->option('verbose'),
245             $self->BuildCFG->policy_targets
246             );
247             }
248              
249             =head2 $smoker->create_smoker($log_handle)
250              
251             Instantiate L.
252              
253             =cut
254              
255             sub create_smoker {
256 1     1 1 3 my $self = shift;
257 1         3 my ($log_handle) = @_;
258              
259 1         19 return Test::Smoke::Smoker->new(
260             $log_handle,
261             {
262             $self->options,
263             v => $self->option('verbose')
264             }
265             );
266             }
267              
268             =head2 $smoker->do_manifest_check()
269              
270             Calls Test::Smoke::SourceTree->check_MANIFEST().
271              
272             =cut
273              
274             sub do_manifest_check {
275 1     1 1 4 my $self = shift;
276              
277 1         5 my $tree = Test::Smoke::SourceTree->new(
278             $self->option('ddir'),
279             $self->option('verbose'),
280             );
281              
282 1         7 my $mani_check = $tree->check_MANIFEST(
283             $self->option('outfile'),
284             $self->option('rptfile'),
285             'patchlevel.bak',
286             );
287 1         14 foreach my $file ( sort keys %$mani_check ) {
288 0 0       0 if ( $mani_check->{ $file } == ST_MISSING ) {
    0          
289 0         0 $self->smoker->log("MANIFEST declared '$file' but it is missing\n");
290             }
291             elsif ( $mani_check->{ $file } == ST_UNDECLARED ) {
292 0         0 $self->smoker->log( "MANIFEST did not declare '$file'\n" );
293             }
294             }
295             }
296              
297             =head2 $smoker->add_smoke_patchlevel()
298              
299             Calls L to add a patch-string.
300              
301             =cut
302              
303             sub add_smoke_patchlevel {
304 1     1 1 4 my $self = shift;
305 1         4 my ($patch) = @_;
306              
307 1         5 my @smokereg = grep
308             /^SMOKE[a-fA-F0-9]+$/
309             , get_local_patches($self->option('ddir'), $self->option('verbose'));
310 1 50       7 if (!@smokereg) {
311 1         8 $self->log_info("Adding 'SMOKE$patch' to the registered patches.");
312 1         4 set_local_patch($self->option('ddir'), "SMOKE$patch");
313             }
314             }
315              
316             1;
317              
318             =head1 COPYRIGHT
319              
320             (c) 2002-2013, Abe Timmerman All rights reserved.
321              
322             With contributions from Jarkko Hietaniemi, Merijn Brand, Campo
323             Weijerman, Alan Burlison, Allen Smith, Alain Barbet, Dominic Dunlop,
324             Rich Rauenzahn, David Cantrell.
325              
326             This library is free software; you can redistribute it and/or modify
327             it under the same terms as Perl itself.
328              
329             See:
330              
331             =over 4
332              
333             =item * L
334              
335             =item * L
336              
337             =back
338              
339             This program is distributed in the hope that it will be useful,
340             but WITHOUT ANY WARRANTY; without even the implied warranty of
341             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
342              
343             =cut