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