readd scale, but enlarge smaller images
[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.05);
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         my $maxinterval=shift||15;
393         my $typedchars=0;
394         fctlog('sendautotype', "string='$string'");
395         my @letters = split("", $string);
396         while (@letters) {
397                 my $letter = shift @letters;
398                 if($charmap{$letter}) { $letter=$charmap{$letter} }
399                 sendkey $letter;
400                 if ($typedchars++ >= $maxinterval && @letters > $maxinterval / 3 ) {
401                         waitstillimage(1);
402                         $typedchars=0;
403                 }
404         }
405         waitstillimage(1) if ($typedchars > 0);
406 }
407
408 sub sendpassword() {
409         sendautotype($password);
410 }
411 ## keyboard end
412
413
414 ## mouse
415 sub mouse_move_nosleep($$) {
416         my ($mdx, $mdy) = @_;
417         fctlog('mouse_move', "delta_x=$mdx", "delta_y=$mdy");
418         $backend->mouse_move($mdx, $mdy);
419 }
420
421 sub mouse_set_nosleep($$) {
422         my ($mx, $my) = @_;
423         fctlog('mouse_set', "x=$mx", "y=$my");
424         $backend->mouse_set($mx, $my);
425 }
426
427 sub mouse_move($$) {
428         # relative
429         # FIXME: backend value abstraction
430         my ($mdx, $mdy) = @_;
431         mouse_move_nosleep($mdx, $mdy);
432         sleep 0.5;
433 }
434
435 sub mouse_set($$) {
436         # absolute
437         my ($mx, $my) = @_;
438         mouse_set_nosleep($mx, $my);
439         sleep 0.5;
440 }
441
442 sub mouse_click(;$$) {
443         my $button = shift || 'left';
444         my $time = shift || 0.15;
445         fctlog('mouse_click', "button=$button", "cursor_down=$time");
446         $backend->mouse_button($button, 1);
447         sleep $time;
448         $backend->mouse_button($button, 0);
449 }
450
451 sub mouse_hide(;$) {
452         my $border_offset = shift || 0;
453         fctlog('mouse_hide', "border_offset=$border_offset");
454         $backend->mouse_hide($border_offset);
455 }
456 ## mouse end
457
458
459 ## helpers
460 sub x11_start_program($;$) {
461         my $program=shift;
462         my $options=shift||{};
463         sendkey "alt-f2"; sleep 4;
464         sendautotype $program; sleep 1;
465         if($options->{terminal}) {sendkey "alt-t";sleep 3;}
466         sendkey "ret";
467         waitidle();
468         sleep 1;
469 }
470
471 =head2 script_run
472
473 script_run($program, [$wait_seconds])
474
475 Run $program (by assuming the console prompt and typing it).
476 Wait for idle before  and after.
477
478 =cut
479 sub script_run($;$) {
480         # start console application
481         my $name=shift;
482         my $wait=shift || 9;
483         waitidle();
484         sendautotype("$name\n");
485         waitidle($wait);
486         sleep 3;
487 }
488
489 =head2 script_sudo
490
491 script_sudo($program, [$wait_seconds])
492
493 Run $program. Handle the sudo timeout and send password when appropriate.
494
495 $wait_seconds
496 =cut
497 sub script_sudo($;$) {
498         my ($prog,$wait)=@_;
499         sendautotype("sudo $prog\n");
500         if(!$lastsudotime||$lastsudotime+$sudotimeout<time()) {$sudos=0}
501         if($password && !$sudos++) {
502                 waitidle();
503                 sendpassword;
504                 sendkey "ret";
505         }
506         $lastsudotime=time();
507         waitidle($wait);
508 }
509
510 =head2 script_sudo_logout
511
512 Reset so that the next sudo will send password
513
514 =cut
515 sub script_sudo_logout() {
516         $sudos=0
517 }
518
519 sub ensure_installed {
520         my @pkglist=@_;
521         #pkcon refresh # once
522         #pkcon install @pkglist
523         if($ENV{OPENSUSE}) {
524                 x11_start_program("xdg-su -c 'zypper -n in @pkglist'"); # SUSE-specific
525         } elsif($ENV{DEBIAN}) {
526                 x11_start_program("su -c 'aptitude -y install @pkglist'", {terminal=>1});
527         } elsif($ENV{FEDORA}) {
528                 x11_start_program("su -c 'yum -y install @pkglist'", {terminal=>1});
529         } else {
530                 mydie "TODO: implement package install for your distri $ENV{DISTRI}";
531         }
532         if($password) { sendpassword; sendkeyw "ret"; }
533         waitstillimage(7,90); # wait for install
534 }
535
536 sub clear_console() {
537         sendkey "ctrl-c";
538         sleep 1;
539         sendkey "ctrl-c";
540         sendautotype "reset\n";
541         sleep 2;
542 }
543 ## helpers end
544
545 #TODO: convert to new bmwqemu
546 #sub clickimage($;$$$$) {
547 #       my ($reflist,$button,$bstatus,$flags,$timeout) = @_;
548 #       $flags||="h";
549 #       $timeout||=60;
550 #       my $waitres = waitimage("click/$reflist",$timeout);
551 #       if(defined $waitres) {
552 #               diag "Got absolute refimg coordinates: $waitres->[0]x$waitres->[1]";
553 #               $waitres->[2]=~m/-(-?\d+)-(-?\d+)\.ppm$/;
554 #               my @relcoor = ($1,$2);
555 #               #my @relcoor = ($waitres[2],$waitres[2]);
556 #               #$relcoor[0]=~s/^.*\d-(-?\d+)--?\d+.ppm/$1/;
557 #               #$relcoor[1]=~s/^.*\d--?\d+-(-?\d+).ppm/$1/;
558 #               diag "Got relative action coordinates: $relcoor[0]x$relcoor[1]";
559 #               my @abscoor;
560 #               for my $i (0..1) { $abscoor[$i] = $waitres->[$i] + $relcoor[$i]; }
561 #               diag "Got absolute action coordinates: $abscoor[0]x$abscoor[1]";
562 #               # slide
563 #               if($flags=~m/s/) {
564 #                       diag "Sliding mouse to $abscoor[0]x$abscoor[1]";
565 #                       for my $pos (Algorithm::Line::Bresenham::line($mouse_position[1],$mouse_position[0] => $abscoor[1],$abscoor[0])) {
566 #                               mousemove($pos->[1],$pos->[0],0.005);
567 #                       }
568 #               }
569 #               else {
570 #                       diag "Set mouse position: $abscoor[0]x$abscoor[1]";
571 #                       mousemove($abscoor[0],$abscoor[1]);
572 #               }
573 #               sleep(0.25);
574 #               mousebuttonaction($button, $bstatus);
575 #               sleep(0.25);
576 #               # cursor in ninja mode
577 #               if($flags=~m/h/) {
578 #                       mousemove(800,600);
579 #               }
580 #               return @abscoor;
581 #       }
582 #       else {
583 #               diag "Skipping click action!";
584 #               return undef;
585 #       }
586 #}
587
588
589 sub power($) {
590         # params: (on), off, acpi, reset
591         my $action = shift;
592         fctlog('power', "action=$action");
593         $backend->power($action);
594 }
595
596
597 # runtime keyboard/mouse io functions end
598
599
600 # runtime information gathering functions
601
602 sub do_take_screenshot() {
603         my $ret = $backend->screendump();
604         return $ret->scale(1024, 768);
605 }
606
607 sub timeout_screenshot() {
608         my $n = ++$timeoutcounter;
609         my $dir=result_dir;
610         my $n2=sprintf("%02i",$n);
611         getcurrentscreenshot()->write_optimized("$dir/timeout-$n2.png");
612 }
613
614 sub take_screenshot(;$) {
615         my $flags = shift || '';
616         my $path="qemuscreenshot/";
617         mkdir $path;
618
619         my $t=[gettimeofday()];
620         my $img = do_take_screenshot();
621
622         # strip first 10 screenshots, if they are too small (was that related to some ffmpeg issues?)
623         if(($framecounter++ < 10) && $img->xres()<800) { return; }
624
625         # TODO detect bad needles
626
627         my $filename=$path.sprintf("%s.%06i.png", POSIX::strftime("%Y%m%d_%H%M%S", gmtime($t->[0])), $t->[1]);
628         unless($flags=~m/q/) {
629                 fctlog('screendump', "filename=$filename");
630         }
631
632         #print STDERR $filename,"\n";
633
634         my($statuser, $statsystem) = $backend->cpu_stat();
635         my $statstr = '';
636         if ($statuser) {
637                 for($statuser,$statsystem) {$_/=$clock_ticks}
638                 $statstr .= "statuser=$statuser ";
639                 $statstr .= "statsystem=$statsystem ";
640         }
641         if ($img->xres() > 0) {
642                 @lastavgcolor = $img->avgcolor();
643         }
644         #my $filevar = "file=".basename($lastname)." ";
645         #my $laststgvar = ($ENV{HW})?"laststage=$lastinststage ":'';
646         #my $md5var = ($ENV{HW})?'':"md5=$md5 ";
647         #my $avgvar = "avgcolor=".join(',', map(sprintf("%.3f", $_), @lastavgcolor));
648         #diag($md5var.$filevar.$laststgvar.$statstr.$avgvar);
649
650         # hardlinking identical files saves space
651
652         # 47 is about the similarity of two screenshots with blinking cursor
653         if($lastscreenshot && $lastscreenshot->similarity($img) > 47) {
654                 symlink(basename($lastscreenshotName), $filename);
655                 $lastscreenshotCount++;
656                 $prestandstillwarning=($lastscreenshotCount>$standstillthreshold/2);
657                 if($lastscreenshotCount>$standstillthreshold) {
658                         timeout_screenshot(); sleep 1;
659                         my $dir=result_dir;
660                         sendkey "alt-sysrq-w";
661                         sendkey "alt-sysrq-l";
662                         sendkey "alt-sysrq-d"; # only available with CONFIG_LOCKDEP
663                         do_take_screenshot()->write_optimized("$dir/standstill-1.png");sleep 1;
664                         mydie "standstill detected. test ended. see $filename\n"; # above 120s of autoreboot
665                 }
666         }
667         else { # new
668                 $img->write($filename) || die "write $filename";
669                 $screenshotQueue->enqueue($filename);
670                 $lastscreenshot = $img;
671                 $lastscreenshotName = $filename;
672                 $lastscreenshotCount = 0;
673                 #my $ocr=get_ocr($img);
674                 #if($ocr) { diag "ocr: $ocr" }
675         }
676 }
677
678 sub do_start_audiocapture($) {
679         my $filename = shift;
680         fctlog('start_audiocapture', $filename);
681         $backend->start_audiocapture($filename);
682 }
683
684 sub do_stop_audiocapture($) {
685         my $index = shift;
686         fctlog('stop_audiocapture', $index);
687         $backend->stop_audiocapture($index);
688 }
689
690 sub alive() {
691         if(defined $backend) {
692                 # backend will kill me when
693                 # backend.run has been deleted
694                 return $backend->alive();
695         }
696         return 0;
697 }
698
699 # runtime information gathering functions end
700
701
702 # check functions (runtime and result-checks)
703
704 sub checkrefimgs($$$) {
705         my ($screenimg, $refimg, $flags) = @_;
706         my $screenppm = tinycv::read($screenimg);
707         my $refppm = tinycv::read($refimg);
708         if (!$screenppm || !$refppm) {
709                 return undef;
710         }
711         if ($flags=~m/t/) {
712                 # black/white => drop most background
713                 $screenppm->threshold(0x80);
714                 $refppm->threshold(0x80);
715         }
716         if ($flags=~m/f/) {
717                 # perform vector-based fuzzy matching using opencv
718                 return $screenppm->search_fuzzy($refppm);
719         }
720         elsif ($flags=~m/d/) {
721                 # allow difference of 40 per byte
722                 return $screenppm->search($refppm, 40);
723         }
724         else {
725                 return $screenppm->search($refppm, 0);
726         }
727 }
728
729 sub get_ocr($) {
730         # input: tinycv object
731         my $img=shift;
732         my $ocr=ocr::get_ocr($img, "-m 2 -s 6", \@ocrrect);
733         if(!$ocr) {return ""}
734         $ocr=~s/^[_ \t\n]+//;
735         $ocr=~s/\n/ --- /g;
736         # correct common mis-readings:
737         $ocr=~s/nstaII/nstall/g;
738         $ocr=~s/l(install|Remaining)/($1/g;
739         return " ocr='$ocr'";
740 }
741
742 sub decodewav($) {
743         # FIXME: move to multimonNG (multimon fork)
744         my $wavfile = shift;
745         my $dtmf = '';
746         my $mm = "multimon -a DTMF -t wav $wavfile";
747         open M, "$mm |" || return 1;
748         while (<M>) {
749                 next unless /^DTMF: .$/;
750                 my ($a, $b) = split ':';
751                 $b =~ tr/0-9*#ABCD//csd; # Allow 0-9 * # A B C D
752                 $dtmf .= $b;
753         }
754         return $dtmf;
755 }
756
757 # check functions end
758
759
760 # wait functions
761
762 =head2 waitstillimage
763
764 waitstillimage([$stilltime_sec [, $timeout_sec [, $similarity_level]]])
765
766 Wait until the screen stops changing
767
768 =cut
769 sub waitstillimage(;$$$) {
770         my $stilltime=shift||7;
771         my $timeout=shift||30;
772         my $similarity_level=shift||47;
773         my $starttime=time;
774         fctlog('waitstillimage', "stilltime=$stilltime", "timeout=$timeout", "simlvl=$similarity_level");
775         my $lastchangetime=time;        
776         my $lastchangeimg = getcurrentscreenshot();
777         while(time-$starttime<$timeout) {
778                 my $img=getcurrentscreenshot();
779                 my $sim = $img->similarity($lastchangeimg);
780                 if ($sim < $similarity_level) {
781                         # a change
782                         $lastchangetime=time;
783                         $lastchangeimg=$img;
784                 }
785                 if (time-$lastchangetime>=$stilltime) {
786                                 fctres('waitstillimage', "detected same image for $stilltime seconds");
787                                 return 1;
788                 }
789                 sleep(0.5);
790         }
791         timeout_screenshot();
792         fctres('waitstillimage', "waitstillimage timed out after $timeout");
793         return 0;
794 }
795
796 sub waitimage($;$$) {
797         my $reflist = shift;
798         my $timeout = shift || 60;
799         my $flags = shift || 'd';
800         my $wact = ($flags=~m/s/)?'disappear':'appear';
801         fctlog('waitimage', "reflist=$reflist", "timeout=$timeout", "flags=$flags");
802         diag "WARNING: waitimage is no longer supported\n";
803         for(my $i=0;$i<=$timeout;$i+=2) {
804                 getcurrentscreenshot();
805                 sleep 1;
806         }
807         timeout_screenshot();
808         fctres('waitimage', "Waiting for images $reflist ($wact) timed out!");
809         return undef;
810 }
811
812 =head2 waitcolor
813
814 waitcolor($rgb_minmax [, $timeout_sec])
815
816 $rgb_minmax is  [[red_min,red_max], [green_min,green_max], [blue_min,blue_max]]
817 eg: [undef, [0.2, 0.7], [0,0.1]]
818
819 =cut
820 sub waitcolor($;$) {
821         my $rgb_minmax = shift;
822         my $timeout = shift || 30;
823         my $starttime = time;
824         fctlog('waitcolor', "rgb=".dump(@$rgb_minmax), "timeout=$timeout");
825         while(time-$starttime<$timeout) {
826                 if (check_color(\@lastavgcolor, $rgb_minmax)) {
827                         fctres('waitcolor', "detected ".dump(@lastavgcolor));
828                         return 1;
829                 }
830                 sleep 1;
831         }
832         timeout_screenshot();
833         fctres('waitcolor', "rgb ".dump(@$rgb_minmax)." timed out after $timeout");
834         return 0;
835 }
836
837 =head2 waitserial
838
839 waitserial($regex [, $timeout_sec])
840
841 Wait for a message to appear on serial output.
842 You could have sent it there earlier with
843
844 C<script_run("echo Hello World E<gt> /dev/$serialdev");>
845
846 =cut
847 sub waitserial($;$) {
848         # wait for a message to appear on serial output
849         my $regexp=shift;
850         my $timeout=shift||90; # seconds
851         fctlog('waitserial', "regex=$regexp", "timeout=$timeout");
852         for my $n (1..$timeout) {
853                 my $str=`tail $serialfile`;
854                 if($str=~m/$regexp/) {fctres('waitserial', "found $regexp"); return 1;}
855                 if($prestandstillwarning) {return 2}
856                 sleep 1;
857         }
858         fctres('waitserial', "$regexp timed out after $timeout");
859         return 0;
860 }
861
862 =head2 waitidle
863
864 waitidle([$timeout_sec])
865
866 Wait until the system becomes idle (as configured by IDLETHESHOLD in env.sh)
867
868 =cut
869 sub waitidle(;$) {
870         my $timeout=shift||19;
871         my $prev;
872         fctlog('waitidle', "timeout=$timeout");
873         return 0;
874         my $timesidle=0;
875         for my $n (1..$timeout) {
876                 my($stat, $systemstat) = $backend->cpu_stat();
877                 sleep 1; # sleep before skip to timeout when having no data (hw)
878                 next unless $stat;
879                 $stat += $systemstat;
880                 if($prev) {
881                         my $diff = $stat - $prev;
882                         if($diff<$idlethreshold) {
883                                 if(++$timesidle > $timesidleneeded) { # idle for $x sec
884                                 #if($diff<2000000) # idle for one sec
885                                         fctres('waitidle', "idle detected");
886                                         return 1;
887                                 }
888                         }
889                         else {$timesidle=0}
890                 }
891                 $prev = $stat;
892         }
893         fctres('waitidle', "timed out after $timeout");
894         return 0;
895 }
896
897 sub waitinststage($;$$) {
898         my $stage = shift;
899         my $timeout = shift||30;
900         my $extra = shift;
901         return waitforneedle($stage, $timeout, $extra);
902 }
903
904 sub _waitforneedle {
905         my %args = @_;
906         my $mustmatch = $args{'mustmatch'};
907         my $timeout = $args{'timeout'} || 30;
908
909         # get the array reference to all matching needles
910         my $needles;
911         if (ref($mustmatch) eq "ARRAY") {
912                 $needles = $mustmatch;
913                 for my $n (@{$needles}) {
914                         $mustmatch .= $n->{name} . "_";
915                 }
916         } elsif ($mustmatch) {
917                 $needles = needle::tags($mustmatch) || [];
918         }
919         fctlog('waitforneedle', "'$mustmatch'", "timeout=$timeout");
920         if (!@$needles) {
921                 printf "NO matching needles for $mustmatch\n";
922                 # give it some time to settle but not too much
923                 $timeout = 3;
924         }
925         my $img = getcurrentscreenshot();
926         my $oldimg;
927         for my $n (1..$timeout) {
928                 if (-e "waitneedlefail") {
929                         unlink("waitneedlefail");
930                         last;
931                 }
932                 if ($oldimg) {
933                         sleep 1;
934                         $img = getcurrentscreenshot();
935                         if ($oldimg == $img) { # no change, no need to search
936                                 printf "no change %d\n", $timeout-$n;
937                                 next;
938                         }
939                 }
940                 my $foundneedle = $img->search($needles);
941                 if ($foundneedle) {
942                         my $t = time();
943                         $img->write(result_dir() . "/match-$mustmatch-$t.png");
944                         fctres(sprintf("found %s, similarity %.2f @ %d/%d",
945                                 $foundneedle->{'needle'}->{'name'},
946                                 $foundneedle->{'similarity'},
947                                 $foundneedle->{'x'}, $foundneedle->{'y'}));
948                         if ($args{'click'}) {
949                                 my $rx = 1; # $origx / $img->xres();
950                                 my $ry = 1; # $origy / $img->yres();
951                                 my $x = ($foundneedle->{'x'} + $foundneedle->{'w'}/2)*$rx;
952                                 my $y = ($foundneedle->{'y'} + $foundneedle->{'h'}/2)*$ry;
953                                 diag ("clicking at $x/$y");
954                                 mouse_set($x, $y);
955                                 mouse_click($args{'click'}, $args{'clicktime'});
956                         }
957                         return $foundneedle;
958                 }
959                 $oldimg = $img;
960         }
961         fctres('waitforneedle', "match=$mustmatch timed out after $timeout");
962         for (@{$needles||[]}) {
963                 diag $_->{'file'};
964         }
965         my $t = time();
966         $img->write_optimized(result_dir() . "/template-$mustmatch-$t.png");
967         my $fn = result_dir() . "/template-$mustmatch-$t.json";
968         open(J, ">", $fn) or die "$fn: $!\n";
969         my $json = { area => [ { xpos => 0, ypos => 0, width => $img->xres(), height => $img->yres(), type => 'match' } ] };
970         my @tags = ( $mustmatch );
971         # write out some known env variables
972         for my $key (qw(VIDEOMODE DESKTOP DISTRI INSTLANG LIVECD)) {
973                 push(@tags, "ENV-$key-" . $ENV{$key}) if $ENV{$key};
974         }
975         $json->{"tags"} = \@tags;
976         print J JSON->new->pretty->encode( $json );
977         close(J);
978         diag("wrote $fn");
979
980         # beware of spaghetti code below
981         my $newname;
982         my $run_editor = 0;
983         if ($ENV{'scaledhack'}) {
984                 my $needle;
985                 for my $t (qw/.1 .2 .3 .4 .5 .6/) {
986                         diag("trying to find needle with threshold $t ...");
987                         my $foundneedle = $img->search($needles, $t);
988                         next unless $foundneedle;
989                         fctres(sprintf("found %s, similarity %.2f @ %d/%d",
990                                         $foundneedle->{'needle'}->{'name'},
991                                         $foundneedle->{'similarity'},
992                                         $foundneedle->{'x'}, $foundneedle->{'y'}));
993                         $needle = $foundneedle->{'needle'};
994                         last;
995                 }
996
997                 for my $i (1..@{$needles||[]}) {
998                         printf "%d - %s\n", $i, $needles->[$i-1]->{'name'};
999                 }
1000                 print "note: called from checkneedle()\n" if $args{'check'};
1001                 print "(E)dit, (N)ew, (Q)uit, (C)ontinue\n";
1002                 my $r = <STDIN>;
1003                 if ($r =~ /^(\d+)/) {
1004                         $r = 'e';
1005                         $needle = $needles->[$1-1];
1006                 }
1007                 if ($r =~ /^e/i) {
1008                         unless ($needle) {
1009                                 $needle = $needles->[0] if $needles;
1010                                 die "no needle\n" unless $needle;
1011                         }
1012                         $newname = $needle->{'name'};
1013                         $run_editor = 1;
1014                 } elsif ($r =~ /^n/i) {
1015                         $run_editor = 1;
1016                 } elsif ($r =~ /^q/i) {
1017                         $args{'retried'} = 99;
1018                 }
1019         } elsif (!$args{'check'} && $ENV{'interactive_crop'}) {
1020                 $run_editor = 1;
1021         }
1022
1023         $args{'retried'} ||= 0;
1024         if ($run_editor && $args{'retried'} < 3) {
1025                 $newname = $mustmatch.($ENV{'interactive_crop'} || '') unless $newname;
1026                 system("$scriptdir/crop.py", '--new', $newname, $fn) == 0 || mydie;
1027                 $fn = sprintf("%s/needles/%s.json", $ENV{'CASEDIR'}, $newname)
1028                 if (-e $fn);
1029                 {
1030                         for my $n (needle->all()) {
1031                                 if ($n->{'file'} eq $fn) {
1032                                         $n->unregister();
1033                                 }
1034                         }
1035                         diag("reading new needle $fn");
1036                         needle->new($fn) || mydie "$!";
1037                         # XXX: recursion!
1038                         return waitforneedle($mustmatch, 3, $args{'check'}, $args{'retried'}+1);
1039                 }
1040         }
1041         mydie unless $args{'check'};
1042         return undef;
1043 }
1044
1045 sub waitforneedle($;$) {
1046         return _waitforneedle(mustmatch => $_[0], timeout => $_[1]);
1047 }
1048
1049 sub checkneedle($;$) {
1050         return _waitforneedle(mustmatch => $_[0], timeout => $_[1], check => 1);
1051 }
1052
1053 # warning: will not work due to https://bugs.launchpad.net/qemu/+bug/752476
1054 sub goandclick($;$$$) {
1055         return _waitforneedle(mustmatch => $_[0],
1056                 click => ($_[1] || 'left'),
1057                 timeout => $_[2],
1058                 clicktime => $_[3]);
1059 }
1060
1061 #FIXME: new wait functions
1062 # waitscreenactive - ($backend->screenactive())
1063 # wait-time - like sleep but prints info to log
1064 # wait-screen-(un)-active to catch reboot of hardware
1065
1066 # wait functions end
1067
1068
1069 1;
1070
1071 # Local Variables:
1072 # tab-width: 8
1073 # cperl-indent-level: 8
1074 # End: