6 use Time::HiRes qw(sleep gettimeofday);
10 eval {require Algorithm::Line::Bresenham;};
20 use Data::Dump "dump";
23 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
25 @EXPORT = qw($realname $username $password $scriptdir $testresults $serialdev $testedversion %cmd
26 &diag &modstart &fileContent &qemusend_nolog &qemusend &backend_send_nolog &backend_send &sendkey
27 &sendkeyw &sendautotype &sendpassword &mouse_move &mouse_set &mouse_click &mouse_hide &clickimage &result_dir
28 &timeout_screenshot &waitidle &waitserial &waitimage &waitforneedle &waitstillimage &waitcolor
29 &checkneedle &goandclick
30 &init_backend &start_vm &stop_vm &set_ocr_rect &get_ocr
31 &script_run &script_sudo &script_sudo_logout &x11_start_program &ensure_installed &clear_console
32 &getcurrentscreenshot &power &mydie &checkEnv &waitinststage);
37 my $goodimageseen :shared = 0;
38 my $screenshotQueue = Thread::Queue->new();
39 my $prestandstillwarning :shared = 0;
40 my $timeoutcounter :shared = 0;
41 share($ENV{SCREENSHOTINTERVAL}); # to adjust at runtime
42 my @lastavgcolor = (0,0,0); share(@lastavgcolor);
43 my @ocrrect; share(@ocrrect);
44 my @extrahashrects; share(@extrahashrects);
53 our $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK );
56 our $idlethreshold=($ENV{IDLETHRESHOLD}||$ENV{IDLETHESHOLD}||18)*$clock_ticks/100; # % load max for being considered idle
57 our $timesidleneeded=2;
58 our $standstillthreshold=530;
60 our $realname="Bernhard M. Wiedemann";
61 our $username="bernhard";
62 our $password="nots3cr3t";
64 our $testresults="testresults";
65 our $serialdev="ttyS0"; #FIXME: also backend
66 our $serialfile="serial0";
67 our $gocrbin="/usr/bin/gocr";
69 our $scriptdir=$0; $scriptdir=~s{/[^/]+$}{};
70 our $testedversion=$ENV{ISO}||""; $testedversion=~s{.*/}{};$testedversion=~s/\.iso$//; $testedversion=~s{-Media1?$}{};
72 if($testedversion=~m/^(debian|openSUSE|Fedora|SLE[SD]-1\d|oi|FreeBSD|archlinux)-/) {$ENV{DISTRI}=lc($1)}
74 $ENV{CASEDIR}||="$scriptdir/distri/$ENV{DISTRI}" if $ENV{DISTRI};
75 foreach my $part (split("-", $testedversion)) {$ENV{uc($part)}=1}
76 $ENV{LIVECD}=$ENV{LIVE};
79 $ENV{QEMUPORT}||=15222;
80 $ENV{INSTLANG}||="en_US";
81 $ENV{CASEDIR}||="$scriptdir/distri/$ENV{DISTRI}" if $ENV{DISTRI};
82 if(defined($ENV{DISTRI}) && $ENV{DISTRI} eq 'archlinux') {$ENV{HDDMODEL}="ide";}
115 if($ENV{INSTLANG} eq "de_DE") {
116 $cmd{"next"}="alt-w";
117 $cmd{"createpartsetup"}="alt-e";
118 $cmd{"custompart"}="alt-b";
119 $cmd{"addpart"}="alt-h";
120 $cmd{"finish"}="alt-b";
121 $cmd{"accept"}="alt-r";
122 $cmd{"donotformat"}="alt-n";
124 # $cmd{"raid6"}="alt-d"; 11.2 only
125 $cmd{"raid10"}="alt-r";
126 $cmd{"mountpoint"}="alt-e";
127 $cmd{"rebootnow"}="alt-j";
128 $cmd{"otherrootpw"}="alt-e";
129 $cmd{"change"}="alt-n";
130 $cmd{"software"}="w";
132 if($ENV{INSTLANG} eq "es_ES") {
133 $cmd{"next"}="alt-i";
135 if($ENV{INSTLANG} eq "fr_FR") {
136 $cmd{"next"}="alt-s";
138 ## keyboard cmd vars end
140 needle::init("$scriptdir/distri/$ENV{DISTRI}/needles") if ($scriptdir && $ENV{DISTRI});
143 if(!-x $gocrbin) {$gocrbin=undef}
144 if($ENV{SUSEMIRROR} && $ENV{SUSEMIRROR}=~s{^(\w+)://}{}) { # strip & check proto
145 if($1 ne "http") {die "only http mirror URLs are currently supported but found '$1'."}
147 ## some var checks end
154 our $backend; #FIXME: make local after adding frontend-api to bmwqemu
156 my $framecounter = 0; # screenshot counter
159 my $sudotimeout=298; # 5 mins
164 ## charmap (like L => shift+l)
166 ","=>"comma", "."=>"dot", "/"=>"slash", "="=>"equal", "-"=>"minus", "*"=>"asterisk",
167 "["=>"bracket_left", "]"=>"bracket_right",
168 "{"=>"shift-bracket_left", "}"=>"shift-bracket_right",
169 "\\"=>"backslash", "|"=>"shift-backslash",
170 ";"=>"semicolon", ":"=>"shift-semicolon",
171 "'"=>"apostrophe", '"'=>"shift-apostrophe",
172 "`"=>"grave_accent", "~"=>"shift-grave_accent",
173 "<"=>"shift-comma", ">"=>"shift-dot",
174 "+"=>"shift-equal", "_"=>"shift-minus", '?'=>"shift-slash",
175 "\t"=>"tab", "\n"=>"ret", " "=>"spc", "\b"=>"backspace", "\e"=>"esc"
177 for my $c ("A".."Z") {$charmap{$c}="shift-\L$c"}
180 for my $c (')','!','@','#','$','%','^','&','*','(') {$charmap{$c}="shift-".($n++)}
187 # global/shared var set functions
189 sub set_ocr_rect {@ocrrect=@_;}
191 # global/shared var set functions end
195 # util and helper functions
198 $logfd && print $logfd "@_\n";
199 return unless $debug;
206 $logfd && print $logfd '<<< '.$fname.'('.join(', ', @fparams).")\n";
207 return unless $debug;
208 print STDERR colored('<<< '.$fname.'('.join(', ', @fparams).')', 'blue')."\n";
214 $logfd && print $logfd ">>> $fname: @fparams\n";
215 return unless $debug;
216 print STDERR colored(">>> $fname: @fparams", 'green')."\n";
222 $logfd && print $logfd "::: $fname: @fparams\n";
223 return unless $debug;
224 print STDERR colored("::: $fname: @fparams", 'yellow')."\n";
229 $logfd && print $logfd "||| @text\n";
230 return unless $debug;
231 print STDERR colored("||| @text", 'bold')."\n";
237 return 1 if (defined $ENV{$var} && $ENV{$var} eq $val);
243 open(my $fd, $fn) or return undef;
251 unless (-e "$testresults/$testedversion") {
253 mkdir "$testresults/$testedversion" or die "mkdir $testresults/$testedversion: $!\n";
255 return "$testresults/$testedversion"
259 our $lastscreenshotName;
260 our $lastscreenshotCount;
261 sub getcurrentscreenshot() {
263 # using a queue to get the latest is most likely the least efficient solution,
264 # but we need to check the current screenshot not to miss things
265 while ($screenshotQueue->pending()) {
266 # unfortunately passing objects between threads is almost impossible
267 $filename = $screenshotQueue->dequeue();
270 $lastscreenshot = tinycv::read($filename);
271 $lastscreenshotName = $filename;
272 $lastscreenshotCount = 0;
275 return $lastscreenshot;
278 sub check_color($$) {
282 foreach my $r (@$range) {
283 my $c=$color->[$n++];
284 next unless defined $r;
285 return 0 unless $r->[0]<=$c && $c<=$r->[1];
289 # TODO: move to a separate tests file:
290 sub test_check_color()
292 my $c=[0.1, 0.6, 0.2];
293 die 1 unless check_color($c, []); # all zero ranges match
294 die 2 unless check_color($c, [undef, [0.2,0.7], undef]); # just match green
295 die 3 unless check_color($c, [[0,0.4], [0.4,0.7], [0,0.4]]); # all three must match
296 die 4 if check_color($c, [[0.3,0.4], [0.2,0.7], [0,0.4]]); # red too low
297 die 5 if check_color($c, [undef, [0.7,0.9], [0,0.4]]); # green too low
298 die 6 if check_color($c, [undef, [0.4,0.9], [0,0.1]]); # blue too high
302 # util and helper functions end
307 sub init_backend($) {
309 require "backend/$name.pm";
310 $backend="backend::$name"->new();
311 open($logfd, ">>", "currentautoinst-log.txt");
312 # set unbuffered so that sendkey lines from main thread will be written
313 my $oldfh=select($logfd); $|=1; select($oldfh);
317 $backend->start_vm();
325 fctlog('mydie', "@_");
328 eval 'croak "mydie"; ';
332 sub backend_send_nolog($) {
333 # should not be used if possible
342 sub backend_send($) {
343 # should not be used if possible
344 fctlog('backend_send', join(',', @_));
348 sub qemusend_nolog($) {&backend_send_nolog;} # deprecated
349 sub qemusend($) {&backend_send;} # deprecated
351 # backend management end
354 # runtime keyboard/mouse io functions
359 sendkey($qemu_key_name)
364 #fctlog('sendkey', "key=$key");
365 $backend->sendkey($key);
366 my @t=gettimeofday();
367 push(@keyhistory, [$t[0]*1000000+$t[1], $key]);
373 sendkeyw($qemu_key_name)
375 L</sendkey> then L</waitidle>
385 sendautotype($string)
387 send a string of characters, mapping them to appropriate key names as necessary
390 sub sendautotype($) {
392 fctlog('sendautotype', "string='$string'");
393 foreach my $letter (split("", $string)) {
394 if($charmap{$letter}) { $letter=$charmap{$letter} }
400 sendautotype($password);
406 sub mouse_move_nosleep($$) {
407 my ($mdx, $mdy) = @_;
408 fctlog('mouse_move', "delta_x=$mdx", "delta_y=$mdy");
409 $backend->mouse_move($mdx, $mdy);
412 sub mouse_set_nosleep($$) {
414 fctlog('mouse_set', "x=$mx", "y=$my");
415 $backend->mouse_set($mx, $my);
420 # FIXME: backend value abstraction
421 my ($mdx, $mdy) = @_;
422 mouse_move_nosleep($mdx, $mdy);
429 mouse_set_nosleep($mx, $my);
433 sub mouse_click(;$$) {
434 my $button = shift || 'left';
435 my $time = shift || 0.15;
436 fctlog('mouse_click', "button=$button", "cursor_down=$time");
437 $backend->mouse_button($button, 1);
439 $backend->mouse_button($button, 0);
443 my $border_offset = shift || 0;
444 fctlog('mouse_hide', "border_offset=$border_offset");
445 $backend->mouse_hide($border_offset);
451 sub x11_start_program($;$) {
453 my $options=shift||{};
454 sendkey "alt-f2"; sleep 4;
455 sendautotype $program; sleep 1;
456 if($options->{terminal}) {sendkey "alt-t";sleep 3;}
464 script_run($program, [$wait_seconds])
466 Run $program (by assuming the console prompt and typing it).
467 Wait for idle before and after.
470 sub script_run($;$) {
471 # start console application
475 sendautotype("$name\n");
482 script_sudo($program, [$wait_seconds])
484 Run $program. Handle the sudo timeout and send password when appropriate.
488 sub script_sudo($;$) {
490 sendautotype("sudo $prog\n");
491 if(!$lastsudotime||$lastsudotime+$sudotimeout<time()) {$sudos=0}
492 if($password && !$sudos++) {
497 $lastsudotime=time();
501 =head2 script_sudo_logout
503 Reset so that the next sudo will send password
506 sub script_sudo_logout() {
510 sub ensure_installed {
512 #pkcon refresh # once
513 #pkcon install @pkglist
515 x11_start_program("xdg-su -c 'zypper -n in @pkglist'"); # SUSE-specific
516 } elsif($ENV{DEBIAN}) {
517 x11_start_program("su -c 'aptitude -y install @pkglist'", {terminal=>1});
518 } elsif($ENV{FEDORA}) {
519 x11_start_program("su -c 'yum -y install @pkglist'", {terminal=>1});
521 mydie "TODO: implement package install for your distri $ENV{DISTRI}";
523 if($password) { sendpassword; sendkeyw "ret"; }
524 waitstillimage(6,90); # wait for install
527 sub clear_console() {
531 sendautotype "reset\n";
536 #TODO: convert to new bmwqemu
537 #sub clickimage($;$$$$) {
538 # my ($reflist,$button,$bstatus,$flags,$timeout) = @_;
541 # my $waitres = waitimage("click/$reflist",$timeout);
542 # if(defined $waitres) {
543 # diag "Got absolute refimg coordinates: $waitres->[0]x$waitres->[1]";
544 # $waitres->[2]=~m/-(-?\d+)-(-?\d+)\.ppm$/;
545 # my @relcoor = ($1,$2);
546 # #my @relcoor = ($waitres[2],$waitres[2]);
547 # #$relcoor[0]=~s/^.*\d-(-?\d+)--?\d+.ppm/$1/;
548 # #$relcoor[1]=~s/^.*\d--?\d+-(-?\d+).ppm/$1/;
549 # diag "Got relative action coordinates: $relcoor[0]x$relcoor[1]";
551 # for my $i (0..1) { $abscoor[$i] = $waitres->[$i] + $relcoor[$i]; }
552 # diag "Got absolute action coordinates: $abscoor[0]x$abscoor[1]";
555 # diag "Sliding mouse to $abscoor[0]x$abscoor[1]";
556 # for my $pos (Algorithm::Line::Bresenham::line($mouse_position[1],$mouse_position[0] => $abscoor[1],$abscoor[0])) {
557 # mousemove($pos->[1],$pos->[0],0.005);
561 # diag "Set mouse position: $abscoor[0]x$abscoor[1]";
562 # mousemove($abscoor[0],$abscoor[1]);
565 # mousebuttonaction($button, $bstatus);
567 # # cursor in ninja mode
569 # mousemove(800,600);
574 # diag "Skipping click action!";
581 # params: (on), off, acpi, reset
583 fctlog('power', "action=$action");
584 $backend->power($action);
588 # runtime keyboard/mouse io functions end
591 # runtime information gathering functions
593 sub do_take_screenshot() {
594 my $ret = $backend->screendump();
598 sub timeout_screenshot() {
599 my $n = ++$timeoutcounter;
601 my $n2=sprintf("%02i",$n);
602 getcurrentscreenshot()->write_optimized("$dir/timeout-$n2.png");
605 sub take_screenshot(;$) {
606 my $flags = shift || '';
607 my $path="qemuscreenshot/";
610 my $t=[gettimeofday()];
611 my $img = do_take_screenshot();
613 # strip first 10 screenshots, if they are too small (was that related to some ffmpeg issues?)
614 if(($framecounter++ < 10) && $img->xres()<800) { return; }
616 # TODO detect bad needles
618 my $filename=$path.sprintf("%s.%06i.png", POSIX::strftime("%Y%m%d_%H%M%S", gmtime($t->[0])), $t->[1]);
619 unless($flags=~m/q/) {
620 fctlog('screendump', "filename=$filename");
623 #print STDERR $filename,"\n";
625 my($statuser, $statsystem) = $backend->cpu_stat();
628 for($statuser,$statsystem) {$_/=$clock_ticks}
629 $statstr .= "statuser=$statuser ";
630 $statstr .= "statsystem=$statsystem ";
632 if ($img->xres() > 0) {
633 @lastavgcolor = $img->avgcolor();
635 #my $filevar = "file=".basename($lastname)." ";
636 #my $laststgvar = ($ENV{HW})?"laststage=$lastinststage ":'';
637 #my $md5var = ($ENV{HW})?'':"md5=$md5 ";
638 #my $avgvar = "avgcolor=".join(',', map(sprintf("%.3f", $_), @lastavgcolor));
639 #diag($md5var.$filevar.$laststgvar.$statstr.$avgvar);
641 # hardlinking identical files saves space
643 # 48 is about the similarity of two screenshots with blinking cursor
644 if($lastscreenshot && $lastscreenshot->similarity($img) > 48) {
645 symlink(basename($lastscreenshotName), $filename);
646 $lastscreenshotCount++;
647 $prestandstillwarning=($lastscreenshotCount>$standstillthreshold/2);
648 if($lastscreenshotCount>$standstillthreshold) {
649 timeout_screenshot(); sleep 1;
651 sendkey "alt-sysrq-w";
652 sendkey "alt-sysrq-l";
653 sendkey "alt-sysrq-d"; # only available with CONFIG_LOCKDEP
654 do_take_screenshot()->write_optimized("$dir/standstill-1.png");sleep 1;
655 mydie "standstill detected. test ended. see $filename\n"; # above 120s of autoreboot
659 $img->write($filename) || die "write $filename";
660 $screenshotQueue->enqueue($filename);
661 $lastscreenshot = $img;
662 $lastscreenshotName = $filename;
663 $lastscreenshotCount = 0;
664 #my $ocr=get_ocr($img);
665 #if($ocr) { diag "ocr: $ocr" }
669 sub do_start_audiocapture($) {
670 my $filename = shift;
671 fctlog('start_audiocapture', $filename);
672 $backend->start_audiocapture($filename);
675 sub do_stop_audiocapture($) {
677 fctlog('stop_audiocapture', $index);
678 $backend->stop_audiocapture($index);
682 if(defined $backend) {
683 # backend will kill me when
684 # backend.run has been deleted
685 return $backend->alive();
690 # runtime information gathering functions end
693 # check functions (runtime and result-checks)
695 sub checkrefimgs($$$) {
696 my ($screenimg, $refimg, $flags) = @_;
697 my $screenppm = tinycv::read($screenimg);
698 my $refppm = tinycv::read($refimg);
699 if (!$screenppm || !$refppm) {
703 # black/white => drop most background
704 $screenppm->threshold(0x80);
705 $refppm->threshold(0x80);
708 # perform vector-based fuzzy matching using opencv
709 return $screenppm->search_fuzzy($refppm);
711 elsif ($flags=~m/d/) {
712 # allow difference of 40 per byte
713 return $screenppm->search($refppm, 40);
716 return $screenppm->search($refppm, 0);
721 # input: tinycv object
723 my $ocr=ocr::get_ocr($img, "-m 2 -s 6", \@ocrrect);
724 if(!$ocr) {return ""}
725 $ocr=~s/^[_ \t\n]+//;
727 # correct common mis-readings:
728 $ocr=~s/nstaII/nstall/g;
729 $ocr=~s/l(install|Remaining)/($1/g;
730 return " ocr='$ocr'";
734 # FIXME: move to multimonNG (multimon fork)
737 my $mm = "multimon -a DTMF -t wav $wavfile";
738 open M, "$mm |" || return 1;
740 next unless /^DTMF: .$/;
741 my ($a, $b) = split ':';
742 $b =~ tr/0-9*#ABCD//csd; # Allow 0-9 * # A B C D
748 # check functions end
753 =head2 waitstillimage
755 waitstillimage([$stilltime_sec [, $timeout_sec [, $similarity_level]]])
757 Wait until the screen stops changing
760 sub waitstillimage(;$$$) {
761 my $stilltime=shift||7;
762 my $timeout=shift||30;
763 my $similarity_level=shift||48;
765 my @recentimages; # fifo
766 fctlog('waitstillimage', "stilltime=$stilltime", "timeout=$timeout", "simlvl=$similarity_level");
767 while(time-$starttime<$timeout) {
768 my $img=getcurrentscreenshot();
769 next unless $img; # this must stay to get only valid imgs to fifo
770 push(@recentimages, $img);
771 if(@recentimages > $stilltime) {
772 my $e = shift @recentimages;
773 if ($img->similarity($e) > $similarity_level) {
774 fctres('waitstillimage', "detected same image for $stilltime seconds");
779 timeout_screenshot();
780 fctres('waitstillimage', "waitstillimage timed out after $timeout");
784 sub waitimage($;$$) {
786 my $timeout = shift || 60;
787 my $flags = shift || 'd';
788 my $wact = ($flags=~m/s/)?'disappear':'appear';
789 fctlog('waitimage', "reflist=$reflist", "timeout=$timeout", "flags=$flags");
790 diag "WARNING: waitimage is no longer supported\n";
791 for(my $i=0;$i<=$timeout;$i+=2) {
792 getcurrentscreenshot();
795 timeout_screenshot();
796 fctres('waitimage', "Waiting for images $reflist ($wact) timed out!");
802 waitcolor($rgb_minmax [, $timeout_sec])
804 $rgb_minmax is [[red_min,red_max], [green_min,green_max], [blue_min,blue_max]]
805 eg: [undef, [0.2, 0.7], [0,0.1]]
809 my $rgb_minmax = shift;
810 my $timeout = shift || 30;
811 my $starttime = time;
812 fctlog('waitcolor', "rgb=".dump(@$rgb_minmax), "timeout=$timeout");
813 while(time-$starttime<$timeout) {
814 if (check_color(\@lastavgcolor, $rgb_minmax)) {
815 fctres('waitcolor', "detected ".dump(@lastavgcolor));
820 timeout_screenshot();
821 fctres('waitcolor', "rgb ".dump(@$rgb_minmax)." timed out after $timeout");
827 waitserial($regex [, $timeout_sec])
829 Wait for a message to appear on serial output.
830 You could have sent it there earlier with
832 C<script_run("echo Hello World E<gt> /dev/$serialdev");>
835 sub waitserial($;$) {
836 # wait for a message to appear on serial output
838 my $timeout=shift||90; # seconds
839 fctlog('waitserial', "regex=$regexp", "timeout=$timeout");
840 for my $n (1..$timeout) {
841 my $str=`tail $serialfile`;
842 if($str=~m/$regexp/) {fctres('waitserial', "found $regexp"); return 1;}
843 if($prestandstillwarning) {return 2}
846 fctres('waitserial', "$regexp timed out after $timeout");
852 waitidle([$timeout_sec])
854 Wait until the system becomes idle (as configured by IDLETHESHOLD in env.sh)
858 my $timeout=shift||19;
860 fctlog('waitidle', "timeout=$timeout");
863 for my $n (1..$timeout) {
864 my($stat, $systemstat) = $backend->cpu_stat();
865 sleep 1; # sleep before skip to timeout when having no data (hw)
867 $stat += $systemstat;
869 my $diff = $stat - $prev;
870 if($diff<$idlethreshold) {
871 if(++$timesidle > $timesidleneeded) { # idle for $x sec
872 #if($diff<2000000) # idle for one sec
873 fctres('waitidle', "idle detected");
881 fctres('waitidle', "timed out after $timeout");
885 sub waitinststage($;$$) {
887 my $timeout = shift||30;
889 return waitforneedle($stage, $timeout, $extra);
894 my $mustmatch = $args{'mustmatch'};
895 my $timeout = $args{'timeout'} || 30;
897 # get the array reference to all matching needles
899 if (ref($mustmatch) eq "ARRAY") {
900 $needles = $mustmatch;
902 for my $n (@{$needles}) {
903 $mustmatch .= $n->{name} . " ";
905 } elsif ($mustmatch) {
906 $needles = needle::tags($mustmatch) || [];
908 fctlog('waitforneedle', "'$mustmatch'", "timeout=$timeout");
910 printf "NO goods for $mustmatch\n";
911 # give it some time to settle but not too much
914 my $img = getcurrentscreenshot();
916 for my $n (1..$timeout) {
917 if (-e "waitneedlefail") {
918 unlink("waitneedlefail");
923 $img = getcurrentscreenshot();
924 if ($oldimg == $img) { # no change, no need to search
925 print "no change $n\n";
929 my $foundneedle = $img->search($needles);
932 $img->write(result_dir() . "/match-$mustmatch-$t.png");
933 fctres(sprintf("found %s, similarity %.2f @ %d/%d",
934 $foundneedle->{'needle'}->{'name'},
935 $foundneedle->{'similarity'},
936 $foundneedle->{'x'}, $foundneedle->{'y'}));
937 if ($args{'click'}) {
938 my $rx = 1; # $origx / $img->xres();
939 my $ry = 1; # $origy / $img->yres();
940 my $x = ($foundneedle->{'x'} + $foundneedle->{'w'}/2)*$rx;
941 my $y = ($foundneedle->{'y'} + $foundneedle->{'h'}/2)*$ry;
942 diag ("clicking at $x/$y");
944 mouse_click($args{'click'}, $args{'clicktime'});
950 fctres('waitforneedle', "match=$mustmatch timed out after $timeout");
951 for (@{$needles||[]}) {
955 $img->write_optimized(result_dir() . "/$mustmatch-$t.png");
956 my $fn = result_dir() . "/$mustmatch-$t.json";
957 open(J, ">", $fn) or die "$fn: $!\n";
958 my $json = { area => [ { xpos => 0, ypos => 0, width => $img->xres(), height => $img->yres(), type => 'match' } ] };
959 my @tags = ( $mustmatch );
960 # write out some known env variables
961 for my $key (qw(VIDEOMODE DESKTOP DISTRI INSTLANG LIVECD)) {
962 push(@tags, "ENV-$key-" . $ENV{$key}) if $ENV{$key};
964 $json->{"tags"} = \@tags;
965 print J JSON->new->pretty->encode( $json );
969 $args{'retried'} ||= 0;
970 if (!$args{'check'} && $ENV{'interactive_crop'} && $args{'retried'} < 3) {
971 my $newname = $mustmatch.($ENV{'interactive_crop'} || '');
972 system("$scriptdir/crop.py", '--new', $newname, $fn) == 0 || mydie;
973 # FIXME: kill needle with same file name
974 $fn = sprintf("%s/needles/%s.json", $ENV{'CASEDIR'}, $newname)
977 diag("reading new needle $fn");
978 needle->new($fn) || mydie "$!";
980 return waitforneedle($mustmatch, 3, $args{'check'}, $args{'retried'}+1);
983 mydie unless $args{'check'};
987 sub waitforneedle($;$) {
988 return _waitforneedle(mustmatch => $_[0], timeout => $_[1]);
991 sub checkneedle($;$) {
992 return _waitforneedle(mustmatch => $_[0], timeout => $_[1], check => 1);
995 # warning: will not work due to https://bugs.launchpad.net/qemu/+bug/752476
996 sub goandclick($;$$$) {
997 return _waitforneedle(mustmatch => $_[0],
998 click => ($_[1] || 'left'),
1000 clicktime => $_[3]);
1003 #FIXME: new wait functions
1004 # waitscreenactive - ($backend->screenactive())
1005 # wait-time - like sleep but prints info to log
1006 # wait-screen-(un)-active to catch reboot of hardware
1008 # wait functions end
1015 # cperl-indent-level: 8