changelog | [dw-free] Tests which use convenience methods report failures unhelpfully

[commit: http://hg.dwscoalition.org/dw-free/rev/f7b821ec9d41]

http://bugs.dwscoalition.org/show_bug.cgi?id=3553

Report a more accurate line number, and divide into subtests where
applicable.

Patch by

fu.

Files modified:

t/atom-post.t
t/cleaner-link.t
t/directorysearch.t
t/jabber-presence.t
t/paid-time.t
t/protocol.t
t/synsuck.t
t/user-infoshow-migrate.t

--------------------------------------------------------------------------------
diff -r 5fe1dc7c915a -r f7b821ec9d41 t/atom-post.t
--- a/t/atom-post.t	Tue Mar 01 15:22:55 2011 +0800
+++ b/t/atom-post.t	Tue Mar 01 16:59:00 2011 +0800
@@ -64,41 +64,45 @@ sub check_entry {
 sub check_entry {
     my ( $atom_entry, $entry_info, $journal ) = @_;
 
-    ok( $atom_entry, "Got an atom entry back from the server" );
-    is( $atom_entry->title, $entry_info->{title}, "atom entry has right title" )
-        if defined $entry_info->{title};
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
 
-    # having the content body be of type HTML
-    # causes newlines to appear for some reason when we try to extract the content as a string
-    # so let's just work around it; it should be harmless (as_xml doesn't contain the extra newlines)
-    my $event_raw = $entry_info->{content};
-    like( $atom_entry->content->body, qr/\s*$event_raw\s*/, "atom entry has right content" )
-        if defined $entry_info->{content};
+    subtest "check_entry $entry_info->{id} - $entry_info->{title}"  => sub {
+        ok( $atom_entry, "Got an atom entry back from the server" );
+        is( $atom_entry->title, $entry_info->{title}, "atom entry has right title" )
+            if defined $entry_info->{title};
 
-    is( $atom_entry->id, $entry_info->{atom_id}, "atom id" )
-        if defined $entry_info->{atom_id};
+        # having the content body be of type HTML
+        # causes newlines to appear for some reason when we try to extract the content as a string
+        # so let's just work around it; it should be harmless (as_xml doesn't contain the extra newlines)
+        my $event_raw = $entry_info->{content};
+        like( $atom_entry->content->body, qr/\s*$event_raw\s*/, "atom entry has right content" )
+            if defined $entry_info->{content};
 
-    is( $atom_entry->author->name, $entry_info->{author}, "atom entry author" )
-        if defined $entry_info->{author};
+        is( $atom_entry->id, $entry_info->{atom_id}, "atom id" )
+            if defined $entry_info->{atom_id};
 
-    if ( defined $entry_info->{url} ) {
-        my @links = $atom_entry->link;
-        is( scalar @links, 2, "got back two links" );
-        foreach my $link( @links ) {
-            if ( $link->rel eq "edit" ) {
-                is( $link->href, $journal->atom_base . "/entries/$entry_info->{id}", "edit link" );
-            } else { # alternate
-                is( $link->href, $entry_info->{url}, "entry link" );
+        is( $atom_entry->author->name, $entry_info->{author}, "atom entry author" )
+            if defined $entry_info->{author};
+
+        if ( defined $entry_info->{url} ) {
+            my @links = $atom_entry->link;
+            is( scalar @links, 2, "got back two links" );
+            foreach my $link( @links ) {
+                if ( $link->rel eq "edit" ) {
+                    is( $link->href, $journal->atom_base . "/entries/$entry_info->{id}", "edit link" );
+                } else { # alternate
+                    is( $link->href, $entry_info->{url}, "entry link" );
+                }
             }
         }
-    }
 
-    if ( defined $entry_info->{categories} ) {
-        my %tags = map { $_ => 1 } @{ $entry_info->{categories} || [] };
-        my %categories = map { $_->term => 1 } $atom_entry->category;
-        is( scalar keys %categories, 2, "got back multiple categories" );
-        is_deeply( { %categories }, { %tags }, "got back the categories we sent in" );
-    }
+        if ( defined $entry_info->{categories} ) {
+            my %tags = map { $_ => 1 } @{ $entry_info->{categories} || [] };
+            my %categories = map { $_->term => 1 } $atom_entry->category;
+            is( scalar keys %categories, 2, "got back multiple categories" );
+            is_deeply( { %categories }, { %tags }, "got back the categories we sent in" );
+        }
+    };
 }
 
 
diff -r 5fe1dc7c915a -r f7b821ec9d41 t/cleaner-link.t
--- a/t/cleaner-link.t	Tue Mar 01 15:22:55 2011 +0800
+++ b/t/cleaner-link.t	Tue Mar 01 16:59:00 2011 +0800
@@ -20,6 +20,8 @@ sub clean {
 }
 
 sub is_cleaned {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my $input = shift;
     my $type = shift;
     my $output = clean($input);
@@ -27,6 +29,8 @@ sub is_cleaned {
 }
 
 sub not_cleaned {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my $input = shift;
     my $type = shift;
     my $output = clean($input);
diff -r 5fe1dc7c915a -r f7b821ec9d41 t/directorysearch.t
--- a/t/directorysearch.t	Tue Mar 01 15:22:55 2011 +0800
+++ b/t/directorysearch.t	Tue Mar 01 16:59:00 2011 +0800
@@ -22,6 +22,8 @@ my @args;
 my @args;
 
 my $is = sub {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my ($name, $str, @good_cons) = @_;
     my %args = map { LJ::durl($_) } split(/[=&]/, $str);
     my @cons = sort { ref($a) cmp ref($b) } LJ::Directory::Constraint->constraints_from_formargs(\%args);
diff -r 5fe1dc7c915a -r f7b821ec9d41 t/jabber-presence.t
--- a/t/jabber-presence.t	Tue Mar 01 15:22:55 2011 +0800
+++ b/t/jabber-presence.t	Tue Mar 01 16:59:00 2011 +0800
@@ -70,70 +70,96 @@ delobj_all( $one );
 } );
 
 sub add {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
     my $args = shift;
     my $obj = LJ::Jabber::Presence->create( %$args );
 
-    $presence{$args->{resource}} = 1;
-
-    ok( $obj, "Object create" );
-    checkattrs( $obj, $args );
-    checkres( $args->{u}, scalar( keys %presence ) );
+    subtest "add $args->{resource} - $args->{client}" => sub {
+        $presence{$args->{resource}} = 1;
+    
+        ok( $obj, "Object create" );
+        checkattrs( $obj, $args );
+        checkres( $args->{u}, scalar( keys %presence ) );
+    };
 
     return $obj;
 }
 
 sub load {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my $args = shift;
     my $obj = LJ::Jabber::Presence->new( $args->{u}, $args->{resource} );
 
-    ok( $obj, "Object load" );
-    checkattrs( $obj, $args );
-    checkres( $args->{u}, scalar( keys %presence ) );
+    subtest "load $args->{resource} - $args->{client}" => sub {
+        ok( $obj, "Object load" );
+        checkattrs( $obj, $args );
+        checkres( $args->{u}, scalar( keys %presence ) );
+    };
 
     return $obj;
 }
 
 sub del {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my $args = shift;
-    LJ::Jabber::Presence->delete( $args->{u}->id, $args->{resource} );
 
-    delete $presence{$args->{resource}};
-
-    checkres( $args->{u}, scalar( keys %presence ) );
+    subtest "del $args->{resource} - $args->{client}" => sub {
+        LJ::Jabber::Presence->delete( $args->{u}->id, $args->{resource} );
+    
+        delete $presence{$args->{resource}};
+    
+        checkres( $args->{u}, scalar( keys %presence ) );
+    };
 }
 
 sub delobj {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my $args = shift;
     my $obj = load( $args );
 
-    delete $presence{$args->{resource}};
-    $obj->delete;
-
-    checkres( $args->{u}, scalar( keys %presence ) );
+    subtest "delobj $args->{resource} - $args->{client}" => sub {
+        delete $presence{$args->{resource}};
+        $obj->delete;
+    
+        checkres( $args->{u}, scalar( keys %presence ) );
+    };
 }
 
 sub del_all {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my $u = shift;
-    LJ::Jabber::Presence->delete_all( $u->id );
 
-    %presence = ();
-
-    checkres( $u, 0 );
+    subtest "delall" => sub {
+        LJ::Jabber::Presence->delete_all( $u->id );
+    
+        %presence = ();
+    
+        checkres( $u, 0 );
+    };
 }
 
 sub delobj_all {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my $args = shift;
     my $obj = load( $args );
 
-    %presence = ();
-    $obj->delete_all;
-
-    checkres( $args->{u}, 0 );
+    subtest "delobj_all $args->{resource} - $args->{client}" => sub {
+        %presence = ();
+        $obj->delete_all;
+    
+        checkres( $args->{u}, 0 );
+    };
 }
 
 sub checkattrs {
     my $obj = shift;
     my $check = shift;
+
     is( $obj->u, $check->{u}, "User matches" );
     is( $obj->resource, $check->{resource}, "Resource matches" );
     is( $obj->cluster, $check->{cluster}, "cluster matches" );
diff -r 5fe1dc7c915a -r f7b821ec9d41 t/paid-time.t
--- a/t/paid-time.t	Tue Mar 01 15:22:55 2011 +0800
+++ b/t/paid-time.t	Tue Mar 01 16:59:00 2011 +0800
@@ -7,7 +7,7 @@ use DW::Pay;
 use DW::Pay;
 use LJ::Test qw (temp_user);
 
-plan tests => 29;
+plan tests => 8;
 
 my $u1 = temp_user();
 my $paidmos = 0;
@@ -26,15 +26,23 @@ sub rst {
 }
 
 sub assert {
-    my ( $u, $type ) = @_;
-    my ($typeid) = grep { $LJ::CAP{$_}->{_account_type} eq $type } keys %LJ::CAP;
-    ok( $typeid, 'valid class' );
+    my ( $u, $type, $testname ) = @_;
 
-    my $ps = DW::Pay::get_paid_status( $u );
-    my $secs = 86400 * $paidmos;
-    ok( $ps, 'got paid status' );
-    ok( $ps->{typeid} == $typeid, 'typeids match' );
-    ok( abs( $ps->{expiresin} - $secs) < 60, 'secs match within a minute' );
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+    subtest $testname => sub {
+        plan tests => 4;
+
+        my ($typeid) = grep { $LJ::CAP{$_}->{_account_type} eq $type } keys %LJ::CAP;
+        ok( $typeid, 'valid class' );
+
+        my $ps = DW::Pay::get_paid_status( $u );
+        my $secs = 86400 * $paidmos;
+        ok( $ps, 'got paid status' );
+        ok( $ps->{typeid} == $typeid, 'typeids match' );
+        ok( abs( $ps->{expiresin} - $secs) < 60, 'secs match within a minute' );
+
+    }
 }
 
 ################################################################################
@@ -45,14 +53,14 @@ DW::Pay::add_paid_time( $u1, 'paid', 1 )
     or die DW::Pay::error_text();
 $paidmos += $mdays;  # 30
 
-assert( $u1, 'paid' );
+assert( $u1, 'paid', "free->paid 1 month" );
 
 # paid +1 month
 DW::Pay::add_paid_time( $u1, 'paid', 1 )
     or die DW::Pay::error_text();
 $paidmos += $mdays;  # 60
 
-assert( $u1, 'paid' );
+assert( $u1, 'paid', "paid +1 month" );
 
 # premium +1 month
 DW::Pay::add_paid_time( $u1, 'premium', 1 )
@@ -62,21 +70,21 @@ DW::Pay::add_paid_time( $u1, 'premium', 
 # should be 72 days... they bought 1 month of premium time (30 days)
 # and they had 60 days of paid.  60 days of paid converts to 42 days
 # of premium, 42+30 = 72 days premium.
-assert( $u1, 'premium' );
+assert( $u1, 'premium', "premium +1 month" );
 
 # premium +1 month
 DW::Pay::add_paid_time( $u1, 'premium', 1 )
     or die DW::Pay::error_text();
 $paidmos += $mdays;  # 102
 
-assert( $u1, 'premium' );
+assert( $u1, 'premium', "premium +1 month" );
 
 # paid +1 month == premium +21 days
 DW::Pay::add_paid_time( $u1, 'paid', 1 )
     or die DW::Pay::error_text();
 $paidmos += int( $mdays * 0.7 );  # 123
 
-assert( $u1, 'premium' );
+assert( $u1, 'premium', "paid +1 month == premium +21 days" );
 
 ################################################################################
 
@@ -85,10 +93,10 @@ DW::Pay::add_paid_time( $u1, 'seed', 99 
     or die DW::Pay::error_text();
 $paidmos = 0;  # never expires
 
-assert( $u1, 'seed' );
+assert( $u1, 'seed', "seed account" );
 
 ok( ! DW::Pay::add_paid_time( $u1, 'paid', 1 ), 'adding paid time fails' );
 
-assert( $u1, 'seed' );
+assert( $u1, 'seed', "seed account after trying to add paid time" );
 
 ################################################################################
diff -r 5fe1dc7c915a -r f7b821ec9d41 t/protocol.t
--- a/t/protocol.t	Tue Mar 01 15:22:55 2011 +0800
+++ b/t/protocol.t	Tue Mar 01 16:59:00 2011 +0800
@@ -49,6 +49,8 @@ my $do_request = sub {
 
 
 my $check_err = sub {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my ( $expectedcode, $testmsg ) = @_;
 
     # code is either in the form of ###, or ###:description
@@ -57,6 +59,8 @@ my $check_err = sub {
 };
 
 my $success = sub {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my ( $testmsg ) = @_;
 
     is( $err, 0, "$testmsg (success)" );
diff -r 5fe1dc7c915a -r f7b821ec9d41 t/synsuck.t
--- a/t/synsuck.t	Tue Mar 01 15:22:55 2011 +0800
+++ b/t/synsuck.t	Tue Mar 01 16:59:00 2011 +0800
@@ -1,6 +1,6 @@
 # -*-perl-*-
 use strict;
-use Test::More tests => 26;
+use Test::More tests => 24;
 
 use lib "$ENV{LJHOME}/cgi-bin";
 require 'ljlib.pl';
@@ -9,19 +9,33 @@ use LJ::SynSuck;
 
 
 sub err {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my ( $content, $type, $test ) = @_;
 
-    my ( $ok, $rv ) = LJ::SynSuck::parse_items_from_feed( $content );
-    ok( ! $ok, $test );
-    is( $rv->{type}, $type, $rv->{message} ? " $test - $rv->{message}" : $test );
+    subtest "$test (expect err)" => sub {
+        plan tests => 2;
+
+        my ( $ok, $rv ) = LJ::SynSuck::parse_items_from_feed( $content );
+        ok( ! $ok, "returned status is an error" );
+        is( $rv->{type}, $type, $rv->{message} ? "$rv->{message}" : "(no response message)" );
+    };
 }
 
 sub success {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my ( $content, $test, %opts ) = @_;
 
-    my ( $ok, $rv ) = LJ::SynSuck::parse_items_from_feed( $content, $opts{num_items} );
-    ok( $ok, $test );
-    die $rv->{message} unless $ok;
+    my ( $ok, $rv );
+
+    subtest "$test (expect ok)" => sub {
+        plan tests => 1;
+
+        ( $ok, $rv ) = LJ::SynSuck::parse_items_from_feed( $content, $opts{num_items} );
+        ok( $ok, "returned status is ok" );
+        die $rv->{message} unless $ok;
+    };
 
     return @{$rv->{items}};
 };
diff -r 5fe1dc7c915a -r f7b821ec9d41 t/user-infoshow-migrate.t
--- a/t/user-infoshow-migrate.t	Tue Mar 01 15:22:55 2011 +0800
+++ b/t/user-infoshow-migrate.t	Tue Mar 01 16:59:00 2011 +0800
@@ -6,24 +6,31 @@ require 'ljlib.pl';
 require 'ljlib.pl';
 
 
-plan tests => 228;
+plan tests => 156;
 
 use LJ::Test qw(temp_user memcache_stress);
 
 $LJ::DISABLED{infoshow_migrate} = 0;
 
 sub new_temp_user {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
     my $u = temp_user();
-    ok(LJ::isu($u), 'temp user created');
 
-    # force it to Y, since we're testing migration here
-    $u->update_self( { allow_infoshow => 'Y' } );
-    $u->clear_prop("opt_showlocation");
-    $u->clear_prop("opt_showbday");
+    subtest "created new temp user" => sub {
+        plan tests => 4;
 
-    is($u->{'allow_infoshow'}, 'Y', 'allow_infoshow set to Y');
-    ok(! defined $u->{'opt_showbday'}, 'opt_showbday not set');
-    ok(! defined $u->{'opt_showlocation'}, 'opt_showlocation not set');
+        ok(LJ::isu($u), 'temp user created');
+
+        # force it to Y, since we're testing migration here
+        $u->update_self( { allow_infoshow => 'Y' } );
+        $u->clear_prop("opt_showlocation");
+        $u->clear_prop("opt_showbday");
+
+        is($u->{'allow_infoshow'}, 'Y', 'allow_infoshow set to Y');
+        ok(! defined $u->{'opt_showbday'}, 'opt_showbday not set');
+        ok(! defined $u->{'opt_showlocation'}, 'opt_showlocation not set');
+    };
 
     return $u;
 }
--------------------------------------------------------------------------------

Flat | Top-Level Comments Only

These are failing for me now - did I miss something when updating?

t/atom-post.t ..................... String found where operator expected at t/atom-post.t line 69, near "subtest "check_entry $entry_info->{id} - $entry_info->{title}""
	(Do you need to predeclare subtest?)
syntax error at t/atom-post.t line 69, near "subtest "check_entry $entry_info->{id} - $entry_info->{title}""
Execution of t/atom-post.t aborted due to compilation errors.

Similarly for create-url.t, jabber-presence.t, paid-time.t, routing-errors.t, routing-formats.t, routing-indexes.t, routing-methods.t, routing-roles-regex.t, routing-roles-string.t, synsuck.t, & user-infoshow-migrate.t.

Edit: I think this may be due to an older version of Test::More being installed on the Dreamhacks.

$ perl -MTest::More -e 'print "$Test::More::VERSION\n"'
0.92

CPAN says the current version is 0.98.

Edited (checked CPAN) 2011-03-01 15:18 (UTC)

Hehehe I was just about to comment back asking for your version! My dev env has 0.96, and that works fine. Perhaps time to message

sophie?

Message sent!

Updated to 0.98! Give it another go now. :)

[edit: And thanks for the message!]

Edited 2011-03-01 17:22 (UTC)

Works now, thanks! :)

If that fixes it, shouldn't we also update checkconfig to make sure we have a good version?

Thank you, and yes please!

It's bug 3554.

[dw-free] Tests which use convenience methods report failures unhelpfully

no subject

no subject

no subject

no subject

no subject

no subject

no subject

no subject