File Coverage

blib/lib/Test/Unit/GTestRunner.pm

Criterion	Covered	Total	%
statement	29	70	41.4
branch	0	6	0.0
condition	0	6	0.0
subroutine	11	30	36.6
pod			n/a
total	40	112	35.7

#! /bin/false

# $Id: GTestRunner.pm.in,v 1.70 2006/05/12 12:42:14 guido Exp $

# Copyright (C) 2004-2006 Guido Flohr ,
# all rights reserved.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Library General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

package Test::Unit::GTestRunner;

use strict;

use constant DEBUG => 0;

use vars qw ($VERSION $PERL @MY_INC);
$VERSION = '0.04';

package Test::Unit::GTestRunner::Node;

use strict;

sub new {
	my ($class, %args) = @_;

	my $self = {
		__path => $args{path},
		__name => $args{name},
		__is_test => $args{is_test},
		__output => '',
		__result => '',
	};

	bless $self, $class;
}

sub addOutput {
	my ($self, $text) = @_;

	$self->{__output} .= $text;

	return 1;
}

sub setOutput {
	my ($self, $text) = @_;

	$self->{__output} = $text;

	return 1;
}

sub getOutput {
	shift->{__output};
}

sub getStockID {
	my ($self) = @_;

	my $stock_id = '';

	$stock_id = 'gtk-dialog-question'
		if $self->isTest;
	$stock_id = 'gtk-dialog-warning'
		if length $self->getOutput;
	$stock_id = 'gtk-dialog-error'
		if ($self->isError || $self->isFailure);

	return $stock_id;
}

sub getName {
	shift->{__name};
}

sub getPath {
	shift->{__path};
}

sub isError {
	shift->{__error};
}

sub setError {
	my ($self) = @_;

	$self->{__errror} = 1;
}

sub isTest {
	shift->{__is_test};
}

sub isFailure {
	shift->{__failure};
}

sub setFailure {
	my ($self) = @_;

	$self->{__failure} = 1;
}

sub isSuccess {
	my $self = shift;

	return (!$self->isError && !$self->isFailure);
}

sub setSuccess {
	my ($self) = shift;

	delete $self->{__error};
	delete $self->{__failure};
	$self->{__result} = '';

	return;
}

sub getResult {
	shift->{__result};
}

sub setResult {
	my ($self, $result) = @_;

	$self->{__result} = $result;
}

sub getFailurePath {
	shift->{__failure_path};
}

sub setFailurePath {
	my ($self, $path) = @_;

	$self->{__failure_path} = $path;
}

sub unsetFailurePath {
	delete shift->{__failure_path};
}

package Test::Unit::GTestRunner;

use English qw (-no_match_vars);
BEGIN {
	$PERL = $EXECUTABLE_NAME; # Aka $^X.
	@MY_INC = @INC;
}

use Locale::TextDomain qw (Test-Unit-GTestRunner);
use Locale::Messages qw (bind_textdomain_filter bind_textdomain_codeset
						 turn_utf_8_on);
BEGIN {
	bind_textdomain_filter 'Test-Unit-GTestRunner', \&turn_utf_8_on;
	bind_textdomain_codeset 'Test-Unit-GTestRunner', 'utf-8';
}

use MIME::Base64 qw (decode_base64);
use Test::Unit::GTestRunner::Worker;
use Config;
use Gtk2;
use Gtk2::GladeXML;
use Storable qw (thaw);

use constant GUI_STATES => {
	initial => {
		run_menu_item => 0,
		run_button => 0,
		run_selected_menu_item => 0,
		run_selected_button => 0,
		open_menu_item => 1,
		open_button => 1,
		cancel_menu_item => 0,
		cancel_button => 0,
		refresh_menu_item => 0,
		refresh_button => 0,
	},
	loaded => {
		run_menu_item => 1,
		run_button => 1,
		run_selected_menu_item => 0,
		run_selected_button => 0,
		open_menu_item => 1,
		open_button => 1,
		cancel_menu_item => 0,
		cancel_button => 0,
		refresh_menu_item => 1,
		refresh_button => 1,
	},
	loaded_selected => {
		run_menu_item => 1,
		run_button => 1,
		run_selected_menu_item => 1,
		run_selected_button => 1,
		open_menu_item => 1,
		open_button => 1,
		cancel_menu_item => 0,
		cancel_button => 0,
		refresh_menu_item => 1,
		refresh_button => 1,
	},
	running => {
		run_menu_item => 0,
		run_button => 0,
		run_selected_menu_item => 0,
		run_selected_button => 0,
		open_menu_item => 0,
		open_button => 0,
		cancel_menu_item => 1,
		cancel_button => 1,
		refresh_menu_item => 0,
		refresh_button => 0,
	}
};

sub new {
	my $class = shift;

	my $self = {
		__counter => 0,
		__errors => 0,
		__pid => 0,
		__kill_signals => [],
		__last_signal => undef,
		__failures => [],
		__new_file_chooser => 0,
	};

	# Should we make sure that init is called only once?
	Gtk2->init;

	local $/;
	my $data = ;

	# It seems that libglade does not consider our call to
	# bind_textdomain().  We therefore roll our own version.
	my $gettext = $__;
	$data =~ s{
		[ ]translatable="yes">([^<]+)
		}{
			my $string = $1;
			$string =~ s/"/\"/g;
			$string =~ s/'/\'/g;
			$string =~ s/</
			$string =~ s/>/>/g;
			$string =~ s/&/&/g;
			$string = $gettext->{$string};
			$string =~ s/&/&/g;
			$string =~ s/>/>/g;
			$string =~ s/
			$string =~ s/\'/'/g;
			$string =~ s/\"/"/g;
			qq{ translatable="no">$string
	}gex;

	my $gladexml = Gtk2::GladeXML->new_from_buffer ($data);

	bless $self, $class;

	$gladexml->signal_autoconnect_from_package ($self);

	$self->{__gladexml} = $gladexml;

	my $statusbar = $self->{__statusbar} =
		$gladexml->get_widget ('statusbar1');
	my $context_id = $self->{__context_id} =
		$statusbar->get_context_id (__PACKAGE__);
	$statusbar->push ($context_id, ' ' . __"Starting GTestRunner.");

	my $error_textview = $self->{__error_textview} =
		$gladexml->get_widget ('errortextview');
	my $error_textbuffer = Gtk2::TextBuffer->new;
	my $tag = $error_textbuffer->create_tag (
		'error',
		foreground => 'red',
		'foreground-set' => 1,
		weight => 600,
	);

	$error_textview->set_buffer ($error_textbuffer);
	$error_textview->set_wrap_mode ('word');
	$self->{__error_textbuffer} = $error_textbuffer;

	my $progress_bar = $self->{__progress_bar} =
		$gladexml->get_widget ('progressbar');
	my $progress_image = $self->{__progress_image} =
		$gladexml->get_widget ('progressimage');

	$self->{__green} = Gtk2::Gdk::Color->new (0, 65535, 0);
	$self->{__red} = Gtk2::Gdk::Color->new (65535, 0, 0);

	my $failure_view = $gladexml->get_widget ('failure_treeview');
	my $failure_store = Gtk2::ListStore->new ('Glib::String',
											  'Glib::String',
											  'Glib::String',
											  'Glib::String');
	$failure_view->set_model ($failure_store);
	$failure_view->get_selection->set_mode ('multiple');
	$self->{__failure_store} = $failure_store;
	$self->{__failure_view} = $failure_view;

	my $column = Gtk2::TreeViewColumn->new;
	$column->set_title (__"Test");
	$failure_view->append_column ($column);

	my $count = 0;
	my $pixbuf_renderer = Gtk2::CellRendererPixbuf->new;
	$column->pack_start ($pixbuf_renderer, 0);
	$column->add_attribute ($pixbuf_renderer, 'stock-id' => $count++);

	my $text_renderer = Gtk2::CellRendererText->new;
	$column->pack_start ($text_renderer, 1);
	$column->add_attribute ($text_renderer, text => $count++);

	for my $header (__"Test Case", __"Source") {
		my $renderer = Gtk2::CellRendererText->new;
		$column =
			Gtk2::TreeViewColumn->new_with_attributes ($header, $renderer,
													   text => $count++);
		$column->set_resizable (1);
		$column->set_expand (1);
		$failure_view->append_column ($column);
	}

	$failure_view->signal_connect (cursor_changed =>
								   sub {
									   $self->__onFailureChange (@_);
								   });

	my $hierarchy_view = $gladexml->get_widget ('hierarchy_treeview');
	my $hierarchy_store = Gtk2::TreeStore->new ('Glib::String',
												'Glib::String');
	$hierarchy_view->get_selection->set_mode ('multiple');
	$hierarchy_view->set_model ($hierarchy_store);
	$self->{__hierarchy_store} = $hierarchy_store;
	$self->{__hierarchy_view} = $hierarchy_view;

	$hierarchy_view->signal_connect (
		cursor_changed =>
		sub {
			$self->__onHierarchyChange (@_);
		});

	$hierarchy_view->signal_connect (
		row_activated =>
		sub {
			$self->__onHierarchyActivated (@_);
		});

	$column = Gtk2::TreeViewColumn->new;
	$column->set_title (__"Test");
	$hierarchy_view->append_column ($column);

	$pixbuf_renderer = Gtk2::CellRendererPixbuf->new;
	$column->pack_start ($pixbuf_renderer, 0);
	$column->add_attribute ($pixbuf_renderer, 'stock-id' => 1);

	$text_renderer = Gtk2::CellRendererText->new;
	$column->pack_start ($text_renderer, 1);
	$column->add_attribute ($text_renderer, text => 0);

	# It would be sufficient to set this up only once, but we want
	# to avoid both a global and complication.
	$self->{__kill_signals} = [];
	if ($Config{sig_name}) {
		my $i = 0;
		my %signo = ();
		foreach my $name (split / +/, $Config{sig_name}) {
			$signo{$name} = $i if ($name eq 'TERM'
								   || $name eq 'QUIT'
								   || $name eq 'KILL');
			++$i;
		}
		my @killers;
		push @killers, [ TERM => $signo{TERM} ] if $signo{TERM};
		push @killers, [ QUIT => $signo{QUIT} ] if $signo{QUIT};
		push @killers, [ KILL => $signo{KILL} ] if $signo{KILL};
		$self->{__kill_signals} = \@killers;
	}

	my $notebook = $gladexml->get_widget ('notebook');
	$notebook->signal_connect (switch_page =>
								   sub {
									   $self->__onSwitchPage (@_);
								   });

	my $check = $gladexml->get_widget ('always_refresh_checkbutton');
	$check->set_active (1);
	$self->__refreshSuitesBeforeEveryRun ($check);

	# Otherwise a zero kill will report on Zombies.
	$SIG{CHLD} = 'IGNORE' if exists $SIG{CHLD};

	return $self;
}

sub start {
    my ($self, @args) = @_;

    $self->{__suites} = [@args];
	$self->__loadSuite if @args;

    if (@args) {
		$self->__setGUIState ('loaded');
    } else {
		$self->__setGUIState ('initial');
    }

    Gtk2->main;

    return 1;
}

sub main {
    Test::Unit::GTestRunner->new->start (@_);
}

sub __runTests {
	my ($self, $suites) = @_;

	Glib::Source->remove ($self->{__timeout_id}) if $self->{__timeout_id};

	$self->__setGUIState ('running');

	$self->__setErrorTextBuffer ('');
	$self->{__progress_bar}->set_fraction (0);
	$self->{__failure_store}->clear;
	$self->{__failures} = [];
	$self->{__error_count} = 0;
	$self->{__failure_count} = 0;
	$self->{__counter} = 0;
	$self->{__num_planned} = @{$self->{__planned}};
	$self->{__progress_image}->set_from_stock ('gtk-dialog-question',
											   'button');

	foreach my $node (@{$self->{__planned}}) {
		$node->setOutput ('');
		$node->setResult ('');
	}

	foreach my $node (@{$self->{__nodes}}) {
		$node->unsetFailurePath;
	}

	my @suites = $suites ? @{$suites} : @{$self->{__suites}};

	my $arg = join ', ', map {'"' . $_ . '"'} @suites;
	my @local_inc = map { '-I' . $_ } @MY_INC;
	local *CMD;
	my @cmd = ($PERL,
			   @local_inc,
			   '-MTest::Unit::GTestRunner::Worker',
			   #'-d:ptkdb',
			   '-e',
			   "Test::Unit::GTestRunner::Worker->new->start ($arg)",
			   );

	unless (open CMD, '-|', @cmd) {
		my $cmd = pop @cmd;

		foreach my $part (@cmd) {
			my $arg = quotemeta $part;
			$cmd .= " $part";
		}

		my $msg = __x ("Test cannot be started: {cmd}: {err}.",
			       cmd => $cmd, err => $!);
		$self->__setErrorTextBuffer ($msg);
		return;
	}
	$self->{__cmd_fileno} = fileno CMD;
	$self->{__cmd_fh} = *CMD;

	$self->__setStatusBar (__"Running ...");

	$self->{__timeout_id} = Glib::Timeout->add (40, sub {
	    $self->__handleReply;
	    return 1;
	});

	return 1;
}

sub __runAllTests {
	my ($self) = @_;

	$self->__loadSuite if $self->{__always_refresh};

	my @planned;
	foreach my $node (@{$self->{__nodes}}) {
		push @planned, $node if $node->isTest;
	}

	$self->{__planned} = \@planned;

	return $self->__runTests;
}

sub __runSelectedTests {
	my $self = shift;
	my $dirty;

	$self->__loadSuite (\$dirty) if $self->{__always_refresh};
	if ($dirty) {
		my $message = __<
The test suite you want to run has changed.  Please make a new
selection, and run again.
EOF
        my $main_window = $self->{__gladexml}->get_widget ('GTestRunner');
		my $dialog = Gtk2::MessageDialog->new ($main_window,
											   'destroy-with-parent',
											   'error',
											   'ok',
											   $message);
		$dialog->run;
		$dialog->destroy;
		return;
	}

	my $hierarchy_view = $self->{__hierarchy_view};
	my $failure_view = $self->{__failure_view};

	my $hierarchy_paths = [$hierarchy_view->get_selection->get_selected_rows];
	my $failure_paths = [$failure_view->get_selection->get_selected_rows];

	if ($failure_paths) {
		# Convert them into hierarchy_paths.
		for (my $i = 0; $i < @$failure_paths; $i++) {
			my $index = $failure_paths->[$i]->to_string;
			my $node = $self->{__failures}->[0 + $index];

			$failure_paths->[$i] =
				Gtk2::TreePath->new_from_string ($node->getPath);
		}
	}

	my $paths = $failure_paths ?
		@$hierarchy_paths > @$failure_paths
			? $hierarchy_paths
			: $failure_paths
		: $hierarchy_paths;

	my @modules;
	my @planned;
	my %planned;
	foreach my $path (@$paths) {
		my $path_str = $path->to_string;

		my $node = $self->{__nodes_by_path}->{$path_str};

		my $module;
		my $store = $self->{__hierarchy_store};
		my $iterator = $store->get_iter ($path);

		if ($node->isTest) {
			$path_str =~ /:([0-9]+)$/;
			my $testno = $1;
			$path->up;

			($module) = $store->get ($store->get_iter ($path));
			# The number serves as the identifier for our worker thread
			# here.  Remember that Perl module names cannot start with
			# a number.
			$module .= "::$testno";
		} else {
			($module) = $store->get ($store->get_iter ($path));
		}
		push @modules, $module;

		my $path_len = length $path_str;
		foreach my $node (@{$self->{__nodes}}) {
			my $node_path = $node->getPath;

			if ($path_str eq substr $node_path, 0, $path_len) {
				# If a subnode of an already selected node is also
				# selected, we have to avoid to run tests twice.
				next if $planned{$node_path};

				# Skip entities which aren't tests.
				next unless $node->{__is_test};

				push @planned, $node;
				$planned{$node_path} = 1;
			}
		}
	}

	$self->{__planned} = \@planned;
	return $self->__runTests (\@modules);
}

sub __terminateTests {
	my ($self, $message) = @_;

	$self->__setStatusBar ($message) if defined $message;

	$self->__sendKill;

	return 1;
}

sub __cancelTests {
	shift->__terminateTests (__"Waiting for test to terminate ...");
}

sub __refreshSuite {
	my $self = shift;

	$self->__setStatusBar (__"Refreshing the test suite.");
	$self->__loadSuite;
}

sub __refreshSuitesBeforeEveryRun {
	my ($self, $check) = @_;

	my $gladexml = $self->{__gladexml};

    my $active = $self->{__always_refresh} = $check->get_active;

	$gladexml->get_widget ('always_refresh_checkbutton')->set_active ($active);
	$gladexml->get_widget ('always_refresh_menuitem')->set_active ($active);

	return 1;
}

sub __loadSuite {
	my ($self, $dirty_flag) = @_;

	$self->{__failure_store}->clear;

	my $store = Gtk2::TreeStore->new ('Glib::String',
									  'Glib::String');
	my $old_store = $self->{__hierarchy_store};

	$self->__setErrorTextBuffer ('');

	my @suites = @{$self->{__suites}};

	foreach my $suite (@suites) {
		$suite =~ s/\'/\\\'/g;
		$suite = "'$suite'";
	}

	my $arg = join ', ', @suites;
	my @local_inc = map { '-I' . $_ } @MY_INC;
	local *CMD;
	my @cmd = ($PERL,
			   @local_inc,
			   '-MTest::Unit::GTestRunner::Lister',
			   # '-d:ptkdb',
			   '-e',
			   "Test::Unit::GTestRunner::Lister->new->list ($arg)",
			   );

	unless (open CMD, '-|', @cmd) {
		my $cmd = pop @cmd;

		foreach my $part (@cmd) {
			my $arg = quotemeta $part;
			$cmd .= " $part";
		}

		my $msg = __x ("Testsuite cannot be listed: {cmd}: {err}.",
			       cmd => $cmd, err => $!);
		$self->__setErrorTextBuffer ($msg);
		return;
	}

	my @lines = ;
	my $status = shift @lines;
	unless (defined $status && $status eq "SUCCESS\n") {
		$self->__setErrorTextBuffer (join "\n", @lines);
		$self->__resetGUI;
		return;
	}
	# (void)
	close CMD;

	my @indices;
	my $dirty;
	my @nodes;
	foreach my $line (@lines) {
		chomp $line;

		unless ($line =~ /^( *)([-+])([A-Za-z0-9_:]+)$/) {
			$self->__setErrorTextBuffer (__x ("Corrupt test listing: {line}\n",
											  line => $line));
			$self->__resetGUI;
			return;
		}

		my ($spaces, $type, $name) = ($1, $2, $3);
		my $depth = length $spaces;

		unless ($depth <= (1 + @indices)) {
			my $old_depth = @indices;
			my $message =
				__x ("Invalid change in test depth ({old} to {new}).",
					 old => $old_depth, new => $depth);
			$self->__setErrorTextBuffer ($message);
			$self->__resetGUI;
			return;
		}

		$#indices = $depth;
		$indices[$depth] = defined $indices[$depth] ? $indices[$depth] + 1 : 0;

		my $hpath_str = join ':', @indices;
		my $hpath = Gtk2::TreePath->new_from_indices (@indices);

		my %args = (path => $hpath_str,
					name => $name);

		$args{is_test} = 1 if '-' eq $type;

		my $node = Test::Unit::GTestRunner::Node->new (%args);
		push @nodes, $node;

		$hpath->up;
		my $parent = $depth ? $store->get_iter ($hpath) : undef;
		my $iterator = $store->append ($parent);
		$store->set ($iterator,
					 0 => $node->getName,
					 1 => $node->getStockID);

		unless ($dirty) {
			my $new_path = $store->get_path ($iterator);
			my $new_path_str = $new_path->to_string;
			my $old_iter = $old_store->get_iter_from_string ($new_path_str);

			unless ($old_iter) {
				$dirty = 1;
				next;

			}

			my $old_name = $old_store->get ($old_iter, 0);
			$dirty = !defined $old_name || $old_name ne $name;
		}
	}

	if ($dirty) {
		$self->{__nodes} = \@nodes;
		$self->{__hierarchy_view}->set_model ($store);
		$self->{__hierarchy_store} = $store;

		$self->{__nodes_by_path} = {};
		foreach my $node (@nodes) {
			$self->{__nodes_by_path}->{$node->getPath} = $node;
		}
	}

	$$dirty_flag = $dirty if $dirty_flag;

	$self->__setGUIState ('loaded');

	return 1;
}

sub __selectTestCase {
	my ($self, $path_string) = @_;

	my $node = $self->{__nodes_by_path}->{$path_string};

	my $hierarchy_view = $self->{__hierarchy_view};
	my $failure_view = $self->{__failure_view};

	my $hierarchy_paths = [$hierarchy_view->get_selection->get_selected_rows];
	my $failure_paths = [$failure_view->get_selection->get_selected_rows];

	if  ((@$hierarchy_paths || @$failure_paths) && !$self->{__pid}) {
		$self->__setGUIState ('loaded_selected');
	}

	unless ($node->isTest) {
		# This is an inner node of the tree.
		$self->__setErrorTextBuffer ('');

		my $tree_selection = $failure_view->get_selection;
		$tree_selection->unselect_all;

		return 1;
	}

	# This is a leaf, and we have a corresponding test case.
	$self->__setErrorTextBuffer ($node->getResult, $node->getOutput);
	my $hierarchy_path = Gtk2::TreePath->new_from_string ($path_string);

	if ($hierarchy_path) {
		my ($old_path, undef) = $hierarchy_view->get_cursor;

		if (!defined $old_path || $old_path->compare ($hierarchy_path)) {
			$hierarchy_view->expand_to_path ($hierarchy_path);
			$hierarchy_view->scroll_to_cell ($hierarchy_path);
			$hierarchy_view->get_selection->select_path ($hierarchy_path);
			$hierarchy_view->set_cursor ($hierarchy_path);
		}
	}

	my $failure_index = $node->getFailurePath;

	if (defined $failure_index) {
		my $failure_path = Gtk2::TreePath->new_from_string ($failure_index);

		if ($failure_path) {
			my ($old_path, undef) = $failure_view->get_cursor;

			if (!defined $old_path || $old_path->compare ($failure_path)) {
				$failure_view->expand_to_path ($failure_path);
				$failure_view->scroll_to_cell ($failure_path);
				$failure_view->get_selection->select_path ($failure_path);
				$failure_view->set_cursor ($failure_path);
			}
		}
	} else {
		# Unselect.
		my $tree_selection = $failure_view->get_selection;
		$tree_selection->unselect_all;
	}

	return 1;
}

sub __setStatusBar {
	my ($self, $msg) = @_;

	my $statusbar = $self->{__statusbar};
	my $context_id = $self->{__context_id};

	$statusbar->pop ($context_id);

	$context_id = $self->{__context_id} =
		$statusbar->get_context_id (__PACKAGE__);

	$statusbar->push ($context_id, ' ' . $msg);

	return 1;
}

sub __onHierarchyChange {
	my ($self, $view) = @_;

	my ($path, $focus_column) = $view->get_cursor;

	if ($path) {
		my $str_path = $path->to_string;

		return $self->__selectTestCase ($str_path);
	}

	$self->__setErrorTextBuffer ('');

	return 1;
}

sub __onFailureChange {
	my ($self, $view) = @_;

	my ($path, $focus_column) = $view->get_cursor;

	if ($path) {
		my $index = $path->to_string;
		my $node = $self->{__failures}->[0 + $index];

		unless ($self->{__pid}) {
			$self->__setGUIState ('loaded_selected');
		}

		return $self->__selectTestCase ($node->getPath);
	}

	$self->__setErrorTextBuffer ('');

	return 1;
}

sub __onHierarchyActivated {
	my ($self, $view, $path) = @_;

	my $str_path = $path->to_string;

	if ($self->{__tests_by_path}->{$str_path}) {
		my $record = $self->{__tests_by_path}->{$str_path};

		return 1 unless defined $record->{failure_path};

		# Currently selected or not?
		my $selection = $self->{__hierarchy_view}->get_selection;
		my $selected = $selection->path_is_selected ($path);
		$self->__selectAllFailures ($selected);
	} else {
		$view->row_expanded ($path) ?
			$view->collapse_row ($path) : $view->expand_row ($path, 1);
	}

	return 1;
}

sub __onSwitchPage {
	my ($self, $notebook, undef, $current_page) = @_;

	return 1 unless @{$self->{__suites}};

	my $view = $current_page == 0 ?
		$self->{__failure_view} : $self->{__hierarchy_view};

	my $selection = $view->get_selection;

	my $selected = $selection->count_selected_rows;

	unless ($self->{__pid}) {
		if ($selected) {
			$self->__setGUIState ('loaded_selected');
		} else {
			$self->__setGUIState ('loaded');
		}
	}

	return 1;
}

sub __quitApplication {
	Gtk2->main_quit;
}

sub __showAboutDialog {
	my ($self) = @_;

	my $viktor = "\x{412}\x{438}\x{43a}\x{442}\x{43e}\x{440} "
		. "\x{41a}\x{43e}\x{436}\x{443}\x{445}\x{430}\x{440}\x{43e}\x{432} "
		. "";

	my $main_window = $self->{__gladexml}->get_widget ('GTestRunner');
	Gtk2->show_about_dialog ($main_window,
							 name => 'GTestRunner',
							 version => $VERSION,
							 authors => [ 'Guido Flohr ',
										  $viktor],
							 translator_credits =>
							 # TRANSLATORS: Replace this string with your
							 # own names and e-mail addresses, one name
							 # per line.
							 __"translator-credits"
							 );
}

sub __showFileSelection {
	my ($self) = @_;

	$self->{__new_file_chooser} = 1 if exists $ENV{GFC};

	if ($self->{__new_file_chooser}) {
		my $dialog = Gtk2::FileChooserDialog->new (
			__"Select a test suite or test case to run!",
			undef,
			'open',
			'gtk-cancel' => 'GTK_RESPONSE_CANCEL',
			'gtk-open' => 'GTK_RESPONSE_OK',
		);

		$dialog->set_select_multiple (1);
		$dialog->set_current_folder ($self->{__current_dir})
			if $self->{__current_dir};

		my $result = $dialog->run;
		$self->{__suites} = [$dialog->get_filenames] if 'ok' eq $result;
		$self->{__current_dir} = $dialog->get_current_folder;
		$dialog->destroy;
	} else {
		require File::Basename;
		my $dialog = Gtk2::FileSelection->new (__("Select a test suite or " .
												  "test case to run!"));

		$dialog->set_select_multiple (1);
		$dialog->set_filename ($self->{__current_dir})
			if $self->{__current_dir};

		my $result = $dialog->run;

		$self->{__suites} = [$dialog->get_selections] if 'ok' eq $result;
		$self->{__current_dir} =
			File::Basename::dirname ($dialog->get_filename) . '/';
		$dialog->destroy;
	}
	$self->__loadSuite if @{$self->{__suites}};

	return 1;
}

sub __handleReply {
	my ($self) = @_;

	my $rin = '';
	vec ($rin, $self->{__cmd_fileno}, 1) = 1;

	my $win = my $ein = '';
	my $nfound = select $rin, $win, $ein, 0;
	return $self->__terminateTests (__x ("Select on pipe to child process "
										 . "failed: {err}.", err => $!))
		if $nfound < 0;

	return unless $nfound;

	my $num_bytes;
	my $bytes = sysread $self->{__cmd_fh}, $num_bytes, 9;
	return $self->__terminateTests (__("Unexpected end of file while reading "
									   . "from child process.")) unless $bytes;

	return $self->__terminateTests (__x ("Read from pipe to child process "
									. "failed: {err}.", err => $!))
		if $bytes < 0;

	chop $num_bytes;
	$num_bytes = hex $num_bytes;
	return $self->__terminateTests (__("Unexpected end of file while reading "
									   . "from child process."))
		if $bytes <= 0;

	my $reply = '';
	my $chunk;
    my $bytes_to_read = $num_bytes;

	while ($bytes_to_read > 0) {
		$bytes = sysread $self->{__cmd_fh}, $chunk, $bytes_to_read;
		return $self->__terminateTests (__("Unexpected end of file while "
										   . "reading from child process."))
			unless $bytes;
		return $self->__terminateTests (__x ("Read from pipe to child process "
											 . "failed: {err}.", err => $!))
			if $bytes < 0;

		$bytes_to_read -= $bytes;

		chop $chunk;
		$reply .= $chunk;
	}

	warn "<<< REPLY: $reply\n" if DEBUG;

	my ($cmd, $args) = split / +/, $reply, 2;

	my $method = '__handleReply' . ucfirst $cmd;

	warn "+++ REPLY: $reply\n" if DEBUG;
	$self->$method ($args);

	return 1;
}

sub __handleReplyPrint {
	my ($self, $message) = @_;

	my $cleartext = decode_base64 $message;

	my $index = $self->{__counter};

	my $node = $self->{__planned}->[$index];

	$node->addOutput ($cleartext);

	$self->__setErrorTextBuffer ($node->getResult, $node->getOutput);

	# We have been here before.
	return 1 if defined $node->getFailurePath;

	my $hpath_str = $node->getPath;
	$self->__selectTestCase ($hpath_str);

	my $hstore = $self->{__hierarchy_store};
	my $iterator = $hstore->get_iter_from_string ($hpath_str);

	my $test = $hstore->get ($iterator, 0);
	$hstore->set ($iterator, 1 => 'gtk-dialog-warning');

	my $package = '';
	my $hpath = Gtk2::TreePath->new_from_string ($hpath_str);
	if ($hpath->up) {
		$iterator = $hstore->get_iter ($hpath);
		$package = $hstore->get ($iterator, 0);
	}

	my $fstore = $self->{__failure_store};

	$iterator = $fstore->append;
	$fstore->set ($iterator,
				  0 => 'gtk-dialog-warning',
				  1 => $test,
				  2 => $package);

	my $fpath = $fstore->get_path ($iterator);

	$node->setFailurePath ($fpath->to_string);

	push @{$self->{__failures}}, $node;

	$self->__selectTestCase ($node->getPath);

	return 1;
}

sub __handleReplyPid {
	my ($self, $pid) = @_;

	$self->{__pid} = $pid;

	return 1;
}

sub __resetGUI {
    my $self = shift;

    my $gladexml = $self->{__gladexml};

    if (@{$self->{__suites}}) {
		my $notebook = $gladexml->get_widget ('notebook');
		my $current_page = $notebook->get_current_page;
		my $view = $current_page == 0 ?
			$self->{__failure_view} : $self->{__hierarchy_view};
		my $selected = $view->get_selection->count_selected_rows;

		my $state = $selected ? 'loaded_selected' : 'loaded';

		$self->__setGUIState ($state);

    } else {
		$self->__setGUIState ('initial');
    }

    Glib::Source->remove ($self->{__timeout_id}) if $self->{__timeout_id};
    $self->{__pid} = 0;
	undef $self->{__last_signal};

	return 1;
}

sub __handleReplyTerminated {
    my $self = shift;
	$self->__resetGUI;
    $self->__setStatusBar (__"Test terminated.");

    return 1;
}

sub __handleReplyStart {
    my ($self, $test) = @_;

    $self->__setStatusBar (__x"Running: {test}", test => $test);

	my $num_tests = $self->{__counter};

	my $num_errors = $self->{__error_count};
	my $num_failures = $self->{__failure_count} - $num_errors;
	my $message = __nx ("one test, ", "{num_tests} tests, ", $num_tests,
						num_tests => $num_tests);
	$message .= __nx ("one error, ", "{num_errors} errors, ", $num_errors,
						num_errors => $num_errors);
	$message .= __nx ("one failure", "{num_failures} failures", $num_failures,
						num_failures => $num_failures);

	$self->{__progress_bar}->set_text ($message);

	my $index = $num_tests;
	my $node = $self->{__planned}->[$index];

	my $store = $self->{__hierarchy_store};

	my $hpath = Gtk2::TreePath->new_from_string ($node->getPath);
	my $iterator = $store->get_iter ($hpath);

	my $icon = $store->get ($iterator, 1);
	$store->set ($iterator, 1 => 'gtk-apply');

    return 1;
}

sub __handleReplyEnd {
    my ($self, $test) = @_;

	++$self->{__counter};

	my $num_tests = $self->{__counter};
	my $fraction = $self->{__num_planned} ?
		($num_tests / $self->{__num_planned}) : 1;
	$self->{__progress_bar}->set_fraction ($fraction);

	my $num_errors = $self->{__error_count};
	my $num_failures = $self->{__failure_count} - $num_errors;
	my $message = __nx ("one test, ", "{num_tests} tests, ", $num_tests,
						num_tests => $num_tests);
	$message .= __nx ("one error, ", "{num_errors} errors, ", $num_errors,
						num_errors => $num_errors);
	$message .= __nx ("one failure", "{num_failures} failures", $num_failures,
						num_failures => $num_failures);

	$self->{__progress_bar}->set_text ($message);

	if ($num_failures == 0 && $num_errors == 0) {
		$self->{__progress_bar}->modify_bg ('normal', $self->{__green});
		$self->{__progress_image}->set_from_stock ('gtk-apply', 'button');
	}

    return 1;
}

sub __handleReplySuccess {
    my ($self, $reply) = @_;

    my ($test) = split / +/, $reply, 1;

    $self->__setStatusBar (__x"Success: {test}", test => $test);

	my $index = $self->{__counter};

	my $node = $self->{__planned}->[$index];

	my $store = $self->{__hierarchy_store};

	my $hpath = Gtk2::TreePath->new_from_string ($node->getPath);
	my $iterator = $store->get_iter ($hpath);

	my $icon = $store->get ($iterator, 1);
	$store->set ($iterator, 1 => 'gtk-apply')
		unless $icon eq 'gtk-dialog-warning';

    return 1;
}

sub __handleReplyFailure {
    my ($self, $reply) = @_;

	++$self->{__failure_count};

    my ($test, $obj) = split / +/, $reply, 2;

    $self->__setStatusBar (__x"Failure: {test}", test => $test);

    my $failure = thaw decode_base64 $obj;

	my $package = $failure->{package};
	my $file = $failure->{file};
	my $line = $failure->{line};
	my $text = $failure->{text};

	my $index = $self->{__counter};
	my $node = $self->{__planned}->[$index];
	$node->setFailure;

	my $failure_store = $self->{__failure_store};

	my $iterator;
	if (defined $node->getFailurePath) {
		my $fpath = Gtk2::TreePath->new_from_string ($node->getFailurePath);
		$iterator = $failure_store->get_iter ($fpath);
	} else {
		$iterator = $failure_store->append;
		my $fpath = $failure_store->get_path ($iterator);
		$node->setFailurePath ($fpath->to_string);

		push @{$self->{__failures}}, $node;
	}

	$failure_store->set ($iterator,
						 0 => $node->getStockID,
						 1 => $test,
						 2 => $package,
						 3 => "$file:$line");

	$node->setResult ($text);

    $self->__setErrorTextBuffer ($text, $node->getOutput);

	$self->{__progress_image}->set_from_stock ($node->getStockID,
											   'button');
	$self->{__progress_bar}->modify_bg ('normal', $self->{__red});

	my $store = $self->{__hierarchy_store};

	my $hpath = Gtk2::TreePath->new_from_string ($node->getPath);
	$iterator = $store->get_iter ($hpath);
	$store->set ($iterator, 1 => $node->getStockID);

	$self->__selectTestCase ($node->getPath);

    return 1;
}

sub __handleReplyError {
    my ($self, $reply) = @_;

	++$self->{__error_count};

	my $node = $self->{__planned}->[$self->{__counter}];
	$node->setError;

	$self->__handleReplyFailure ($reply);
}

# FIXME! What should happen here?
sub __handleReplyWarning {
	my ($self, $warning) = @_;

	warn "$warning\n";

	return 1;
}

sub __setErrorTextBuffer {
	my ($self, $text, $output) = @_;

	my $buffer = $self->{__error_textbuffer};

	$text = '' unless defined $text;

	$buffer->set_text ($text);

	my ($start, $end) = $buffer->get_bounds;

	$buffer->apply_tag_by_name ('error', $start, $end);
	$buffer->insert ($start, $output) if defined $output;

	return 1;
}

sub __handleReplyAbort {
	my ($self, $message) = @_;

	$self->__setErrorTextBuffer ($message);
	$self->__handleReplyTerminated;
	$self->__setStatusBar (__"Test aborted.");

	return 1;
}

sub __sendKill {
	my ($self) = @_;

	Glib::Source->remove ($self->{__timeout_id}) if $self->{__timeout_id};
	return 1 unless $self->{__pid};

	# Still alive?
	my $alive = kill 0 => $self->{__pid};
	unless ($alive) {
		$self->__resetGUI;
		$self->__setStatusBar (__"Test process terminated.");
		return 1;
	}

	$self->{__last_signal} = -1 unless defined $self->{__last_signal};

	++$self->{__last_signal};

	unless (defined $self->{__kill_signals}->[$self->{__last_signal}]) {
		$self->__resetGUI;
		$self->__setStatusBar
		    (__"Child process cannot be terminated.");
		return 1;
	}

	my ($signame, $signo) =
		@{$self->{__kill_signals}->[$self->{__last_signal}]};

	$self->__setStatusBar (__x ("Child process signaled with SIG{NAME}.",
								NAME => $signame));
	kill $signo => $self->{__pid};

	$self->{__timeout_id} = Glib::Timeout->add (1500, sub {
	    $self->__sendKill;
	    return 1;
	});

	return 1;
}

sub __setGUIState {
	my ($self, $state) = @_;

	my $record = GUI_STATES->{$state};

	unless ($record) {
		my $message = __x (< $state);
Internal error: Unrecognized error state "{state}".  This should
not happen.
EOF

        my $main_window = $self->{__gladexml}->get_widget ('GTestRunner');
		my $dialog = Gtk2::MessageDialog->new ($main_window,
											   'destroy-with-parent',
											   'error',
											   'ok',
											   $message,
											   );
		$dialog->run;
		Gtk2->main_quit;
		exit 1;
	}

	$self->{__gui_state} = $state;

	my $gladexml = $self->{__gladexml};
	while (my ($key, $value) = each %$record) {
		$gladexml->get_widget ($key)->set_sensitive ($value);
	}

	return 1;
}

sub __selectAllFailures {
	my ($self) = @_;

	my $hstore = $self->{__hierarchy_store};
	my $hview = $self->{__hierarchy_view};
	my $hselection = $hview->get_selection;
	$hselection->unselect_all;

	my $fstore = $self->{__failure_store};
	my $fview = $self->{__failure_view};
	my $fselection = $fview->get_selection;
	$fselection->unselect_all;

	my $records = $self->{__tests_by_path};
	foreach my $str_hpath (keys %$records) {
		my $str_fpath = $records->{$str_hpath}->{failure_path};
		next unless defined $str_fpath;

		my $hpath = Gtk2::TreePath->new_from_string ($str_hpath);
		$hselection->select_path ($hpath);

		my $fpath = Gtk2::TreePath->new_from_string ($str_fpath);
		$fselection->select_path ($fpath);
	}

	if (!$self->{__pid}) {
		my $new_state = 'loaded';
		$new_state .= '_selected' if $hselection->count_selected_rows;
	}
}

1;

=head1 NAME

Test::Unit::GTestRunner - Unit testing framework helper class

=head1 SYNOPSIS

 use Test::Unit::GTestRunner;

 Test::Unit::GTestRunner->new->start ($my_testcase_class);

 Test::Unit::GTestRunner::main ($my_testcase_class);

=head1 DESCRIPTION

If you just want to run a unit test (suite), try it like this:

    gtestrunner "MyTestSuite.pm"

Try "perldoc gtestrunner" or "man gtestrunner" for more information.

This class is a GUI test runner using the Gimp Toolkit Gtk+ (which
is called Gtk2 in Perl).  You can use it if you want to integrate
the testing framework into your own application.

For a description of the graphical user interface, please see
gtestrunner(1).

=head1 EXAMPLE

You will usually invoke it from a runner script like this:

    #! /usr/local/bin/perl -w

    use strict;

    require Test::Unit::GTestRunner;

    Test::Unit::GTestRunner::main (@ARGV) or exit 1;

See Test::Unit::TestRunner (3) for details.

An internationalized version would go like this:

    #!/usr/bin/perl -w

    use strict;

    use Test::Unit::GTestRunner;
    use POSIX;
    use Locale::Messages qw (LC_ALL);

    POSIX::setlocale (LC_ALL, "");

    Test::Unit::GTestRunner::main (@ARGV) or exit (1);

=head1 CONSTRUCTOR

=over 4

=item B

The constructor takes no arguments.  It will throw an exception in
case of failure.

=back

=head1 METHODS

=over 4

=item B

The method fires up the graphical user interface and will never
return.

The optional arguments B can either be the name of a file
containing a test suite (see Test::Unit::TestSuite(3pm)), for
example "TS_MySuite.pm", or the name of a Perl module, for example
"Tests::TS_MySuite".  Multiple suites passed as arguments to
the method are assembled into one virtual top-level suite that is
hidden from the display.

=back

=head1 FUNCTIONS

=over 4

=item B

If you prefer a functional interface, you can also start a test
session with

    Test::Unit::GTestRunner::main ($suite_name);

The optional argument B is interpreted as described above
for the method start().

=back

=head1 AUTHOR

Copyright (C) 2004-2006, Guido Flohr [e-mail], all
rights reserved.  See the source code for details.

This software is contributed to the Perl community by Imperia
 (L).

=head1 ENVIRONMENT

The package is internationalized with libintl-perl, hence the
environment variables "LANGUAGE", "LANG", "LC_MESSAGES", and
"LC_ALL" will influence the language in which the GUI and
messages are presented.

=head1 SEE ALSO

gtestrunner(1), Test::Unit::TestRunner(3pm), Test::Unit(3pm),
Locale::Messages(3pm), perl(1)

=cut

#Local Variables:
#mode: perl
#perl-indent-level: 4
#perl-continued-statement-offset: 4
#perl-continued-brace-offset: 0
#perl-brace-offset: -4
#perl-brace-imaginary-offset: 0
#perl-label-offset: -4
#cperl-indent-level: 4
#cperl-continued-statement-offset: 2
#tab-width: 4
#End:

__DATA__