view release on metacpan or  search on metacpan

tkx-prove  view on Meta::CPAN

$frame = $mw->new_frame(
    -bd => 5,
);
$frame->g_pack(-fill => "x");
my $bb = $frame->new_ttk__button(
    -text => "Run all tests",
    -command => sub { run_tests(Tkx::SplitList($tree->children(""))) },
);
$bb->g_pack(-side => "left");

$bb = $frame->new_ttk__button(
    -text => "Run selected tests",
    -command => sub { run_tests(Tkx::SplitList($tree->selection)) },
);
$bb->g_pack(-side => "left");

$bb = $frame->new_ttk__button(
    -text => "New dir",
    -command => \&new_test_dir,
);
$bb->g_pack(-side => "left");

my $dir;
my %result;

sub new_test_dir {
    my $dir = Tkx::tk___chooseDirectory(
	-parent => $mw,
        -title => "New test directory",
        -mustexist => 1,
    );
    if ($dir) {
	$dir =~ s,/t/?$,,;
	set_dir($dir);
    }
}

sub set_dir {
    $dir = shift;
    %result = ();

    $tree->delete($tree->children(""));
    $text->delete("1.0", "end");

    use File::Find qw(find);
    find({
	wanted => sub {
	    return unless -f $_;
	    return unless /\.t$/;
	    my $name = substr($File::Find::name, length("$dir/t") + 1);
	    substr($name, -2, 2, "");
	    $tree->insert("", "end", -text => $name, -values => ["-", "-"]);
	},
	no_chdir => 1,
    }, "$dir/t");
}

use Test::Harness::Straps;
my $strap = Test::Harness::Straps->new;

$tree->g_bind("<<TreeviewSelect>>", \&tree_select);

new_test_dir();

Tkx::MainLoop();

sub run_tests {
    my $old_selection = $tree->selection;
    for my $item (@_) {
        my $test = "t/" . $tree->item($item, "-text") . ".t";
	#print "Item $item $test\n";
	delete $result{$item};

        $tree->selection_set($item);
	$tree->see($item);
	$tree->set($item, "status", "-");
	$tree->set($item, "time", "-");
	Tkx::update();

	my $cmd = $strap->_command_line("$dir/$test");
	my $before = time;
	my @output = qx($cmd);
	my $used = time - $before;
	my $status = $?;
	my %res = $strap->analyze($item, \@output);
	$res{output} = join("", @output);
	$res{start_time} = $before;
	$res{used_time} = sprintf "%.03f", $used;
	$res{status} = $status;
	#use Data::Dump; print Data::Dump::dump(\%res), "\n";
	$result{$item} = \%res;

	$tree->set($item, "status", $res{passing} ? ($res{skip_all} ? "skipped" : "ok") : "fail");
	$tree->set($item, "time", sprintf "%.2f", $used);
	tree_select();
	Tkx::update();
	#select(undef, undef, undef, 0.4);
    }
    $tree->selection_set($old_selection);
    #$tree->yview_moveto(0);
}

sub tree_select {
    my @sel = Tkx::SplitList($tree->selection);
    #print "[select @sel]\n";
    $text->delete("1.0", "end");
    if (@sel == 0) {
	$text->insert("end", "No test selected\n");
    }
    elsif (@sel == 1) {
	my $name = $tree->item($sel[0], "-text");
	#$text->insert("end", "$name\n");
	if (my $res = $result{$sel[0]}) {
	    $text->insert("end", "Skipped: $res->{skip_all}\n", "heading") if $res->{skip_all};
	    $text->insert("end", "Passed $res->{ok} of $res->{max} tests in $res->{used_time} seconds.\n");
	    $text->insert("end", "Todo tests: $res->{todo}\n") if $res->{todo};
	    $text->insert("end", "Bonus tests: $res->{bonus}\n") if $res->{bonus};
	    $text->insert("end", "Skipped tests: $res->{skip}\n") if $res->{skip};
	    $text->insert("end", "Status: $res->{status}\n") if $res->{status};
	    $text->insert("end", "\nComplete test output\n\n", "heading");
	    $text->insert("end", $res->{output}, "code");