line |
stmt |
code |
1
|
|
# Copyright 2009-2013 Bernhard M. Wiedemann |
2
|
|
# Copyright 2012-2021 SUSE LLC |
3
|
|
# SPDX-License-Identifier: GPL-2.0-or-later |
4
|
|
|
5
|
|
# this is an abstract class |
6
|
|
|
7
|
|
use Mojo::Base -base, -signatures; |
8
|
37
|
use feature 'say'; |
|
37
|
|
|
37
|
|
9
|
37
|
use autodie ':all'; |
|
37
|
|
|
37
|
|
10
|
37
|
|
|
37
|
|
|
37
|
|
11
|
|
use Carp qw(carp confess); |
12
|
37
|
use Mojo::JSON; # booleans |
|
37
|
|
|
37
|
|
13
|
37
|
use Cpanel::JSON::XS (); |
|
37
|
|
|
37
|
|
14
|
37
|
use File::Copy 'cp'; |
|
37
|
|
|
37
|
|
15
|
37
|
use File::Basename; |
|
37
|
|
|
37
|
|
16
|
37
|
use Time::HiRes qw(gettimeofday time tv_interval); |
|
37
|
|
|
37
|
|
17
|
37
|
use Try::Tiny; |
|
37
|
|
|
37
|
|
18
|
37
|
use POSIX qw(_exit :sys_wait_h); |
|
37
|
|
|
37
|
|
19
|
37
|
use IO::Select; |
|
37
|
|
|
37
|
|
20
|
37
|
require IPC::System::Simple; |
|
37
|
|
|
37
|
|
21
|
|
use myjsonrpc; |
22
|
37
|
use Net::SSH2 'LIBSSH2_ERROR_EAGAIN'; |
|
37
|
|
|
37
|
|
23
|
37
|
use OpenQA::Benchmark::Stopwatch; |
|
37
|
|
|
37
|
|
24
|
37
|
use MIME::Base64 'encode_base64'; |
|
37
|
|
|
37
|
|
25
|
37
|
use List::Util 'min'; |
|
37
|
|
|
37
|
|
26
|
37
|
use List::MoreUtils 'uniq'; |
|
37
|
|
|
37
|
|
27
|
37
|
use Scalar::Util 'looks_like_number'; |
|
37
|
|
|
37
|
|
28
|
37
|
use Mojo::File 'path'; |
|
37
|
|
|
37
|
|
29
|
37
|
use OpenQA::Exceptions; |
|
37
|
|
|
37
|
|
30
|
37
|
use Time::Seconds; |
|
37
|
|
|
37
|
|
31
|
37
|
use English -no_match_vars; |
|
37
|
|
|
37
|
|
32
|
37
|
use OpenQA::NamedIOSelect; |
|
37
|
|
|
37
|
|
33
|
37
|
|
|
37
|
|
|
37
|
|
34
|
|
use constant FULL_SCREEN_SEARCH_FREQUENCY => $ENV{OS_AUTOINST_FULL_SCREEN_SEARCH_FREQUENCY} // 5; |
35
|
37
|
use constant FULL_UPDATE_REQUEST_FREQUENCY => $ENV{OS_AUTOINST_FULL_UPDATE_REQUEST_FREQUENCY} // 5; |
|
37
|
|
|
37
|
|
36
|
37
|
|
|
37
|
|
|
37
|
|
37
|
|
# should be a singleton - and only useful in backend process |
38
|
|
our $backend; |
39
|
|
|
40
|
|
has [qw( |
41
|
|
update_request_interval last_update_request screenshot_interval |
42
|
|
last_screenshot last_image assert_screen_check |
43
|
|
reference_screenshot assert_screen_tags assert_screen_needles |
44
|
|
assert_screen_deadline assert_screen_fails assert_screen_last_check |
45
|
|
stall_detected |
46
|
|
)]; |
47
|
|
|
48
|
|
my $self = bless({class => $class}, $class); |
49
|
68
|
$self->{started} = 0; |
|
68
|
|
|
68
|
|
50
|
68
|
$self->{serialfile} = "serial0"; |
51
|
68
|
$self->{serial_offset} = 0; |
52
|
68
|
$self->{video_frame_data} = []; |
53
|
68
|
$self->{video_frame_number} = 0; |
54
|
68
|
$self->{video_encoders} = {}; |
55
|
68
|
$self->{external_video_encoder_image_data} = []; |
56
|
68
|
$self->{min_image_similarity} = 10000; |
57
|
68
|
$self->{min_video_similarity} = 10000; |
58
|
68
|
$self->{children} = []; |
59
|
68
|
$self->{ssh_connections} = {}; |
60
|
68
|
$self->{xres} = $bmwqemu::vars{XRES} // 1024; |
61
|
68
|
$self->{yres} = $bmwqemu::vars{YRES} // 768; |
62
|
68
|
|
63
|
68
|
return $self; |
64
|
|
} |
65
|
68
|
|
66
|
|
open(my $sf, '>', $self->{serialfile}); |
67
|
|
close($sf); |
68
|
14
|
} |
|
14
|
|
|
14
|
|
69
|
14
|
|
70
|
14
|
# runs in the backend process to deserialize VNC commands |
71
|
|
my $func = $cmd->{cmd}; |
72
|
|
die "not supported command: $func" unless $self->can($func); |
73
|
|
return $self->$func($cmd->{arguments}); |
74
|
205
|
} |
|
205
|
|
|
205
|
|
|
205
|
|
75
|
205
|
|
76
|
205
|
chomp($msg); |
77
|
205
|
bmwqemu::fctinfo "Backend process died, backend errors are reported below in the following lines:\n$msg"; |
78
|
|
bmwqemu::serialize_state(component => 'backend', msg => $msg); |
79
|
|
$backend->stop_vm(); |
80
|
2
|
$backend->close_pipes(); |
|
2
|
|
|
2
|
|
81
|
2
|
} |
82
|
2
|
|
83
|
2
|
bmwqemu::diag("backend got $sig"); |
84
|
2
|
$backend->stop_vm; |
85
|
1
|
} |
86
|
|
|
87
|
|
die "there can be only one!" if $backend; |
88
|
1
|
$backend = $self; |
|
1
|
|
|
1
|
|
89
|
1
|
|
90
|
1
|
$SIG{__DIE__} = \&die_handler; |
91
|
|
$SIG{TERM} = \&backend_signalhandler; |
92
|
|
|
93
|
11
|
my $io = IO::Handle->new(); |
|
11
|
|
|
11
|
|
|
11
|
|
|
11
|
|
94
|
11
|
$io->fdopen($cmdpipe, "r") || die "r fdopen $!"; |
95
|
11
|
$self->{cmdpipe} = $io; |
96
|
|
|
97
|
11
|
$io = IO::Handle->new(); |
98
|
11
|
$io->fdopen($rsppipe, "w") || die "w fdopen $!"; |
99
|
|
$rsppipe = $io; |
100
|
11
|
$io->autoflush(1); |
101
|
11
|
$self->{rsppipe} = $io; |
102
|
10
|
|
103
|
|
bmwqemu::diag "$$: cmdpipe " . fileno($self->{cmdpipe}) . ', rsppipe ' . fileno($self->{rsppipe}); |
104
|
10
|
|
105
|
10
|
bmwqemu::diag "started mgmt loop with pid $$"; |
106
|
10
|
|
107
|
10
|
my $select_read = $self->{select_read} = OpenQA::NamedIOSelect->new; |
108
|
10
|
my $select_write = $self->{select_write} = OpenQA::NamedIOSelect->new; |
109
|
|
$select_read->add($self->{cmdpipe}, "baseclass::cmdpipe"); |
110
|
10
|
$select_write->add($self->{cmdpipe}, "baseclass::cmdpipe"); |
111
|
|
|
112
|
10
|
$self->last_update_request("-Inf" + 0); |
113
|
|
$self->last_screenshot(undef); |
114
|
10
|
$self->screenshot_interval($bmwqemu::vars{SCREENSHOTINTERVAL} || .5); |
115
|
10
|
# query the VNC backend more often than we write out screenshots, so the chances |
116
|
10
|
# are high we're not writing out outdated screens |
117
|
10
|
$self->update_request_interval($self->screenshot_interval / 2); |
118
|
|
|
119
|
10
|
for my $console (values %{$testapi::distri->{consoles}}) { |
120
|
10
|
# tell the consoles who they need to talk to (in this thread) |
121
|
10
|
$console->backend($self); |
122
|
|
} |
123
|
|
|
124
|
10
|
$self->run_capture_loop; |
125
|
|
|
126
|
10
|
bmwqemu::diag("management process exit at " . POSIX::strftime("%F %T", gmtime)); |
|
10
|
|
127
|
|
} |
128
|
16
|
|
129
|
|
# write as much data as possible (this is called when $fh is ready to write) |
130
|
|
my $data = shift @$array_of_buffers; |
131
|
10
|
my $data_written = $fh->syswrite($data); |
132
|
|
die "$program_name not accepting data: $!" unless defined $data_written; |
133
|
0
|
|
134
|
|
# put remaining data it back into the queue |
135
|
|
unshift @$array_of_buffers, substr($data, $data_written) unless $data_written == length($data); |
136
|
10532
|
|
|
10532
|
|
|
10532
|
|
|
10532
|
|
|
10532
|
|
|
10532
|
|
137
|
|
# remove file handle from selects if there's no more data to write |
138
|
10532
|
if (!@$array_of_buffers) { |
139
|
10532
|
$self->{select_read}->remove($fh); |
140
|
10532
|
$self->{select_write}->remove($fh); |
141
|
|
} |
142
|
|
} |
143
|
10532
|
|
144
|
|
# Time slot buckets |
145
|
|
my $buckets = {}; |
146
|
10532
|
my $wait_time_limit = $bmwqemu::vars{_CHKSEL_RATE_WAIT_TIME} // 30; |
147
|
325
|
my $hits_limit = $bmwqemu::vars{_CHKSEL_RATE_HITS} // 30_000; |
148
|
325
|
|
149
|
|
while (1) { |
150
|
|
last unless $self->{cmdpipe}; |
151
|
|
my $now = gettimeofday; |
152
|
2803
|
my $time_to_timeout = "Inf" + 0; |
|
2803
|
|
|
2803
|
|
|
2803
|
|
|
2803
|
|
153
|
|
if (defined $timeout && defined $starttime) { |
154
|
2803
|
$time_to_timeout = $timeout - ($now - $starttime); |
155
|
2803
|
last if $time_to_timeout <= 0; |
156
|
2803
|
} |
157
|
|
|
158
|
2803
|
my $time_to_update_request = $self->update_request_interval - ($now - $self->last_update_request); |
159
|
16629
|
if ($time_to_update_request <= 0) { |
160
|
16627
|
$self->request_screen_update(); |
161
|
16627
|
$self->last_update_request($now); |
162
|
16627
|
# no need to interrupt loop if VNC does not talk to us first |
163
|
14272
|
$time_to_update_request = $time_to_timeout; |
164
|
14272
|
} |
165
|
|
|
166
|
|
# if we got stalled for a long time, we assume bad hardware and report it |
167
|
13836
|
if ($self->assert_screen_last_check && $now - $self->last_screenshot > $self->screenshot_interval * 20) { |
168
|
13836
|
$self->stall_detected(1); |
169
|
641
|
my $diff = $now - $self->last_screenshot; |
170
|
641
|
bmwqemu::fctwarn "There is some problem with your environment, we detected a stall for $diff seconds"; |
171
|
|
} |
172
|
641
|
|
173
|
|
my $time_to_screenshot = $self->screenshot_interval - ($now - $self->last_screenshot); |
174
|
|
if ($time_to_screenshot <= 0) { |
175
|
|
$self->capture_screenshot(); |
176
|
13836
|
$self->last_screenshot($now); |
177
|
0
|
$time_to_screenshot = $self->screenshot_interval; |
178
|
0
|
} |
179
|
0
|
|
180
|
|
my $time_to_next = min($time_to_screenshot, $time_to_update_request, $time_to_timeout); |
181
|
|
my ($read_set, $write_set) = IO::Select->select($self->{select_read}->select(), $self->{select_write}->select(), undef, $time_to_next); |
182
|
13836
|
|
183
|
13836
|
# We need to check the video encoder and the serial socket |
184
|
322
|
my ($video_encoder, $external_video_encoder, $other) = (0, 0, 0); |
185
|
322
|
for my $fh (@$write_set) { |
186
|
322
|
if ($fh == $self->{encoder_pipe}) { |
187
|
|
$self->_write_buffered_data_to_file_handle('Encoder', $self->{video_frame_data}, $fh); |
188
|
|
$video_encoder = 1; |
189
|
13836
|
} |
190
|
13836
|
elsif ($fh == $self->{external_video_encoder_cmd_pipe}) { |
191
|
|
$self->_write_buffered_data_to_file_handle('External encoder', $self->{external_video_encoder_image_data}, $fh); |
192
|
|
$external_video_encoder = 1; |
193
|
13836
|
} |
194
|
13836
|
else { |
195
|
10496
|
next if $other; |
196
|
10496
|
$other = 1; |
197
|
10496
|
die "error checking socket for write: $fh\n" unless $self->check_socket($fh, 1) || $other; |
198
|
|
} |
199
|
|
last if $video_encoder == 1 && $external_video_encoder == 1 && $other; |
200
|
0
|
} |
201
|
0
|
|
202
|
|
for my $fh (@$read_set) { |
203
|
|
# This tries to solve the problem of half-open sockets (when reading, as writing will throw an exception) |
204
|
0
|
# There are three ways to solve this problem: |
205
|
0
|
# + Send a message either to the application protocol (null message) or to the application protocol framing (an empty message) |
206
|
0
|
# Disadvantages: Requires changes on both ends of the communication. (for example: on SSH connection i realized that after a |
207
|
|
# while I start getting "bad packet length" errors) |
208
|
10496
|
# + Polling the connections (Note: This is how HTTP servers work when dealing with persistent connections) |
209
|
|
# Disadvantages: False positives |
210
|
|
# + Change the keepalive packet settings |
211
|
13836
|
# Disadvantages: TCP/IP stacks are not required to support keepalives. |
212
|
|
if (fileno $fh && fileno $fh != -1) { |
213
|
|
# Very high limits! On a working socket, the maximum hits per 10 seconds will be around 60. |
214
|
|
# The maximum hits per 10 seconds saw on a half open socket was >100k |
215
|
|
if (check_select_rate($buckets, $wait_time_limit, $hits_limit, fileno $fh, time())) { |
216
|
|
my $console = $self->{current_console}->{testapi_console}; |
217
|
|
my $fd_nr = fileno $fh; |
218
|
|
my $cnt = $buckets->{BUCKET}{$fd_nr}; |
219
|
|
my $name = $self->{select_read}->get_name($fh); |
220
|
|
my $msg = "The file descriptor $fd_nr ($name) hit the read attempts threshold of $hits_limit/${wait_time_limit}s by $cnt. "; |
221
|
202
|
$msg .= "Active console '$console' is not responding, it could be a half-open socket or you need to increase _CHKSEL_RATE_HITS value. "; |
222
|
|
$msg .= "Make sure the console is reachable or disable stall detection on expected disconnects with '\$console->disable_vnc_stalls', for example in case of intended machine shutdown."; |
223
|
|
OpenQA::Exception::ConsoleReadError->throw(error => $msg); |
224
|
202
|
} |
225
|
0
|
} |
226
|
0
|
|
227
|
0
|
|
228
|
0
|
die "error checking socket for read: $fh\n" unless $self->check_socket($fh, 0); |
229
|
0
|
# don't check for further sockets after this one as |
230
|
0
|
# check_socket can have side effects on the sockets |
231
|
0
|
# (e.g. console resets), so better take the next socket |
232
|
0
|
# next time |
233
|
|
last; |
234
|
|
} |
235
|
|
} |
236
|
|
} |
237
|
202
|
|
238
|
|
=head2 run_capture_loop($timeout) |
239
|
|
|
240
|
|
=out |
241
|
|
|
242
|
192
|
=item timeout |
243
|
|
|
244
|
|
run the loop this long in seconds, indefinitely if undef, or until the |
245
|
|
$self->{cmdpipe} is closed, whichever occurs first. |
246
|
|
|
247
|
|
=back |
248
|
|
|
249
|
|
=cut |
250
|
|
|
251
|
|
my $starttime = gettimeofday; |
252
|
|
$self->last_screenshot($starttime) unless $self->last_screenshot; |
253
|
|
|
254
|
|
eval { $self->do_capture($timeout, $starttime) }; |
255
|
|
return unless $@; |
256
|
|
bmwqemu::fctwarn "capture loop failed $@"; |
257
|
|
$self->close_pipes(); |
258
|
|
} |
259
|
|
|
260
|
2803
|
# wait_time_limit = seconds |
|
2803
|
|
|
2803
|
|
|
2803
|
|
261
|
2803
|
# This is not sliding buckets. All the IDs inside the bucket must be over the limit! |
262
|
2803
|
my $lower_limit = $buckets->{TIME} //= $time; |
263
|
|
my $upper_limit = $lower_limit + $wait_time_limit; |
264
|
2803
|
if ($time > $upper_limit) { |
|
2803
|
|
265
|
2793
|
$buckets->{TIME} = $time; |
266
|
0
|
|
267
|
0
|
# This is to give the opportunity to recover, if the reboot/restart is slow |
268
|
|
for (keys %{$buckets->{BUCKET}}) { |
269
|
|
if ($buckets->{BUCKET}{$_} < $hits_limit) { |
270
|
|
$buckets->{BUCKET} = {$id => 1}; |
271
|
|
return 0; |
272
|
292
|
} |
|
292
|
|
|
292
|
|
|
292
|
|
|
292
|
|
|
292
|
|
|
292
|
|
273
|
292
|
} |
274
|
292
|
|
275
|
292
|
return 1; |
276
|
6
|
} |
277
|
|
$buckets->{BUCKET}{$id}++; |
278
|
|
return 0; |
279
|
6
|
} |
|
6
|
|
280
|
9
|
|
281
|
4
|
my $pid = open($self->{$pipe_name}, '|-', @cmd); |
282
|
4
|
my $pipe = $self->{$pipe_name}; |
283
|
|
$self->{video_encoders}->{$pid} = {name => $display_name, pipe => $pipe}; |
284
|
|
$pipe->blocking(0); |
285
|
|
} |
286
|
2
|
|
287
|
|
return 0 if $bmwqemu::vars{NOVIDEO}; |
288
|
286
|
|
289
|
286
|
my $cmd = $bmwqemu::vars{EXTERNAL_VIDEO_ENCODER_CMD} or return 0; |
290
|
|
my $output_file_name = $bmwqemu::vars{EXTERNAL_VIDEO_ENCODER_OUTPUT_FILE_EXTENSION} // 'webm'; |
291
|
|
my $output_file_path = Cwd::getcwd . "/video.$output_file_name"; |
292
|
10
|
$cmd .= " '$output_file_path'" unless $cmd =~ s/%OUTPUT_FILE_NAME%/$output_file_path/; |
|
10
|
|
|
10
|
|
|
10
|
|
|
10
|
|
|
10
|
|
293
|
10
|
|
294
|
10
|
bmwqemu::diag "Launching external video encoder: $cmd"; |
295
|
10
|
$self->_invoke_video_encoder(external_video_encoder_cmd_pipe => 'external video encoder', $cmd); |
296
|
10
|
return 1; |
297
|
|
} |
298
|
|
|
299
|
10
|
# start external video encoder if configured |
|
10
|
|
|
10
|
|
300
|
10
|
my $has_external_video_encoder_configured = $self->_start_external_video_encoder_if_configured; |
301
|
|
|
302
|
10
|
# start internal video encoder; only start it to generate PNGs if an external video encoder is used or NOVIDEO set |
303
|
0
|
my $cwd = Cwd::getcwd; |
304
|
0
|
my @cmd = (qw(nice -n 19), "$bmwqemu::scriptdir/videoencoder", "$cwd/video.ogv"); |
305
|
0
|
push(@cmd, '-n') if $bmwqemu::vars{NOVIDEO} || ($has_external_video_encoder_configured && !$bmwqemu::vars{EXTERNAL_VIDEO_ENCODER_ADDITIONALLY}); |
306
|
|
push @cmd, '-x', $self->{xres}, '-y', $self->{yres}; |
307
|
0
|
$self->_invoke_video_encoder(encoder_pipe => 'built-in video encoder', @cmd); |
308
|
0
|
|
309
|
0
|
# open file for recording real time clock timestamps as subtitle |
310
|
|
open($self->{vtt_caption_file}, '>', "$cwd/video_time.vtt"); |
311
|
|
$self->{vtt_caption_file}->print("WEBVTT\n"); |
312
|
10
|
|
|
10
|
|
|
10
|
|
313
|
|
return; |
314
|
10
|
} |
315
|
|
|
316
|
|
my $video_encoders = delete $self->{video_encoders}; |
317
|
10
|
return undef unless defined $video_encoders && keys %$video_encoders; |
318
|
10
|
|
319
|
10
|
# pass remaining video frames to the video encoder |
320
|
10
|
bmwqemu::diag 'Passing remaining frames to the video encoder'; |
321
|
10
|
my $timeout = 30; |
322
|
|
my $video_data_for_internal_encoder = $self->{video_frame_data}; |
323
|
|
my $video_data_for_external_encoder = $self->{external_video_encoder_image_data}; |
324
|
10
|
my $select = IO::Select->new; |
325
|
10
|
$select->add(my $internal_pipe = $self->{encoder_pipe}) if @$video_data_for_internal_encoder; |
326
|
|
$select->add(my $external_pipe = $self->{external_video_encoder_cmd_pipe}) if @$video_data_for_external_encoder; |
327
|
10
|
try { |
328
|
|
while ($select->count) { |
329
|
|
$! = 0; |
330
|
11
|
die($! ? "$!\n" : 'timeout exceeded') unless my @ready = $select->can_write($timeout); |
|
11
|
|
|
11
|
|
331
|
11
|
for my $fh (@ready) { |
332
|
11
|
if (defined $internal_pipe && $fh == $internal_pipe) { |
333
|
|
$self->_write_buffered_data_to_file_handle('Encoder', $video_data_for_internal_encoder, $fh); |
334
|
|
$select->remove($fh) unless @$video_data_for_internal_encoder; |
335
|
10
|
} |
336
|
10
|
elsif (defined $external_pipe && $fh == $external_pipe) { |
337
|
10
|
$self->_write_buffered_data_to_file_handle('External encoder', $video_data_for_external_encoder, $fh); |
338
|
10
|
$select->remove($fh) unless @$video_data_for_external_encoder; |
339
|
10
|
} |
340
|
10
|
} |
341
|
10
|
} |
342
|
|
} |
343
|
10
|
catch { |
344
|
19
|
bmwqemu::diag "Unable to pass remaining frames to video encoder: $_"; |
345
|
19
|
}; |
346
|
19
|
|
347
|
37
|
# give the video encoder processes time to finalize the video |
348
|
19
|
# note: Closing the pipe should cause the video encoder to terminate. Not sending SIGTERM/SIGINT because the signal might be |
349
|
18
|
# already sent by the worker or shell and ffmpeg will not continue finalizing the video after receiving a 2nd exit signal. |
350
|
|
no autodie qw(close waitpid); |
351
|
|
close $video_encoders->{$_}->{pipe} for keys %$video_encoders; |
352
|
18
|
bmwqemu::diag 'Waiting for video encoder to finalize the video'; |
353
|
18
|
for (my $interval = 0.25; $timeout > 0; sleep($interval), $timeout -= $interval) { |
354
|
|
for my $pid (keys %$video_encoders) { |
355
|
|
my $ret = waitpid($pid, WNOHANG); |
356
|
|
if ($ret == $pid || $ret == -1) { |
357
|
|
bmwqemu::diag "The $video_encoders->{$pid}->{name} (pid $pid) terminated"; |
358
|
|
delete $video_encoders->{$pid}; |
359
|
1
|
} |
360
|
10
|
} |
361
|
|
last unless keys %$video_encoders; |
362
|
|
} |
363
|
|
return undef unless keys %$video_encoders; |
364
|
|
bmwqemu::diag "Unable to terminate $video_encoders->{$_}->{name}, sending SIGKILL" for keys %$video_encoders; |
365
|
37
|
kill KILL => (keys %$video_encoders); |
|
37
|
|
|
37
|
|
366
|
10
|
} |
367
|
10
|
|
368
|
10
|
# new api |
369
|
486
|
|
370
|
486
|
$self->{started} = 1; |
371
|
486
|
$self->start_encoder(); |
372
|
6
|
return $self->do_start_vm(); |
373
|
6
|
} |
374
|
|
|
375
|
|
if ($self->{started}) { |
376
|
486
|
# backend.run might have disappeared already in case of failed builds |
377
|
|
no autodie 'unlink'; |
378
|
10
|
unlink('backend.run'); |
379
|
4
|
$self->do_stop_vm(); |
380
|
4
|
$self->{started} = 0; |
381
|
|
} |
382
|
|
$self->_stop_video_encoder(); |
383
|
|
$self->close_ssh_connections(); |
384
|
|
$self->close_pipes(); # does not return |
385
|
10
|
return; |
|
10
|
|
|
10
|
|
386
|
10
|
} |
387
|
10
|
|
388
|
10
|
return 0 unless $self->{started}; |
389
|
|
return 1 if $self->file_alive() and $self->raw_alive(); |
390
|
|
bmwqemu::fctwarn("ALARM: backend.run got deleted! - exiting..."); |
391
|
11
|
_exit(1); |
|
11
|
|
|
11
|
|
392
|
11
|
} |
393
|
|
|
394
|
37
|
# new api end |
|
37
|
|
|
37
|
|
395
|
6
|
|
396
|
6
|
# virtual methods |
397
|
6
|
my $method = (caller(1))[3]; |
398
|
|
$method =~ s/^backend::baseclass:://; |
399
|
11
|
confess sprintf "backend method '%s' not implemented for class '%s'", |
400
|
11
|
$method, ref $self; |
401
|
11
|
} |
402
|
5
|
|
403
|
|
# parameters: acpi, reset, (on), off |
404
|
|
|
405
|
9
|
return; # sorry, no |
|
9
|
|
|
9
|
|
406
|
9
|
} |
407
|
0
|
|
408
|
0
|
|
409
|
0
|
|
410
|
|
|
411
|
|
|
412
|
|
|
413
|
|
## MAY be overwritten: |
414
|
|
|
415
|
75
|
# vm's would return |
|
75
|
|
|
75
|
|
416
|
75
|
# (userstat, systemstat) |
417
|
75
|
|
418
|
75
|
my $frametime_ms = 1000 * $self->{video_frame_number} / 24; |
419
|
|
my $caption = "\n$self->{video_frame_number}\n"; |
420
|
|
# presentation time span (one frame) |
421
|
|
$caption .= sprintf(POSIX::strftime("%T.%%03d", gmtime($frametime_ms / 1000)), $frametime_ms % 1000); |
422
|
|
$frametime_ms += 1000 / 24; |
423
|
10
|
$caption .= " --> "; |
|
10
|
|
|
10
|
|
|
10
|
|
|
10
|
|
424
|
5
|
$caption .= sprintf(POSIX::strftime("%T.%%03d\n", gmtime($frametime_ms / 1000)), $frametime_ms % 1000); |
|
5
|
|
|
5
|
|
|
5
|
|
425
|
10
|
# clock value as caption text |
|
10
|
|
|
10
|
|
|
10
|
|
|
10
|
|
426
|
10
|
$caption .= sprintf(POSIX::strftime("[%FT%T.%%03d]\n", localtime($walltime)), 1000 * ($walltime - int($walltime))); |
|
10
|
|
|
10
|
|
|
10
|
|
427
|
10
|
|
|
10
|
|
|
10
|
|
|
10
|
|
428
|
5
|
return $caption; |
|
5
|
|
|
5
|
|
|
5
|
|
429
|
5
|
} |
|
5
|
|
|
5
|
|
|
5
|
|
430
|
|
|
431
|
5
|
my $watch = OpenQA::Benchmark::Stopwatch->new(); |
|
5
|
|
|
5
|
|
432
|
5
|
$watch->start(); |
433
|
|
|
434
|
|
$image = $image->scale($self->{xres}, $self->{yres}); |
435
|
5
|
$watch->lap("scaling"); |
|
5
|
|
|
5
|
|
|
5
|
|
|
5
|
|
436
|
|
|
437
|
5
|
my $lastscreenshot = $self->last_image; |
|
5
|
|
|
5
|
|
|
5
|
|
438
|
|
|
439
|
5
|
# link identical files to save space |
|
5
|
|
|
5
|
|
|
5
|
|
|
5
|
|
440
|
|
my $sim = 0; |
441
|
5
|
$sim = $lastscreenshot->similarity($image) if $lastscreenshot; |
|
5
|
|
|
5
|
|
|
5
|
|
|
5
|
|
442
|
|
$watch->lap("similarity"); |
443
|
5
|
|
|
5
|
|
|
5
|
|
|
5
|
|
|
5
|
|
444
|
|
$self->{min_image_similarity} -= 1; |
445
|
|
$self->{min_image_similarity} = $sim if $sim < $self->{min_image_similarity}; |
446
|
|
$self->{min_video_similarity} -= 1; |
447
|
|
$self->{min_video_similarity} = $sim if $sim < $self->{min_video_similarity}; |
448
|
|
|
449
|
5
|
# ensure gettimeofday returns float number, not a list of two entries |
|
5
|
|
|
5
|
|
|
5
|
|
450
|
|
# where we would discard the second element |
451
|
331
|
$self->{vtt_caption_file}->print($self->format_vtt_timestamp('' . gettimeofday)); |
|
331
|
|
|
331
|
|
|
331
|
|
452
|
331
|
|
453
|
331
|
# we have two different similarity levels - one (slightly higher value, based |
454
|
|
# t/data/user-settings-*) to determine if it's worth it to recheck needles |
455
|
331
|
# and one (slightly lower as less significant) determining if we write the frame |
456
|
331
|
# into the video |
457
|
331
|
if ($self->{min_image_similarity} <= 54) { |
458
|
331
|
$self->last_image($image); |
459
|
|
$self->{min_image_similarity} = 10000; |
460
|
331
|
} |
461
|
|
|
462
|
331
|
my $external_video_encoder_cmd_pipe = $self->{external_video_encoder_cmd_pipe}; |
463
|
|
if ($self->{min_video_similarity} > 50) { # we ignore smaller differences |
464
|
|
push(@{$self->{video_frame_data}}, "R\n"); |
465
|
321
|
push(@{$self->{external_video_encoder_image_data}}, $self->{last_image_data}) |
|
321
|
|
|
321
|
|
|
321
|
|
466
|
321
|
if defined $external_video_encoder_cmd_pipe && defined $self->{last_image_data}; |
467
|
321
|
} |
468
|
|
else { |
469
|
321
|
my $imgdata = $self->{last_image_data} = $image->ppm_data; |
470
|
321
|
$watch->lap("convert ppm data"); |
471
|
|
push(@{$self->{video_frame_data}}, 'E ' . length($imgdata) . "\n"); |
472
|
321
|
push(@{$self->{video_frame_data}}, $imgdata); |
473
|
|
$self->{min_video_similarity} = 10000; |
474
|
|
push(@{$self->{external_video_encoder_image_data}}, $imgdata) |
475
|
321
|
if defined $external_video_encoder_cmd_pipe; |
476
|
321
|
} |
477
|
321
|
my $encoder_pipe = $self->{encoder_pipe}; |
478
|
|
$self->{select_read}->add($encoder_pipe, 'baseclass::encoder_pipe'); |
479
|
321
|
$self->{select_write}->add($encoder_pipe, 'baseclass::encoder_pipe'); |
480
|
321
|
if (defined $external_video_encoder_cmd_pipe) { |
481
|
321
|
$self->{select_read}->add($external_video_encoder_cmd_pipe, 'baseclass::external_video_encoder_cmd_pipe'); |
482
|
321
|
$self->{select_write}->add($external_video_encoder_cmd_pipe, 'baseclass::external_video_encoder_cmd_pipe'); |
483
|
|
} |
484
|
|
$self->{video_frame_number} += 1; |
485
|
|
|
486
|
321
|
$watch->stop(); |
487
|
|
if ($watch->as_data()->{total_time} > $self->screenshot_interval && !$bmwqemu::vars{NO_DEBUG_IO}) { |
488
|
|
bmwqemu::fctwarn sprintf("enqueue_screenshot took %.2f seconds", $watch->as_data()->{total_time}); |
489
|
|
bmwqemu::diag "DEBUG_IO: \n" . $watch->summary(); |
490
|
|
} |
491
|
|
|
492
|
321
|
return; |
493
|
297
|
} |
494
|
297
|
|
495
|
|
if ($self->{cmdpipe}) { |
496
|
|
close($self->{cmdpipe}) || die "close $!\n"; |
497
|
321
|
$self->{cmdpipe} = undef; |
498
|
321
|
} |
499
|
46
|
|
|
46
|
|
500
|
0
|
return unless $self->{rsppipe}; |
501
|
46
|
|
502
|
|
# disarm SIGTERM handler to avoid re-entrant stop_vm call, stopping anyway |
503
|
|
$SIG{TERM} = 'IGNORE'; |
504
|
275
|
|
505
|
275
|
bmwqemu::diag "sending magic and exit"; |
506
|
275
|
myjsonrpc::send_json($self->{rsppipe}, {QUIT => 1}); |
|
275
|
|
507
|
275
|
close($self->{rsppipe}) || die "close $!\n"; |
|
275
|
|
508
|
275
|
Devel::Cover::report() if Devel::Cover->can('report'); |
509
|
275
|
_exit(0); |
|
0
|
|
510
|
|
} |
511
|
|
|
512
|
321
|
# this is called for all sockets ready to read from |
513
|
321
|
if ($self->{cmdpipe} && $fh == $self->{cmdpipe}) { |
514
|
321
|
return 1 if $write; |
515
|
321
|
my $cmd = myjsonrpc::read_json($self->{cmdpipe}); |
516
|
0
|
|
517
|
0
|
if ($cmd->{cmd}) { |
518
|
|
my $rsp = {rsp => ($self->handle_command($cmd) // 0)}; |
519
|
321
|
$rsp->{json_cmd_token} = $cmd->{json_cmd_token}; |
520
|
|
if ($self->{rsppipe}) { # the command might have closed it |
521
|
321
|
myjsonrpc::send_json($self->{rsppipe}, $rsp); |
522
|
321
|
} |
523
|
0
|
} |
524
|
0
|
else { |
525
|
|
use Data::Dumper; |
526
|
|
die "no command in " . Dumper($cmd); |
527
|
321
|
} |
528
|
|
return 1; |
529
|
|
} |
530
|
12
|
return 0; |
|
12
|
|
|
12
|
|
531
|
12
|
} |
532
|
6
|
|
533
|
6
|
################################################################### |
534
|
|
## access other consoles from the test case process |
535
|
|
|
536
|
12
|
# There can be two vnc backends (local Xvnc or remote vnc) and |
537
|
|
# there can be several terminals on the local Xvnc. |
538
|
|
# |
539
|
6
|
# switching means: turn to the right vnc and if it's the Xvnc, |
540
|
|
# iconify/deiconify the right x3270 terminal window. |
541
|
6
|
# |
542
|
6
|
# For now, we just raise the terminal window to the front on the local-Xvnc |
543
|
6
|
# DISPLAY. |
544
|
6
|
# |
545
|
0
|
# should we hide the other windows, somehow? |
546
|
|
#if exists $self->{current_console} ... |
547
|
|
# my $current_window_id = $self->{current_console}->{window_id}; |
548
|
|
# if (defined $current_window_id) { |
549
|
203
|
# system("DISPLAY=$display xdotool windowminimize --sync $current_window_id"); |
|
203
|
|
|
203
|
|
|
203
|
|
|
203
|
|
550
|
203
|
# } |
551
|
200
|
#-> select |
552
|
200
|
|
553
|
|
my $testapi_console = $args->{testapi_console}; |
554
|
200
|
|
555
|
200
|
my $selected_console = $self->console($testapi_console); |
556
|
191
|
my $activated = try { |
557
|
191
|
local $SIG{__DIE__} = 'DEFAULT'; |
558
|
191
|
$selected_console->select; |
559
|
|
} |
560
|
|
catch { |
561
|
|
{error => $_}; |
562
|
37
|
}; |
|
37
|
|
|
37
|
|
563
|
0
|
|
564
|
|
return $activated if ref($activated); |
565
|
190
|
$self->{current_console} = $selected_console; |
566
|
|
$self->{current_screen} = $selected_console->screen; |
567
|
3
|
$self->capture_screenshot(); |
568
|
|
return {activated => $activated}; |
569
|
|
} |
570
|
|
|
571
|
|
# we iterate through all consoles |
572
|
|
for my $console (keys %{$testapi::distri->{consoles}}) { |
573
|
|
next if $self->console($console)->{args}->{persistent}; |
574
|
|
$self->reset_console({testapi_console => $console}); |
575
|
|
} |
576
|
|
return; |
577
|
|
} |
578
|
|
|
579
|
|
$self->console($args->{testapi_console})->reset; |
580
|
|
return; |
581
|
|
} |
582
|
|
|
583
|
|
my $testapi_console = $args->{testapi_console}; |
584
|
|
my $console_info = $self->console($testapi_console); |
585
|
|
$self->{current_console} = undef if defined $self->{current_console} && $self->{current_console} == $console_info; |
586
|
|
$console_info->disable(); |
587
|
|
return; |
588
|
|
} |
589
|
|
|
590
|
7
|
for my $console (keys %{$testapi::distri->{consoles}}) { |
|
7
|
|
|
7
|
|
|
7
|
|
591
|
7
|
my $console_info = $self->console($console); |
592
|
|
$console_info->disable() if $console_info->can('disable'); |
593
|
7
|
} |
594
|
|
} |
595
|
7
|
|
596
|
7
|
for my $console (keys %{$testapi::distri->{consoles}}) { |
597
|
|
my $console_info = $self->console($console); |
598
|
|
$console_info->activate() if $console_info->{activated} && $console_info->can('disable'); |
599
|
1
|
} |
600
|
7
|
} |
601
|
|
|
602
|
7
|
=head3 save_console_snapshots |
603
|
4
|
|
604
|
4
|
Should be called when a snapshot of the SUT is taken to save the current state |
605
|
4
|
of any consoles which have state. For example: text consoles may have |
606
|
4
|
unprocessed output from the SUT in their buffers which is needed by test |
607
|
|
module after the snapshot. |
608
|
|
|
609
|
0
|
=cut |
|
0
|
|
|
0
|
|
|
0
|
|
610
|
|
for my $console (keys %{$testapi::distri->{consoles}}) { |
611
|
0
|
my $console_info = $self->console($console); |
|
0
|
|
612
|
0
|
$console_info->save_snapshot($name) if $console_info->can('save_snapshot'); |
613
|
0
|
} |
614
|
|
} |
615
|
0
|
|
616
|
|
=head3 load_console_snapshots |
617
|
|
|
618
|
0
|
Should be called when a snapshot of the SUT is loaded to ensure consoles are |
|
0
|
|
|
0
|
|
|
0
|
|
619
|
0
|
in the same state as when the snapshot was taken. |
620
|
0
|
|
621
|
|
=cut |
622
|
|
for my $console (keys %{$testapi::distri->{consoles}}) { |
623
|
5
|
my $console_info = $self->console($console); |
|
5
|
|
|
5
|
|
|
5
|
|
624
|
5
|
$console_info->load_snapshot($name) if $console_info->can('load_snapshot'); |
625
|
5
|
} |
626
|
5
|
} |
627
|
5
|
|
628
|
5
|
return $self->bouncer('request_screen_update', $args); |
629
|
|
} |
630
|
|
|
631
|
1
|
my $ret = $testapi::distri->{consoles}->{$testapi_console}; |
|
1
|
|
|
1
|
|
632
|
1
|
carp "console $testapi_console does not exist" unless $ret; |
|
1
|
|
633
|
1
|
return $ret; |
634
|
1
|
} |
635
|
|
|
636
|
|
# forward to the current VNC console |
637
|
|
return unless $self->{current_screen}; |
638
|
0
|
return $self->{current_screen}->$call($args); |
|
0
|
|
|
0
|
|
639
|
0
|
} |
|
0
|
|
640
|
0
|
|
641
|
0
|
return $self->bouncer('send_key', $args); |
642
|
|
} |
643
|
|
|
644
|
|
return $self->bouncer('hold_key', $args); |
645
|
|
} |
646
|
|
|
647
|
|
return $self->bouncer('release_key', $args); |
648
|
|
} |
649
|
|
|
650
|
|
return $self->bouncer('type_string', $args); |
651
|
|
} |
652
|
|
|
653
|
0
|
return $self->bouncer('mouse_set', $args); |
|
0
|
|
|
0
|
|
|
0
|
|
654
|
0
|
} |
|
0
|
|
655
|
0
|
|
656
|
0
|
return $self->bouncer('mouse_hide', $args); |
657
|
|
} |
658
|
|
|
659
|
|
return $self->bouncer('mouse_button', $args); |
660
|
|
} |
661
|
|
|
662
|
|
return $self->bouncer('get_last_mouse_set', $args); |
663
|
|
} |
664
|
|
|
665
|
|
return {yesorno => $self->{current_console}->is_serial_terminal}; |
666
|
0
|
} |
|
0
|
|
|
0
|
|
|
0
|
|
667
|
0
|
|
|
0
|
|
668
|
0
|
|
669
|
0
|
return unless $self->{current_screen}; |
670
|
|
|
671
|
|
my $screen = $self->{current_screen}->current_screen(); |
672
|
|
$self->enqueue_screenshot($screen) if $screen; |
673
|
663
|
return; |
|
663
|
|
|
663
|
|
|
663
|
|
674
|
663
|
} |
675
|
|
|
676
|
|
# called from testapi::set_var, so read the vars |
677
|
25
|
bmwqemu::load_vars(); |
|
25
|
|
|
25
|
|
|
25
|
|
678
|
25
|
|
679
|
25
|
$_->unregister() for needle::all(); |
680
|
25
|
needle::init(); |
681
|
|
} |
682
|
|
|
683
|
698
|
################################################################### |
|
698
|
|
|
698
|
|
|
698
|
|
|
698
|
|
684
|
|
# this is used by backend::console_proxy |
685
|
698
|
my ($console, $function, $args) = @$wrapped_call{qw(console function args)}; |
686
|
682
|
$console = $self->console($console); |
687
|
|
|
688
|
|
my $wrapped_result = {}; |
689
|
4
|
|
|
4
|
|
|
4
|
|
|
4
|
|
690
|
4
|
eval { |
691
|
|
# Do not die in here. |
692
|
|
# Move the decision to actually die to the server side instead. |
693
|
0
|
# For this ignore backend::baseclass::die_handler. |
|
0
|
|
|
0
|
|
|
0
|
|
694
|
0
|
local $SIG{__DIE__} = 'DEFAULT'; |
695
|
|
$wrapped_result->{result} = $wrapped_call->{wantarray} ? [$console->$function(@$args)] : $console->$function(@$args); |
696
|
|
}; |
697
|
0
|
$wrapped_result->{exception} = join("\n", bmwqemu::pp($wrapped_call), $@) if $@; |
|
0
|
|
|
0
|
|
|
0
|
|
698
|
0
|
return $wrapped_result; |
699
|
|
} |
700
|
|
|
701
|
30
|
=head2 clear_serial_buffer |
|
30
|
|
|
30
|
|
|
30
|
|
702
|
30
|
|
703
|
|
Determines the starting offset within the serial file - so that we do not check the |
704
|
|
previous test's serial output. Call this before you start doing something new |
705
|
0
|
|
|
0
|
|
|
0
|
|
|
0
|
|
706
|
0
|
=cut |
707
|
|
|
708
|
|
$self->{serial_offset} = -s $self->{serialfile}; |
709
|
1
|
return $self->{serial_offset}; |
|
1
|
|
|
1
|
|
|
1
|
|
710
|
1
|
} |
711
|
|
|
712
|
|
|
713
|
0
|
=head2 serial_text |
|
0
|
|
|
0
|
|
|
0
|
|
714
|
0
|
|
715
|
|
Returns the output on the serial device since the last call to clear_serial_buffer |
716
|
|
|
717
|
0
|
=cut |
|
0
|
|
|
0
|
|
|
0
|
|
718
|
0
|
|
719
|
|
return ($self->read_serial($self->{serial_offset}))[0]; |
720
|
|
} |
721
|
0
|
|
|
0
|
|
|
0
|
|
|
0
|
|
722
|
0
|
=head2 read_serial |
723
|
|
|
724
|
|
Returns the output and the offset after reading on the serial device from position |
725
|
2
|
|
|
2
|
|
|
2
|
|
|
2
|
|
|
2
|
|
726
|
|
=cut |
727
|
326
|
|
|
326
|
|
|
326
|
|
728
|
326
|
open(my $SERIAL, "<", $self->{serialfile}); |
729
|
|
seek($SERIAL, $position, $whence); |
730
|
323
|
local $/; |
731
|
323
|
my $data = <$SERIAL>; |
732
|
323
|
my $offset = tell $SERIAL; |
733
|
|
close($SERIAL); |
734
|
|
|
735
|
1
|
return ($data, $offset); |
|
1
|
|
736
|
|
} |
737
|
1
|
|
738
|
|
my $regexp = $args->{regexp}; |
739
|
1
|
my $timeout = $args->{timeout}; |
740
|
1
|
my $matched = 0; |
741
|
|
my $str; |
742
|
|
|
743
|
|
confess '\'current_console\' is not set' unless $self->{current_console}; |
744
|
|
if ($self->{current_console}->is_serial_terminal) { |
745
|
40
|
return $self->{current_screen}->read_until($regexp, $timeout, %$args); |
|
40
|
|
|
40
|
|
|
40
|
|
746
|
40
|
} |
747
|
40
|
|
748
|
|
$regexp = [$regexp] if ref $regexp ne 'ARRAY'; |
749
|
40
|
my $initial_time = time; |
750
|
|
my $current_offset = $self->{serial_offset}; |
751
|
40
|
while (time < $initial_time + $timeout) { |
752
|
|
$str = $self->serial_text(); |
753
|
|
for my $r (@$regexp) { |
754
|
|
if (!$args->{no_regex} && $str =~ m/$r/) { |
755
|
40
|
$current_offset += $LAST_MATCH_END[0]; |
756
|
40
|
$str = substr($str, 0, $LAST_MATCH_END[0]); |
757
|
|
$matched = 1; |
758
|
40
|
last; |
759
|
40
|
} elsif ($args->{no_regex} && (my $i = index($str, $r)) >= 0) { |
760
|
|
$current_offset += length($r) + $i; |
761
|
|
$str = substr($str, 0, $i + length($r)); |
762
|
|
$matched = 1; |
763
|
|
last; |
764
|
|
} |
765
|
|
} |
766
|
|
last if ($matched); |
767
|
|
$self->run_capture_loop(1); |
768
|
|
} |
769
|
27
|
$self->{serial_offset} = $current_offset; |
|
27
|
|
|
27
|
|
770
|
27
|
return {matched => $matched, string => $str}; |
771
|
27
|
} |
772
|
|
|
773
|
|
# set_reference_screenshot and similiarity_to_reference are necessary to |
774
|
|
# implement wait_still and wait_changed functions in the tests without having |
775
|
|
# to transfer the screenshot into the test process |
776
|
|
$self->reference_screenshot($self->last_image); |
777
|
|
return; |
778
|
|
} |
779
|
|
|
780
|
|
return {sim => 10000} if (!$self->reference_screenshot || !$self->last_image); |
781
|
15
|
return {sim => $self->reference_screenshot->similarity($self->last_image)}; |
|
15
|
|
|
15
|
|
782
|
15
|
} |
783
|
|
|
784
|
|
my $mustmatch = $args->{mustmatch}; |
785
|
|
my $timeout = $args->{timeout} // $bmwqemu::default_timeout; |
786
|
|
|
787
|
|
# keep only the most recently used images (https://progress.opensuse.org/issues/15438) |
788
|
|
needle::clean_image_cache(); |
789
|
|
|
790
|
|
# get the array reference to all matching needles |
791
|
33
|
my $needles = []; |
|
33
|
|
|
33
|
|
|
33
|
|
|
33
|
|
792
|
33
|
my @tags; |
793
|
32
|
if (ref($mustmatch) eq "ARRAY") { |
794
|
32
|
my @a = @$mustmatch; |
795
|
32
|
while (my $n = shift @a) { |
796
|
32
|
if (ref($n) eq '') { |
797
|
32
|
push @tags, split(/ /, $n); |
798
|
|
$n = needle::tags($n); |
799
|
32
|
push @a, @$n if $n; |
800
|
|
next; |
801
|
|
} |
802
|
13
|
unless (ref($n) eq 'needle' && $n->{name}) { |
|
13
|
|
|
13
|
|
|
13
|
|
803
|
13
|
warn "invalid needle passed <" . ref($n) . "> " . bmwqemu::pp($n); |
804
|
13
|
next; |
805
|
13
|
} |
806
|
13
|
push @$needles, $n; |
807
|
|
} |
808
|
13
|
$needles = [uniq @$needles]; |
809
|
13
|
} |
810
|
0
|
elsif ($mustmatch) { |
811
|
|
$needles = needle::tags($mustmatch) || []; |
812
|
|
@tags = ($mustmatch); |
813
|
13
|
} |
814
|
13
|
|
815
|
13
|
{ # remove duplicates |
816
|
13
|
my %h = map { $_ => 1 } @tags; |
817
|
15
|
@tags = sort keys %h; |
818
|
15
|
} |
819
|
15
|
$mustmatch = join(',', @tags); |
820
|
9
|
bmwqemu::fctinfo "NO matching needles for $mustmatch" unless @$needles; |
821
|
9
|
|
822
|
9
|
$self->set_assert_screen_timeout($timeout); |
823
|
9
|
$self->assert_screen_fails([]); |
824
|
|
$self->assert_screen_needles($needles); |
825
|
2
|
$self->assert_screen_last_check(undef); |
826
|
2
|
$self->stall_detected(0); |
827
|
2
|
# store them for needle reload event |
828
|
2
|
$self->assert_screen_tags(\@tags); |
829
|
|
$self->assert_screen_check($args->{check}); |
830
|
|
return {tags => \@tags}; |
831
|
15
|
} |
832
|
4
|
|
833
|
|
return bmwqemu::fctwarn('set_assert_screen_timeout called with non-numeric timeout') unless looks_like_number($timeout); |
834
|
13
|
$self->assert_screen_deadline(time + $timeout); |
835
|
13
|
return $self->assert_screen_deadline; |
836
|
|
} |
837
|
|
|
838
|
|
return $self->assert_screen_deadline - time; |
839
|
|
} |
840
|
|
|
841
|
9
|
my $failed_screens = $self->assert_screen_fails; |
|
9
|
|
|
9
|
|
|
9
|
|
842
|
9
|
my $final_mismatch = $failed_screens->[-1]; |
843
|
9
|
if ($final_mismatch) { |
844
|
|
_reduce_to_biggest_changes($failed_screens, 20); |
845
|
|
# only append the last mismatch if it's different to the last one in the reduced list |
846
|
15
|
my $new_final = $failed_screens->[-1]; |
|
15
|
|
|
15
|
|
|
15
|
|
847
|
15
|
if ($new_final != $final_mismatch) { |
848
|
15
|
my $sim = $new_final->[0]->similarity($final_mismatch->[0]); |
849
|
|
push(@$failed_screens, $final_mismatch) if ($sim < 50); |
850
|
|
} |
851
|
9
|
} |
|
9
|
|
|
9
|
|
|
9
|
|
852
|
9
|
|
853
|
9
|
my @json_fails; |
854
|
|
for my $l (@$failed_screens) { |
855
|
|
my ($img, $failed_candidates, $testtime, $similarity, $frame) = @$l; |
856
|
9
|
my $h = { |
857
|
|
candidates => $failed_candidates, |
858
|
|
image => encode_base64($img->ppm_data), |
859
|
9
|
frame => $frame, |
860
|
9
|
}; |
861
|
9
|
push(@json_fails, $h); |
862
|
1
|
} |
863
|
1
|
|
864
|
2
|
# free memory |
865
|
2
|
$self->assert_screen_fails([]); |
866
|
2
|
return {timeout => 1, failed_screens => \@json_fails}; |
867
|
2
|
} |
868
|
2
|
|
869
|
|
# compensate rounding to be consistent with truncation in $search_ratio calculation |
870
|
0
|
return sprintf("%.1fs", $time - 0.05); |
871
|
0
|
} |
872
|
0
|
|
873
|
|
$self->{_final_full_update_requested} = 0; |
874
|
0
|
$self->assert_screen_last_check(undef); |
875
|
|
} |
876
|
1
|
|
877
|
|
return unless my $img = $self->last_image; # no screenshot yet to search on |
878
|
|
my $watch = OpenQA::Benchmark::Stopwatch->new(); |
879
|
8
|
my $timestamp = $self->last_screenshot; |
880
|
8
|
my $n = $self->_time_to_assert_screen_deadline; |
881
|
|
my $frame = $self->{video_frame_number}; |
882
|
|
|
883
|
|
# do a full-screen search every FULL_SCREEN_SEARCH_FREQUENCY'th time and at the end |
884
|
9
|
my $search_ratio = $n < 0 || $n % FULL_SCREEN_SEARCH_FREQUENCY == 0 ? 1 : 0.02; |
|
9
|
|
|
10
|
|
885
|
9
|
my ($oldimg, $old_search_ratio) = @{$self->assert_screen_last_check || [undef, 0]}; |
886
|
|
|
887
|
9
|
bmwqemu::diag('no change: ' . time_remaining_str($n)) and return if $n >= 0 && $oldimg && $oldimg eq $img && $old_search_ratio >= $search_ratio; |
888
|
9
|
|
889
|
|
$watch->start(); |
890
|
9
|
$watch->{debug} = 0; |
891
|
9
|
|
892
|
9
|
my @registered_needles = grep { !$_->{unregistered} } @{$self->assert_screen_needles}; |
893
|
9
|
my ($foundneedle, $failed_candidates) = $img->search(\@registered_needles, 0, $search_ratio, ($watch->{debug} ? $watch : undef)); |
894
|
9
|
$watch->lap("Needle search") unless $watch->{debug}; |
895
|
|
if ($foundneedle) { |
896
|
9
|
$self->_reset_asserted_screen_check_variables; |
897
|
9
|
return { |
898
|
9
|
image => encode_base64($img->ppm_data), |
899
|
|
found => $foundneedle, |
900
|
|
candidates => $failed_candidates, |
901
|
9
|
frame => $frame, |
|
9
|
|
|
9
|
|
|
9
|
|
902
|
9
|
}; |
903
|
9
|
} |
904
|
9
|
|
905
|
|
$watch->stop(); |
906
|
|
if ($watch->as_data()->{total_time} > $self->screenshot_interval) { |
907
|
44
|
bmwqemu::fctwarn sprintf( |
|
44
|
|
|
44
|
|
908
|
44
|
"check_asserted_screen took %.2f seconds for %d candidate needles - make your needles more specific", |
909
|
|
$watch->as_data()->{total_time}, |
910
|
|
scalar(@registered_needles)); |
911
|
3
|
bmwqemu::diag "DEBUG_IO: \n" . $watch->summary() if (!$bmwqemu::vars{NO_DEBUG_IO} && $watch->{debug}); |
|
3
|
|
|
3
|
|
912
|
3
|
} |
913
|
3
|
|
914
|
3
|
my $no_match_diag = 'no match: ' . time_remaining_str($n); |
915
|
3
|
if (my $best_candidate = $failed_candidates->[0]) { |
916
|
|
$no_match_diag .= sprintf( |
917
|
3
|
", best candidate: %s (%.2f)", |
918
|
3
|
$best_candidate->{needle}->{name}, |
919
|
0
|
1 - sqrt($best_candidate->{error}) |
920
|
0
|
); |
921
|
|
} |
922
|
|
bmwqemu::diag($no_match_diag); |
923
|
|
|
924
|
3
|
if ($n < 0) { |
925
|
3
|
$self->_reset_asserted_screen_check_variables; |
926
|
5
|
|
927
|
5
|
if (!$self->assert_screen_check) { |
928
|
|
my @unregistered_needles = grep { $_->{unregistered} } @{$self->assert_screen_needles}; |
929
|
|
my ($foundneedle, $candidates) = $img->search(\@unregistered_needles, 0, 1, undef); |
930
|
|
# the best here is still a failure, as unregistered |
931
|
|
push(@$failed_candidates, $foundneedle) if $foundneedle; |
932
|
5
|
push(@$failed_candidates, @$candidates); |
933
|
|
} |
934
|
|
my $failed_screens = $self->assert_screen_fails; |
935
|
|
# store the final mismatch |
936
|
3
|
push(@$failed_screens, [$img, $failed_candidates, 0, 1000, $frame]); |
937
|
3
|
my $hash = $self->_failed_screens_to_json; |
938
|
|
$hash->{image} = encode_base64($img->ppm_data); |
939
|
|
# store stall status |
940
|
60
|
$hash->{stall} = $self->stall_detected; |
|
60
|
|
|
60
|
|
941
|
|
|
942
|
60
|
return $hash; |
943
|
|
} |
944
|
|
elsif ($n <= $self->screenshot_interval * 2 && !$self->{_final_full_update_requested}) { |
945
|
9
|
# try to request a full screen update to workaround possibly destorted VNC screen |
|
9
|
|
|
9
|
|
946
|
9
|
# as we're nearing the deadline |
947
|
9
|
$self->request_screen_update({incremental => 0}); |
948
|
|
$self->{_final_full_update_requested} = 1; |
949
|
|
} |
950
|
47
|
elsif ($n % FULL_UPDATE_REQUEST_FREQUENCY == 0) { |
|
47
|
|
|
47
|
|
|
47
|
|
951
|
47
|
$self->request_screen_update({incremental => 0}); |
952
|
47
|
} |
953
|
47
|
|
954
|
47
|
if ($search_ratio == 1) { |
955
|
47
|
# save only failures where the whole screen has been searched |
956
|
|
# results of partial searching are rather confusing |
957
|
|
|
958
|
47
|
# as the images create memory pressure, we only save quite different images |
959
|
47
|
# the last screen is handled automatically and the first screen is only interesting |
|
47
|
|
960
|
|
# if there are no others |
961
|
47
|
my $sim = 29; |
962
|
|
my $failed_screens = $self->assert_screen_fails; |
963
|
47
|
if ($failed_screens->[-1] && $n > 0) { |
964
|
47
|
$sim = $failed_screens->[-1]->[0]->similarity($img); |
965
|
|
} |
966
|
47
|
if ($sim < 30) { |
|
24
|
|
|
47
|
|
967
|
47
|
push(@$failed_screens, [$img, $failed_candidates, $n, $sim, $frame]); |
968
|
47
|
} |
969
|
47
|
# clean up every once in a while to avoid excessive memory consumption. |
970
|
6
|
# The value here is an arbitrary limit. |
971
|
|
if (@$failed_screens > 60) { |
972
|
6
|
_reduce_to_biggest_changes($failed_screens, 20); |
973
|
|
} |
974
|
|
} |
975
|
|
$self->assert_screen_last_check([$img, $search_ratio]); |
976
|
|
return; |
977
|
|
} |
978
|
|
|
979
|
41
|
return if @$imglist <= $limit; |
980
|
41
|
|
981
|
|
my $first = shift @$imglist; |
982
|
|
@$imglist = (sort { $b->[3] <=> $a->[3] } @$imglist)[0 .. (@$imglist > $limit ? $limit - 1 : $#$imglist)]; |
983
|
|
unshift @$imglist, $first; |
984
|
0
|
|
985
|
0
|
# now sort for test time |
986
|
|
@$imglist = sort { $b->[2] <=> $a->[2] } @$imglist; |
987
|
|
|
988
|
41
|
# recalculate similarity |
989
|
41
|
for (my $i = 1; $i < @$imglist; ++$i) { |
990
|
|
$imglist->[$i]->[3] = $imglist->[$i - 1]->[0]->similarity($imglist->[$i]->[0]); |
991
|
|
} |
992
|
|
|
993
|
|
return; |
994
|
15
|
} |
995
|
|
|
996
|
41
|
bmwqemu::diag "ignored freeze_vm"; |
997
|
|
return; |
998
|
41
|
} |
999
|
3
|
|
1000
|
|
bmwqemu::diag "ignored cont_vm"; |
1001
|
3
|
return; |
1002
|
2
|
} |
|
0
|
|
|
2
|
|
1003
|
2
|
|
1004
|
|
return {} unless $self->last_image; |
1005
|
2
|
return { |
1006
|
2
|
image => encode_base64($self->last_image->ppm_data), |
1007
|
|
frame => $self->{video_frame_number}, |
1008
|
3
|
}; |
1009
|
|
} |
1010
|
3
|
|
1011
|
3
|
my $imgpath = $args->{imgpath}; |
1012
|
3
|
my $mustmatch = $args->{mustmatch}; |
1013
|
|
|
1014
|
3
|
my $img = tinycv::read($imgpath); |
1015
|
|
my $needles = needle::tags($mustmatch) || []; |
1016
|
3
|
|
1017
|
|
my ($foundneedle, $failed_candidates) = $img->search($needles, 0, 1); |
1018
|
|
return {found => $foundneedle, candidates => $failed_candidates} if $foundneedle; |
1019
|
|
return {candidates => $failed_candidates}; |
1020
|
|
} |
1021
|
3
|
|
1022
|
3
|
$self->reload_needles if $args->{reload_needles}; |
1023
|
|
# reset timeout otherwise continue wait_forneedle might just fail if stopped too long than timeout |
1024
|
|
$self->set_assert_screen_timeout($args->{timeout}) if $args->{timeout}; |
1025
|
21
|
$self->cont_vm; |
1026
|
|
# do not need to retry in 5 seconds but contining SUT if continue_waitforneedle |
1027
|
|
if ($args->{reload_needles}) { |
1028
|
38
|
# short timeout, we're already there |
1029
|
|
$self->set_tags_to_assert({mustmatch => $self->assert_screen_tags, timeout => 5, reloadneedles => 1}); |
1030
|
|
} |
1031
|
|
return; |
1032
|
|
} |
1033
|
|
|
1034
|
|
# shared between svirt and s390 backend |
1035
|
24
|
bmwqemu::log_call(%{$self->hide_password(%args)}); |
1036
|
24
|
my %credentials = $self->get_ssh_credentials; |
1037
|
24
|
$args{$_} //= $credentials{$_} foreach (keys(%credentials)); |
1038
|
19
|
$args{username} ||= 'root'; |
1039
|
|
$args{port} ||= 22; |
1040
|
24
|
$args{keep_open} //= 0; |
1041
|
6
|
my $connection_key; |
1042
|
|
|
1043
|
|
# e.g. using hyperv_intermediate host which is running Windows need to keep the connection. |
1044
|
|
# Otherwise a mount point doesn't exists within the next command. |
1045
|
24
|
if ($args{keep_open}) { |
1046
|
0
|
$connection_key = join(',', map { $_ . "=" . $args{$_} } qw(hostname username port)); |
1047
|
|
my $con = $self->{ssh_connections}->{$connection_key}; |
1048
|
|
if (defined($con)) { |
1049
|
38
|
# Check if we still can create channels on that connection |
1050
|
38
|
if (my $tmp_chan = $con->channel()) { |
1051
|
|
$tmp_chan->close(); |
1052
|
|
bmwqemu::diag "Use existing SSH connection (key:$connection_key)"; |
1053
|
3
|
return $con; |
|
3
|
|
|
3
|
|
|
3
|
|
1054
|
3
|
} else { |
1055
|
|
bmwqemu::diag "Close broken SSH connection (key:$connection_key)"; |
1056
|
0
|
$con->disconnect(); |
1057
|
0
|
delete $self->{ssh_connections}->{$connection_key}; |
|
0
|
|
1058
|
0
|
} |
1059
|
|
} |
1060
|
|
} |
1061
|
0
|
|
|
0
|
|
1062
|
|
# timeout requires libssh2 >= 1.2.9 so not all versions might have it |
1063
|
|
my $ssh = Net::SSH2->new(timeout => ($bmwqemu::vars{SSH_COMMAND_TIMEOUT_S} // 5 * ONE_MINUTE) * 1000); |
1064
|
0
|
|
1065
|
0
|
# Retry multiple times, in case of the guest is not running yet |
1066
|
|
my $counter = $bmwqemu::vars{SSH_CONNECT_RETRY} // 5; |
1067
|
|
my $con_pretty = "$args{username}\@$args{hostname}"; |
1068
|
0
|
$con_pretty .= ":$args{port}" unless $args{port} == 22; |
1069
|
|
while ($counter > 0) { |
1070
|
|
if ($ssh->connect($args{hostname}, $args{port})) { |
1071
|
0
|
|
|
0
|
|
|
0
|
|
1072
|
0
|
if ($args{password}) { |
1073
|
0
|
$ssh->auth(username => $args{username}, password => $args{password}); |
1074
|
|
} |
1075
|
|
else { |
1076
|
0
|
# this relies on agent to be set up correctly |
|
0
|
|
|
0
|
|
1077
|
0
|
$ssh->auth_agent($args{username}); |
1078
|
0
|
} |
1079
|
|
bmwqemu::diag "SSH connection to $con_pretty established" if $ssh->auth_ok; |
1080
|
|
last; |
1081
|
13
|
} |
|
13
|
|
|
13
|
|
|
13
|
|
1082
|
13
|
else { |
1083
|
|
bmwqemu::diag "Could not connect to $con_pretty, Retrying after some seconds..."; |
1084
|
|
sleep($bmwqemu::vars{SSH_CONNECT_RETRY_INTERVAL} // 10); |
1085
|
|
$counter--; |
1086
|
12
|
next; |
1087
|
|
} |
1088
|
|
} |
1089
|
0
|
OpenQA::Exception::SSHConnectionError->throw(error => "Error connecting to <$con_pretty>: $@") unless $ssh->auth_ok; |
|
0
|
|
|
0
|
|
|
0
|
|
1090
|
0
|
|
1091
|
0
|
$self->{ssh_connections}->{$connection_key} = $ssh if ($args{keep_open}); |
1092
|
|
return $ssh; |
1093
|
0
|
} |
1094
|
0
|
|
1095
|
|
=head2 get_ssh_credentials |
1096
|
0
|
Should return a hash with the keys: C<hostname, username, password, port> |
1097
|
0
|
The keys port and username are optional and default to 22 and 'root', respectively. |
1098
|
0
|
=cut |
1099
|
|
|
1100
|
|
# open another ssh connection to grab the serial console |
1101
|
0
|
bmwqemu::log_call(%{$self->hide_password(%args)}); |
|
0
|
|
|
0
|
|
|
0
|
|
1102
|
0
|
$self->stop_ssh_serial; |
1103
|
|
|
1104
|
0
|
my $ssh = $self->{serial} = $self->new_ssh_connection(%args); |
1105
|
0
|
my $chan = $self->{serial_chan} = $ssh->channel(); |
1106
|
|
$ssh->die_with_error("Unable to establish SSH channel for serial console") unless $chan; |
1107
|
0
|
$chan->blocking(0); |
1108
|
|
$chan->pty(1); |
1109
|
0
|
$chan->ext_data('merge'); |
1110
|
|
$self->{select_read}->add($ssh->sock); |
1111
|
0
|
return ($ssh, $chan); |
1112
|
|
} |
1113
|
|
|
1114
|
|
my $ssh = $self->{serial}; |
1115
|
75
|
return 0 unless $ssh; |
|
75
|
|
|
75
|
|
|
75
|
|
1116
|
75
|
my $ssh_socket = $ssh->sock; |
|
75
|
|
1117
|
75
|
return 0 unless $ssh_socket == $fh; |
1118
|
75
|
|
1119
|
75
|
if ($write) { |
1120
|
75
|
bmwqemu::fctwarn 'SSH serial: setup error: socket has been wrongly selected for writing'; |
1121
|
75
|
return 1; |
1122
|
75
|
} |
1123
|
|
|
1124
|
|
# read from SSH channel (receiving extended data channel as well via `$chan->ext_data('merge')`) |
1125
|
|
my $chan = $self->{serial_chan}; |
1126
|
75
|
my $buffer; |
1127
|
50
|
while (defined(my $bytes_read = $chan->read($buffer, 4096))) { |
|
150
|
|
1128
|
50
|
return 1 unless $bytes_read > 0; |
1129
|
50
|
print $buffer; |
1130
|
|
open(my $serial, '>>', $self->{serialfile}); |
1131
|
35
|
print $serial $buffer; |
1132
|
30
|
close($serial); |
1133
|
30
|
} |
1134
|
30
|
|
1135
|
|
my ($error_code, $error_name, $error_string) = $ssh->error; |
1136
|
5
|
return 1 if $error_code == LIBSSH2_ERROR_EAGAIN; |
1137
|
5
|
|
1138
|
5
|
bmwqemu::fctwarn "ssh serial: unable to read: $error_string (error code: $error_code) - closing connection"; |
1139
|
|
$self->stop_ssh_serial(); |
1140
|
|
return 1; |
1141
|
|
} |
1142
|
|
|
1143
|
|
=head2 run_ssh_cmd |
1144
|
45
|
|
1145
|
|
$ret = run_ssh_cmd($cmd [, username => ?][, password => ?][,host => ?]); |
1146
|
|
($ret, $stdout, $stderr) = run_ssh_cmd($cmd [, username => ?][, password => ?][,host => ?], wantarray => 1); |
1147
|
45
|
|
1148
|
45
|
=cut |
1149
|
45
|
my ($stdout, $stderr) = ('', ''); |
1150
|
45
|
$args{wantarray} //= 0; |
1151
|
45
|
$args{keep_open} //= 1; |
1152
|
|
|
1153
|
45
|
bmwqemu::log_call(cmd => $cmd, %{$self->hide_password(%args)}); |
1154
|
45
|
my ($ssh, $chan) = $self->run_ssh($cmd, %args); |
1155
|
|
$chan->send_eof; |
1156
|
|
|
1157
|
|
while (!$chan->eof) { |
1158
|
0
|
if (my ($o, $e) = $chan->read2) { |
1159
|
|
$stdout .= $o; |
1160
|
45
|
$stderr .= $e; |
1161
|
45
|
} |
1162
|
|
} |
1163
|
|
|
1164
|
0
|
bmwqemu::diag("[run_ssh_cmd($cmd)] stdout:$/$stdout") if length($stdout); |
1165
|
0
|
bmwqemu::diag("[run_ssh_cmd($cmd)] stderr:$/$stderr") if length($stderr); |
1166
|
0
|
my $ret = $chan->exit_status(); |
1167
|
0
|
bmwqemu::diag("[run_ssh_cmd($cmd)] exit-code: $ret"); |
1168
|
|
$ssh->disconnect() unless ($args{keep_open}); |
1169
|
|
|
1170
|
45
|
return $args{wantarray} ? ($ret, $stdout, $stderr) : $ret; |
1171
|
|
} |
1172
|
40
|
|
1173
|
40
|
bmwqemu::log_call(cmd => $cmd, %{$self->hide_password(%args)}); |
1174
|
|
$args{blocking} //= 1; |
1175
|
|
my $ssh = $self->new_ssh_connection(%args); |
1176
|
|
my $chan = $ssh->channel() || $ssh->die_with_error("Unable to create SSH channel for executing \"$cmd\""); |
1177
|
|
$chan->exec($cmd) || $ssh->die_with_error("Unable to execute \"$cmd\""); |
1178
|
|
$ssh->blocking($args{blocking}); |
1179
|
|
return ($ssh, $chan); |
1180
|
75
|
} |
|
75
|
|
1181
|
|
|
1182
|
|
my $cons = $self->{ssh_connections} // {}; |
1183
|
5
|
for my $key (keys(%{$cons})) { |
|
5
|
|
|
5
|
|
|
5
|
|
1184
|
5
|
bmwqemu::diag("SSH disconnect $key"); |
|
5
|
|
1185
|
5
|
$cons->{$key}->disconnect(); |
1186
|
|
delete($cons->{$key}); |
1187
|
5
|
} |
1188
|
5
|
} |
1189
|
5
|
|
1190
|
5
|
my $ssh = $self->{serial}; |
1191
|
5
|
return undef unless $ssh; |
1192
|
5
|
bmwqemu::diag('Closing SSH serial connection with ' . $ssh->hostname); |
1193
|
5
|
$self->{select_read}->remove($ssh->sock); |
1194
|
5
|
$ssh->disconnect; |
1195
|
|
$self->{serial_chan} = undef; |
1196
|
|
return $self->{serial} = undef; |
1197
|
28
|
} |
|
28
|
|
|
28
|
|
|
28
|
|
|
28
|
|
1198
|
28
|
|
1199
|
28
|
$args{password} = 'SECRET' if ($args{password}); |
1200
|
20
|
return \%args; |
1201
|
20
|
} |
1202
|
|
|
1203
|
15
|
my $deprecation_message = <<"EOF"; |
1204
|
0
|
DEPRECATED: 'backend::$backend' is unsupported and planned to be |
1205
|
0
|
removed from os-autoinst eventually. If the backend is still needed please |
1206
|
|
report an issue on https://github.com/os-autoinst/os-autoinst . This message |
1207
|
|
can be temporarily turned into a warning by setting the environment variable |
1208
|
|
'OS_AUTOINST_NO_DEPRECATE_BACKEND_$backend' or the os-autoinst variable |
1209
|
15
|
'NO_DEPRECATE_BACKEND_$backend' |
1210
|
15
|
EOF |
1211
|
15
|
die $deprecation_message unless $bmwqemu::vars{"NO_DEPRECATE_BACKEND_$backend"} || $ENV{"OS_AUTOINST_NO_DEPRECATE_BACKEND_$backend"}; |
1212
|
25
|
log::fctwarn $deprecation_message; |
1213
|
20
|
} |
1214
|
20
|
|
1215
|
20
|
# Send TERM signal to any child process |
1216
|
20
|
my $ret; |
1217
|
|
for my $pid (@{$self->{children}}) { |
1218
|
|
bmwqemu::diag("terminating child $pid"); |
1219
|
10
|
kill('TERM', $pid); |
1220
|
10
|
for my $i (1 .. 5) { |
1221
|
|
$ret = waitpid($pid, WNOHANG); |
1222
|
5
|
bmwqemu::diag "waitpid for $pid returned $ret"; |
1223
|
5
|
last if ($ret == $pid); |
1224
|
5
|
sleep 1; |
1225
|
|
} |
1226
|
|
} |
1227
|
|
} |
1228
|
|
|
1229
|
|
die "Can't spawn child without code" unless ref($code) eq "CODE"; |
1230
|
|
|
1231
|
|
my $pid = fork(); |
1232
|
|
die "fork failed" unless defined($pid); |
1233
|
25
|
|
|
25
|
|
|
25
|
|
|
25
|
|
|
25
|
|
1234
|
25
|
if ($pid == 0) { |
1235
|
25
|
$code->(); |
1236
|
25
|
} |
1237
|
|
else { |
1238
|
25
|
push @{$self->{children}}, $pid; |
|
25
|
|
1239
|
25
|
return $pid; |
1240
|
25
|
} |
1241
|
|
|
1242
|
25
|
} |
1243
|
25
|
|
1244
|
25
|
1; |