zlax/ljr
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

init

Browse Source
This commit is contained in:
ivan
2019-02-06 00:49:12 +03:00
commit 8dbb1bb605
4796 changed files with 506072 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

232
livejournal/test/lib/LJ/Object.pm Executable file
View File

@@ -0,0 +1,232 @@
#!/usr/bin/perl
##############################################################################
=head1 NAME
LJ::Object - Base object class for LiveJournal object classes.
=head1 SYNOPSIS
use base qw{LJ::Object};
sub new {
my $prot = shift;
my $class = ref $proto || $proto;
return $self->SUPER::new( @_ );
}
=head1 REQUIRES
C<Carp>, C<Class::Translucent>, C<Danga::Exceptions>, C<Scalar::Util>,
C<constant>
=head1 DESCRIPTION
This is a base object class for LiveJournal object classes that provides some
basic useful functionality that would otherwise have to be repeated throughout
various object classes.
It currently provides methods for debugging and logging facilities, translucent
attributes, etc.
=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::Object;
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: Object.pm,v 1.2 2004/10/30 02:07:22 deveiant Exp $;
# Human-readable constants
use constant TRUE => 1;
use constant FALSE => 0;
# Modules
use Carp qw{carp croak confess};
use Scalar::Util qw{blessed};
use Danga::Exceptions qw{:syntax};
# Superclass + class template
use Class::Translucent ({
debugFunction => undef,
logFunction => undef,
debugLevel => 0,
});
# Inheritance
use base qw{Class::Translucent};
}
#####################################################################
### C L A S S V A R I A B L E S
#####################################################################
our ( $AUTOLOAD );
###############################################################################
### P U B L I C M E T H O D S
###############################################################################
### (CLASS) METHOD: DebugMsg( $level, $format, @args )
### If the debug level is C<$level> or above, and the debugFunction is defined,
### call it at the specified level with the given printf C<$format> and
### C<@args>. If the debug level would allow the message, but no debugFunction
### is defined, the LogMsg() method is called instead at the 'debug' priority.
sub DebugMsg {
my $self = shift or throw Danga::MethodError;
my $level = shift;
my $debugLevel = $self->debugLevel;
return unless $level && $debugLevel >= abs $level;
my $message = shift;
if ( $debugLevel > 1 ) {
my $caller = caller;
$message = "<$caller> $message";
}
if (( my $debugFunction = $self->debugFunction )) {
$debugFunction->( $message, @_ );
} else {
$self->LogMsg( 'debug', $message, @_ );
}
}
### (CLASS) METHOD: LogMsg( $level, $format, @args )
### Call the log function (if defined) at the specified level with the given
### printf C<$format> and C<@args>.
sub LogMsg {
my $self = shift or throw Danga::MethodError;
my $logFunction = $self->logFunction or return ();
my (
@args,
$level,
$objectName,
$format,
);
### Massage the format a bit to include the object it's coming from.
$level = shift;
( $objectName = ref $self ) =~ s{(Danga|LJ|FotoBilder)::}{}g;
$format = sprintf( '%s: %s', $objectName, shift() );
# Turn any references or undefined values in the arglist into dumped strings
@args = map { defined $_ ? (ref $_ ? Data::Dumper->Dumpxs([$_], [ref $_]) : $_) : '(undef)' } @_;
# Call the logging callback
$logFunction->( $level, $format, @args );
}
### (PROXY) METHOD: AUTOLOAD( @args )
### Proxy method to build (non-translucent) object accessors.
sub AUTOLOAD {
my $self = shift or throw Danga::MethodError;
( my $name = $AUTOLOAD ) =~ s{.*::}{};
### Build an accessor for extant attributes
if ( blessed $self && exists $self->{$name} ) {
$self->DebugMsg( 5, "AUTOLOADing '%s'", $name );
### Define an accessor for this attribute
my $method = sub : lvalue {
my $closureSelf = shift or throw Danga::MethodError;
$closureSelf->{$name} = shift if @_;
return $closureSelf->{$name};
};
### Install the new method in the symbol table
NO_STRICT_REFS: {
no strict 'refs';
*{$AUTOLOAD} = $method;
}
### Now jump to the new method after sticking the self-ref back onto the
### stack
unshift @_, $self;
goto &$AUTOLOAD;
}
### Try to delegate to our parent's version of the method
my $parentMethod = "SUPER::$name";
return $self->$parentMethod( @_ );
}
### Destructors
END {}
### The package return value (required)
1;
###############################################################################
### D O C U M E N T A T I O N
###############################################################################
### AUTOGENERATED DOCUMENTATION FOLLOWS
=head1 METHODS
=head2 Class Methods
=over 4
=item I<DebugMsg( $level, $format, @args )>
If the debug level is C<$level> or above, and the debugFunction is defined,
call it at the specified level with the given printf C<$format> and
C<@args>. If the debug level would allow the message, but no debugFunction
is defined, the LogMsg() method is called instead at the 'debug' priority.
=item I<LogMsg( $level, $format, @args )>
Call the log function (if defined) at the specified level with the given
printf C<$format> and C<@args>.
=back
=head2 Proxy Methods
=over 4
=item I<AUTOLOAD( @args )>
Proxy method to build (non-translucent) object accessors.
=back
=cut

676
livejournal/test/lib/LJ/Test/Assertions.pm Executable file
View File

@@ -0,0 +1,676 @@
#!/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

207
livejournal/test/lib/LJ/Test/Result.pm Executable file
View File

@@ -0,0 +1,207 @@
#!/usr/bin/perl
##############################################################################
=head1 NAME
LJ::Test::Result - Unit-test result class for LiveJournal testing
=head1 SYNOPSIS
use LJ::Test::Result qw{};
use LJ::Test::Assertions qw{:all};
my $res = new LJ::Test::Result;
$res->run( sub {assert(1)} );
print "Results: ", $res->stringify, "\n\n";
=head1 REQUIRES
C<Danga::Exceptions>, C<LJ::Object>, C<LJ::Test::Assertions>, C<LJ::Test::Unit>
=head1 DESCRIPTION
None yet.
=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::Result;
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: Result.pm,v 1.2 2004/10/30 02:07:22 deveiant Exp $;
use LJ::Test::Unit qw{};
use LJ::Test::Assertions qw{};
use Danga::Exceptions qw{:syntax};
use LJ::Object ({
assertions => 0,
passed => 0,
runs => [],
failures => [],
errors => [],
});
use base qw{LJ::Object};
}
###############################################################################
### C O N S T R U C T O R
###############################################################################
sub new {
my $class = shift;
my $self = $class->SUPER::new( @_ );
$self->assertions( 0 );
$self->passed( 0 );
$self->runs( [] );
$self->failures( [] );
$self->errors( [] );
return $self;
}
### METHOD: run( \&coderef )
### Run a test I<coderef>, counting assertions, errors, and failures towards the
### result.
sub run ($&) {
my ( $self, $testcode ) = @_;
my $rchar = '.';
try {
$self->pushRuns( "$testcode" );
LJ::Test::Assertions->add_observer( $self );
$testcode->();
} catch LJ::Test::AssertionFailure with {
my ( $failure, $keeptrying ) = @_;
$self->pushFailures( $failure );
$$keeptrying = 0;
$rchar = 'F';
} catch Danga::Exception with {
my $error = shift;
$self->pushErrors( $error );
$rchar = 'E';
} finally {
LJ::Test::Assertions->remove_observer( $self );
};
return $rchar;
}
### METHOD: update( $package, $type )
### Observable callback: Called from LJ::Test::Assertion when an assertion is
### made or passes.
sub update {
my $self = shift or throw Danga::MethodError;
my ( $package, $type ) = @_;
if ( $type eq 'assert' ) {
$self->{assertions}++;
}
elsif ( $type eq 'success' ) {
$self->{passed}++;
}
else {
warn "Unhandled update type '$type' from '$package'";
}
}
### METHOD: stringify()
### Return a string representation of the test results as a scalar.
sub stringify {
my $self = shift or throw Danga::MethodError;
my @rval = ("");
my @exceptions;
# Add any error traces that occurred
if (( @exceptions = $self->errors )) {
push @rval, "Errors:";
foreach my $exception ( @exceptions ) {
push @rval, $exception->stringify;
}
}
# Add any assertion failure messages
if (( @exceptions = $self->failures )) {
push @rval, "Failures:";
foreach my $failure ( @exceptions ) {
push @rval, $failure->error;
}
}
# Now append the totals
push @rval, sprintf( "%d tests, %d assertions, %d failures, %d errors",
scalar @{$self->{runs}},
$self->{assertions},
scalar @{$self->{failures}},
scalar @{$self->{errors}} );
return join( "\n", @rval );
}
1;
### AUTOGENERATED DOCUMENTATION FOLLOWS
=head1 METHODS
=over 4
=item I<run( \&coderef )>
Run a test I<coderef>, counting assertions, errors, and failures towards the
result.
=item I<stringify()>
Return a string representation of the test results as a scalar.
=item I<update( $package, $type )>
Observable callback: Called from LJ::Test::Assertion when an assertion is
made or passes.
=back
=cut

295
livejournal/test/lib/LJ/Test/Unit.pm Executable file
View File

@@ -0,0 +1,295 @@
#!/usr/bin/perl
##############################################################################
=head1 NAME
LJ::Test::Unit - unit-testing framework for LiveJournal
=head1 SYNOPSIS
use LJ::Test::Unit qw{+autorun};
use My::FooModule ();
sub test_foo { assert My::FooModule::foo() }
=head1 EXAMPLE
use LJ::Test::Unit qw{+autorun};
use LJ::Test::Assertions qw{:all};
# Require the module
sub test_require {
# Make sure we can load the module to be tested.
assert_no_exception { require MyClass };
# Try to import some functions, generating a custom error message if it
# fails.
assert_no_exception { MyClass->import(':myfuncs') } "Failed to import :myfuncs";
# Make sure calling 'import()' actually imported the functions
assert_ref 'CODE', *::myfunc{CODE};
assert_ref 'CODE', *::myotherfunc{CODE};
}
=head1 DESCRIPTION
This is a simplified Perl unit-testing framework for creating unit tests to be
run either standalone or under Test::Harness.
=head2 Testing
Testing in LJ::Test::Unit is done by running a test suite, either via 'make
test', which uses the L<Test::Harness|Test::Harness> 'test' target written by
L<ExtUtils::MakeMaker|ExtUtils::MakeMaker>, or as a standalone script.
If errors occur while running tests via the 'make test' method, you can get more
verbose output about the test run by adding C<TEST_VERBOSE=1> to the end of the
C<make> invocation:
$ make test TEST_VERBOSE=1
If you want to display only the messages caused by failing assertions, you can
add a C<VERBOSE=1> to the end of the C<make> invocation instead:
$ make test VERBOSE=1
=head2 Test Suites
A test suite is one or more test cases, each of which tests a specific unit of
functionality.
=head2 Test Cases
A test case is a unit of testing which consists of one or more tests, combined
with setup and teardown functions that make the necessary preparations for
testing.
You may wish to split test cases up into separate files under a C<t/> directory
so they will run under a L<Test::Harness|Test::Harness>-style C<make test>.
=head2 Tests
You can run tests in one of two ways: either by calling L<runTests> with a list
of function names or CODErefs to test, or by using this module with the
':autorun' tag, in which case any subs whose name begins with C<'test_'> will
automatically run at the end of the script.
=head1 REQUIRES
C<Carp>, C<Data::Dumper>, C<LJ::Test::Assertions>, C<LJ::Test::Result>,
C<Time::HiRes>, C<constant>
=head1 LICENSE
This module borrows liberally from the Test::SimpleUnit CPAN module, the license
of which is as follows:
Michael Granger E<lt>ged@danga.comE<gt>
Copyright (c) 1999-2003 The FaerieMUD Consortium. 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)
LiveJournal-specific code is also licensed under the the same terms as Perl
itself:
Copyright (c) 2004 Danga Interactive. All rights reserved.
=cut
##############################################################################
package LJ::Test::Unit;
use strict;
use warnings qw{all};
###############################################################################
### I N I T I A L I Z A T I O N
###############################################################################
BEGIN {
# Versioning
use vars qw{$VERSION $RCSID};
$VERSION = 1.21;
$RCSID = q$Id: Unit.pm,v 1.2 2004/10/30 02:07:22 deveiant Exp $;
# More readable constants
use constant TRUE => 1;
use constant FALSE => 0;
# Main unit-testing modules
use LJ::Test::Assertions qw{:all};
use LJ::Test::Result qw{};
# Load other modules
use Carp qw{croak confess};
use Time::HiRes qw{gettimeofday tv_interval};
use Data::Dumper qw{};
# Export the 'runTests' function
use vars qw{@EXPORT @EXPORT_OK %EXPORT_TAGS};
@EXPORT_OK = qw{&runTests};
use base qw{Exporter};
}
our @AutorunPackages = ();
### Exporter callback -- support :autorun tag
sub import {
my $package = shift;
my @args = @_;
my @pureargs = grep { !/\+autorun/ } @args;
if ( @args != @pureargs ) {
push @AutorunPackages, scalar caller;
}
__PACKAGE__->export_to_level( 1, $package, @pureargs );
}
### FUNCTION: extractTestFunctions( @packages )
### Iterate over the specified I<packages>' symbol tables and return a list of
### coderefs that point to functions contained in those packages that are named
### 'test_*'.
sub extractTestFunctions {
my @packages = @_ or croak "No package given.";
my (
$glob, # Iterated glob for symbol table traversal
$coderef, # Extracted coderef from symtable glob
@tests, # Collected coderefs for test functions
);
@tests = ();
# Iterate over the package's symbol table, extracting coderefs to functions
# that are named 'test_*'.
PACKAGE: foreach my $package ( @packages ) {
no strict 'refs';
SYMBOL: foreach my $sym ( sort keys %{"${package}::"} ) {
next SYMBOL unless $sym =~ m{test_};
$coderef = extractFunction( $package, $sym );
push @tests, $coderef;
}
}
return @tests;
}
### FUNCTION: extractFunction( $package, $funcname )
### Given a I<package> and a function name I<funcname>, extract its coderef from
### the symbol table and return it.
sub extractFunction {
my $package = shift or croak "No package name given.";
my $sym = shift or croak "No function name given";
no strict 'refs';
my $glob = ${"${package}::"}{ $sym } or return undef;
return *$glob{CODE};
}
### FUNCTION: prepTests( $package[, @rawTests] )
### Normalize the given I<rawTests> (which can be coderefs or function names)
### and return them as coderefs. If I<rawTests> is empty, extract functions from
### the given I<package> and return those.
sub prepTests {
my $package = shift or croak "No calling package specified.";
my @rawtests = @_;
my @tests = ();
@rawtests = extractTestFunctions( $package ) if !@rawtests;
my $coderef;
foreach my $test ( @rawtests ) {
push( @tests, $test), next if ref $test eq 'CODE';
$coderef = extractFunction( $package, $test )
or croak "No such test '$test' in $package";
push @tests, $coderef;
}
return @tests;
}
### FUNCTION: runTests( [@tests] )
### Run the specified I<tests> and report the result. The I<tests> can be
### coderefs or names of functions in the current package. If no I<tests> are
### specified, functions that are named 'test_*' in the current package are
### assumed to be the test functions.
sub runTests {
my @tests = prepTests( scalar caller, @_ );
my $result = new LJ::Test::Result;
print "Started.\n";
my $starttime = [gettimeofday];
$|++;
foreach my $test ( @tests ) {
print $result->run( $test );
}
printf "\nFinished in %0.5fs\n", tv_interval( $starttime );
print $result->stringify, "\n\n";
return;
}
### Extract tests from packages that were registered for 'autorun' and run them.
END {
return unless @AutorunPackages;
# Extract coderefs from autorun packages.
my @tests = extractTestFunctions( @AutorunPackages );
runTests( @tests );
}
1;
### AUTOGENERATED DOCUMENTATION FOLLOWS
=head1 FUNCTIONS
=over 4
=item I<extractFunction( $package, $funcname )>
Given a I<package> and a function name I<funcname>, extract its coderef from
the symbol table and return it.
=item I<extractTestFunctions( @packages )>
Iterate over the specified I<packages>' symbol tables and return a list of
coderefs that point to functions contained in those packages that are named
'test_*'.
=item I<prepTests( $package[, @rawTests] )>
Normalize the given I<rawTests> (which can be coderefs or function names)
and return them as coderefs. If I<rawTests> is empty, extract functions from
the given I<package> and return those.
=item I<runTests( [@tests] )>
Run the specified I<tests> and report the result. The I<tests> can be
coderefs or names of functions in the current package. If no I<tests> are
specified, functions that are named 'test_*' in the current package are
assumed to be the test functions.
=back
=cut