#!/usr/bin/perl -w
use strict;
die "Unsupported";
##############################################################################
=head1 NAME
tprove_gtk - Simple proof of concept GUI for proving tests
=head1 USAGE
tprove_gtk [ list of test files ]
=head1 DESCRIPTION
I've included this in the distribution. It's a gtk interface by Torsten
Schoenfeld. I've not run it myself.
C<tprove_gtk> is not installed on your system unless you explicitly copy it
somewhere in your path. The current incarnation B<must> be run in a directory
with both C<t/> and C<lib/> (i.e., the standard "root" level directory in
which CPAN style modules are developed). This will probably change in the
future. As noted, this is a proof of concept.
=head1 CAVEATS
This is alpha code. You've been warned.
=cut
my @tests;
if (@ARGV) {
@tests = @ARGV;
}
else {
find(
sub { -f && /\.t$/ && push @tests => $File::Find::name },
"t"
);
}
pipe( my $reader, my $writer );
# Unfortunately, autoflush-ing seems to be a big performance problem. If you
# don't care about "real-time" progress bars, turn this off.
$writer->autoflush(1);
if ( my $pid = fork ) {
close $writer;
my $gui = Gui->new( $pid, $reader );
$gui->add_tests(@tests);
$gui->run();
}
else {
die "Cannot fork: $!" unless defined $pid;
close $reader;
my $runner = TestRunner->new($writer);
$runner->add_tests(@tests);
$runner->run();
close $writer;
}
###############################################################################
# --------------------------------------------------------------------------- #
###############################################################################
package Gui;
use Glib qw(TRUE FALSE);
use Gtk2 -init;
use constant {
COLUMN_FILENAME => 0,
COLUMN_TOTAL => 1,
COLUMN_RUN => 2,
COLUMN_PASS => 3,
COLUMN_FAIL => 4,
COLUMN_SKIP => 5,
COLUMN_TODO => 6,
};
BEGIN {
if ( !Gtk2->CHECK_VERSION( 2, 6, 0 ) ) {
die("$0 needs gtk+ >= 2.6");
}
}
DESTROY {
my ($self) = @_;
if ( defined $self->{reader_source} ) {
Glib::Source->remove( $self->{reader_source} );
}
}
sub new {
my ( $class, $child_pid, $reader ) = @_;
my $self = bless {}, $class;
$self->create_window();
$self->create_menu();
$self->create_view();
$self->{child_pid} = $child_pid;
$self->{child_running} = TRUE;
$self->{reader_source} = Glib::IO->add_watch(
fileno $reader, [qw(in pri hup)],
\&_callback_reader, $self
);
return $self;
}
sub add_tests {
my ( $self, @tests ) = @_;
my $model = $self->{_model};
$self->{_path_cache} = {};
foreach my $test (@tests) {
my $iter = $model->append();
$model->set( $iter, COLUMN_FILENAME, $test );
$self->{_path_cache}->{$test} = $model->get_path($iter);
}
}
sub create_window {
my ($self) = @_;
my $window = Gtk2::Window->new();
my $vbox = Gtk2::VBox->new( FALSE, 5 );
$window->add($vbox);
$window->set_title("Test Runner");
$window->set_default_size( 300, 600 );
$window->signal_connect( delete_event => \&_callback_quit, $self );
$self->{_window} = $window;
$self->{_vbox} = $vbox;
}
sub create_menu {
my ($self) = @_;
my $window = $self->{_window};
my $vbox = $self->{_vbox};
my $ui = <<"UI";
<ui>
<menubar>
<menu action="test_menu">
<menuitem action="quit_item" />
</menu>
</menubar>
</ui>
UI
my $actions = [
[ "test_menu", undef, "_Tests" ],
[ "quit_item",
"gtk-quit",
"_Quit",
"<control>Q",
"Quit the test runner",
sub { _callback_quit( undef, undef, $self ) },
],
];
my $action_group = Gtk2::ActionGroup->new("main");
$action_group->add_actions($actions);
my $manager = Gtk2::UIManager->new();
$manager->insert_action_group( $action_group, 0 );
$manager->add_ui_from_string($ui);
my $menu_box = Gtk2::VBox->new( FALSE, 0 );
$manager->signal_connect(
add_widget => sub {
my ( $manager, $widget ) = @_;
$menu_box->pack_start( $widget, FALSE, FALSE, 0 );
}
);
$vbox->pack_start( $menu_box, FALSE, FALSE, 0 );
$window->add_accel_group( $manager->get_accel_group() );
$self->{_manager} = $manager;
}
sub create_view {
my ($self) = @_;
my $window = $self->{_window};
my $vbox = $self->{_vbox};
my $scroller = Gtk2::ScrolledWindow->new();
$scroller->set_policy( "never", "automatic" );
my $model = Gtk2::ListStore->new(
# filename total run pass fail skip todo
qw(Glib::String Glib::Int Glib::Int Glib::Int Glib::Int Glib::Int Glib::Int)
);
my $view = Gtk2::TreeView->new($model);
# ------------------------------------------------------------------------- #
my $column_filename = Gtk2::TreeViewColumn->new_with_attributes(
"Filename",
Gtk2::CellRendererText->new(),
text => COLUMN_FILENAME
);
$column_filename->set_sizing("autosize");
$column_filename->set_expand(TRUE);
$view->append_column($column_filename);
# ------------------------------------------------------------------------- #
my $renderer_progress = Gtk2::CellRendererProgress->new();
my $column_progress = Gtk2::TreeViewColumn->new_with_attributes(
"Progress",
$renderer_progress
);
$column_progress->set_cell_data_func(
$renderer_progress,
sub {
my ( $column, $renderer, $model, $iter ) = @_;
my ( $total, $run )
= $model->get( $iter, COLUMN_TOTAL, COLUMN_RUN );
if ( $run == 0 ) {
$renderer->set(
text => "",
value => 0
);
return;
}
if ( $total != 0 ) {
$renderer->set(
text => "$run/$total",
value => $run / $total * 100
);
}
else {
$renderer->set(
text => $run,
value => 0
);
}
}
);
$view->append_column($column_progress);
# ------------------------------------------------------------------------- #
my @count_columns = (
[ "Pass", COLUMN_PASS ],
[ "Fail", COLUMN_FAIL ],
[ "Skip", COLUMN_SKIP ],
[ "Todo", COLUMN_TODO ],
);
foreach (@count_columns) {
my ( $heading, $column_number ) = @{$_};
my $renderer = Gtk2::CellRendererText->new();
$renderer->set( xalign => 1.0 );
my $column = Gtk2::TreeViewColumn->new_with_attributes(
$heading,
$renderer,
text => $column_number
);
$view->append_column($column);
}
# ------------------------------------------------------------------------- #
$scroller->add($view);
$vbox->pack_start( $scroller, TRUE, TRUE, 0 );
$self->{_view} = $view;
$self->{_model} = $model;
}
sub run {
my ($self) = @_;
$self->{_window}->show_all();
Gtk2->main();
}
# --------------------------------------------------------------------------- #
sub _callback_reader {
my ( $fileno, $condition, $self ) = @_;
if ( $condition & "in" || $condition & "pri" ) {
my $data = <$reader>;
if ( $data !~ /^[^\t]+ \t \d+ \t \d+ \t \d+ \t \d+ \t \d+ \t \d+$/x )
{
return TRUE;
}
my ( $filename, $total, $run, $pass, $fail, $skip, $todo )
= split /\t/, $data;
my $view = $self->{_view};
my $model = $self->{_model};
my $path_cache = $self->{_path_cache};
if ( $path_cache->{$filename} ) {
my $iter = $model->get_iter( $path_cache->{$filename} );
$model->set(
$iter,
COLUMN_TOTAL, $total,
COLUMN_RUN, $run,
COLUMN_PASS, $pass,
COLUMN_FAIL, $fail,
COLUMN_SKIP, $skip,
COLUMN_TODO, $todo
);
$view->scroll_to_cell( $path_cache->{$filename} );
}
}
elsif ( $condition & "hup" ) {
$self->{child_running} = FALSE;
return FALSE;
}
else {
warn "got unknown condition: $condition";
return FALSE;
}
return TRUE;
}
sub _callback_quit {
my ( $window, $event, $self ) = @_;
if ( $self->{child_running} ) {
kill "TERM", $self->{child_pid};
}
Gtk2->main_quit();
}
###############################################################################
# --------------------------------------------------------------------------- #
###############################################################################
package TestRunner;
use constant {
INDEX_TOTAL => 0,
INDEX_RUN => 1,
INDEX_PASS => 2,
INDEX_FAIL => 3,
INDEX_SKIP => 4,
INDEX_TODO => 5,
};
sub new {
my ( $class, $writer ) = @_;
my $self = bless {}, $class;
$self->{_writer} = $writer;
return $self;
}
sub add_tests {
my ( $self, @tests ) = @_;
$self->{_tests} = [@tests];
$self->{_results} = {};
foreach my $test ( @{ $self->{_tests} } ) {
$self->{_results}->{$test} = [ 0, 0, 0, 0, 0, 0 ];
}
}
sub run {
my ($self) = @_;
my $source = TAP::Parser::Source::Perl->new();
foreach my $test ( @{ $self->{_tests} } ) {
my $parser = TAP::Parser->new( { source => $test } );
$self->analyze( $test, $parser ) if $parser;
}
my $writer = $self->{_writer};
$writer->flush();
$writer->print("\n");
}
sub analyze {
my ( $self, $test, $parser ) = @_;
my $writer = $self->{_writer};
my $result = $self->{_results}->{$test};
while ( my $line = $parser->next() ) {
if ( $line->is_plan() ) {
$result->[INDEX_TOTAL] = $line->tests_planned();
}
elsif ( $line->is_test() ) {
$result->[INDEX_RUN]++;
if ( $line->has_skip() ) {
$result->[INDEX_SKIP]++;
next;
}
if ( $line->has_todo() ) {
$result->[INDEX_TODO]++;
}
if ( $line->is_ok() ) {
$result->[INDEX_PASS]++;
}
else {
$result->[INDEX_FAIL]++;
}
}
elsif ( $line->is_comment() ) {
# ignore
}
else {
warn "Unknown result type `"
. $line->type() . "´: "
. $line->as_string();
}
my $string = join "\t", $test, @{$result};
$writer->print("$string\n");
}
return $parser;
}