Acme-Albed
view release on metacpan or search on metacpan
inc/Module/Install/AuthorTests.pm view on Meta::CPAN
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.002';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
#line 42
sub author_tests {
my ($self, @dirs) = @_;
_add_author_tests($self, \@dirs, 0);
}
#line 56
sub recursive_author_tests {
my ($self, @dirs) = @_;
_add_author_tests($self, \@dirs, 1);
}
sub _wanted {
my $href = shift;
sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 }
}
sub _add_author_tests {
my ($self, $dirs, $recurse) = @_;
return unless $Module::Install::AUTHOR;
my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t';
# XXX: pick a default, later -- rjbs, 2008-02-24
my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests";
@dirs = grep { -d } @dirs;
if ($recurse) {
require File::Find;
my %test_dir;
File::Find::find(_wanted(\%test_dir), @dirs);
$self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir );
} else {
$self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs );
}
}
#line 107
1;
inc/Module/Install/Makefile.pm view on Meta::CPAN
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing, always use defaults
if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
sub makemaker_args {
my $self = shift;
inc/Module/Install/Makefile.pm view on Meta::CPAN
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
my %test_dir = ();
sub _wanted_t {
/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
if ( $self->tests ) {
die "tests_recursive will not work if tests are already defined";
}
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
inc/Module/Install/Makefile.pm view on Meta::CPAN
$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
$args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
$args->{NO_META} = 1;
}
if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
$args->{SIGN} = 1;
inc/Module/Install/Makefile.pm view on Meta::CPAN
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
my $makefile = do { local $/; <MAKEFILE> };
close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
inc/Module/Install/Metadata.pm view on Meta::CPAN
sign
};
my @scalar_keys = qw{
name
module_name
abstract
author
version
distribution_type
tests
installdirs
};
my @tuple_keys = qw{
configure_requires
build_requires
requires
recommends
bundles
resources
inc/Module/Install/Metadata.pm view on Meta::CPAN
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
inc/Module/Install/Metadata.pm view on Meta::CPAN
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
inc/Module/Install/TestBase.pm view on Meta::CPAN
use warnings;
use Module::Install::Base;
use vars qw($VERSION @ISA);
BEGIN {
$VERSION = '0.11';
@ISA = 'Module::Install::Base';
}
sub use_test_base {
my $self = shift;
$self->include('Test::Base');
$self->include('Test::Base::Filter');
$self->include('Spiffy');
$self->include('Test::More');
$self->include('Test::Builder');
$self->include('Test::Builder::Module');
$self->requires('Filter::Util::Call');
}
inc/Spiffy.pm view on Meta::CPAN
my $stack_frame = 0;
my $dump = 'yaml';
my $bases_map = {};
sub WWW; sub XXX; sub YYY; sub ZZZ;
# This line is here to convince "autouse" into believing we are autousable.
sub can {
($_[1] eq 'import' and caller()->isa('autouse'))
? \&Exporter::import # pacify autouse's equality test
: $_[0]->SUPER::can($_[1]) # normal case
}
# TODO
#
# Exported functions like field and super should be hidden so as not to
# be confused with methods that can be inherited.
#
sub new {
inc/Test/Base.pm view on Meta::CPAN
#line 1
# TODO:
#
package Test::Base;
use 5.006001;
use Spiffy 0.30 -Base;
use Spiffy ':XXX';
our $VERSION = '0.59';
my @test_more_exports;
BEGIN {
@test_more_exports = qw(
ok isnt like unlike is_deeply cmp_ok
skip todo_skip pass fail
eq_array eq_hash eq_set
plan can_ok isa_ok diag
use_ok
$TODO
);
}
use Test::More import => \@test_more_exports;
use Carp;
our @EXPORT = (@test_more_exports, qw(
is no_diff
blocks next_block first_block
delimiters spec_file spec_string
filters filters_delay filter_arguments
run run_compare run_is run_is_deeply run_like run_unlike
skip_all_unless_require is_deep run_is_deep
WWW XXX YYY ZZZ
tie_output no_diag_on_only
inc/Test/Base.pm view on Meta::CPAN
unless (grep /^-base$/i, @_) {
my @args;
for (my $ii = 1; $ii <= $#_; ++$ii) {
if ($_[$ii] eq '-package') {
++$ii;
} else {
push @args, $_[$ii];
}
}
Test::More->import(import => \@test_more_exports, @args)
if @args;
}
_strict_warnings();
goto &Spiffy::import;
}
# Wrap Test::Builder::plan
my $plan_code = \&Test::Builder::plan;
my $Have_Plan = 0;
inc/Test/Base/Filter.pm view on Meta::CPAN
$self->assert_scalar(@_);
my $output = '';
Test::Base::tie_output(*STDOUT, $output);
CORE::eval(shift);
no warnings;
untie *STDOUT;
return $output;
}
sub exec_perl_stdout {
my $tmpfile = "/tmp/test-blocks-$$";
$self->_write_to($tmpfile, @_);
open my $execution, "$^X $tmpfile 2>&1 |"
or die "Couldn't open subprocess: $!\n";
local $/;
my $output = <$execution>;
close $execution;
unlink($tmpfile)
or die "Couldn't unlink $tmpfile: $!\n";
return $output;
}
inc/Test/Builder.pm view on Meta::CPAN
$? = 0;
$child->{Parent} = $self;
$child->{Name} = $name || "Child of " . $self->name;
$self->{Child_Name} = $child->name;
return $child;
}
#line 201
sub subtest {
my $self = shift;
my($name, $subtests) = @_;
if ('CODE' ne ref $subtests) {
$self->croak("subtest()'s second argument must be a code ref");
}
# Turn the child into the parent so anyone who has stored a copy of
# the Test::Builder singleton will get the child.
my $child = $self->child($name);
my %parent = %$self;
%$self = %$child;
my $error;
if( !eval { $subtests->(); 1 } ) {
$error = $@;
}
# Restore the parent and the copied child.
%$child = %$self;
%$self = %parent;
# Die *after* we restore the parent.
die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
inc/Test/Builder.pm view on Meta::CPAN
# XXX This will only be necessary for TAP envelopes (we think)
#$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
my $ok = 1;
$self->parent->{Child_Name} = undef;
if ( $self->{Skip_All} ) {
$self->parent->skip($self->{Skip_All});
}
elsif ( not @{ $self->{Test_Results} } ) {
$self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
}
else {
$self->parent->ok( $self->is_passing, $self->name );
}
$? = $self->{Child_Error};
delete $self->{Parent};
return $self->is_passing;
}
inc/Test/Builder.pm view on Meta::CPAN
$self->_dup_stdhandles;
return;
}
#line 414
my %plan_cmds = (
no_plan => \&no_plan,
skip_all => \&skip_all,
tests => \&_plan_tests,
);
sub plan {
my( $self, $cmd, $arg ) = @_;
return unless $cmd;
local $Level = $Level + 1;
$self->croak("You tried to plan twice") if $self->{Have_Plan};
inc/Test/Builder.pm view on Meta::CPAN
}
else {
my @args = grep { defined } ( $cmd, $arg );
$self->croak("plan() doesn't understand @args");
}
return 1;
}
sub _plan_tests {
my($self, $arg) = @_;
if($arg) {
local $Level = $Level + 1;
return $self->expected_tests($arg);
}
elsif( !defined $arg ) {
$self->croak("Got an undefined number of tests");
}
else {
$self->croak("You said to run 0 tests");
}
return;
}
#line 470
sub expected_tests {
my $self = shift;
my($max) = @_;
if(@_) {
$self->croak("Number of tests must be a positive integer. You gave it '$max'")
unless $max =~ /^\+?\d+$/;
$self->{Expected_Tests} = $max;
$self->{Have_Plan} = 1;
$self->_output_plan($max) unless $self->no_header;
}
return $self->{Expected_Tests};
}
inc/Test/Builder.pm view on Meta::CPAN
$self->_print("$plan\n");
$self->{Have_Output_Plan} = 1;
return;
}
#line 579
sub done_testing {
my($self, $num_tests) = @_;
# If done_testing() specified the number of tests, shut off no_plan.
if( defined $num_tests ) {
$self->{No_Plan} = 0;
}
else {
$num_tests = $self->current_test;
}
if( $self->{Done_Testing} ) {
my($file, $line) = @{$self->{Done_Testing}}[1,2];
$self->ok(0, "done_testing() was already called at $file line $line");
return;
}
$self->{Done_Testing} = [caller];
if( $self->expected_tests && $num_tests != $self->expected_tests ) {
$self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
"but done_testing() expects $num_tests");
}
else {
$self->{Expected_Tests} = $num_tests;
}
$self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
$self->{Have_Plan} = 1;
# The wrong number of tests were run
$self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
# No tests were run
$self->is_passing(0) if $self->{Curr_Test} == 0;
return 1;
}
#line 630
sub has_plan {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
if( defined $pack ) {
$self->{Exported_To} = $pack;
}
return $self->{Exported_To};
}
#line 702
sub ok {
my( $self, $test, $name ) = @_;
if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
$name = 'unnamed test' unless defined $name;
$self->is_passing(0);
$self->croak("Cannot run test ($name) with active children");
}
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
lock $self->{Curr_Test};
$self->{Curr_Test}++;
# In case $name is a string overloaded object, force it to stringify.
$self->_unoverload_str( \$name );
$self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
You named your test '$name'. You shouldn't use numbers for your test names.
Very confusing.
ERR
# Capture the value of $TODO for the rest of this ok() call
# so it can more easily be found by other routines.
my $todo = $self->todo();
my $in_todo = $self->in_todo;
local $self->{Todo} = $todo if $in_todo;
$self->_unoverload_str( \$todo );
my $out;
my $result = &share( {} );
unless($test) {
$out .= "not ";
@$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
}
else {
@$result{ 'ok', 'actual_ok' } = ( 1, $test );
}
$out .= "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
if( defined $name ) {
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
$out .= " - $name";
$result->{name} = $name;
}
inc/Test/Builder.pm view on Meta::CPAN
else {
$result->{reason} = '';
$result->{type} = '';
}
$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
$out .= "\n";
$self->_print($out);
unless($test) {
my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
$self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
my( undef, $file, $line ) = $self->caller;
if( defined $name ) {
$self->diag(qq[ $msg test '$name'\n]);
$self->diag(qq[ at $file line $line.\n]);
}
else {
$self->diag(qq[ $msg test at $file line $line.\n]);
}
}
$self->is_passing(0) unless $test || $self->in_todo;
# Check that we haven't violated the plan
$self->_check_is_passing_plan();
return $test ? 1 : 0;
}
# Check that we haven't yet violated the plan and set
# is_passing() accordingly
sub _check_is_passing_plan {
my $self = shift;
my $plan = $self->has_plan;
return unless defined $plan; # no plan yet defined
inc/Test/Builder.pm view on Meta::CPAN
#line 876
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
$self->_unoverload_str( \$got, \$expect );
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok( $test, $name );
$self->_is_diag( $got, 'eq', $expect ) unless $test;
return $test;
}
return $self->cmp_ok( $got, 'eq', $expect, $name );
}
sub is_num {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
$self->_unoverload_num( \$got, \$expect );
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok( $test, $name );
$self->_is_diag( $got, '==', $expect ) unless $test;
return $test;
}
return $self->cmp_ok( $got, '==', $expect, $name );
}
sub _diag_fmt {
my( $self, $type, $val ) = @_;
if( defined $$val ) {
if( $type eq 'eq' or $type eq 'ne' ) {
inc/Test/Builder.pm view on Meta::CPAN
}
#line 973
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok( $test, $name );
$self->_isnt_diag( $got, 'ne' ) unless $test;
return $test;
}
return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
}
sub isnt_num {
my( $self, $got, $dont_expect, $name ) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok( $test, $name );
$self->_isnt_diag( $got, '!=' ) unless $test;
return $test;
}
return $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
#line 1022
sub like {
my( $self, $this, $regex, $name ) = @_;
inc/Test/Builder.pm view on Meta::CPAN
return $self->_regex_ok( $this, $regex, '!~', $name );
}
#line 1046
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
sub cmp_ok {
my( $self, $got, $type, $expect, $name ) = @_;
my $test;
my $error;
{
## no critic (BuiltinFunctions::ProhibitStringyEval)
local( $@, $!, $SIG{__DIE__} ); # isolate eval
my($pack, $file, $line) = $self->caller();
$test = eval qq[
#line 1 "cmp_ok [from $file line $line]"
\$got $type \$expect;
];
$error = $@;
}
local $Level = $Level + 1;
my $ok = $self->ok( $test, $name );
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
my $unoverload
= $numeric_cmps{$type}
? '_unoverload_num'
: '_unoverload_str';
$self->diag(<<"END") if $error;
An error occurred while using $type:
inc/Test/Builder.pm view on Meta::CPAN
unless( defined $usable_regex ) {
local $Level = $Level + 1;
$ok = $self->ok( 0, $name );
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
{
## no critic (BuiltinFunctions::ProhibitStringyEval)
my $test;
my $context = $self->_caller_context;
local( $@, $!, $SIG{__DIE__} ); # isolate eval
$test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
$test = !$test if $cmp eq '!~';
local $Level = $Level + 1;
$ok = $self->ok( $test, $name );
}
unless($ok) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
local $Level = $Level + 1;
$self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
%s
%13s '%s'
inc/Test/Builder.pm view on Meta::CPAN
#line 1389
sub _try {
my( $self, $code, %opts ) = @_;
my $error;
my $return;
{
local $!; # eval can mess up $!
local $@; # don't set $@ in the test
local $SIG{__DIE__}; # don't trip an outside DIE handler.
$return = eval { $code->() };
$error = $@;
}
die $error if $error and $opts{die_on_fail};
return wantarray ? ( $return, $error ) : $return;
}
inc/Test/Builder.pm view on Meta::CPAN
sub _print {
my $self = shift;
return $self->_print_to_fh( $self->output, @_ );
}
sub _print_to_fh {
my( $self, $fh, @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, ' ', '' );
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
$msg =~ s{\n(?!\z)}{\n# }sg;
inc/Test/Builder.pm view on Meta::CPAN
or $self->croak("Can't open scalar ref $file_or_fh: $!");
}
# Emulate scalar ref filehandles with a tie.
else {
$fh = Test::Builder::IO::Scalar->new($file_or_fh)
or $self->croak("Can't tie scalar ref $file_or_fh");
}
}
else {
open $fh, ">", $file_or_fh
or $self->croak("Can't open test output log $file_or_fh: $!");
_autoflush($fh);
}
return $fh;
}
sub _autoflush {
my($fh) = shift;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
return;
}
my( $Testout, $Testerr );
sub _dup_stdhandles {
my $self = shift;
$self->_open_testhandles;
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
_autoflush($Testout);
_autoflush( \*STDOUT );
_autoflush($Testerr);
_autoflush( \*STDERR );
$self->reset_outputs;
return;
}
sub _open_testhandles {
my $self = shift;
return if $self->{Opened_Testhandles};
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
# $self->_copy_io_layers( \*STDOUT, $Testout );
# $self->_copy_io_layers( \*STDERR, $Testerr );
$self->{Opened_Testhandles} = 1;
return;
}
inc/Test/Builder.pm view on Meta::CPAN
}
sub croak {
my $self = shift;
return die $self->_message_at_caller(@_);
}
#line 1923
sub current_test {
my( $self, $num ) = @_;
lock( $self->{Curr_Test} );
if( defined $num ) {
$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};
}
#line 1971
sub is_passing {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
}
#line 2239
#line 2253
#'#
sub _sanity_check {
my $self = shift;
$self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
$self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
'Somehow you got a different number of results than tests ran!' );
return;
}
#line 2274
sub _whoa {
my( $self, $check, $desc ) = @_;
if($check) {
local $Level = $Level + 1;
inc/Test/Builder.pm view on Meta::CPAN
return if $self->{Ending}++;
my $real_exit_code = $?;
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
if( $self->{Original_Pid} != $$ ) {
return;
}
# Ran tests but never declared a plan or hit done_testing
if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
$self->is_passing(0);
$self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
}
# Exit if plan() was never called. This is so "require Test::Simple"
# doesn't puke.
if( !$self->{Have_Plan} ) {
return;
}
# Don't do an ending if we bailed out.
if( $self->{Bailed_Out} ) {
$self->is_passing(0);
return;
}
# Figure out if we passed or failed and print helpful messages.
my $test_results = $self->{Test_Results};
if(@$test_results) {
# The plan? We have no plan.
if( $self->{No_Plan} ) {
$self->_output_plan($self->{Curr_Test}) unless $self->no_header;
$self->{Expected_Tests} = $self->{Curr_Test};
}
# Auto-extended arrays and elements which aren't explicitly
# filled in with a shared reference will puke under 5.8.0
# ithreads. So we have to fill them in by hand. :(
my $empty_result = &share( {} );
for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
$test_results->[$idx] = $empty_result
unless defined $test_results->[$idx];
}
my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
if( $num_extra != 0 ) {
my $s = $self->{Expected_Tests} == 1 ? '' : 's';
$self->diag(<<"FAIL");
Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
FAIL
$self->is_passing(0);
}
if($num_failed) {
my $num_tests = $self->{Curr_Test};
my $s = $num_failed == 1 ? '' : 's';
my $qualifier = $num_extra == 0 ? '' : ' run';
$self->diag(<<"FAIL");
Looks like you failed $num_failed test$s of $num_tests$qualifier.
FAIL
$self->is_passing(0);
}
if($real_exit_code) {
$self->diag(<<"FAIL");
Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
FAIL
$self->is_passing(0);
_my_exit($real_exit_code) && return;
}
my $exit_code;
if($num_failed) {
$exit_code = $num_failed <= 254 ? $num_failed : 254;
}
elsif( $num_extra != 0 ) {
inc/Test/Builder.pm view on Meta::CPAN
$exit_code = 0;
}
_my_exit($exit_code) && return;
}
elsif( $self->{Skip_All} ) {
_my_exit(0) && return;
}
elsif($real_exit_code) {
$self->diag(<<"FAIL");
Looks like your test exited with $real_exit_code before it could output anything.
FAIL
$self->is_passing(0);
_my_exit($real_exit_code) && return;
}
else {
$self->diag("No tests run!\n");
$self->is_passing(0);
_my_exit(255) && return;
}
$self->is_passing(0);
$self->_whoa( 1, "We fell off the end of _ending()" );
}
END {
$Test->_ending if defined $Test;
inc/Test/Builder/Module.pm view on Meta::CPAN
#line 74
sub import {
my($class) = shift;
# 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);
$class->import_extra( \@_ );
my(@imports) = $class->_strip_imports( \@_ );
$test->plan(@_);
$class->export_to_level( 1, $class, @imports );
}
sub _strip_imports {
my $class = shift;
my $list = shift;
my @imports = ();
my @other = ();
inc/Test/More.pm view on Meta::CPAN
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
our @EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
cmp_ok
skip todo todo_skip
pass fail
eq_array eq_hash eq_set
$TODO
plan
done_testing
can_ok isa_ok new_ok
diag note explain
subtest
BAIL_OUT
);
#line 164
sub plan {
my $tb = Test::More->builder;
return $tb->plan(@_);
}
inc/Test/More.pm view on Meta::CPAN
$idx++;
}
@$list = @other;
return;
}
#line 217
sub done_testing {
my $tb = Test::More->builder;
$tb->done_testing(@_);
}
#line 289
sub ok ($;$) {
my( $test, $name ) = @_;
my $tb = Test::More->builder;
return $tb->ok( $test, $name );
}
#line 367
sub is ($$;$) {
my $tb = Test::More->builder;
return $tb->is_eq(@_);
}
inc/Test/More.pm view on Meta::CPAN
else {
$tb->ok( 0, "new() died" );
$tb->diag(" Error was: $error");
}
return $obj;
}
#line 719
sub subtest($&) {
my ($name, $subtests) = @_;
my $tb = Test::More->builder;
return $tb->subtest(@_);
}
#line 743
sub pass (;$) {
my $tb = Test::More->builder;
return $tb->ok( 1, @_ );
}
inc/Test/More.pm view on Meta::CPAN
#line 1204
## no critic (Subroutines::RequireFinalReturn)
sub skip {
my( $why, $how_many ) = @_;
my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "skip() needs to know \$how_many tests are in the block"
unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
if( defined $how_many and $how_many =~ /\D/ ) {
_carp
"skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
$how_many = 1;
}
for( 1 .. $how_many ) {
$tb->skip($why);
}
no warnings 'exiting';
last SKIP;
}
#line 1288
sub todo_skip {
my( $why, $how_many ) = @_;
my $tb = Test::More->builder;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "todo_skip() needs to know \$how_many tests are in the block"
unless $tb->has_plan eq 'no_plan';
$how_many = 1;
}
for( 1 .. $how_many ) {
$tb->todo_skip($why);
}
no warnings 'exiting';
last TODO;
( run in 2.221 seconds using v1.01-cache-2.11-cpan-98e64b0badf )