diff options
Diffstat (limited to 'cpan/Test-Simple/lib/Test/Builder')
22 files changed, 4671 insertions, 83 deletions
diff --git a/cpan/Test-Simple/lib/Test/Builder/ExitMagic.pm b/cpan/Test-Simple/lib/Test/Builder/ExitMagic.pm new file mode 100644 index 0000000000..021cad9649 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/ExitMagic.pm @@ -0,0 +1,194 @@ +package Test::Builder::ExitMagic; +use strict; +use warnings; + +use Test::Builder::Util qw/new accessors/; +require Test::Builder::Result::Finish; + +accessors qw/stream tb ended pid/; + +sub init { + my $self = shift; + $self->pid($$); +} + +sub do_magic { + my $self = shift; + + return if $self->ended; $self->ended(1); + + # Don't bother with an ending if this is a forked copy. Only the parent + # should do the ending. + return unless $self->pid == $$; + + my $stream = $self->stream || (Test::Builder::Stream->root ? Test::Builder::Stream->shared : undef); + return unless $stream; # No stream? no point! + my $tb = $self->tb; + + return if $stream->no_ending; + + my $real_exit_code = $?; + + my $plan = $stream->plan; + my $total = $stream->tests_run; + my $fails = $stream->tests_failed; + + $stream->send( + Test::Builder::Result::Finish->new( + tests_run => $total, + tests_failed => $fails, + depth => $tb->depth, + source => $tb->name, + ) + ); + + # Ran tests but never declared a plan or hit done_testing + return $self->no_plan_magic($stream, $tb, $total, $fails, $real_exit_code) + if $total && !$plan; + + # Exit if plan() was never called. This is so "require Test::Simple" + # doesn't puke. + return unless $plan; + + # Don't do an ending if we bailed out. + if( $stream->bailed_out ) { + $stream->is_passing(0); + return; + } + + # Figure out if we passed or failed and print helpful messages. + return $self->be_helpful_magic($stream, $tb, $total, $fails, $plan, $real_exit_code) + if $total && $plan; + + if ($plan->directive && $plan->directive eq 'SKIP') { + $? = 0; + return; + } + + if($real_exit_code) { + $tb->diag("Looks like your test exited with $real_exit_code before it could output anything.\n"); + $stream->is_passing(0); + $? = $real_exit_code; + return; + } + + unless ($total) { + $tb->diag("No tests run!\n"); + $tb->is_passing(0); + $? = 255; + return; + } + + $tb->is_passing(0); + $tb->_whoa( 1, "We fell off the end of _ending()" ); + + 1; +} + +sub no_plan_magic { + my $self = shift; + my ($stream, $tb, $total, $fails, $real_exit_code) = @_; + + $stream->is_passing(0); + $tb->diag("Tests were run but no plan was declared and done_testing() was not seen."); + + if($real_exit_code) { + $tb->diag("Looks like your test exited with $real_exit_code just after $total.\n"); + $? = $real_exit_code; + return; + } + + # But if the tests ran, handle exit code. + if ($total && $fails) { + my $exit_code = $fails <= 254 ? $fails : 254; + $? = $exit_code; + return; + } + + $? = 254; + return; +} + +sub be_helpful_magic { + my $self = shift; + my ($stream, $tb, $total, $fails, $plan, $real_exit_code) = @_; + + my $planned = $plan->max; + my $num_extra = $plan->directive && $plan->directive eq 'NO_PLAN' ? 0 : $total - $planned; + + if ($num_extra != 0) { + my $s = $planned == 1 ? '' : 's'; + $tb->diag("Looks like you planned $planned test$s but ran $total.\n"); + $tb->is_passing(0); + } + + if($fails) { + my $s = $fails == 1 ? '' : 's'; + my $qualifier = $num_extra == 0 ? '' : ' run'; + $tb->diag("Looks like you failed $fails test$s of ${total}${qualifier}.\n"); + $tb->is_passing(0); + } + + if($real_exit_code) { + $tb->diag("Looks like your test exited with $real_exit_code just after $total.\n"); + $tb->is_passing(0); + $? = $real_exit_code; + return; + } + + my $exit_code; + if($fails) { + $exit_code = $fails <= 254 ? $fails : 254; + } + elsif($num_extra != 0) { + $exit_code = 255; + } + else { + $exit_code = 0; + } + + $? = $exit_code; + return; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::ExitMagic - Encapsulate the magic exit logic used by +Test::Builder. + +=head1 DESCRIPTION + +It's magic! well kinda.. + +=head1 SYNOPSYS + +Don't use this yourself, let L<Test::Builder> handle it. + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +Most of this code was pulled out ot L<Test::Builder>, written by Schwern and +others. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Fork.pm b/cpan/Test-Simple/lib/Test/Builder/Fork.pm new file mode 100644 index 0000000000..c99253a1f9 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Fork.pm @@ -0,0 +1,171 @@ +package Test::Builder::Fork; +use strict; +use warnings; + +use Carp qw/confess/; +use Scalar::Util qw/blessed/; +use File::Temp(); +use Test::Builder::Util qw/try/; + +sub tmpdir { shift->{tmpdir} } +sub pid { shift->{pid} } + +sub new { + my $class = shift; + + my $dir = File::Temp::tempdir(CLEANUP => 0) || die "Could not get a temp dir"; + + my $self = bless { tmpdir => $dir, pid => $$ }, $class; + + return $self; +} + +my $id = 1; +sub handle { + my $self = shift; + my ($item) = @_; + + return if $item && blessed($item) && $item->isa('Test::Builder::Result::Finish'); + + confess "Did not get a valid Test::Builder::Result object! ($item)" + unless $item && blessed($item) && $item->isa('Test::Builder::Result'); + + my $stream = Test::Builder::Stream->shared; + return 0 if $$ == $stream->pid; + + # First write the file, then rename it so that it is not read before it is ready. + my $name = $self->tmpdir . "/$$-" . $id++; + require Storable; + Storable::store($item, $name); + rename($name, "$name.ready") || die "Could not rename file"; + + return 1; +} + +sub cull { + my $self = shift; + my $dir = $self->tmpdir; + + opendir(my $dh, $dir) || die "could not open temp dir!"; + while(my $file = readdir($dh)) { + next if $file =~ m/^\.+$/; + next unless $file =~ m/\.ready$/; + + require Storable; + my $obj = Storable::retrieve("$dir/$file"); + die "Empty result object found" unless $obj; + + Test::Builder::Stream->shared->send($obj); + + if ($ENV{TEST_KEEP_TMP_DIR}) { + rename("$dir/$file", "$dir/$file.complete") || die "Could not rename file"; + } + else { + unlink("$dir/$file") || die "Could not unlink file: $file"; + } + } + closedir($dh); +} + +sub DESTROY { + my $self = shift; + + return unless $$ == $self->pid; + + my $dir = $self->tmpdir; + + if ($ENV{TEST_KEEP_TMP_DIR}) { + print STDERR "# Not removing temp dir: $dir\n"; + return; + } + + opendir(my $dh, $dir) || die "Could not open temp dir!"; + while(my $file = readdir($dh)) { + next if $file =~ m/^\.+$/; + die "Unculled result! You ran tests in a child process, but never pulled them in!\n" + if $file !~ m/\.complete$/; + unlink("$dir/$file") || die "Could not unlink file: $file"; + } + closedir($dh); + rmdir($dir); +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Fork - Fork support for Test::Builder + +=head1 DESCRIPTION + +This module is used by L<Test::Builder::Stream> to support forking. + +=head1 SYNOPSYS + + use Test::Builder::Fork; + + my $f = Test::Builder::Fork; + + if ($pid = fork) { + waitpid($pid, 0); + $f->cull; + } + else { + $f->handle(Test::Builder::Result::Ok->new(bool => 1); + } + + ... + +=head1 METHODS + +=over 4 + +=item $f = $class->new + +Create a new instance + +=item $f->pid + +Original PID in which the fork object was created. + +=item $f->tmpdir + +Temp dir used to share results between procs + +=item $f->handle($result) + +Send a result object to the parent + +=item $f->cull + +Retrieve result objects and send them to the stream + +=back + +=head1 SEE ALSO + +L<Child> - Makes forking easier. + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Formatter.pm b/cpan/Test-Simple/lib/Test/Builder/Formatter.pm new file mode 100644 index 0000000000..44e6be4cc4 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Formatter.pm @@ -0,0 +1,180 @@ +package Test::Builder::Formatter; +use strict; +use warnings; + +use Carp qw/confess/; +use Scalar::Util qw/blessed/; + +use Test::Builder::Util qw/new package_sub/; + +sub handle { + my $self = shift; + my ($item) = @_; + + confess "Handler did not get a valid Test::Builder::Result object! ($item)" + unless $item && blessed($item) && $item->isa('Test::Builder::Result'); + + my $method = $item->type; + + # Not all formatters will handle all types. + return 0 unless $self->can($method); + + $self->$method($item); + + return 1; +} + +sub to_handler { + my $self = shift; + return sub { $self->handle(@_) }; +} + +sub listen { + my $class = shift; + my %params = @_; + my $caller = caller; + + my $tb = $params{tb}; + $tb ||= package_sub($caller, 'TB_INSTANCE') ? $caller->TB_INSTANCE : undef; + + my $stream = delete $params{stream} || ($tb ? $tb->stream : undef) || Test::Builder::Stream->shared; + + my $id = delete $params{id}; + ($id) = ($class =~ m/^.*::([^:]+)$/g) unless $id; + + return $stream->listen($id => $class->new(%params)); +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Formatter - Base class for formatters + +=head1 DESCRIPTION + +Results go to L<Test::Builder::Stream> which then forwards them on to one or +more formatters. This module is a base class for formatters. You do not NEED to +use this module to write a formatter, but it can help. + +=head1 TEST COMPONENT MAP + + [Test Script] > [Test Tool] > [Test::Builder] > [Test::Bulder::Stream] > [Result Formatter] + ^ + You are here + +A test script uses a test tool such as L<Test::More>, which uses Test::Builder +to produce results. The results are sent to L<Test::Builder::Stream> which then +forwards them on to one or more formatters. The default formatter is +L<Test::Builder::Fromatter::TAP> which produces TAP output. + +=head1 SYNOPSYS + + package My::Formatter; + use base 'Test::Builder::Formatter'; + + sub ok { + my $self = shift; + my ($result) = @_; + + ... + } + + ... + + 1; + +=head2 TO USE IT + + use Test::More; + use My::Formatter; + + # Creates a new instance of your listener. Any params you pass in will be + # passed into the constructor. Exceptions: 'id', 'stream' and 'tb' which + # are used directly by 'listen' if present. + my $unlisten = My::Formatter->listen(...); + + # To stop listening: + $unlisten->(); + +=head1 METHODS + +=head2 PROVIDED + +=over 4 + +=item $L = $class->new(%params) + +Create a new instance. Arguments must be key => value pairs where the key is a +method name on the object. + +=item $unlisten = $class->listen(%params) + +=item $unlisten = $class->listen(id => 'foo', %params) + +=item $unlisten = $class->listen(stream => $STREAM, %params) + +=item $unlisten = $class->listen(tb => $BUILDER, %params) + +Construct an instance using %params, and add it as a listener on the stream. +'id', 'stream', and 'tb' are special arguments that can be used to specify the +id of the listener, the stream to which the instance will listen, or the +L<Test::Builder> instance from which to find the stream. + +=item $L->handle($result) + +Forward the resutl on to the correct method. + +=item $subref = $L->to_handler() + +Returns an anonymous sub that accepts results as arguments and passes them into +handle() on this instance. + +=back + +=head2 FOR YOU TO WRITE + +=over 4 + +=item $self->ok($result) + +=item $self->note($result) + +=item $self->diag($result) + +=item $self->plan($result) + +=item $self->finish($result) + +=item $self->bail($result) + +=item $self->child($result) + +Any results given to the handle() method will be passed into the associated +sub. If the sub is not defined then results of that type will be ignored. + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Formatter/LegacyResults.pm b/cpan/Test-Simple/lib/Test/Builder/Formatter/LegacyResults.pm new file mode 100644 index 0000000000..63960f7a27 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Formatter/LegacyResults.pm @@ -0,0 +1,166 @@ +package Test::Builder::Formatter::LegacyResults; +use strict; +use warnings; + +use base 'Test::Builder::Formatter'; + +use Test::Builder::Threads; + +sub init { + my $self = shift; + $self->reset; +} + +sub reset { + my $self = shift; + + $self->{Test_Results} = &share( [] ); + $self->{Curr_Test} = 0; + + &share(\$self->{Curr_Test}); + + return; +} + +sub summary { + my($self) = shift; + return map { $_->{'ok'} } @{ $self->{Test_Results} }; +} + +sub details { + my $self = shift; + return @{ $self->{Test_Results} }; +} + +sub current_test { + my ($self, $num) = @_; + + lock( $self->{Curr_Test} ); + if( defined $num ) { + my $delta = $num - $self->{Curr_Test}; + $self->{Curr_Test} = $num; + + # If the test counter is being pushed forward fill in the details. + my $test_results = $self->{Test_Results}; + if( $num > @$test_results ) { + my $start = @$test_results ? @$test_results : 0; + for( $start .. $num - 1 ) { + $test_results->[$_] = &share( + { + 'ok' => 1, + actual_ok => undef, + reason => 'incrementing test number', + type => 'unknown', + name => undef + } + ); + } + } + # If backward, wipe history. Its their funeral. + elsif( $num < @$test_results ) { + $#{$test_results} = $num - 1; + } + } + return $self->{Curr_Test}; +} + +sub sanity_check { + my $self = shift; + my ($tb) = @_; + + $tb->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); + + $tb->_whoa( + $self->{Curr_Test} != @{ $self->{Test_Results} }, + 'Somehow you got a different number of results than tests ran!' + ); + + return; +} + +sub ok { + my $self = shift; + my ($item) = @_; + + my $result = &share( {} ); + + lock $self->{Curr_Test}; + $self->{Curr_Test}++; + + $result->{ok} = $item->bool; + $result->{actual_ok} = $item->real_bool; + + my $name = $item->name; + if(defined $name) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $result->{name} = $name; + } + else { + $result->{name} = ''; + } + + if($item->skip && ($item->in_todo || $item->todo)) { + $result->{type} = 'todo_skip', + $result->{reason} = $item->skip || $item->todo; + } + elsif($item->in_todo || $item->todo) { + $result->{reason} = $item->todo; + $result->{type} = 'todo'; + } + elsif($item->skip) { + $result->{reason} = $item->skip; + $result->{type} = 'skip'; + } + else { + $result->{reason} = ''; + $result->{type} = ''; + } + + $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Formatter::LegacyResults - Encapsulate some legacy stuff. + +=head1 DESCRIPTION + +Older versions kept track of test results using an array of hashes. This is now +deprecated, but needs to still work for legacy code. + +=head1 TEST COMPONENT MAP + + [Test Script] > [Test Tool] > [Test::Builder] > [Test::Bulder::Stream] > [Result Formatter] + ^ + You are here + +A test script uses a test tool such as L<Test::More>, which uses Test::Builder +to produce results. The results are sent to L<Test::Builder::Stream> which then +forwards them on to one or more formatters. The default formatter is +L<Test::Builder::Fromatter::TAP> which produces TAP output. + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Formatter/TAP.pm b/cpan/Test-Simple/lib/Test/Builder/Formatter/TAP.pm new file mode 100644 index 0000000000..f1d2f57d72 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Formatter/TAP.pm @@ -0,0 +1,447 @@ +package Test::Builder::Formatter::TAP; +use strict; +use warnings; + +use Test::Builder::Threads; +use Test::Builder::Util qw/accessors try protect new accessor/; +use Carp qw/croak confess/; + +use base 'Test::Builder::Formatter'; + +accessors qw/No_Header No_Diag Depth Use_Numbers _the_plan/; + +accessor io_sets => sub { {} }; + +use constant OUT => 0; +use constant FAIL => 1; +use constant TODO => 2; + +####################### +# {{{ INITIALIZATION +####################### + +sub init { + my $self = shift; + + $self->no_header(0); + $self->use_numbers(1); + + $self->{number} = 0; + + $self->{lock} = 1; + share($self->{lock}); + + $self->init_legacy; + + return $self; +} + +####################### +# }}} INITIALIZATION +####################### + +####################### +# {{{ RESULT METHODS +####################### + +for my $handler (qw/bail nest/) { + my $sub = sub { + my $self = shift; + my ($item) = @_; + $self->_print_to_fh($self->result_handle($item, OUT), $item->indent || "", $item->to_tap); + }; + no strict 'refs'; + *$handler = $sub; +} + +sub child { + my $self = shift; + my ($item) = @_; + + return unless $item->action eq 'push' && $item->is_subtest; + + my $name = $item->name; + $self->_print_to_fh($self->result_handle($item, OUT), $item->indent || "", "# Subtest: $name\n"); +} + +sub finish { + my $self = shift; + my ($item) = @_; + + return if $self->no_header; + return unless $item->tests_run; + + my $plan = $self->_the_plan; + return unless $plan; + + if ($plan) { + return unless $plan->directive; + return unless $plan->directive eq 'NO_PLAN'; + } + + my $total = $item->tests_run; + $self->_print_to_fh($self->result_handle($item, OUT), $item->indent || '', "1..$total\n"); +} + +sub plan { + my $self = shift; + my ($item) = @_; + + $self->_the_plan($item); + + return if $self->no_header; + + return if $item->directive && $item->directive eq 'NO_PLAN'; + + my $out = $item->to_tap; + return unless $out; + + my $handle = $self->result_handle($item, OUT); + $self->_print_to_fh($handle, $item->indent || "", $out); +} + +sub ok { + my $self = shift; + my ($item) = @_; + + $self->atomic_result(sub { + my $num = $self->use_numbers ? ++($self->{number}) : undef; + $self->_print_to_fh($self->result_handle($item, OUT), $item->indent || "", $item->to_tap($num)); + }); +} + +sub diag { + my $self = shift; + my ($item) = @_; + + return if $self->no_diag; + + # Prevent printing headers when compiling (i.e. -c) + return if $^C; + + my $want_handle = $item->in_todo ? TODO : FAIL; + my $handle = $self->result_handle($item, $want_handle); + + $self->_print_to_fh( $handle, $item->indent || "", $item->to_tap ); +} + +sub note { + my $self = shift; + my ($item) = @_; + + return if $self->no_diag; + + # Prevent printing headers when compiling (i.e. -c) + return if $^C; + + $self->_print_to_fh( $self->result_handle($item, OUT), $item->indent || "", $item->to_tap ); +} + +####################### +# }}} RESULT METHODS +####################### + +############################## +# {{{ IO accessors +############################## + +sub io_set { + my $self = shift; + my ($name, @handles) = @_; + + if (@handles) { + my ($out, $fail, $todo) = @handles; + $out = $self->_new_fh($out); + + $fail = $fail ? $self->_new_fh($fail) : $out; + $todo = $todo ? $self->_new_fh($todo) : $out; + + $self->io_sets->{$name} = [$out, $fail, $todo]; + } + + return $self->io_sets->{$name}; +} + +sub encoding_set { + my $self = shift; + my ($encoding) = @_; + + $self->io_sets->{$encoding} ||= do { + my ($out, $fail) = $self->open_handles(); + my $todo = $out; + + binmode($out, ":encoding($encoding)"); + binmode($fail, ":encoding($encoding)"); + + [$out, $fail, $todo]; + }; + + return $self->io_sets->{$encoding}; +} + +sub result_handle { + my $self = shift; + my ($result, $index) = @_; + + my $rencoding = $result ? $result->encoding : undef; + + # Open handles in the encoding if one is set. + $self->encoding_set($rencoding) if $rencoding && $rencoding ne 'legacy'; + + for my $name ($rencoding, qw/utf8 legacy/) { + next unless $name; + my $handles = $self->io_set($name); + return $handles->[$index] if $handles; + } + + confess "This should not happen"; +} + +############################## +# }}} IO accessors +############################## + +######################## +# {{{ Legacy Support +######################## + +my $LEGACY; + +sub full_reset { $LEGACY = undef } + +sub init_legacy { + my $self = shift; + + unless ($LEGACY) { + my ($out, $err) = $self->open_handles(); + + _copy_io_layers(\*STDOUT, $out); + _copy_io_layers(\*STDERR, $err); + + _autoflush($out); + _autoflush($err); + + # LEGACY, BAH! + _autoflush(\*STDOUT); + _autoflush(\*STDERR); + + $LEGACY = [$out, $err, $out]; + } + + $self->reset_outputs; +} + +sub reset_outputs { + my $self = shift; + my ($out, $fail, $todo) = @$LEGACY; + $self->io_sets->{legacy} = [$out, $fail, $todo]; +} + +sub reset { + my $self = shift; + $self->reset_outputs; + $self->no_header(0); + $self->use_numbers(1); + lock $self->{lock}; + $self->{number} = 0; + share( $self->{number} ); + + 1; +} + +sub output { + my $self = shift; + my $handles = $self->io_set('legacy'); + ($handles->[OUT]) = $self->_new_fh($_[0]) if @_; + return $handles->[OUT]; +} + +sub failure_output { + my $self = shift; + my $handles = $self->io_set('legacy'); + ($handles->[FAIL]) = $self->_new_fh($_[0]) if @_; + return $handles->[FAIL]; +} + +sub todo_output { + my $self = shift; + my $handles = $self->io_set('legacy'); + ($handles->[TODO]) = $self->_new_fh($_[0]) if @_; + return $handles->[TODO]; +} + +sub _diag_fh { + my $self = shift; + my ($in_todo) = @_; + + return $in_todo ? $self->todo_output : $self->failure_output; +} + +sub _print { + my $self = shift; + my ($indent, @msgs) = @_; + return $self->_print_to_fh( $self->output, $indent, @msgs ); +} + +sub current_test { + my $self = shift; + + if (@_) { + my ($new) = @_; + $self->atomic_result(sub { $self->{number} = $new }); + } + + return $self->{number}; +} + +######################## +# }}} Legacy Support +######################## + +############### +# {{{ UTILS +############### + +sub _print_to_fh { + my( $self, $fh, $indent, @msgs ) = @_; + + # Prevent printing headers when only compiling. Mostly for when + # tests are deparsed with B::Deparse + return if $^C; + + my $msg = join '', @msgs; + + local( $\, $", $, ) = ( undef, ' ', '' ); + + $msg =~ s/^/$indent/mg; + + return print $fh $msg; +} + +sub open_handles { + my $self = shift; + + open( my $out, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; + open( my $err, ">&STDERR" ) or die "Can't dup STDERR: $!"; + + _autoflush($out); + _autoflush($err); + + return ($out, $err); +} + +sub atomic_result { + my $self = shift; + my ($code) = @_; + lock $self->{lock}; + $code->(); +} + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; + + return; +} + +sub _copy_io_layers { + my($src, $dst) = @_; + + try { + require PerlIO; + my @src_layers = PerlIO::get_layers($src); + _apply_layers($dst, @src_layers) if @src_layers; + }; + + return; +} + +sub _new_fh { + my $self = shift; + my($file_or_fh) = shift; + + return $file_or_fh if $self->is_fh($file_or_fh); + + my $fh; + if( ref $file_or_fh eq 'SCALAR' ) { + open $fh, ">>", $file_or_fh + or croak("Can't open scalar ref $file_or_fh: $!"); + } + else { + open $fh, ">", $file_or_fh + or croak("Can't open test output log $file_or_fh: $!"); + _autoflush($fh); + } + + return $fh; +} + +sub is_fh { + my $self = shift; + my $maybe_fh = shift; + return 0 unless defined $maybe_fh; + + return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref + return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob + + my $out; + protect { + $out = eval { $maybe_fh->isa("IO::Handle") } + || eval { tied($maybe_fh)->can('TIEHANDLE') }; + }; + + return $out; +} + + +############### +# }}} UTILS +############### + +1; + +__END__ + +=head1 NAME + +Test::Builder::Formatter::TAP - TAP formatter. + +=head1 TEST COMPONENT MAP + + [Test Script] > [Test Tool] > [Test::Builder] > [Test::Bulder::Stream] > [Result Formatter] + ^ + You are here + +A test script uses a test tool such as L<Test::More>, which uses Test::Builder +to produce results. The results are sent to L<Test::Builder::Stream> which then +forwards them on to one or more formatters. The default formatter is +L<Test::Builder::Fromatter::TAP> which produces TAP output. + +=head1 DESCRIPTION + +This module is responsible for taking results from the stream and outputting +TAP. You probably should not directly interact with this. + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm index a11033eaba..1a095ca8fc 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Module.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -7,13 +7,18 @@ use Test::Builder 0.99; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.001003'; +our $VERSION = '1.301001_034'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) =head1 NAME -Test::Builder::Module - Base class for test modules +Test::Builder::Module - *DEPRECATED* Base class for test modules + +=head1 DEPRECATED + +B<This module is deprecated> See L<Test::Builder::Provider> for what you should +use instead. =head1 SYNOPSIS @@ -29,59 +34,61 @@ Test::Builder::Module - Base class for test modules my $tb = $CLASS->builder; return $tb->ok(@_); } - + 1; =head1 DESCRIPTION -This is a superclass for Test::Builder-based modules. It provides a +This is a superclass for L<Test::Builder>-based modules. It provides a handful of common functionality and a method of getting at the underlying -Test::Builder object. +L<Test::Builder> object. =head2 Importing -Test::Builder::Module is a subclass of Exporter which means your +Test::Builder::Module is a subclass of L<Exporter> which means your module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... all act normally. -A few methods are provided to do the C<use Your::Module tests => 23> part +A few methods are provided to do the C<< use Your::Module tests => 23 >> part for you. =head3 import -Test::Builder::Module provides an import() method which acts in the -same basic way as Test::More's, setting the plan and controlling +Test::Builder::Module provides an C<import()> method which acts in the +same basic way as L<Test::More>'s, setting the plan and controlling exporting of functions and variables. This allows your module to set -the plan independent of Test::More. +the plan independent of L<Test::More>. -All arguments passed to import() are passed onto -C<< Your::Module->builder->plan() >> with the exception of +All arguments passed to C<import()> are passed onto +C<< Your::Module->builder->plan() >> with the exception of C<< import =>[qw(things to import)] >>. use Your::Module import => [qw(this that)], tests => 23; -says to import the functions this() and that() as well as set the plan +says to import the functions C<this()> and C<that()> as well as set the plan to be 23 tests. -import() also sets the exported_to() attribute of your builder to be -the caller of the import() function. +C<import()> also sets the C<exported_to()> attribute of your builder to be +the caller of the C<import()> function. -Additional behaviors can be added to your import() method by overriding -import_extra(). +Additional behaviors can be added to your C<import()> method by overriding +C<import_extra()>. =cut sub import { my($class) = shift; + my $test = $class->builder; + my $caller = caller; + + warn __PACKAGE__ . " is deprecated!\n" if $caller->can('TB_INSTANCE') && $caller->TB_INSTANCE->modern; + # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; - my $test = $class->builder; - - my $caller = caller; $test->exported_to($caller); @@ -123,13 +130,13 @@ sub _strip_imports { Your::Module->import_extra(\@import_args); -import_extra() is called by import(). It provides an opportunity for you +C<import_extra()> is called by C<import()>. It provides an opportunity for you to add behaviors to your module based on its import list. -Any extra arguments which shouldn't be passed on to plan() should be +Any extra arguments which shouldn't be passed on to C<plan()> should be stripped off by this method. -See Test::More for an example of its use. +See L<Test::More> for an example of its use. B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it feels like a bit of an ugly hack in its current form. @@ -147,15 +154,15 @@ Test::Builder object. my $builder = Your::Class->builder; -This method returns the Test::Builder object associated with Your::Class. +This method returns the L<Test::Builder> object associated with Your::Class. It is not a constructor so you can call it as often as you like. -This is the preferred way to get the Test::Builder object. You should +This is the preferred way to get the L<Test::Builder> object. You should I<not> get it via C<< Test::Builder->new >> as was previously recommended. -The object returned by builder() may change at runtime so you should -call builder() inside each function rather than store it in a global. +The object returned by C<builder()> may change at runtime so you should +call C<builder()> inside each function rather than store it in a global. sub ok { my $builder = Your::Class->builder; diff --git a/cpan/Test-Simple/lib/Test/Builder/Provider.pm b/cpan/Test-Simple/lib/Test/Builder/Provider.pm new file mode 100644 index 0000000000..fbee3b5722 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Provider.pm @@ -0,0 +1,463 @@ +package Test::Builder::Provider; +use strict; +use warnings; + +use Test::Builder 1.301001; +use Test::Builder::Util qw/package_sub is_tester is_provider find_builder/; +use Test::Builder::Trace; +use Carp qw/croak/; +use Scalar::Util qw/reftype set_prototype/; +use B(); + +my %SIG_MAP = ( + '$' => 'SCALAR', + '@' => 'ARRAY', + '%' => 'HASH', + '&' => 'CODE', +); + +my $ID = 1; + +sub import { + my $class = shift; + my $caller = caller; + + $class->export_into($caller, @_); +} + +sub export_into { + my $class = shift; + my ($dest, @sym_list) = @_; + + my %subs; + + my $meta = $class->make_provider($dest); + + $subs{TB} = \&find_builder; + $subs{builder} = \&find_builder; + $subs{anoint} = \&anoint; + $subs{import} = \&provider_import; + $subs{nest} = \&nest; + $subs{provide} = $class->_build_provide($dest, $meta); + $subs{export} = $class->_build_export($dest, $meta); + $subs{modernize} = \&modernize; + + $subs{gives} = sub { $subs{provide}->($_, undef, give => 1) for @_ }; + $subs{give} = sub { $subs{provide}->($_[0], $_[1], give => 1) }; + $subs{provides} = sub { $subs{provide}->($_) for @_ }; + + @sym_list = keys %subs unless @sym_list; + + my %seen; + for my $name (grep { !$seen{$_}++ } @sym_list) { + no strict 'refs'; + my $ref = $subs{$name} || package_sub($class, $name); + croak "$class does not export '$name'" unless $ref; + *{"$dest\::$name"} = $ref ; + } + + 1; +} + +sub nest(&) { + return Test::Builder::Trace->nest(@_); +} + +sub make_provider { + my $class = shift; + my ($dest) = @_; + + my $meta = is_provider($dest); + + unless ($meta) { + $meta = {refs => {}, attrs => {}, export => []}; + no strict 'refs'; + *{"$dest\::TB_PROVIDER_META"} = sub { $meta }; + } + + return $meta; +} + +sub _build_provide { + my $class = shift; + my ($dest, $meta) = @_; + + $meta->{provide} ||= sub { + my ($name, $ref, %params) = @_; + + croak "$dest already provides or gives '$name'" + if $meta->{attrs}->{$name}; + + croak "The second argument to provide() must be a ref, got: $ref" + if $ref && !ref $ref; + + $ref ||= package_sub($dest, $name); + croak "$dest has no sub named '$name', and no ref was given" + unless $ref; + + my $attrs = {%params, package => $dest, name => $name}; + $meta->{attrs}->{$name} = $attrs; + + push @{$meta->{export}} => $name; + + # If this is just giving, or not a coderef + return $meta->{refs}->{$name} = $ref if $params{give} || reftype $ref ne 'CODE'; + + my $o_name = B::svref_2object($ref)->GV->NAME; + if ($o_name && $o_name ne '__ANON__') { #sub has a name + $meta->{refs}->{$name} = $ref; + $attrs->{named} = 1; + } + else { + $attrs->{named} = 0; + # Voodoo.... + # Insert an anonymous sub, and use a trick to make caller() think its + # name is this string, which tells us how to find the thing that was + # actually called. + my $globname = __PACKAGE__ . '::__ANON' . ($ID++) . '__'; + + my $code = sub { + no warnings 'once'; + local *__ANON__ = $globname; # Name the sub so we can find it for real. + $ref->(@_); + }; + + # The prototype on set_prototype blocks this usage, even though it + # is valid. This is why we use the old-school &func() call. + # Oh the irony. + my $proto = prototype($ref); + &set_prototype($code, $proto) if $proto; + + $meta->{refs}->{$name} = $code; + + no strict 'refs'; + *$globname = $code; + *$globname = $attrs; + } + }; + + return $meta->{provide}; +} + +sub _build_export { + my $class = shift; + my ($dest, $meta) = @_; + + return sub { + my $class = shift; + my ($caller, @args) = @_; + + my (%no, @list); + for my $thing (@args) { + if ($thing =~ m/^!(.*)$/) { + $no{$1}++; + } + else { + push @list => $thing; + } + } + + unless(@list) { + my %seen; + @list = grep { !($no{$_} || $seen{$_}++) } @{$meta->{export}}; + } + + for my $name (@list) { + if ($name =~ m/^(\$|\@|\%)(.*)$/) { + my ($sig, $sym) = ($1, $2); + + croak "$class does not export '$name'" + unless ($meta->{refs}->{$sym} && reftype $meta->{refs}->{$sym} eq $SIG_MAP{$sig}); + + no strict 'refs'; + *{"$caller\::$sym"} = $meta->{refs}->{$name} || *{"$class\::$sym"}{$SIG_MAP{$sig}} + || croak "'$class' has no symbol named '$name'"; + } + else { + croak "$class does not export '$name'" + unless $meta->{refs}->{$name}; + + no strict 'refs'; + *{"$caller\::$name"} = $meta->{refs}->{$name} || package_sub($class, $name) + || croak "'$class' has no sub named '$name'"; + } + } + }; +} + +sub provider_import { + my $class = shift; + my $caller = caller; + + $class->anoint($caller); + $class->before_import(\@_, $caller) if $class->can('before_import'); + $class->export($caller, @_); + $class->after_import(@_) if $class->can('after_import'); + + 1; +} + +sub anoint { Test::Builder::Trace->anoint($_[1], $_[0]) }; + +sub modernize { + my $target = shift; + + if (package_sub($target, 'TB_INSTANCE')) { + my $tb = $target->TB_INSTANCE; + $tb->stream->use_fork; + $tb->modern(1); + } + else { + my $tb = Test::Builder->create( + modern => 1, + shared_stream => 1, + no_reset_plan => 1, + ); + $tb->stream->use_fork; + no strict 'refs'; + *{"$target\::TB_INSTANCE"} = sub {$tb}; + } +} + +1; + +=head1 NAME + +Test::Builder::Provider - Helper for writing testing tools + +=head1 TEST COMPONENT MAP + + [Test Script] > [Test Tool] > [Test::Builder] > [Test::Bulder::Stream] > [Result Formatter] + ^ + You are here + +A test script uses a test tool such as L<Test::More>, which uses Test::Builder +to produce results. The results are sent to L<Test::Builder::Stream> which then +forwards them on to one or more formatters. The default formatter is +L<Test::Builder::Fromatter::TAP> which produces TAP output. + +=head1 DESCRIPTION + +This package provides you with tools to write testing tools. It makes your job +of integrating with L<Test::Builder> and other testing tools much easier. + +=head1 SYNOPSYS + +Instead of use L<Exporter> or other exporters, you can use convenience +functions to define exports on the fly. + + package My::Tester + use strict; + use warnings; + + use Test::Builder::Provider; + + sub before_import { + my $class = shift; + my ($import_args_ref) = @_; + + ... Modify $import_args_ref ... + # $import_args_ref should contain only what you want to pass as + # arguments into export(). + } + + sub after_import { + my $class = shift; + my @args = @_; + + ... + } + + # Provide (export) an 'ok' function (the anonymous function is the export) + provide ok => sub { builder()->ok(@_) }; + + # Provide some of our package functions as test functions. + provides qw/is is_deeply/; + sub is { ... } + sub is_deeply { ... }; + + # Provide a 'subtests' function. Functions that accept a block like this + # that may run other tests should be use nest() to run the codeblocks they + # recieve to mark them as nested providers. + provide subtests => sub(&) { + my $code = shift; + nest { $code->() }; # OR: nest(\&$code) OR: &nest($code); + }; + + # Provide a couple nested functions defined in our package + provide qw/subtests_alt subtests_xxx/; + sub subtests_alt(&) { ... } + sub subtests_xxx(&) { ... } + + # Export a helper function that does not produce any results (regular + # export). + give echo => sub { print @_ }; + + # Same for multiple functions in our package: + gives qw/echo_stdout echo_stderr/; + sub echo_stdout { ... } + sub echo_stderr { ... } + +=head2 IN A TEST FILE + + use Test::More; + use My::Tester; + + ok(1, "blah"); + + is(1, 1, "got 1"); + + subtests { + ok(1, "a subtest"); + ok(1, "another"); + }; + +=head2 USING EXTERNAL EXPORT LIBRARIES + +Maybe you like L<Exporter> or another export tool. In that case you still need +the 'provides' and 'nest' functions from here to mark testing tools as such. + +This is also a quick way to update an old library, but you also need to remove +any references to C<$Test::Builder::Level> which is now deprecated. + + package My::Tester + use strict; + use warnings; + + use base 'Exporter'; + use Test::Builder::Provider qw/provides nest/; + + our @EXPORT = qw{ + ok is is_deeply + subtests subtests_alt subtests_xxx + echo echo_stderr echo stdout + }; + + # *mark* the testing tools + provides qw/ok is is_deeply/; + sub ok { builder()->ok(@_) } + sub is { ... } + sub is_deeply { ... }; + + # Remember to use nest() + provide qw/subtests subtests_alt subtests_xxx/; + sub subtests(&) { ... } + sub subtests_alt(&) { ... } + sub subtests_xxx(&) { ... } + + # No special marking needed for these as they do not produce results. + sub echo { print @_ } + sub echo_stdout { ... } + sub echo_stderr { ... } + +=head2 SUPPORTING OLD VERSIONS + +See L<Test::Builder::Compat> which is a seperate dist that has no dependancies. +You can use it to write providers that make use of the new Test::Builder, while +also working fine on older versions of Test::Builder. + +=head1 META-DATA + +Importing this module will always mark your package as a test provider. It does +this by injecting a method into your package called 'TB_PROVIDER_META'. This +method simply returns the meta-data hash for your package. + +To avoid this you can use 'require' instead of 'use', or you can use () in your import: + + # Load the module, but do not make this package a provider. + require Test::Builder::Provider; + use Test::Builder::Provider(); + +=head1 EXPORTS + +All of these subs are injected into your package (unless you request a subset). + +=over 4 + +=item my $tb = TB() + +=item my $tb = builder() + +Get the correct instance of L<Test::Builder>. Usually this is the instance used +in the test file calling a tool in your package. If no such instance can be +found the default Test::Builder instance will be used. + +=item $class->anoint($target) + +Used to mark the $target package as a test package that consumes your test +package for tools. This is done automatically for you if you use the default +'import' sub below. + +=item $class->import() + +=item $class->import(@list) + +An import() function that exports your tools to any consumers of your class. + +=item $class->export($dest) + +=item $class->export($dest, @list) + +Export the packages tools into the $dest package. @list me be specified to +restrict what is exported. Prefix any item in the list with '!' to prevent +exporting it. + +=item provide $name + +=item provide $name => sub { ... } + +Provide a testing tool that will produce results. If no coderef is given it +will look for a coderef with $name in your package. + +You may also use this to export refs of any type. + +=item provides qw/sub1 sub2 .../ + +Like provide except you can specify multiple subs to export. + +=item nest { ... } + +=item nest(\&$code) + +=item &nest($code) + +Used as a tracing barrier, any results generated inside the nest will trace to +the nest as opposed to the call to your provided tool. + +=item give $name + +=item give $name => sub { ... } + +Export a helper function that does not produce results. + +=item gives qw/sub1 sub2 .../ + +Export helper functions. + +=back + +=head1 HOW DO I TEST MY TEST TOOLS? + +See L<Test::Tester2> + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Result.pm b/cpan/Test-Simple/lib/Test/Builder/Result.pm new file mode 100644 index 0000000000..308a82f901 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Result.pm @@ -0,0 +1,134 @@ +package Test::Builder::Result; +use strict; +use warnings; + +use Carp qw/confess/; +use Scalar::Util qw/blessed/; + +use Test::Builder::Util qw/accessors new/; + +accessors(qw/trace pid depth in_todo source constructed/); + +sub init { + my $self = shift; + my %params = @_; + + $self->constructed([caller(1)]); + $self->pid($$) unless $params{pid}; +} + +sub type { + my $self = shift; + my $class = blessed($self); + if ($class && $class =~ m/^.*::([^:]+)$/) { + return lc($1); + } + + confess "Could not determine result type for $self"; +} + +sub indent { + my $self = shift; + return '' unless $self->depth; + return ' ' x $self->depth; +} + +sub encoding { + my $self = shift; + return unless $self->trace; + return $self->trace->encoding; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Result - Base class for results + +=head1 DESCRIPTION + +Base class for all result objects that get passed through +L<Test::Builder::Stream>. + +=head1 METHODS + +=head2 CONSTRUCTORS + +=over 4 + +=item $r = $class->new(...) + +Create a new instance + +=back + +=head2 SIMPLE READ/WRITE ACCESSORS + +=over 4 + +=item $r->trace + +Get the test trace info, including where to report errors. + +=item $r->pid + +PID in which the result was created. + +=item $r->depth + +Builder depth of the result (0 for normal, 1 for subtest, 2 for nested, etc). + +=item $r->in_todo + +True if the result was generated inside a todo. + +=item $r->source + +Builder that created the result, usually $0, but the name of a subtest when +inside a subtest. + +=item $r->constructed + +Package, File, and Line in which the result was built. + +=back + +=head2 INFORMATION + +=over 4 + +=item $r->type + +Type of result. Usually this is the lowercased name from the end of the +package. L<Test::Builder::Result::Ok> = 'ok'. + +=item $r->indent + +Returns the indentation that should be used to display the result (' ' x +depth). + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Result/Bail.pm b/cpan/Test-Simple/lib/Test/Builder/Result/Bail.pm new file mode 100644 index 0000000000..ff34db7fdd --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Result/Bail.pm @@ -0,0 +1,116 @@ +package Test::Builder::Result::Bail; +use strict; +use warnings; + +use base 'Test::Builder::Result'; + +use Test::Builder::Util qw/accessors/; +accessors qw/reason/; + +sub to_tap { + my $self = shift; + return "Bail out! " . $self->reason . "\n"; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Result::Bail - Bailout! + +=head1 DESCRIPTION + +Sent when the test needs to bail out. + +=head1 METHODS + +See L<Test::Builder::Result> which is the base class for this module. + +=head2 CONSTRUCTORS + +=over 4 + +=item $r = $class->new(...) + +Create a new instance + +=back + +=head2 SIMPLE READ/WRITE ACCESSORS + +=over 4 + +=item $r->reason + +Reason for the bailout. + +=item $r->trace + +Get the test trace info, including where to report errors. + +=item $r->pid + +PID in which the result was created. + +=item $r->depth + +Builder depth of the result (0 for normal, 1 for subtest, 2 for nested, etc). + +=item $r->in_todo + +True if the result was generated inside a todo. + +=item $r->source + +Builder that created the result, usually $0, but the name of a subtest when +inside a subtest. + +=item $r->constructed + +Package, File, and Line in which the result was built. + +=back + +=head2 INFORMATION + +=over 4 + +=item $r->to_tap + +Returns the TAP string for the plan (not indented). + +=item $r->type + +Type of result. Usually this is the lowercased name from the end of the +package. L<Test::Builder::Result::Ok> = 'ok'. + +=item $r->indent + +Returns the indentation that should be used to display the result (' ' x +depth). + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Result/Child.pm b/cpan/Test-Simple/lib/Test/Builder/Result/Child.pm new file mode 100644 index 0000000000..c5fd881aec --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Result/Child.pm @@ -0,0 +1,146 @@ +package Test::Builder::Result::Child; +use strict; +use warnings; + +use base 'Test::Builder::Result'; + +use Carp qw/confess/; + +use Test::Builder::Util qw/accessors/; +accessors qw/name is_subtest/; + +sub action { + my $self = shift; + if (@_) { + my ($action) = @_; + confess "action must be one of 'push' or 'pop'" + unless $action =~ m/^(push|pop)$/; + + $self->{action} = $action; + } + + confess "action was never set!" + unless $self->{action}; + + return $self->{action}; +} + +sub to_tap { } + +1; + +__END__ + +=head1 NAME + +Test::Builder::Result::Child - Child result type + +=head1 DESCRIPTION + +Sent when a child Builder is spawned, such as a subtest. + +=head1 METHODS + +See L<Test::Builder::Result> which is the base class for this module. + +=head2 CONSTRUCTORS + +=over 4 + +=item $r = $class->new(...) + +Create a new instance + +=back + +=head2 ATTRIBUTES + +=over 4 + +=item $r->action + +Either 'push' or 'pop'. When a child is created a push is sent, when a child +exits a pop is sent. + +=back + +=head2 SIMPLE READ/WRITE ACCESSORS + +=over 4 + +=item $r->name + +Name of the child + +=item $r->is_subtest + +True if the child was spawned for a subtest. + +=item $r->trace + +Get the test trace info, including where to report errors. + +=item $r->pid + +PID in which the result was created. + +=item $r->depth + +Builder depth of the result (0 for normal, 1 for subtest, 2 for nested, etc). + +=item $r->in_todo + +True if the result was generated inside a todo. + +=item $r->source + +Builder that created the result, usually $0, but the name of a subtest when +inside a subtest. + +=item $r->constructed + +Package, File, and Line in which the result was built. + +=back + +=head2 INFORMATION + +=over 4 + +=item $r->to_tap + +no-op, return nothing. + +=item $r->type + +Type of result. Usually this is the lowercased name from the end of the +package. L<Test::Builder::Result::Ok> = 'ok'. + +=item $r->indent + +Returns the indentation that should be used to display the result (' ' x +depth). + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Result/Diag.pm b/cpan/Test-Simple/lib/Test/Builder/Result/Diag.pm new file mode 100644 index 0000000000..f865332dc2 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Result/Diag.pm @@ -0,0 +1,156 @@ +package Test::Builder::Result::Diag; +use strict; +use warnings; + +use base 'Test::Builder::Result'; + +use Scalar::Util(); +use Test::Builder::Util qw/accessors try/; +use Encode(); +accessors qw/message/; + +my $NORMALIZE = try { require Unicode::Normalize; 1 }; + +sub to_tap { + my $self = shift; + + chomp(my $msg = $self->message); + + if ($self->trace && $self->trace->report) { + my $encoding = $self->trace->encoding; + if ($encoding && $encoding ne 'legacy') { + my $file = $self->trace->report->file; + my $decoded; + try { $decoded = Encode::decode($encoding, "$file", Encode::FB_CROAK) }; + if ($decoded) { + $decoded = Unicode::Normalize::NFKC($decoded) if $NORMALIZE; + $msg =~ s/$file/$decoded/g; + } + } + } + + $msg = "# $msg" unless $msg =~ m/^\n/; + $msg =~ s/\n/\n# /g; + return "$msg\n"; +} + +sub linked { + my $self = shift; + + if (@_) { + ($self->{linked}) = @_; + Scalar::Util::weaken($self->{linked}) if defined $self->{linked}; + } + + return $self->{linked}; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Result::Diag - Diag result type + +=head1 DESCRIPTION + +The diag result type. + +=head1 METHODS + +See L<Test::Builder::Result> which is the base class for this module. + +=head2 CONSTRUCTORS + +=over 4 + +=item $r = $class->new(...) + +Create a new instance + +=back + +=head2 SIMPLE READ/WRITE ACCESSORS + +=over 4 + +=item $r->message + +The message in the note. + +=item $r->trace + +Get the test trace info, including where to report errors. + +=item $r->pid + +PID in which the result was created. + +=item $r->depth + +Builder depth of the result (0 for normal, 1 for subtest, 2 for nested, etc). + +=item $r->in_todo + +True if the result was generated inside a todo. + +=item $r->source + +Builder that created the result, usually $0, but the name of a subtest when +inside a subtest. + +=item $r->constructed + +Package, File, and Line in which the result was built. + +=item $r->linked + +If this diag is linked to a specific L<Test::Builder::Result::Ok> object, this +will be set to the object. Note this is automatically turned into a weak +reference as it is assumed that the Ok will also link to this object. This is +to avoid cycled and memory leaks. + +=back + +=head2 INFORMATION + +=over 4 + +=item $r->to_tap + +Returns the TAP string for the plan (not indented). + +=item $r->type + +Type of result. Usually this is the lowercased name from the end of the +package. L<Test::Builder::Result::Ok> = 'ok'. + +=item $r->indent + +Returns the indentation that should be used to display the result (' ' x +depth). + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Result/Finish.pm b/cpan/Test-Simple/lib/Test/Builder/Result/Finish.pm new file mode 100644 index 0000000000..9dd7532931 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Result/Finish.pm @@ -0,0 +1,111 @@ +package Test::Builder::Result::Finish; +use strict; +use warnings; + +use base 'Test::Builder::Result'; + +use Test::Builder::Util qw/accessors/; +accessors qw/tests_run tests_failed/; + +1; + +__END__ + +=head1 NAME + +Test::Builder::Result::Finish - The finish result type + +=head1 DESCRIPTION + +Sent after testing is finished. + +=head1 METHODS + +See L<Test::Builder::Result> which is the base class for this module. + +=head2 CONSTRUCTORS + +=over 4 + +=item $r = $class->new(...) + +Create a new instance + +=back + +=head2 SIMPLE READ/WRITE ACCESSORS + +=over 4 + +=item $r->tests_run + +How many tests were run. + +=item $r->tests_failed + +How many tests failed. + +=item $r->trace + +Get the test trace info, including where to report errors. + +=item $r->pid + +PID in which the result was created. + +=item $r->depth + +Builder depth of the result (0 for normal, 1 for subtest, 2 for nested, etc). + +=item $r->in_todo + +True if the result was generated inside a todo. + +=item $r->source + +Builder that created the result, usually $0, but the name of a subtest when +inside a subtest. + +=item $r->constructed + +Package, File, and Line in which the result was built. + +=back + +=head2 INFORMATION + +=over 4 + +=item $r->type + +Type of result. Usually this is the lowercased name from the end of the +package. L<Test::Builder::Result::Ok> = 'ok'. + +=item $r->indent + +Returns the indentation that should be used to display the result (' ' x +depth). + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Result/Note.pm b/cpan/Test-Simple/lib/Test/Builder/Result/Note.pm new file mode 100644 index 0000000000..ff6dd8e1a1 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Result/Note.pm @@ -0,0 +1,120 @@ +package Test::Builder::Result::Note; +use strict; +use warnings; + +use base 'Test::Builder::Result'; + +use Test::Builder::Util qw/accessors/; +accessors qw/message/; + +sub to_tap { + my $self = shift; + + chomp(my $msg = $self->message); + $msg = "# $msg" unless $msg =~ m/^\n/; + $msg =~ s/\n/\n# /g; + return "$msg\n"; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Result::Note - Note result type + +=head1 DESCRIPTION + +Notes in tests + +=head1 METHODS + +See L<Test::Builder::Result> which is the base class for this module. + +=head2 CONSTRUCTORS + +=over 4 + +=item $r = $class->new(...) + +Create a new instance + +=back + +=head2 SIMPLE READ/WRITE ACCESSORS + +=over 4 + +=item $r->message + +The message in the note. + +=item $r->trace + +Get the test trace info, including where to report errors. + +=item $r->pid + +PID in which the result was created. + +=item $r->depth + +Builder depth of the result (0 for normal, 1 for subtest, 2 for nested, etc). + +=item $r->in_todo + +True if the result was generated inside a todo. + +=item $r->source + +Builder that created the result, usually $0, but the name of a subtest when +inside a subtest. + +=item $r->constructed + +Package, File, and Line in which the result was built. + +=back + +=head2 INFORMATION + +=over 4 + +=item $r->to_tap + +Returns the TAP string for the plan (not indented). + +=item $r->type + +Type of result. Usually this is the lowercased name from the end of the +package. L<Test::Builder::Result::Ok> = 'ok'. + +=item $r->indent + +Returns the indentation that should be used to display the result (' ' x +depth). + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Result/Ok.pm b/cpan/Test-Simple/lib/Test/Builder/Result/Ok.pm new file mode 100644 index 0000000000..ac22149aec --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Result/Ok.pm @@ -0,0 +1,268 @@ +package Test::Builder::Result::Ok; +use strict; +use warnings; + +use base 'Test::Builder::Result'; + +use Carp qw/confess/; +use Scalar::Util qw/blessed reftype/; +use Test::Builder::Util qw/accessors/; + +accessors qw/bool real_bool name todo skip/; + +sub init_order { + my $self = shift; + my @attrs = @_; + + my @out; + my $diag; + for my $i (@attrs) { + if ($i eq 'diag') { + $diag++; + next; + } + + push @out => $i; + } + + push @out => 'diag' if $diag; + + return @out; +} + +sub pre_init { + my $self = shift; + my ($params) = @_; + + return if $params->{real_bool} || ($params->{skip} && $params->{todo}); + + my $msg = $params->{in_todo} ? "Failed (TODO)" : "Failed"; + my $prefix = $ENV{HARNESS_ACTIVE} ? "\n" : ""; + + my ($pkg, $file, $line) = $params->{trace}->report->call; + + if (defined $params->{name}) { + my $name = $params->{name}; + $msg = qq[$prefix $msg test '$name'\n at $file line $line.\n]; + } + else { + $msg = qq[$prefix $msg test at $file line $line.\n]; + } + + $params->{diag} ||= []; + unshift @{$params->{diag}} => $msg; +} + +sub to_tap { + my $self = shift; + my ($num) = @_; + + my $out = ""; + $out .= "not " unless $self->real_bool; + $out .= "ok"; + $out .= " $num" if defined $num; + + if (defined $self->name) { + my $name = $self->name; + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $out .= " - " . $name; + } + + if (defined $self->skip && defined $self->todo) { + my $why = $self->skip; + + unless ($why eq $self->todo) { + require Data::Dumper; + confess "2 different reasons to skip/todo: " . Data::Dumper::Dumper($self); + } + + $out .= " # TODO & SKIP $why"; + } + elsif (defined $self->skip) { + $out .= " # skip"; + $out .= " " . $self->skip if length $self->skip; + } + elsif($self->in_todo) { + $out .= " # TODO " . $self->todo if $self->in_todo; + } + + $out =~ s/\n/\n# /g; + + $out .= "\n"; + + return $out; +} + +sub clear_diag { + my $self = shift; + my @out = @{delete $self->{diag} || []}; + $_->linked(undef) for @out; + return @out; +} + +sub diag { + my $self = shift; + + for my $i (@_) { + next unless $i; + my $type = reftype $i || ""; + + my $array = $type eq 'ARRAY' ? $i : [$i]; + for my $d (@$array) { + if (ref $d) { + confess "Only Diag objects can be linked to results." + unless blessed($d) && $d->isa('Test::Builder::Result::Diag'); + + confess "Diag argument '$d' is already linked to a result." + if $d->linked; + } + else { + $d = Test::Builder::Result::Diag->new( message => $d ); + } + + for (qw/trace pid depth in_todo source/) { + $d->$_($self->$_) unless $d->$_; + } + + $d->linked($self); + push @{$self->{diag}} => $d; + } + } + + return $self->{diag}; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Result::Ok - Ok result type + +=head1 DESCRIPTION + +The ok result type. + +=head1 METHODS + +See L<Test::Builder::Result> which is the base class for this module. + +=head2 CONSTRUCTORS + +=over 4 + +=item $r = $class->new(...) + +Create a new instance + +=back + +=head2 SIMPLE READ/WRITE ACCESSORS + +=over 4 + +=item $r->bool + +True if the test passed, or if we are in a todo/skip + +=item $r->real_bool + +True if the test passed, false otherwise, even in todo. + +=item $r->name + +Name of the test. + +=item $r->todo + +Reason for todo (may be empty, even in a todo, check in_todo(). + +=item $r->skip + +Reason for skip + +=item $r->trace + +Get the test trace info, including where to report errors. + +=item $r->pid + +PID in which the result was created. + +=item $r->depth + +Builder depth of the result (0 for normal, 1 for subtest, 2 for nested, etc). + +=item $r->in_todo + +True if the result was generated inside a todo. + +=item $r->source + +Builder that created the result, usually $0, but the name of a subtest when +inside a subtest. + +=item $r->constructed + +Package, File, and Line in which the result was built. + +=item $r->diag + +Either undef, or an arrayref of L<Test::Builder::Result::Diag> objects. These +objects will be linked to this Ok result. Calling C<< $diag->linked >> on them +will return this Ok object. References here are strong references, references +to this object from the linked Diag objects are weakened to avoid cycles. + +You can push diag objects into the arrayref by using them as arguments to this +method. Objects will be validated to ensure that they are Diag objects, and not +already linked to a result. As well C<linked> will be set on them. + +=item $r->clear_diag + +Remove all linked Diag objects, also removes the link within the Diags. Returns +a list of the objects. + +=back + +=head2 INFORMATION + +=over 4 + +=item $r->to_tap + +Returns the TAP string for the plan (not indented). + +=item $r->type + +Type of result. Usually this is the lowercased name from the end of the +package. L<Test::Builder::Result::Ok> = 'ok'. + +=item $r->indent + +Returns the indentation that should be used to display the result (' ' x +depth). + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Result/Plan.pm b/cpan/Test-Simple/lib/Test/Builder/Result/Plan.pm new file mode 100644 index 0000000000..63f0acd1af --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Result/Plan.pm @@ -0,0 +1,135 @@ +package Test::Builder::Result::Plan; +use strict; +use warnings; + +use base 'Test::Builder::Result'; + +use Test::Builder::Util qw/accessors/; +accessors qw/max directive reason/; + +sub to_tap { + my $self = shift; + + my $max = $self->max; + my $directive = $self->directive; + my $reason = $self->reason; + + return if $directive && $directive eq 'NO_PLAN'; + + my $plan = "1..$max"; + $plan .= " # $directive" if defined $directive; + $plan .= " $reason" if defined $reason; + + return "$plan\n"; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Result::Plan - The result of a plan + +=head1 DESCRIPTION + +The plan result object. + +=head1 METHODS + +See L<Test::Builder::Result> which is the base class for this module. + +=head2 CONSTRUCTORS + +=over 4 + +=item $r = $class->new(...) + +Create a new instance + +=back + +=head2 SIMPLE READ/WRITE ACCESSORS + +=over 4 + +=item $r->max + +When the plan is specified as a number of tests, this is set to that number. + +=item $r->directive + +This will be set to 'skip_all' or 'no_plan' in some cases. + +=item $r->reason + +If there is a directive, this gives details. + +=item $r->trace + +Get the test trace info, including where to report errors. + +=item $r->pid + +PID in which the result was created. + +=item $r->depth + +Builder depth of the result (0 for normal, 1 for subtest, 2 for nested, etc). + +=item $r->in_todo + +True if the result was generated inside a todo. + +=item $r->source + +Builder that created the result, usually $0, but the name of a subtest when +inside a subtest. + +=item $r->constructed + +Package, File, and Line in which the result was built. + +=back + +=head2 INFORMATION + +=over 4 + +=item $r->to_tap + +Returns the TAP string for the plan (not indented). + +=item $r->type + +Type of result. Usually this is the lowercased name from the end of the +package. L<Test::Builder::Result::Ok> = 'ok'. + +=item $r->indent + +Returns the indentation that should be used to display the result (' ' x +depth). + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Stream.pm b/cpan/Test-Simple/lib/Test/Builder/Stream.pm new file mode 100644 index 0000000000..d7e07204ca --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Stream.pm @@ -0,0 +1,684 @@ +package Test::Builder::Stream; +use strict; +use warnings; + +use Carp qw/confess croak/; +use Scalar::Util qw/reftype blessed/; +use Test::Builder::Threads; +use Test::Builder::Util qw/accessors accessor atomic_deltas try protect/; + +accessors qw/plan bailed_out/; +atomic_deltas qw/tests_run tests_failed/; + +accessor no_ending => sub { 0 }; +accessor is_passing => sub { 1 }; +accessor _listeners => sub {{ }}; +accessor _mungers => sub {{ }}; +accessor _munge_order => sub {[ ]}; +accessor _follow_up => sub {{ }}; + +sub pid { shift->{pid} } + +{ + my ($root, @shared); + + sub root { $root }; + + sub shared { + $root ||= __PACKAGE__->new; + push @shared => $root unless @shared; + return $shared[-1]; + }; + + sub clear { $root = undef; @shared = () } + + sub intercept { + my $class = shift; + my ($code) = @_; + + confess "argument to intercept must be a coderef, got: $code" + unless reftype $code eq 'CODE'; + + my $orig = $class->intercept_start(); + my ($ok, $error) = try { $code->($shared[-1]) }; + + $class->intercept_stop($orig); + die $error unless $ok; + return $ok; + } + + sub intercept_start { + my $class = shift; + my $new = $_[0] || $class->new(no_follow => 1) || die "Internal error!"; + push @shared => $new; + return $new; + } + + sub intercept_stop { + my $class = shift; + my ($orig) = @_; + confess "intercept nesting inconsistancy!" + unless $shared[-1] == $orig; + return pop @shared; + } +} + +sub new { + my $class = shift; + my %params = @_; + my $self = bless { pid => $$ }, $class; + + share($self->{tests_run}); + share($self->{tests_failed}); + + $self->use_tap if $params{use_tap}; + $self->use_lresults if $params{use_lresults}; + $self->legacy_followup unless $params{no_follow}; + + return $self; +} + +sub follow_up { + my $self = shift; + my ($type, @action) = @_; + croak "'$type' is not a result type" + unless $type && $type->isa('Test::Builder::Result'); + + if (@action) { + my ($sub) = @action; + croak "The second argument to follow_up() must be a coderef, got: $sub" + if $sub && !(ref $sub && reftype $sub eq 'CODE'); + + $self->_follow_up->{$type} = $sub; + } + + return $self->_follow_up->{$type}; +} + +sub legacy_followup { + my $self = shift; + $self->_follow_up({ + 'Test::Builder::Result::Bail' => sub { exit 255 }, + 'Test::Builder::Result::Plan' => sub { + my ($plan) = @_; + return unless $plan->directive; + return unless $plan->directive eq 'SKIP'; + exit 0; + }, + }); +} + +sub exception_followup { + my $self = shift; + + $self->_follow_up({ + 'Test::Builder::Result::Bail' => sub {die $_[0]}, + 'Test::Builder::Result::Plan' => sub { + my $plan = shift; + return unless $plan->directive; + return unless $plan->directive eq 'SKIP'; + die $plan; + }, + }); +} + +sub expected_tests { + my $self = shift; + my $plan = $self->plan; + return undef unless $plan; + return $plan->max; +} + +sub listener { + my $self = shift; + my ($id) = @_; + confess("You must provide an ID for your listener") unless $id; + + confess("Listener ID's may not start with 'LEGACY_', those are reserved") + if $id =~ m/^LEGACY_/ && caller ne __PACKAGE__; + + return $self->_listeners->{$id}; +} + +sub listen { + my $self = shift; + my ($id, $listener) = @_; + + confess("You must provide an ID for your listener") unless $id; + + confess("Listener ID's may not start with 'LEGACY_', those are reserved") + if $id =~ m/^LEGACY_/ && caller ne __PACKAGE__; + + confess("Listeners must be code refs, or objects that implement handle(), got: $listener") + unless $listener && ( + (reftype $listener && reftype $listener eq 'CODE') + || + (blessed $listener && $listener->can('handle')) + ); + + my $listeners = $self->_listeners; + + confess("There is already a listener with ID: $id") + if $listeners->{$id}; + + $listeners->{$id} = $listener; + return sub { $self->unlisten($id) }; +} + +sub unlisten { + my $self = shift; + my ($id) = @_; + + confess("You must provide an ID for your listener") unless $id; + + confess("Listener ID's may not start with 'LEGACY_', those are reserved") + if $id =~ m/^LEGACY_/ && caller ne __PACKAGE__; + + my $listeners = $self->_listeners; + + confess("There is no listener with ID: $id") + unless $listeners->{$id}; + + delete $listeners->{$id}; +} + +sub munger { + my $self = shift; + my ($id) = @_; + confess("You must provide an ID for your munger") unless $id; + return $self->_mungers->{$id}; +} + +sub munge { + my $self = shift; + my ($id, $munger) = @_; + + confess("You must provide an ID for your munger") unless $id; + + confess("Mungers must be code refs, or objects that implement handle(), got: $munger") + unless $munger && ( + (reftype $munger && reftype $munger eq 'CODE') + || + (blessed $munger && $munger->can('handle')) + ); + + my $mungers = $self->_mungers; + + confess("There is already a munger with ID: $id") + if $mungers->{$id}; + + push @{$self->_munge_order} => $id; + $mungers->{$id} = $munger; + + return sub { $self->unmunge($id) }; +} + +sub unmunge { + my $self = shift; + my ($id) = @_; + my $mungers = $self->_mungers; + + confess("You must provide an ID for your munger") unless $id; + + confess("There is no munger with ID: $id") + unless $mungers->{$id}; + + $self->_munge_order([ grep { $_ ne $id } @{$self->_munge_order} ]); + delete $mungers->{$id}; +} + +sub send { + my $self = shift; + my ($item) = @_; + + # The redirect will return true if it intends to redirect, we should then return. + # If it returns false that means we do not need to redirect and should act normally. + if (my $redirect = $self->fork) { + return if $redirect->handle(@_); + } + + my $items = [$item]; + for my $munger_id (@{$self->_munge_order}) { + my $new_items = []; + my $munger = $self->munger($munger_id) || next; + + for my $item (@$items) { + push @$new_items => reftype $munger eq 'CODE' ? $munger->($item) : $munger->handle($item); + } + + $items = $new_items; + } + + for my $item (@$items) { + if ($item->isa('Test::Builder::Result::Plan')) { + $self->plan($item); + } + + if ($item->isa('Test::Builder::Result::Bail')) { + $self->bailed_out($item); + } + + if ($item->isa('Test::Builder::Result::Ok')) { + $self->tests_run(1); + $self->tests_failed(1) unless $item->bool; + } + + for my $listener (values %{$self->_listeners}) { + protect { + if (reftype $listener eq 'CODE') { + $listener->($item); + if ($item->can('diag') && $item->diag) { + $listener->($_) for grep {$_} @{$item->diag}; + } + } + else { + $listener->handle($item); + if ($item->can('diag') && $item->diag) { + $listener->handle($_) for grep {$_} @{$item->diag}; + } + } + }; + } + } + + for my $item (@$items) { + my $type = blessed $item; + my $follow = $self->follow_up($type) || next; + $follow->($item); + } +} + +sub tap { shift->listener('LEGACY_TAP') } + +sub use_tap { + my $self = shift; + return if $self->tap; + require Test::Builder::Formatter::TAP; + $self->listen(LEGACY_TAP => Test::Builder::Formatter::TAP->new()); +} + +sub no_tap { + my $self = shift; + $self->unlisten('LEGACY_TAP') if $self->tap; + return; +} + +sub lresults { shift->listener('LEGACY_RESULTS') } + +sub use_lresults { + my $self = shift; + return if $self->lresults; + require Test::Builder::Formatter::LegacyResults; + $self->listen(LEGACY_RESULTS => Test::Builder::Formatter::LegacyResults->new()); +} + +sub no_lresults { + my $self = shift; + $self->unlisten('LEGACY_RESULTS') if $self->lresults; + return; +} + +sub fork { shift->{'fork'} } + +sub use_fork { + my $self = shift; + + return if $self->{fork}; + + require Test::Builder::Fork; + $self->{fork} = Test::Builder::Fork->new; +} + +sub no_fork { + my $self = shift; + + return unless $self->{fork}; + + delete $self->{fork}; # Turn it off. +} + +sub spawn { + my $self = shift; + my (%params) = @_; + + my $new = blessed($self)->new(); + + $new->{fork} = $self->{fork}; + + my $refs = { + listeners => $self->_listeners, + mungers => $self->_mungers, + }; + + $new->_munge_order([@{$self->_munge_order}]); + + for my $type (keys %$refs) { + for my $key (keys %{$refs->{$type}}) { + next if $key eq 'LEGACY_TAP'; + next if $key eq 'LEGACY_RESULTS'; + $new->{"_$type"}->{$key} = sub { + my $item = $refs->{$type}->{$key} || return; + return $item->(@_) if reftype $item eq 'CODE'; + $item->handle(@_); + }; + } + } + + if ($self->tap && !$params{no_tap}) { + $new->use_tap; + $new->tap->io_sets({%{$self->tap->io_sets}}); + } + + $new->use_lresults if $self->lresults && !$params{no_lresults}; + + return $new; +} + +1; + +__END__ + +=head1 NAME + +Test::Bulder::Stream - The stream between Test::Builder and the formatters. + +=head1 TEST COMPONENT MAP + + [Test Script] > [Test Tool] > [Test::Builder] > [Test::Bulder::Stream] > [Result Formatter] + ^ + You are here + +A test script uses a test tool such as L<Test::More>, which uses Test::Builder +to produce results. The results are sent to L<Test::Builder::Stream> which then +forwards them on to one or more formatters. The default formatter is +L<Test::Builder::Fromatter::TAP> which produces TAP output. + +=head1 DESCRIPTION + +This module is responsible for taking result object from L<Test::Builder> and +forwarding them to the listeners/formatters. It also has facilities for +intercepting the results and munging them. Examples of this are forking support +and L<Test::Tester2>. + +=head1 METHODS + +=head2 CONSTRUCTION/FETCHING + +It is possible to construct an independant stream object using C<new()>. Most +of the time however you do not want an independant stream, you want the shared +stream. The shared stream is the stream to which all test output should be +sent. The shared stream is actually a stack, and the topmost stream should +always be used unless you I<really> know what you are doing. + +=over 4 + +=item $stream = $class->new(); + +=item $stream = $class->new(use_tap => 1); + +=item $stream = $class->new(use_lresults => 1); + +=item $stream = $class->new(no_follow => 1); + +Create a new/independant stream object. No listeners by default, but you can +specify 'use_tap' and/or 'use_lresults' to add those listeners. + +no_follow will disable the legacy behavior of exiting on bailout, or when a +skip_all plan is encountered. + +=item $stream = $class->shared() + +Get the topmost stream on the shared stream stack. + +=item $stream = $class->root() + +Get the bottom-most stream in the shared stack. + +=item $class->clear() + +Remove all streams from the shared stack. + +=item $stream->intercept(sub { ... }) + +Push a new stream onto the stack, run the specified code, then pop the new stream off of the stack. + +=item $stream->intercept_start() + +=item $stream->intercept_start($stream) + +Push a new stream onto the top of the shared stack. Returns the $stream that +was pushed. Optionally you can provide a stream to push instead of letting it +make a new one for you. + +=item $stream->intercept_stop($stream) + +Pop the topmost stream. You B<must> pass in the stream you expect to be popped. +If the stream you pass in does not match the one popped an exception will be +thrown. + +=item $child = $stream->spawn() + +=item $child = $stream->spawn(no_tap => 1) + +=item $child = $stream->spawn(no_lresults => 1) + +Spawn a cloned stream. The clone will have all the same listeners and mungers +as the parent. Removing a listener from the parent will be reflected in the +child, but the reverse is not true. + +TAP and legacy results are special, so they are also cloned instead of carrying +them over. Removing them from the parent will not remove them from the child. + +=back + +=head2 ACCESSORS + +=over 4 + +=item $plan = $stream->plan() + +=item $stream->plan($plan) + +=item $stream->plan(undef) + +Get/Set the plan, usually done for you when a plan object is encountered. + +=item $pid = $stream->pid() + +Get the original PID in which the stream object was built. + +=item $num = $stream->tests_run() + +=item $stream->tests_run($delta) + +Get the number of tests run. Optionally you can provide a delta, the number of +tests run will be adjusted by the delta. + +=item $stream->tests_failed($delta) + +Get the number of tests failed. Optionally you can provide a delta, the number of +tests failed will be adjusted by the delta. + +=item $bool = $stream->is_passing() + +=item $stream->is_padding($bool) + +Check if tests are passing, optinally you can pass in a $bool to reset this. + +=back + +=head2 BEHAVIOR CONTROL + +=over 4 + +=item $bool = $stream->no_ending() + +=item $stream->no_ending($bool) + +enable/disable endings. Defaults to false. + +=item $action = $stream->follow_up('Test::Builder::Result::...') + +=item $stream->follow_up('Test::Builder::Result::...' => sub { ($r) = @_; ... }) + +Fetch or Specify a followup behavior to run after all listeners have gotten a +result of the specified type. + +=item $stream->legacy_followup + +switch to legacy follow-up behavior. This means exiting for bailout or skip_all. + +=item $stream->exception_followup + +Switch to exception follow-up behavior. This means throwing an exception on +bailout or skip_all. This is necessary for intercepting results. + +=item $fork_handler = $stream->fork + +Get the fork handler. + +=item $stream->use_fork + +Enable forking + +=item $stream->no_fork + +Disable forking. + +=back + +=head2 PLANNING + +=over 4 + +=item $count = $stream->expected_tests + +Get the expected number of tests, if any. + +=back + +=head2 LISTENER CONTROL + +=head3 NORMAL LISTENERS + +=over 4 + +=item $L = $stream->listener($id) + +Get the listener with the given ID. + +=item $unlisten = $stream->listen($id, $listener) + +Add a listener with the given ID. The listener can either be a coderef that +takes a result object as an argument, or any object that implements a handle() +method. + +This method returns a coderef that can be used to remove the listener. It is +better to use this method over unlisten as it will remove the listener from the +original stream object and any child stream objects. + +=item $stream->unlisten($id) + +Remove a listener by id. + +=back + +=head3 LEGACY TAP LISTENER + +=over 4 + +=item $L = $stream->tap + +Get the tap listener object (if TAP is enabled) + +=item $stream->use_tap + +Enable the legacy tap listener. + +=item $stream->no_tap + +Disable the legacy tap listener. + +=back + +=head3 LEGACY RESULTS LISTENER + +=over 4 + +=item $L = $stream->lresults + +Get the Legacy Result lsitener object. + +=item $stream->use_lresults + +Enable legacy results + +=item $stream->no_lresults + +Disable legacy results + +=back + +=head2 MUNGING RESULTS + +Mungers are expected to take a result object and return 1 or more result +objects to replace the original. They are also allowed to simply modify the +original, or return nothing to remove it. + +Mungers are run in the order they are added, it is possible that the first +munger will remove a result in which case later mungers will never see it. +Listeners get the product of running all the mungers on the original results. + +=over 4 + +=item $M = $stream->munger($id) + +Get the munger with the specified ID. + +=item $unmunge = $stream->munge($id => $munger) + +Add a munger. The munger may be a coderef that takes a single result object as +an argument, or it can be any object that implements a handle() method. + +This method returns a coderef that can be used to remove the munger. It is +better to use this method over unmunge as it will remove the munger from the +original stream object and any child stream objects. + +=item $stream->unmunge($id) + +Remove a munger by id. + +=back + +=head2 PROVIDING RESULTS + +=over 4 + +=item $stream->send($result) + +Send a result to all listeners (also goes through munging and the form handler, +etc.) + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/cpan/Test-Simple/lib/Test/Builder/Tester.pm index 5128be9d90..68dac50c87 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,17 +1,23 @@ package Test::Builder::Tester; use strict; -our $VERSION = "1.23_003"; +our $VERSION = '1.301001_034'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -use Test::Builder 0.98; +use Test::Builder 1.301001; use Symbol; use Carp; =head1 NAME -Test::Builder::Tester - test testsuites that have been built with +Test::Builder::Tester - *DEPRECATED* test testsuites that have been built with Test::Builder +=head1 DEPRECATED + +B<This module is deprecated.> Please see L<Test::Tester2> for a +better alternative that does not involve dealing with TAP/string output. + =head1 SYNOPSIS use Test::Builder::Tester tests => 1; @@ -25,20 +31,20 @@ Test::Builder =head1 DESCRIPTION A module that helps you test testing modules that are built with -B<Test::Builder>. +L<Test::Builder>. The testing system is designed to be used by performing a three step process for each test you wish to test. This process starts with using C<test_out> and C<test_err> in advance to declare what the testsuite you -are testing will output with B<Test::Builder> to stdout and stderr. +are testing will output with L<Test::Builder> to stdout and stderr. You then can run the test(s) from your test suite that call -B<Test::Builder>. At this point the output of B<Test::Builder> is -safely captured by B<Test::Builder::Tester> rather than being +L<Test::Builder>. At this point the output of L<Test::Builder> is +safely captured by L<Test::Builder::Tester> rather than being interpreted as real test output. The final stage is to call C<test_test> that will simply compare what you -predeclared to what B<Test::Builder> actually outputted, and report the +predeclared to what L<Test::Builder> actually outputted, and report the results back with a "ok" or "not ok" (with debugging) to the normal output. @@ -48,35 +54,36 @@ output. # set up testing #### -my $t = Test::Builder->new; +#my $t = Test::Builder->new; ### # make us an exporter ### -use Exporter; -our @ISA = qw(Exporter); +use Test::Builder::Provider; -our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); +provides qw(test_out test_err test_fail test_diag test_test line_num); -sub import { +sub before_import { my $class = shift; - my(@plan) = @_; + my ($args) = @_; my $caller = caller; - $t->exported_to($caller); - $t->plan(@plan); + warn __PACKAGE__ . " is deprecated!\n" if builder()->modern; + + builder()->exported_to($caller); + builder()->plan(@$args); my @imports = (); - foreach my $idx ( 0 .. $#plan ) { - if( $plan[$idx] eq 'import' ) { - @imports = @{ $plan[ $idx + 1 ] }; + foreach my $idx ( 0 .. @$args ) { + if( $args->[$idx] && $args->[$idx] eq 'import' ) { + @imports = @{ $args->[ $idx + 1 ] }; last; } } - __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports ); + @$args = @imports; } ### @@ -100,6 +107,8 @@ my $testing = 0; my $testing_num; my $original_is_passing; +my $original_stream; + # remembering where the file handles were originally connected my $original_output_handle; my $original_failure_handle; @@ -115,14 +124,14 @@ sub _start_testing { $ENV{HARNESS_ACTIVE} = 0; # remember what the handles were set to - $original_output_handle = $t->output(); - $original_failure_handle = $t->failure_output(); - $original_todo_handle = $t->todo_output(); + $original_output_handle = builder()->output(); + $original_failure_handle = builder()->failure_output(); + $original_todo_handle = builder()->todo_output(); # switch out to our own handles - $t->output($output_handle); - $t->failure_output($error_handle); - $t->todo_output($output_handle); + builder()->output($output_handle); + builder()->failure_output($error_handle); + builder()->todo_output($output_handle); # clear the expected list $out->reset(); @@ -130,13 +139,13 @@ sub _start_testing { # remember that we're testing $testing = 1; - $testing_num = $t->current_test; - $t->current_test(0); - $original_is_passing = $t->is_passing; - $t->is_passing(1); + $testing_num = builder()->current_test; + builder()->current_test(0); + $original_is_passing = builder()->is_passing; + builder()->is_passing(1); # look, we shouldn't do the ending stuff - $t->no_ending(1); + builder()->no_ending(1); } =head2 Functions @@ -165,8 +174,8 @@ which is even the same as test_out("ok 2"); Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have -been called, all further output from B<Test::Builder> will be -captured by B<Test::Builder::Tester>. This means that you will not +been called, all further output from L<Test::Builder> will be +captured by L<Test::Builder::Tester>. This means that you will not be able perform further tests to the normal output in the normal way until you call C<test_test> (well, unless you manually meddle with the output filehandles) @@ -189,7 +198,7 @@ sub test_err { =item test_fail -Because the standard failure message that B<Test::Builder> produces +Because the standard failure message that L<Test::Builder> produces whenever a test fails will be a common occurrence in your test error output, and because it has changed between Test::Builder versions, rather than forcing you to call C<test_err> with the string all the time like @@ -228,7 +237,7 @@ sub test_fail { =item test_diag As most of the remaining expected output to the error stream will be -created by Test::Builder's C<diag> function, B<Test::Builder::Tester> +created by L<Test::Builder>'s C<diag> function, L<Test::Builder::Tester> provides a convenience function C<test_diag> that you can use instead of C<test_err>. @@ -242,7 +251,7 @@ you can write test_diag("Couldn't open file"); -Remember that B<Test::Builder>'s diag function will not add newlines to +Remember that L<Test::Builder>'s diag function will not add newlines to the end of output and test_diag will. So to check Test::Builder->new->diag("foo\n","bar\n"); @@ -261,13 +270,13 @@ sub test_diag { # expect the same thing, but prepended with "# " local $_; - $err->expect( map { "# $_" } @_ ); + $err->expect( map { m/\S/ ? "# $_" : "" } @_ ); } =item test_test Actually performs the output check testing the tests, comparing the -data (with C<eq>) that we have captured from B<Test::Builder> against +data (with C<eq>) that we have captured from L<Test::Builder> against what was declared with C<test_out> and C<test_err>. This takes name/value pairs that effect how the test is run. @@ -297,9 +306,9 @@ As a convenience, if only one argument is passed then this argument is assumed to be the name of the test (as in the above examples.) Once C<test_test> has been run test output will be redirected back to -the original filehandles that B<Test::Builder> was connected to +the original filehandles that L<Test::Builder> was connected to (probably STDOUT and STDERR,) meaning any further tests you run -will function normally and cause success/errors for B<Test::Harness>. +will function normally and cause success/errors for L<Test::Harness>. =cut @@ -322,21 +331,21 @@ sub test_test { unless $testing; # okay, reconnect the test suite back to the saved handles - $t->output($original_output_handle); - $t->failure_output($original_failure_handle); - $t->todo_output($original_todo_handle); + builder()->output($original_output_handle); + builder()->failure_output($original_failure_handle); + builder()->todo_output($original_todo_handle); # restore the test no, etc, back to the original point - $t->current_test($testing_num); + builder()->current_test($testing_num); $testing = 0; - $t->is_passing($original_is_passing); + builder()->is_passing($original_is_passing); # re-enable the original setting of the harness $ENV{HARNESS_ACTIVE} = $original_harness_env; # check the output we've stashed - unless( $t->ok( ( $args{skip_out} || $out->check ) && - ( $args{skip_err} || $err->check ), $mess ) + unless( builder()->ok( ( $args{skip_out} || $out->check ) && + ( $args{skip_err} || $err->check ), $mess ) ) { # print out the diagnostic information about why this @@ -344,10 +353,10 @@ sub test_test { local $_; - $t->diag( map { "$_\n" } $out->complaint ) + builder()->diag( map { "$_\n" } $out->complaint ) unless $args{skip_out} || $out->check; - $t->diag( map { "$_\n" } $err->complaint ) + builder()->diag( map { "$_\n" } $err->complaint ) unless $args{skip_err} || $err->check; } } @@ -400,11 +409,11 @@ respectively, and the function called with no argument will return the current setting. To enable colouring from the command line, you can use the -B<Text::Builder::Tester::Color> module like so: +L<Text::Builder::Tester::Color> module like so: perl -Mlib=Text::Builder::Tester::Color test.t -Or by including the B<Test::Builder::Tester::Color> module directly in +Or by including the L<Test::Builder::Tester::Color> module directly in the PERL5LIB. =cut @@ -420,12 +429,12 @@ sub color { =head1 BUGS -Calls C<<Test::Builder->no_ending>> turning off the ending tests. +Calls C<< Test::Builder->no_ending >> turning off the ending tests. This is needed as otherwise it will trip out because we've run more tests than we strictly should have and it'll register any failures we had that we were testing for as real failures. -The color function doesn't work unless B<Term::ANSIColor> is +The color function doesn't work unless L<Term::ANSIColor> is compatible with your terminal. Bugs (and requests for new features) can be reported to the author @@ -436,7 +445,7 @@ L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester> Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. -Some code taken from B<Test::More> and B<Test::Catch>, written by +Some code taken from L<Test::More> and L<Test::Catch>, written by Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts Copyright Micheal G Schwern 2001. Used and distributed with permission. @@ -487,8 +496,9 @@ sub expect { sub _account_for_subtest { my( $self, $check ) = @_; + my $builder = Test::Builder::Tester->builder(); # Since we ship with Test::Builder, calling a private method is safe...ish. - return ref($check) ? $check : $t->_indent . $check; + return ref($check) ? $check : ($builder->depth ? ' ' x $builder->depth : '') . $check; } sub _translate_Failed_check { diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index b269a2783d..16f54db54b 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,7 +1,8 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = "1.23_002"; +our $VERSION = '1.301001_034'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) require Test::Builder::Tester; diff --git a/cpan/Test-Simple/lib/Test/Builder/Threads.pm b/cpan/Test-Simple/lib/Test/Builder/Threads.pm new file mode 100644 index 0000000000..93206ed41d --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Threads.pm @@ -0,0 +1,107 @@ +package Test::Builder::Threads; +use strict; +use warnings; + +# Make Test::Builder thread-safe for ithreads. +BEGIN { + use Config; + # Load threads::shared when threads are turned on. + if( $Config{useithreads} && $INC{'threads.pm'} ) { + require threads::shared; + + # Hack around YET ANOTHER threads::shared bug. It would + # occasionally forget the contents of the variable when sharing it. + # So we first copy the data, then share, then put our copy back. + *share = sub (\[$@%]) { + my $type = ref $_[0]; + my $data; + + if( $type eq 'HASH' ) { + %$data = %{ $_[0] }; + } + elsif( $type eq 'ARRAY' ) { + @$data = @{ $_[0] }; + } + elsif( $type eq 'SCALAR' ) { + $$data = ${ $_[0] }; + } + else { + die( "Unknown type: " . $type ); + } + + $_[0] = &threads::shared::share( $_[0] ); + + if( $type eq 'HASH' ) { + } + elsif( $type eq 'ARRAY' ) { + @{ $_[0] } = @$data; + } + elsif( $type eq 'SCALAR' ) { + ${ $_[0] } = $$data; + } + else { + die( "Unknown type: " . $type ); + } + + return $_[0]; + }; + } + else { + *share = sub { return $_[0] }; + *lock = sub { 0 }; + } +} + +sub import { + my $class = shift; + my $caller = caller; + + no strict 'refs'; + *{"$caller\::share"} = $class->can('share') if $class->can('share'); + *{"$caller\::lock"} = $class->can('lock') if $class->can('lock'); +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Threads - Helper Test::Builder uses when threaded. + +=head1 DESCRIPTION + +Helper Test::Builder uses when threaded. + +=head1 SYNOPSYS + + use threads; + use Test::Builder::Threads; + + share(...); + lock(...); + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +Most of this code was pulled out ot L<Test::Builder>, written by Schwern and +others. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Trace.pm b/cpan/Test-Simple/lib/Test/Builder/Trace.pm new file mode 100644 index 0000000000..09b76c955e --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Trace.pm @@ -0,0 +1,277 @@ +package Test::Builder::Trace; +use strict; +use warnings; + +use Test::Builder::Util qw/accessor accessors is_tester try/; +use Test::Builder::Trace::Frame; +use List::Util qw/first/; + +accessor anointed => sub { [] }; +accessor full => sub { [] }; +accessor level => sub { [] }; +accessor tools => sub { [] }; +accessor transitions => sub { [] }; +accessor stack => sub { [] }; +accessor todo => sub { [] }; + +accessors qw/_report parent/; + +my $LEVEL_WARNED = 0; + +sub nest { + my $class = shift; + my ($code, @args) = @_; + $code->(@args); +} + +sub new { + my $class = shift; + my $self = bless {}, $class; + + my $stack_level = 0; + my $seek_level = do { no warnings 'once'; $Test::Builder::Level - $Test::Builder::BLevel }; + my $notb_level = 0; + + my $current = $self; + while(my @call = CORE::caller($stack_level)) { + my $depth = $stack_level++; + my $frame = Test::Builder::Trace::Frame->new($depth, @call); + my ($pkg, $file, $line, $sub) = @call; + + push @{$current->full} => $frame; + + if ($frame->nest) { + $current->report; + $current->parent( bless {}, $class ); + $current = $current->parent; + next; + } + + next if $frame->builder; + + $notb_level++ unless $current->_is_transition($frame); + + if ($seek_level && $notb_level - 1 == $seek_level) { + $frame->level(1); + $current->report($current->tools->[-1]) if $current->tools->[-1] && !($current->_report || $frame->anointed); + + warn "\$Test::Builder::Level was used to trace a test! \$Test::Builder::Level is deprecated!\n" + if $INC{'Test/Tester2.pm'} && !$LEVEL_WARNED++; + } + + next unless grep { $frame->$_ } qw/provider_tool anointed transition level todo/; + + push @{$current->stack} => $frame; + push @{$current->tools} => $frame if $frame->provider_tool; + push @{$current->anointed} => $frame if $frame->anointed; + push @{$current->transitions} => $frame if $frame->transition; + push @{$current->level} => $frame if $frame->level; + push @{$current->todo} => $frame if $frame->todo; + } + + $current->report; + $current->encoding; # Generate this now + + return $self; +} + +sub encoding { + my $self = shift; + + unless($self->{encoding}) { + return unless @{$self->anointed}; + $self->{encoding} = $self->anointed->[0]->package->TB_TESTER_META->{encoding}; + } + + return $self->{encoding}; +} + +sub todo_package { + my $self = shift; + return $self->report->package if $self->report && $self->report->todo; + return $self->todo->[-1]->package if @{$self->todo}; + return $self->anointed->[-1]->package if @{$self->anointed}; +} + +sub report { + my $self = shift; + my ($report) = @_; + + if ($report) { + $report->report(1); + $self->_report($report); + } + elsif (!$self->_report) { + my $level = $self->level->[0]; + my $tool = $self->tools->[-1]; + my $anointed = first { !$_->provider_tool } @{$self->anointed}; + my $transition = $self->transitions->[-1]; + + if ($tool && $level) { + ($report) = sort { $b->{depth} <=> $a->{depth} } $tool, $level; + } + + $report ||= $level || $tool || $anointed || $transition; + + if ($report) { + $report->report(1); + $self->_report($report); + } + } + + return $self->_report; +} + +sub _is_transition { + my $self = shift; + my ($frame) = @_; + + # Check if it already knows + return 1 if $frame->transition; + + return if $frame->builder; + return unless @{$self->full} > 1; + return unless $self->full->[-2]->builder || $self->full->[-2]->nest; + + $frame->transition(1); + + return 1; +} + +sub anoint { + my $class = shift; + my ($target, $oil) = @_; + + unless (is_tester($target)) { + my $meta = {anointed_by => {}}; + no strict 'refs'; + *{"$target\::TB_TESTER_META"} = sub {$meta}; + } + + return 1 unless $oil; + my $meta = $target->TB_TESTER_META; + $meta->{anointed_by}->{$oil} = 1; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Test::Builder::Trace - Module to represent a stack trace from a test result. + +=head1 DESCRIPTION + +When a test fails it will report the filename and line where the failure +occured. In order to do this it needs to look at the stack and figure out where +your tests stop, and the tools you are using begin. This object helps you find +the desired caller frame. + +=head1 CLASS METHODS + +=over 4 + +=item $trace = $class->new + +Create a new object tracing from itself to the deepest stack frame. + + my $trace = Test::Builder::Trace->new(); + +=item $class->nest(sub { ... }) + +Used as a tracing barrier. Results produced in the coderef will trace to that +coderef and no deeper. + +=item $class->anoint($TARGET_PACKAGE) + +=item $class->anoint($TARGET_PACKAGE, $ANOINTED_BY_PACKAGE) + +Used to anoint a package as a testing package. + +=back + +=head1 UTILITY METHODS + +=over 4 + +=item $frame = $trace->report + +Get the L<Test::Builder::Trace::Frame> object that should be used when +reporting errors. The 'report' is determined by examining the stack, +C<$Test::Builder::Level>, and provider/anointed metadata. + +=item $package = $trace->todo_package + +Get the name of the package from which the $TODO variable should be checked. + +=item $trace = $trace->parent + +A trace stops when it encounters a call to C<Test::Builder::Trace::nest> which +acts as a tracing barrier. When such a barrier is encountered the tracing +continues, but stores the frames in a new L<Test::Builder::Trace> object that +is set as the parent. You can use this to examine the stack beyond the main +trace. + +=back + +=head1 STACKS + +All stacks are arrayrefs containing L<Test::Builder::Trace::Frame> objects. + +=over 4 + +=item $arrayref = $trace->stack + +This stack contains all frames that are relevant to finding the report. Many +frames are kept out of this list. This will usually be the most helpful stack +to examine. + +=item $arrayref = $trace->full + +Absolutely every frame is kept in this stack. Examine this if you want to see +EVERYTHING. + +=item $arrayref = $trace->anointed + +This stack contains all the frames that come from an anointed package. + +=item $arrayref = $trace->level + +This stack contains all the frames that match the C<$Test::Builder::Level> +variable. + +=item $arrayref = $trace->tools + +This stack contains all the frames that are calls to provider tools. + +=item $arrayref = $trace->transitions + +This stack contains all the frames that act as transitions between external +code and L<Test::Builder> related code. + +=item $arrayref - $trace->todo + +This stack contains all the frames that seem to have a $TODO variable available +to them. See L<Test::Builder::Trace::Frame> for caveats. + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2014 by Chad Granum E<lt>exodist7@gmail.comE<gt> + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Trace/Frame.pm b/cpan/Test-Simple/lib/Test/Builder/Trace/Frame.pm new file mode 100644 index 0000000000..3290dbd1e5 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Trace/Frame.pm @@ -0,0 +1,252 @@ +package Test::Builder::Trace::Frame; +use strict; +use warnings; + +use Test::Builder::Util qw/accessors accessor is_provider is_tester/; + +my %BUILDER_PACKAGES = ( + __PACKAGE__, 1, + 'Test::Builder' => 1, + 'Test::Builder::Result' => 1, + 'Test::Builder::Result::Bail' => 1, + 'Test::Builder::Result::Child' => 1, + 'Test::Builder::Result::Diag' => 1, + 'Test::Builder::Result::Note' => 1, + 'Test::Builder::Result::Ok' => 1, + 'Test::Builder::Result::Plan' => 1, + 'Test::Builder::Stream' => 1, + 'Test::Builder::Trace' => 1, + 'Test::Builder::Util' => 1, +); + +accessors qw{ + depth package file line subname + level report +}; + +sub new { + my $class = shift; + my ($depth, $pkg, $file, $line, $sub) = @_; + + return bless { + depth => $depth || 0, + package => $pkg || undef, + file => $file || undef, + line => $line || 0, + subname => $sub || undef, + }, $class; +} + +sub call { + my $self = shift; + return ( + $self->package, + $self->file, + $self->line, + $self->subname, + ); +} + +accessor todo => sub { + my $self = shift; + no strict 'refs'; + no warnings 'once'; + + my $ref = *{$self->package . '::TODO'}{SCALAR}; + return 1 if $ref == *Test::More::TODO{SCALAR}; + return 0 unless defined $$ref; + return 1; +}; + +accessor transition => sub { + my $self = shift; + + return 0 if $self->builder; + + my $subname = $self->subname; + return 0 unless $subname; + return 0 unless $subname =~ m/^(.*)::([^:]+)$/; + my ($pkg, $sub) = ($1, $2); + + return $BUILDER_PACKAGES{$pkg} || 0; +}; + +accessor nest => sub { + my $self = shift; + return 0 unless $self->subname eq 'Test::Builder::Trace::nest'; + return 1; +}; + +accessor builder => sub { + my $self = shift; + return 0 unless $BUILDER_PACKAGES{$self->package}; + return 1; +}; + +accessor anointed => sub { + my $self = shift; + return 0 unless is_tester($self->package); + return 0 if $self->subname eq 'Test::Builder::subtest'; + return 1; +}; + +accessor provider_tool => sub { + my $self = shift; + + my $subname = $self->subname; + return undef if $subname eq '(eval)'; + + my $attrs; + if ($subname =~ m/^Test\::Builder\::Provider\::__ANON(\d+)__/) { + no strict 'refs'; + return \%{$subname}; + } + else { + my ($pkg, $sub) = ($subname =~ m/^(.+)::([_\w][_\w0-9]*)/); + if (is_provider($pkg) && $sub && $sub ne '__ANON__') { + $attrs = $pkg->TB_PROVIDER_META->{attrs}->{$sub}; + return $attrs if $attrs->{named}; + } + } + + return undef; +}; + +1; + +=pod + +=head1 NAME + +Test::Builder::Trace::Frame - Module to represent a stack frame + +=head1 DESCRIPTION + +When a test fails it will report the filename and line where the failure +occured . In order to do this it needs to look at the stack and figure out +where your tests stop, and the tools you are using begin . This object +represents a single stack frame . + +=head1 CLASS METHODS + +=over 4 + +=item $frame = $class->new($depth, $package, $file, $line, $sub) + +Create a new instance. + + my $frame = $class->new(4, caller(4)); + +=back + +=head1 UTILITY METHODS + +=over 4 + +=item @call = $frame->call + +=item ($pkg, $file, $line, $subname) = $frame->call + +Returns a list similar to calling C<caller()>. + +=back + +=head1 ACCESSORS + +=over 4 + +=item $depth = $frame->depth + +Depth of the frame in the stack + +=item $package = $frame->package + +Package of the frame + +=item $file = $frame->file + +File of the frame + +=item $line = $frame->line + +Line of the frame + +=item $subname = $frame->subname + +Name of sub being called + +=item $attrs = $frame->provider_tool + +If the frame is a call to a provider tool this will contain the attribute +hashref for that tool. This returns undef when the call was not to a provider +tool. + +=back + +=head1 CALCULATED BOOLEAN ATTRIBUTES + +The state of these booleans will be determined the first time they are called. +They will be cached for future calls. + +=over 4 + +=item $todo = $frame->todo + +True if the frame comes from a package where $TODO is present. + +B<Caveat> Will not find the $TODO if it is undefined UNLESS the $TODO came from +L<Test::More>. + +=item $bool = $frame->nest + +True if the frame is a call to L<Test::Builder::Trace::nest()>. + +=item $bool = $frame->builder + +True if the frame is inside Test::Builder code. + +=item $bool = $frame->transition + +True if the frame is a transition between Test::Builder and Non-Test::Builder +code. + +=item $bool = $frame->anointed + +True if the frame is a call from an annointed test package. + +=back + +=head1 BOOLEAN ATTRIBUTES + +B<Note> None of these are set automatically by the constructor or any other +calls. These get set by L<Test::Builder::Trace> when it scans the stack. It +will never be useful to check these on a frame object you created yourself. + +=over 4 + +=item $bool = $frame->level + +True if the frame is associated with C<$Test::Builder::Level>. + +=item $bool = $frame->report + +True if the frame has been chosen as the reporting frame. + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2014 by Chad Granum E<lt>exodist7@gmail.comE<gt> + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> diff --git a/cpan/Test-Simple/lib/Test/Builder/Util.pm b/cpan/Test-Simple/lib/Test/Builder/Util.pm new file mode 100644 index 0000000000..4b053a47d5 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Builder/Util.pm @@ -0,0 +1,443 @@ +package Test::Builder::Util; +use strict; +use warnings; + +use Carp qw/croak/; +use Scalar::Util qw/reftype blessed/; +use Test::Builder::Threads; + +my $meta = {}; +sub TB_EXPORT_META { $meta }; + +exports(qw/ + import export exports accessor accessors delta deltas export_to transform + atomic_delta atomic_deltas try protect + package_sub is_tester is_provider find_builder +/); + +export(new => sub { + my $class = shift; + my %params = @_; + + my $self = bless {}, $class; + + $self->pre_init(\%params) if $self->can('pre_init'); + + my @attrs = keys %params; + @attrs = $self->init_order(@attrs) if @attrs && $self->can('init_order'); + + for my $attr (@attrs) { + croak "$class has no method named '$attr'" unless $self->can($attr); + $self->$attr($params{$attr}); + } + + $self->init(%params) if $self->can('init'); + + return $self; +}); + +sub import { + my $class = shift; + my $caller = caller; + + if (grep {$_ eq 'import'} @_) { + my $meta = {}; + no strict 'refs'; + *{"$caller\::TB_EXPORT_META"} = sub { $meta }; + } + + $class->export_to($caller, @_) if @_; + + 1; +} + +sub export_to { + my $from = shift; + my ($to, @subs) = @_; + + croak "package '$from' is not a TB exporter" + unless is_exporter($from); + + croak "No destination package specified." + unless $to; + + return unless @subs; + + my $meta = $from->TB_EXPORT_META; + + for my $name (@subs) { + my $ref = $meta->{$name} || croak "$from does not export '$name'"; + no strict 'refs'; + *{"$to\::$name"} = $ref; + } + + 1; +} + +sub exports { + my $caller = caller; + + my $meta = is_exporter($caller) + || croak "$caller is not an exporter!"; + + for my $name (@_) { + my $ref = $caller->can($name); + croak "$caller has no sub named '$name'" unless $ref; + + croak "Already exporting '$name'" + if $meta->{$name}; + + $meta->{$name} = $ref; + } +} + +sub export { + my ($name, $ref) = @_; + my $caller = caller; + + croak "The first argument to export() must be a symbol name" + unless $name; + + $ref ||= $caller->can($name); + croak "$caller has no sub named '$name', and no ref was provided" + unless $ref; + + # Allow any type of ref, people can export scalars, hashes, etc. + croak "The second argument to export() must be a reference" + unless ref $ref; + + my $meta = is_exporter($caller) + || croak "$caller is not an exporter!"; + + croak "Already exporting '$name'" + if $meta->{$name}; + + $meta->{$name} = $ref; +} + +sub accessor { + my ($name, $default) = @_; + my $caller = caller; + + croak "The second argument to accessor() must be a coderef, not '$default'" + if $default && !(ref $default && reftype $default eq 'CODE'); + + _accessor($caller, $name, $default); +} + +sub accessors { + my ($name) = @_; + my $caller = caller; + + _accessor($caller, "$_") for @_; +} + +sub _accessor { + my ($caller, $attr, $default) = @_; + my $name = lc $attr; + + my $sub = sub { + my $self = shift; + croak "$name\() must be called on a blessed instance, got: $self" + unless blessed $self; + + $self->{$attr} = $self->$default if $default && !exists $self->{$attr}; + ($self->{$attr}) = @_ if @_; + + return $self->{$attr}; + }; + + no strict 'refs'; + *{"$caller\::$name"} = $sub; +} + +sub transform { + my $name = shift; + my $code = pop; + my ($attr) = @_; + my $caller = caller; + + $attr ||= $name; + + croak "name is mandatory" unless $name; + croak "takes a minimum of 2 arguments" unless $code; + + my $sub = sub { + my $self = shift; + croak "$name\() must be called on a blessed instance, got: $self" + unless blessed $self; + + $self->{$attr} = $self->$code(@_) if @_ and defined $_[0]; + + return $self->{$attr}; + }; + + no strict 'refs'; + *{"$caller\::$name"} = $sub; +} + +sub delta { + my ($name, $initial) = @_; + my $caller = caller; + + _delta($caller, $name, $initial || 0, 0); +} + +sub deltas { + my $caller = caller; + _delta($caller, "$_", 0, 0) for @_; +} + +sub atomic_delta { + my ($name, $initial) = @_; + my $caller = caller; + + _delta($caller, $name, $initial || 0, 1); +} + +sub atomic_deltas { + my $caller = caller; + _delta($caller, "$_", 0, 1) for @_; +} + +sub _delta { + my ($caller, $attr, $initial, $atomic) = @_; + my $name = lc $attr; + + my $sub = sub { + my $self = shift; + + croak "$name\() must be called on a blessed instance, got: $self" + unless blessed $self; + + lock $self->{$attr} if $atomic; + $self->{$attr} = $initial unless defined $self->{$attr}; + $self->{$attr} += $_[0] if @_; + + return $self->{$attr}; + }; + + no strict 'refs'; + *{"$caller\::$name"} = $sub; +} + +sub protect(&) { + my $code = shift; + + my ($ok, $error); + { + local $@; + local $!; + $ok = eval { $code->(); 1 } || 0; + $error = $@ || "Error was squashed!\n"; + } + die $error unless $ok; + return $ok; +} + +sub try(&) { + my $code = shift; + my $error; + my $ok; + + { + local $@; + local $!; + local $SIG{__DIE__}; + + $ok = eval { $code->(); 1 } || 0; + unless($ok) { + $error = $@ || "Error was squashed!\n"; + } + } + + return wantarray ? ($ok, $error) : $ok; +} + +sub package_sub { + my ($pkg, $sub) = @_; + no warnings 'once'; + + my $globref = do { + no strict 'refs'; + \*{"$pkg\::$sub"}; + }; + + return *$globref{CODE} || undef; +} + +sub is_exporter { + my $pkg = shift; + return unless package_sub($pkg, 'TB_EXPORT_META'); + return $pkg->TB_EXPORT_META; +} + +sub is_tester { + my $pkg = shift; + return unless package_sub($pkg, 'TB_TESTER_META'); + return $pkg->TB_TESTER_META; +} + +sub is_provider { + my $pkg = shift; + return unless package_sub($pkg, 'TB_PROVIDER_META'); + return $pkg->TB_PROVIDER_META; +} + +sub find_builder { + my $trace = Test::Builder->trace_test; + + if ($trace && $trace->report) { + my $pkg = $trace->report->package; + return $pkg->TB_INSTANCE + if $pkg && package_sub($pkg, 'TB_INSTANCE'); + } + + return Test::Builder->new; +} + +1; + +__END__ + +=head1 NAME + +Test::Builder::Util - Internal tools for Test::Builder and friends + +=head1 DESCRIPTION + +Tools for generating accessors and other object bits and pieces. + +=head1 SYNOPSYS + + #Imports a sub named 'new' and all the other tools. + use Test::Builder::Util; + + # Define some exports + export 'foo'; # Export the 'foo' sub + export bar => sub { ... }; # export an anon sub named bar + + # Generate some accessors + accessors qw/yabba dabba doo/; + +=head1 EXPORTS + +=over 4 + +=item $class->new(...) + +Generic constructor method, can be used in almost any package. Takes key/value +pairs as arguments. Key is assumed to be the name of a method or accessor. The +method named for the key is called with the value as an argument. You can also +define an 'init' method which this will call for you on the newly created +object. + +=item $class->import(@list) + +Importing this method lets you define exports. + +=item $class->export_to($dest_package, @names) + +Export @names to the package $dest_package + +=item exports(@names) + +Export the subs named in @names. + +=item export($name) + +=item export($name => sub { ... }) + +Export a sub named $name. Optionally a coderef may be used. + +=item accessor($name) + +=item accessor($name, sub { return $DEFAULT }) + +Define an accessor. A default value can be specified via a coderef. + +=item accessors(qw/sub1 sub2 .../) + +Define several read/write accessors at once. + +=item transform($name, sub { ($self, @args) = @_; ... }) + +=item transform($name, $attr, sub { ($self, @args) = @_; ... }) + +Define a read/write accessor that transforms whatever you assign to it via the +given coderef. $attr is optional and defaults to $name. $attr is the key inside +the blessed object hash used to store the field. + +=item delta($name) + +=item delta($name => $default) + +=item deltas(qw/name1 name2 .../) + +=item atomic_delta($name) + +=item atomic_delta($name => $default) + +=item atomic_deltas(qw/name1 name2 .../) + +A delta accessor is an accessor that adds the numeric argument to the current +value. Optionally a default value can be specified, otherwise 0 is used. + +The atomic variations are thread-safe. + +=item $success = try { ... } + +=item ($success, $error) = try { ... } + +Eval the codeblock, return success or failure, and optionally the error +message. This code protects $@ and $!, they will be restored by the end of the +run. This code also temporarily blocks $SIG{DIE} handlers. + +=item protect { ... } + +Similar to try, except that it does not catch exceptions. The idea here is to +protect $@ and $! from changes. $@ and $! will be restored to whatever they +were before the run so long as it is successful. If the run fails $! will still +be restored, but $@ will contain the exception being thrown. + +=item $coderef = package_sub($package, $subname) + +Find a sub in a package, returns the coderef if it is present, otherwise it +returns undef. This is similar to C<< $package->can($subname) >> except that it +ignores inheritance. + +=item $meta = is_tester($package) + +Check if a package is a tester, return the metadata if it is. + +=item $meta = is_provider($package) + +Check if a package is a provider, return the metadata if it is. + +=item $TB = find_builder() + +Find the Test::Builder instance to use. + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 COPYRIGHT + +Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> |