remove useless get_ocr call
[os-autoinst:os-autoinst.git] / bmwqemu.pm
1 $|=1;
2
3 package bmwqemu;
4 use strict;
5 use warnings;
6 use Time::HiRes qw(sleep gettimeofday);
7 use Digest::MD5;
8 use IO::Socket;
9 use File::Basename;
10 eval {require Algorithm::Line::Bresenham;};
11 use Exporter;
12 use ocr;
13 use cv;
14 use needle;
15 use threads;
16 use threads::shared;
17 use Thread::Queue;
18 use POSIX; 
19 use Term::ANSIColor;
20 use Data::Dump "dump";
21 use Carp;
22
23 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
24 @ISA = qw(Exporter);
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);
33
34
35 # shared vars
36
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);
45
46 # shared vars end
47
48
49 # global vars
50
51 our $logfd;
52
53 our $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK );
54
55 our $debug=1;
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;
59
60 our $realname="Bernhard M. Wiedemann";
61 our $username="bernhard";
62 our $password="nots3cr3t";
63
64 our $testresults="testresults";
65 our $serialdev="ttyS0"; #FIXME: also backend
66 our $serialfile="serial0";
67 our $gocrbin="/usr/bin/gocr";
68
69 our $scriptdir=$0; $scriptdir=~s{/[^/]+$}{};
70 our $testedversion=$ENV{ISO}||""; $testedversion=~s{.*/}{};$testedversion=~s/\.iso$//; $testedversion=~s{-Media1?$}{};
71 if(!$ENV{DISTRI}) {
72         if($testedversion=~m/^(debian|openSUSE|Fedora|SLE[SD]-1\d|oi|FreeBSD|archlinux)-/) {$ENV{DISTRI}=lc($1)}
73 }
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};
77
78 ## env vars
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";}
83 ## env vars end
84
85 ## keyboard cmd vars
86 our @keyhistory;
87 our %cmd=qw(
88         next alt-n
89         xnext alt-n
90         install alt-i
91         finish alt-f
92         accept alt-a
93         createpartsetup alt-c
94         custompart alt-c
95         addpart alt-d
96         donotformat alt-d
97         addraid alt-i
98         add alt-a
99         raid0 alt-0
100         raid1 alt-1
101         raid5 alt-5
102         raid6 alt-6
103         raid10 alt-i
104         mountpoint alt-m
105         filesystem alt-s
106         acceptlicense alt-a
107         instdetails alt-d
108         rebootnow alt-n
109         otherrootpw alt-s
110         noautologin alt-a
111         change alt-c
112         software s
113 );
114
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";
123         $cmd{"add"}="alt-h";
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";
131 }
132 if($ENV{INSTLANG} eq "es_ES") {
133         $cmd{"next"}="alt-i";
134 }
135 if($ENV{INSTLANG} eq "fr_FR") {
136         $cmd{"next"}="alt-s";
137 }
138 ## keyboard cmd vars end
139
140 needle::init("$scriptdir/distri/$ENV{DISTRI}/needles") if ($scriptdir && $ENV{DISTRI});
141
142 ## some var checks
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'."}
146 }
147 ## some var checks end
148
149 # global vars end
150
151
152 # local vars
153
154 our $backend; #FIXME: make local after adding frontend-api to bmwqemu
155
156 my $framecounter = 0; # screenshot counter
157
158 ## sudo stuff
159 my $sudotimeout=298; # 5 mins
160 my $lastsudotime;
161 my $sudos=0;
162 ## sudo stuff end
163
164 ## charmap (like L => shift+l)
165 my %charmap=(
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"
176 );
177 for my $c ("A".."Z") {$charmap{$c}="shift-\L$c"}
178 {
179         my $n=0;
180         for my $c (')','!','@','#','$','%','^','&','*','(') {$charmap{$c}="shift-".($n++)}
181 }
182 ## charmap end
183
184 # local vars end
185
186
187 # global/shared var set functions
188
189 sub set_ocr_rect {@ocrrect=@_;}
190
191 # global/shared var set functions end
192
193
194
195 # util and helper functions
196
197 sub diag($) {
198         $logfd && print $logfd "@_\n";
199         return unless $debug;
200         print STDERR "@_\n";
201 }
202
203 sub fctlog {
204         my $fname = shift;
205         my @fparams = @_;
206         $logfd && print $logfd '<<< '.$fname.'('.join(', ', @fparams).")\n";
207         return unless $debug;
208         print STDERR colored('<<< '.$fname.'('.join(', ', @fparams).')', 'blue')."\n";
209 }
210
211 sub fctres {
212         my $fname = shift;
213         my @fparams = @_;
214         $logfd && print $logfd ">>> $fname: @fparams\n";
215         return unless $debug;
216         print STDERR colored(">>> $fname: @fparams", 'green')."\n";
217 }
218
219 sub fctinfo {
220         my $fname = shift;
221         my @fparams = @_;
222         $logfd && print $logfd "::: $fname: @fparams\n";
223         return unless $debug;
224         print STDERR colored("::: $fname: @fparams", 'yellow')."\n";
225 }
226
227 sub modstart {
228         my @text = @_;
229         $logfd && print $logfd "||| @text\n";
230         return unless $debug;
231         print STDERR colored("||| @text", 'bold')."\n";
232 }
233
234 sub checkEnv($$) {
235         my $var = shift;
236         my $val = shift;
237         return 1 if (defined $ENV{$var} && $ENV{$var} eq $val);
238         return 0;
239 }
240
241 sub fileContent($) {
242         my($fn)=@_;
243         open(my $fd, $fn) or return undef;
244         local $/;
245         my $result=<$fd>;
246         close($fd);
247         return $result;
248 }
249
250 sub result_dir() {
251         unless (-e "$testresults/$testedversion") {
252                 mkdir $testresults;
253                 mkdir "$testresults/$testedversion" or die "mkdir $testresults/$testedversion: $!\n";
254         }
255         return "$testresults/$testedversion"
256 }
257
258 our $lastscreenshot;
259 our $lastscreenshotName;
260 our $lastscreenshotCount;
261 sub getcurrentscreenshot() {
262         my $filename;
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();
268         }
269         if ($filename) {
270                 $lastscreenshot = tinycv::read($filename);
271                 $lastscreenshotName = $filename;
272                 $lastscreenshotCount = 0;
273         }
274
275         return $lastscreenshot;
276 }
277
278 sub check_color($$) {
279         my $color = shift;
280         my $range = shift;
281         my $n=0;
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];
286         }
287         return 1;
288 }
289 # TODO: move to a separate tests file:
290 sub test_check_color()
291 {
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
299 }
300
301
302 # util and helper functions end
303
304
305 # backend management
306
307 sub init_backend($) {
308         my $name=shift;
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);
314 }
315
316 sub start_vm() {
317         $backend->start_vm();
318 }
319
320 sub stop_vm() {
321         $backend->stop_vm();
322 }
323
324 sub mydie {
325         fctlog('mydie', "@_");
326         $backend->stop_vm();
327         close $logfd;
328         eval 'croak "mydie"; ';
329         exit 1;
330 }
331
332 sub backend_send_nolog($) {
333         # should not be used if possible
334         if($backend) {
335                 $backend->send(@_);
336         }
337         else {
338                 warn "no backend"
339         }
340 }
341
342 sub backend_send($) {
343         # should not be used if possible
344         fctlog('backend_send', join(',', @_));
345         &backend_send_nolog;
346 }
347
348 sub qemusend_nolog($) {&backend_send_nolog;} # deprecated
349 sub qemusend($) {&backend_send;} # deprecated
350
351 # backend management end
352
353
354 # runtime keyboard/mouse io functions
355
356 ## keyboard
357 =head2 sendkey
358
359 sendkey($qemu_key_name)
360
361 =cut
362 sub sendkey($) {
363         my $key=shift;
364         #fctlog('sendkey', "key=$key");
365         $backend->sendkey($key);
366         my @t=gettimeofday();
367         push(@keyhistory, [$t[0]*1000000+$t[1], $key]);
368         sleep(0.1);
369 }
370
371 =head2 sendkeyw
372
373 sendkeyw($qemu_key_name)
374
375 L</sendkey> then L</waitidle>
376
377 =cut
378 sub sendkeyw($) {
379         sendkey(shift);
380         waitidle();
381 }
382
383 =head2 sendautotype
384
385 sendautotype($string)
386
387 send a string of characters, mapping them to appropriate key names as necessary
388
389 =cut
390 sub sendautotype($) {
391         my $string=shift;
392         fctlog('sendautotype', "string='$string'");
393         foreach my $letter (split("", $string)) {
394                 if($charmap{$letter}) { $letter=$charmap{$letter} }
395                 sendkey $letter;
396         }
397 }
398
399 sub sendpassword() {
400         sendautotype($password);
401 }
402 ## keyboard end
403
404
405 ## mouse
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);
410 }
411
412 sub mouse_set_nosleep($$) {
413         my ($mx, $my) = @_;
414         fctlog('mouse_set', "x=$mx", "y=$my");
415         $backend->mouse_set($mx, $my);
416 }
417
418 sub mouse_move($$) {
419         # relative
420         # FIXME: backend value abstraction
421         my ($mdx, $mdy) = @_;
422         mouse_move_nosleep($mdx, $mdy);
423         sleep 0.5;
424 }
425
426 sub mouse_set($$) {
427         # absolute
428         my ($mx, $my) = @_;
429         mouse_set_nosleep($mx, $my);
430         sleep 0.5;
431 }
432
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);
438         sleep $time;
439         $backend->mouse_button($button, 0);
440 }
441
442 sub mouse_hide(;$) {
443         my $border_offset = shift || 0;
444         fctlog('mouse_hide', "border_offset=$border_offset");
445         $backend->mouse_hide($border_offset);
446 }
447 ## mouse end
448
449
450 ## helpers
451 sub x11_start_program($;$) {
452         my $program=shift;
453         my $options=shift||{};
454         sendkey "alt-f2"; sleep 4;
455         sendautotype $program; sleep 1;
456         if($options->{terminal}) {sendkey "alt-t";sleep 3;}
457         sendkey "ret";
458         waitidle();
459         sleep 1;
460 }
461
462 =head2 script_run
463
464 script_run($program, [$wait_seconds])
465
466 Run $program (by assuming the console prompt and typing it).
467 Wait for idle before  and after.
468
469 =cut
470 sub script_run($;$) {
471         # start console application
472         my $name=shift;
473         my $wait=shift || 9;
474         waitidle();
475         sendautotype("$name\n");
476         waitidle($wait);
477         sleep 3;
478 }
479
480 =head2 script_sudo
481
482 script_sudo($program, [$wait_seconds])
483
484 Run $program. Handle the sudo timeout and send password when appropriate.
485
486 $wait_seconds
487 =cut
488 sub script_sudo($;$) {
489         my ($prog,$wait)=@_;
490         sendautotype("sudo $prog\n");
491         if(!$lastsudotime||$lastsudotime+$sudotimeout<time()) {$sudos=0}
492         if($password && !$sudos++) {
493                 waitidle();
494                 sendpassword;
495                 sendkey "ret";
496         }
497         $lastsudotime=time();
498         waitidle($wait);
499 }
500
501 =head2 script_sudo_logout
502
503 Reset so that the next sudo will send password
504
505 =cut
506 sub script_sudo_logout() {
507         $sudos=0
508 }
509
510 sub ensure_installed {
511         my @pkglist=@_;
512         #pkcon refresh # once
513         #pkcon install @pkglist
514         if($ENV{OPENSUSE}) {
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});
520         } else {
521                 mydie "TODO: implement package install for your distri $ENV{DISTRI}";
522         }
523         if($password) { sendpassword; sendkeyw "ret"; }
524         waitstillimage(6,90); # wait for install
525 }
526
527 sub clear_console() {
528         sendkey "ctrl-c";
529         sleep 1;
530         sendkey "ctrl-c";
531         sendautotype "reset\n";
532         sleep 2;
533 }
534 ## helpers end
535
536 #TODO: convert to new bmwqemu
537 #sub clickimage($;$$$$) {
538 #       my ($reflist,$button,$bstatus,$flags,$timeout) = @_;
539 #       $flags||="h";
540 #       $timeout||=60;
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]";
550 #               my @abscoor;
551 #               for my $i (0..1) { $abscoor[$i] = $waitres->[$i] + $relcoor[$i]; }
552 #               diag "Got absolute action coordinates: $abscoor[0]x$abscoor[1]";
553 #               # slide
554 #               if($flags=~m/s/) {
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);
558 #                       }
559 #               }
560 #               else {
561 #                       diag "Set mouse position: $abscoor[0]x$abscoor[1]";
562 #                       mousemove($abscoor[0],$abscoor[1]);
563 #               }
564 #               sleep(0.25);
565 #               mousebuttonaction($button, $bstatus);
566 #               sleep(0.25);
567 #               # cursor in ninja mode
568 #               if($flags=~m/h/) {
569 #                       mousemove(800,600);
570 #               }
571 #               return @abscoor;
572 #       }
573 #       else {
574 #               diag "Skipping click action!";
575 #               return undef;
576 #       }
577 #}
578
579
580 sub power($) {
581         # params: (on), off, acpi, reset
582         my $action = shift;
583         fctlog('power', "action=$action");
584         $backend->power($action);
585 }
586
587
588 # runtime keyboard/mouse io functions end
589
590
591 # runtime information gathering functions
592
593 sub do_take_screenshot() {
594         my $ret = $backend->screendump();
595         return $ret;
596 }
597
598 sub timeout_screenshot() {
599         my $n = ++$timeoutcounter;
600         my $dir=result_dir;
601         my $n2=sprintf("%02i",$n);
602         getcurrentscreenshot()->write_optimized("$dir/timeout-$n2.png");
603 }
604
605 sub take_screenshot(;$) {
606         my $flags = shift || '';
607         my $path="qemuscreenshot/";
608         mkdir $path;
609
610         my $t=[gettimeofday()];
611         my $img = do_take_screenshot();
612
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; }
615
616         # TODO detect bad needles
617
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");
621         }
622
623         #print STDERR $filename,"\n";
624
625         my($statuser, $statsystem) = $backend->cpu_stat();
626         my $statstr = '';
627         if ($statuser) {
628                 for($statuser,$statsystem) {$_/=$clock_ticks}
629                 $statstr .= "statuser=$statuser ";
630                 $statstr .= "statsystem=$statsystem ";
631         }
632         if ($img->xres() > 0) {
633                 @lastavgcolor = $img->avgcolor();
634         }
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);
640
641         # hardlinking identical files saves space
642
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;
650                         my $dir=result_dir;
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
656                 }
657         }
658         else { # new
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" }
666         }
667 }
668
669 sub do_start_audiocapture($) {
670         my $filename = shift;
671         fctlog('start_audiocapture', $filename);
672         $backend->start_audiocapture($filename);
673 }
674
675 sub do_stop_audiocapture($) {
676         my $index = shift;
677         fctlog('stop_audiocapture', $index);
678         $backend->stop_audiocapture($index);
679 }
680
681 sub alive() {
682         if(defined $backend) {
683                 # backend will kill me when
684                 # backend.run has been deleted
685                 return $backend->alive();
686         }
687         return 0;
688 }
689
690 # runtime information gathering functions end
691
692
693 # check functions (runtime and result-checks)
694
695 sub checkrefimgs($$$) {
696         my ($screenimg, $refimg, $flags) = @_;
697         my $screenppm = tinycv::read($screenimg);
698         my $refppm = tinycv::read($refimg);
699         if (!$screenppm || !$refppm) {
700                 return undef;
701         }
702         if ($flags=~m/t/) {
703                 # black/white => drop most background
704                 $screenppm->threshold(0x80);
705                 $refppm->threshold(0x80);
706         }
707         if ($flags=~m/f/) {
708                 # perform vector-based fuzzy matching using opencv
709                 return $screenppm->search_fuzzy($refppm);
710         }
711         elsif ($flags=~m/d/) {
712                 # allow difference of 40 per byte
713                 return $screenppm->search($refppm, 40);
714         }
715         else {
716                 return $screenppm->search($refppm, 0);
717         }
718 }
719
720 sub get_ocr($) {
721         # input: tinycv object
722         my $img=shift;
723         my $ocr=ocr::get_ocr($img, "-m 2 -s 6", \@ocrrect);
724         if(!$ocr) {return ""}
725         $ocr=~s/^[_ \t\n]+//;
726         $ocr=~s/\n/ --- /g;
727         # correct common mis-readings:
728         $ocr=~s/nstaII/nstall/g;
729         $ocr=~s/l(install|Remaining)/($1/g;
730         return " ocr='$ocr'";
731 }
732
733 sub decodewav($) {
734         # FIXME: move to multimonNG (multimon fork)
735         my $wavfile = shift;
736         my $dtmf = '';
737         my $mm = "multimon -a DTMF -t wav $wavfile";
738         open M, "$mm |" || return 1;
739         while (<M>) {
740                 next unless /^DTMF: .$/;
741                 my ($a, $b) = split ':';
742                 $b =~ tr/0-9*#ABCD//csd; # Allow 0-9 * # A B C D
743                 $dtmf .= $b;
744         }
745         return $dtmf;
746 }
747
748 # check functions end
749
750
751 # wait functions
752
753 =head2 waitstillimage
754
755 waitstillimage([$stilltime_sec [, $timeout_sec [, $similarity_level]]])
756
757 Wait until the screen stops changing
758
759 =cut
760 sub waitstillimage(;$$$) {
761         my $stilltime=shift||7;
762         my $timeout=shift||30;
763         my $similarity_level=shift||48;
764         my $starttime=time;
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");
775                                 return 1;
776                         }
777                 }
778         }
779         timeout_screenshot();
780         fctres('waitstillimage', "waitstillimage timed out after $timeout");
781         return 0;
782 }
783
784 sub waitimage($;$$) {
785         my $reflist = shift;
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();
793                 sleep 1;
794         }
795         timeout_screenshot();
796         fctres('waitimage', "Waiting for images $reflist ($wact) timed out!");
797         return undef;
798 }
799
800 =head2 waitcolor
801
802 waitcolor($rgb_minmax [, $timeout_sec])
803
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]]
806
807 =cut
808 sub waitcolor($;$) {
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));
816                         return 1;
817                 }
818                 sleep 1;
819         }
820         timeout_screenshot();
821         fctres('waitcolor', "rgb ".dump(@$rgb_minmax)." timed out after $timeout");
822         return 0;
823 }
824
825 =head2 waitserial
826
827 waitserial($regex [, $timeout_sec])
828
829 Wait for a message to appear on serial output.
830 You could have sent it there earlier with
831
832 C<script_run("echo Hello World E<gt> /dev/$serialdev");>
833
834 =cut
835 sub waitserial($;$) {
836         # wait for a message to appear on serial output
837         my $regexp=shift;
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}
844                 sleep 1;
845         }
846         fctres('waitserial', "$regexp timed out after $timeout");
847         return 0;
848 }
849
850 =head2 waitidle
851
852 waitidle([$timeout_sec])
853
854 Wait until the system becomes idle (as configured by IDLETHESHOLD in env.sh)
855
856 =cut
857 sub waitidle(;$) {
858         my $timeout=shift||19;
859         my $prev;
860         fctlog('waitidle', "timeout=$timeout");
861         return 0;
862         my $timesidle=0;
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)
866                 next unless $stat;
867                 $stat += $systemstat;
868                 if($prev) {
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");
874                                         return 1;
875                                 }
876                         }
877                         else {$timesidle=0}
878                 }
879                 $prev = $stat;
880         }
881         fctres('waitidle', "timed out after $timeout");
882         return 0;
883 }
884
885 sub waitinststage($;$$) {
886         my $stage = shift;
887         my $timeout = shift||30;
888         my $extra = shift;
889         return waitforneedle($stage, $timeout, $extra);
890 }
891
892 sub _waitforneedle {
893         my %args = @_;
894         my $mustmatch = $args{'mustmatch'};
895         my $timeout = $args{'timeout'} || 30;
896
897         # get the array reference to all matching needles
898         my $needles;
899         if (ref($mustmatch) eq "ARRAY") {
900                 $needles = $mustmatch;
901                 $mustmatch = '';
902                 for my $n (@{$needles}) {
903                         $mustmatch .= $n->{name} . " ";
904                 }
905         } elsif ($mustmatch) {
906                 $needles = needle::tags($mustmatch) || [];
907         }
908         fctlog('waitforneedle', "'$mustmatch'", "timeout=$timeout");
909         if (!@$needles) {
910                 printf "NO goods for $mustmatch\n";
911                 # give it some time to settle but not too much
912                 $timeout = 3;
913         }
914         my $img = getcurrentscreenshot();
915         my $oldimg;
916         for my $n (1..$timeout) {
917                 if (-e "waitneedlefail") {
918                         unlink("waitneedlefail");
919                         last;
920                 }
921                 if ($oldimg) {
922                         sleep 1;
923                         $img = getcurrentscreenshot();
924                         if ($oldimg == $img) { # no change, no need to search
925                                 print "no change $n\n";
926                                 next;
927                         }
928                 }
929                 my $foundneedle = $img->search($needles);
930                 if ($foundneedle) {
931                         my $t = time();
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");
943                                 mouse_set($x, $y);
944                                 mouse_click($args{'click'}, $args{'clicktime'});
945                         }
946                         return $foundneedle;
947                 }
948                 $oldimg = $img;
949         }
950         fctres('waitforneedle', "match=$mustmatch timed out after $timeout");
951         for (@{$needles||[]}) {
952                 diag $_->{'file'};
953         }
954         my $t = time();
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};
963         }
964         $json->{"tags"} = \@tags;
965         print J JSON->new->pretty->encode( $json );
966         close(J);
967         diag("wrote $fn");
968
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)
975                 if (-e $fn);
976                 {
977                         diag("reading new needle $fn");
978                         needle->new($fn) || mydie "$!";
979                         # XXX: recursion!
980                         return waitforneedle($mustmatch, 3, $args{'check'}, $args{'retried'}+1);
981                 }
982         }
983         mydie unless $args{'check'};
984         return undef;
985 }
986
987 sub waitforneedle($;$) {
988         return _waitforneedle(mustmatch => $_[0], timeout => $_[1]);
989 }
990
991 sub checkneedle($;$) {
992         return _waitforneedle(mustmatch => $_[0], timeout => $_[1], check => 1);
993 }
994
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'),
999                 timeout => $_[2],
1000                 clicktime => $_[3]);
1001 }
1002
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
1007
1008 # wait functions end
1009
1010
1011 1;
1012
1013 # Local Variables:
1014 # tab-width: 8
1015 # cperl-indent-level: 8
1016 # End: