#!/usr/bin/perl
Tkx::package_require(
"tile"
);
my
$mw
= Tkx::widget->new(
"."
);
my
$pane
=
$mw
->new_ttk__panedwindow(
-orient
=>
"vertical"
,
);
$pane
->g_pack(
-expand
=> 1,
-fill
=>
"both"
,
);
my
$frame
=
$pane
->new_frame;
$pane
->add(
$frame
,
-weight
=> 1);
my
$tree
=
$frame
->new_ttk__treeview(
-columns
=> [
qw(status time)
],
-height
=> 5,
);
$tree
->heading(
"#0"
,
-text
=>
"Test Name"
,
-command
=>
sub
{ sort_rows(
"#0"
) });
$tree
->heading(
"status"
,
-text
=>
"Status"
,
-command
=>
sub
{ sort_rows(
"status"
) });
$tree
->column(
"status"
,
-width
=> 45,
-anchor
=>
"center"
);
$tree
->heading(
"time"
,
-text
=>
"Time"
,
-command
=>
sub
{ sort_rows(
"time"
) });
$tree
->column(
"time"
,
-width
=> 45,
-anchor
=>
"e"
);
my
$sb
=
$frame
->new_ttk__scrollbar(
-orient
=>
"vertical"
,
-command
=> [
$tree
,
"yview"
],
);
$sb
->g_pack(
-side
=>
"right"
,
-fill
=>
"y"
,
);
$tree
->configure(
-yscrollcommand
=> [
$sb
,
"set"
]);
$tree
->g_pack(
-expand
=> 1,
-fill
=>
"both"
,
-side
=>
"left"
,
);
my
$text
=
$pane
->new_text(
-font
=>
"Helvetica 10"
,
-width
=> 10,
-height
=> 2,
);
$text
->tag_configure(
"heading"
,
-font
=>
"Helvetica 12 bold"
);
$text
->tag_configure(
"code"
,
-font
=>
"Courier 8"
);
$pane
->add(
$text
,
-weight
=> 3);
$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"
);
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"
);
}
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"
;
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
;
$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();
}
$tree
->selection_set(
$old_selection
);
}
sub
tree_select {
my
@sel
= Tkx::SplitList(
$tree
->selection);
$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"
);
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"
);
}
else
{
$text
->insert(
"end"
,
"No result\n"
);
}
}
else
{
my
$num_tests
=
@sel
;
$text
->insert(
"end"
,
"$num_tests tests selected\n"
);
}
}
BEGIN {
my
%ascending
;
sub
sort_rows {
my
$col
=
shift
;
$ascending
{
$col
} = !
$ascending
{
$col
};
my
$kids
=
$tree
->children(
""
);
my
@kids
= Tkx::SplitList(
$kids
);
@kids
=
map
{
$_
->[0] }
sort
{
my
$cmp
=
$a
->[1] cmp
$b
->[1];
$cmp
= -
$cmp
if
$ascending
{
$col
};
$cmp
}
map
{ [
$_
,
$col
eq
"#0"
?
$tree
->item(
$_
,
"-text"
) :
$tree
->set(
$_
,
$col
) ] }
@kids
;
$tree
->detach(
$kids
);
for
my
$item
(
@kids
) {
$tree
->move(
$item
,
""
,
"end"
);
}
}
}