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     TMPFILE => undef,
  24     );
  25 my @test_data = ();
  26
  27 sub shell_quote
  28 {
  29     my $arg=shift;
  30     $arg =~ s/'/'\\''/;
  31     return "'$arg'";
  32 }
  33
  34 sub to_number
  35 {
  36     my $arg=shift;
  37     return $arg if $arg =~ /^\d+$/;
  38     return 0;
  39 }
  40
  41 sub execute_tests
  42 {
  43     my ($used_tests, $environment, $setup, $teardown) = @_;
  44     my $panopts="";
  45     my $tdir;
  46     for(keys %$environment) {
  47         if (/^\$/) {
  48             my $value=$environment->{$_};
  49             s/^\$//;
  50             $ENV{$_}=$value;
  51         }
  52     }
  53     for(keys %static_env) {
  54         my $value=$static_env{$_};
  55         $ENV{$_}=$value;
  56     }
  57     if(($environment->{output} // "") ne "") {
  58         $tdir=File::Temp::tempdir(CLEANUP => 1);
  59         $panopts.=" -o ".shell_quote($environment->{output})." -O ".shell_quote($tdir);
  60     }
  61
  62     if(!$environment->{fulloutput}) {
  63         $panopts.=" -q ";
  64     }
  65
  66     if(($environment->{failfile} // "") ne "") {
  67         my $ff=$environment->{failfile};
  68         my $out=$environment->{output}//"";
  69         $out =~ s/^.*\///;
  70         $ff =~ s/%s/$out/;
  71         my $now = localtime;
  72         $ff =~ s/%d/$now/;
  73         $panopts.=" -C ".shell_quote($ff);
  74     }
  75
  76     if(($environment->{logfile} // "") ne "") {
  77         my $ff=$environment->{logfile};
  78         my $out=$environment->{output}//"";
  79         $out =~ s/^.*\///;
  80         $ff =~ s/%s/$out/;
  81         my $now = localtime;
  82         $ff =~ s/%d/$now/;
  83         $panopts.=" -l ".shell_quote($ff);
  84     }
  85
  86     my $count;
  87     if(($environment->{count} // "") ne "") {
  88         $count=$environment->{count};
  89         if($count =~ /^(\d)l$/) {
  90             $count=$1*@$used_tests;
  91         }
  92         $count=to_number($count);
  93     }
  94     if($environment->{random}) {
  95         $count = $count // scalar @$used_tests;
  96     }
  97
  98     if(!($environment->{random})) {
  99         $panopts.=" -S";
 100     }
 101
 102     if(defined($count)) {
 103         $panopts.=" -s ".$count;
 104     }
 105
 106     if(($environment->{time} // "") ne "") {
 107         return if !$environment->{time} =~ /[0-9]+[hmsd]?/;
 108         $panopts.=" -t ".$environment->{time};
 109     }
 110
 111     if(($environment->{parallel} // "") ne "") {
 112         $panopts.=" -x ".to_number ($environment->{parallel} // 0);
 113     }
 114
 115     my $ft=new File::Temp(TEMPLATE => "/tmp/runtestXXXXXXXXX");
 116     my $zoo=new File::Temp(TEMPLATE => "/tmp/zoo$$.XXXXXXXXX");
 117     local $,="\n";
 118     print $ft map { "$_->{id} $_->{command}" } @$used_tests;
 119     $ft->flush;
 120     system "@$setup";
 121     system '${LTPTOOLS}/ltp-pan -p -n $$ -a '.$zoo->filename.' -f '.$ft->filename.$panopts;
 122     system "@$teardown";
 123     File::Path::rmtree $tdir if defined($tdir);
 124 }
 125
 126 my %testsuites =();
 127 my %test_hash= ();
 128 sub load_file
 129 {
 130     my ($file)=@_;
 131     my $num=0;
 132     open(FILE, "<$file");
 133     my $name="$file";
 134     my $ts_desc={ selected => 0, tests => [] };
 135     my $allvars = [];
 136     my $allsetup = [];
 137
 138     my $last;
 139     my $comment=sub {
 140         if($1 =~ /DESCRIPTION:(.*)/) {
 141             $ts_desc->{description}=$1;
 142             $last=\$ts_desc->{description};
 143         } elsif ($1 =~ /ALL:(.*)/) {
 144             push @$allvars, grep m/./, (split qr/ +/, $1);
 145         } elsif ($1 =~ /SETUP:(.*)/) {
 146             push @$allsetup, grep m/./, (split qr/ +/, $1);
 147         } elsif ($1 eq "") {
 148             undef $last;
 149         } elsif(defined $last) {
 150             $$last.="\n". $1;
 151         }
 152
 153     };
 154     while(<FILE>) {
 155         if (/^#(.*)/) {
 156             $comment-> ($1);
 157             next;
 158         }
 159         next unless /^([^[:space:]]+)[[:space:]]+(.*)/;
 160         $comment-> ("");
 161         if(exists($test_hash{"$1 $2"})) {
 162             next if exists $test_hash{"$1 $2"}->{files}->{$name};
 163             push @{$ts_desc->{tests}}, $test_hash{"$1 $2"};
 164             $test_hash{"$1 $2"}->{files}->{$name}=undef;
 165             $ts_desc->{selected}++ if($test_hash{"$1 $2"}->{selected});
 166         } else {
 167             push(@test_data, { id => $1, command => $2,
 168                  files => {$name => undef}});
 169             my $id="$1 $2";
 170             $test_data[$#test_data]->{vars}=[(grep { /^\$(.*)/; !exists($static_env{$1}) } ( @$allvars, $2 =~ /\$[[:alpha:]][[:alnum:]_]*/g ))];
 171             $test_data[$#test_data]->{setup}=$allsetup;
 172             push @{$ts_desc->{tests}}, \%{$test_data[$#test_data]};
 173             $test_hash{$id}=\%{$test_data[$#test_data]};
 174             $testsuites{"<ALL>"}->{count}++;
 175         }
 176         $num++;
 177     }
 178     close (FILE);
 179     $ts_desc->{count}=$num;
 180     $testsuites{$name}=$ts_desc;
 181 }
 182
 183 sub load_available
 184 {
 185     $testsuites{"<ALL>"}={selected => 0, count => 0, tests => \@test_data};
 186
 187     my @files;
 188     opendir(DIR, $runtest_dir) || die("Couldn't open directory $runtest_dir");
 189     @files=readdir(DIR);
 190     closedir(DIR);
 191
 192     foreach(@files) {
 193         next if (/^\./);
 194         load_file("$runtest_dir/$_");
 195     }
 196
 197 }
 198
 199 sub flatten
 200 {
 201     return map { (ref($_) eq "ARRAY") ? flatten(@$_) : $_ } @_;
 202 }
 203
 204 sub needed_vars
 205 {
 206     my ($ts_list)=@_;
 207     return uniq(flatten(map $_->{vars}, @$ts_list));
 208 }
 209
 210 sub setup_scripts
 211 {
 212     my ($ts_list)=@_;
 213     return uniq(flatten(map $_->{setup}, @$ts_list));
 214 }
 215
 216 sub tests_needing_vars
 217 {
 218     my ($tests, @vars)=@_;
 219     my %vars_hash=(map { ($_ => undef) } @vars);
 220     return grep { any { exists($vars_hash{$_}) } @{$_->{vars}} } @$tests;
 221 }
 222
 223 load_available;
 224
 225 package Layout::Proportional;
 226
 227 use Curses::UI::Container;
 228
 229 our @ISA=qw/Curses::UI::Container/;
 230
 231 sub new {
 232     my $class = shift;
 233     my $self = $class->SUPER::new( @_, -layoutorder => [] );
 234     return $self;
 235 }
 236
 237 sub add {
 238     my $self=shift;
 239     my $ret=$self->SUPER::add(@_);
 240     push @{$self->{-layoutorder}}, $self->{-object2id}->{$ret};
 241     return $ret;
 242 }
 243
 244 sub layout {
 245     my $self = shift;
 246     $self->Curses::UI::Widget::layout();
 247
 248     my $size=($self->{-vertical} ? "height" : "width");
 249     my $coord=($self->{-vertical} ? "y" : "x");
 250     my $ot_size=($self->{-vertical} ? "width" : "height");
 251     my $ot_coord=($self->{-vertical} ? "x" : "y");
 252     my $padding=($self->{-vertical} ?
 253                  sub { my $obj=shift; return ($obj->{-padtop}//0)+($obj->{-padbottom}//0); } :
 254                  sub { my $obj=shift; return ($obj->{-padleft}//0)+($obj->{-padright}//0); });
 255     my $total_min=0;
 256     my $total_mult=0;
 257     my %sizes= ( height => $self->canvasheight(), width => $self->canvaswidth() );
 258     foreach(@{$self->{-layoutorder}}) {
 259         my $obj=$self->{-id2object}->{$_};
 260         $total_min += $obj->{"-min-$size"} if $obj->{"-min-$size"};
 261         $total_mult += $obj->{"-mult-$size"} if $obj->{"-mult-$size"};
 262     }
 263     my $excess = $sizes{$size}-$total_min;
 264     my $ratio=($total_mult==0 ? 0 : $excess/$total_mult);
 265
 266     my $cur=0;
 267     foreach(@{$self->{-layoutorder}}) {
 268         my $obj=$self->{-id2object}->{$_};
 269         $obj->{-$coord}=$cur;
 270         $obj->{-$ot_coord}=0;
 271         $obj->{-$size}=int (($obj->{"-min-$size"} // 0) + ($obj->{"-mult-$size"} // 0)*$ratio);
 272         $cur += $obj->{-$size};
 273         $obj->{-$size} = 0 if $obj->{-$size} < 0;
 274         delete $obj->{-$ot_size};
 275         $obj->{-parent}=$self;
 276         $obj->layout();
 277         $obj->intellidraw();
 278     }
 279     return $self;
 280 }
 281
 282 $INC{"Layout/Proportional.pm"}="";
 283
 284 package ListBox::MultiColumn;
 285
 286 use Curses::UI::Listbox;
 287
 288 our @ISA=qw/Curses::UI::Listbox/;
 289
 290 sub new {
 291     my $class = shift;
 292     my $self = $class->SUPER::new(
 293         -colwidth => [],
 294         "-col-designator" => [],
 295         @_
 296         );
 297     return $self;
 298 }
 299
 300 sub getcolwidth
 301 {
 302     my ($self, $col) = @_;
 303     return $self->{-colwidth}->[$col] if $self->{-colwidth}->[$col];
 304     return 10;
 305 }
 306
 307 sub getlabel {
 308     my ($self, $i) = @_;
 309     my $val = $self->values()->[$i];
 310     my @disp=();
 311     if(ref($val) eq "ARRAY") {
 312         for my $idx (0..$#$val-1) {
 313             my $len=$self->getcolwidth($idx);
 314             push (@disp, $$val[$idx]);
 315         }
 316         push (@disp, $$val[$#$val]);
 317     } elsif(ref($val) eq "HASH") {
 318         my $cd=$self->{"-col-designator"};
 319         return "" unless $cd;
 320         for my $idx (0..$#$cd-1) {
 321             my $len=$self->getcolwidth($idx);
 322             push (@disp, $val->{$cd->[$idx]});
 323         }
 324         push (@disp, $val->{$cd->[$#$cd]});
 325     } else {
 326         @disp=($self->SUPER::getlabel($i));
 327     }
 328     @disp=($self->{"-col-formatter"} ?
 329            $self->{"-col-formatter"}->(@disp) :
 330            @disp);
 331     for (0..$#disp-1) {
 332             my $len=$self->getcolwidth($_);
 333             $disp[$_] = sprintf("%-${len}.${len}s", $disp[$_]);
 334     }
 335     return join("|", @disp);
 336 }
 337
 338 package main;
 339 use List::MoreUtils qw/any/;
 340
 341 #######
 342 # TUI #
 343 #######
 344
 345 $INC{"ListBox/MultiColumn.pm"}="";
 346
 347 my $cui = new Curses::UI (
 348     -clear_on_exit => 1
 349 );
 350 my $tc_list;
 351 my $ts_list;
 352 my $win;
 353
 354 my @opt_template = (
 355     simple_text(label => "Output file", name => "output"),
 356     simple_text(label => "Log file", name => "logfile"),
 357     simple_text(label => "Failed command file", name => "failfile"),
 358     simple_text(label => "Running time", name => "time", validator => '/^\d*[hdms]?$/'),
 359     simple_text(label => "Parallel tests", name => "parallel", validator => '/^\d*$/'),
 360     simple_check(label => "Random tests", name => "random"),
 361     simple_check(label => "Full Output", name => "fulloutput"),
 362     simple_text(label => "Test count", name => "count", validator => '/^\d*l?$/'),
 363     );
 364
 365 my %options =( failfile => "/var/tmp/LTP_RUN_ON_%d.failed",
 366                logfile => "/var/tmp/LTP_RUN_ON_%d.log" );
 367
 368 sub simple_text {
 369     my %params=@_;
 370     return { label => $params{label}, name => $params{name},
 371              create => sub {
 372                  my ($parent, $data, @params) = @_;
 373                  @params=(@params, -regexp => $params{validator}) if exists $params{validator};
 374                  my $lab=$parent->add(undef, "TextEntry", @params);
 375                  $lab->text($data) if defined $data;
 376                  return $lab;
 377              },
 378              get => sub { return shift()->get(); }
 379     };
 380
 381 }
 382
 383 sub simple_check {
 384     my %params=@_;
 385     return { label => $params{label}, name => $params{name},
 386              create => sub {
 387                  my ($parent, $data, @params) = @_;
 388                  my $lab=$parent->add(undef, "Checkbox", @params);
 389                  $lab->check() if $data;
 390                  return $lab;
 391              },
 392              get => sub { return shift()->get(); }
 393     };
 394
 395 }
 396
 397 sub show_opt_dialog
 398 {
 399     options_dialog([@opt_template, map {
 400         +{
 401             label => $_, name => $_,
 402             create => sub {
 403                 my ($parent, $data, @params) = @_;
 404                 my $lab=$parent->add(undef, "TextEntry", @params);
 405                 $lab->text($data) if defined $data;
 406                 return $lab;
 407             },
 408             get => sub { return shift()->get(); }
 409         }
 410                     } LTPTests::needed_vars [grep { $_->{selected} } @test_data]], \%options);
 411 }
 412
 413 sub execute_tests
 414 {
 415     my $selected_tests=[grep { $_->{selected} } @test_data];
 416     my @needed_vars=LTPTests::needed_vars $selected_tests;
 417     my @unsatisfied_tests=LTPTests::tests_needing_vars $selected_tests, (grep !$options{$_}, @needed_vars);
 418     if(@unsatisfied_tests) {
 419         my $response=$cui->dialog(
 420             -message => "You have sellected tests that need setting some variables. Would you like to set them now?",
 421             -buttons => [
 422                  {-label => "Show the options dialog", -value => 0},
 423                  {-label => "Don't run those tests", -value => 1},
 424                  {-label => "Cancel", -value => 2}
 425             ],
 426             -title => "Unset variables"
 427             );
 428         return if($response == 2);
 429         if($response==0) {
 430             show_opt_dialog;
 431         } else { # filter tests
 432             $selected_tests=[grep { !any { !$options{$_} } LTPTests::needed_vars [$_] } @$selected_tests ];
 433         }
 434     }
 435     my @setups = LTPTests::setup_scripts $selected_tests;
 436     $cui->leave_curses();
 437     LTPTests::execute_tests($selected_tests, \%options, ["clear; echo Running LTP Tests; ", map { "$_ setup;" } @setups], [map { "$_ teardown;" } @setups]);
 438     $cui->reset_curses();
 439 }
 440
 441 my $main_menu = [
 442     { -label => "Load", -value => sub {
 443         my $file=$cui->loadfilebrowser();
 444         LTPTests::load_file $file if defined $file;
 445         $ts_list->values([sort keys (%testsuites)]);
 446       } },
 447     { -label => "Execute", -value => \&execute_tests },
 448     { -label => "Options", -value => \&show_opt_dialog },
 449     { -label => "Exit", -value => sub { exit(0) } }
 450 ];
 451
 452 sub update_tc_list
 453 {
 454     my $v=$ts_list->get_active_value();
 455     $tc_list->values($testsuites{$v}->{tests} );
 456     my $seh=$tc_list->{-onchange};
 457     $tc_list->onChange(undef);
 458     $tc_list->set_selection(grep { $tc_list->{-values}->[$_]->{selected} } (0..$#{$tc_list->{-values}}));
 459     $tc_list->onChange($seh);
 460     $tc_list->intellidraw();
 461 }
 462
 463 sub update_tc_selection
 464 {
 465     my @sel=$tc_list->get();
 466     for(@{$tc_list->{-values}}){
 467          if($_->{selected}) {
 468             $_->{selected}=0;
 469             for(keys %{$_->{files}}) {
 470                 $testsuites{$_}->{selected}--;
 471             }
 472             $testsuites{"<ALL>"}->{selected}--;
 473          }
 474     }
 475     foreach (@sel) {
 476         if(!$_->{selected}) {
 477             $_->{selected}=1;
 478             for(keys %{$_->{files}}) {
 479                 $testsuites{$_}->{selected}++;
 480             }
 481             $testsuites{"<ALL>"}->{selected}++;
 482         }
 483     }
 484     $ts_list->intellidraw();
 485 }
 486
 487 sub check_ts
 488 {
 489     update_tc_list();
 490     my $seh=$tc_list->{-onchange};
 491     $tc_list->onChange(undef);
 492     $tc_list->set_selection((0..$#{$tc_list->{-values}}));
 493     $tc_list->onChange($seh);
 494     $seh->($tc_list);
 495     $tc_list->intellidraw();
 496 }
 497
 498 sub uncheck_ts
 499 {
 500     update_tc_list();
 501     $tc_list->clear_selection();
 502     update_tc_selection(); # clear_selection doesn't call -onchange callback
 503     $tc_list->intellidraw();
 504 }
 505
 506 sub toggle_ts
 507 {
 508     my $ts=$testsuites{$ts_list->get_active_value()};
 509     if($ts->{count}>$ts->{selected}) {
 510         check_ts();
 511     } else {
 512         uncheck_ts();
 513     }
 514 }
 515
 516 sub max
 517 {
 518     my $ret=shift;
 519     for(@_) {
 520         $ret=$_ if $_>$ret;
 521     }
 522     return $ret;
 523 }
 524
 525 sub options_dialog
 526 {
 527     my ($template, $options)=@_;
 528
 529     my $dialog=$cui->add(undef, "Window");
 530     my $dialogid=$cui->{-object2id}->{$dialog};
 531
 532     my $line=1;
 533     my $labelwidth=20;
 534
 535     my @widgets=();
 536     for(@$template) {
 537         my $label=$dialog->add(undef, "Label", -text => $_->{label},
 538                                -x => 0, -width => $labelwidth, -y => $line);
 539         push @widgets, $_->{create}->($dialog, $options->{$_->{name}}, -x => $labelwidth+2, -y => $line);
 540
 541         $label->layout();
 542         $line+=max($label->{-h}, $widgets[$#widgets]->{-h});
 543     }
 544
 545     $dialog->add(undef, "Buttonbox", -y => $line+1, -buttons =>[
 546                      { -label => "Ok", -onpress => sub { $dialog->loose_focus; } }
 547                  ]);
 548
 549     $dialog->modalfocus;
 550
 551     for(@$template) {
 552         $options->{$_->{name}}=$_->{get}->(shift(@widgets));
 553     }
 554
 555     $cui->delete($dialogid);
 556     $cui->root->focus(undef, 1);
 557 }
 558
 559 $win = $cui->add("win", "Window", -padtop => 1);
 560
 561 $cui->add (
 562     "menu", "Menubar",
 563     -menu => [ { -label => "File", -submenu=>$main_menu } ]
 564     );
 565
 566 my $cont=$win->add(
 567     "layout", "Layout::Proportional", -vertical => 0, -border => 1
 568     );
 569
 570 $ts_list=$cont->add (
 571     "lb", "ListBox::MultiColumn",
 572     -values => [sort keys (%testsuites)],
 573     -vscrollbar => "right",
 574 #    -padtop => 2, -padleft => 2,
 575 #    -padright => 2, -padbottom => 2,
 576     "-mult-width" => 1, -border => 1,
 577     -onselchange => \&update_tc_list,
 578     "-col-formatter" => sub {
 579         my $tmp=$testsuites{$_[0]} // { selected => 0, count => 1 };
 580         my $pref;
 581         if($tmp->{selected}==0) {
 582             $pref='  ';
 583         } elsif($tmp->{selected}<$tmp->{count}) {
 584             $pref='x ';
 585         } else {
 586             $pref='X ';
 587         }
 588         $_[0]=~s/^(.*\/)//;
 589         $_[0]=$pref.$_[0];
 590         return @_ }
 591     );
 592
 593 $tc_list=$cont->add (
 594     "lb2", "ListBox::MultiColumn",
 595     -values => \@test_data,
 596     "-col-designator" => ["id", "command"],
 597     -vscrollbar => "right",
 598 #    -padtop => 2, -padleft => 2,
 599 #    -padright => 2, -padbottom => 2,
 600     "-mult-width" => 2, -border => 1,
 601     -multi => 1,
 602     -onchange => \&update_tc_selection
 603     );
 604
 605 $ts_list->set_routine('option-check', \&check_ts);
 606 $ts_list->set_routine('option-uncheck', \&uncheck_ts);
 607 $ts_list->set_routine('option-select', \&toggle_ts);
 608
 609 $cui->set_binding( sub{ $cui->focus('menu') }, Curses::KEY_F(10) );
 610
 611 $cui->layout();
 612 $ts_list->focus();
 613 $cui->mainloop();