33.33KiB, text/plain; utf-8; Perl | Statements 711
1
# Copyright © 2009-2013 Bernhard M. Wiedemann
2
# Copyright © 2012-2016 SUSE LLC
3
#
4
# This program is free software; you can redistribute it and/or modify
5
# it under the terms of the GNU General Public License as published by
6
# the Free Software Foundation; either version 2 of the License, or
7
# (at your option) any later version.
8
#
9
# This program is distributed in the hope that it will be useful,
10
# but WITHOUT ANY WARRANTY; without even the implied warranty of
11
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12
# GNU General Public License for more details.
13
#
14
# You should have received a copy of the GNU General Public License along
15
# with this program; if not, see <http://www.gnu.org/licenses/>.
16
17
# this is an abstract class
18 1
package backend::baseclass;
19
use strict;
20
use warnings;
21
use Carp qw(cluck carp confess);
22
use JSON 'to_json';
23
use File::Copy 'cp';
24
use File::Basename;
25
use Time::HiRes qw(gettimeofday time tv_interval);
26
use POSIX qw(_exit :sys_wait_h);
27
use bmwqemu;
28
use IO::Select;
29
require IPC::System::Simple;
30
use autodie ':all';
31
use myjsonrpc;
32
use Net::SSH2;
33
use feature 'say';
34
use OpenQA::Benchmark::Stopwatch;
35
use MIME::Base64 'encode_base64';
36
use List::Util 'min';
37
use List::MoreUtils 'uniq';
38
39
# should be a singleton - and only useful in backend process
40
our $backend;
41
42
use parent 'Class::Accessor::Fast';
43
__PACKAGE__->mk_accessors(
44
    qw(
45
      update_request_interval last_update_request screenshot_interval
46
      last_screenshot last_image assert_screen_check
47
      reference_screenshot assert_screen_tags assert_screen_needles
48
      assert_screen_deadline assert_screen_fails assert_screen_last_check
49
      stall_detected
50
      ));
51
52
sub new {
53
    my $class = shift;
54
    my $self = bless({class => $class}, $class);
55
    $self->{started}              = 0;
56
    $self->{serialfile}           = "serial0";
57
    $self->{serial_offset}        = 0;
58
    $self->{video_frame_data}     = [];
59
    $self->{video_frame_number}   = 0;
60 1
    $self->{min_image_similarity} = 10000;
61 1
    $self->{min_video_similarity} = 10000;
62
    $self->{children}             = [];
63
64
    return $self;
65
}
66
67
# runs in the backend process to deserialize VNC commands
68
sub handle_command {
69
    my ($self, $cmd) = @_;
70
71
    my $func = $cmd->{cmd};
72
    unless ($self->can($func)) {
73
        die "not supported command: $func";
74
    }
75
    return $self->$func($cmd->{arguments});
76
}
77
78
sub die_handler {
79
    my $msg = shift;
80
    cluck "DIE $msg\n";
81
    $backend->stop_vm();
82
    $backend->close_pipes();
83
}
84
85
sub backend_signalhandler {
86
    my ($sig) = @_;
87
    bmwqemu::diag("backend got $sig");
88
    $backend->stop_vm;
89
}
90
91
sub run {
92
    my ($self, $cmdpipe, $rsppipe) = @_;
93
94
    die "there can be only one!" if $backend;
95
    $backend = $self;
96
97
    $SIG{__DIE__} = \&die_handler;
98
    $SIG{TERM}    = \&backend_signalhandler;
99
100
    my $io = IO::Handle->new();
101
    $io->fdopen($cmdpipe, "r") || die "r fdopen $!";
102
    $self->{cmdpipe} = $io;
103
104
    $io = IO::Handle->new();
105
    $io->fdopen($rsppipe, "w") || die "w fdopen $!";
106
    $rsppipe = $io;
107
    $io->autoflush(1);
108
    $self->{rsppipe} = $io;
109
110
    printf STDERR "$$: cmdpipe %d, rsppipe %d\n", fileno($self->{cmdpipe}), fileno($self->{rsppipe});
111
112
    bmwqemu::diag "started mgmt loop with pid $$";
113
114
    $self->{select} = IO::Select->new();
115
    $self->{select}->add($self->{cmdpipe});
116
117
    $self->last_update_request("-Inf" + 0);
118
    $self->last_screenshot(undef);
119
    $self->screenshot_interval($bmwqemu::vars{SCREENSHOTINTERVAL} || .5);
120
    # query the VNC backend more often than we write out screenshots, so the chances
121
    # are high we're not writing out outdated screens
122
    $self->update_request_interval($self->screenshot_interval / 2);
123
124
    for my $console (values %{$testapi::distri->{consoles}}) {
125
        # tell the consoles who they need to talk to (in this thread)
126
        $console->backend($self);
127
    }
128
129
    $self->run_capture_loop;
130
131
    bmwqemu::diag("management process exit at " . POSIX::strftime("%F %T", gmtime));
132
}
133
134
=head2 run_capture_loop($timeout)
135
136
=out
137
138
=item timeout
139
140
run the loop this long in seconds, indefinitely if undef, or until the
141
$self->{cmdpipe} is closed, whichever occurs first.
142
143
=back
144
145
=cut
146
147
sub run_capture_loop {
148
    my ($self, $timeout) = @_;
149
    my $starttime = gettimeofday;
150
151
    if (!$self->last_screenshot) {
152
        my $now = gettimeofday;
153
        $self->last_screenshot($now);
154
    }
155
156
    eval {
157
        # Time slot buckets
158
        my $buckets          = {};
159
        my $bucket_time_size = $bmwqemu::vars{OS_AUTOINST_BUCKET_TIME_SIZE} // 30;
160
        my $bucket_hit_size  = $bmwqemu::vars{OS_AUTOINST_BUCKET_HIT_LIMIT} // 300_000;
161
162
        while (1) {
163
164
            last if (!$self->{cmdpipe});
165
166
            my $now = gettimeofday;
167
168
            my $time_to_timeout = "Inf" + 0;
169
            if (defined $timeout) {
170
                $time_to_timeout = $timeout - ($now - $starttime);
171
172
                last if $time_to_timeout <= 0;
173
            }
174
175
            my $time_to_update_request = $self->update_request_interval - ($now - $self->last_update_request);
176
            if ($time_to_update_request <= 0) {
177
                $self->request_screen_update();
178
                $self->last_update_request($now);
179
                # no need to interrupt loop if VNC does not talk to us first
180
                $time_to_update_request = $time_to_timeout;
181
            }
182
183
            # if we got stalled for a long time, we assume bad hardware and report it
184
            if ($self->assert_screen_last_check && $now - $self->last_screenshot > $self->screenshot_interval * 20) {
185
                $self->stall_detected(1);
186
                my $diff = $now - $self->last_screenshot;
187 1
                bmwqemu::diag "WARNING: There is some problem with your environment, we detected a stall for $diff seconds";
188
            }
189
190
            my $time_to_screenshot = $self->screenshot_interval - ($now - $self->last_screenshot);
191
            if ($time_to_screenshot <= 0) {
192
                $self->capture_screenshot();
193
                $self->last_screenshot($now);
194
                $time_to_screenshot = $self->screenshot_interval;
195
            }
196
197
            my $time_to_next = min($time_to_screenshot, $time_to_update_request, $time_to_timeout);
198
            my ($read_set, $write_set) = IO::Select->select($self->{select}, $self->{select}, undef, $time_to_next);
199
200
            # We need to check the video encoder and the serial socket
201
            my ($video_encoder, $other) = (0, 0);
202
            for my $fh (@$write_set) {
203
                if ($fh == $self->{encoder_pipe}) {
204
                    # check the video encoder pipe, it has the most traffic
205
                    my $fdata        = shift @{$self->{video_frame_data}};
206
                    my $data_written = $self->{encoder_pipe}->syswrite($fdata);
207
                    die "Encoder not accepting data" unless defined $data_written;
208
                    if ($data_written != length($fdata)) {
209
                        # put it back into the queue
210
                        unshift @{$self->{video_frame_data}}, substr($fdata, $data_written);
211
                    }
212
                    if (!@{$self->{video_frame_data}}) {
213
                        $self->{select}->remove($self->{encoder_pipe});
214
                    }
215
                    $video_encoder = 1;
216
                }
217
                else {
218
                    next if $other;
219
                    $other = 1;
220
                    if (!$self->check_socket($fh, 1) && !$other) {
221
                        die "huh! $fh\n";
222
                    }
223
                }
224
                last if $video_encoder == 1 && $other;
225
            }
226
227
            for my $fh (@$read_set) {
228 1
                # This tries to solve the problem of half-open sockets (when reading, as writing will throw an exception)
229
                # There are three ways to solve this problem:
230 1
                # + Send a message either to the application protocol (null message) or to the application protocol framing (an empty message)
231 1
                #   Disadvantages: Requires changes on both ends of the communication. (for example: on SSH connection i realized that after a
232
                #   while i start getting "bad packet length" errors)
233 1
                # + Polling the connections (Note: This is how HTTP servers work when dealing with persistent connections)
234
                #    Disadvantages: False positives
235
                # + Change the keepalive packet settings
236
                #   Disadvantages: TCP/IP stacks are not required to support keepalives.
237
                if (fileno $fh && fileno $fh != -1) {
238
                    # Very high limits! On a working socket, the maximum hits per 10 seconds will be around 60.
239
                    # The maximum hits per 10 seconds saw on a half open socket was >100k
240
                    if (update_time_bucket($buckets, $bucket_time_size, fileno $fh) > $bucket_hit_size) {
241
                        die "The console isn't responding correctly. Maybe half-open socket?";
242
                    }
243
                }
244
245
246
                unless ($self->check_socket($fh, 0)) {
247
                    die "huh! $fh\n";
248
                }
249
                # don't check for further sockets after this one as
250
                # check_socket can have side effects on the sockets
251
                # (e.g. console resets), so better take the next socket
252
                # next time
253
                last;
254
            }
255
        }
256
    };
257
258
    if ($@) {
259
        bmwqemu::diag "capture loop failed $@";
260
        $self->close_pipes();
261
    }
262
    return;
263
}
264
265
# bucket_size = seconds
266
# This is not sliding buckets
267
sub update_time_bucket {
268
    my ($buckets, $bucket_size, $id) = @_;
269
270
    my $time        = gettimeofday;
271
    my $lower_limit = gettimeofday;
272
273
    if ($buckets->{TIME}) {
274
        $lower_limit = $buckets->{TIME};
275
    }
276
    else {
277
        # Bucket initialization;
278
        $buckets->{TIME} = $time;
279
    }
280
281
    my $upper_limit = $lower_limit + $bucket_size;
282
    if ($time > $upper_limit) {
283
        $buckets->{TIME}   = $time;
284
        $buckets->{BUCKET} = {};
285
    }
286
287
    return ++$buckets->{BUCKET}{$id};
288
}
289
290
291
sub start_encoder {
292
    my ($self) = @_;
293
294
    my $cwd = Cwd::getcwd();
295
    my @cmd = qw(nice -n 19);
296
    push(@cmd, ("$bmwqemu::scriptdir/videoencoder", "$cwd/video.ogv"));
297
    push(@cmd, '-n') if $bmwqemu::vars{NOVIDEO};
298
    open($self->{encoder_pipe}, '|-', @cmd);
299
300
    $self->{encoder_pipe}->blocking(0);
301
302
    return;
303
}
304
305
# new api
306
307
sub start_vm {
308
    my ($self) = @_;
309
    $self->{started} = 1;
310
    $self->start_encoder();
311
    return $self->do_start_vm();
312
}
313
314
sub stop_vm {
315
    my ($self) = @_;
316
    if ($self->{started}) {
317
        # backend.run might have disappeared already in case of failed builds
318
        no autodie 'unlink';
319
        unlink('backend.run');
320
        $self->do_stop_vm();
321
        # flush frames
322
        $self->{encoder_pipe}->blocking(1);
323
        for my $fdata (@{$self->{video_frame_data}}) {
324
            $self->{encoder_pipe}->print($fdata);
325
        }
326
        $self->{encoder_pipe}->close if $self->{encoder_pipe};
327
        $self->{encoder_pipe} = undef;
328
        $self->{started}      = 0;
329
    }
330
    $self->close_pipes();    # does not return
331
    return;
332
}
333
334
sub alive {
335
    my ($self) = @_;
336
    if ($self->{started}) {
337
        if ($self->file_alive() and $self->raw_alive()) {
338
            return 1;
339
        }
340
        else {
341
            bmwqemu::diag("ALARM: backend.run got deleted! - exiting...");
342
            _exit(1);
343
        }
344
    }
345
    return 0;
346
}
347
348
my $iscrashedfile = 'backend.crashed';
349
sub unlink_crash_file {
350
    unlink($iscrashedfile) if -e $iscrashedfile;
351
}
352
353
sub write_crash_file {
354
    open(my $fh, ">", $iscrashedfile);
355
    print $fh "crashed\n";
356
    close $fh;
357
}
358
359
# new api end
360
361
# virtual methods
362
sub notimplemented { confess "backend method not implemented" }
363
364
sub power {
365
366
    # parameters: acpi, reset, (on), off
367
    notimplemented;
368
}
369
370
sub insert_cd { notimplemented }
371
sub eject_cd  { notimplemented }
372
373
sub do_start_vm {
374
    # start up the vm
375
    notimplemented;
376
}
377
378
sub do_stop_vm { notimplemented }
379
380
sub stop { notimplemented }
381
sub cont { notimplemented }
382
383
sub can_handle {
384
    my ($self, $args) = @_;
385
    return;    # sorry, no
386
}
387
388
sub do_extract_assets { notimplemented }
389
390
sub is_shutdown {
391
    return -1;
392
}
393
394
sub save_memory_dump {
395
    notimplemented;
396
}
397
398
sub save_storage_drives {
399
    notimplemented;
400
}
401
402
## MAY be overwritten:
403
404
sub cpu_stat {
405
    # vm's would return
406
    # (userstat, systemstat)
407
    return [];
408
}
409
410
sub enqueue_screenshot {
411
    my ($self, $image) = @_;
412
413
    return unless $image;
414
415
    my $watch = OpenQA::Benchmark::Stopwatch->new();
416
    $watch->start();
417
418
    $image = $image->scale(1024, 768);
419
    $watch->lap("scaling");
420
421
    my $lastscreenshot = $self->last_image;
422
423
    # link identical files to save space
424
    my $sim = 0;
425
    $sim = $lastscreenshot->similarity($image) if $lastscreenshot;
426
    $watch->lap("similarity");
427
428
    $self->{min_image_similarity} -= 1;
429
    $self->{min_image_similarity} = $sim if $sim < $self->{min_image_similarity};
430
    $self->{min_video_similarity} -= 1;
431
    $self->{min_video_similarity} = $sim if $sim < $self->{min_video_similarity};
432
433
    # we have two different similarity levels - one (slightly higher value, based
434
    # t/data/user-settings-*) to determine if it's worth it to recheck needles
435
    # and one (slightly lower as less significant) determining if we write the frame
436
    # into the video
437
    if ($self->{min_image_similarity} <= 54) {
438
        $self->last_image($image);
439 1
        $self->{min_image_similarity} = 10000;
440
    }
441
442
    if ($self->{min_video_similarity} > 50) {    # we ignore smaller differences
443
        push(@{$self->{video_frame_data}}, "R\n");
444
    }
445
    else {
446
        my $imgdata = $image->ppm_data;
447
        $watch->lap("convert ppm data");
448
        push(@{$self->{video_frame_data}}, 'E ' . length($imgdata) . "\n");
449
        push(@{$self->{video_frame_data}}, $imgdata);
450 1
        $self->{min_video_similarity} = 10000;
451
    }
452
    $self->{select}->add($self->{encoder_pipe});
453
    $self->{video_frame_number} += 1;
454
455
    $watch->stop();
456
    if ($watch->as_data()->{total_time} > $self->screenshot_interval && !$bmwqemu::vars{NO_DEBUG_IO}) {
457
        bmwqemu::diag sprintf("WARNING: enqueue_screenshot took %.2f seconds", $watch->as_data()->{total_time});
458
        bmwqemu::diag "DEBUG_IO: \n" . $watch->summary();
459
    }
460
461
    return;
462
}
463
464
sub close_pipes {
465
    my ($self) = @_;
466
467
    if ($self->{cmdpipe}) {
468
        close($self->{cmdpipe}) || die "close $!\n";
469
        $self->{cmdpipe} = undef;
470
    }
471
472
    return unless $self->{rsppipe};
473
474
    bmwqemu::diag "sending magic and exit";
475
    $self->{rsppipe}->print('{"QUIT":1}');
476
    close($self->{rsppipe}) || die "close $!\n";
477
    Devel::Cover::report() if Devel::Cover->can('report');
478
    _exit(0);
479
}
480
481
# this is called for all sockets ready to read from
482
sub check_socket {
483
    my ($self, $fh, $write) = @_;
484
485
    if ($self->{cmdpipe} && $fh == $self->{cmdpipe}) {
486
        return 1 if $write;
487
        my $cmd = myjsonrpc::read_json($self->{cmdpipe});
488
489
        if ($cmd->{cmd}) {
490
            my $rsp = {rsp => ($self->handle_command($cmd) // 0)};
491
            $rsp->{json_cmd_token} = $cmd->{json_cmd_token};
492
            if ($self->{rsppipe}) {    # the command might have closed it
493
                my $JSON = JSON->new()->convert_blessed();
494
                my $json = $JSON->encode($rsp);
495
                $self->{rsppipe}->print($json);
496
            }
497
        }
498
        else {
499 1
            use Data::Dumper;
500
            die "no command in " . Dumper($cmd);
501
        }
502
        return 1;
503
    }
504
    return 0;
505
}
506
507
###################################################################
508
## access other consoles from the test case process
509
510
# There can be two vnc backends (local Xvnc or remote vnc) and
511
# there can be several terminals on the local Xvnc.
512
#
513
# switching means: turn to the right vnc and if it's the Xvnc,
514
# iconify/deiconify the right x3270 terminal window.
515
#
516
# FIXME? for now, we just raise the terminal window to the front on
517
# the local-Xvnc DISPLAY.
518
#
519
# should we hide the other windows, somehow?
520
#if exists $self->{current_console} ...
521
# my $current_window_id = $self->{current_console}->{window_id};
522
# if (defined $current_window_id) {
523
#     system("DISPLAY=$display xdotool windowminimize --sync $current_window_id");
524
# }
525
#-> select
526
527
sub select_console {
528
    my ($self, $args) = @_;
529
    my $testapi_console = $args->{testapi_console};
530
531
    my $selected_console = $self->console($testapi_console);
532
    my $activated        = $selected_console->select;
533
534
    return $activated if ref($activated);
535
    $self->{current_console} = $selected_console;
536
    $self->{current_screen}  = $selected_console->screen;
537
    $self->capture_screenshot();
538
    return {activated => $activated};
539
}
540
541
sub reset_consoles {
542
    my ($self, $args) = @_;
543
544
    # we iterate through all consoles
545
    for my $console (keys %{$testapi::distri->{consoles}}) {
546
        #next if ($console eq 'x3270');
547
        $self->reset_console({testapi_console => $console});
548
    }
549
    return;
550
}
551
552
sub reset_console {
553
    my ($self, $args) = @_;
554
    $self->console($args->{testapi_console})->reset;
555
    return;
556
}
557
558
sub deactivate_console {
559
    my ($self, $args) = @_;
560
    my $testapi_console = $args->{testapi_console};
561
562
    my $console_info = $self->console($testapi_console);
563
    if (defined $self->{current_console} && $self->{current_console} == $console_info) {
564
        $self->{current_console} = undef;
565
    }
566
    $console_info->disable();
567
    return;
568
}
569
570
sub request_screen_update {
571
    my ($self) = @_;
572
573
    return $self->bouncer('request_screen_update', undef);
574
}
575
576
sub console {
577
    my ($self, $testapi_console) = @_;
578
579
    my $ret = $testapi::distri->{consoles}->{$testapi_console};
580
    unless ($ret) {
581
        carp "console $testapi_console does not exist";
582
    }
583
    return $ret;
584
}
585
586
sub bouncer {
587
    my ($self, $call, $args) = @_;
588
    # forward to the current VNC console
589
    return unless $self->{current_screen};
590
    return $self->{current_screen}->$call($args);
591
}
592
593
sub send_key {
594
    my ($self, $args) = @_;
595
    return $self->bouncer('send_key', $args);
596
}
597
598
sub hold_key {
599
    my ($self, $args) = @_;
600
    return $self->bouncer('hold_key', $args);
601
}
602
603
sub release_key {
604
    my ($self, $args) = @_;
605
    return $self->bouncer('release_key', $args);
606
}
607
608
sub type_string {
609
    my ($self, $args) = @_;
610
    return $self->bouncer('type_string', $args);
611
}
612
613
sub mouse_set {
614
    my ($self, $args) = @_;
615
    return $self->bouncer('mouse_set', $args);
616
}
617
618
sub mouse_hide {
619
    my ($self, $args) = @_;
620
    return $self->bouncer('mouse_hide', $args);
621
}
622
623
sub mouse_button {
624
    my ($self, $args) = @_;
625
    return $self->bouncer('mouse_button', $args);
626
}
627
628
sub get_last_mouse_set {
629
    my ($self, $args) = @_;
630
    return $self->bouncer('get_last_mouse_set', $args);
631
}
632
633
sub is_serial_terminal {
634
    my ($self, $args) = @_;
635
    return {yesorno => $self->{current_console}->is_serial_terminal};
636
}
637
638
sub capture_screenshot {
639
    my ($self) = @_;
640
    return unless $self->{current_screen};
641
642
    my $screen = $self->{current_screen}->current_screen();
643
    $self->enqueue_screenshot($screen) if $screen;
644
    return;
645
}
646
647
sub reload_needles {
648
    # called from testapi::set_var, so read the vars
649
    bmwqemu::load_vars();
650
651
    for my $n (needle->all()) {
652
        $n->unregister();
653
    }
654
    needle::init();
655
}
656
657
###################################################################
658
# this is used by backend::console_proxy
659
sub proxy_console_call {
660
    my ($self, $wrapped_call) = @_;
661
662
    my ($console, $function, $args) = @$wrapped_call{qw(console function args)};
663
    $console = $self->console($console);
664
665
    my $wrapped_result = {};
666
667
    eval {
668
        # Do not die in here.
669
        # Move the decision to actually die to the server side instead.
670
        # For this ignore backend::baseclass::die_handler.
671
        local $SIG{__DIE__} = 'DEFAULT';
672
        $wrapped_result->{result} = $console->$function(@$args);
673
    };
674
675
    if ($@) {
676
        $wrapped_result->{exception} = join("\n", bmwqemu::pp($wrapped_call), $@);
677
    }
678
679
    return $wrapped_result;
680
}
681
682
=head2 set_serial_offset
683
684
Determines the starting offset within the serial file - so that we do not check the
685
previous test's serial output. Call this before you start doing something new
686
687
=cut
688
689
sub set_serial_offset {
690
    my ($self, $args) = @_;
691
692
    $self->{serial_offset} = -s $self->{serialfile};
693
    return $self->{serial_offset};
694
}
695
696
697
=head2 serial_text
698
699
Returns the output on the serial device since the last call to set_serial_offset
700
701
=cut
702
703
sub serial_text {
704
    my ($self) = @_;
705
706
    open(my $SERIAL, "<", $self->{serialfile});
707
    seek($SERIAL, $self->{serial_offset}, 0);
708
    local $/;
709
    my $data = <$SERIAL>;
710
    close($SERIAL);
711
    return $data;
712
}
713
714
sub wait_serial {
715
    my ($self, $args) = @_;
716
717
    my $regexp  = $args->{regexp};
718
    my $timeout = $args->{timeout};
719
    my $matched = 0;
720
    my $str;
721
722
    confess '\'current_console\' is not set' unless $self->{current_console};
723
    if ($self->{current_console}->is_serial_terminal) {
724
        return $self->{current_screen}->read_until($regexp, $timeout, %$args);
725
    }
726
727
    if (ref $regexp ne 'ARRAY') {
728
        $regexp = [$regexp];
729
    }
730
731
    my $initial_time = time;
732
    while (time < $initial_time + $timeout) {
733
        $str = $self->serial_text();
734
        for my $r (@$regexp) {
735
            if (ref $r eq 'Regexp') {
736
                $matched = $str =~ $r;
737
            }
738
            else {
739
                $matched = $str =~ m/$r/;
740
            }
741
            if ($matched) {
742
                $regexp = "$r";
743
                last;
744
            }
745
        }
746
        last if ($matched);
747
        $self->run_capture_loop(1);
748
    }
749
    $self->set_serial_offset();
750
    return {matched => $matched, string => $str};
751
}
752
753
# set_reference_screenshot and similiarity_to_reference are necessary to
754
# implement wait_still and wait_changed functions in the tests without having
755
# to transfer the screenshot into the test process
756
sub set_reference_screenshot {
757
    my ($self, $args) = @_;
758
759
    $self->reference_screenshot($self->last_image);
760
    return;
761
}
762
763
sub similiarity_to_reference {
764
    my ($self, $args) = @_;
765
    if (!$self->reference_screenshot || !$self->last_image) {
766 1
        return {sim => 10000};
767
    }
768
    return {sim => $self->reference_screenshot->similarity($self->last_image)};
769
}
770
771
sub wait_idle {
772
    my ($self, $args) = @_;
773
    my $timeout = $args->{timeout};
774
775
    bmwqemu::diag("wait_idle sleeping for $timeout seconds");
776
    $self->run_capture_loop($timeout);
777
    return;
778
}
779
780
sub set_tags_to_assert {
781
    my ($self, $args) = @_;
782
    my $mustmatch = $args->{mustmatch};
783
    my $timeout   = $args->{timeout} // $bmwqemu::default_timeout;
784
785
    # free all needle images (https://progress.opensuse.org/issues/15438)
786
    for my $n (needle->all()) {
787
        $n->{img} = undef;
788
    }
789
790
    # get the array reference to all matching needles
791
    my $needles = [];
792
    my @tags;
793
    if (ref($mustmatch) eq "ARRAY") {
794
        my @a = @$mustmatch;
795
        while (my $n = shift @a) {
796
            if (ref($n) eq '') {
797
                push @tags, split(/ /, $n);
798
                $n = needle::tags($n);
799
                push @a, @$n if $n;
800
                next;
801
            }
802
            unless (ref($n) eq 'needle' && $n->{name}) {
803
                warn "invalid needle passed <" . ref($n) . "> " . bmwqemu::pp($n);
804
                next;
805
            }
806
            push @$needles, $n;
807
        }
808
        $needles = [uniq @$needles];
809
    }
810
    elsif ($mustmatch) {
811
        $needles = needle::tags($mustmatch) || [];
812
        @tags = ($mustmatch);
813
    }
814
815
    {    # remove duplicates
816
        my %h = map { $_ => 1 } @tags;
817
        @tags = sort keys %h;
818
    }
819
    $mustmatch = join(',', @tags);
820
821
    if (!@$needles) {
822
        bmwqemu::diag("NO matching needles for $mustmatch");
823
    }
824
825
    $self->assert_screen_deadline(time + $timeout);
826
    $self->assert_screen_fails([]);
827
    $self->assert_screen_needles($needles);
828
    $self->assert_screen_last_check(undef);
829
    $self->stall_detected(0);
830
    # store them for needle reload event
831
    $self->assert_screen_tags(\@tags);
832
    $self->assert_screen_check($args->{check});
833
    return {tags => \@tags};
834
}
835
836
sub _time_to_assert_screen_deadline {
837
    my ($self) = @_;
838
839
    return $self->assert_screen_deadline - time;
840
}
841
842
sub reduce_deadline {
843
    my ($self) = @_;
844
845
    $self->assert_screen_deadline(time);
846
    return;
847
}
848
849
sub _failed_screens_to_json {
850
    my ($self) = @_;
851
852
    my $failed_screens = $self->assert_screen_fails;
853
    my $final_mismatch = $failed_screens->[-1];
854
    if ($final_mismatch) {
855
        _reduce_to_biggest_changes($failed_screens, 20);
856
        # only append the last mismatch if it's different to the last one in the reduced list
857
        my $new_final = $failed_screens->[-1];
858
        if ($new_final != $final_mismatch) {
859
            my $sim = $new_final->[0]->similarity($final_mismatch->[0]);
860
            push(@$failed_screens, $final_mismatch) if ($sim < 50);
861
        }
862
    }
863
864
    my @json_fails;
865
    for my $l (@$failed_screens) {
866
        my ($img, $failed_candidates, $testtime, $similarity, $frame) = @$l;
867
        my $h = {
868
            candidates => $failed_candidates,
869
            image      => encode_base64($img->ppm_data),
870
            frame      => $frame,
871
        };
872
        push(@json_fails, $h);
873
    }
874
875
    # free memory
876
    $self->assert_screen_fails([]);
877
    return {timeout => 1, failed_screens => \@json_fails};
878
}
879
880
sub time_remaining_str {
881
    my $time = shift;
882
    # compensate rounding to be consistent with truncation in $search_ratio calculation
883
    return sprintf("%.1fs", $time - 0.05);
884
}
885
886
sub check_asserted_screen {
887
    my ($self, $args) = @_;
888
889
    my $img = $self->last_image;
890
    if (!$img) {    # no screenshot yet to search on
891
        return;
892
    }
893
    my $watch     = OpenQA::Benchmark::Stopwatch->new();
894
    my $timestamp = $self->last_screenshot;
895
    my $n         = $self->_time_to_assert_screen_deadline;
896
    my $frame     = $self->{video_frame_number};
897
898
    my $search_ratio = 0.02;
899
    $search_ratio = 1 if ($n % 5 == 0);
900
901
    my ($oldimg, $old_search_ratio) = @{$self->assert_screen_last_check || [undef, 0]};
902
903
    if ($n < 0) {
904
        # one last big search
905
        $search_ratio = 1;
906
    }
907
    else {
908
        if ($oldimg && $oldimg eq $img && $old_search_ratio >= $search_ratio) {
909
            bmwqemu::diag('no change: ' . time_remaining_str($n));
910
            return;
911
        }
912
    }
913
914
    $watch->start();
915
    $watch->{debug} = 1;
916
917
    my @registered_needles = grep { !$_->{unregistered} } @{$self->assert_screen_needles};
918 1
    my ($foundneedle, $failed_candidates) = $img->search(\@registered_needles, 0, $search_ratio, ($watch->{debug} ? $watch : undef));
919
    $watch->lap("Needle search") unless $watch->{debug};
920
    if ($foundneedle) {
921
        $self->assert_screen_last_check(undef);
922
        return {
923
            image      => encode_base64($img->ppm_data),
924
            found      => $foundneedle,
925
            candidates => $failed_candidates,
926
            frame      => $frame,
927
        };
928
    }
929
930
    $watch->stop();
931
    if ($watch->as_data()->{total_time} > $self->screenshot_interval && !$bmwqemu::vars{NO_DEBUG_IO}) {
932 1
        bmwqemu::diag sprintf("WARNING: check_asserted_screen took %.2f seconds - make your needles more specific", $watch->as_data()->{total_time});
933
        bmwqemu::diag "DEBUG_IO: \n" . $watch->summary();
934
    }
935
936
    if ($n < 0) {
937
        # make sure we recheck later
938
        $self->assert_screen_last_check(undef);
939
940
        if (!$self->assert_screen_check) {
941
            my @unregistered_needles = grep { $_->{unregistered} } @{$self->assert_screen_needles};
942 1
            my ($foundneedle, $candidates) = $img->search(\@unregistered_needles, 0, 1, undef);
943
            # the best here is still a failure, as unregistered
944
            push(@$failed_candidates, $foundneedle) if $foundneedle;
945
            push(@$failed_candidates, @$candidates);
946
        }
947
        my $failed_screens = $self->assert_screen_fails;
948
        # store the final mismatch
949
        push(@$failed_screens, [$img, $failed_candidates, 0, 1000, $frame]);
950
        my $hash = $self->_failed_screens_to_json;
951
        $hash->{image} = encode_base64($img->ppm_data);
952
        # store stall status
953
        $hash->{stall} = $self->stall_detected;
954
955
        return $hash;
956
    }
957
958
    if ($search_ratio == 1) {
959
        # save only failures where the whole screen has been searched
960
        # results of partial searching are rather confusing
961
962
        # as the images create memory pressure, we only save quite different images
963
        # the last screen is handled automatically and the first screen is only interesting
964
        # if there are no others
965
        my $sim            = 29;
966
        my $failed_screens = $self->assert_screen_fails;
967
        if ($failed_screens->[-1] && $n > 0) {
968
            $sim = $failed_screens->[-1]->[0]->similarity($img);
969
        }
970
        if ($sim < 30) {
971
            push(@$failed_screens, [$img, $failed_candidates, $n, $sim, $frame]);
972
        }
973
        # clean up every once in a while to avoid excessive memory consumption.
974
        # The value here is an arbitrary limit.
975
        if (@$failed_screens > 60) {
976
            _reduce_to_biggest_changes($failed_screens, 20);
977
        }
978
    }
979
    bmwqemu::diag('no match: ' . time_remaining_str($n));
980
    $self->assert_screen_last_check([$img, $search_ratio]);
981
    return;
982
}
983
984
sub _reduce_to_biggest_changes {
985
    my ($imglist, $limit) = @_;
986
987
    return if @$imglist <= $limit;
988
989
    my $first = shift @$imglist;
990
    @$imglist = (sort { $b->[3] <=> $a->[3] } @$imglist)[0 .. (@$imglist > $limit ? $limit - 1 : $#$imglist)];
991
    unshift @$imglist, $first;
992
993
    # now sort for test time
994
    @$imglist = sort { $b->[2] <=> $a->[2] } @$imglist;
995
996
    # recalculate similarity
997
    for (my $i = 1; $i < @$imglist; ++$i) {
998
        $imglist->[$i]->[3] = $imglist->[$i - 1]->[0]->similarity($imglist->[$i]->[0]);
999
    }
1000
1001
    return;
1002
}
1003
1004
sub freeze_vm {
1005
    my ($self) = @_;
1006
    bmwqemu::diag "ignored freeze_vm";
1007
    return;
1008
}
1009
1010
sub cont_vm {
1011
    my ($self) = @_;
1012
    bmwqemu::diag "ignored cont_vm";
1013
    return;
1014
}
1015
1016
sub last_screenshot_data {
1017
    my ($self, $args) = @_;
1018
    return {} unless $self->last_image;
1019
    return {
1020
        image => encode_base64($self->last_image->ppm_data),
1021
        frame => $self->{video_frame_number},
1022
    };
1023
}
1024
1025
sub verify_image {
1026
    my ($self, $args) = @_;
1027
    my $imgpath   = $args->{imgpath};
1028
    my $mustmatch = $args->{mustmatch};
1029
1030
    my $img = tinycv::read($imgpath);
1031
    my $needles = needle::tags($mustmatch) || [];
1032
1033
    my ($foundneedle, $failed_candidates) = $img->search($needles, 0, 1);
1034
    if ($foundneedle) {
1035
        return {found => $foundneedle, candidates => $failed_candidates};
1036
    }
1037
    return {candidates => $failed_candidates};
1038
}
1039
1040
sub retry_assert_screen {
1041
    my ($self, $args) = @_;
1042
1043
    if ($args->{reload_needles}) {
1044
        $self->reload_needles;
1045
    }
1046
    # reset timeout otherwise continue wait_forneedle might just fail if stopped too long than timeout
1047
    if ($args->{timeout}) {
1048
        $self->assert_screen_deadline(time + $args->{timeout});
1049
    }
1050
    $self->cont_vm;
1051
    # do not need to retry in 5 seconds but contining SUT if continue_waitforneedle
1052
    if ($args->{reload_needles}) {
1053
        # short timeout, we're already there
1054
        $self->set_tags_to_assert({mustmatch => $self->assert_screen_tags, timeout => 5, reloadneedles => 1});
1055
    }
1056
    return;
1057
}
1058
1059
# shared between svirt and s390 backend
1060
sub new_ssh_connection {
1061
    my ($self, %args) = @_;
1062
    $args{username} ||= 'root';
1063
1064
    my $ssh = Net::SSH2->new;
1065
1066
    # Retry 5 times, in case of the guest is not running yet
1067
    my $counter = 5;
1068
    while ($counter > 0) {
1069
        if ($ssh->connect($args{hostname})) {
1070
1071
            if ($args{password}) {
1072
                $ssh->auth(username => $args{username}, password => $args{password});
1073
            }
1074
            else {
1075
                # this relies on agent to be set up correctly
1076
                $ssh->auth_agent($args{username});
1077
            }
1078
            bmwqemu::diag "Connection to $args{username}\@$args{hostname} established" if $ssh->auth_ok;
1079
            last;
1080
        }
1081
        else {
1082
            bmwqemu::diag "Could not connect to $args{username}\@$args{hostname}, Retry";
1083
            sleep(10);
1084
            $counter--;
1085
            next;
1086
        }
1087
    }
1088
    die "Failed to login to $args{username}\@$args{hostname}" unless $ssh->auth_ok;
1089
1090
    return $ssh;
1091
}
1092
1093
# open another ssh connection to grab the serial console
1094
sub start_ssh_serial {
1095
    my ($self, %args) = @_;
1096
1097
    $self->stop_ssh_serial;
1098
1099
    $self->{serial} = $self->new_ssh_connection(%args);
1100
    my $chan = $self->{serial}->channel();
1101
    die "No channel found" unless $chan;
1102
    $self->{serial_chan} = $chan;
1103
    $chan->blocking(0);
1104
    $chan->pty(1);
1105
    $self->{select}->add($self->{serial}->sock);
1106
    return $chan;
1107
}
1108
1109
sub check_ssh_serial {
1110
    my ($self, $fh) = @_;
1111
1112
    if ($self->{serial} && $self->{serial}->sock == $fh) {
1113
        my $chan = $self->{serial_chan};
1114
        my $line = <$chan>;
1115
        if (defined $line) {
1116
            print $line;
1117
            open(my $serial, '>>', $self->{serialfile});
1118
            print $serial $line;
1119
            close($serial);
1120
        }
1121
        return 1;
1122
    }
1123
    return;
1124
}
1125
1126
sub stop_ssh_serial {
1127
    my ($self) = @_;
1128
1129
    if (!$self->{serial}) {
1130
        return;
1131
    }
1132
    $self->{select}->remove($self->{serial}->sock);
1133
    $self->{serial}->disconnect;
1134
    $self->{serial} = undef;
1135
    return;
1136
}
1137
1138
# Send TERM signal to any child process
1139 1
sub _kill_children_processes {
1140
    my ($self) = @_;
1141
    my $ret;
1142
    for my $pid (@{$self->{children}}) {
1143
        bmwqemu::diag("killing child $pid");
1144
        kill('TERM', $pid);
1145
        for my $i (1 .. 5) {
1146
            $ret = waitpid($pid, WNOHANG);
1147
            bmwqemu::diag "waitpid for $pid returned $ret";
1148
            last if ($ret == $pid);
1149
            sleep 1;
1150
        }
1151
    }
1152
}
1153
1154 1
sub _child_process {
1155
    my ($self, $code) = @_;
1156
1157
    die "Can't spawn child without code" unless ref($code) eq "CODE";
1158
1159
    my $pid = fork();
1160
    die "fork failed" unless defined($pid);
1161
1162
    if ($pid == 0) {
1163
        $code->();
1164
    }
1165
    else {
1166
        push @{$self->{children}}, $pid;
1167
        return $pid;
1168
    }
1169
1170
}
1171
1172
1;
1173
# vim: set sw=4 et: