ltpmenu2

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Curses::UI();
   5 use File::Temp();
   6 use diagnostics;
   7
   8 use Carp ();
   9 local $SIG{__WARN__} = \&Carp::cluck;
  10
  11 package LTPTests;
  12 use List::MoreUtils qw/any uniq/;
  13
  14 my $runtest_dir="/usr/lib/ltp/runtest";
  15 #my $runtest_dir="runtest";
  16 my %static_env = (
  17     LTPRESULTS => "/var/cache/ltp/results",
  18     LTPROOT => "/usr/lib/ltp",
  19     TOOLSDIR => "/usr/lib/ltp/tools",
  20     LTPTOOLS => "/usr/lib/ltp/tools",
  21     PATH => "$ENV{PATH}:/usr/lib/ltp/testcases/bin",
  22     TMP => $ENV{TMP} // $ENV{TMPDIR} // "/tmp",
  23     TMPDIR => $ENV{TMP} // $ENV{TMPDIR} // "/tmp",
  24     TMPFILE => undef,
  25     );
  26 my @test_data = ();
  27
  28 sub shell_quote
  29 {
  30     my $arg=shift;
  31     $arg =~ s/'/'\\''/;
  32     return "'$arg'";
  33 }
  34
  35 sub to_number
  36 {
  37     my $arg=shift;
  38     return $arg if $arg =~ /^\d+$/;
  39     return 0;
  40 }
  41
  42 sub execute_tests
  43 {
  44     my ($used_tests, $environment, $setup, $teardown) = @_;
  45     my $panopts="";
  46     my $tdir;
  47     for(keys %$environment) {
  48         if (/^\$/) {
  49             my $value=$environment->{$_};
  50             s/^\$//;
  51             $ENV{$_}=$value;
  52         }
  53     }
  54     for(keys %static_env) {
  55         my $value=$static_env{$_};
  56         $ENV{$_}=$value;
  57     }
  58     if(($environment->{output} // "") ne "") {
  59         $tdir=File::Temp::tempdir(CLEANUP => 1);
  60         $panopts.=" -o ".shell_quote($environment->{output})." -O ".shell_quote($tdir);
  61     }
  62
  63     if(!$environment->{fulloutput}) {
  64         $panopts.=" -q ";
  65     }
  66
  67     if(($environment->{failfile} // "") ne "") {
  68         my $ff=$environment->{failfile};
  69         my $out=$environment->{output}//"";
  70         $out =~ s/^.*\///;
  71         $ff =~ s/%s/$out/;
  72         my $now = localtime;
  73         $ff =~ s/%d/$now/;
  74         $panopts.=" -C ".shell_quote($ff);
  75     }
  76
  77     if(($environment->{logfile} // "") ne "") {
  78         my $ff=$environment->{logfile};
  79         my $out=$environment->{output}//"";
  80         $out =~ s/^.*\///;
  81         $ff =~ s/%s/$out/;
  82         my $now = localtime;
  83         $ff =~ s/%d/$now/;
  84         $panopts.=" -l ".shell_quote($ff);
  85     }
  86
  87     my $count;
  88     if(($environment->{count} // "") ne "") {
  89         $count=$environment->{count};
  90         if($count =~ /^(\d)l$/) {
  91             $count=$1*@$used_tests;
  92         }
  93         $count=to_number($count);
  94     }
  95     if($environment->{random}) {
  96         $count = $count // scalar @$used_tests;
  97     }
  98
  99     if(!($environment->{random})) {
 100         $panopts.=" -S";
 101     }
 102
 103     if(defined($count)) {
 104         $panopts.=" -s ".$count;
 105     }
 106
 107     if(($environment->{time} // "") ne "") {
 108         return if !$environment->{time} =~ /[0-9]+[hmsd]?/;
 109         $panopts.=" -t ".$environment->{time};
 110     }
 111
 112     if(($environment->{parallel} // "") ne "") {
 113         $panopts.=" -x ".to_number ($environment->{parallel} // 0);
 114     }
 115
 116     my $ft=new File::Temp(TEMPLATE => "/tmp/runtestXXXXXXXXX");
 117     my $zoo=new File::Temp(TEMPLATE => "/tmp/zoo$$.XXXXXXXXX");
 118     local $,="\n";
 119     print $ft map { "$_->{id} $_->{command}" } @$used_tests;
 120     $ft->flush;
 121     system "@$setup";
 122     system '${LTPTOOLS}/ltp-pan -p -n $$ -a '.$zoo->filename.' -f '.$ft->filename.$panopts;
 123     system "@$teardown";
 124     File::Path::rmtree $tdir if defined($tdir);
 125 }
 126
 127 my %testsuites =();
 128 my %test_hash= ();
 129 sub load_file
 130 {
 131     my ($file)=@_;
 132     my $num=0;
 133     open(FILE, "<$file");
 134     my $name="$file";
 135     my $ts_desc={ selected => 0, tests => [] };
 136     my $allvars = [];
 137     my $allsetup = [];
 138
 139     my $last;
 140     my $comment=sub {
 141         if($1 =~ /DESCRIPTION:(.*)/) {
 142             $ts_desc->{description}=$1;
 143             $last=\$ts_desc->{description};
 144         } elsif ($1 =~ /ALL:(.*)/) {
 145             push @$allvars, grep m/./, (split qr/ +/, $1);
 146         } elsif ($1 =~ /SETUP:(.*)/) {
 147             push @$allsetup, grep m/./, (split qr/ +/, $1);
 148         } elsif ($1 eq "") {
 149             undef $last;
 150         } elsif(defined $last) {
 151             $$last.="\n". $1;
 152         }
 153
 154     };
 155     while(<FILE>) {
 156         if (/^#(.*)/) {
 157             $comment-> ($1);
 158             next;
 159         }
 160         next unless /^([^[:space:]]+)[[:space:]]+(.*)/;
 161         $comment-> ("");
 162         if(exists($test_hash{"$1 $2"})) {
 163             next if exists $test_hash{"$1 $2"}->{files}->{$name};
 164             push @{$ts_desc->{tests}}, $test_hash{"$1 $2"};
 165             $test_hash{"$1 $2"}->{files}->{$name}=undef;
 166             $ts_desc->{selected}++ if($test_hash{"$1 $2"}->{selected});
 167         } else {
 168             push(@test_data, { id => $1, command => $2,
 169                  files => {$name => undef}});
 170             my $id="$1 $2";
 171             $test_data[$#test_data]->{vars}=[(grep { /^\$(.*)/; !exists($static_env{$1}) } ( @$allvars, $2 =~ /\$[[:alpha:]][[:alnum:]_]*/g ))];
 172             $test_data[$#test_data]->{setup}=$allsetup;
 173             push @{$ts_desc->{tests}}, \%{$test_data[$#test_data]};
 174             $test_hash{$id}=\%{$test_data[$#test_data]};
 175             $testsuites{"<ALL>"}->{count}++;
 176         }
 177         $num++;
 178     }
 179     close (FILE);
 180     $ts_desc->{count}=$num;
 181     $testsuites{$name}=$ts_desc;
 182 }
 183
 184 sub load_available
 185 {
 186     $testsuites{"<ALL>"}={selected => 0, count => 0, tests => \@test_data};
 187
 188     my @files;
 189     opendir(DIR, $runtest_dir) || die("Couldn't open directory $runtest_dir");
 190     @files=readdir(DIR);
 191     closedir(DIR);
 192
 193     foreach(@files) {
 194         next if (/^\./);
 195         load_file("$runtest_dir/$_");
 196     }
 197
 198 }
 199
 200 sub flatten
 201 {
 202     return map { (ref($_) eq "ARRAY") ? flatten(@$_) : $_ } @_;
 203 }
 204
 205 sub needed_vars
 206 {
 207     my ($ts_list)=@_;
 208     return uniq(flatten(map $_->{vars}, @$ts_list));
 209 }
 210
 211 sub setup_scripts
 212 {
 213     my ($ts_list)=@_;
 214     return uniq(flatten(map $_->{setup}, @$ts_list));
 215 }
 216
 217 sub tests_needing_vars
 218 {
 219     my ($tests, @vars)=@_;
 220     my %vars_hash=(map { ($_ => undef) } @vars);
 221     return grep { any { exists($vars_hash{$_}) } @{$_->{vars}} } @$tests;
 222 }
 223
 224 load_available;
 225
 226 package Layout::Proportional;
 227
 228 use Curses::UI::Container;
 229
 230 our @ISA=qw/Curses::UI::Container/;
 231
 232 sub new {
 233     my $class = shift;
 234     my $self = $class->SUPER::new( @_, -layoutorder => [] );
 235     return $self;
 236 }
 237
 238 sub add {
 239     my $self=shift;
 240     my $ret=$self->SUPER::add(@_);
 241     push @{$self->{-layoutorder}}, $self->{-object2id}->{$ret};
 242     return $ret;
 243 }
 244
 245 sub layout {
 246     my $self = shift;
 247     $self->Curses::UI::Widget::layout();
 248
 249     my $size=($self->{-vertical} ? "height" : "width");
 250     my $coord=($self->{-vertical} ? "y" : "x");
 251     my $ot_size=($self->{-vertical} ? "width" : "height");
 252     my $ot_sz=($self->{-vertical} ? "w" : "h");
 253     my $ot_coord=($self->{-vertical} ? "x" : "y");
 254     my $padding=($self->{-vertical} ?
 255                  sub { my $obj=shift; return ($obj->{-padtop}//0)+($obj->{-padbottom}//0); } :
 256                  sub { my $obj=shift; return ($obj->{-padleft}//0)+($obj->{-padright}//0); });
 257     my $total_min=0;
 258     my $total_mult=0.0;
 259     my %sizes= ( height => $self->canvasheight(), width => $self->canvaswidth() );
 260     foreach(@{$self->{-layoutorder}}) {
 261         my $obj=$self->{-id2object}->{$_};
 262 # NOTE: if -min-$size is less than what's needed to accommodate the widget, you'll likely hit screen too small.
 263         $total_min += $obj->{"-min-$size"} if $obj->{"-min-$size"};
 264         $total_mult += $obj->{"-mult-$size"} if $obj->{"-mult-$size"};
 265     }
 266     my $excess = $sizes{$size}-$total_min;
 267     my $ratio=($total_mult==0 ? 0 : $excess/$total_mult);
 268
 269     my $cur=0;
 270     foreach(@{$self->{-layoutorder}}) {
 271         my $obj=$self->{-id2object}->{$_};
 272         $obj->{-$coord}=$cur;
 273         $obj->{-$ot_coord}=0;
 274         $obj->{-$size}=int (($obj->{"-min-$size"} // 0) + ($obj->{"-mult-$size"} // 0)*$ratio);
 275         $obj->{-$size} = 0 if $obj->{-$size} < 0;
 276         $obj->{-$ot_size} = $self->{-$ot_size};
 277         $obj->{-parent}=$self;
 278         $obj->layout();
 279         $cur += $obj->{-$size};
 280         $self->{-$ot_sz} = $obj->{-$ot_sz}
 281         if ($obj->{-$ot_sz} > $self->{-$ot_sz});
 282         $obj->intellidraw();
 283     }
 284     return $self;
 285 }
 286
 287 $INC{"Layout/Proportional.pm"}="";
 288
 289 package ListBox::MultiColumn;
 290
 291 use Curses::UI::Listbox;
 292
 293 our @ISA=qw/Curses::UI::Listbox/;
 294
 295 sub new {
 296     my $class = shift;
 297     my $self = $class->SUPER::new(
 298         -colwidth => [],
 299         "-col-designator" => [],
 300         @_
 301         );
 302     return $self;
 303 }
 304
 305 sub getcolwidth
 306 {
 307     my ($self, $col) = @_;
 308     return $self->{-colwidth}->[$col] if $self->{-colwidth}->[$col];
 309     return 10;
 310 }
 311
 312 sub getlabel {
 313     my ($self, $i) = @_;
 314     my $val = $self->values()->[$i];
 315     my @disp=();
 316     if(ref($val) eq "ARRAY") {
 317         for my $idx (0..$#$val-1) {
 318             my $len=$self->getcolwidth($idx);
 319             push (@disp, $$val[$idx]);
 320         }
 321         push (@disp, $$val[$#$val]);
 322     } elsif(ref($val) eq "HASH") {
 323         my $cd=$self->{"-col-designator"};
 324         return "" unless $cd;
 325         for my $idx (0..$#$cd-1) {
 326             my $len=$self->getcolwidth($idx);
 327             push (@disp, $val->{$cd->[$idx]});
 328         }
 329         push (@disp, $val->{$cd->[$#$cd]});
 330     } else {
 331         @disp=($self->SUPER::getlabel($i));
 332     }
 333     @disp=($self->{"-col-formatter"} ?
 334            $self->{"-col-formatter"}->(@disp) :
 335            @disp);
 336     for (0..$#disp-1) {
 337             my $len=$self->getcolwidth($_);
 338             $disp[$_] = sprintf("%-${len}.${len}s", $disp[$_]);
 339     }
 340     return join("|", @disp);
 341 }
 342
 343 $INC{"ListBox/MultiColumn.pm"}="";
 344
 345 package Container::Paged;
 346
 347 our @ISA=qw/Curses::UI::Container/;
 348
 349 sub new {
 350     my $class = shift;
 351     my $self = $class->SUPER::new(
 352         @_,
 353         -pageno => 0,
 354         -pagestart => [0],
 355         -pageend => undef,
 356         -layoutorder => [],
 357         -drawdisabled => 0
 358         );
 359     $self->set_binding(\&page_up, Curses::KEY_PPAGE);
 360     $self->set_binding(\&page_down, Curses::KEY_NPAGE);
 361     $self->{-morelabel}=$self->SUPER::add(undef, "Label",
 362                                       -text => "-- more (PgDn/PgUp) --"
 363         );
 364     return $self;
 365 }
 366
 367 sub add {
 368     my $self=shift;
 369     my $ret=$self->SUPER::add(@_);
 370     push @{$self->{-layoutorder}}, $ret;
 371     return $ret;
 372 }
 373
 374 sub page_up {
 375     my $self = shift;
 376     return if $self->{-pageno}<=0;
 377     $self->{-pageno}--;
 378     $self->{-canvasscr}->erase();
 379     $self->layout();
 380     $self->intellidraw();
 381 }
 382
 383 sub page_down {
 384     my $self = shift;
 385     return if $self->{-pageend}>$#{$self->{-layoutorder}};
 386     $self->{-pageno}++;
 387     $self->{-pagestart}->[$self->{-pageno}] = $self->{-pageend};
 388     $self->{-canvasscr}->erase();
 389     $self->layout();
 390     $self->intellidraw();
 391 }
 392
 393 sub layout {
 394     my $self = shift;
 395     $self->Curses::UI::Widget::layout();
 396
 397     my $line = 0;
 398     my $saved_screen_too_small = $Curses::UI::screen_too_small;
 399     my $last_widget = $#{$self->{-layoutorder}}+1;
 400     my $page_start = $self->{-pagestart}->[$self->{-pageno}];
 401     for my $widget_idx ($page_start..$#{$self->{-layoutorder}}) {
 402         my $widget=$self->{-layoutorder}->[$widget_idx];
 403         $widget->{-y}=$line;
 404         $widget->show();
 405         $widget->layout();
 406
 407         if($Curses::UI::screen_too_small != $saved_screen_too_small) {
 408             $last_widget = $widget_idx;
 409             last;
 410         }
 411         $line += $widget->height();
 412     }
 413
 414     if ($last_widget > $page_start+1 && $last_widget <= $#{$self->{-layoutorder}} && $line>=$self->{-h}) {
 415         $last_widget--;
 416     }
 417
 418     $self->{-pageend}=$last_widget;
 419     $Curses::UI::screen_too_small = $saved_screen_too_small;
 420
 421     my @label_arr=();
 422     if ($last_widget <= $#{$self->{-layoutorder}}) {
 423         $self->{-morelabel}->{-x}=($self->{-w}-$self->{-morelabel}->{-w})/2;
 424         $self->{-morelabel}->{-y}=$self->{-h}-1;
 425         $self->{-morelabel}->layout;
 426         push @label_arr, $self->{-morelabel};
 427     }
 428
 429     for (@{$self->{-layoutorder}}[0..$page_start-1]) {
 430         $_->hide();
 431     }
 432
 433     if ($last_widget >= 0 && $last_widget<=$#{$self->{-layoutorder}}) {
 434         for (@{$self->{-layoutorder}}[$last_widget..$#{$self->{-layoutorder}}]) {
 435             $_->hide();
 436         }
 437     }
 438
 439     $Curses::UI::screen_too_small++
 440         if($last_widget > 0 && $page_start==$last_widget);
 441
 442     $self->set_draworder(map $self->{-object2id}->{$_}, @label_arr, @{$self->{-layoutorder}}[$page_start..$last_widget-1]);
 443     $self->focus($self->{-layoutorder}->[$page_start])
 444         if defined $self->{-layoutorder}->[$page_start];
 445     return $self;
 446 }
 447
 448 sub disable_draw
 449 {
 450     shift()->{-drawdisabled}++;
 451 }
 452
 453 sub enable_draw
 454 {
 455     my $self=shift;
 456     $self->{-drawdisabled}--;
 457     $self->intellidraw;
 458 }
 459
 460 sub draw
 461 {
 462     my $self=shift;
 463     return $self->SUPER::draw(@_)
 464         unless $self->{-drawdisabled};
 465 }
 466
 467 sub focus {
 468     my $self=shift;
 469     my $page_start=$self->{-pagestart}->[$self->{-pageno}];
 470     my $last_widget=$self->{-pageend};
 471     my $last_draworder=$self->{-draworder};
 472
 473     return $self->SUPER::focus(@_) unless $#{$self->{-draworder}}>=0;
 474     $self->disable_draw;
 475
 476     $self->set_draworder(grep ($self->{-draworder}->[-1] ne $_, map $self->{-object2id}->{$_}, @{$self->{-layoutorder}}), $self->{-draworder}->[-1]);
 477     $self->SUPER::focus(@_);
 478
 479     my $new_focus=$self->{-object2id}->{$self->getfocusobj};
 480     my $i=0;
 481     for my $j (0..$#{$self->{-layoutorder}}) {
 482         $i=$j;
 483         last if $self->{-object2id}->{$self->{-layoutorder}->[$i]} eq $new_focus;
 484     }
 485
 486     if ($i>=$page_start && $i<$last_widget) {
 487         $self->set_draworder(grep ($self->{-draworder}->[-1] ne $_, @$last_draworder), $self->{-draworder}->[-1]);
 488         $self->enable_draw;
 489         return;
 490     }
 491
 492     if($i>=$last_widget) {
 493         while($i>=$self->{-pageend}) {
 494             $self->page_down;
 495         }
 496     } else {
 497         while($i<$self->{-pagestart}->[$self->{-pageno}]) {
 498             $self->page_up;
 499         }
 500     }
 501     $self->enable_draw;
 502     $self->focus(@_);
 503
 504 }
 505
 506 $INC{"Container/Paged.pm"}="";
 507
 508 package main;
 509 use List::MoreUtils qw/any/;
 510
 511 #######
 512 # TUI #
 513 #######
 514
 515 my $cui = new Curses::UI (
 516     -clear_on_exit => 1
 517 );
 518 my $tc_list;
 519 my $ts_list;
 520 my $win;
 521
 522 my @opt_template = (
 523     simple_text(label => "Output file", name => "output"),
 524     simple_text(label => "Log file", name => "logfile"),
 525     simple_text(label => "Failed command file", name => "failfile"),
 526     simple_text(label => "Running time", name => "time", validator => '/^\d*[hdms]?$/'),
 527     simple_text(label => "Parallel tests", name => "parallel", validator => '/^\d*$/'),
 528     simple_check(label => "Random tests", name => "random"),
 529     simple_check(label => "Full Output", name => "fulloutput"),
 530     simple_text(label => "Test count", name => "count", validator => '/^\d*l?$/'),
 531     );
 532
 533 my %options =( failfile => "/var/tmp/LTP_RUN_ON_%d.failed",
 534                logfile => "/var/tmp/LTP_RUN_ON_%d.log" );
 535
 536 sub simple_text {
 537     my %params=@_;
 538     return { label => $params{label}, name => $params{name},
 539              create => sub {
 540                  my ($parent, $data, @params) = @_;
 541                  @params=(@params, -regexp => $params{validator}) if exists $params{validator};
 542                  my $lab=$parent->add(undef, "TextEntry", @params);
 543                  $lab->text($data) if defined $data;
 544                  return $lab;
 545              },
 546              get => sub { return shift()->get(); }
 547     };
 548
 549 }
 550
 551 sub simple_check {
 552     my %params=@_;
 553     return { label => $params{label}, name => $params{name},
 554              create => sub {
 555                  my ($parent, $data, @params) = @_;
 556                  my $lab=$parent->add(undef, "Checkbox", @params);
 557                  $lab->check() if $data;
 558                  return $lab;
 559              },
 560              get => sub { return shift()->get(); }
 561     };
 562
 563 }
 564
 565 sub show_opt_dialog
 566 {
 567     options_dialog([@opt_template, map {
 568         +{
 569             label => $_, name => $_,
 570             create => sub {
 571                 my ($parent, $data, @params) = @_;
 572                 my $lab=$parent->add(undef, "TextEntry", @params);
 573                 $lab->text($data) if defined $data;
 574                 return $lab;
 575             },
 576             get => sub { return shift()->get(); }
 577         }
 578                     } LTPTests::needed_vars [grep { $_->{selected} } @test_data]], \%options);
 579 }
 580
 581 sub execute_tests
 582 {
 583     my $selected_tests=[grep { $_->{selected} } @test_data];
 584     my @needed_vars=LTPTests::needed_vars $selected_tests;
 585     my @unsatisfied_tests=LTPTests::tests_needing_vars $selected_tests, (grep !$options{$_}, @needed_vars);
 586     if(@unsatisfied_tests) {
 587         my $response=$cui->dialog(
 588             -message => "You have sellected tests that need setting some variables. Would you like to set them now?",
 589             -buttons => [
 590                  {-label => "Show the options dialog", -value => 0},
 591                  {-label => "Don't run those tests", -value => 1},
 592                  {-label => "Cancel", -value => 2}
 593             ],
 594             -title => "Unset variables"
 595             );
 596         return if($response == 2);
 597         if($response==0) {
 598             show_opt_dialog;
 599         } else { # filter tests
 600             $selected_tests=[grep { !any { !$options{$_} } LTPTests::needed_vars [$_] } @$selected_tests ];
 601         }
 602     }
 603     my @setups = LTPTests::setup_scripts $selected_tests;
 604     $cui->leave_curses();
 605     LTPTests::execute_tests($selected_tests, \%options, ["clear; echo Running LTP Tests; ", map { "$_ setup;" } @setups], [map { "$_ teardown;" } @setups]);
 606     $cui->reset_curses();
 607 }
 608
 609 my $main_menu = [
 610     { -label => "Load", -value => sub {
 611         my $file=$cui->loadfilebrowser();
 612         LTPTests::load_file $file if defined $file;
 613         $ts_list->values([sort keys (%testsuites)]);
 614       } },
 615     { -label => "Execute", -value => \&execute_tests },
 616     { -label => "Options", -value => \&show_opt_dialog },
 617     { -label => "Exit", -value => sub { exit(0) } }
 618 ];
 619
 620 sub update_tc_list
 621 {
 622     my $v=$ts_list->get_active_value();
 623     $tc_list->values($testsuites{$v}->{tests} );
 624     my $seh=$tc_list->{-onchange};
 625     $tc_list->onChange(undef);
 626     $tc_list->set_selection(grep { $tc_list->{-values}->[$_]->{selected} } (0..$#{$tc_list->{-values}}));
 627     $tc_list->onChange($seh);
 628     $tc_list->intellidraw();
 629 }
 630
 631 sub update_tc_selection
 632 {
 633     my @sel=$tc_list->get();
 634     for(@{$tc_list->{-values}}){
 635          if($_->{selected}) {
 636             $_->{selected}=0;
 637             for(keys %{$_->{files}}) {
 638                 $testsuites{$_}->{selected}--;
 639             }
 640             $testsuites{"<ALL>"}->{selected}--;
 641          }
 642     }
 643     foreach (@sel) {
 644         if(!$_->{selected}) {
 645             $_->{selected}=1;
 646             for(keys %{$_->{files}}) {
 647                 $testsuites{$_}->{selected}++;
 648             }
 649             $testsuites{"<ALL>"}->{selected}++;
 650         }
 651     }
 652     $ts_list->intellidraw();
 653 }
 654
 655 sub check_ts
 656 {
 657     update_tc_list();
 658     my $seh=$tc_list->{-onchange};
 659     $tc_list->onChange(undef);
 660     $tc_list->set_selection((0..$#{$tc_list->{-values}}));
 661     $tc_list->onChange($seh);
 662     $seh->($tc_list);
 663     $tc_list->intellidraw();
 664 }
 665
 666 sub uncheck_ts
 667 {
 668     update_tc_list();
 669     $tc_list->clear_selection();
 670     update_tc_selection(); # clear_selection doesn't call -onchange callback
 671     $tc_list->intellidraw();
 672 }
 673
 674 sub toggle_ts
 675 {
 676     my $ts=$testsuites{$ts_list->get_active_value()};
 677     if($ts->{count}>$ts->{selected}) {
 678         check_ts();
 679     } else {
 680         uncheck_ts();
 681     }
 682 }
 683
 684 sub options_dialog
 685 {
 686     my ($template, $options)=@_;
 687
 688     my $dialog=$cui->add(undef, "Window");
 689     my $dialogid=$cui->{-object2id}->{$dialog};
 690     my $vbox = $dialog->add(undef, "Layout::Proportional",
 691                             -vertical => 1);
 692     my $opts_container = $vbox->add(undef, "Container::Paged", "-mult-height" => 1, -releasefocus => 1);
 693
 694     my $labelwidth=20;
 695
 696     my @widgets=();
 697     for(@$template) {
 698         my $line = $opts_container->add(undef, "Layout::Proportional",
 699                                         -vertical => 0, -height => 0,
 700                                         -releasefocus => 1);
 701         my $label=$line->add(undef, "Label", -text => $_->{label},
 702                              "-min-width" => $labelwidth,
 703                              -releasefocus => 1);
 704         push @widgets, $_->{create}->($line, $options->{$_->{name}}, "-mult-width" => 1);
 705     }
 706
 707     $vbox->add(undef, "Buttonbox", "-min-height" => 3, -buttons =>[
 708                    { -label => "Ok", -onpress => sub { $dialog->loose_focus; } }
 709                ], -releasefocus => 1);
 710
 711     $dialog->layout();
 712
 713 # run the dialog and wait for completion
 714     $dialog->modalfocus;
 715
 716     for(@$template) {
 717         $options->{$_->{name}}=$_->{get}->(shift(@widgets));
 718     }
 719
 720     $cui->delete($dialogid);
 721     $cui->root->focus(undef, 1);
 722 }
 723
 724 $win = $cui->add("win", "Window", -padtop => 1);
 725
 726 $cui->add (
 727     "menu", "Menubar",
 728     -menu => [ { -label => "File", -submenu=>$main_menu } ]
 729     );
 730
 731 my $cont=$win->add(
 732     "layout", "Layout::Proportional", -vertical => 0, -border => 1
 733     );
 734
 735 $ts_list=$cont->add (
 736     "lb", "ListBox::MultiColumn",
 737     -values => [sort keys (%testsuites)],
 738     -vscrollbar => "right",
 739 #    -padtop => 2, -padleft => 2,
 740 #    -padright => 2, -padbottom => 2,
 741     "-mult-width" => 1, -border => 1,
 742     -onselchange => \&update_tc_list,
 743     "-col-formatter" => sub {
 744         my $tmp=$testsuites{$_[0]} // { selected => 0, count => 1 };
 745         my $pref;
 746         if($tmp->{selected}==0) {
 747             $pref='  ';
 748         } elsif($tmp->{selected}<$tmp->{count}) {
 749             $pref='x ';
 750         } else {
 751             $pref='X ';
 752         }
 753         $_[0]=~s/^(.*\/)//;
 754         $_[0]=$pref.$_[0];
 755         return @_ }
 756     );
 757
 758 $tc_list=$cont->add (
 759     "lb2", "ListBox::MultiColumn",
 760     -values => \@test_data,
 761     "-col-designator" => ["id", "command"],
 762     -vscrollbar => "right",
 763 #    -padtop => 2, -padleft => 2,
 764 #    -padright => 2, -padbottom => 2,
 765     "-mult-width" => 2, -border => 1,
 766     -multi => 1,
 767     -onchange => \&update_tc_selection
 768     );
 769
 770 $ts_list->set_routine('option-check', \&check_ts);
 771 $ts_list->set_routine('option-uncheck', \&uncheck_ts);
 772 $ts_list->set_routine('option-select', \&toggle_ts);
 773
 774 $cui->set_binding( sub{ $cui->focus('menu') }, Curses::KEY_F(10) );
 775
 776 $cui->layout();
 777 $ts_list->focus();
 778 $cui->mainloop();