File Coverage

blib/lib/Test/NameNote.pm

Criterion	Covered	Total	%
statement	27	29	93.1
branch	5	6	83.3
condition	4	9	44.4
subroutine	8	8	100.0
pod	1	1	100.0
total	45	53	84.9

package Test::NameNote;
use strict;
use warnings;
our $VERSION = '0.04';

=head1 NAME

Test::NameNote - add notes to test names

=head1 SYNOPSIS

Adds notes to test names in L-based test scripts.

  use Test::More tests => 10;
  use Test::NameNote;

  ok foo(), "foo true";
  foreach my $foo (0, 1) {
      my $n1 = Test::NameNote->new("foo=$foo");
      foreach my $bar (0, 1) {
          my $n2 = Test::NameNote->new("bar=$bar");
          is thing($foo, $bar), "thing", "thing returns thing";
          is thang($foo, $bar), "thang", "thang returns thang";
      }
  }
  ok bar(), "bar true";

  # prints:
  1..10
  ok 1 - foo true
  ok 2 - thing returns thing (foo=0,bar=0)
  ok 3 - thang returns thang (foo=0,bar=0)
  ok 4 - thing returns thing (foo=0,bar=1)
  ok 5 - thang returns thang (foo=0,bar=1)
  ok 6 - thing returns thing (foo=1,bar=0)
  ok 7 - thang returns thang (foo=1,bar=0)
  ok 8 - thing returns thing (foo=1,bar=1)
  ok 9 - thang returns thang (foo=1,bar=1)
  ok 10 - bar true

=cut

use Test::Builder;
use Sub::Prepend 'prepend';

our @_notes;
our $_wrapped_test_group_ok = 0;

_wrap('Test::Builder::ok');

sub _wrap {
    my $target = shift;

    prepend $target => sub {
        if (@_notes) {
            # Append any current notes to the test name in $_[2].
            my $note = join ',', map {$$_} @_notes;
            if (defined $_[2] and length $_[2]) {
                $note = "$_[2] ($note)";
            }
            @_ = (@_[0,1], $note, @_[3,-1]);
        }
    };
}

=head1 CONSTRUCTORS

=over

=item new ( NOTE )

Builds a new C object for the specifed NOTE text.  The note
will be added to the names of all L tests run while the
object is in scope.

=cut

sub new {
    my ($pkg, $note) = @_;

    if (!$_wrapped_test_group_ok and
                            exists &Test::Builder::_HijackedByTestGroup::ok) {
        _wrap('Test::Builder::_HijackedByTestGroup::ok');
        $_wrapped_test_group_ok = 1;
    }

    push @_notes, \$note;
    return bless { NoteRef => \$note }, ref($pkg)||$pkg;
}

=back

=cut

sub DESTROY {
    my $self = shift;

    @_notes = grep {$_ ne $self->{NoteRef}} @_notes;
}

=head1 AUTHOR

Nick Cleaton, C<<  >>

=head1 COPYRIGHT & LICENSE

Copyright 2009 Nick Cleaton, all rights reserved.

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;