Powered by ViewCVS 1.0-dev
tweak TkTestRunner
#! /usr/bin/perl -w
# $Id: testrunner.pl,v 1.35 2005/08/07 21:35:53 mca1001 Exp $
use strict;
use vars qw($VERSION);
=head1 NAME
testrunner.pl - easy-typing test run script
=head1 SYNOPSIS
testrunner.pl -I lib -I testlib My::ClassTest My::OtherTest
export PERL5LIB=./lib:./testlib
testrunner.pl My::Suite -g
=head1 DESCRIPTION
Run a L<Test::Unit::TestSuite> containing the class(es) named as
arguments under your choice of L<Test::Unit::TestRunner> subclass
(i.e. front end).
Top part of script just makes items of the classes (included below)
and hits 'go'.
=head1 BUGS & WISHLIST
=over 4
=item *
Sometimes when the last Tk::MainWindow is destroyed, X loses the focus
completely and the window manager (Sawfish or Metacity) can't catch
the window cycling keystroke. Not sure where this starts or how I
work around it.
=item *
No support for the L<Test::Unit::Debug> features, but it's probably
not needed.
### Uncomment and edit to enable framework debugging individual packages
# use Test::Unit::Debug qw(debug_pkgs);
# debug_pkgs(qw/Test::Unit::TestCase/);
=item *
When setting libraries, allow the changes to pass through to
$ENV{PERL5LIB} in case the tests run another Perl. ISTR this gets
complicated where ExtUtils is involved.
=item *
Finish the POD for options.
=item *
Add a C<-M> option which applies after the C<-I>s are done and works
as documented in L<perlrun>, or some useful subset.
=back
=cut
$VERSION = (qw$Revision: 1.35 $)[1];
warn "Running $0 v$VERSION under Perl $]\n";
my $obj = My::TestUtil->new();
$obj->do_cmdline;
$obj->shift_libs;
$obj->load_mods;
# Load and start testrunner, finish with exit code
sub go {
my ($trunner, @args) = $obj->get_runner;
my $ok = $trunner->start(@args);
# if ($obj->gui_runner) {
# # Another bodge to return focus to somewhere (anywhere!)
# # not sure how it gets lost, but sawfish window manager then ignore windowswitch keystrokes
# my $tmp_mw = Tk::MainWindow->new();
# $tmp_mw->waitVisibility;
# $tmp_mw->focusForce;
# $tmp_mw->update;
# $tmp_mw->afterIdle(sub { $tmp_mw->withdraw; $tmp_mw->destroy });
# $tmp_mw->waitWindow;
# }
exit( $ok ? 0 : 1 );
}
main::go(); # will exit
##############################################################################
=head1 My::TestUtil
Shell utility interface. Does Getopt and makes a testrunner. I can't
see how more than one instance would be useful.
Default runner is the terminal one if STDOUT is a tty, else the
original text runner.
=head2 Options
=over 4
=item --gui
=item -g
Use the TkTestRunner.
=item -L
Leak testing with C<use Devel::Leak::Object qw(GLOBAL_bless)>.
=item -l
Leak testing with C<use Devel::Leak::Object>.
=back
There are more.
=cut
package My::TestUtil;
use strict;
use Getopt::Long;
use Test::Unit; # for the version number
sub new {
my ($proto) = @_;
my $class = ref($proto) || $proto;
my $self = {
opt => {
include => [],
objleak_global => 0,
objleak => 0,
},
testclasses => []
};
return bless $self, $class;
}
# Eats everything in @ARGV
sub do_cmdline {
my $self = shift;
my $opt = $self->{opt};
my $p = new Getopt::Long::Parser;
$p->configure('no_ignore_case');
$p->getoptions($opt, $self->get_getopt_args) && !$opt->{help}
or die "Syntax: $0 [--runner|-r Test::Unit::Runner:Foo] [--gui|-g] [-L|-l] My::TestClass ...\n";
push @{ $self->{testclasses} }, splice @ARGV;
}
sub get_getopt_args {('help|h', 'runner|r=s', 'gui|g', 'include|I=s', 'objleak|l', 'objleak_global|L')}
# Move requested library directories from the object instance to
# Perl's global
sub shift_libs {
my $self = shift;
unshift @INC, splice @{ $self->{opt}->{include} };
}
sub load_mods {
my $self = shift;
if ($self->{opt}->{objleak} ||
$self->{opt}->{objleak_global}) {
require Devel::Leak::Object;
import Devel::Leak::Object 'GLOBAL_bless'
if $self->{opt}->{objleak_global};
}
}
sub choose_runner {
my $self = shift;
my $opt = $self->{opt};
if ($opt->{runner}) {
warn "--gui flag ignored, runner specified already\n"
if $opt->{gui};
} else {
if ($opt->{gui}) {
$opt->{runner} = ( $Test::Unit::VERSION eq '0.24'
? "My::TkTestRunner"
: "Test::Unit::TkTestRunner" );
} else {
$opt->{runner} = ( -t STDOUT
? "Test::Unit::Runner::Terminal"
: "Test::Unit::TestRunner" );
}
}
delete $opt->{gui};
return $opt->{runner};
}
sub gui_runner {
my $self = shift;
return $self->choose_runner =~ /::Tk\w*Runner/;
}
sub get_tests {
my $self = shift;
return @{ $self->{testclasses} };
}
# Make and populate a runner, give args to pass to its start method
sub get_runner {
my $self = shift;
my $runner_class = $self->choose_runner;
eval "use $runner_class; 1"
or die "Failed to load testrunner '$runner_class': $@";
# This could be the last time to provide them
die "No test classes specified" unless $self->get_tests;
my $testrunner = $runner_class->new();
# Standard runners won't take more than one test class, so we have
# a suite kicking around
my $runclass = $obj->get_tests > 1 ? "My::TestSuite" : ($obj->get_tests)[0];
return ($testrunner, $runclass);
}
##############################################################################
=head1 My::TestSuite
Minimal bog-standard suite, takes class list from file-scoped C<$obj>.
=cut
package My::TestSuite;
use strict;
use base 'Test::Unit::TestSuite';
sub name {"$0 built-in suite"}
sub include_tests {
return $obj->get_tests;
}
##############################################################################
=head1 My::TkTestRunner
Bodge-around subclass L<Test::Unit::TkTestRunner> replaces
C<show_error_trace> and tails C<new> to fix minor bugs.
=over 4
=item *
ensure that annotations are displayed
=item *
expand the text widget when the 'Details' dialog is resized
=item *
cause the tests to start running when the window appears
=item *
scrollbars only where necessary
=back
=cut
package My::TkTestRunner;
BEGIN { $INC{'My/TkTestRunner.pm'} = $0 } # so future 'use' knows we're already here
use strict;
# This (and the die in 'new') is a compilation speed optimised version
# of "use base 'Test::Unit::TkTestRunner';"
our @ISA;
sub import {
eval "use Tk; 1"
or die "Failed to load Tk: $@";
eval "use 'Test::Unit::TkTestRunner'; 1"
or die "Failed to load superclass: $@";
@ISA = ('Test::Unit::TkTestRunner');
}
sub new {
my $proto = shift;
die "Class has not been 'use'd or 'import'd" unless @ISA;
my $self = $proto->SUPER::new(@_); # normal constructor
# Make a MW in order to attach an idle timer, double-fork style
# When the timer goes off the whole lot is garbagecollected
my $tmp_mw = Tk::MainWindow->new();
my $run_it = sub {
$self->{frame}->waitVisibility;
$self->{frame}->afterIdle(sub{ $self->{run}->invoke });
$tmp_mw->destroy;
};
$tmp_mw->afterIdle($run_it);
warn "$proto: Bodged to autostart under v0.24\n";
return $self;
}
# Replacement method, mostly copied from Test::Unit::TkTestRunner in release v0.24
sub show_error_trace {
# pop up a text dialog containing the details.
my $self = shift;
my $dialog = $self->{frame}->DialogBox(
-title => 'Details',
-buttons => [ 'OK' ]
);
my $selected = $self->{failure_list}->curselection;
return unless defined($selected) && $self->{exceptions}[$selected];
my $text = $dialog->add("Scrolled", "ROText", -width => 80, -height => 20,
-scrollbars => "osoe")
->pack(-expand => 1, -fill => 'both');
$text->insert("end", $self->{exceptions}[$selected]->to_string());
my $e = $self->{exceptions}[$selected];
if ($e->object->annotations()) {
foreach my $data ("\n\nAnnotations:\n", $e->object->annotations()) {
$text->insert("end", $data); # third arg would be a tag
}
}
$dialog->Show();
}
1;
|
Repository owner Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |