support German install keyboard shortcuts
[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 Exporter;
10 use ppm;
11 use ocr;
12 use threads;
13 use threads::shared;
14 use POSIX; 
15 our $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK );
16 my $goodimageseen :shared = 0;
17 my $endreadingcon :shared = 0;
18 my $lastname;
19 my $lastinststage :shared = "";
20 my $lastknowninststage :shared = "";
21 my $prestandstillwarning :shared = 0;
22 my $timeoutcounter :shared = 0;
23
24 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
25 @ISA = qw(Exporter);
26 @EXPORT = qw($realname $username $password $qemubin $qemupid $scriptdir $testresults $serialdev $testedversion %cmd 
27 &diag &fileContent &qemusend_nolog &qemusend &sendkey &sendautotype &sendpassword &mousemove_raw &mousemove &mouseclick &qemualive &result_dir 
28 &timeout_screenshot &waitidle &waitserial &waitgoodimage &waitinststage &open_management_console &close_management_console &set_hash_rects &set_ocr_rect &get_ocr &script_run &script_sudo &script_sudo_logout &x11_start_program);
29
30
31 our $debug=1;
32 our $idlethreshold=($ENV{IDLETHESHOLD}||18)*$clock_ticks/100; # % load max for being considered idle
33 our $timesidleneeded=2;
34 our $standstillthreshold=530;
35 our $realname="Bernhard M. Wiedemann";
36 our $username="bernhard";
37 our $password="nots3cr3t";
38 our $qemubin="/usr/bin/kvm";
39 our $qemupid;
40 our $gocrbin="/usr/bin/gocr";
41 our $qemupidfilename="qemu.pid";
42 our $testresults="testresults";
43 our $serialdev="ttyS0";
44 our $serialfile="serial0";
45 $ENV{QEMUPORT}||=15222;
46 our $managementcon;
47 share($ENV{SCREENSHOTINTERVAL}); # to adjust at runtime
48 our $scriptdir=$0; $scriptdir=~s{/[^/]+$}{};
49 our $testedversion=$ENV{ISO}||""; $testedversion=~s{.*/}{};$testedversion=~s/\.iso$//; $testedversion=~s{^([^.]+?)(?:-Media)?$}{$1};
50 if($testedversion=~m/^(debian|openSUSE|Fedora)-/) {$ENV{DISTRI}=lc($1)}
51 my @ocrrect; share(@ocrrect);
52 my @extrahashrects; share(@extrahashrects);
53 our @keyhistory;
54 our %cmd=qw(
55 next alt-n
56 install alt-i
57 finish alt-f
58 accept alt-a
59 createpartsetup alt-c
60 custompart alt-c
61 addpart alt-d
62 donotformat alt-d
63 addraid alt-i
64 add alt-a
65 raid0 alt-0
66 raid1 alt-1
67 raid5 alt-5
68 raid6 alt-6
69 raid10 alt-i
70 mountpoint alt-m
71 filesystem alt-s
72 acceptlicense alt-a
73 instdetails alt-d
74 rebootnow alt-n
75 otherrootpw alt-s
76 change alt-c
77 software s
78 );
79
80
81 $ENV{INSTLANG}||="en_US";
82 if($ENV{INSTLANG} eq "de_DE") {
83         $cmd{"next"}="alt-w";
84         $cmd{"createpartsetup"}="alt-e";
85         $cmd{"custompart"}="alt-b";
86         $cmd{"addpart"}="alt-h";
87         $cmd{"finish"}="alt-b";
88         $cmd{"accept"}="alt-r";
89         $cmd{"donotformat"}="alt-n";
90         $cmd{"add"}="alt-h";
91 #       $cmd{"raid6"}="alt-d"; 11.2 only
92         $cmd{"raid10"}="alt-r";
93         $cmd{"mountpoint"}="alt-e";
94         $cmd{"rebootnow"}="alt-j";
95         $cmd{"otherrootpw"}="alt-e";
96         $cmd{"change"}="alt-n";
97         $cmd{"software"}="w";
98 }
99
100 if(!-x $gocrbin) {$gocrbin=undef}
101 if(!-x $qemubin) {$qemubin=~s/kvm/qemu-kvm/}
102 if(!-x $qemubin) {$qemubin=~s/-kvm//}
103 if(!-x $qemubin) {die "no Qemu/KVM found"}
104 if($ENV{SUSEMIRROR} && $ENV{SUSEMIRROR}=~s{^(\w+)://}{}) { # strip & check proto
105         if($1 ne "http") {die "only http mirror URLs are currently supported but found '$1'."}
106 }
107
108
109 sub diag($)
110 { print LOG "@_\n"; return unless $debug; print STDERR "@_\n";}
111
112 sub mydie($)
113 { kill(15, $qemupid); unlink($qemupidfilename); diag "@_"; close LOG; sleep 1 ; exit 1; }
114
115 sub fileContent($) {my($fn)=@_;
116         open(my $fd, $fn) or return undef;
117         local $/;
118         my $result=<$fd>;
119         close($fd);
120         return $result;
121 }
122
123 sub qemusend_nolog($)
124 {
125         print $managementcon shift(@_)."\n";
126 }
127 sub qemusend($)
128 {
129         print LOG "qemusend: $_[0]\n";
130         &qemusend_nolog;
131 }
132
133 sub sendkey($)
134 {
135         my $key=shift;
136         qemusend "sendkey $key";
137         my @t=gettimeofday();
138         push(@keyhistory, [$t[0]*1000000+$t[1], $key]);
139         sleep(0.25);
140 }
141
142 my %charmap=(","=>"comma", "."=>"dot", "/"=>"slash", "="=>"equal", "-"=>"minus", "*"=>"asterisk", 
143    "["=>"bracket_left", "]"=>"bracket_right",
144    "{"=>"shift-bracket_left", "}"=>"shift-bracket_right",
145    "\\"=>"backslash", "|"=>"shift-backslash",
146    ";"=>"semicolon", ":"=>"shift-semicolon",
147    "'"=>"apostrophe", '"'=>"shift-apostrophe",
148    "`"=>"grave_accent", "~"=>"shift-grave_accent",
149    "<"=>"shift-comma", ">"=>"shift-dot",
150    "+"=>"shift-equal", "_"=>"shift-minus", '?'=>"shift-slash",
151    "\t"=>"tab", "\n"=>"ret", " "=>"spc", "\b"=>"backspace", "\e"=>"esc");
152 for my $c ("A".."Z") {$charmap{$c}="shift-\L$c"}
153 {
154         my $n=0;
155         for my $c (')','!','@','#','$','%','^','&','*','(') {$charmap{$c}="shift-".($n++)}
156 }
157
158
159 sub sendautotype($)
160 {
161         my $string=shift;
162         diag "sendautotype '$string'";
163         foreach my $letter (split("", $string)) {
164                 if($charmap{$letter}) { $letter=$charmap{$letter} }
165                 sendkey $letter;
166         }
167 }
168
169 sub sendpassword()
170 {
171         sendautotype($password);
172 }
173
174 sub autotype($)
175 {
176         my $string=shift;
177         my $result="";
178         foreach my $letter (split("", $string)) {
179                 $result.="sendkey $letter\n";
180         }
181         return $result;
182 }
183
184 sub mousemove_raw($$)
185 {
186         qemusend "mouse_move @_";
187         sleep 0.5;
188 }
189
190 # send mouse move via emulated touch screen
191 # in: x,y coords in pixels
192 sub mousemove($$)
193 { my(@coord)=@_;
194         my @size=(800,600);
195         my $maxtouch=0x7fff;
196         # transform to touchscreen coords (0..$maxtouch)
197         for my $i (0..1) {$coord[$i]=int($coord[$i]*$maxtouch/$size[$i])}
198         mousemove_raw($coord[0], $coord[1]);
199 }
200
201 # send mouse click
202 # in: button (default:L=1; R=2; M=4), duration of click (default: 0.15 sec)
203 # still broken for some reason (Qemu?)
204 sub mouseclick(;$$)
205 {
206         my $button=shift||1;
207         my $time=shift||0.15;
208         qemusend "mouse_button $button";
209         sleep $time;
210         qemusend "mouse_button 0";
211 }
212
213 my $n=0;
214 my %md5file;
215 our %md5badlist=qw();
216 our %md5goodlist;
217 our %md5inststage;
218 do "goodimage.pm"; # fill above vars
219 my $readconthread;
220 my $conmuxthread;
221
222 sub set_hash_rects
223
224         # sharing nested structure does not work, so turn arrayref into string
225         @extrahashrects=map {join(",", @$_)} @_;
226 }
227
228 sub set_ocr_rect
229 {
230         @ocrrect=@_;
231 }
232 # input: ref on PPM data
233 sub get_ocr($)
234 { my $dataref=shift;
235         my $ocr=ocr::get_ocr($dataref, "-m 2 -s 6", \@ocrrect);
236         if(!$ocr) {return ""}
237         $ocr=~s/^[_ \t\n]+//;
238         $ocr=~s/\n/ --- /g;
239         # correct common mis-readings:
240         $ocr=~s/nstaII/nstall/g;
241         $ocr=~s/l(install|Remaining)/($1/g;
242         return " ocr='$ocr'";
243 }
244
245 sub hashrect($$$)
246 { my($ppm,$rect,$flags)=@_;
247         my $ppm2=$ppm->copyrect(@$rect);
248         my @result;
249         return unless $ppm2;
250         if($flags=~m/r/) {$ppm2->replacerect(0,137,13,15);} # mask out text
251         if($flags=~m/c/) {push(@result, [Digest::MD5::md5_hex($ppm2->{data}),$rect,$flags])} # extra coloured version hash
252         if($flags=~m/t/) {$ppm2->threshold(0x80);} # black/white => drop most background
253         return (@result,[Digest::MD5::md5_hex($ppm2->{data}),$rect,$flags]);
254 }
255
256 my %goodsizes=(1440015=>1, 2359312=>1);
257
258 # input: ref on PPM data
259 sub inststagedetect($)
260 { my $dataref=shift;
261         return if !$goodsizes{length($$dataref)}; # only work on images of 800x600 and 1024x768
262         my $ppm=ppm->new($$dataref);
263         return unless $ppm;
264         my @md5=();
265         # use several relevant non-text parts of the screen to look them up
266         # WARNING: some break when background/theme changes (%md5inststage needs updating)
267         # popup text detector
268         push(@md5, hashrect($ppm, [230,230, 300,100], "t"));
269         # smaller popup text detector
270         push(@md5, hashrect($ppm, [300,240, 100,100], "t"));
271         # use header text for GNOME-installer
272         push(@md5, hashrect($ppm, [0,0, 250,30], "t"));
273         # KDE/NET/DVD detect checks on left
274         push(@md5, hashrect($ppm, [27,128,13,200], "rct"));
275         
276         foreach my $rect (@extrahashrects) {
277                 next unless $rect;
278                 my @r=split(",", $rect);
279                 push(@md5, hashrect($ppm, \@r, ""));
280         }
281
282         my $found=0;
283         foreach my $md5e (@md5) {
284                 my($md5,$rect,$flags)=@$md5e;
285                 my $currentinststage=$md5inststage{$md5}||"";
286                 diag "stage=$currentinststage $md5 ".join(",",@$rect)." $flags";
287                 next if $found;
288                 if($currentinststage) { $lastknowninststage=$lastinststage=$currentinststage }
289                 if($currentinststage){$found=1}; # stop on first match - so must put most specific tests first
290         }
291         if($found) {return}
292         $lastinststage="unknown";
293 }
294
295 sub result_dir()
296 {
297         mkdir $testresults;
298         mkdir "$testresults/$testedversion";
299         "$testresults/$testedversion"
300 }
301
302 sub do_take_screenshot($)
303 { my($filename)=@_;
304         qemusend "screendump $filename";
305 }
306 sub timeout_screenshot()
307 {
308         my $n=++$timeoutcounter;
309         my $dir=result_dir;
310         do_take_screenshot("$dir/timeout-$n.ppm");
311 }
312
313 my $framecounter=0;
314 sub take_screenshot()
315 {
316         my $path="qemuscreenshot/";
317         mkdir $path;
318         if($lastname && -e $lastname) { # processing previous image, because saving takes time
319                 # hardlinking identical files saves space
320                 my $data=fileContent($lastname);
321                 my $md5=Digest::MD5::md5_hex($data);
322                 if($md5badlist{$md5}) {diag "error condition detected. test failed. see $lastname"; sleep 1; mydie "bad image seen"}
323                 my($statuser,$statsystem)=proc_stat_cpu($qemupid);
324                 for($statuser,$statsystem) {$_/=$clock_ticks}
325                 diag("md5=$md5 laststage=$lastinststage statuser=$statuser statsystem=$statsystem");
326                 if($md5goodlist{$md5}) {$goodimageseen=1; diag "good image"}
327                 # ignore bottom 15 lines (blinking cursor, animated mouse-pointer)
328                 if(length($data)==1440015) {$md5=Digest::MD5::md5(substr($data,15,800*3*(600-15)))}
329                 if($md5file{$md5}) { # old
330                         unlink($lastname); # warning: will break if FS does not support hardlinking
331                         link($md5file{$md5}->[0], $lastname);
332                         my $linkcount=$md5file{$md5}->[1]++;
333                         #my $linkcount=(stat($lastname))[3]; # relies on FS
334                         $prestandstillwarning=($linkcount>$standstillthreshold/2);
335                         if($linkcount>$standstillthreshold) { 
336                                 timeout_screenshot(); sleep 1;
337                                 mydie "standstill detected. test ended. see $lastname\n"; # above 120s of autoreboot
338                         }
339                 } else { # new
340                         $md5file{$md5}=[$lastname,1];
341                         my $ocr=get_ocr(\$data);
342                         if($ocr) { diag $ocr }
343                         inststagedetect(\$data);
344                 }
345                 if(($framecounter++ < 10) && length($data)<800*600*3) {unlink($lastname)}
346         }
347         my $t=[gettimeofday()];
348         my $filename=$path.sprintf("%i.%06i.ppm", $t->[0], $t->[1]);
349         #print STDERR $filename,"\n";
350         do_take_screenshot($filename);
351         $lastname=$filename;
352 }
353
354 sub qemualive()
355
356         if(!$qemupid) {($qemupid=fileContent($qemupidfilename)) && chomp $qemupid;}
357         return 0 unless $qemupid;
358         kill 0, $qemupid;
359 }
360
361 # input: PID (process identifier)
362 # output: user/system clock_ticks used
363 sub proc_stat_cpu($)
364 { my $pid=shift;
365         my $stat=fileContent("/proc/$pid/stat");
366         my @a=split(" ", $stat);
367         return @a[13,14];
368 }
369
370 # wait for a message to appear on serial output
371 sub waitserial($;$)
372 { my $regexp=shift;
373   my $timeout=shift||90; # seconds
374         for my $n (1..$timeout) {
375                 my $str=`tail $serialfile`;
376                 if($str=~m/$regexp/) {diag "found $regexp"; return 1;}
377                 sleep 1;
378         }
379         return 0;
380 }
381
382 sub waitidle(;$)
383 {
384         my $timeout=shift||19;
385         my $prev;
386         diag "waitidle(timeout=$timeout)";
387         my $timesidle=0;
388         for my $n (1..$timeout) {
389                 my($stat,$systemstat)=proc_stat_cpu($qemupid);
390                 next unless $stat;
391                 $stat+=$systemstat;
392                 if($prev) {
393                         my $diff=$stat-$prev;
394                         if($diff<$idlethreshold) {
395                                 if(++$timesidle>$timesidleneeded) { # idle for $x sec
396                                 #if($diff<2000000) # idle for one sec
397                                         diag "idle detected";
398                                         return 1;
399                                 }
400                         } else {$timesidle=0}
401                 }
402                 $prev=$stat;
403                 sleep 1;
404         }
405         diag "waitidle timed out";
406         return 0;
407 }
408
409 sub waitgoodimage(;$)
410 {
411         my $timeout=shift||10;
412         $goodimageseen=0;
413         diag "waiting for good image(timeout=$timeout)";
414         for my $n (1..$timeout) {
415                 if($goodimageseen) {diag "seen good image... continuing execution"; return 1;}
416                 sleep 1;
417         }
418         timeout_screenshot();
419         diag "waitgoodimage timed out";
420         return 0;
421 }
422
423 sub waitinststage($;$$)
424 {
425         my $stage=shift;
426         my $timeout=shift||30;
427         my $extradelay=shift||3;
428         diag "start waiting $timeout seconds for stage=$stage";
429         if($prestandstillwarning) { sleep 3 }
430         for my $n (1..$timeout) {
431                 if($lastinststage=~m/$stage/) {diag "detected stage=$stage ... continuing execution"; sleep $extradelay; return 1;}
432                 if($prestandstillwarning) {
433                         timeout_screenshot();
434                         diag "WARNING: waited too long for stage=$stage";
435                         $prestandstillwarning=0;
436                         return 2;
437                 }
438                 sleep 1;
439         }
440         timeout_screenshot() if($timeout>1);
441         diag "waitinststage stage=$stage timed out after $timeout";
442         return 0;
443 }
444
445
446 sub handlemuxcon($)
447 { my $conn=shift;
448         while(<$conn>) {
449                 chomp;
450                 qemusend $_;
451         }
452 }
453
454 # accept connections and forward to management console
455 sub conmuxloop
456 {
457         my $listen_sock=IO::Socket::INET->new(
458                 Listen    => 1,
459         #       LocalAddr => 'localhost',
460                 LocalPort => $ENV{QEMUPORT}+1,
461                 Proto     => 'tcp',
462                 ReUseAddr => 1,
463         );
464
465         while(my $conn=$listen_sock->accept()) {
466                 # launch one thread per connection
467                 my $thr=threads->create(\&handlemuxcon, $conn);
468                 $thr->detach();
469         }
470 }
471
472 # read all output from management console and forward it to STDOUT
473 sub readconloop
474 {
475         $|=1;
476         while(<$managementcon>) {
477                 print $_;
478                 last if($endreadingcon);
479         }
480         diag "exiting management console read loop";
481         unlink $qemupidfilename;
482         alarm 3; # kill all extra threads soon
483 }
484
485 sub open_management_console()
486 {
487         open(LOG, ">>", "currentautoinst-log.txt");
488         # set unbuffered so that sendkey lines from main thread will be written
489         my $oldfh=select(LOG); $|=1; select($oldfh);
490
491         $managementcon=IO::Socket::INET->new("localhost:$ENV{QEMUPORT}") or mydie "error opening management console: $!";
492         $endreadingcon=0;
493         select($managementcon); $|=1; select($oldfh); # autoflush
494         $conmuxthread=threads->create(\&conmuxloop); # allow external qemu input
495         $conmuxthread->detach();
496         $readconthread=threads->create(\&readconloop); # without this, qemu will block
497         $readconthread->detach();
498         $managementcon;
499 }
500
501 sub close_management_console()
502 {
503         $endreadingcon=1;
504         qemusend "";
505         close $managementcon;
506 }
507
508 # start console application
509 sub script_run($;$)
510 { my $name=shift; my $wait=shift;
511         waitidle;
512         sendautotype("$name\n");
513         waitidle $wait;
514         sleep 3;
515 }
516
517 my $sudotimeout=300; # 5 mins
518 my $lastsudotime;
519 my $sudos=0;
520 sub script_sudo($;$)
521 { my ($prog,$wait)=@_;
522         sendautotype("sudo $prog\n");
523         if(!$lastsudotime||$lastsudotime+$sudotimeout<time()) {$sudos=0}
524         if($password && !$sudos++) {
525                 waitidle;
526                 sendpassword;
527                 sendkey "ret";
528         }
529         $lastsudotime=time();
530         waitidle $wait;
531 }
532 # reset so that next sudo will send password
533 sub script_sudo_logout()
534 { $sudos=0 }
535
536
537 sub x11_start_program($)
538 { my $program=shift;
539         sendkey "alt-f2"; sleep 2;
540         sendautotype $program; sleep 1;
541         sendkey "ret";
542         waitidle;
543         sleep 1;
544 }
545
546 1;