zlax/ljr
zlax
/
ljr
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
ljr/livejournal/test/lib/LJ/Test/Assertions.pm

677 lines
22 KiB
Perl
Raw Permalink Normal View History

init
2019-02-05 21:49:12 +00:00
#!/usr/bin/perl
##############################################################################
=head1 NAME
LJ::Test::Assertions - Assertion-function library
=head1 SYNOPSIS
use LJ::Test::Assertions qw{:all};
=head1 REQUIRES
C<Carp>, C<Danga::Exceptions>, C<Data::Compare>, C<Data::Dumper>,
C<Scalar::Util>
=head1 DESCRIPTION
None yet.
=head1 EXPORTS
Nothing by default.
This module exports several useful assertion functions for the following tags:
=over 4
=item B<:assertions>
A collection of assertion functions for testing. You can define your own
assertion functions by implementing them in terms of L<assert/"Assertion
Functions">.
L<assert|/"Assertion Functions">, L<assert_not|/"Assertion Functions">,
L<assert_defined|/"Assertion Functions">, L<assert_undef|/"Assertion Functions">,
L<assert_no_exception|/"Assertion Functions">, L<assert_exception|/"Assertion
Functions">, L<assert_exception_type|/"Assertion Functions">,
L<assert_exception_matches|/"Assertion Functions">, L<assert_equals|/"Assertion
Functions">, L<assert_matches|/"Assertion Functions">, L<assert_ref|/"Assertion
Functions">, L<assert_not_ref|/"Assertion Functions">,
L<assert_instance_of|/"Assertion Functions">, L<assert_kind_of|/"Assertion
Functions">, L<fail|/"Assertion Functions">
=item B<:skip>
L<skip_one|/"Skip Functions">, L<skip_all|/"Skip Functions">
=back
=head1 TO DO
=over 4
=item Skip Functions
The skip functions are functional, but the backend isn't set up to handle them
yet.
=item Test::Harness Integration
I ripped out the L<Test::Harness> code when I ported over the
L<Test::SimpleUnit> code for the sake of simplicity. I plan to move that over at
some point.
=item Docs
The docs for most of this stuff is still sketchy.
=back
=head1 AUTHOR
Michael Granger E<lt>ged@danga.comE<gt>
Copyright (c) 2004 Danga Interactive. All rights reserved.
This module is free software. You may use, modify, and/or redistribute this
software under the terms of the Perl Artistic License. (See
http://language.perl.com/misc/Artistic.html)
THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND
FITNESS FOR A PARTICULAR PURPOSE.
=cut
##############################################################################
package LJ::Test::Assertions;
use strict;
use warnings qw{all};
###############################################################################
### I N I T I A L I Z A T I O N
###############################################################################
BEGIN {
### Versioning stuff and custom includes
use vars qw{$VERSION $RCSID};
$VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
$RCSID = q$Id: Assertions.pm,v 1.2 2004/10/30 02:07:22 deveiant Exp $;
# Export functions
use base qw{Exporter};
use vars qw{@EXPORT @EXPORT_OK %EXPORT_TAGS};
@EXPORT = qw{};
%EXPORT_TAGS = (
assertions => [qw{
&assert
&assert_not
&assert_defined
&assert_undef
&assert_no_exception
&assert_exception
&assert_exception_type
&assert_exception_matches
&assert_equal
&assert_equals
&assert_matches
&assert_ref
&assert_not_ref
&assert_instance_of
&assert_kind_of
&fail
}],
skip => [qw{
&skip_one
&skip_all
}],
);
# Create an 'all' Exporter class which is the union of all the others and
# then add the symbols it contains to @EXPORT_OK
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
}
Exporter::export_ok_tags('all');
# Require modules
use Data::Compare qw{Compare};
use Scalar::Util qw{blessed dualvar};
use Data::Dumper qw{};
use Carp qw{croak confess};
# Observer pattern
use vars qw{@Observers};
@Observers = qw{};
}
#####################################################################
### A S S E R T I O N F A I L U R E C L A S S
#####################################################################
{
package LJ::Test::AssertionFailure;
use Danga::Exceptions qw{};
use Carp qw{croak confess};
use base qw{Danga::Exception};
our $ErrorType = "assertion failure";
### Overridden to unwrap frames from the stacktrace.
sub new {
my $proto = shift;
local $Danga::Exception::Depth = $Danga::Exception::Depth + 2;
return $proto->SUPER::new( @_ );
}
### Override the base class's error message to make sense as an exception
### failure.
sub error {
my $self = shift;
my ( $priorframe, $testframe );
my @frames = $self->stacktrace;
for ( my $i = 0; $i <= $#frames; $i++ ) {
next unless $frames[$i]->{package} eq 'LJ::Test::Result';
( $priorframe, $testframe ) = @frames[ $i-1, $i ];
last;
}
unless ( $priorframe ) {
( $priorframe, $testframe ) = @frames[ 0, 1 ];
}
return sprintf( "%s\n\tin %s (%s) line %d\n\t(%s).\n",
$self->message,
$testframe->{subroutine},
$priorframe->{filename},
$priorframe->{line},
scalar localtime($self->timestamp) );
}
}
#####################################################################
### F O R W A R D D E C L A R A T I O N S
#####################################################################
sub assert ($;$);
sub assert_not ($;$);
sub assert_defined ($;$);
sub assert_undef ($;$);
sub assert_no_exception (&;$);
sub assert_exception (&;$);
sub assert_exception_type (&$;$);
sub assert_exception_matches (&$;$);
sub assert_equals ($$;$);
sub assert_matches ($$;$);
sub assert_ref ($$;$);
sub assert_not_ref ($;$);
sub assert_instance_of ($$;$);
sub assert_kind_of ($$;$);
sub fail (;$);
sub skip_one (;$);
sub skip_all (;$);
#####################################################################
### O B S E R V E R F U N C T I O N S
#####################################################################
### METHOD: add_observer( $observer )
### Add the given object, package, or coderef (I<observer>) to the list of
### observers. When an assertion is called, a notification will be sent to the
### registrant. If the specified I<observer> is an object or a package, the
### C<update> method will be called on it. If the observer is a coderef, the
### coderef itself will be called.
sub add_observer {
shift if $_[0] eq __PACKAGE__; # Allow this to be called as a method, too.
my $observer = shift or return;
push @Observers, $observer;
}
### METHOD: remove_observer( $observer )
### Remove the given I<observer> from the list of observers.
sub remove_observer {
shift if $_[0] eq __PACKAGE__; # Allow calling as a method
my $observer = shift or return;
@Observers = grep { "$observer" ne "$_" } @Observers;
}
### METHOD: notify_observers( $type )
### Notify any registered observers that an assertion has been made. The
### I<arguments> will be passed to each observer.
sub notify_observers {
shift if $_[0] eq __PACKAGE__; # Allow calling as a method
foreach my $observer ( @Observers ) {
if ( ref $observer eq 'CODE' ) {
$observer->( __PACKAGE__, @_ );
}
else {
$observer->update( __PACKAGE__, @_ );
}
}
}
### (PRIVATE) FUNCTION: makeMessage( $failureInfo, $format, @args )
### Do sprintf-style formatting on I<format> and I<args> and catenate it with
### the given I<failureInfo> if it's defined and not empty.
sub makeMessage {
my ( $failureInfo, $fmt, @rawargs ) = @_;
local $Data::Dumper::Terse = 1;
my @args = map {
ref $_
? Data::Dumper->Dumpxs([$_], ['_'])
: (defined $_ ? "$_" : "(undef)")
} @rawargs;
my $failureMessage = sprintf( $fmt, @args );
return $failureInfo
? "$failureInfo\n\t$failureMessage"
: $failureMessage;
}
#####################################################################
### A S S E R T I O N F U N C T I O N S
#####################################################################
### (ASSERTION) FUNCTION: assert( $value[, $failureInfo] )
### Die with a failure message if the specified I<value> is not true. If the
### optional I<failureInfo> is given, It will precede the failure message.
sub assert ($;$) {
my ( $assert, $message ) = @_;
__PACKAGE__->notify_observers( 'assert' );
$message ||= "Assertion failed: " . (defined $assert ? "'$assert'" : "(undef)");
throw LJ::Test::AssertionFailure $message unless $assert;
__PACKAGE__->notify_observers( 'success' );
return 1;
}
### (ASSERTION) FUNCTION: assert_not( $value[, $failureInfo] )
### Die with a failure message if the specified I<value> B<is> true. If the
### optional I<failureInfo> is given, it will precede the failure message.
sub assert_not ($;$) {
my ( $assert, $info ) = @_;
my $message = makeMessage( $info, "Expected a false value, got '%s'", $assert );
assert( !$assert, $message );
}
### (ASSERTION) FUNCTION: assert_defined( $value[, $failureInfo] )
### Die with a failure message if the specified I<value> is undefined. If the
### optional I<failureInfo> is given, it will precede the failure message.
sub assert_defined ($;$) {
my ( $assert, $info ) = @_;
my $message = makeMessage( $info, "Expected a defined value, got: %s", $assert );
assert( defined($assert), $message );
}
### (ASSERTION) FUNCTION: assert_undef( $value[, $failureInfo] )
### Die with a failure message if the specified I<value> is B<defined>. If the
### optional I<failureInfo> is given, it will precede the failure message.
sub assert_undef ($;$) {
my ( $assert, $info ) = @_;
my $message = makeMessage( $info, "Expected an undefined value, got %s",
$assert );
assert( !defined($assert), $message );
}
### (ASSERTION) FUNCTION: assert_no_exception( \&coderef[, $failureInfo] )
### Evaluate the specified I<coderef>, and die with a failure message if it
### generates an exception. If the optional I<failureInfo> is given, it will
### precede the failure message.
sub assert_no_exception (&;$) {
my ( $code, $info ) = @_;
eval { $code->() };
( my $errmsg = $@ ) =~ s{ at .* line \d+\.?\s*$}{};
my $message = makeMessage( $info, "Exception raised when none expected:\n\t<$errmsg>" );
assert( ! $@, $message );
}
### (ASSERTION) FUNCTION: assert_exception( \&coderef[, $failureInfo] )
### Evaluate the specified I<coderef>, and die with a failure message if it does
### not generate an exception. If the optional I<failureInfo> is given, it will
### precede the failure message.
sub assert_exception (&;$) {
my ( $code, $info ) = @_;
eval { $code->() };
assert( $@, makeMessage($info, "No exception raised.") );
}
### (ASSERTION) FUNCTION: assert_exception_type( \&coderef, $type[, $failureInfo] )
### Evaluate the specified I<coderef>, and die with a failure message if it does
### not generate an exception which is an object blessed into the specified
### I<type> or one of its subclasses (ie., the exception must return true to
### C<$exception->isa($type)>. If the optional I<failureInfo> is given, it will
### precede the failure message.
sub assert_exception_type (&$;$) {
my ( $code, $type, $info ) = @_;
eval { $code->() };
assert $@, makeMessage($info, "Expected an exception of type '$type', but none was raised.");
my $message = makeMessage( $info, "Exception thrown, but was wrong type" );
assert_kind_of( $type, $@, $message );
}
### (ASSERTION) FUNCTION: assert_exception_matches( \&code, $regex[, $failureInfo] )
### Evaluate the specified I<coderef>, and die with a failure message if it does
### not generate an exception which matches the specified I<regex>. If the
### optional I<failureInfo> is given, it will precede the failure message.
sub assert_exception_matches (&$;$) {
my ( $code, $regex, $info ) = @_;
eval { $code->() };
assert $@, makeMessage($info, "Expected an exception which matched <$regex>, but none was raised.");
my $err = "$@";
my $message = makeMessage( $info, "Exception thrown, but message didn't match" );
assert_matches( $regex, $err, $message );
}
### (ASSERTION) FUNCTION: assert_equal( $wanted, $tested[, $failureInfo] )
### Die with a failure message if the specified I<wanted> value doesn't equal the
### specified I<tested> value. The comparison is done with L<Data::Compare>, so
### arbitrarily complex data structures may be compared, as long as they contain
### no C<GLOB>, C<CODE>, or C<REF> references. If the optional I<failureInfo> is
### given, it will precede the failure message.
sub assert_equal ($$;$) {
my ( $wanted, $tested, $info ) = @_;
my $message = makeMessage( $info, "Values not equal: wanted '%s', got '%s' instead",
$wanted, $tested );
assert( Compare($wanted, $tested), $message );
}
*assert_equals = *assert_equal;
### (ASSERTION) FUNCTION: assert_matches( $wantedRegexp, $testedValue[, $failureInfo] )
### Die with a failure message if the specified I<testedValue> doesn't match the
### specified I<wantedRegExp>. If the optional I<failureInfo> is given, it will
### precede the failure message.
sub assert_matches ($$;$) {
my ( $wanted, $tested, $info ) = @_;
if ( ! blessed $wanted || ! $wanted->isa('Regexp') ) {
$wanted = qr{$wanted};
}
my $message = makeMessage( $info, "Tested value '%s' did not match wanted regex '%s'",
$tested, $wanted );
assert( ($tested =~ $wanted), $message );
}
### (ASSERTION) FUNCTION: assert_ref( $wantedType, $testedValue[, $failureInfo] )
### Die with a failure message if the specified I<testedValue> is not of the
### specified I<wantedType>. The I<wantedType> can either be a ref-type like 'ARRAY'
### or 'GLOB' or a package name for testing object classes. If the optional
### I<failureInfo> is given, it will precede the failure message.
sub assert_ref ($$;$) {
my ( $wantedType, $testValue, $info ) = @_;
my $message = makeMessage( $info, "Expected a %s reference, got <%s>",
$wantedType, $testValue );
assert( ref $testValue &&
(ref $testValue eq $wantedType || UNIVERSAL::isa($wantedType, $testValue)),
$message );
}
### (ASSERTION) FUNCTION: assert_not_ref( $testedValue[, $failureInfo] )
### Die with a failure message if the specified I<testedValue> is a reference of
### any kind. If the optional I<failureInfo> is given, it will precede the
### failure message.
sub assert_not_ref ($;$) {
my ( $testValue, $info ) = @_;
my $message = makeMessage( $info, "Expected a simple scalar, got <%s>", $testValue );
assert( !ref $testValue, $message );
}
### (ASSERTION) FUNCTION: assert_instance_of( $wantedClass, $testedValue[, $failureInfo] )
### Die with a failure message if the specified I<testedValue> is not an instance
### of the specified I<wantedClass>. If the optional I<failureInfo> is given, it will
### precede the failure message.
sub assert_instance_of ($$;$) {
my ( $wantedClass, $testValue, $info ) = @_;
my $message = makeMessage( $info, "Expected an instance of '%s', got a non-object <%s>",
$wantedClass, $testValue );
assert( blessed $testValue, $message );
$message = makeMessage( $info, "Expected an instance of '%s'", $wantedClass );
assert_equals( $wantedClass, ref $testValue, $message );
}
### (ASSERTION) FUNCTION: assert_kind_of( $wantedClass, $testedValue[, $failureInfo] )
### Die with a failure message if the specified I<testedValue> is not an instance
### of the specified I<wantedClass> B<or> one of its derivatives. If the optional
### I<failureInfo> is given, it will precede the failure message.
sub assert_kind_of ($$;$) {
my ( $wantedClass, $testValue, $info ) = @_;
my $message = makeMessage( $info, "Expected an instance of '%s' or a subclass, got <%s>",
$wantedClass, $testValue );
assert( blessed $testValue, $message );
assert( $testValue->isa($wantedClass), $message );
}
### (ASSERTION) FUNCTION: fail( [$message] )
### Die with a failure message unconditionally. If the optional I<message> is
### not given, the failure message will be C<Failed (no reason given)>.
sub fail (;$) {
my $message = shift || "Failed (no reason given)";
__PACKAGE__->notify_observers( 'assert' );
throw LJ::Test::AssertionFailure $message;
}
### (SKIP) FUNCTION: skip_one( [$message] )
### Skip the rest of this test, optionally outputting a message as to why the
### rest of the test was skipped.
sub skip_one (;$) {
my $message = shift || '';
die bless \$message, 'SKIPONE';
}
### (SKIP) FUNCTION: skip_all( [$message] )
### Skip all the remaining tests, optionally outputting a message as to why the
### they were skipped.
sub skip_all (;$) {
my $message = shift || '';
die bless \$message, 'SKIPALL';
}
### Destructors
DESTROY {}
END {}
1;
### AUTOGENERATED DOCUMENTATION FOLLOWS
=head1 FUNCTIONS
=head2 Assertion Functions
=over 4
=item I<assert( $value[, $failureInfo] )>
Die with a failure message if the specified I<value> is not true. If the
optional I<failureInfo> is given, It will precede the failure message.
=item I<assert_defined( $value[, $failureInfo] )>
Die with a failure message if the specified I<value> is undefined. If the
optional I<failureInfo> is given, it will precede the failure message.
=item I<assert_equal( $wanted, $tested[, $failureInfo] )>
Die with a failure message if the specified I<wanted> value doesn't equal the
specified I<tested> value. The comparison is done with L<Data::Compare>, so
arbitrarily complex data structures may be compared, as long as they contain
no C<GLOB>, C<CODE>, or C<REF> references. If the optional I<failureInfo> is
given, it will precede the failure message.
=item I<assert_exception( \&coderef[, $failureInfo] )>
Evaluate the specified I<coderef>, and die with a failure message if it does
not generate an exception. If the optional I<failureInfo> is given, it will
precede the failure message.
=item I<assert_exception_matches( \&code, $regex[, $failureInfo] )>
Evaluate the specified I<coderef>, and die with a failure message if it does
not generate an exception which matches the specified I<regex>. If the
optional I<failureInfo> is given, it will precede the failure message.
=item I<assert_exception_type( \&coderef, $type[, $failureInfo] )>
Evaluate the specified I<coderef>, and die with a failure message if it does
not generate an exception which is an object blessed into the specified
I<type> or one of its subclasses (ie., the exception must return true to
C<$exception->isa($type)>. If the optional I<failureInfo> is given, it will
precede the failure message.
=item I<assert_instance_of( $wantedClass, $testedValue[, $failureInfo] )>
Die with a failure message if the specified I<testedValue> is not an instance
of the specified I<wantedClass>. If the optional I<failureInfo> is given, it will
precede the failure message.
=item I<assert_kind_of( $wantedClass, $testedValue[, $failureInfo] )>
Die with a failure message if the specified I<testedValue> is not an instance
of the specified I<wantedClass> B<or> one of its derivatives. If the optional
I<failureInfo> is given, it will precede the failure message.
=item I<assert_matches( $wantedRegexp, $testedValue[, $failureInfo] )>
Die with a failure message if the specified I<testedValue> doesn't match the
specified I<wantedRegExp>. If the optional I<failureInfo> is given, it will
precede the failure message.
=item I<assert_no_exception( \&coderef[, $failureInfo] )>
Evaluate the specified I<coderef>, and die with a failure message if it
generates an exception. If the optional I<failureInfo> is given, it will
precede the failure message.
=item I<assert_not( $value[, $failureInfo] )>
Die with a failure message if the specified I<value> B<is> true. If the
optional I<failureInfo> is given, it will precede the failure message.
=item I<assert_not_ref( $testedValue[, $failureInfo] )>
Die with a failure message if the specified I<testedValue> is a reference of
any kind. If the optional I<failureInfo> is given, it will precede the
failure message.
=item I<assert_ref( $wantedType, $testedValue[, $failureInfo] )>
Die with a failure message if the specified I<testedValue> is not of the
specified I<wantedType>. The I<wantedType> can either be a ref-type like 'ARRAY'
or 'GLOB' or a package name for testing object classes. If the optional
I<failureInfo> is given, it will precede the failure message.
=item I<assert_undef( $value[, $failureInfo] )>
Die with a failure message if the specified I<value> is B<defined>. If the
optional I<failureInfo> is given, it will precede the failure message.
=item I<fail( [$message] )>
Die with a failure message unconditionally. If the optional I<message> is
not given, the failure message will be C<Failed (no reason given)>.
=back
=head2 Private Functions
=over 4
=item I<makeMessage( $failureInfo, $format, @args )>
Do sprintf-style formatting on I<format> and I<args> and catenate it with
the given I<failureInfo> if it's defined and not empty.
=back
=head2 Skip Functions
=over 4
=item I<skip_all( [$message] )>
Skip all the remaining tests, optionally outputting a message as to why the
they were skipped.
=item I<skip_one( [$message] )>
Skip the rest of this test, optionally outputting a message as to why the
rest of the test was skipped.
=back
=head1 METHODS
=over 4
=item I<add_observer( $observer )>
Add the given object, package, or coderef (I<observer>) to the list of
observers. When an assertion is called, a notification will be sent to the
registrant. If the specified I<observer> is an object or a package, the
C<update> method will be called on it. If the observer is a coderef, the
coderef itself will be called.
=item I<notify_observers( $type )>
Notify any registered observers that an assertion has been made. The
I<arguments> will be passed to each observer.
=item I<remove_observer( $observer )>
Remove the given I<observer> from the list of observers.
=back
=cut