File Coverage

testapi.pm
Criterion Covered Total %
statement 449 655 68.5
total 449 655 68.5


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    
6   use Carp;
7 54 use Exporter;
  54  
  54  
8 54 use Mojo::Base 'Exporter', -signatures;
  54  
  54  
9 54 use File::Basename qw(basename dirname);
  54  
  54  
10 54 use File::Path 'make_path';
  54  
  54  
11 54 use Time::HiRes qw(sleep gettimeofday tv_interval);
  54  
  54  
12 54 use autotest 'query_isotovideo';
  54  
  54  
13 54 use Mojo::DOM;
  54  
  54  
14 54 require IPC::System::Simple;
  54  
  54  
15   use autodie ':all';
16 54 use OpenQA::Exceptions;
  54  
  54  
17 54 use OpenQA::Isotovideo::NeedleDownloader;
  54  
  54  
18 54 use Digest::MD5 'md5_base64';
  54  
  54  
19 54 use Carp qw(cluck croak);
  54  
  54  
20 54 use MIME::Base64 'decode_base64';
  54  
  54  
21 54 use Scalar::Util qw(looks_like_number reftype);
  54  
  54  
22 54 use B::Deparse;
  54  
  54  
23 54 use Time::Seconds;
  54  
  54  
24 54  
  54  
  54  
25   require bmwqemu;
26   use constant OPENQA_LIBPATH => '/usr/share/openqa/lib';
27 54  
  54  
  54  
28   our @EXPORT = qw($realname $username $password $serialdev %cmd %vars
29    
30   get_var get_required_var check_var set_var get_var_array check_var_array autoinst_url
31    
32   send_key send_key_until_needlematch type_string type_password
33   enter_cmd
34   hold_key release_key
35    
36   assert_screen check_screen assert_and_dclick save_screenshot
37   assert_and_click mouse_hide mouse_set mouse_click
38   mouse_dclick mouse_tclick match_has_tag click_lastmatch mouse_drag
39    
40   assert_script_run script_run background_script_run
41   assert_script_sudo script_sudo script_output validate_script_output
42    
43   start_audiocapture assert_recorded_sound check_recorded_sound
44    
45   select_console console reset_consoles current_console
46    
47   upload_asset data_url check_shutdown assert_shutdown parse_junit_log parse_extra_log upload_logs
48    
49   wait_screen_change assert_screen_change wait_still_screen assert_still_screen wait_serial
50   record_soft_failure record_info force_soft_failure
51   become_root x11_start_program ensure_installed eject_cd power
52    
53   switch_network
54   save_memory_dump save_storage_drives freeze_vm resume_vm
55    
56   diag hashed_string
57    
58   save_tmp_file get_test_data
59   );
60   our @EXPORT_OK = qw(is_serial_terminal);
61    
62   our %cmd;
63    
64   our $distri;
65    
66   our $realname = "Bernhard M. Wiedemann";
67   our $username;
68   our $password;
69    
70   our $serialdev;
71    
72   our $last_matched_needle;
73    
74   sub send_key;
75   sub check_screen;
76   sub type_string;
77   sub type_password;
78   sub enter_cmd;
79    
80    
81   =head1 introduction
82    
83   =for stopwords os autoinst isotovideo openQA
84    
85   This test API module provides methods exposed by the os-autoinst backend to be
86   used within tests.
87    
88   Many methods define a timeout parameter which can be scaled by setting the
89   C<TIMEOUT_SCALE> variable in the test settings which are read by the isotovideo
90   process. The scale parameter can be used based on performance of workers to
91   prevent false positive timeouts based on differing worker performance.
92    
93   os-autoinst is used in the openQA project.
94   +For more information on how to use openQA, please visit http://open.qa/documentation
95    
96   =cut
97    
98   =head1 internal
99    
100   =head2 _calculate_clickpoint
101    
102   This subroutine is used to by several subroutines dealing with mouse clicks to calculate
103   a clickpoint, when only the needle area is available. It takes the area coordinates and
104   returns the center of that area. It is meant to be a helper subroutine not available
105   to be used in tests.
106    
107   =cut
108    
109   my ($needle_to_use, $needle_area, $click_point) = @_;
110   # If there is no needle area defined, take it from the needle itself.
111 12 if (!$needle_area) {
112   $needle_area = $needle_to_use->{area}->[-1];
113 12 }
114 5 # If there is no clickpoint defined, or if it has been specifically defined as "center"
115   # then calculate the click point as a central point of the specified area.
116   if (!$click_point || $click_point eq 'center') {
117   $click_point = {
118 12 xpos => $needle_area->{w} / 2,
119   ypos => $needle_area->{h} / 2,
120   };
121 10 }
122   # Use the click point coordinates (which are relative numbers inside of the area)
123   # to calculate the absolute click point position.
124   my $x = int($needle_area->{x} + $click_point->{xpos});
125   my $y = int($needle_area->{y} + $click_point->{ypos});
126 12 return $x, $y;
127 12 }
128 12  
129   =for stopwords xen hvc0 xvc0 ipmi ttyS
130    
131   =head2 init
132    
133   Used for internal initialization, do not call from tests.
134    
135   =cut
136    
137   if (get_var('OFW') || get_var('BACKEND', '') =~ /s390x|pvm_hmc/) {
138   $serialdev = "hvc0";
139   }
140 14 elsif (get_var('SERIALDEV')) {
141 0 $serialdev = get_var('SERIALDEV');
142   }
143   else {
144 0 $serialdev = 'ttyS0';
145   }
146   return;
147 14 }
148    
149 14 =for stopwords ProhibitSubroutinePrototypes
150    
151   =head2 set_distribution
152    
153   set_distribution($distri);
154    
155   Set distribution object.
156    
157   You can use distribution object to implement distribution specific helpers.
158    
159   =cut
160    
161   ($distri) = @_;
162   return $distri->init();
163   }
164    
165 23 =for stopwords SUT
166 23  
167   =head1 video output handling
168    
169   =head2 save_screenshot
170    
171   save_screenshot;
172    
173   Saves screenshot of current SUT screen.
174    
175   =cut
176    
177   return $autotest::current_test->take_screenshot;
178   }
179    
180   =head2 record_soft_failure
181    
182 2 =for stopwords softfail
183    
184   record_soft_failure([$reason]);
185    
186   Record a soft failure on the current test modules result. The result will
187   still be counted as a success. Use this to mark where workarounds are applied.
188   Takes an optional C<$reason> string which is recorded in the log file. See
189   C<force_soft_failure> to forcefully override a failed test module status from
190   a C<post_fail_hook> or C<record_info> when the status should not be
191   influenced.
192    
193   =cut
194    
195   my ($reason) = @_;
196   bmwqemu::log_call(reason => $reason);
197    
198   $autotest::current_test->record_soft_failure_result($reason);
199   }
200    
201 2 my ($result) = @_;
202 2 return $result =~ /^(ok|fail|softfail)$/;
203   }
204 2  
205   =head2 record_info
206    
207   =for stopwords softfail
208 3  
209 3 record_info($title, $output [, result => $result] [, resultname => $resultname]);
210    
211   Example:
212    
213   record_info('workaround', "we know what we are doing");
214    
215   Record a generic step result on the current test modules. This is meant for
216   informational purposes to be interpreted by a displaying system. For example
217   openQA can show a info box as part of the job results details. Use this
218   instead of C<record_soft_failure> for example when you do not want to mark the
219   job as a softfail. The optional value C<$result> can be 'ok' (default),
220   'fail', 'softfail'. C<$resultname> can be specified for the additional name
221   tag on the result file.
222    
223   =cut
224    
225   my ($title, $output, %nargs) = @_;
226   $nargs{result} //= 'ok';
227   die 'unsupported $result \'' . $nargs{result} . '\'' unless _is_valid_result($nargs{result});
228   $output //= '';
229   bmwqemu::log_call(title => $title, output => $output, %nargs);
230   $autotest::current_test->record_resultfile($title, $output, %nargs);
231   }
232    
233 3 =head2 force_soft_failure
234 3  
235 3 =for stopwords softfail
236 2  
237 2 force_soft_failure([$reason]);
238 2  
239   Similar to C<record_soft_failure> but can be used to override the test module
240   status to softfail from a C<post_fail_hook> if the module would be set to fail
241   otherwise. This can be used for easier tracking of known issues without
242   needing to handle failed tests a lot.
243    
244   =cut
245    
246   my ($reason) = @_;
247   bmwqemu::log_call(reason => $reason);
248    
249   $autotest::current_test->record_soft_failure_result($reason, force_status => 1);
250   }
251    
252   my ($foundneedle, $rsp, $tags) = @_;
253   # convert the needle back to an object
254   $foundneedle->{needle} = needle->new($foundneedle->{needle});
255 0 my $img = tinycv::from_ppm(decode_base64($rsp->{image}));
256 0 my $frame = $rsp->{frame};
257   $autotest::current_test->record_screenmatch($img, $foundneedle, $tags, $rsp->{candidates}, $frame);
258 0 my $lastarea = $foundneedle->{area}->[-1];
259   bmwqemu::fctres(
260   sprintf("found %s, similarity %.2f @ %d/%d", $foundneedle->{needle}->{name}, $lastarea->{similarity}, $lastarea->{x} // 0, $lastarea->{y} // 0));
261   $last_matched_needle = $foundneedle;
262 0 return $foundneedle;
263   }
264 0  
265 0  
266 0 my ($rsp, $check, $timeout, $mustmatch) = @_;
267 0  
268 0 my $tags = $rsp->{tags};
269    
270 0 if (my $foundneedle = $rsp->{found}) {
271 0 return _handle_found_needle($foundneedle, $rsp, $tags);
272 0 }
273   elsif ($rsp->{timeout}) {
274   my $method = $check ? 'check_screen' : 'assert_screen';
275   my $status_message = "match=" . join(',', @$tags) . " timed out after $timeout ($method)";
276   bmwqemu::fctres($status_message);
277 13  
278   # add the final mismatch as 'unk' result to be able to create a new needle from it
279 13 # note: add the screenshot only if configured to pause on timeout - otherwise we would
280   # record each failure twice
281 13 my $failed_screens = $rsp->{failed_screens};
282 8 my $final_mismatch = $failed_screens->[-1];
283   if (query_isotovideo(is_configured_to_pause_on_timeout => {check => $check})) {
284   my $current_test = $autotest::current_test;
285 5 if ($final_mismatch) {
286 5 $autotest::current_test->record_screenfail(
287 5 img => tinycv::from_ppm(decode_base64($final_mismatch->{image})),
288   needles => $final_mismatch->{candidates},
289   tags => $tags,
290   result => 'unk',
291   frame => $final_mismatch->{frame},
292 5 );
293 5 }
294 5 else {
295 0 bmwqemu::fctwarn("ran into $method timeout but there's no final mismatch - just taking a screenshot");
296 0 $current_test->take_screenshot();
297   }
298   $current_test->save_test_result();
299   }
300    
301   # do a special rpc call to isotovideo which will block if the test should be paused
302   # (if the test should not be paused this call will return 0; on resume (after pause) it will return 1)
303 0 query_isotovideo('report_timeout', {
304   tags => $tags,
305   msg => $status_message,
306 0 check => $check,
307 0 }) and return 'try_again';
308    
309 0 if ($check) {
310   # only care for the last one
311   $failed_screens = [$final_mismatch];
312   }
313   for my $l (@$failed_screens) {
314 5 my $img = tinycv::from_ppm(decode_base64($l->{image}));
315   my $result = $check ? 'unk' : 'fail';
316   $result = 'unk' if ($l != $final_mismatch);
317   if ($rsp->{saveresult}) {
318   $autotest::current_test->record_screenfail(
319   img => $img,
320 3 needles => $l->{candidates},
321   tags => $tags,
322 1 result => $result,
323   frame => $l->{frame},
324 3 );
325 3 }
326 3 else {
327 3 $autotest::current_test->record_screenfail(
328 3 img => $img,
329   needles => $l->{candidates},
330   tags => $tags,
331   result => $result,
332   overall => $check ? undef : 'fail',
333   frame => $l->{frame},
334   );
335 0 }
336   }
337   # Handle case where a stall was detected: fail if this is an
338   # assert_screen, warn if it's a check_screen
339   if ($rsp->{stall}) {
340   if (!$check) {
341   record_info('Stall detected', 'Stall was detected during assert_screen fail', result => 'fail');
342   }
343   else {
344   bmwqemu::fctwarn("stall detected during check_screen failure!");
345 3 }
346   }
347   if (!$check && !$rsp->{saveresult}) {
348   # Must match can be only scalar or array ref.
349   my $needletags = $mustmatch;
350 3 if (ref($mustmatch) eq 'ARRAY') {
351 0 $needletags = join(', ', @$mustmatch);
352 0 }
353   OpenQA::Exception::FailedNeedle->throw(
354   error => "no candidate needle with tag(s) '$needletags' matched",
355 0 tags => $mustmatch
356   );
357   }
358 3 if ($rsp->{saveresult}) {
359   $autotest::current_test->save_test_result();
360 2 # now back into waiting for the backend
361 2 $rsp = myjsonrpc::read_json($autotest::isotovideo);
362 0 return unless $rsp;
363   $rsp = $rsp->{ret};
364   $rsp->{tags} = $tags;
365 2 return _check_backend_response($rsp, $check, $timeout, $mustmatch);
366   }
367   }
368   else {
369 1 die "unexpected response " . bmwqemu::pp($rsp);
370 0 }
371   return;
372 0 }
373 0  
374 0 my ($mustmatch, $check, %args) = @_;
375 0  
376 0 die "no tags specified" if (!$mustmatch || (ref $mustmatch eq 'ARRAY' && scalar @$mustmatch == 0));
377   die "current_test undefined" unless $autotest::current_test;
378    
379   $args{timeout} = bmwqemu::scale_timeout($args{timeout});
380 0  
381   while (1) {
382 1 my $rsp = query_isotovideo('check_screen', {mustmatch => $mustmatch, check => $check, timeout => $args{timeout}, no_wait => $args{no_wait}});
383    
384   # check backend response
385   # (implemented as separate function because it needs to call itself)
386 14 my $backend_response = _check_backend_response($rsp, $check, $args{timeout}, $mustmatch);
387    
388 14 # return the response unless we should try again after resuming from paused state
389 12 return $backend_response if (!$backend_response || $backend_response ne 'try_again');
390    
391 11 # download new needles
392   OpenQA::Isotovideo::NeedleDownloader->new()->download_missing_needles($rsp->{new_needles} // []);
393 11  
394 13 # reload needles before trying again
395   query_isotovideo('backend_reload_needles', {});
396   }
397   }
398 13  
399   =head2 assert_screen
400    
401 11 assert_screen($mustmatch [, [$timeout] | [timeout => $timeout]] [, no_wait => $no_wait]);
402    
403   Wait for needle with tag C<$mustmatch> to appear on SUT screen. C<$mustmatch>
404 2 can be string or C<ARRAYREF> of string (C<['tag1', 'tag2']>). The maximum
405   waiting time is defined by C<$timeout>. It is recommended to use a value lower
406   than the default timeout only when explicitly needed. C<assert_screen> is not
407 2 very suitable for checking performance expectations. Under the normal
408   circumstance of the screen being shown this does not imply a longer waiting
409   time as the method returns as soon as a successful needle match occurred.
410    
411   Specify C<$no_wait> to run the screen check as fast as possible that is
412   possibly more than once per second which is default. Select this to check a
413   screen which can change in a range faster than 1-2 seconds not to miss the
414   screen to check for.
415    
416   Returns matched needle or throws C<FailedNeedle> exception if $timeout timeout
417   is hit. Default timeout is 30s.
418    
419   =cut
420    
421   my ($mustmatch) = shift;
422   my $timeout;
423   $timeout = shift if (@_ % 2);
424   my %args = (timeout => $timeout // $bmwqemu::default_timeout, @_);
425   bmwqemu::log_call(mustmatch => $mustmatch, %args);
426   return _check_or_assert($mustmatch, 0, %args);
427   }
428    
429   =head2 check_screen
430    
431   check_screen($mustmatch [, [$timeout] | [timeout => $timeout]] [, no_wait => $no_wait]);
432    
433   Similar to C<assert_screen> but does not throw exceptions. Use this for optional matches.
434 10 Check C<assert_screen> for parameters.
435 10  
436 10 Unlike C<assert_screen> it is recommended to use the lowest possible timeout
437 10 to prevent needless waiting time in case no match is expected behaviour. In
438 10 general a value of 0s for the timeout should suffice, that is only checking
439 10 once with no waiting time. In most cases a check_screen with a higher timeout
440   can be replaced by C<assert_screen> with multiple tags using an C<ARRAYREF> in
441   combination with C<match_has_tag> or another synchronization call in before,
442   for example C<wait_screen_change> or C<wait_still_screen>.
443    
444   Returns matched needle or C<undef> if timeout is hit. Default timeout is 0s.
445    
446   =cut
447    
448   my ($mustmatch) = shift;
449   my $timeout;
450   $timeout = shift if (@_ % 2);
451   my %args = (timeout => $timeout // 0, @_);
452   bmwqemu::log_call(mustmatch => $mustmatch, %args);
453   return _check_or_assert($mustmatch, 1, %args);
454   }
455    
456   =head2 match_has_tag
457    
458   match_has_tag($tag);
459    
460   Returns true (1) if last matched needle has C<$tag>, false (0) if last
461   matched needle does not have C<$tag>, and C<undef> if no needle has yet
462 4 been matched at the time of the call.
463 4  
464 4 =cut
465 4  
466 4 my ($tag) = @_;
467 4 if ($last_matched_needle) {
468   return $last_matched_needle->{needle}->has_tag($tag);
469   }
470   return;
471   }
472    
473   =head2 assert_and_click
474    
475   assert_and_click($mustmatch [, timeout => $timeout] [, button => $button] [, clicktime => $clicktime ] [, dclick => 1 ] [, mousehide => 1 ]);
476    
477   Wait for needle with C<$mustmatch> tag to appear on SUT screen. Then click
478   C<$button> at the "click_point" position as defined in the needle JSON file,
479   or - if the JSON has not explicit "click_point" - in the middle of the last
480   needle area. If C<$dclick> is set, do double click instead. C<$mustmatch> can
481 2 be string or C<ARRAYREF> of strings (C<['tag1', 'tag2']>). C<$button> is by
482 2 default C<'left'>. C<'left'> and C<'right'> is supported. If C<$mousehide> is
483 0 true then always move mouse to the 'hidden' position after clicking to prevent
484   to hide the area where user wants to assert/click in second step.
485 2  
486   Throws C<FailedNeedle> exception if C<$timeout> timeout is hit. Default timeout is 30s.
487    
488   =cut
489    
490   my ($mustmatch, %args) = @_;
491   $args{timeout} //= $bmwqemu::default_timeout;
492    
493   $last_matched_needle = assert_screen($mustmatch, $args{timeout});
494   bmwqemu::log_call(mustmatch => $mustmatch, %args);
495    
496   my %click_args = map { $_ => $args{$_} } qw(button dclick mousehide);
497   return click_lastmatch(%click_args);
498   }
499    
500   =head2 click_lastmatch
501    
502   click_lastmatch([, button => $button] [, clicktime => $clicktime ] [, dclick => 1 ] [, mousehide => 1 ]);
503    
504   Click C<$button> at the "click_point" position as defined in the needle JSON file
505   of the last matched needle, or - if the JSON has not explicit "click_point" -
506 6 in the middle of the last match area. If C<$dclick> is set, do double click
507 6 instead. Supported values for C<$button> are C<'left'> and C<'right'>, C<'left'>
508   is the default. If C<$mousehide> is true then always move mouse to the 'hidden'
509 6 position after clicking to prevent to disturb the area where user wants to
510 6 assert/click in second step, otherwise move the mouse back to its previous
511   position.
512 6  
  18  
513 6 =cut
514    
515   my %args = @_;
516   $args{button} //= 'left';
517   $args{dclick} //= 0;
518   $args{mousehide} //= 0;
519    
520   return unless $last_matched_needle;
521    
522   my $old_mouse_coords = query_isotovideo('backend_get_last_mouse_set');
523    
524   # determine click coordinates from the last area which has those explicitly specified
525   my $relevant_area;
526   my $relative_click_point;
527   for my $area (reverse @{$last_matched_needle->{area}}) {
528   next unless ($relative_click_point = $area->{click_point});
529   $relevant_area = $area;
530   last;
531   }
532 6  
533 6 # Calculate the absolute click point.
534 6 my ($x, $y) = _calculate_clickpoint($last_matched_needle, $relevant_area, $relative_click_point);
535 6 bmwqemu::diag("clicking at $x/$y");
536   mouse_set($x, $y);
537 6 if ($args{dclick}) {
538   mouse_dclick($args{button}, $args{clicktime});
539 6 }
540   else {
541   mouse_click($args{button}, $args{clicktime});
542 6 }
543    
544 6 # move mouse back to where it was before we clicked, or to the 'hidden' position if it had never been
  6  
545 9 # positioned
546 4 # note: We can not move the mouse instantly. Otherwise we might end up in a click-and-drag situation.
547 4 sleep 1;
548   if ($old_mouse_coords->{x} > -1 && $old_mouse_coords->{y} > -1 && !$args{mousehide}) {
549   return mouse_set($old_mouse_coords->{x}, $old_mouse_coords->{y});
550   }
551 6 else {
552 6 return mouse_hide();
553 6 }
554 6 }
555 1  
556   =head2 assert_and_dclick
557    
558 5 assert_and_dclick($mustmatch [, timeout => $timeout] [, button => $button] [, clicktime => $clicktime ] [, dclick => 1 ] [, mousehide => 1 ]);
559    
560   Alias for C<assert_and_click> with C<$dclick> set.
561    
562   =cut
563    
564 6 my ($mustmatch, %args) = @_;
565 6 $args{dclick} = 1;
566 4 return assert_and_click($mustmatch, %args);
567   }
568    
569 2 =head2 wait_screen_change
570    
571   wait_screen_change(CODEREF [,$timeout [, similarity_level => 50]]);
572    
573   Wrapper around code that is supposed to change the screen. This is the
574   opposite to C<wait_still_screen>. Make sure to put the commands to change the
575   screen within the block to avoid races between the action and the screen
576   change. C<wait_screen_change> waits for a screen change after C<CODEREF> was
577   executed.
578    
579   Example:
580    
581   wait_screen_change {
582 1 send_key 'esc';
583 1 };
584 1  
585   Notice: If you use the second parameter, you could get the following warning
586    
587   Useless use of private variable in void context
588    
589   To avoid it, use parentheses for the function call and the reserved word 'sub' for the callback
590   subroutine block.
591    
592   wait_screen_change(sub {
593   send_key 'esc';
594   }, 15);
595    
596   Returns true if screen changed or false on timeout. Default timeout is 10s. Default
597   similarity_level is 50.
598    
599   =cut
600    
601   my ($callback, $timeout, %args) = @_;
602   $timeout ||= 10;
603   $args{similarity_level} //= 50;
604    
605   bmwqemu::log_call(timeout => $timeout, %args);
606   $timeout = bmwqemu::scale_timeout($timeout);
607    
608   # get the initial screen
609   query_isotovideo('backend_set_reference_screenshot');
610   $callback->() if $callback;
611    
612   my $starttime = time;
613    
614   while (time - $starttime < $timeout) {
615   my $sim = query_isotovideo('backend_similiarity_to_reference')->{sim};
616   bmwqemu::diag("waiting for screen change: " . (time - $starttime) . " $sim");
617   if ($sim < $args{similarity_level}) {
618   bmwqemu::fctres("screen change seen at " . (time - $starttime));
619   return 1;
620 2 }
621 2 sleep(0.5);
622 2 }
623   save_screenshot;
624 2 bmwqemu::fctres("timed out");
625 2 return 0;
626   }
627    
628 2 =head2 assert_screen_change
629 2  
630   assert_screen_change(CODEREF [,$timeout]);
631 2  
632   Run C<CODEREF> with C<wait_screen_change> but C<die> if screen did not change
633 2 within timeout. Look into C<wait_screen_change> for details.
634 3  
635 3 Example:
636 3  
637 1 assert_screen_change { send_key 'alt-f4' };
638 1  
639   =cut
640 2  
641   # Need to parse code reference and pass to the method explicitly as
642 1 # wait_screen_change uses prototype which expects code block as an argument
643 1 # This resolves compile time issues
644 1 my ($coderef, @args) = @_;
645   wait_screen_change(\&{$coderef}, @_) or die 'assert_screen_change failed to detect a screen change';
646   }
647    
648    
649   =head2 wait_still_screen
650    
651   =for stopwords stilltime
652    
653   wait_still_screen([$stilltime | [stilltime => $stilltime]] [, $timeout] | [timeout => $timeout]] [, similarity_level => $similarity_level] [, no_wait => $no_wait]);
654    
655   Wait until the screen stops changing.
656    
657   See C<assert_screen> for C<$no_wait>.
658    
659   Returns true if screen is not changed for given C<$stilltime> (in seconds) or undef on timeout.
660   Default timeout is 30s, default stilltime is 7s.
661    
662   =cut
663    
664 0 my $stilltime = looks_like_number($_[0]) ? shift : 7;
665 0 my $timeout = (@_ % 2) ? shift : $bmwqemu::default_timeout;
  0  
666   my %args = (stilltime => $stilltime, timeout => $timeout, @_);
667   $args{similarity_level} //= 47;
668   bmwqemu::log_call(%args);
669   $timeout = bmwqemu::scale_timeout($args{timeout});
670   $stilltime = $args{stilltime};
671   if ($timeout < $stilltime) {
672   bmwqemu::fctwarn("Selected timeout \'$timeout\' below stilltime \'$stilltime\', returning with false");
673   return 0;
674   }
675    
676   my $starttime = time;
677   my $lastchangetime = [gettimeofday];
678   query_isotovideo('backend_set_reference_screenshot');
679    
680   my $sim = 0;
681   while (time - $starttime < $timeout) {
682   $sim = query_isotovideo('backend_similiarity_to_reference')->{sim};
683   my $now = [gettimeofday];
684   if ($sim < $args{similarity_level}) {
685 7  
686 7 # a change
687 7 $lastchangetime = $now;
688 7 query_isotovideo('backend_set_reference_screenshot');
689 7 }
690 7 if (($now->[0] - $lastchangetime->[0]) + ($now->[1] - $lastchangetime->[1]) / 1000000. >= $stilltime) {
691 7 bmwqemu::fctres("detected same image for $stilltime seconds, last detected similarity is $sim");
692 7 return 1;
693 1 }
694 1 # with 'no_wait' actually wait a little bit not to waste too much CPU
695   # corresponding to what check_screen/assert_screen also does
696   # internally
697 6 sleep($args{no_wait} ? 0.01 : 0.5);
698 6 }
699 6 $autotest::current_test->timeout_screenshot();
700   bmwqemu::fctres("wait_still_screen timed out after $timeout, last detected similarity is $sim");
701 6 return 0;
702 6 }
703 432  
704 432 =head2 assert_still_screen
705 432  
706   assert_still_screen([$args...])
707    
708 0 Run C<wait_still_screen> but C<die> if screen changed within timeout. Look
709 0 into C<wait_still_screen> for details.
710    
711 432 =cut
712 6  
713 6 wait_still_screen(@_) or die 'assert_still_screen failed to detect a still screen';
714   }
715    
716   =head1 test variable access
717    
718 426 =head2 get_var
719    
720 0 get_var($variable [, $default ])
721 0  
722 0 Returns content of test variable C<$variable> or the C<$default> given as second argument or C<undef>
723    
724   =cut
725    
726   my ($var, $default) = @_;
727   return $bmwqemu::vars{$var} // $default;
728   }
729    
730   =head2 get_required_var
731    
732   get_required_var($variable)
733    
734   Similar to C<get_var> but without default value and throws exception if variable can not be retrieved.
735 2  
736   =cut
737    
738   my ($var) = @_;
739   return $bmwqemu::vars{$var} // croak "Could not retrieve required variable $var";
740   }
741    
742   =head2 set_var
743    
744   set_var($variable, $value [, reload_needles => 1] );
745    
746   Set test variable C<$variable> to value C<$value>.
747    
748   Variables starting with C<_SECRET_> or including C<_PASSWORD> will not appear
749 179 in the C<vars.json> file.
750 179  
751   Specify a true value for the C<reload_needles> flag to trigger a reloading
752   of needles in the backend and call the cleanup handler with the new variables
753   to make sure that possibly deselected needles are now taken into account
754   (useful if you change scenarios during the test run)
755    
756   =cut
757    
758   my ($var, $val, %args) = @_;
759   $bmwqemu::vars{$var} = $val;
760   if ($args{reload_needles}) {
761   bmwqemu::save_vars();
762 3 query_isotovideo('backend_reload_needles', {});
763 3 }
764   return;
765   }
766    
767    
768   =head2 check_var
769    
770   check_var($variable, $value);
771    
772   Returns true if test variable C<$variable> is equal to C<$value> or returns C<undef>.
773    
774   =cut
775    
776   my ($var, $val) = @_;
777   return 1 if (defined $bmwqemu::vars{$var} && $bmwqemu::vars{$var} eq $val);
778   return 0;
779   }
780    
781   =head2 get_var_array
782    
783 33 get_var_array($variable [, $default ]);
784 33  
785 33 Return the given variable as array reference (split variable value by , | or ; )
786 0  
787 0 =cut
788    
789 33 my ($var, $default) = @_;
790   my @vars = split(/,|;/, $bmwqemu::vars{$var} || '');
791   my @default = split(/,|;/, $default || '');
792   return \@default if !@vars;
793   return \@vars;
794   }
795    
796   =head2 check_var_array
797    
798   check_var_array($variable, $value);
799    
800   Boolean function to check if a value list contains a value
801    
802 34 =cut
803 34  
804 22 my ($var, $val) = @_;
805   my $vars_r = get_var_array($var);
806   return grep { $_ eq $val } @$vars_r;
807   }
808    
809   =head1 script execution helpers
810    
811   =for stopwords os-autoinst autoinst isotovideo VNC
812    
813   =head2 is_serial_terminal
814    
815   is_serial_terminal;
816 0  
817 0 Determines if communication with the guest is being performed purely over a
818 0 serial port. When true, the guest should have a tty attached to a serial port
819 0 and os-autoinst sends commands to it as text. This differs from when a text
820 0 console is selected in the guest, but VNC is being used to simulate key presses.
821    
822   When a serial terminal is selected you will not be able to use functions which
823   rely on needles. This sub is not exported by default as most tests I<will not
824   benefit> from changing their behaviour depending on if communication happens
825   over serial or VNC.
826    
827   For more info see consoles/virtio_console.pm and consoles/serial_screen.pm.
828    
829   =cut
830    
831   state $ret;
832 0 state $last_seen = '';
833 0 if (defined current_console() && current_console() ne $last_seen) {
834 0 $last_seen = current_console();
  0  
835   $ret = query_isotovideo('backend_is_serial_terminal', {});
836   }
837   return $ret->{yesorno};
838   }
839    
840    
841   =head2 wait_serial
842    
843   wait_serial($regex or ARRAYREF of $regexes, [, timeout => $timeout] [, expect_not_found => $expect_not_found] [, %args]);
844    
845   Deprecated mode
846    
847   wait_serial($regex or ARRAYREF of $regexes [, $timeout [, $expect_not_found [, @args ]]]);
848    
849   Wait for C<$regex> or anyone of C<$regexes> to appear on serial output.
850    
851   Setting C<$no_regex> will cause it to do a plain string search.
852    
853   Set C<$quiet>, to avoid recording serial_result.
854    
855   For serial_terminal there are more options available, like C<record_output>,
856   C<buffer_size>. See C<consoles::serial_screen::read_until> for details.
857    
858   Returns the string matched or C<undef> if C<$expect_not_found> is false
859   (default).
860 119  
861 119 Returns C<undef> or (after timeout) the string that I<did _not_ match> if
862 119 C<$expect_not_found> is true. The default timeout is 90 seconds.
863 1  
864 1 =cut
865    
866 119 my $regexp = shift;
867   my %args = compat_args(
868   {
869   regexp => $regexp,
870   timeout => 90,
871   expect_not_found => 0,
872   quiet => undef,
873   no_regex => 0,
874   buffer_size => undef,
875   record_output => undef,
876   }, ['timeout', 'expect_not_found'], @_);
877    
878   bmwqemu::log_call(%args);
879   $args{timeout} = bmwqemu::scale_timeout($args{timeout});
880    
881   my $ret = query_isotovideo('backend_wait_serial', \%args);
882   my $matched = $ret->{matched};
883    
884   if ($args{expect_not_found}) {
885   $matched = !$matched;
886   }
887   bmwqemu::wait_for_one_more_screenshot() unless is_serial_terminal;
888    
889   # to string, we need to feed string of result to
890   # record_serialresult()
891   $matched = $matched ? 'ok' : 'fail';
892   # convert dos2unix (poo#20542)
893   # hyperv and vmware (backend/svirt.pm) connect serial line over TCP/IP (socat)
894   # convert CRLF to LF only
895   $ret->{string} =~ s,\r\n,\n,g;
896 15 $autotest::current_test->record_serialresult(bmwqemu::pp($regexp), $matched, $ret->{string}) unless ($args{quiet});
897 15 bmwqemu::fctres("$regexp: $matched");
898   return $ret->{string} if ($matched eq "ok");
899   return; # false
900   }
901    
902   =head2 x11_start_program
903    
904   x11_start_program($program[, @args]);
905    
906   Start C<$program> in graphical desktop environment.
907    
908 15 I<The implementation is distribution specific and not always available.>
909 15  
910   =cut
911 15  
912 15 my ($program, @args) = @_;
913   bmwqemu::log_call(program => $program, @args);
914 15 return $distri->x11_start_program($program, @args);
915 0 }
916    
917 15 my ($ret, $cmd, %args) = @_;
918   croak "command '$cmd' timed out" unless (defined $ret);
919   my $die_msg = "command '$cmd' failed";
920   $die_msg .= ": $args{fail_message}" if $args{fail_message};
921 15 croak $die_msg unless ($ret == 0);
922   }
923    
924   =head2 assert_script_run
925 15  
926 15 assert_script_run($cmd [, timeout => $timeout] [, fail_message => $fail_message] [,quiet => $quiet]);
927 15  
928 15 Deprecated mode
929 2  
930   assert_script_run($cmd [, $timeout [, $fail_message]]);
931    
932   Run C<$cmd> via C<< $distri->script_run >> and C<die> unless it returns zero
933   (indicating successful completion of C<$cmd>). Default timeout is 90 seconds.
934   Use C<script_run> instead if C<$cmd> may fail.
935    
936   C<$fail_message> is returned in the die message if specified.
937    
938   I<The C<script_run> implementation is distribution specific and not always available.
939   For this to work correctly, it must return 0 if and only if C<$command> completes
940   successfully. It must NOT return 0 if C<$command> times out. The default implementation
941   should work on *nix operating systems with a configured serial device.>
942    
943 0 =cut
944 0  
945 0 my $cmd = shift;
946   my %args = compat_args(
947   {
948   # assert_script_run originally had the implicit default timeout of
949 8 # wait_serial which we are repeating here to preserve old behaviour and
950 8 # not change default timeout.
951 6 timeout => 90,
952 6 fail_message => '',
953 6 quiet => testapi::get_var('_QUIET_SCRIPT_CALLS')
954   }, ['timeout', 'fail_message'], @_);
955    
956   bmwqemu::log_call(cmd => $cmd, %args);
957   my $ret = $distri->script_run($cmd, timeout => $args{timeout}, quiet => $args{quiet});
958   _handle_script_run_ret($ret, $cmd, %args);
959   return;
960   }
961    
962   =head2 script_run
963    
964   script_run($cmd [, timeout => $timeout] [, output => ''] [, quiet => $quiet] [, die_on_timeout => -1]);
965    
966   Deprecated mode
967    
968   script_run($cmd [, $timeout]);
969    
970   Run C<$cmd> (in the default implementation, by assuming the console prompt and typing
971   the command). If C<$timeout> is greater than 0, wait for that length of time for
972   execution to complete.
973    
974   C<$output> can be used as an explanatory text that will be displayed with the execution of
975   the command.
976    
977   With C<die_on_timeout> -1 (default) a warning will be printed to log. To avoid
978 8 this warning, set it explicit to 0. With C<die_on_timeout> equal to 1, this command
979 8 throw an exception, if timeout expires.
980    
981   <Returns> exit code received from I<$cmd> or undef if C<$timeout> is 0 or timeout
982   expired and C<die_on_timeout> is not C<1>.
983    
984   I<The implementation is distribution specific and not always available.>
985    
986   The default implementation should work on *nix operating systems with a configured
987   serial device so long as the user has permissions to write to the supplied serial
988   device C<$serialdev>.
989 8  
990 8 =cut
991 8  
992 3 my $cmd = shift;
993   my %args = compat_args(
994   {
995   timeout => $bmwqemu::default_timeout,
996   output => '',
997   quiet => testapi::get_var('_QUIET_SCRIPT_CALLS'),
998   die_on_timeout => $distri->{script_run_die_on_timeout},
999   }, ['timeout'], @_);
1000    
1001   bmwqemu::log_call(cmd => $cmd, %args);
1002   my $die_on_timeout = delete $args{die_on_timeout};
1003   my $ret = $distri->script_run($cmd, %args);
1004   if ($args{timeout} > 0) {
1005   if ($die_on_timeout > 0) {
1006   croak("command '$cmd' timed out") if !defined($ret);
1007   } else {
1008   # This is to warn users of script_run(), if they do not use
1009   # die_on_timeout => 0 explicit.
1010   if ($die_on_timeout < 0) {
1011   my ($package, $filename, $line) = caller;
1012   my $casedir = testapi::get_var(CASEDIR => '');
1013   $filename =~ s%^\Q$casedir\E/%%;
1014   bmwqemu::fctwarn("DEPRECATED call of script_run() in $filename:$line " .
1015   'add `die_on_timeout => ?` to the call or set
1016   $distri->{script_run_die_on_timeout} to avoid this
1017   warning');
1018   }
1019   }
1020   }
1021   return $ret;
1022   }
1023    
1024   =head2 background_script_run
1025    
1026 12 background_script_run($cmd [, output => ''] [, quiet => $quiet]);
1027    
1028   Run C<$cmd> in background without waiting for it to finish. Remember to redirect output,
1029   otherwise the PID marker may get corrupted.
1030    
1031   C<$output> can be used as an explanatory text that will be displayed with the execution of
1032   the command.
1033 12  
1034   <Returns> PID of the I<$cmd> process running in the background.
1035 12  
1036 12 I<The implementation is distribution specific and not always available.>
1037 12  
1038 12 The default implementation should work on *nix operating systems with a configured
1039 11 serial device so long as the user has permissions to write to the supplied serial
1040 9 device C<$serialdev>.
1041    
1042   =cut
1043    
1044 2 my ($cmd, %args) = @_;
1045 1  
1046 1 bmwqemu::log_call(cmd => $cmd, %args);
1047 1 return $distri->background_script_run($cmd, %args);
1048 1 }
1049    
1050   =head2 assert_script_sudo
1051    
1052   assert_script_sudo($command [, $wait]);
1053    
1054   Run C<$command> via C<script_sudo> and then check by C<wait_serial> if its exit
1055 10 status is not zero.
1056   See C<wait_serial> for default timeout.
1057    
1058   I<The implementation is distribution specific and not always available.>
1059    
1060   Make sure the non-root user has permissions to write to the supplied serial device
1061   C<$serialdev>.
1062    
1063   =cut
1064    
1065   my ($cmd, $wait) = @_;
1066   my $str = hashed_string("ASS$cmd");
1067   script_sudo("$cmd; echo $str-\$?- > /dev/$serialdev", 0);
1068   my $ret = wait_serial("$str-\\d+-", $wait);
1069   $ret = ($ret =~ /$str-(\d+)-/)[0] if $ret;
1070   _handle_script_run_ret($ret, $cmd);
1071   return;
1072   }
1073    
1074    
1075   =head2 script_sudo
1076    
1077   script_sudo($program [, $wait]);
1078    
1079 2 Run C<$program> using sudo. Handle the sudo timeout and send password when appropriate.
1080   C<$wait> defaults to 2 seconds.
1081 2  
1082 2 I<The implementation is distribution specific and not always available.>
1083    
1084   =cut
1085    
1086   my $name = shift;
1087   my $wait = shift // 2;
1088    
1089   bmwqemu::log_call(name => $name, wait => $wait);
1090   return $distri->script_sudo($name, $wait);
1091   }
1092    
1093   =for stopwords SUT
1094    
1095   =head2 script_output
1096    
1097   script_output($script [, $wait, type_command => 1, proceed_on_failure => 1] [,quiet => $quiet])
1098    
1099   Executing script inside SUT with C<bash -eox> (in case of serial console with C<bash -eo>)
1100   and directs C<stdout> (I<not> C<stderr>!) to the serial console and returns
1101 0 the output I<if> the script exits with 0. Otherwise the test is set to failed.
1102 0 NOTE: execution result may include extra serial output which was on serial console
1103 0 since command was triggered in case serial console is not dedicated for
1104 0 the script output only.
1105 0  
1106 0 The script content is based on the variable content of C<current_test_script>
1107 0 and is typed or fetched through HTTP depending on various parameters. Typing
1108   can be forced by passing C<type_command => 1> for example when the SUT does
1109   not provide a usable network connection.
1110    
1111   C<proceed_on_failure> - allows to proceed with validation when C<$script> is
1112   failing (return non-zero exit code)
1113    
1114   The default timeout for the script is based on the default in C<wait_serial>
1115   and can be tweaked by setting the C<$wait> positional parameter.
1116    
1117   =cut
1118    
1119   my $script = shift;
1120   my %args = testapi::compat_args(
1121   {
1122   timeout => undef,
1123 0 proceed_on_failure => undef, # fail on error by default
1124 0 quiet => testapi::get_var('_QUIET_SCRIPT_CALLS'),
1125   type_command => undef,
1126 0 }, ['timeout'], @_);
1127 0  
1128   return $distri->script_output($script, %args);
1129   }
1130    
1131    
1132   =head2 save_tmp_file
1133    
1134   save_tmp_file($relpath, $content)
1135    
1136   Saves content to the file in the worker pool directory using hash of the path,
1137   including file, so it can be fetched via http later on using
1138   C< <autoinst_url>/files/#path_to_the_file> > url.
1139   Can be used to modify files for specific test needs, e.g. autoinst profiles.
1140   Dies if cannot open file for writing.
1141    
1142   Returns filename of saved file (filename hashed).
1143    
1144   Example:
1145   save_tmp_file('autoyast/autoinst.xml', '<profile>Test</profile>')
1146   Then the file can be fetched using url:
1147   C< <autoinst_url>/files/autoyast/autoinst.xml> >
1148    
1149   =cut
1150    
1151   my ($relpath, $content) = @_;
1152   my $path = hashed_string($relpath);
1153    
1154   bmwqemu::log_call(path => $relpath);
1155   open my $fh, ">", $path;
1156   print $fh $content;
1157 26 close $fh;
1158 26  
1159   return $path;
1160   }
1161    
1162   =head2 get_test_data
1163    
1164   get_test_data($relpath)
1165    
1166 26 Returns content of the file located in data directory. This method can be used
1167   if one needs to modify files content before accessing it in SUT.
1168    
1169   Example:
1170   get_test_data('autoyast/autoinst.xml')
1171   This will return content of the file located in data/autoyast/autoinst.xml
1172    
1173   =cut
1174    
1175   my ($path) = @_;
1176   $path = get_var('CASEDIR') . '/data/' . $path;
1177   bmwqemu::log_call(path => $path);
1178   unless (-e $path) {
1179   bmwqemu::diag("File doesn't exist: $path");
1180   return;
1181   }
1182   open my $fh, "<", $path;
1183   my $content = do { local $/; <$fh> };
1184   close $fh;
1185   return $content;
1186   }
1187    
1188   =head2 validate_script_output
1189    
1190 1 validate_script_output($script, $code | $regexp [, timeout => $timeout] [,quiet => $quiet])
1191 1  
1192   Deprecated mode
1193 1  
1194 1 validate_script_output($script, $code, [$wait])
1195 1  
1196 1 Wrapper around script_output, that runs a callback on the output, or
1197   alternatively matches a regular expression. Use it as
1198 1  
1199   validate_script_output "cat /etc/hosts", sub { m/127.*localhost/ };
1200   validate_script_output "cat /etc/hosts", qr/127.*localhost/;
1201   validate_script_output "cat /etc/hosts", sub { $_ !~ m/987.*somehost/ };
1202    
1203   =cut
1204    
1205   my ($script, $check, @args) = @_;
1206    
1207   my $output = script_output($script, @args);
1208   my $res = 'ok';
1209    
1210   my $message = '';
1211   if (reftype $check eq 'CODE') {
1212   # set $_ so the callbacks can be simpler code
1213   $_ = $output;
1214   if (!$check->()) {
1215 0 $res = 'fail';
1216 0 bmwqemu::diag("output does not pass the code block:\n$output");
1217 0 }
1218 0 my $deparse = B::Deparse->new("-p");
1219 0 # avoid "use strict; use warnings" in the output to make it shorter
1220 0 $deparse->ambient_pragmas(warnings => [], strict => "all");
1221    
1222 0 my $body = $deparse->coderef2text($check);
1223 0  
  0  
  0  
1224 0 $message = sprintf
1225 0 "validate_script_output got:\n%s\n\nCheck function (deparsed code):\n%s",
1226   $output, $body;
1227   }
1228   elsif (reftype $check eq 'REGEXP') {
1229   if ($output !~ $check) {
1230   $res = 'fail';
1231   bmwqemu::diag("output does not match the regex:\n$output");
1232   }
1233   $message = sprintf
1234   "validate_script_output got:\n%s\n\nRegular expression:\n%s",
1235   $output, $check;
1236   }
1237   else {
1238   croak "Invalid use of validate_script_output(), second arg must be a coderef or regexp";
1239   }
1240   $autotest::current_test->record_resultfile(
1241   'validate_script_output', $message,
1242   result => $res,
1243   );
1244   if ($res eq 'fail') {
1245   croak "output not validating";
1246 12 }
1247   return 0;
1248 12 }
1249 12  
1250   =head2 become_root
1251 12  
1252 12 become_root;
1253    
1254 5 Open a root shell.
1255 5  
1256 1 I<The implementation is distribution specific and not always available.>
1257 1  
1258   =cut
1259 5  
1260   return $distri->become_root;
1261 5 }
1262    
1263 5 =head2 ensure_installed
1264    
1265 5 ensure_installed $package;
1266    
1267   Helper to install a package to SUT.
1268    
1269   I<The implementation is distribution specific and not always available.>
1270 6  
1271 0 =cut
1272 0  
1273   return $distri->ensure_installed(@_);
1274 6 }
1275    
1276   =head2 hashed_string
1277    
1278   hashed_string();
1279 1  
1280   Return a short string representing the given string by passing it through the
1281 11 MD5 algorithm and taking the first characters.
1282    
1283   =cut
1284    
1285 11 my ($string, $count) = @_;
1286 1 $count //= 5;
1287    
1288 10 my $hash = md5_base64($string);
1289   # + and / are problematic in regexps and shell commands
1290   $hash =~ s,\+,_,g;
1291   $hash =~ s,/,~,g;
1292   return substr($hash, 0, $count);
1293   }
1294    
1295   =head1 keyboard support
1296    
1297   =head2 send_key
1298    
1299   send_key($key [, wait_screen_change => $wait_screen_change]);
1300    
1301   Send one C<$key> to SUT keyboard input. Waits for the screen to change when
1302 0 C<$wait_screen_change> is true.
1303    
1304   Special characters naming:
1305    
1306   'esc', 'down', 'right', 'up', 'left', 'equal', 'spc', 'minus', 'shift', 'ctrl'
1307   'caps', 'meta', 'alt', 'ret', 'tab', 'backspace', 'end', 'delete', 'home', 'insert'
1308   'pgup', 'pgdn', 'sysrq', 'super'
1309    
1310   =cut
1311    
1312   my $key = shift;
1313   my %args = (@_ == 1) ? (do_wait => +shift()) : @_;
1314   $args{do_wait} //= 0;
1315   $args{wait_screen_change} //= 0;
1316 0 bmwqemu::log_call(key => $key, %args);
1317   if ($args{wait_screen_change}) {
1318   wait_screen_change { query_isotovideo('backend_send_key', {key => $key}) };
1319   }
1320   else {
1321   query_isotovideo('backend_send_key', {key => $key});
1322   }
1323   }
1324    
1325   =head2 hold_key
1326    
1327   hold_key($key);
1328    
1329 21 Hold one C<$key> until release it
1330 21  
1331   =cut
1332 21  
1333   my ($key) = @_;
1334 21 bmwqemu::log_call('hold_key', key => $key);
1335 21 query_isotovideo('backend_hold_key', {key => $key});
1336 21 }
1337    
1338   =head2 release_key
1339    
1340   release_key($key);
1341    
1342   Release one C<$key> which is kept holding
1343    
1344   =cut
1345    
1346   my $key = shift;
1347   bmwqemu::log_call('release_key', key => $key);
1348   query_isotovideo('backend_release_key', {key => $key});
1349   }
1350    
1351   =head2 send_key_until_needlematch
1352    
1353   send_key_until_needlematch($tag, $key [, $counter, $timeout]);
1354    
1355   Send specific key until needle with C<$tag> is not matched or C<$counter> is 0.
1356   C<$tag> can be string or C<ARRAYREF> (C<['tag1', 'tag2']>)
1357 5 Default counter is 20 steps, default timeout is 1s
1358 5  
1359 5 Throws C<FailedNeedle> exception if needle is not matched until C<$counter> is 0.
1360 5  
1361 5 =cut
1362 5  
1363 1 my ($tag, $key, $counter, $timeout) = @_;
  1  
1364    
1365   $counter //= 20;
1366 4 $timeout //= 1;
1367   while (!check_screen($tag, $timeout)) {
1368   wait_screen_change {
1369   send_key $key;
1370   };
1371   if (!$counter--) {
1372   assert_screen $tag, 1;
1373   }
1374   }
1375   }
1376    
1377   =head2 type_string
1378    
1379 0 type_string($string [, max_interval => <num> ] [, wait_screen_changes => <num> ] [, wait_still_screen => <num> ] [, secret => 1 ]
1380 0 [, timeout => <num>] [, similarity_level => <num>] [, lf => 1 ]);
1381 0  
1382   send a string of characters, mapping them to appropriate key names as necessary
1383    
1384   you can pass optional parameters with following keys:
1385    
1386   C<max_interval (1-250)> determines the typing speed, the lower the
1387   C<max_interval> the slower the typing.
1388    
1389   C<wait_screen_change> if set, type only this many characters at a time
1390   C<wait_screen_change> and wait for the screen to change between sets.
1391    
1392   C<wait_still_screen> if set, C<wait_still_screen> returns true if screen is not
1393 0 changed for given C<$wait_still_screen> seconds or false if the screen is not still
1394 0 for the given seconds within defined C<timeout> after the whole string is typed.
1395 0 Default timeout is 30s, default stilltime is 0s.
1396    
1397   C<similarity_level> can be passed as argument for wrapped C<wait_still_screen> calls.
1398    
1399   C<secret (bool)> suppresses logging of the actual string typed.
1400    
1401   C<lf (bool)> finishes the string with an additional line feed, for example to
1402   enter a command line.
1403    
1404   =cut
1405    
1406   # special argument handling for backward compat
1407   my $string = shift;
1408   my %args;
1409   if (@_ == 1) { # backward compat
1410   %args = (max_interval => $_[0]);
1411 0 }
1412   else {
1413 0 %args = @_;
1414 0 }
1415 0 $string .= "\n" if $args{lf};
1416    
1417 0 if (is_serial_terminal) {
1418 0 query_isotovideo('backend_type_string', {text => $string, %args});
1419 0 return;
1420 0 }
1421    
1422   my $max_interval = $args{max_interval} // 250;
1423   my $wait = $args{wait_screen_change} // 0;
1424   my $wait_still = $args{wait_still_screen} // 0;
1425   my $wait_timeout = $args{timeout} // 30;
1426   my $wait_sim_level = $args{similarity_level} // 47;
1427   bmwqemu::log_call(string => $string, max_interval => $max_interval, wait_screen_changes => $wait, wait_still_screen => $wait_still,
1428   timeout => $wait_timeout, similarity_level => $wait_sim_level, $args{secret} ? (-masked => $string) : ());
1429   my @pieces;
1430   if ($wait) {
1431   # split string into an array of pieces of specified size
1432   # https://stackoverflow.com/questions/372370
1433   @pieces = unpack("(a${wait})*", $string);
1434   }
1435   else {
1436   push @pieces, $string;
1437   }
1438   for my $piece (@pieces) {
1439   if ($wait) {
1440   wait_screen_change { query_isotovideo('backend_type_string', {text => $piece, max_interval => $max_interval}); };
1441   }
1442   else {
1443   query_isotovideo('backend_type_string', {text => $piece, max_interval => $max_interval});
1444   }
1445   if ($wait_still && !wait_still_screen(stilltime => $wait_still,
1446   timeout => $wait_timeout, similarity_level => $wait_sim_level)) {
1447   die "wait_still_screen timed out after ${wait_timeout}s!";
1448   }
1449   }
1450   }
1451    
1452   =head2 type_password
1453    
1454   type_password($password [, max_interval => <num> ] [, wait_screen_changes => <num> ] [, wait_still_screen => <num> ] [, timeout => <num>]
1455   [, similarity_level => <num>] );
1456 49  
1457 49 A convenience wrapper around C<type_string>, which doesn't log the string.
1458 49  
1459 1 Uses C<$testapi::password> if no string is given.
1460    
1461   You can pass the same optional parameters as for C<type_string> function.
1462 48  
1463   =cut
1464 49  
1465   my ($string, %args) = @_;
1466 49 $string //= $password;
1467 0 type_string $string, secret => 1, max_interval => ($args{max_interval} // 100), %args;
1468 0 }
1469    
1470   =head2 enter_cmd
1471 49  
1472 49 enter_cmd($string [, max_interval => <num> ] [, wait_screen_changes => <num> ] [, wait_still_screen => <num> ] [, secret => 1 ]
1473 49 [, timeout => <num>] [, similarity_level => <num>] );
1474 49  
1475 49 A convenience wrapper around C<type_string>, that adds a linefeed to execute a
1476   command within a command line prompt.
1477 49  
1478 49 You can pass the same optional parameters as for C<type_string> function.
1479 49  
1480   =cut
1481    
1482 3 type_string shift, lf => 1, @_;
1483   }
1484    
1485 46 =head1 mouse support
1486    
1487 49 =head2 mouse_set
1488 53  
1489 7 mouse_set($x, $y);
  7  
1490    
1491   Move mouse pointer to given coordinates
1492 46  
1493   =cut
1494 53  
1495   my ($mx, $my) = @_;
1496 0  
1497   bmwqemu::log_call(x => $mx, y => $my);
1498   query_isotovideo('backend_mouse_set', {x => $mx, y => $my});
1499   }
1500    
1501   =head2 mouse_click
1502    
1503   mouse_click([$button, $hold_time]);
1504    
1505   Click mouse C<$button>. Can be C<'left'> or C<'right'>. Set C<$hold_time> to hold button for set time in seconds.
1506   Default hold time is 0.15s
1507    
1508   =cut
1509    
1510   my $button = shift || 'left';
1511   my $time = shift || 0.15;
1512   bmwqemu::log_call(button => $button, cursor_down => $time);
1513   query_isotovideo('backend_mouse_button', {button => $button, bstate => 1});
1514   sleep $time;
1515 4 query_isotovideo('backend_mouse_button', {button => $button, bstate => 0});
1516 4 }
1517 4  
1518   =head2 mouse_dclick
1519    
1520   mouse_dclick([$button, $hold_time]);
1521    
1522   Same as mouse_click only for double click.
1523    
1524   =cut
1525    
1526   my $button = shift || 'left';
1527   my $time = shift || 0.10;
1528   bmwqemu::log_call(button => $button, cursor_down => $time);
1529   query_isotovideo('backend_mouse_button', {button => $button, bstate => 1});
1530   sleep $time;
1531   query_isotovideo('backend_mouse_button', {button => $button, bstate => 0});
1532   sleep $time;
1533 1 query_isotovideo('backend_mouse_button', {button => $button, bstate => 1});
1534   sleep $time;
1535   query_isotovideo('backend_mouse_button', {button => $button, bstate => 0});
1536   }
1537    
1538   =head2 mouse_tclick
1539    
1540   mouse_tclick([$button, $hold_time]);
1541    
1542   Same as mouse_click only for triple click.
1543    
1544   =cut
1545    
1546   my $button = shift || 'left';
1547 18 my $time = shift || 0.10;
1548   bmwqemu::log_call(button => $button, cursor_down => $time);
1549 18 query_isotovideo('backend_mouse_button', {button => $button, bstate => 1});
1550 18 sleep $time;
1551   query_isotovideo('backend_mouse_button', {button => $button, bstate => 0});
1552   sleep $time;
1553   query_isotovideo('backend_mouse_button', {button => $button, bstate => 1});
1554   sleep $time;
1555   query_isotovideo('backend_mouse_button', {button => $button, bstate => 0});
1556   sleep $time;
1557   query_isotovideo('backend_mouse_button', {button => $button, bstate => 1});
1558   sleep $time;
1559   query_isotovideo('backend_mouse_button', {button => $button, bstate => 0});
1560   }
1561    
1562   =head2 mouse_hide
1563 5  
1564 5 mouse_hide([$border_offset]);
1565 5  
1566 5 Hide mouse cursor by moving it out of screen area.
1567 5  
1568 5 =cut
1569    
1570   my $border_offset = shift || 0;
1571   bmwqemu::log_call(border_offset => $border_offset);
1572   query_isotovideo('backend_mouse_hide', {border_offset => $border_offset});
1573   }
1574    
1575   =head2 mouse_drag
1576   mouse_drag([$startpoint, $endpoint, $startx, $starty, $endx, $endy, $button, $timeout]);
1577    
1578   Click mouse C<$button>, C<'left'> or C<'right'>, at a given location, hold the button and drag
1579   the mouse to another location where the button is released. You can set the C<$startpoint>
1580 1 and C<$endpoint> by passing the name of the needle tag, i.e. the mouse drag happens between
1581 1 the two needle areas. Alternatively, you can set all the coordinates explicitly with C<$startx>,
1582 1 C<$starty>, C<$endx>, and C<$endy>. You can also set one point using a needle and another one
1583 1 using coordinates. If both the coordinates and the needle are provided, the coordinates
1584 1 will be used to set up the locations and the needle location will be overridden.
1585 1  
1586 1 =cut
1587 1  
1588 1 my %args = @_;
1589 1 my ($startx, $starty, $endx, $endy);
1590   # If full coordinates are provided, work with them as a priority,
1591   if (defined $args{startx} and defined $args{starty}) {
1592   $startx = $args{startx};
1593   $starty = $args{starty};
1594   }
1595   # If the coordinates were not complete, use the needle as a fallback solution.
1596   elsif (defined $args{startpoint}) {
1597   my $startmatch = $args{startpoint};
1598   # Check that the needle exists.
1599   my $start_matched_needle = assert_screen($startmatch, $args{timeout});
1600   # Calculate the click point from the area defined by the needle (take the center of it)
1601 0 ($startx, $starty) = _calculate_clickpoint($start_matched_needle);
1602 0 }
1603 0 # If neither coordinates nor a needle is provided, report an error and quit.
1604 0 else {
1605 0 die "The starting point of the drag was not correctly provided. Either provide the 'startx' and 'starty' coordinates, or a needle marking the starting point.";
1606 0 }
1607 0  
1608 0 # Repeat the same for endpoint coordinates or needles.
1609 0 if (defined $args{endx} and defined $args{endy}) {
1610 0 $endx = $args{endx};
1611 0 $endy = $args{endy};
1612 0 }
1613 0 elsif (defined $args{endpoint}) {
1614 0 my $endmatch = $args{endpoint};
1615   my $end_matched_needle = assert_screen($endmatch, $args{timeout});
1616   ($endx, $endy) = _calculate_clickpoint($end_matched_needle);
1617   }
1618   else {
1619   die "The ending point of the drag was not correctly provided. Either provide the 'endx' and 'endy' coordinates, or a needle marking the end point.";
1620   }
1621   # Get the button variable. If no button has been provided, assume the "left" button.
1622   my $button = $args{button} // "left";
1623    
1624   # Now, perform the actual mouse drag. Navigate to the startpoint location,
1625   # press and hold the mouse button, then navigate to the endpoint location
1626 2 # and release the mouse button.
1627 2 mouse_set($startx, $starty);
1628 2 query_isotovideo('backend_mouse_button', {button => $button, bstate => 1});
1629   mouse_set($endx, $endy);
1630   query_isotovideo('backend_mouse_button', {button => $button, bstate => 0});
1631   bmwqemu::log_call(message => "Mouse dragged from $startx,$starty to $endx, $endy", button => $button);
1632   }
1633    
1634   =head1 multi console support
1635    
1636   All C<testapi> commands that interact with the system under test do that
1637   through a console. C<send_key>, C<type_string> type into a console.
1638   C<assert_screen> 'looks' at a console, C<assert_and_click> looks at
1639   and clicks on a console.
1640    
1641   Most backends support several consoles in some way. These consoles
1642   then have names as defined by the backend.
1643    
1644   Consoles can be selected for interaction with the system under test.
1645 4 One of them is 'selected' by default, as defined by the backend.
1646 4  
1647   There are no consoles predefined by default, the distribution has
1648 4 to add them during initial setup and define actions on what should
1649 3 happen when they are selected first by the tests.
1650 3  
1651   E.g. your distribution can give e.g. C<tty2> and C<tty4> a name for the
1652   tests to select
1653    
1654 1 $self->add_console('root-console', 'tty-console', {tty => 2});
1655   $self->add_console('user-console', 'tty-console', {tty => 4});
1656 1  
1657   =head2 add_console
1658 1  
1659   add_console("console", "console type" [, optional console parameters...])
1660    
1661   You need to do this in your distribution and not in tests. It will not trigger
1662 0 any action on the system under test, but only store the parameters.
1663    
1664   The console parameters are console specific. Parameter C<persistent> skips
1665   console reset and console is persistent during the test execution.
1666 4  
1667 3 I<The implementation is distribution specific and not always available.>
1668 3  
1669   =cut
1670    
1671 1 require backend::console_proxy;
1672 1 our %testapi_console_proxies;
1673 1  
1674   =head2 select_console
1675    
1676 0 select_console($console [, @args]);
1677    
1678   Example:
1679 4  
1680   select_console("root-console");
1681    
1682   Select the named console for further C<testapi> interaction (send_text,
1683   send_key, wait_screen_change, ...)
1684 4  
1685 4 If this the first time, a test selects this console, the distribution
1686 4 will get a call into activate_console('root-console', $console_obj, @args) to
1687 4 make sure to actually log in root. For the backend it's just a C<tty>
1688 4 object (in this example) - so it will ensure the console is active,
1689   but to setup the root shell on this console, the distribution needs
1690   to run test code.
1691    
1692   After the console selection the distribution callback
1693   C<$distri->console_selected> is called with C<@args>.
1694    
1695   =cut
1696    
1697   my ($testapi_console, @args) = @_;
1698   bmwqemu::log_call(testapi_console => $testapi_console, @args);
1699   if (!exists $testapi_console_proxies{$testapi_console}) {
1700   $testapi_console_proxies{$testapi_console} = backend::console_proxy->new($testapi_console);
1701   }
1702   my $ret = query_isotovideo('backend_select_console', {testapi_console => $testapi_console});
1703   die $ret->{error} if $ret->{error};
1704    
1705   $autotest::selected_console = $testapi_console;
1706   if ($ret->{activated}) {
1707   # we need to store the activated consoles for rollback
1708   if ($autotest::last_milestone) {
1709   push(@{$autotest::last_milestone->{activated_consoles}}, $testapi_console);
1710   }
1711   $testapi::distri->activate_console($testapi_console, @args);
1712   }
1713   $testapi::distri->console_selected($testapi_console, @args);
1714    
1715   return $testapi_console_proxies{$testapi_console};
1716   }
1717    
1718   =head2 console
1719    
1720   console("testapi_console")->$console_command(@console_command_args)
1721    
1722   Some consoles have special commands beyond C<type_string>, C<assert_screen>
1723    
1724   Such commands can be accessed using this API.
1725    
1726   C<console("bootloader")>, C<console("errorlog")>, ... returns a proxy
1727   object for the specific console which can then be directly accessed.
1728    
1729   This is also useful for typing/interacting 'in the background',
1730   without turning the video away from the currently selected console.
1731    
1732   Note: C<assert_screen()> and friends look at the currently selected
1733   console (select_console), no matter which console you send commands to
1734   here.
1735    
1736   =cut
1737    
1738   my ($testapi_console) = @_;
1739   $testapi_console ||= current_console();
1740   bmwqemu::log_call(testapi_console => $testapi_console);
1741   if (!exists $testapi_console_proxies{$testapi_console}) {
1742   $testapi_console_proxies{$testapi_console} = backend::console_proxy->new($testapi_console);
1743   }
1744   return $testapi_console_proxies{$testapi_console};
1745   }
1746    
1747   =head2 reset_consoles
1748    
1749   reset_consoles;
1750    
1751   will make sure the next select_console will activate the console. This is important
1752   if you did something to the system that affects the console (e.g. trigger reboot).
1753    
1754   =cut
1755 2  
1756 2 query_isotovideo('backend_reset_consoles');
1757 2 return;
1758 2 }
1759    
1760 2 =head2
1761 2 current_console
1762    
1763 2 Return the currently selected console, a call when no console is selected, will
1764 2 return C<undef>.
1765    
1766 0 =cut
1767 0  
  0  
1768   return $autotest::selected_console;
1769 0 }
1770    
1771 2 =head1 audio support
1772    
1773 2 =for stopwords qemu
1774    
1775   =head2 start_audiocapture
1776    
1777   start_audiocapture;
1778    
1779   Tells the backend to record a C<.wav> file of the sound card.
1780    
1781   I<Only supported by qemu backend.>
1782    
1783   =cut
1784    
1785   my $fn = $autotest::current_test->capture_filename;
1786   my $filename = join('/', bmwqemu::result_dir(), $fn);
1787   bmwqemu::log_call(filename => $filename);
1788   return query_isotovideo('backend_start_audiocapture', {filename => $filename});
1789   }
1790    
1791   my ($mustmatch, $check) = @_;
1792    
1793   my $result = $autotest::current_test->stop_audiocapture();
1794   my $wavfile = join('/', bmwqemu::result_dir(), $result->{audio});
1795   system("snd2png $wavfile $result->{audio}.png");
1796    
1797 40 my $imgpath = "$result->{audio}.png";
1798 40  
1799 40 return $autotest::current_test->verify_sound_image($imgpath, $mustmatch, $check);
1800 40 }
1801 0  
1802   =head2 assert_recorded_sound
1803 40  
1804   assert_recorded_sound('we-will-rock-you');
1805    
1806   Tells the backend to record a C<.wav> file of the sound card and asserts if it matches
1807   expected audio. Comparison is performed after conversion to the image.
1808    
1809   I<Only supported by QEMU backend.>
1810    
1811   =cut
1812    
1813   my ($mustmatch) = @_;
1814   return _check_or_assert_sound $mustmatch;
1815   }
1816 0  
1817 0 =head2 check_recorded_sound
1818    
1819   check_recorded_sound('we-will-rock-you');
1820    
1821   Tells the backend to record a C<.wav> file of the sound card and checks if it matches
1822   expected audio. Comparison is performed after conversion to the image.
1823    
1824   I<Only supported by QEMU backend.>
1825    
1826   =cut
1827    
1828   my ($mustmatch) = @_;
1829 216 return _check_or_assert_sound $mustmatch, 1;
1830   }
1831    
1832   =head1 miscellaneous
1833    
1834   =head2 power
1835    
1836   power($action);
1837    
1838   Trigger backend specific power action, can be C<'on'>, C<'off'>, C<'acpi'> or C<'reset'>
1839    
1840   =cut
1841    
1842    
1843   # params: (on), off, acpi, reset
1844   my ($action) = @_;
1845   bmwqemu::log_call(action => $action);
1846   query_isotovideo('backend_power', {action => $action});
1847 0 }
1848 0  
1849 0 =head2 check_shutdown
1850 0  
1851   check_shutdown([$timeout]);
1852    
1853   Periodically check backend for status until C<'shutdown'>. Does I<not> initiate shutdown.
1854 0  
1855   Returns true on success and false if C<$timeout> timeout is hit. Default timeout is 60s.
1856 0  
1857 0 =cut
1858 0  
1859   my ($timeout) = @_;
1860 0 $timeout //= ONE_MINUTE;
1861   bmwqemu::log_call(timeout => $timeout);
1862 0 $timeout = bmwqemu::scale_timeout($timeout);
1863   while ($timeout >= 0) {
1864   my $is_shutdown = query_isotovideo('backend_is_shutdown') || 0;
1865   if ($is_shutdown < 0) {
1866   bmwqemu::diag("Backend does not implement is_shutdown - just sleeping");
1867   sleep($timeout);
1868   }
1869   # -1 counts too
1870   if ($is_shutdown) {
1871   return 1;
1872   }
1873   sleep 1;
1874   --$timeout;
1875   }
1876   return 0;
1877 0 }
1878 0  
1879   =head2 assert_shutdown
1880    
1881   assert_shutdown([$timeout]);
1882    
1883   Periodically check backend for status until C<'shutdown'>. Does I<not> initiate shutdown.
1884    
1885   Returns C<undef> on success, marks the test as failed and throws exception
1886   if C<$timeout> timeout is hit. Default timeout is 60s.
1887    
1888   =cut
1889    
1890   my ($timeout) = @_;
1891   $timeout //= ONE_MINUTE;
1892   if (check_shutdown($timeout)) {
1893 0 $autotest::current_test->take_screenshot('ok');
1894 0 return;
1895   }
1896   else {
1897   $autotest::current_test->take_screenshot('fail');
1898   croak "Machine didn't shut down!";
1899   }
1900   }
1901    
1902   =head2 eject_cd
1903    
1904   eject_cd;
1905    
1906   if backend supports it, eject the CD
1907    
1908   =cut
1909    
1910 0 my (%nargs) = @_;
1911 0 bmwqemu::log_call(%nargs);
1912 0 query_isotovideo(backend_eject_cd => \%nargs);
1913   }
1914    
1915   =head2 switch_network
1916    
1917   switch_network network_enabled => $boolean, [network_link_name => $string];
1918    
1919   Changes network device's state akin to disconnecting the physical cable,
1920   default network is qanet0.
1921    
1922   This method is fatal in case the network device doesn't exist.
1923    
1924   =cut
1925    
1926 6 my (%nargs) = @_;
1927 6 bmwqemu::log_call(%nargs);
1928 6 query_isotovideo(backend_switch_network => \%nargs);
1929 6 }
1930 6  
1931 126 =head2 save_memory_dump
1932 126  
1933 2 save_memory_dump(filename => undef);
1934 2  
1935   Saves the SUT memory state using C<$filename> as base for the memory dump
1936   filename, the default will be the current test's name.
1937 126  
1938 4 This method must be called within a post_fail_hook.
1939    
1940 122 I<Currently only qemu backend is supported.>
1941 122  
1942   =cut
1943 2  
1944   my %nargs = @_;
1945   $nargs{filename} ||= $autotest::current_test->{name};
1946    
1947   bmwqemu::log_call(%nargs);
1948   bmwqemu::diag("Trying to save machine state");
1949    
1950   query_isotovideo('backend_save_memory_dump', \%nargs);
1951   }
1952    
1953   =head2 save_storage_drives
1954    
1955   save_storage_drives([$filename]);
1956    
1957   Saves all of the SUT drives using C<$filename> as part of the final filename,
1958 3 the default will be the current test's name. The disk number will be always present.
1959 3  
1960 3 This method must be called within a post_fail_hook.
1961 2  
1962 2 I<Currently only qemu backend is supported.>
1963    
1964   =cut
1965 1  
1966 1 my $filename ||= $autotest::current_test->{name};
1967   die "save_storage_drives should be called within a post_fail_hook" unless ((caller(1))[3]) =~ /post_fail_hook/;
1968    
1969   bmwqemu::log_call();
1970   bmwqemu::diag("Trying to save machine drives");
1971   bmwqemu::load_vars();
1972    
1973   # Right now, we're saving all the disks
1974   # sometimes we might not want to. This could be improved.
1975   if (my $nd = $bmwqemu::vars{NUMDISKS}) {
1976   for my $i (1 .. $nd) {
1977   query_isotovideo('backend_save_storage_drives', {disk => $i, filename => $filename});
1978   }
1979 2 }
1980 2 }
1981 2  
1982   =head2 freeze_vm
1983    
1984   freeze_vm;
1985    
1986   If the backend supports it, freeze the virtual machine. This will allow the
1987   virtual machine to be paused/frozen within the test, it is recommended to call
1988   this within a C<post_fail_hook> so that memory and disk dumps can be extracted
1989   without any risk of data changing, or in rare cases call it before the tests
1990   tests have already begun, to avoid unexpected behaviour.
1991    
1992   I<Currently only qemu backend is supported.>
1993    
1994   =cut
1995    
1996 2 # While it might be a good idea to allow the user to stop the vm within a test
1997 2 # we're not encouraging them to do that outside a post_fail_hook or at any point
1998 2 # in the test code.
1999   bmwqemu::diag "Call freeze_vm within a post_fail_hook or very early in your test"
2000   unless ((caller(1))[3]) =~ /post_fail_hook/;
2001   bmwqemu::log_call();
2002   query_isotovideo('backend_freeze_vm');
2003   }
2004    
2005   =head2 resume_vm
2006    
2007   resume_vm;
2008    
2009   If the backend supports it, resume the virtual machine. Call this method to
2010   start virtual machine CPU explicitly if DELAYED_START is set.
2011    
2012   I<Currently only qemu backend is supported.>
2013    
2014   =cut
2015 0  
2016 0 bmwqemu::log_call();
2017   query_isotovideo('backend_cont_vm');
2018 0 }
2019 0  
2020   =head2 parse_junit_log
2021 0  
2022   =for stopwords jUnit
2023    
2024   parse_junit_log("report.xml");
2025    
2026   Upload log file from SUT (calls upload_logs internally). The uploaded
2027   file is then parsed as jUnit format and extra test results are created from it.
2028    
2029   =cut
2030    
2031   # XXX: To keep until tests are adapted
2032    
2033   =head2 parse_extra_log
2034    
2035   =for stopwords extra_log
2036    
2037   parse_extra_log( Format => "report.xml" );
2038 0  
2039 0 Upload log file from SUT (calls upload_logs internally). The uploaded
2040   file is then parsed as the format supplied, that can be understood by OpenQA::Parser
2041 0 and extra test results are created from it.
2042 0  
2043 0 Formats currently supported are: JUnit, XUnit, LTP
2044    
2045   =cut
2046    
2047 0 my ($format, $file) = @_;
2048 0  
2049 0 $file = upload_logs($file);
2050   my @tests;
2051    
2052   {
2053   local $@;
2054   # We need to touch @INC as specific supported format are split
2055   # in different classes and dynamically loaded by OpenQA::Parser
2056   local @INC = ($ENV{OPENQA_LIBPATH} // OPENQA_LIBPATH, @INC);
2057   eval {
2058   require OpenQA::Parser;
2059   OpenQA::Parser->import('parser');
2060   my $parser = parser($format => "ulogs/$file");
2061   $parser->write_output(bmwqemu::result_dir());
2062   $parser->write_test_result(bmwqemu::result_dir());
2063    
2064   $parser->tests->each(
2065   sub {
2066   push(@tests, $_->to_openqa);
2067   });
2068   };
2069   croak $@ if $@;
2070   }
2071    
2072 0 return $autotest::current_test->register_extra_test_results(\@tests);
2073   }
2074 0  
2075 0 =head1 log and data upload and download helpers
2076    
2077   =for stopwords diag
2078    
2079   =head2 diag
2080    
2081   diag('important message');
2082    
2083   Write a diagnostic message to the logfile. In color, if possible.
2084    
2085   =cut
2086    
2087   return bmwqemu::diag(@_);
2088   }
2089    
2090 0 =head2 host_ip
2091 0  
2092   =for stopwords kvm VM
2093    
2094   Return VM's host IP.
2095   In a kvm instance you reach the VM's host under default 10.0.2.2
2096    
2097   =cut
2098    
2099    
2100   =head2 autoinst_url
2101    
2102   autoinst_url([$path, $query]);
2103    
2104   returns the base URL to contact the local C<os-autoinst> service
2105    
2106 0 Optional C<$path> argument is appended after base url.
2107    
2108   Optional HASHREF C<$query> is converted to URL query and appended
2109   after path.
2110    
2111   Returns constructor URL. Can be used inline:
2112    
2113   script_run("curl " . autoinst_url . "/data");
2114    
2115   =cut
2116    
2117   my ($path, $query) = @_;
2118   $path //= '';
2119   $query //= {};
2120   my $hostname = get_var('AUTOINST_URL_HOSTNAME', host_ip());
2121   # QEMUPORT is historical for the base port of the worker instance
2122   my $workerport = get_var("QEMUPORT") + 1;
2123 0  
2124   my $token = get_var('JOBTOKEN');
2125 0 my $querystring = join('&', map { "$_=$query->{$_}" } sort keys %$query);
2126 0 my $url = "http://$hostname:$workerport/$token$path";
2127   $url .= "?$querystring" if $querystring;
2128    
2129 0 return $url;
  0  
2130   }
2131    
2132 0 =head2 data_url
2133 0  
2134 0 data_url($name);
2135 0  
2136 0 returns the URL to download data or asset file
2137 0 Special values REPO_\d and ASSET_\d points to the asset configured
2138 0 in the corresponding variable
2139    
2140   =cut
2141    
2142 0 my ($name) = @_;
2143 0 autoinst_url($name =~ /^REPO_\d$/ ? "/assets/repo/" . get_var($name) :
2144   $name =~ /^ASSET_\d$/ ? "/assets/other/" . get_var($name) : "/data/$name");
2145 0 }
2146    
2147    
2148 0 =head2 upload_logs
2149    
2150   =for stopwords GiB failok OpenQA WebUI
2151    
2152   upload_logs($file [, failok => 0, timeout => 90, log_name => "custom_name.log" ]);
2153    
2154   Upload C<$file> to OpenQA WebUI as a log file and
2155   return the uploaded file name. If failok is not set, a failed upload or
2156   timeout will cause the test to die. Failed uploads happen if the file does not
2157   exist or is over 20 GiB in size, so failok is useful when you just want
2158   to upload the file if it exists but not mind if it doesn't. Default
2159   timeout is 90s. C<log_name> parameter allow to control resulted job's attachment name.
2160    
2161   =cut
2162    
2163   my $file = shift;
2164 9 my %args = @_;
2165   my $failok = $args{failok} || 0;
2166   my $timeout = $args{timeout} || 90;
2167    
2168   if (get_var('OFFLINE_SUT')) {
2169   record_info('upload skipped', "Skipped uploading log file '$file' as we are offline");
2170   return;
2171   }
2172   bmwqemu::log_call(file => $file, failok => $failok, timeout => $timeout, %args);
2173   my $basename = basename($file);
2174   my $upname = $args{log_name} || ($autotest::current_test->{name} . '-' . $basename);
2175   my $cmd = "curl --form upload=\@$file --form upname=$upname ";
2176 8 $cmd .= show_curl_progress_meter();
2177   $cmd .= autoinst_url("/uploadlog/$basename");
2178   if ($failok) {
2179   # just use script_run so we don't care if the upload fails
2180   script_run($cmd, $timeout, die_on_timeout => 1);
2181   }
2182   else {
2183   assert_script_run($cmd, $timeout);
2184   }
2185   return $upname;
2186   }
2187    
2188   =head2 upload_asset
2189    
2190   =for stopwords svirt
2191    
2192   upload_asset $file [,$public[,$nocheck]];
2193    
2194   Uploads C<$file> as asset to OpenQA WebUI
2195    
2196 6 You can upload private assets only accessible by related jobs:
2197 6  
2198 6 upload_asset '/tmp/suse.ps';
2199 6  
2200   Or you can upload public assets that will have a fixed filename
2201 6 replacing previous assets - useful for external users:
2202    
2203 6 upload_asset '/tmp/suse.ps', 1;
2204 6  
  0  
2205 6 If you just want to upload a file and verify that it was uploaded
2206 6 correctly on your own (e.g. in svirt console we don't have a serial
2207   line and can't rely on assert_script_run check), add an optional
2208 6 C<$nocheck> parameter:
2209    
2210   upload_asset '/tmp/suse.ps', 1, 1;
2211    
2212   =cut
2213    
2214   my ($file, $public, $nocheck) = @_;
2215    
2216   if (get_var('OFFLINE_SUT')) {
2217   record_info('upload skipped', "Skipped uploading asset '$file' as we are offline");
2218   return;
2219   }
2220   bmwqemu::log_call(file => $file, public => $public, nocheck => $nocheck);
2221   my $cmd = "curl --form upload=\@$file ";
2222 2 $cmd .= "--form target=assets_public " if $public;
2223 2 $cmd .= show_curl_progress_meter();
2224   my $basename = basename($file);
2225   $cmd .= autoinst_url("/upload_asset/$basename");
2226   if ($nocheck) {
2227   type_string("$cmd\n");
2228   }
2229   else {
2230   return assert_script_run($cmd);
2231   }
2232   }
2233    
2234   =head2 compat_args
2235    
2236   Helper function to create backward compatible function arguments when moving
2237   from positional arguments to named one.
2238    
2239   compat_args( $hash_ref_defaults, $arrayref_old_fixed, [ $arg1, $arg2, ...])
2240    
2241   A typical call would look like:
2242    
2243   my %args = compat_args({timeout => 60, .. }, ['timeout'], @_);
2244 0  
2245 0 =cut
2246 0  
2247 0 my ($def_args, $fix_keys) = splice(@_, 0, 2);
2248   my %ret;
2249 0 for my $key (@{$fix_keys}) {
2250 0 $ret{$key} = shift if (scalar(@_) >= 1 && (!defined($_[0]) || !grep { $_ eq $_[0] } keys(%{$def_args})));
2251 0 }
2252   carp("Odd number of arguments") unless ((@_ % 2) == 0);
2253 0 %ret = (%{$def_args}, %ret, @_);
2254 0 map { $ret{$_} //= $def_args->{$_} } keys(%{$def_args});
2255 0 return %ret;
2256 0 }
2257 0  
2258 0 =head2 show_curl_progress_meter
2259 0  
2260   Helper function to alter the curl command to show progress meter.
2261 0 Progress meter is shown only when the server output is redirected.
2262   This works only when uploading where the output is not lately used.
2263    
2264 0 show_curl_progress_meter( $cmd )
2265    
2266 0 A typical call would look like:
2267    
2268   $cmd .= show_curl_progress_meter($cmd);
2269    
2270   =cut
2271    
2272    
2273   =head2 backend_get_wait_still_screen_on_here_doc_input
2274    
2275   Function to query the backend if it has the known bug from
2276   https://progress.opensuse.org/issues/60566 which is that typing too fast into
2277   the here-document input can yield invalid script content.
2278   This function returns the value to be used by C<wait_still_screen> before
2279   starting to write the script into the here document.
2280   =cut
2281   state $ret;
2282   $ret = query_isotovideo('backend_get_wait_still_screen_on_here_doc_input', {}) unless defined($ret);
2283   return get_var(_WAIT_STILL_SCREEN_ON_HERE_DOC_INPUT => $ret);
2284   }
2285   1;