File Coverage

blib/lib/POE/Component/SmokeBox/Backend.pm
Criterion Covered Total %
statement 248 307 80.7
branch 96 162 59.2
condition 21 57 36.8
subroutine 33 39 84.6
pod 7 7 100.0
total 405 572 70.8


line stmt bran cond sub pod time code
1             package POE::Component::SmokeBox::Backend;
2             $POE::Component::SmokeBox::Backend::VERSION = '0.58';
3             #ABSTRACT: smoker backend to POE::Component::SmokeBox
4              
5 44     44   224786 use strict;
  44         143  
  44         1266  
6 44     44   253 use warnings;
  44         94  
  44         1070  
7 44     44   215 use Carp;
  44         127  
  44         2925  
8 44     44   29210 use Storable;
  44         146094  
  44         2933  
9 44     44   34317 use File::Temp ();
  44         440037  
  44         1372  
10 44     44   328 use File::Path qw[rmtree];
  44         131  
  44         2011  
11 44     44   275 use File::Spec;
  44         101  
  44         977  
12 44     44   259 use POSIX qw( O_CREAT O_RDWR O_RDONLY ); # for SDBM_File
  44         104  
  44         367  
13 44     44   25174 use SDBM_File;
  44         22154  
  44         2118  
14 44     44   865 use POE qw[Wheel::Run Filter::Line];
  44         24170  
  44         452  
15 44     44   1089858 use Digest::SHA qw[sha256_hex];
  44         138097  
  44         3924  
16 44     44   38823 use Regexp::Assemble;
  44         741469  
  44         1726  
17 44     44   20856 use Env::Sanctify;
  44         22301  
  44         1737  
18 44     44   21731 use Module::Pluggable search_path => 'POE::Component::SmokeBox::Backend', sub_name => 'backends', except => 'POE::Component::SmokeBox::Backend::Base';
  44         461318  
  44         389  
19              
20 44 50   44   6698 use constant ON_BSD => $^O =~ m!^(free|midnight|dragonfly|open)(bsd)?$! ? 1 : 0;
  44         131  
  44         9825  
21              
22             my $GOT_KILLFAM;
23             my $GOT_PTY;
24              
25             BEGIN {
26 44     44   229 $GOT_KILLFAM = 0;
27 44         137 eval {
28 44         7238 require Proc::ProcessTable;
29 0         0 $GOT_KILLFAM = 1;
30             };
31 44         204 $GOT_PTY = 0;
32 44         115 eval {
33 44         195 require IO::Pty;
34 44         111 $GOT_PTY = 1;
35             };
36 44 50       154825 if ( $^O eq 'MSWin32' ) {
37 0         0 require POE::Wheel::Run::Win32;
38              
39             # MSWin32: Disable critical error popups
40             # Thanks to https://rt.cpan.org/Public/Bug/Display.html?id=56547
41              
42             # Call kernel32.SetErrorMode(SEM_FAILCRITICALERRORS):
43             # "The system does not display the critical-error-handler message box.
44             # Instead, the system sends the error to the calling process." and
45             # "A child process inherits the error mode of its parent process."
46 0 0       0 if ( eval { require Win32API::File } ) {
  0         0  
47 0         0 Win32API::File->import( qw( SetErrorMode SEM_FAILCRITICALERRORS SEM_NOGPFAULTERRORBOX ) );
48 0         0 SetErrorMode( SEM_FAILCRITICALERRORS() | SEM_NOGPFAULTERRORBOX() );
49             } else {
50 0         0 warn "Unable to use Win32API::File -> $@";
51 0         0 warn 'This means sometimes perl.exe will popup a dialog box... Annoying!';
52             }
53             }
54             }
55              
56             my @cmds = qw(check index smoke);
57              
58             sub check {
59 7     7 1 8503 my $package = shift;
60 7         27 return $package->spawn( @_, command => 'check' );
61             }
62              
63             sub index {
64 5     5 1 5306 my $package = shift;
65 5         18 return $package->spawn( @_, command => 'index' );
66             }
67              
68             sub smoke {
69 12     12 1 11347 my $package = shift;
70 12         41 return $package->spawn( @_, command => 'smoke' );
71             }
72              
73             sub spawn {
74 108     108 1 9391 my $package = shift;
75 108         1087 my %opts = @_;
76 108         734 my $extra = { map { ( $_ => delete $opts{$_} ) } grep { /^\_/ } keys %opts };
  0         0  
  852         2537  
77 108         590 $opts{extra} = $extra;
78 108         2312 $opts{lc $_} = delete $opts{$_} for keys %opts;
79 108         432 my $options = delete $opts{options};
80 108 50       2472 unless ( $opts{event} ) {
81 0         0 carp "The 'event' parameter is a mandatory requirement\n";
82 0         0 return;
83             }
84 108 100       2231 $opts{idle} = 600 unless $opts{idle};
85 108 100       2311 $opts{timeout} = 3600 unless $opts{timeout};
86 108 100       3439 $opts{timer} = 60 unless $opts{timer};
87 108 50       396 $opts{reaper} = 30 unless $opts{reaper};
88 108 100       1344 $opts{type} = 'CPANPLUS::YACSmoke' unless $opts{type};
89 108   50     636 $opts{command} = lc $opts{command} || 'check';
90 108 50       553 $opts{command} = 'check' unless grep { $_ eq $opts{command} } @cmds;
  324         1278  
91 108 50       461 $opts{perl} = $^X unless $opts{perl}; # and -e $opts{perl};
92 108 100       449 $opts{no_log} = 0 unless $opts{no_log};
93 108 100       384 $opts{check_warnings} = 1 unless exists $opts{check_warnings};
94              
95 108 50       339 if ( $opts{check_warnings} ) {
96 108         33228 require String::Perl::Warnings;
97             }
98              
99 108 50 66     68291608 if ( $opts{command} eq 'smoke' and !$opts{module} ) {
100 0         0 carp "You must specify a 'module' with 'smoke'\n";
101 0         0 return;
102             }
103 108         1049 my $self = bless \%opts, $package;
104 108         1231 my @backends = $self->backends();
105 108         772212 my ($type) = grep { /\Q$opts{type}\E$/ } @backends;
  972         4457  
106 108 100       611 unless ( $type ) {
107 1         359 carp "No such backend '$opts{type}'\n";
108 1         25 return;
109             }
110 107         15616 eval "require $type;";
111 107 50       922 if ( $@ ) {
112 0         0 carp "Could not load '$type' '$@'\n";
113 0         0 return;
114             }
115 107         1448 $self->{backend} = $type->new();
116 107 50 33     652 unless ( $self->{backend} or $self->{backend}->can($self->{command}) ) {
117 0         0 croak "Problem loading backend '$type'\n";
118 0         0 return;
119             }
120 107 50       884 if ( $self->{backend}->can('digest') ) {
121 107         611 $self->{_reset_digest} = $self->{backend}->digest();
122             }
123 107         388 my $cmd = $self->{command};
124 107         621 $self->{program} = $self->{backend}->$cmd;
125 107 50 33     577 unless ( $self->{program} or ref $self->{program} eq 'ARRAY' ) {
126 0         0 carp "The backend method '$cmd' did not return an arrayref\n";
127 0         0 return;
128             }
129 107         262 unshift @{ $self->{program} }, $self->{perl};
  107         547  
130 107 100       487 push @{ $self->{program} }, $self->{module} if $cmd eq 'smoke';
  37         192  
131 107 100       2370 $self->{session_id} = POE::Session->create(
132             package_states => [
133             $self => { shutdown => '_shutdown', },
134             $self => [qw(_start _spawn_wheel _wheel_error _wheel_closed _wheel_stdout _wheel_stderr _wheel_idle _wheel_reap _wheel_kill _sig_child)],
135             ],
136             heap => $self,
137             ( ref($options) eq 'HASH' ? ( options => $options ) : () ),
138             )->ID();
139 107         17951 return $self;
140             }
141              
142             sub session_id {
143 0     0 1 0 return $_[0]->{session_id};
144             }
145              
146             sub current_log {
147 0     0 1 0 my $self = shift;
148 0 0       0 return unless $self->{_wheel_log};
149 0         0 my $item = Storable::dclone( $self->{_wheel_log} );
150 0         0 return $item;
151             }
152              
153             sub shutdown {
154 0     0 1 0 my $self = shift;
155 0         0 $poe_kernel->post( $self->session_id() => 'shutdown' => @_ );
156             }
157              
158             sub _start {
159 107     107   46585 my ($kernel,$sender,$self) = @_[KERNEL,SENDER,OBJECT];
160 107         436 $self->{session_id} = $_[SESSION]->ID();
161 107 50 33     1095 if ( $kernel == $sender and !$self->{session} ) {
162 0         0 croak "Not called from another POE session and 'session' wasn't set\n";
163             }
164 107         265 my $sender_id;
165 107 50       448 if ( $self->{session} ) {
166 0 0       0 if ( my $ref = $kernel->alias_resolve( $self->{session} ) ) {
167 0         0 $sender_id = $ref->ID();
168             }
169             else {
170 0         0 croak "Could not resolve 'session' to a valid POE session\n";
171             }
172             }
173             else {
174 107         381 $sender_id = $sender->ID();
175             }
176 107         1036 $kernel->refcount_increment( $sender_id, __PACKAGE__ );
177 107         5255 $self->{session} = $sender_id;
178 107 50       853 $kernel->detach_myself() if $kernel != $sender;
179              
180 107         17058 $self->{_wheel_log} = [ ];
181              
182 107 100       504 if ( !$self->{_reset_digest} ) {
183 74         351 $self->_tie_digests();
184             }
185             else {
186 33         106 $self->{_digests} = { };
187             }
188              
189 107         385 $self->{_loop_detect} = 0;
190 107         375 $self->{start_time} = time();
191              
192 107         645 $kernel->yield( '_spawn_wheel' );
193 107         11322 return;
194             }
195              
196             sub _shutdown {
197 0     0   0 my ($kernel,$self) = @_[KERNEL,OBJECT];
198 0 0       0 if ( !$self->{_reset_digest} ) {
199 0         0 $self->_untie_digests();
200             }
201             else {
202 0         0 delete $self->{_digests};
203             }
204 0         0 $self->{term_kill} = 1;
205 0         0 $kernel->yield( '_wheel_kill', 'Killing current due to component shutdown event' );
206 0         0 return;
207             }
208              
209             # Digests tie and untie
210              
211             sub _tie_digests {
212 74     74   260 my $self = shift;
213 74         1333 $self->{_tempdir} = File::Temp->newdir();
214 74         52651 $self->{_tmpdirname} = $self->{_tempdir}->dirname;
215 74         2243 my $file = File::Spec->catfile( $self->{_tmpdirname}, 'digests.dat' );
216 74         382 $self->{_digests} = { };
217 74 50       191 tie %{ $self->{_digests} }, 'SDBM_File', $file, O_CREAT|O_RDWR, 0644 or die "Could not tie: $!\n";
  74         10668  
218 74         443 return 1;
219             }
220              
221             sub _untie_digests {
222 74     74   320 my $self = shift;
223 74 50       849 if ( $self->{_digests} ) {
224 74         273 untie %{ $self->{_digests} };
  74         4032  
225 74         1051 delete $self->{_digests};
226 74         1988 delete $self->{_tempdir};
227 74 50       73851 rmtree( $self->{_tmpdirname} ) if -d $self->{_tmpdirname};
228             }
229 74         409 return 1;
230             }
231              
232             sub _spawn_wheel {
233 107     107   49636 my ($kernel,$self) = @_[KERNEL,OBJECT];
234              
235             # do we need to process callbacks?
236 107 100       609 if ( $self->{do_callback} ) {
237             # Ask it if we should process this job or not?
238 6 100       28 unless ( $self->{do_callback}->( 'BEFORE', $self ) ) {
239 1 50 33     140 warn "Callback denied job, aborting!\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
240 1         6 my $job = $self->_finalize_job( -1 );
241 1         5 $job->{cb_kill} = 1;
242 1         6 $kernel->post( $self->{session}, $self->{event}, $job );
243 1         209 return;
244             }
245             }
246              
247             # Set appropriate %ENV values before we fork()
248             my $sanctify = Env::Sanctify->sanctify(
249             env => $self->{env},
250 106         3329 sanctify => [
251             '^POE_',
252             '^PERL5_SMOKEBOX',
253             '^HARNESS_',
254             '^(PERL5LIB|TAP_VERSION|TEST_VERBOSE)$',
255             '^AUTHOR_TESTING$',
256             '^PERL_TEST',
257             ] );
258 106         76228 my $type = 'POE::Wheel::Run';
259 106 50       688 $type .= '::Win32' if $^O eq 'MSWin32';
260             $self->{wheel} = $type->new(
261             Program => $self->{program},
262 106 50       2096 StdoutEvent => '_wheel_stdout',
263             StderrEvent => '_wheel_stderr',
264             StdoutFilter => POE::Filter::Line->new( InputLiteral => "\n" ),
265             StderrFilter => POE::Filter::Line->new( InputLiteral => "\n" ),
266             ErrorEvent => '_wheel_error',
267             CloseEvent => '_wheel_closed',
268             ( $GOT_PTY ? ( Conduit => 'pty-pipe' ) : () ),
269             );
270             # Restore the %ENV values
271 106         1019084 $sanctify->restore();
272 106         10901 $self->{_wheel_time} = time();
273 106         2138 $self->{PID} = $self->{wheel}->PID();
274 106         3426 $kernel->sig_child( $self->{PID}, '_sig_child' );
275 106 100       34923 $kernel->delay( '_wheel_idle', $self->{timer} ) unless $self->{command} eq 'index';
276 106         22265 return;
277             }
278              
279             sub _sig_child {
280 106     106   93585 my ($kernel,$self,$thing,$pid,$status) = @_[KERNEL,OBJECT,ARG0..ARG2];
281 106 100       836 push @{ $self->{_wheel_log} }, "$thing $pid $status" if ! $self->{no_log};
  105         1117  
282 106 50 33     1844 warn "$thing $pid $status\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
283 106         964 $kernel->sig_handled();
284 106         2267 $kernel->delay( '_wheel_idle' );
285              
286 106         8338 my $job = $self->_finalize_job( $status );
287              
288             # do we need to process callbacks?
289 106 100       633 if ( $self->{do_callback} ) {
290             # Inform the callback that the job is done
291 5         45 $self->{do_callback}->( 'AFTER', $self, $job );
292             }
293              
294 106         3760 $kernel->post( $self->{session}, $self->{event}, $job );
295 106 100       18912 $kernel->delay( '_wheel_reap' => $self->{reaper} ) if $self->{wheel};
296 106         752 return;
297             }
298              
299             sub _finalize_job {
300 107     107   710 my( $self, $status ) = @_;
301              
302 107         752 $self->{end_time} = time();
303              
304 107 100       763 if ( !$self->{_reset_digest} ) {
305 74         542 $self->_untie_digests();
306             }
307             else {
308 33         208 delete $self->{_digests};
309             }
310              
311 107         510 delete $self->{_loop_detect};
312              
313 107         639 my $job = { };
314 107         1114 $job->{status} = $status;
315 107         992 $job->{log} = $self->{_wheel_log};
316 107         467 $job->{$_} = $self->{extra}->{$_} for keys %{ $self->{extra} };
  107         826  
317 107         745 $job->{$_} = $self->{$_} for grep { $self->{$_} } qw(command env PID start_time end_time idle_kill excess_kill term_kill perl type);
  1070         5655  
318 107 50 33     1916 $job->{program} = $self->{program} if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
319 107 100       1070 $job->{module} = $self->{module} if $self->{command} eq 'smoke';
320 107         1093 $poe_kernel->refcount_decrement( $self->{session}, __PACKAGE__ );
321              
322 107         9636 return $job;
323             }
324              
325             sub _wheel_reap {
326 0     0   0 my ($kernel,$self) = @_[KERNEL,OBJECT];
327 0 0 0     0 warn "wheel reaped\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
328 0         0 delete $self->{wheel};
329 0         0 return;
330             }
331              
332             sub _wheel_error {
333 212     212   84181781 my ($self,$operation,$errnum,$errstr,$wheel_id) = @_[OBJECT,ARG0..ARG3];
334 212 100 66     3298 $errstr = "remote end closed" if $operation eq "read" and !$errnum;
335 212 50 33     3193 warn "wheel $wheel_id generated $operation error $errnum: $errstr\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
336 212         1121 return;
337             }
338              
339             sub _wheel_closed {
340 106     106   6834 my ($kernel,$self) = @_[KERNEL,OBJECT];
341 106         869 $kernel->delay( '_wheel_idle' );
342 106         16307 $kernel->delay( '_wheel_reap' );
343 106 50 33     8888 warn "wheel closed\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
344 106         1815 delete $self->{wheel};
345 106         61169 return;
346             }
347              
348             sub _wheel_stdout {
349 1090     1090   15158998 my ($self, $input, $wheel_id) = @_[OBJECT, ARG0, ARG1];
350 1090 100       3169 return if $self->{_killed};
351 387         759 $self->{_wheel_time} = time();
352 387 100       987 push @{ $self->{_wheel_log} }, $input if ! $self->{no_log};
  386         1110  
353 387 50 33     2207 warn $input, "\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
354 387 100       1232 if ( $self->_detect_loop( $input, 'stdout' ) ) {
355 1         11 $self->{excess_kill} = 1;
356 1         11 $poe_kernel->yield( '_wheel_kill', 'Killing current run due to detection of looping output' );
357             }
358 387         1596 return;
359             }
360              
361             sub _wheel_stderr {
362 42     42   28124 my ($self, $input, $wheel_id) = @_[OBJECT, ARG0, ARG1];
363 42 50       438 return if $self->{_killed};
364 42         564 $self->{_wheel_time} = time();
365 42 50       399 push @{ $self->{_wheel_log} }, $input if ! $self->{no_log};
  42         411  
366 42 50 33     867 if ( $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG} ) {
367 0 0       0 if ( length( $input ) > 5000 ) {
368 0         0 warn "[SUPPRESSED OUTPUT > 5000]\n";
369             }
370             else {
371 0         0 warn $input, "\n";
372             }
373             }
374 42 50       441 if ( $self->_detect_loop( $input, 'stderr' ) ) {
375 0         0 $self->{excess_kill} = 1;
376 0         0 $poe_kernel->yield( '_wheel_kill', 'Killing current run due to detection of looping output' );
377             }
378 42         271 return;
379             }
380              
381             sub _detect_loop {
382 429     429   964 my $self = shift;
383 429   50     1227 my $input = shift || return;
384 429   50     1260 my $handle = shift || 'stdout';
385 429 100       1275 return if $self->{_loop_detect};
386 350 100       1049 if ( my $reset = $self->{_reset_digest} ) {
387 33 50       130 if ( eval { $input =~ $reset } ) {
  33         575  
388 0 0 0     0 warn "Resetting digests\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
389 0         0 $self->{_digests} = { };
390             }
391             }
392 350 50       1843 return if $input =~ /^\[(MSG|ERROR)\]/;
393 350         3251 my $digest = sha256_hex( $input );
394              
395 350         836 my $weighting;
396 350 50       2179 if ( ON_BSD and $handle eq 'stderr' and _bsd_compiler_warnings($input) ) {
397             $weighting = 0.01;
398             }
399 0 50       0 elsif ( $self->{check_warnings} and length( $input ) <= 5000 ) {
400 350 50 66     1840 $weighting = ( $handle eq 'stderr' and String::Perl::Warnings::is_warning($input) ) ? 1 : 10;
401             } else {
402 0 0       0 $weighting = $handle eq 'stderr' ? 1 : 10;
403             }
404              
405 350 100       36916 if ( exists $self->{_digests}->{ $digest } ) {
406 277         6579 $self->{_digests}->{ $digest } += $weighting;
407             }
408             else {
409 73         3163 $self->{_digests}->{ $digest } = $weighting;
410             }
411 350 100       8836 return unless ++$self->{_digests}->{ $digest } > 3000;
412 1         22 return $self->{_loop_detect} = 1;
413             }
414              
415             {
416             my $re = Regexp::Assemble->new()
417             ->add('note: expanded from macro')
418             ->add('note: .+? token is here')
419             ->add('tokens terminating statement expression appear in different macro expansion contexts')
420             ->add('tokens introducing statement expression appear in different macro expansion contexts')
421             ->add('STMT_START')
422             ->add('STMT_END')
423             ->add('PUSHMARK')
424             ->add('XSRETURN')
425             ->add('EXTEND')
426             ->add('SvTAINT')
427             ->add('SvCUR_set')
428             ->add('PUSHTARG')
429             ->add('^')
430             ->add('~')
431             ->re;
432             sub _bsd_compiler_warnings {
433 0     0   0 my $line = shift;
434 0 0       0 return 1 if $line =~ m!$re!;
435 0         0 return;
436             }
437             }
438              
439             sub _wheel_idle {
440 2     2   15013675 my ($kernel,$self) = @_[KERNEL,OBJECT];
441 2         11 my $now = time();
442 2 100       28 if ( $now - $self->{_wheel_time} >= $self->{idle} ) {
443 1         29 $self->{idle_kill} = 1;
444 1         28 $kernel->yield( '_wheel_kill', 'Killing current run due to excessive idle' );
445 1         214 return;
446             }
447 1 50       15 if ( $now - $self->{start_time} >= $self->{timeout} ) {
448 1         33 $self->{excess_kill} = 1;
449 1         18 $kernel->yield( '_wheel_kill', 'Killing current run due to excessive run-time' );
450 1         257 return;
451             }
452 0         0 $kernel->delay( '_wheel_idle', 60 );
453 0         0 return;
454             }
455              
456             sub _wheel_kill {
457 3     3   817 my ($kernel,$self,$reason) = @_[KERNEL,OBJECT,ARG0];
458 3 50       33 return if $self->{_killed};
459 3         41 $self->{_killed} = 1;
460 3 50       41 push @{ $self->{_wheel_log} }, $reason if ! $self->{no_log};
  3         41  
461 3 50 33     133 warn $reason, "\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG};
462 3 50 33     83 if ( $^O eq 'MSWin32' and $self->{wheel} ) {
463 0         0 $self->{wheel}->kill();
464             }
465             else {
466 3 50       30 if ( !$self->{no_grp_kill} ) {
467 0 0       0 if ( $^O eq 'solaris' ) {
468 0 0       0 kill( 9, '-' . $self->{wheel}->PID() ) if $self->{wheel};
469             }
470             else {
471 0 0       0 $self->{wheel}->kill(-9) if $self->{wheel};
472             }
473             }
474             # elsif ( $GOT_KILLFAM ) {
475             # _kill_family( 9, $self->{wheel}->PID() ) if $self->{wheel};
476             # }
477             else {
478 3 50       89 $self->{wheel}->kill(9) if $self->{wheel};
479             }
480             }
481 3         352 return;
482             }
483              
484             1;
485              
486             __END__