init

livejournal/test/MANIFEST

@@ -0,0 +1,9 @@
+bin/ipl
+examples/example.test.pl
+examples/moveuclusterd_tests.pl
+lib/LJ/Object.pm
+lib/LJ/Test/Assertions.pm
+lib/LJ/Test/Result.pm
+lib/LJ/Test/Unit.pm
+Makefile.PL
+MANIFEST

livejournal/test/MANIFEST.SKIP

@@ -0,0 +1,11 @@
+^#
+\bCVS\b
+^MANIFEST\.
+^Makefile$
+~$
+\.html$
+\.old$
+^blib/
+_blib$
+^MakeMaker-\d
+^\.exists

livejournal/test/Makefile.PL

@@ -0,0 +1,37 @@
+#!/usr/bin/perl
+#
+#   Perl Makefile for LJ-Test
+#   $Id: Makefile.PL,v 1.1 2004/10/30 01:10:20 deveiant Exp $
+#
+#   Invoke with 'perl Makefile.PL'
+#
+#   See ExtUtils::MakeMaker (3) for more information on how to influence
+#    the contents of the Makefile that is written
+#
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME                    => 'LJ-Test',
+    VERSION_FROM            => 'lib/LJ/Test/Unit.pm', # finds $VERSION
+    AUTHOR                  => 'Michael Granger <ged@danga.com>',
+    ABSTRACT                => 'Unit testing for LiveJournal code',
+    PREREQ_PM               => {
+        Scalar::Util        => 0,
+        Time::HiRes         => 0,
+        Carp                => 0,
+        Data::Compare       => 0,
+        Danga::Exceptions   => 1.03,
+        overload            => 0,
+        Class::Translucent  => 0,
+    },
+    dist                    => {
+        CI                      => "cvs commit",
+        RCS_LABEL               => 'cvs tag RELEASE_$(VERSION_SYM)',
+        SUFFIX                  => ".gz",
+        DIST_DEFAULT            => 'all tardist',
+        COMPRESS                => "gzip",
+    },
+
+);
+

livejournal/test/bin/ipl

@@ -0,0 +1,404 @@
+#!/usr/bin/perl
+package IPL::Shell;
+use strict;
+
+BEGIN {
+    use vars qw{$VERSION $RCSID};
+
+    $VERSION    = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+    $RCSID      = q$Id: ipl,v 1.3 2004/11/11 00:51:38 deveiant Exp $;
+
+    use base qw{Shell::Base};
+
+    use Carp            qw{carp croak confess};
+    use Data::Dumper    qw{};
+    use Term::ANSIColor qw{color};
+    use Cwd             qw{cwd};
+    use File::Basename  qw(basename);
+    use Net::Domain     qw(hostfqdn);
+    use String::Format  qw(stringf);
+    use Sys::Hostname   qw(hostname);
+    use Devel::Symdump  qw{};
+
+    $Shell::Base::RE_QUIT = '(?i)^\s*(exit|q(uit)?|logout)';
+}
+
+
+
+#####################################################################
+###	C L A S S   G L O B A L S
+#####################################################################
+
+# Default configuration values
+our %Defaults = (
+    prompt_fmt  => '%{bold cyan}C%p%{white}C %!> ',
+);
+
+
+
+#####################################################################
+###	I N S T A N C E   M E T H O D S
+#####################################################################
+
+### Shell initialization
+sub init {
+    my ( $self, $args ) = @_;
+
+    # Merge defaults
+    %$args = ( %Defaults, %$args );
+
+    # Add instance vars
+    $self->{result_history} = [];
+    $self->{package} = 'main';
+    $self->{prompt_fmt} = $args->{prompt_fmt};
+}
+
+
+### METHOD: init_completions()
+### Initialize the internal COMPLETIONS list.
+sub init_completions {
+    my $self = shift;
+    $self->SUPER::init_completions;
+    $self->completions( map { ":$_" } $self->completions );
+}
+
+
+### Intro/outro message
+sub intro { return qq{IPL: Interactive Perl Shell $VERSION} }
+sub outro { "" }
+
+
+### Prompt callback
+sub prompt {
+    my $self = shift;
+    my $fmt = $self->{prompt_fmt};
+
+    my $prompt = stringf $fmt => {
+        '!' => $self->term->{history_length},
+        '$' => $$,
+        '0' => $self->progname,
+        'C' => sub { color($_[0]) },
+        'H' => hostfqdn,
+        'W' => basename(cwd),
+        'c' => ref($self),
+        'g' => scalar getgrgid($(),
+        'h' => hostname,
+        'p' => $self->{package},
+        'u' => scalar getpwuid($<),
+        'w' => cwd,
+    };
+
+    # Append a reset to clean up if there are color escapes in the prompt
+    $prompt .= color( 'reset' ) if $prompt =~ m{\e\[};
+
+    return "\n$prompt";
+}
+
+
+### METHOD: print( $output )
+### Output method.
+sub print {
+    my $self = shift;
+    my $output = join( "", @_ );
+
+    my $nlcount = $output =~ tr/\n/\n/;
+
+    if ( $nlcount >= $self->{ROWS} - 3 ) {
+        my $pager = $self->pager;
+        open my $P, "|$pager" or carp "Can't open $pager: $!";
+        CORE::print $P $output;
+        close $P;
+    } else {
+        CORE::print $output;
+    }
+
+}
+
+
+### METHOD: parseline( $input )
+### Command-parsing method: parse the specified I<input>, run the specified
+### command, and output the result.
+sub parseline {
+    my ( $self, $input ) = @_;
+
+    if ( $input =~ m{^:(\S+.*)} ) {
+        return $self->SUPER::parseline( $1 );
+    }
+
+    else {
+        return ( "eval", {}, $input );
+    }
+}
+
+
+### METHOD: prettyPrint( $value )
+### Return the given I<value> as a pretty-printed string.
+sub prettyPrint {
+    my ( $self, $val ) = @_;
+
+    local $Data::Dumper::Terse = 1;
+    local $Data::Dumper::Indent = 1;
+    local $Data::Dumper::Pad = "    ";
+
+    my $rval = Data::Dumper->Dumpxs( [$val] );
+    $rval =~ s{^\s+}{};
+    $rval = " => $rval ";
+
+    return $rval;
+}
+
+
+
+#####################################################################
+###	C O M M A N D   M E T H O D S
+#####################################################################
+
+### METHOD: do_shellobj( undef )
+### Implementation of the 'shellobj' command
+sub do_shellobj {
+    my $self = shift;
+    return Data::Dumper->Dumpxs( [$self], [qw{self}] );
+}
+
+
+### METHOD: help_shellobj( undef )
+### Callback for help on the 'shellobj' command.
+sub help_shellobj {
+    return q{Show a dump of the IPL shell object itself.};
+}
+
+
+### METHOD: do_eval( @args )
+### Implementation of the 'eval' command.
+sub do_eval {
+    my ( $self, @args ) = @_;
+
+    my (
+        $input,
+        $res,
+        $rval,
+       );
+
+    $input = join( ' ', @args );
+    #$self->print( "[Evaluating '$input']\n" );
+    $res = eval qq{
+        package $self->{package};
+        no strict;
+        $input ;
+    };
+
+    # Show error message for errors
+    if ( $@ ) {
+        ( $rval = $@ ) =~ s{at \S+ line \d+\..*}{};
+    }
+
+    # Dump everything else
+    else {
+        $rval = $self->prettyPrint( $res );
+    }
+
+    return $rval;
+}
+
+### METHOD: help_eval( undef )
+### Provide help text for the 'eval' command.
+sub help_eval {
+    return q{Evaluate the input as Perl and display the result.};
+}
+
+
+### METHOD: do_rl( $subcmd, @args )
+### Implementation of the 'readline' command.
+sub do_rl {
+    my ( $self, $subcmd, @args ) = @_;
+
+    my $rval = '';
+
+    if ( $subcmd =~ m{features} ) {
+        $rval = $self->prettyPrint( $self->term->Features );
+    }
+
+    elsif ( $subcmd =~ m{module} ) {
+        $rval = "Readline features provided by: " .
+            $self->term->ReadLine;
+    }
+
+    elsif ( $subcmd =~ m{completions} ) {
+        $rval = "Tab-completions: \n" .
+            $self->prettyPrint( [sort $self->completions] );
+    }
+
+    else {
+        $rval = $self->prettyPrint( $self->term );
+    }
+
+    return $rval;
+}
+
+
+### METHOD: help_rl( undef )
+### Return help text for the 'rl' (readline) command.
+sub help_rl {q{
+rl [<subcommand>]
+
+Provide information about the readline implementation used by the shell. The
+<subcommand> can be one of:
+
+features    Dump the hash of features understood by the implementation.
+module      Show the name of the actual module that is providing readline
+            features.
+completions Dump the list of tab-completions.
+
+}}
+
+
+### METHOD: do_perldoc( @args )
+### Implementation of the 'perldoc' command.
+sub do_perldoc {
+    my ( $self, @args ) = @_;
+
+    if ( @args ) {
+        system 'perldoc', @args;
+        return undef;
+    } else {
+        return "'perldoc' requires at least one argument.";
+    }
+}
+
+
+### METHOD: help_perldoc()
+### Help method for the 'perldoc' command.
+sub help_perldoc {q{
+Run the 'perldoc' program.
+}}
+
+
+### METHOD: do_package( $newpkg )
+### Change the package future evals will take place in.
+sub do_package {
+    my ( $self, $package ) = @_;
+
+    if ( $package ) {
+        return "Invalid package name '$package'"
+            unless $package =~ m{^[a-z]\w+(?:::[a-z]\w+)*$}i;
+        $self->{package} = $package;
+        return "Set eval package to: '$package'.";
+    } else {
+        return "Current package is: '$self->{package}'.";
+    }
+}
+
+
+### METHOD: help_package()
+### Help method for the 'package' command.
+sub help_package {q{
+  package [<newpackage>]
+
+Set the package future evaluations will occur in to 'newpackage' if the optional
+argument is given, else just print the name of the current package.
+}}
+
+
+
+
+### METHOD: do_reload()
+### Implementation of the 'reload' command.
+sub do_reload {
+    my $self = shift;
+
+    if ( my $h = $self->histfile ) {
+        $self->term->WriteHistory( $h );
+    }
+
+    $self->print( "Re-execing shell...\n" );
+    local $ENV{IPL_RELOAD} = 1;
+    exec $0;
+    return "Hmmm... something funky happened.";
+}
+
+sub help_reload {q{
+  reload
+
+Reload the shell.
+}}
+
+
+### METHOD: do_inspect( [$package] )
+### Implementation of the 'inspect' command.
+sub do_inspect {
+    my $self = shift;
+    my $package = shift || $self->{package};
+
+    my $inspector = new Devel::Symdump $package;
+
+    no strict;
+    my @out = ( "Symbol table for $package" );
+    my ( %scalars, %arrays, %hashes, %functions, %packages, %filehandles );
+
+    # Grab entries for each type from the symbol table for the inspected
+    # package.
+    %scalars     = map { $_ => ${*{$_}{SCALAR}} } $inspector->scalars;
+    %arrays      = map { $_ => *{$_}{ARRAY} } $inspector->arrays;
+    %hashes      = map { $_ => *{$_}{HASH} } $inspector->hashes;
+    %functions   = map { $_ => *{$_}{CODE} } $inspector->functions;
+    %packages    = map { $_ => undef } $inspector->packages;
+    %filehandles = map { $_ => *{$_}{IO} } $inspector->filehandles;
+
+    # Build displays for each entry in the symbol table, sorted by type,
+    # prepending the sigil for each one. In part stolen from Matthew Simon
+    # Cavalletto's Term::ShellKit::Dev
+    foreach my $output (
+        [ 'Scalars', \%scalars, '$', ],
+        [ 'Arrays', \%arrays, '@'],
+        [ 'Hashes', \%hashes, '%'],
+        [ 'Subs', \%functions, 'sub '],
+        [ 'Packages', \%packages, '::'],
+        [ 'Filehandles', \%filehandles, '*'],
+       ) {
+        next unless scalar keys %{$output->[1]};
+        push @out, "$output->[0]:", '-' x length($output->[0]);
+        foreach ( sort keys %{$output->[1]} ) {
+            if ( defined $output->[1]{$_} ) {
+                push @out, qq{  $output->[2]$_ = "$output->[1]{$_}"};
+            } else {
+                push @out, qq{  $output->[2]$_};
+            }
+        }
+    }
+
+    return join "\n", @out;
+
+
+}
+
+sub help_inspect {q{
+  inspect [<package>]
+
+Inspect the contents of the specified package, or the current package if no
+package is given.
+}}
+
+
+
+#####################################################################
+###	R U N T I M E   P A C K A G E
+#####################################################################
+package ipl;
+use strict;
+
+BEGIN {
+    use Getopt::Long qw{GetOptions};
+    $GetOpt::Long::Bundling = 1;
+}
+
+
+if ( $0 eq __FILE__ ) {
+    my %opts = (
+        HISTFILE => glob("~/.ipl_history"),
+        RCFILES => [glob("~/.iplrc"), ".iplrc"],
+       );
+
+    IPL::Shell->new( %opts )->run;
+}
+
+

livejournal/test/examples/example.test.pl

@@ -0,0 +1,40 @@
+#!/usr/bin/perl -w
+###########################################################################
+
+=head1 Example test script
+
+This is a minimal test suite to demo LJ::Test::Unit.
+
+=head1 CVS
+
+  $Id: example.test.pl,v 1.1 2004/10/30 01:10:21 deveiant Exp $
+
+=cut
+
+###########################################################################
+package moveuclusterd_tests;
+use strict;
+
+use lib qw{lib};
+
+use LJ::Test::Unit          qw{+autorun};
+use LJ::Test::Assertions    qw{:all};
+
+sub test_00_packages {
+    assert( 1 );
+    assert_undef( undef );
+    assert_defined( 1 );
+    assert_no_exception { my $foo = 1; };
+}
+
+sub test_01_fail {
+    fail( "Intentional failure." );
+}
+
+sub test_02_fail2 {
+    assert_no_exception { blargllglg() } "Demo of failing assertion.";
+}
+
+sub test_05_error {
+    plop();
+}

livejournal/test/examples/moveuclusterd_tests.pl

@@ -0,0 +1,130 @@
+#!/usr/bin/perl -w
+###########################################################################
+
+=head1 Tests For moveuclusterd
+
+This is the test suite for 'moveuclusterd', the jobserver half of the
+LiveJournal user-mover.
+
+=cut
+
+###########################################################################
+package moveuclusterd_tests;
+use strict;
+
+use lib ( "$ENV{LJHOME}/bin", "lib" );
+
+use LJ::Test::Unit          qw{+autorun};
+use LJ::Test::Assertions    qw{:all};
+
+BEGIN {
+    require 'moveuclusterd.pl';
+}
+
+
+my @test_goodjobspecs = (
+    q{67645:23:30},
+    q{3932342:117:62 prelock=1},
+    q{1103617:85:88 giddy=whippingcream bollocks=queen prelock=1},
+);
+my @test_badjobspecs = (
+    q{},
+    q{14},
+    q{12:22},
+);
+
+
+### General tests
+sub test_packages {
+    foreach my $package (qw{JobServer JobServer::Job JobServer::Client}) {
+        assert_no_exception { $package->isa('UNIVERSAL') };
+    }
+}
+
+### JobServer::Job class tests
+sub test_jobserverjob_new {
+    my ( $obj, $rval );
+    my $server = new JobServer;
+
+    # Requires a server as first argument
+    assert_exception {
+        new JobServer::Job;
+    };
+
+    # Valid jobspecs
+    foreach my $spec ( @test_goodjobspecs ) {
+        assert_no_exception {
+            $obj = new JobServer::Job $server, $spec
+        };
+        assert_instance_of 'JobServer::Job', $obj;
+
+        my ( $userid, $scid, $dcid, $rest ) = split /[:\s]/, $spec, 4;
+        $rest ||= '';
+
+        assert_no_exception { $rval = $obj->userid };
+        assert_equal $userid, $rval;
+
+        assert_no_exception { $rval = $obj->srcclusterid };
+        assert_equal $scid, $rval;
+
+        assert_no_exception { $rval = $obj->dstclusterid };
+        assert_equal $dcid, $rval;
+
+        assert_no_exception { $rval = $obj->stringify };
+        $rest = sprintf '(%s)', join( '|', split(/\s+/, $rest) );
+        assert_matches qr{$userid:$scid:$dcid \d+.\d+ $rest}, $rval;
+    }
+
+    # Invalid jobspecs
+    foreach my $spec ( @test_badjobspecs ) {
+        assert_exception {
+            new JobServer::Job $server, $spec
+        } "Didn't expect to be able to create job '$spec'";
+    }
+}
+
+
+### JobServer class tests
+sub test_jobserver_new {
+    my $rval;
+
+    assert_no_exception { $rval = new JobServer };
+    assert_instance_of 'JobServer', $rval;
+}
+
+
+sub test_jobserver_addjobs {
+    my $rval;
+    my $js = new JobServer;
+
+    # Should be able to call addJobs() with no jobs.
+    assert_no_exception {
+        local $^W = 0; # Quell LJ::start_request()'s warnings
+        $js->addJobs;
+    };
+
+    # Server should have 0 jobs queued
+    assert_no_exception {
+        $rval = $js->getJobList;
+    };
+    assert_matches qr{0 queued jobs, 0 assigned jobs for 0 clusters}, $rval->{footer}[0];
+    assert_matches qr{0 of 0 total jobs assigned since}, $rval->{footer}[1];
+
+    # Load up some job objects and add those
+    my @jobs = map { new JobServer::Job $js, $_ } @test_goodjobspecs;
+    my $jobcount = scalar @jobs;
+    assert_no_exception {
+        local $^W = 0; # Quell LJ::start_request()'s warnings
+        $js->addJobs( @jobs );
+    };
+
+    # Now server should have the test jobs queued
+    assert_no_exception {
+        $rval = $js->getJobList;
+    };
+    assert_matches qr{$jobcount queued jobs, 0 assigned jobs for \d+ clusters}, $rval->{footer}[0];
+    assert_matches qr{0 of $jobcount total jobs assigned since}, $rval->{footer}[1];
+
+}
+
+

livejournal/test/lib/LJ/Object.pm

@@ -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
+

livejournal/test/lib/LJ/Test/Assertions.pm

@@ -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
+

livejournal/test/lib/LJ/Test/Result.pm

@@ -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
+

livejournal/test/lib/LJ/Test/Unit.pm

@@ -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
+