gitorious.org Git - os-autoinst:os-autoinst.git/blob

1 $|=1;

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;

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);

35 # shared vars

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);

46 # shared vars end

49 # global vars

51 our $logfd;

53 our $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK );

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;

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?$}{};

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};

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

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: