I added short_backtrace() that parallels quell_backtrace() in
assert.pm. It causes a short version of the stacktrace to be printed
that filters out Test::Unit calls. If no calls are left, it prints the
whole stack.
I didn't add it to the Unit.pm interface but it probably should be.
I don't really like how assert.pm handles the flags so if you want to
change it feel free.
-Kevin Connor
Interwoven
###########################################################
SHORT STACKTRACE:
C:\perl\Test-Unit-0.13\examples>perl -I. ..\TestRunner.pl
testcase_fail_example
..F
Time: 0 wallclock secs ( 0.01 usr + 0.00 sys = 0.01 CPU)
!!!FAILURES!!!
Test Results:
Run: 2 Failures: 1 Errors: 0
There was 1 failure:
1) test_fail2(testcase_fail_example): Born to lose ...
Level 2: in package 'testcase_fail_example', file
'testcase_fail_example.pm', at
line '18', sub 'Test::Unit::Assert::assert'
Level 14: in package 'main', file '..\TestRunner.pl', at line '4', sub
'Test::Un
it::TestRunner::start'
Test was not successful.
###########################################################
FULL STACKTRACE:
C:\perl\Test-Unit-0.13\examples>perl -I. ..\TestRunner.pl
testcase_fail_example
..F
Time: 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU)
!!!FAILURES!!!
Test Results:
Run: 2 Failures: 1 Errors: 0
There was 1 failure:
1) test_fail2(testcase_fail_example): Born to lose ...
Level 1: in package 'Test::Unit::Assert', file
'c:\iw-home\iw-perl\site\lib/Test
/Unit/Assert.pm', at line '9', sub 'Test::Unit::Assert::fail'
Level 2: in package 'testcase_fail_example', file
'testcase_fail_example.pm', at
line '18', sub 'Test::Unit::Assert::assert'
Level 3: in package 'Test::Unit::TestCase', file
'c:\iw-home\iw-perl\site\lib/Te
st/Unit/TestCase.pm', at line '65', sub
'testcase_fail_example::test_fail2'
Level 4: in package 'Test::Unit::TestCase', file
'c:\iw-home\iw-perl\site\lib/Te
st/Unit/TestCase.pm', at line '45', sub 'Test::Unit::TestCase::run_test'
Level 5: in package 'Test::Unit::TestCase', file
'c:\iw-home\iw-perl\site\lib/Te
st/Unit/TestCase.pm', at line '44', sub '(eval)'
Level 6: in package 'Test::Unit::TestResult', file
'c:\iw-home\iw-perl\site\lib/
Test/Unit/TestResult.pm', at line '100', sub
'Test::Unit::TestCase::run_bare'
Level 7: in package 'Test::Unit::TestResult', file
'c:\iw-home\iw-perl\site\lib/
Test/Unit/TestResult.pm', at line '110', sub
'Test::Unit::TestResult::__ANON__'
Level 8: in package 'Test::Unit::TestResult', file
'c:\iw-home\iw-perl\site\lib/
Test/Unit/TestResult.pm', at line '109', sub '(eval)'
Level 9: in package 'Test::Unit::TestResult', file
'c:\iw-home\iw-perl\site\lib/
Test/Unit/TestResult.pm', at line '100', sub
'Test::Unit::TestResult::run_protec
ted'
Level 10: in package 'Test::Unit::TestCase', file
'c:\iw-home\iw-perl\site\lib/T
est/Unit/TestCase.pm', at line '36', sub 'Test::Unit::TestResult::run'
Level 11: in package 'Test::Unit::TestSuite', file
'c:\iw-home\iw-perl\site\lib/
Test/Unit/TestSuite.pm', at line '157', sub 'Test::Unit::TestCase::run'
Level 12: in package 'Test::Unit::TestRunner', file
'c:\iw-home\iw-perl\site\lib
/Test/Unit/TestRunner.pm', at line '58', sub
'Test::Unit::TestSuite::run'
Level 13: in package 'Test::Unit::TestRunner', file
'c:\iw-home\iw-perl\site\lib
/Test/Unit/TestRunner.pm', at line '196', sub
'Test::Unit::TestRunner::do_run'
Level 14: in package 'main', file '..\TestRunner.pl', at line '4', sub
'Test::Un
it::TestRunner::start'
Test was not successful.
package Test::Unit::Exception;
use strict;
use constant DEBUG => 0;
sub new {
my $class = shift;
my ($message) = @_;
$message = '' unless defined($message);
$message = ref($class) . ": " . $message . "\n";
my $i = 0;
my $stacktrace = '';
my ($pack, $file, $line, $subname, $hasargs, $wantarray);
while (($pack, $file, $line, $subname,
$hasargs, $wantarray) = caller(++$i)) {
$stacktrace .= "Level $i: in package '$pack', file '$file', at line '$line',
sub '$subname'\n";
}
bless { _message => $message, _stacktrace => $stacktrace }, $class;
}
sub stacktrace {
my $self = shift;
return $self->{_stacktrace};
}
sub get_message {
my $self = shift;
return $self->{_message};
}
sub hide_backtrace {
my $self = shift;
$self->{_hide_backtrace} = 1;
}
sub short_backtrace {
my $self = shift;
$self->{_short_backtrace} = 1;
}
sub to_string {
my $self = shift;
if ($self->{_hide_backtrace})
{
return $self->get_message();
}
elsif ($self->{_short_backtrace})
{
my $short_stacktrace = join "\n",
grep {$_ !~ /package \'Test\:\:Unit/}
split "\n", $self->stacktrace();
$short_stacktrace = $self->stacktrace() if ($short_stacktrace eq "");
return $self->get_message() . $short_stacktrace;
}
return $self->get_message() . $self->stacktrace();
}
1;
__END__
=head1 NAME
Test::Unit::Exception - unit testing framework exception class
=head1 SYNOPSIS
# this class is not intended to be used directly
=head1 DESCRIPTION
This class is used by the framework to communicate the result
of assertions, which will throw an instance of a subclass
of this class in case of errors or failures.
=head1 AUTHOR
Copyright (c) 2000 Christian Lemburg, <[EMAIL PROTECTED]>.
All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as
Perl itself.
Thanks go to the other PerlUnit framework people:
Brian Ewins, Cayte Lindner, J.E. Fritz, Zhon Johansen.
Thanks for patches go to:
Matthew Astley.
=head1 SEE ALSO
- Test::Unit::Assert
- Test::Unit::ExceptionError
- Test::Unit::ExceptionFailure
=cut
package Test::Unit::Assert;
use strict;
use constant DEBUG => 0;
sub assert {
my $self = shift;
print ref($self) . "::assert() called\n" if DEBUG;
my ($condition, $message) = @_;
$self->fail($message) unless $condition;
}
sub fail {
my $self = shift;
print ref($self) . "::fail() called\n" if DEBUG;
my ($message) = @_;
my $ex = Test::Unit::ExceptionFailure->new($message);
$ex->hide_backtrace() unless $self->get_backtrace_on_fail();
$ex->short_backtrace() if $self->get_short_backtrace_on_fail();
die $ex;
}
sub quell_backtrace {
my $self = shift;
$self->{_no_backtrace_on_fail} = 1;
$self->{_short_backtrace_on_fail} = 0;
}
sub short_backtrace {
my $self = shift;
$self->{_short_backtrace_on_fail} = 1;
$self->{_no_backtrace_on_fail} = 0;
}
sub get_short_backtrace_on_fail {
my $self = shift;
return $self->{_short_backtrace_on_fail};
}
sub get_backtrace_on_fail {
my $self = shift;
return $self->{_no_backtrace_on_fail} ? 0 : 1;
}
1;
__END__
=head1 NAME
Test::Unit::Assert - unit testing framework assertion class
=head1 SYNOPSIS
# this class is not intended to be used directly,
# normally you get the functionality by subclassing from
# Test::Unit::TestCase
use Test::Unit::TestCase;
# more code here ...
$self->assert($your_condition_here, $your_optional_message_here);
# NOTE: if you want to use regexes in comparisons, do it like this:
$self->assert(scalar("foo" =~ /bar/), $your_optional_message_here);
=head1 DESCRIPTION
This class is used by the framework to assert boolean conditions
that determine the result of a given test. The optional message
will be displayed if the condition fails. Normally, it is not
used directly, but you get the functionality by subclassing from
Test::Unit::TestCase.
There is one problem with assert(): the arguments to assert() are
evaluated in list context, e.g. making a failing regex "pull" the
message into the place of the first argument. Since this is ususally
just plain wrong, please use scalar() to force the regex comparison
to yield a useful boolean value. I currently do not see a way around
this, since function prototypes don't work for object methods, and
any other tricks (counting argument number, and complaining if there
is only one argument and it looks like a string, etc.) don't appeal
to me. Thanks to Matthew Astley for noting this effect.
The procedural interface to this framework, Test::Unit, does not have
this problem, as it exports a "normal" assert() function, and that can
and does use a function prototype to correct the problem.
=head1 AUTHOR
Copyright (c) 2000 Christian Lemburg, <[EMAIL PROTECTED]>.
All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as
Perl itself.
Thanks go to the other PerlUnit framework people:
Brian Ewins, Cayte Lindner, J.E. Fritz, Zhon Johansen.
Thanks for patches go to:
Matthew Astley, David Esposito.
=head1 SEE ALSO
- Test::Unit::TestCase
- Test::Unit::Exception
- The framework self-testing suite (Test::Unit::tests::AllTests)
=cut
