line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package POE::Component::SmokeBox::Backend; |
2
|
|
|
|
|
|
|
$POE::Component::SmokeBox::Backend::VERSION = '0.56'; |
3
|
|
|
|
|
|
|
#ABSTRACT: smoker backend to POE::Component::SmokeBox |
4
|
|
|
|
|
|
|
|
5
|
44
|
|
|
44
|
|
213662
|
use strict; |
|
44
|
|
|
|
|
107
|
|
|
44
|
|
|
|
|
1268
|
|
6
|
44
|
|
|
44
|
|
232
|
use warnings; |
|
44
|
|
|
|
|
98
|
|
|
44
|
|
|
|
|
1050
|
|
7
|
44
|
|
|
44
|
|
216
|
use Carp; |
|
44
|
|
|
|
|
89
|
|
|
44
|
|
|
|
|
2584
|
|
8
|
44
|
|
|
44
|
|
30639
|
use Storable; |
|
44
|
|
|
|
|
138897
|
|
|
44
|
|
|
|
|
2738
|
|
9
|
44
|
|
|
44
|
|
30861
|
use File::Temp (); |
|
44
|
|
|
|
|
419907
|
|
|
44
|
|
|
|
|
1380
|
|
10
|
44
|
|
|
44
|
|
317
|
use File::Path qw[rmtree]; |
|
44
|
|
|
|
|
126
|
|
|
44
|
|
|
|
|
1967
|
|
11
|
44
|
|
|
44
|
|
266
|
use File::Spec; |
|
44
|
|
|
|
|
107
|
|
|
44
|
|
|
|
|
981
|
|
12
|
44
|
|
|
44
|
|
227
|
use POSIX qw( O_CREAT O_RDWR O_RDONLY ); # for SDBM_File |
|
44
|
|
|
|
|
101
|
|
|
44
|
|
|
|
|
354
|
|
13
|
44
|
|
|
44
|
|
23139
|
use SDBM_File; |
|
44
|
|
|
|
|
20663
|
|
|
44
|
|
|
|
|
2017
|
|
14
|
44
|
|
|
44
|
|
787
|
use POE qw[Wheel::Run Filter::Line]; |
|
44
|
|
|
|
|
22650
|
|
|
44
|
|
|
|
|
463
|
|
15
|
44
|
|
|
44
|
|
1022950
|
use Digest::SHA qw[sha256_hex]; |
|
44
|
|
|
|
|
128152
|
|
|
44
|
|
|
|
|
3800
|
|
16
|
44
|
|
|
44
|
|
35011
|
use Regexp::Assemble; |
|
44
|
|
|
|
|
711340
|
|
|
44
|
|
|
|
|
1593
|
|
17
|
44
|
|
|
44
|
|
18804
|
use Env::Sanctify; |
|
44
|
|
|
|
|
21062
|
|
|
44
|
|
|
|
|
1721
|
|
18
|
44
|
|
|
44
|
|
22479
|
use Module::Pluggable search_path => 'POE::Component::SmokeBox::Backend', sub_name => 'backends', except => 'POE::Component::SmokeBox::Backend::Base'; |
|
44
|
|
|
|
|
435134
|
|
|
44
|
|
|
|
|
336
|
|
19
|
|
|
|
|
|
|
|
20
|
44
|
50
|
|
44
|
|
6382
|
use constant ON_FREEBSD => $^O =~ m!^(free|midnight|dragonfly)(bsd)?$! ? 1 : 0; |
|
44
|
|
|
|
|
121
|
|
|
44
|
|
|
|
|
9482
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
my $GOT_KILLFAM; |
23
|
|
|
|
|
|
|
my $GOT_PTY; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
BEGIN { |
26
|
44
|
|
|
44
|
|
196
|
$GOT_KILLFAM = 0; |
27
|
44
|
|
|
|
|
95
|
eval { |
28
|
44
|
|
|
|
|
5978
|
require Proc::ProcessTable; |
29
|
0
|
|
|
|
|
0
|
$GOT_KILLFAM = 1; |
30
|
|
|
|
|
|
|
}; |
31
|
44
|
|
|
|
|
207
|
$GOT_PTY = 0; |
32
|
44
|
|
|
|
|
110
|
eval { |
33
|
44
|
|
|
|
|
195
|
require IO::Pty; |
34
|
44
|
|
|
|
|
109
|
$GOT_PTY = 1; |
35
|
|
|
|
|
|
|
}; |
36
|
44
|
50
|
|
|
|
146971
|
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
|
7800
|
my $package = shift; |
60
|
7
|
|
|
|
|
28
|
return $package->spawn( @_, command => 'check' ); |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
sub index { |
64
|
5
|
|
|
5
|
1
|
5321
|
my $package = shift; |
65
|
5
|
|
|
|
|
16
|
return $package->spawn( @_, command => 'index' ); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub smoke { |
69
|
12
|
|
|
12
|
1
|
13639
|
my $package = shift; |
70
|
12
|
|
|
|
|
40
|
return $package->spawn( @_, command => 'smoke' ); |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub spawn { |
74
|
108
|
|
|
108
|
1
|
8654
|
my $package = shift; |
75
|
108
|
|
|
|
|
918
|
my %opts = @_; |
76
|
108
|
|
|
|
|
604
|
my $extra = { map { ( $_ => delete $opts{$_} ) } grep { /^\_/ } keys %opts }; |
|
0
|
|
|
|
|
0
|
|
|
852
|
|
|
|
|
2295
|
|
77
|
108
|
|
|
|
|
423
|
$opts{extra} = $extra; |
78
|
108
|
|
|
|
|
1297
|
$opts{lc $_} = delete $opts{$_} for keys %opts; |
79
|
108
|
|
|
|
|
1678
|
my $options = delete $opts{options}; |
80
|
108
|
50
|
|
|
|
1353
|
unless ( $opts{event} ) { |
81
|
0
|
|
|
|
|
0
|
carp "The 'event' parameter is a mandatory requirement\n"; |
82
|
0
|
|
|
|
|
0
|
return; |
83
|
|
|
|
|
|
|
} |
84
|
108
|
100
|
|
|
|
3332
|
$opts{idle} = 600 unless $opts{idle}; |
85
|
108
|
100
|
|
|
|
2139
|
$opts{timeout} = 3600 unless $opts{timeout}; |
86
|
108
|
100
|
|
|
|
2311
|
$opts{timer} = 60 unless $opts{timer}; |
87
|
108
|
50
|
|
|
|
359
|
$opts{reaper} = 30 unless $opts{reaper}; |
88
|
108
|
100
|
|
|
|
1417
|
$opts{type} = 'CPANPLUS::YACSmoke' unless $opts{type}; |
89
|
108
|
|
50
|
|
|
455
|
$opts{command} = lc $opts{command} || 'check'; |
90
|
108
|
50
|
|
|
|
428
|
$opts{command} = 'check' unless grep { $_ eq $opts{command} } @cmds; |
|
324
|
|
|
|
|
1306
|
|
91
|
108
|
50
|
|
|
|
409
|
$opts{perl} = $^X unless $opts{perl}; # and -e $opts{perl}; |
92
|
108
|
100
|
|
|
|
389
|
$opts{no_log} = 0 unless $opts{no_log}; |
93
|
108
|
100
|
|
|
|
360
|
$opts{check_warnings} = 1 unless exists $opts{check_warnings}; |
94
|
|
|
|
|
|
|
|
95
|
108
|
50
|
|
|
|
352
|
if ( $opts{check_warnings} ) { |
96
|
108
|
|
|
|
|
29289
|
require String::Perl::Warnings; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
108
|
50
|
66
|
|
|
67460308
|
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
|
|
|
|
|
849
|
my $self = bless \%opts, $package; |
104
|
108
|
|
|
|
|
1065
|
my @backends = $self->backends(); |
105
|
108
|
|
|
|
|
732606
|
my ($type) = grep { /\Q$opts{type}\E$/ } @backends; |
|
972
|
|
|
|
|
4241
|
|
106
|
108
|
100
|
|
|
|
553
|
unless ( $type ) { |
107
|
1
|
|
|
|
|
335
|
carp "No such backend '$opts{type}'\n"; |
108
|
1
|
|
|
|
|
23
|
return; |
109
|
|
|
|
|
|
|
} |
110
|
107
|
|
|
|
|
13425
|
eval "require $type;"; |
111
|
107
|
50
|
|
|
|
768
|
if ( $@ ) { |
112
|
0
|
|
|
|
|
0
|
carp "Could not load '$type' '$@'\n"; |
113
|
0
|
|
|
|
|
0
|
return; |
114
|
|
|
|
|
|
|
} |
115
|
107
|
|
|
|
|
982
|
$self->{backend} = $type->new(); |
116
|
107
|
50
|
33
|
|
|
590
|
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
|
|
|
|
832
|
if ( $self->{backend}->can('digest') ) { |
121
|
107
|
|
|
|
|
674
|
$self->{_reset_digest} = $self->{backend}->digest(); |
122
|
|
|
|
|
|
|
} |
123
|
107
|
|
|
|
|
357
|
my $cmd = $self->{command}; |
124
|
107
|
|
|
|
|
653
|
$self->{program} = $self->{backend}->$cmd; |
125
|
107
|
50
|
33
|
|
|
562
|
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
|
|
|
|
|
221
|
unshift @{ $self->{program} }, $self->{perl}; |
|
107
|
|
|
|
|
517
|
|
130
|
107
|
100
|
|
|
|
480
|
push @{ $self->{program} }, $self->{module} if $cmd eq 'smoke'; |
|
37
|
|
|
|
|
150
|
|
131
|
107
|
100
|
|
|
|
2319
|
$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
|
|
|
|
|
16718
|
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
|
|
44089
|
my ($kernel,$sender,$self) = @_[KERNEL,SENDER,OBJECT]; |
160
|
107
|
|
|
|
|
420
|
$self->{session_id} = $_[SESSION]->ID(); |
161
|
107
|
50
|
33
|
|
|
1028
|
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
|
|
|
|
|
243
|
my $sender_id; |
165
|
107
|
50
|
|
|
|
388
|
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
|
|
|
|
|
346
|
$sender_id = $sender->ID(); |
175
|
|
|
|
|
|
|
} |
176
|
107
|
|
|
|
|
851
|
$kernel->refcount_increment( $sender_id, __PACKAGE__ ); |
177
|
107
|
|
|
|
|
4785
|
$self->{session} = $sender_id; |
178
|
107
|
50
|
|
|
|
769
|
$kernel->detach_myself() if $kernel != $sender; |
179
|
|
|
|
|
|
|
|
180
|
107
|
|
|
|
|
16010
|
$self->{_wheel_log} = [ ]; |
181
|
|
|
|
|
|
|
|
182
|
107
|
100
|
|
|
|
432
|
if ( !$self->{_reset_digest} ) { |
183
|
74
|
|
|
|
|
416
|
$self->_tie_digests(); |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
else { |
186
|
33
|
|
|
|
|
96
|
$self->{_digests} = { }; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
107
|
|
|
|
|
344
|
$self->{_loop_detect} = 0; |
190
|
107
|
|
|
|
|
328
|
$self->{start_time} = time(); |
191
|
|
|
|
|
|
|
|
192
|
107
|
|
|
|
|
625
|
$kernel->yield( '_spawn_wheel' ); |
193
|
107
|
|
|
|
|
11237
|
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
|
|
242
|
my $self = shift; |
213
|
74
|
|
|
|
|
1174
|
$self->{_tempdir} = File::Temp->newdir(); |
214
|
74
|
|
|
|
|
43661
|
$self->{_tmpdirname} = $self->{_tempdir}->dirname; |
215
|
74
|
|
|
|
|
2099
|
my $file = File::Spec->catfile( $self->{_tmpdirname}, 'digests.dat' ); |
216
|
74
|
|
|
|
|
291
|
$self->{_digests} = { }; |
217
|
74
|
50
|
|
|
|
171
|
tie %{ $self->{_digests} }, 'SDBM_File', $file, O_CREAT|O_RDWR, 0644 or die "Could not tie: $!\n"; |
|
74
|
|
|
|
|
7287
|
|
218
|
74
|
|
|
|
|
401
|
return 1; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
sub _untie_digests { |
222
|
74
|
|
|
74
|
|
242
|
my $self = shift; |
223
|
74
|
50
|
|
|
|
555
|
if ( $self->{_digests} ) { |
224
|
74
|
|
|
|
|
174
|
untie %{ $self->{_digests} }; |
|
74
|
|
|
|
|
2879
|
|
225
|
74
|
|
|
|
|
735
|
delete $self->{_digests}; |
226
|
74
|
|
|
|
|
1429
|
delete $self->{_tempdir}; |
227
|
74
|
50
|
|
|
|
53646
|
rmtree( $self->{_tmpdirname} ) if -d $self->{_tmpdirname}; |
228
|
|
|
|
|
|
|
} |
229
|
74
|
|
|
|
|
336
|
return 1; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
sub _spawn_wheel { |
233
|
107
|
|
|
107
|
|
50179
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# do we need to process callbacks? |
236
|
107
|
100
|
|
|
|
562
|
if ( $self->{do_callback} ) { |
237
|
|
|
|
|
|
|
# Ask it if we should process this job or not? |
238
|
6
|
100
|
|
|
|
32
|
unless ( $self->{do_callback}->( 'BEFORE', $self ) ) { |
239
|
1
|
50
|
33
|
|
|
157
|
warn "Callback denied job, aborting!\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG}; |
240
|
1
|
|
|
|
|
7
|
my $job = $self->_finalize_job( -1 ); |
241
|
1
|
|
|
|
|
5
|
$job->{cb_kill} = 1; |
242
|
1
|
|
|
|
|
9
|
$kernel->post( $self->{session}, $self->{event}, $job ); |
243
|
1
|
|
|
|
|
131
|
return; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# Set appropriate %ENV values before we fork() |
248
|
|
|
|
|
|
|
my $sanctify = Env::Sanctify->sanctify( |
249
|
|
|
|
|
|
|
env => $self->{env}, |
250
|
106
|
|
|
|
|
3107
|
sanctify => [ |
251
|
|
|
|
|
|
|
'^POE_', |
252
|
|
|
|
|
|
|
'^PERL5_SMOKEBOX', |
253
|
|
|
|
|
|
|
'^HARNESS_', |
254
|
|
|
|
|
|
|
'^(PERL5LIB|TAP_VERSION|TEST_VERBOSE)$', |
255
|
|
|
|
|
|
|
'^AUTHOR_TESTING$', |
256
|
|
|
|
|
|
|
'^PERL_TEST', |
257
|
|
|
|
|
|
|
] ); |
258
|
106
|
|
|
|
|
74090
|
my $type = 'POE::Wheel::Run'; |
259
|
106
|
50
|
|
|
|
683
|
$type .= '::Win32' if $^O eq 'MSWin32'; |
260
|
|
|
|
|
|
|
$self->{wheel} = $type->new( |
261
|
|
|
|
|
|
|
Program => $self->{program}, |
262
|
106
|
50
|
|
|
|
1887
|
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
|
|
|
|
|
828204
|
$sanctify->restore(); |
272
|
106
|
|
|
|
|
9655
|
$self->{_wheel_time} = time(); |
273
|
106
|
|
|
|
|
1849
|
$self->{PID} = $self->{wheel}->PID(); |
274
|
106
|
|
|
|
|
2884
|
$kernel->sig_child( $self->{PID}, '_sig_child' ); |
275
|
106
|
100
|
|
|
|
32424
|
$kernel->delay( '_wheel_idle', $self->{timer} ) unless $self->{command} eq 'index'; |
276
|
106
|
|
|
|
|
19212
|
return; |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub _sig_child { |
280
|
106
|
|
|
106
|
|
73768
|
my ($kernel,$self,$thing,$pid,$status) = @_[KERNEL,OBJECT,ARG0..ARG2]; |
281
|
106
|
100
|
|
|
|
659
|
push @{ $self->{_wheel_log} }, "$thing $pid $status" if ! $self->{no_log}; |
|
105
|
|
|
|
|
838
|
|
282
|
106
|
50
|
33
|
|
|
1547
|
warn "$thing $pid $status\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG}; |
283
|
106
|
|
|
|
|
886
|
$kernel->sig_handled(); |
284
|
106
|
|
|
|
|
1996
|
$kernel->delay( '_wheel_idle' ); |
285
|
|
|
|
|
|
|
|
286
|
106
|
|
|
|
|
7441
|
my $job = $self->_finalize_job( $status ); |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
# do we need to process callbacks? |
289
|
106
|
100
|
|
|
|
522
|
if ( $self->{do_callback} ) { |
290
|
|
|
|
|
|
|
# Inform the callback that the job is done |
291
|
5
|
|
|
|
|
35
|
$self->{do_callback}->( 'AFTER', $self, $job ); |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
106
|
|
|
|
|
3019
|
$kernel->post( $self->{session}, $self->{event}, $job ); |
295
|
106
|
100
|
|
|
|
15730
|
$kernel->delay( '_wheel_reap' => $self->{reaper} ) if $self->{wheel}; |
296
|
106
|
|
|
|
|
680
|
return; |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
sub _finalize_job { |
300
|
107
|
|
|
107
|
|
485
|
my( $self, $status ) = @_; |
301
|
|
|
|
|
|
|
|
302
|
107
|
|
|
|
|
567
|
$self->{end_time} = time(); |
303
|
|
|
|
|
|
|
|
304
|
107
|
100
|
|
|
|
560
|
if ( !$self->{_reset_digest} ) { |
305
|
74
|
|
|
|
|
392
|
$self->_untie_digests(); |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
else { |
308
|
33
|
|
|
|
|
174
|
delete $self->{_digests}; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
107
|
|
|
|
|
421
|
delete $self->{_loop_detect}; |
312
|
|
|
|
|
|
|
|
313
|
107
|
|
|
|
|
560
|
my $job = { }; |
314
|
107
|
|
|
|
|
905
|
$job->{status} = $status; |
315
|
107
|
|
|
|
|
773
|
$job->{log} = $self->{_wheel_log}; |
316
|
107
|
|
|
|
|
328
|
$job->{$_} = $self->{extra}->{$_} for keys %{ $self->{extra} }; |
|
107
|
|
|
|
|
646
|
|
317
|
107
|
|
|
|
|
555
|
$job->{$_} = $self->{$_} for grep { $self->{$_} } qw(command env PID start_time end_time idle_kill excess_kill term_kill perl type); |
|
1070
|
|
|
|
|
4559
|
|
318
|
107
|
50
|
33
|
|
|
1628
|
$job->{program} = $self->{program} if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG}; |
319
|
107
|
100
|
|
|
|
858
|
$job->{module} = $self->{module} if $self->{command} eq 'smoke'; |
320
|
107
|
|
|
|
|
779
|
$poe_kernel->refcount_decrement( $self->{session}, __PACKAGE__ ); |
321
|
|
|
|
|
|
|
|
322
|
107
|
|
|
|
|
7861
|
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
|
|
84147519
|
my ($self,$operation,$errnum,$errstr,$wheel_id) = @_[OBJECT,ARG0..ARG3]; |
334
|
212
|
100
|
66
|
|
|
2733
|
$errstr = "remote end closed" if $operation eq "read" and !$errnum; |
335
|
212
|
50
|
33
|
|
|
2340
|
warn "wheel $wheel_id generated $operation error $errnum: $errstr\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG}; |
336
|
212
|
|
|
|
|
964
|
return; |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub _wheel_closed { |
340
|
106
|
|
|
106
|
|
5840
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
341
|
106
|
|
|
|
|
733
|
$kernel->delay( '_wheel_idle' ); |
342
|
106
|
|
|
|
|
13139
|
$kernel->delay( '_wheel_reap' ); |
343
|
106
|
50
|
33
|
|
|
7375
|
warn "wheel closed\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG}; |
344
|
106
|
|
|
|
|
1473
|
delete $self->{wheel}; |
345
|
106
|
|
|
|
|
50065
|
return; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
sub _wheel_stdout { |
349
|
1074
|
|
|
1074
|
|
15135604
|
my ($self, $input, $wheel_id) = @_[OBJECT, ARG0, ARG1]; |
350
|
1074
|
100
|
|
|
|
3047
|
return if $self->{_killed}; |
351
|
381
|
|
|
|
|
750
|
$self->{_wheel_time} = time(); |
352
|
381
|
100
|
|
|
|
934
|
push @{ $self->{_wheel_log} }, $input if ! $self->{no_log}; |
|
380
|
|
|
|
|
972
|
|
353
|
381
|
50
|
33
|
|
|
1972
|
warn $input, "\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG}; |
354
|
381
|
100
|
|
|
|
1052
|
if ( $self->_detect_loop( $input, 'stdout' ) ) { |
355
|
1
|
|
|
|
|
4
|
$self->{excess_kill} = 1; |
356
|
1
|
|
|
|
|
12
|
$poe_kernel->yield( '_wheel_kill', 'Killing current run due to detection of looping output' ); |
357
|
|
|
|
|
|
|
} |
358
|
381
|
|
|
|
|
1563
|
return; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
sub _wheel_stderr { |
362
|
42
|
|
|
42
|
|
23321
|
my ($self, $input, $wheel_id) = @_[OBJECT, ARG0, ARG1]; |
363
|
42
|
50
|
|
|
|
384
|
return if $self->{_killed}; |
364
|
42
|
|
|
|
|
415
|
$self->{_wheel_time} = time(); |
365
|
42
|
50
|
|
|
|
279
|
push @{ $self->{_wheel_log} }, $input if ! $self->{no_log}; |
|
42
|
|
|
|
|
270
|
|
366
|
42
|
50
|
33
|
|
|
733
|
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
|
|
|
|
496
|
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
|
|
|
|
|
288
|
return; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
sub _detect_loop { |
382
|
423
|
|
|
423
|
|
908
|
my $self = shift; |
383
|
423
|
|
50
|
|
|
1158
|
my $input = shift || return; |
384
|
423
|
|
50
|
|
|
1149
|
my $handle = shift || 'stdout'; |
385
|
423
|
100
|
|
|
|
1184
|
return if $self->{_loop_detect}; |
386
|
350
|
100
|
|
|
|
1014
|
if ( my $reset = $self->{_reset_digest} ) { |
387
|
33
|
50
|
|
|
|
115
|
if ( eval { $input =~ $reset } ) { |
|
33
|
|
|
|
|
526
|
|
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
|
|
|
|
1662
|
return if $input =~ /^\[(MSG|ERROR)\]/; |
393
|
350
|
|
|
|
|
2896
|
my $digest = sha256_hex( $input ); |
394
|
|
|
|
|
|
|
|
395
|
350
|
|
|
|
|
800
|
my $weighting; |
396
|
350
|
50
|
|
|
|
2010
|
if ( ON_FREEBSD and $handle eq 'stderr' and _fbsd_compiler_warnings($input) ) { |
397
|
|
|
|
|
|
|
$weighting = 0.01; |
398
|
|
|
|
|
|
|
} |
399
|
0
|
50
|
|
|
|
0
|
elsif ( $self->{check_warnings} and length( $input ) <= 5000 ) { |
400
|
350
|
50
|
66
|
|
|
1587
|
$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
|
|
|
|
33902
|
if ( exists $self->{_digests}->{ $digest } ) { |
406
|
277
|
|
|
|
|
6056
|
$self->{_digests}->{ $digest } += $weighting; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
else { |
409
|
73
|
|
|
|
|
2620
|
$self->{_digests}->{ $digest } = $weighting; |
410
|
|
|
|
|
|
|
} |
411
|
350
|
100
|
|
|
|
8147
|
return unless ++$self->{_digests}->{ $digest } > 3000; |
412
|
1
|
|
|
|
|
6
|
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 _fbsd_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
|
|
15012914
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
441
|
2
|
|
|
|
|
19
|
my $now = time(); |
442
|
2
|
100
|
|
|
|
37
|
if ( $now - $self->{_wheel_time} >= $self->{idle} ) { |
443
|
1
|
|
|
|
|
12
|
$self->{idle_kill} = 1; |
444
|
1
|
|
|
|
|
20
|
$kernel->yield( '_wheel_kill', 'Killing current run due to excessive idle' ); |
445
|
1
|
|
|
|
|
132
|
return; |
446
|
|
|
|
|
|
|
} |
447
|
1
|
50
|
|
|
|
7
|
if ( $now - $self->{start_time} >= $self->{timeout} ) { |
448
|
1
|
|
|
|
|
8
|
$self->{excess_kill} = 1; |
449
|
1
|
|
|
|
|
12
|
$kernel->yield( '_wheel_kill', 'Killing current run due to excessive run-time' ); |
450
|
1
|
|
|
|
|
127
|
return; |
451
|
|
|
|
|
|
|
} |
452
|
0
|
|
|
|
|
0
|
$kernel->delay( '_wheel_idle', 60 ); |
453
|
0
|
|
|
|
|
0
|
return; |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
sub _wheel_kill { |
457
|
3
|
|
|
3
|
|
632
|
my ($kernel,$self,$reason) = @_[KERNEL,OBJECT,ARG0]; |
458
|
3
|
50
|
|
|
|
38
|
return if $self->{_killed}; |
459
|
3
|
|
|
|
|
20
|
$self->{_killed} = 1; |
460
|
3
|
50
|
|
|
|
55
|
push @{ $self->{_wheel_log} }, $reason if ! $self->{no_log}; |
|
3
|
|
|
|
|
30
|
|
461
|
3
|
50
|
33
|
|
|
61
|
warn $reason, "\n" if $self->{debug} or $ENV{PERL5_SMOKEBOX_DEBUG}; |
462
|
3
|
50
|
33
|
|
|
58
|
if ( $^O eq 'MSWin32' and $self->{wheel} ) { |
463
|
0
|
|
|
|
|
0
|
$self->{wheel}->kill(); |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
else { |
466
|
3
|
50
|
|
|
|
33
|
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
|
|
|
|
60
|
$self->{wheel}->kill(9) if $self->{wheel}; |
479
|
|
|
|
|
|
|
} |
480
|
|
|
|
|
|
|
} |
481
|
3
|
|
|
|
|
230
|
return; |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
1; |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
__END__ |