git.maemo.org Git - pkg-perl/blob - deb-src/libtest-harness-perl/libtest-harness-perl-3.12/examples/bin/tprove_gtk

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 use File::Find;
   5 use IO::Handle;
   6
   7 ##############################################################################
   8
   9 =head1 NAME
  10
  11 tprove_gtk - Simple proof of concept GUI for proving tests
  12
  13 =head1 USAGE
  14
  15  tprove_gtk [ list of test files ]
  16
  17 =head1 DESCRIPTION
  18
  19 I've included this in the distribution.  It's a gtk interface by Torsten
  20 Schoenfeld.  I've not run it myself.
  21
  22 C<tprove_gtk> is not installed on your system unless you explicitly copy it
  23 somewhere in your path.  The current incarnation B<must> be run in a directory
  24 with both C<t/> and C<lib/> (i.e., the standard "root" level directory in
  25 which CPAN style modules are developed).  This will probably change in the
  26 future.  As noted, this is a proof of concept.
  27
  28 =head1 CAVEATS
  29
  30 This is alpha code.  You've been warned.
  31
  32 =cut
  33
  34 my @tests;
  35 if (@ARGV) {
  36     @tests = @ARGV;
  37 }
  38 else {
  39     find(
  40         sub { -f && /\.t$/ && push @tests => $File::Find::name },
  41         "t"
  42     );
  43 }
  44
  45 pipe( my $reader, my $writer );
  46
  47 # Unfortunately, autoflush-ing seems to be a big performance problem.  If you
  48 # don't care about "real-time" progress bars, turn this off.
  49 $writer->autoflush(1);
  50
  51 if ( my $pid = fork ) {
  52     close $writer;
  53
  54     my $gui = Gui->new( $pid, $reader );
  55     $gui->add_tests(@tests);
  56     $gui->run();
  57 }
  58
  59 else {
  60     die "Cannot fork: $!" unless defined $pid;
  61     close $reader;
  62
  63     my $runner = TestRunner->new($writer);
  64     $runner->add_tests(@tests);
  65     $runner->run();
  66
  67     close $writer;
  68 }
  69
  70 ###############################################################################
  71 # --------------------------------------------------------------------------- #
  72 ###############################################################################
  73
  74 package Gui;
  75
  76 use Glib qw(TRUE FALSE);
  77 use Gtk2 -init;
  78
  79 use constant {
  80     COLUMN_FILENAME => 0,
  81     COLUMN_TOTAL    => 1,
  82     COLUMN_RUN      => 2,
  83     COLUMN_PASS     => 3,
  84     COLUMN_FAIL     => 4,
  85     COLUMN_SKIP     => 5,
  86     COLUMN_TODO     => 6,
  87 };
  88
  89 BEGIN {
  90     if ( !Gtk2->CHECK_VERSION( 2, 6, 0 ) ) {
  91         die("$0 needs gtk+ >= 2.6");
  92     }
  93 }
  94
  95 DESTROY {
  96     my ($self) = @_;
  97
  98     if ( defined $self->{reader_source} ) {
  99         Glib::Source->remove( $self->{reader_source} );
 100     }
 101 }
 102
 103 sub new {
 104     my ( $class, $child_pid, $reader ) = @_;
 105
 106     my $self = bless {}, $class;
 107
 108     $self->create_window();
 109     $self->create_menu();
 110     $self->create_view();
 111
 112     $self->{child_pid}     = $child_pid;
 113     $self->{child_running} = TRUE;
 114
 115     $self->{reader_source} = Glib::IO->add_watch(
 116         fileno $reader, [qw(in pri hup)],
 117         \&_callback_reader, $self
 118     );
 119
 120     return $self;
 121 }
 122
 123 sub add_tests {
 124     my ( $self, @tests ) = @_;
 125
 126     my $model = $self->{_model};
 127
 128     $self->{_path_cache} = {};
 129
 130     foreach my $test (@tests) {
 131         my $iter = $model->append();
 132         $model->set( $iter, COLUMN_FILENAME, $test );
 133         $self->{_path_cache}->{$test} = $model->get_path($iter);
 134     }
 135 }
 136
 137 sub create_window {
 138     my ($self) = @_;
 139
 140     my $window = Gtk2::Window->new();
 141     my $vbox = Gtk2::VBox->new( FALSE, 5 );
 142
 143     $window->add($vbox);
 144     $window->set_title("Test Runner");
 145     $window->set_default_size( 300, 600 );
 146     $window->signal_connect( delete_event => \&_callback_quit, $self );
 147
 148     $self->{_window} = $window;
 149     $self->{_vbox}   = $vbox;
 150 }
 151
 152 sub create_menu {
 153     my ($self) = @_;
 154
 155     my $window = $self->{_window};
 156     my $vbox   = $self->{_vbox};
 157
 158     my $ui = <<"UI";
 159 <ui>
 160   <menubar>
 161     <menu action="test_menu">
 162       <menuitem action="quit_item" />
 163     </menu>
 164   </menubar>
 165 </ui>
 166 UI
 167
 168     my $actions = [
 169         [ "test_menu", undef, "_Tests" ],
 170         [   "quit_item",
 171             "gtk-quit",
 172             "_Quit",
 173             "<control>Q",
 174             "Quit the test runner",
 175             sub { _callback_quit( undef, undef, $self ) },
 176         ],
 177     ];
 178
 179     my $action_group = Gtk2::ActionGroup->new("main");
 180     $action_group->add_actions($actions);
 181
 182     my $manager = Gtk2::UIManager->new();
 183     $manager->insert_action_group( $action_group, 0 );
 184     $manager->add_ui_from_string($ui);
 185
 186     my $menu_box = Gtk2::VBox->new( FALSE, 0 );
 187     $manager->signal_connect(
 188         add_widget => sub {
 189             my ( $manager, $widget ) = @_;
 190             $menu_box->pack_start( $widget, FALSE, FALSE, 0 );
 191         }
 192     );
 193
 194     $vbox->pack_start( $menu_box, FALSE, FALSE, 0 );
 195     $window->add_accel_group( $manager->get_accel_group() );
 196
 197     $self->{_manager} = $manager;
 198 }
 199
 200 sub create_view {
 201     my ($self) = @_;
 202
 203     my $window = $self->{_window};
 204     my $vbox   = $self->{_vbox};
 205
 206     my $scroller = Gtk2::ScrolledWindow->new();
 207     $scroller->set_policy( "never", "automatic" );
 208
 209     my $model = Gtk2::ListStore->new(
 210
 211         #  filename     total     run       pass      fail      skip      todo
 212         qw(Glib::String Glib::Int Glib::Int Glib::Int Glib::Int Glib::Int Glib::Int)
 213     );
 214     my $view = Gtk2::TreeView->new($model);
 215
 216  # ------------------------------------------------------------------------- #
 217
 218     my $column_filename = Gtk2::TreeViewColumn->new_with_attributes(
 219         "Filename",
 220         Gtk2::CellRendererText->new(),
 221         text => COLUMN_FILENAME
 222     );
 223     $column_filename->set_sizing("autosize");
 224     $column_filename->set_expand(TRUE);
 225     $view->append_column($column_filename);
 226
 227  # ------------------------------------------------------------------------- #
 228
 229     my $renderer_progress = Gtk2::CellRendererProgress->new();
 230     my $column_progress   = Gtk2::TreeViewColumn->new_with_attributes(
 231         "Progress",
 232         $renderer_progress
 233     );
 234     $column_progress->set_cell_data_func(
 235         $renderer_progress,
 236         sub {
 237             my ( $column, $renderer, $model, $iter ) = @_;
 238
 239             my ( $total, $run )
 240               = $model->get( $iter, COLUMN_TOTAL, COLUMN_RUN );
 241
 242             if ( $run == 0 ) {
 243                 $renderer->set(
 244                     text  => "",
 245                     value => 0
 246                 );
 247                 return;
 248             }
 249
 250             if ( $total != 0 ) {
 251                 $renderer->set(
 252                     text  => "$run/$total",
 253                     value => $run / $total * 100
 254                 );
 255             }
 256             else {
 257                 $renderer->set(
 258                     text  => $run,
 259                     value => 0
 260                 );
 261             }
 262         }
 263     );
 264     $view->append_column($column_progress);
 265
 266  # ------------------------------------------------------------------------- #
 267
 268     my @count_columns = (
 269         [ "Pass", COLUMN_PASS ],
 270         [ "Fail", COLUMN_FAIL ],
 271         [ "Skip", COLUMN_SKIP ],
 272         [ "Todo", COLUMN_TODO ],
 273     );
 274
 275     foreach (@count_columns) {
 276         my ( $heading, $column_number ) = @{$_};
 277
 278         my $renderer = Gtk2::CellRendererText->new();
 279         $renderer->set( xalign => 1.0 );
 280
 281         my $column = Gtk2::TreeViewColumn->new_with_attributes(
 282             $heading,
 283             $renderer,
 284             text => $column_number
 285         );
 286
 287         $view->append_column($column);
 288     }
 289
 290  # ------------------------------------------------------------------------- #
 291
 292     $scroller->add($view);
 293     $vbox->pack_start( $scroller, TRUE, TRUE, 0 );
 294
 295     $self->{_view}  = $view;
 296     $self->{_model} = $model;
 297 }
 298
 299 sub run {
 300     my ($self) = @_;
 301
 302     $self->{_window}->show_all();
 303
 304     Gtk2->main();
 305 }
 306
 307 # --------------------------------------------------------------------------- #
 308
 309 sub _callback_reader {
 310     my ( $fileno, $condition, $self ) = @_;
 311
 312     if ( $condition & "in" || $condition & "pri" ) {
 313         my $data = <$reader>;
 314
 315         if ( $data !~ /^[^\t]+ \t \d+ \t \d+ \t \d+ \t \d+ \t \d+ \t \d+$/x )
 316         {
 317             return TRUE;
 318         }
 319
 320         my ( $filename, $total, $run, $pass, $fail, $skip, $todo )
 321           = split /\t/, $data;
 322
 323         my $view       = $self->{_view};
 324         my $model      = $self->{_model};
 325         my $path_cache = $self->{_path_cache};
 326
 327         if ( $path_cache->{$filename} ) {
 328             my $iter = $model->get_iter( $path_cache->{$filename} );
 329             $model->set(
 330                 $iter,
 331                 COLUMN_TOTAL, $total,
 332                 COLUMN_RUN,   $run,
 333                 COLUMN_PASS,  $pass,
 334                 COLUMN_FAIL,  $fail,
 335                 COLUMN_SKIP,  $skip,
 336                 COLUMN_TODO,  $todo
 337             );
 338             $view->scroll_to_cell( $path_cache->{$filename} );
 339         }
 340     }
 341
 342     elsif ( $condition & "hup" ) {
 343         $self->{child_running} = FALSE;
 344         return FALSE;
 345     }
 346
 347     else {
 348         warn "got unknown condition: $condition";
 349         return FALSE;
 350     }
 351
 352     return TRUE;
 353 }
 354
 355 sub _callback_quit {
 356     my ( $window, $event, $self ) = @_;
 357
 358     if ( $self->{child_running} ) {
 359         kill "TERM", $self->{child_pid};
 360     }
 361
 362     Gtk2->main_quit();
 363 }
 364
 365 ###############################################################################
 366 # --------------------------------------------------------------------------- #
 367 ###############################################################################
 368
 369 package TestRunner;
 370
 371 use TAP::Parser;
 372 use TAP::Parser::Source::Perl;
 373
 374 use constant {
 375     INDEX_TOTAL => 0,
 376     INDEX_RUN   => 1,
 377     INDEX_PASS  => 2,
 378     INDEX_FAIL  => 3,
 379     INDEX_SKIP  => 4,
 380     INDEX_TODO  => 5,
 381 };
 382
 383 sub new {
 384     my ( $class, $writer ) = @_;
 385
 386     my $self = bless {}, $class;
 387
 388     $self->{_writer} = $writer;
 389
 390     return $self;
 391 }
 392
 393 sub add_tests {
 394     my ( $self, @tests ) = @_;
 395
 396     $self->{_tests} = [@tests];
 397
 398     $self->{_results} = {};
 399     foreach my $test ( @{ $self->{_tests} } ) {
 400         $self->{_results}->{$test} = [ 0, 0, 0, 0, 0, 0 ];
 401     }
 402 }
 403
 404 sub run {
 405     my ($self) = @_;
 406
 407     my $source = TAP::Parser::Source::Perl->new();
 408
 409     foreach my $test ( @{ $self->{_tests} } ) {
 410         my $stream = $source->source($test)->get_stream();
 411         if ($stream) {
 412             my $parser = $self->analyze( $test, $stream );
 413
 414             # $aggregate -> add($test, $parser);
 415         }
 416         else {
 417             warn "Could not run `$test´: " . $source->error();
 418             next;
 419         }
 420     }
 421
 422     my $writer = $self->{_writer};
 423     $writer->flush();
 424     $writer->print("\n");
 425 }
 426
 427 sub analyze {
 428     my ( $self, $test, $stream ) = @_;
 429
 430     my $writer = $self->{_writer};
 431     my $result = $self->{_results}->{$test};
 432
 433     my $parser = TAP::Parser->new( { stream => $stream } );
 434     while ( my $line = $parser->next() ) {
 435         if ( $line->is_plan() ) {
 436             $result->[INDEX_TOTAL] = $line->tests_planned();
 437         }
 438
 439         elsif ( $line->is_test() ) {
 440             $result->[INDEX_RUN]++;
 441
 442             if ( $line->has_skip() ) {
 443                 $result->[INDEX_SKIP]++;
 444                 next;
 445             }
 446
 447             if ( $line->has_todo() ) {
 448                 $result->[INDEX_TODO]++;
 449             }
 450
 451             if ( $line->is_ok() ) {
 452                 $result->[INDEX_PASS]++;
 453             }
 454             else {
 455                 $result->[INDEX_FAIL]++;
 456             }
 457         }
 458
 459         elsif ( $line->is_comment() ) {
 460
 461             # ignore
 462         }
 463
 464         else {
 465             warn "Unknown result type `"
 466               . $line->type() . "´: "
 467               . $line->as_string();
 468         }
 469
 470         my $string = join "\t", $test, @{$result};
 471         $writer->print("$string\n");
 472     }
 473
 474     return $parser;
 475 }