File Coverage

blib/lib/Test/Modern.pm

Criterion	Covered	Total	%
statement	201	279	72.0
branch	52	116	44.8
condition	9	25	36.0
subroutine	37	44	84.0
pod	5	5	100.0
total	304	469	64.8

use 5.006001;
use strict;
use warnings;

package Test::Modern;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.012';

our $VERBOSE;

use Cwd              0     qw();
use Exporter::Tiny   0.030 qw();
use File::Spec       0     qw();
use IO::File         1.08  qw();
use IO::Handle       1.21  qw();
use Import::Into     1.002 qw();
use Module::Runtime  0.012 qw( require_module module_notional_filename );
use Test::More       0.96;
use Test::API        0.004;
use Test::Fatal      0.007;
use Test::Warnings   0.009 qw( warning warnings ), ($ENV{PERL_TEST_MODERN_ALLOW_WARNINGS} ? ':no_end_test' : ());
use Test::Deep       0.111 qw( :v1 );
use Try::Tiny        0.15  qw( try catch );

my %HINTS;

$HINTS{ extended } = sub
{
	return if $ENV{EXTENDED_TESTING};
	plan skip_all => 'Not running extended tests';
};

$HINTS{ author } = sub
{
	return if $ENV{AUTHOR_TESTING};
	plan skip_all => 'Not running author tests';
};

$HINTS{ release } = sub
{
	return if $ENV{RELEASE_TESTING};
	plan skip_all => 'Not running release tests';
};

$HINTS{ interactive } = sub
{
	return unless $ENV{AUTOMATED_TESTING};
	plan skip_all => 'Not running interactive tests';
};

$HINTS{ requires } = sub
{
	my %requires = %{ $_[2] };
	for my $module (sort keys %requires)
	{
		if ($module eq 'perl')
		{
			next if !defined($requires{$module});
			next if $] >= $requires{$module};
			return plan skip_all => sprintf(
				"Test requires Perl %s",
				$requires{$module},
			);
		}

		try {
			&require_module(
				$module,
				defined($requires{$module}) ? $requires{$module} : (),
			);
		}
		catch {
			plan skip_all => sprintf(
				"Test requires %s%s",
				$module,
				defined($requires{$module}) ? " $requires{$module}" : "",
			);
		}
	}
	return;
};

$HINTS{ lib } = sub { $_[3]{lib}++; () };

{
	my ($installed, %hide) = 0;

	# This implementation stolen from Devel::Hide. Keep the
	# Perl-5.6 compatible implementation, because one day it
	# might be nice if this module could support Perl 5.6.
	my $_scalar_as_io = ($] >= 5.008)
		? sub {
			open(my($io), '<', \$_[0])
				or die("Cannot open scalarref for IO?!");
			return $io;
		}
		: sub {
			my $scalar = shift;
			require File::Temp;
			my $io = File::Temp::tempfile();
			print {$io} $scalar;
			seek $io, 0, 0; # rewind the handle
			return $io;
		};

	my $inc = sub
	{
		my (undef, $file) = @_;
		if ($hide{$file})
		{
			my $oops = sprintf(
				qq{die "Can't locate %s (hidden by %s)\\n";},
				$file,
				__PACKAGE__,
			);
			return $_scalar_as_io->($oops);
		}
		return;
	};

	$HINTS{ without } = sub
	{
		unless ($installed)
		{
			unshift(@INC, $inc);
			++$installed;
		}

		my @without = @{ $_[2] };
		for my $module (@without)
		{
			my $file = module_notional_filename($module);
			exists($INC{$file})
				? plan(skip_all => sprintf("cannot prevent $module from loading (it is already loaded)"))
				: ++$hide{$file};
		}
		return;
	};
}

{
	my $checker;
	$checker = sub {
		$checker = eval q{
			package #
				Dummy::Test::RequiresInternet;
			use Socket;
			sub {
				my ($host, $port) = @_;
				my $portnum = ($port =~ /[^0-9]/) ? getservbyname($port, "tcp") : $port;
				die "Could not find a port number for $port\n" if not $portnum;
				my $iaddr = inet_aton($host) or die "no host: $host\n";
				my $paddr = sockaddr_in($portnum, $iaddr);
				my $proto = getprotobyname("tcp");
				socket(my $sock, PF_INET, SOCK_STREAM, $proto) or die "socket: $!\n";
				connect($sock, $paddr) or die "connect: $!\n";
				close($sock) or die "close: $!\n";
				!!1;
			}
		};
		goto($checker);
	};

	$HINTS{ internet } = sub
	{
		plan skip_all => 'Not running network tests'
			if $ENV{NO_NETWORK_TESTING};

		my $arg = $_[2];
		my @hosts =
			ref($arg) eq q(HASH)   ? %$arg :
			ref($arg) eq q(ARRAY)  ? @$arg :
			ref($arg) eq q(SCALAR) ? ( $$arg => 80 ) :
			( 'www.google.com' => 80 );

		while (@hosts) {
			my ($host, $port) = splice(@hosts, 0, 2);
			defined($host) && defined($port)
				or BAIL_OUT("Expected host+port pair (not undef)");
			eval { $checker->($host, $port); 1 } or plan skip_all => "$@";
		}

		return;
	};
}

$HINTS{ benchmark } = sub
{
	return qw(is_fastest)
		if $ENV{RELEASE_TESTING} || $ENV{EXTENDED_TESTING};
	plan skip_all => 'Not running benchmarks';
};

$HINTS{ verbose } = sub { $VERBOSE = 1; () };

our @ISA = qw(Exporter::Tiny);
our %EXPORT_TAGS = (
	more     => [qw(
		ok is isnt like unlike is_deeply cmp_ok new_ok isa_ok can_ok
		pass fail
		diag note explain
		subtest
		skip todo_skip plan done_testing BAIL_OUT
	)],
	fatal    => [qw( exception )],
	warnings => [qw( warnings warning )],
	api      => [qw( public_ok import_ok class_api_ok )],
	moose    => [qw( does_ok )],
	pod      => [qw(
		pod_file_ok all_pod_files_ok
		pod_coverage_ok all_pod_coverage_ok
	)],
	versions => [qw( version_ok version_all_ok version_all_same )],
	strings  => [qw(
		is_string is_string_nows like_string unlike_string
		contains_string lacks_string
	)],
	clean    => [qw( namespaces_clean )],
	deep     => [qw( cmp_deeply TD )],
	deeper   => [qw(
		cmp_deeply TD
		ignore methods listmethods shallow noclass useclass
		re superhashof subhashof bag superbagof subbagof
		set supersetof subsetof all any obj_isa array_each
		str num bool code
	)],
	deprecated => [qw( use_ok require_ok eq_array eq_hash eq_set )],
	%HINTS,
);

our @EXPORT_OK = (
	'object_ok', 'shouldnt_warn', 'is_fastest',
	map(@$_, grep { ref($_) eq 'ARRAY' } values(%EXPORT_TAGS)),
);

our @EXPORT = (
	'object_ok',
	map(@{$EXPORT_TAGS{$_}}, qw(more fatal warnings api moose strings deep clean)),
);

# Here we check to see if the import list consists
# only of hints. If so, we add @EXPORT to the list.
# This means that `use Test::Modern -extended;`
# won't result in the standard exports getting
# suppressed.
#
sub import
{
	my $me = shift;
	my $symbols = grep {
		ref($_)                        ? 0 :  # refs are not symbols
		/\A[:-](\w+)\z/ && $HINTS{$1}  ? 0 :  # hints are not symbols
		1;                                    # everything else is
	} @_;

	push @_, @EXPORT if $symbols == 0;

	my $globals = ref($_[0]) eq 'HASH' ? shift() : {};
	$globals->{into_file} = (caller)[1] unless ref($globals->{into});

	unshift @_, $me, $globals;
	goto \&Exporter::Tiny::import;
}

sub _exporter_validate_opts
{
	my $me = shift;
	my ($opts) = @_;
	my $caller = $opts->{into};

	# Exporter::Tiny can't handle exporting variables
	# at the moment. :-(
	#
	{
		no strict qw(refs);
		(ref($caller) ? $caller->{'$TODO'} : *{"$caller\::TODO"})
			= \$Test::More::TODO;
	}

	return if ref $caller;
	'strict'->import::into($caller);
	'warnings'->import::into($caller);
	$me->_setup_inc($opts);
}

sub _setup_inc
{
	shift;
	my ($opts) = @_;

	return unless exists($opts->{into_file});

	my $dir = do {
		my ($v, $d) = 'File::Spec'->splitpath($opts->{into_file});
		'File::Spec'->catpath($v, $d, '');
	};

	my $found;
	LEVEL: for my $i (0..5)
	{
		my $t_dir    = 'File::Spec'->catdir($dir, (('File::Spec'->updir) x $i), 't');
		my $xt_dir   = 'File::Spec'->catdir($dir, (('File::Spec'->updir) x $i), 'xt');

		-d $t_dir or -d $xt_dir or next LEVEL;

		my $tlib_dir = 'File::Spec'->catdir($t_dir, 'lib');

		if (-d $tlib_dir)
		{
			require lib;
			'lib'->import(Cwd::abs_path $tlib_dir);
			$found++;
		}

		last LEVEL if $found;
	}

	if ($opts->{lib} and not $found)
	{
		BAIL_OUT("Expected to find directory t/lib!");
	}
}

# Additional exports
#

sub does_ok ($$;$) # just a copy of Test::More::isa_ok
{
	my( $thing, $class, $thing_name ) = @_;
	my $tb = Test::More->builder;

	my $whatami;
	if( !defined $thing ) {
		$whatami = 'undef';
	}
	elsif( ref $thing ) {
		$whatami = 'reference';

		local($@,$!);
		require Scalar::Util;
		if( Scalar::Util::blessed($thing) ) {
			$whatami = 'object';
		}
	}
	else {
		$whatami = 'class';
	}

	my ($rslt, $error);
	try { $rslt = $thing->DOES($class) } catch { $error = $_ };

	if ($error) {
		die <
WHOA! I tried to call ->DOES on your $whatami and got some weird error.
Here's the error.
$error
WHOA
	}

	# Special case for isa_ok( [], "ARRAY" ) and like
	if( $whatami eq 'reference' ) {
		$rslt = UNIVERSAL::DOES($thing, $class);
	}

	my($diag, $name);
	if( defined $thing_name ) {
		$name = "'$thing_name' does '$class'";
		$diag = defined $thing ? "'$thing_name' doesn't '$class'" : "'$thing_name' isn't defined";
	}
	elsif( $whatami eq 'object' ) {
		my $my_class = ref $thing;
		$thing_name = qq[An object of class '$my_class'];
		$name = "$thing_name does '$class'";
		$diag = "The object of class '$my_class' doesn't '$class'";
	}
	elsif( $whatami eq 'reference' ) {
		my $type = ref $thing;
		$thing_name = qq[A reference of type '$type'];
		$name = "$thing_name does '$class'";
		$diag = "The reference of type '$type' doesn't '$class'";
	}
	elsif( $whatami eq 'undef' ) {
		$thing_name = 'undef';
		$name = "$thing_name does '$class'";
		$diag = "$thing_name isn't defined";
	}
	elsif( $whatami eq 'class' ) {
		$thing_name = qq[The class (or class-like) '$thing'];
		$name = "$thing_name does '$class'";
		$diag = "$thing_name doesn't '$class'";
	}
	else {
		die;
	}

	my $ok;
	if($rslt) {
		$ok = $tb->ok( 1, $name );
	}
	else {
		$ok = $tb->ok( 0, $name );
		$tb->diag("	$diag\n");
	}

	return $ok;
}

sub object_ok
{
	local $Test::Builder::Level = $Test::Builder::Level + 1;

	my $object = shift;
	my $name   = (@_%2) ? shift : '$object';
	my %tests  = @_;
	my $bail   = !!0;

	my $result = &subtest("$name ok", sub
	{
		if (ref($object) eq q(CODE))
		{
			try {
				my $tmp = $object->();
				die 'coderef did not return an object'
					unless ref($tmp);
				$object = $tmp;
				pass("instantiate $name");
			}
			catch {
				fail("instantiate $name");
				diag("instantiating $name threw an exception: $_");
			}
		}

		ok(Scalar::Util::blessed($object), "$name is blessed")
			or return;

		if (exists($tests{isa}))
		{
			my @classes = ref($tests{isa}) eq q(ARRAY) ? @{$tests{isa}} : $tests{isa};
			isa_ok($object, $_, $name) for @classes;
			delete $tests{isa};
		}

		if (exists($tests{does}))
		{
			my @roles = ref($tests{does}) eq q(ARRAY) ? @{$tests{does}} : $tests{does};
			does_ok($object, $_, $name) for @roles;
			delete $tests{does};
		}

		if (exists($tests{can}))
		{
			my @methods = ref($tests{can}) eq q(ARRAY) ? @{$tests{can}} : $tests{can};
			can_ok($object, @methods);
			delete $tests{can};
		}

		if (exists($tests{api}))
		{
			my @methods = ref($tests{api}) eq q(ARRAY) ? @{$tests{api}} : $tests{api};
			class_api_ok(ref($object), @methods);
			delete $tests{api};
		}

		if (delete($tests{clean}))
		{
			namespaces_clean(ref($object));
		}

		if (exists($tests{more}))
		{
			my $more = delete $tests{more};
			&subtest("more tests for $name", sub
			{
				my $exception = exception { $object->$more };
				is($exception, undef, "no exception thrown by additional tests");
				done_testing;
			});
		}

		$bail = !!keys %tests;

		done_testing;
	});

	if ($bail)
	{
		my $huh = join q[, ], sort keys %tests;
		BAIL_OUT("object_ok cannot understand: $huh");
	}

	# return $object
	$result ? $object : ();
}

{
	my $wrap = sub {
		my @alts = @_;
		my $chosen;
		return sub {
			unless ($chosen)
			{
				ALT: for (@alts)
				{
					ref($_) and ($chosen = $_) and last ALT;
					my ($module, $sub) = /^(.+)::(\w+)$/;
					try {
						no strict qw(refs);
						no warnings qw(exiting);
						require_module($module);
						exists(&$_)
							? (($chosen = \&$_) and last ALT)
							: die("no such sub $_");
					}
					catch {
						diag("could not load $module: $_");
					};
				}
			}
			$chosen
				? goto($chosen)
				: fail("$alts[0] not available - failing test!")
		};
	};

	*is_string = $wrap->(
		'Test::LongString::is_string',
		'Test::More::is',
	);
	*is_string_nows = $wrap->(
		'Test::LongString::is_string_nows',
		sub {
			my $got      = shift;
			my $expected = shift;
			s/\s+//g for $got, $expected;
			unshift @_, $got, $expected;
			goto \&Test::More::is;
		},
	);
	*like_string = $wrap->(
		'Test::LongString::like_string',
		'Test::More::like',
	);
	*unlike_string = $wrap->(
		'Test::LongString::unlike_string',
		'Test::More::unlike',
	);
	*contains_string = $wrap->(
		'Test::LongString::contains_string',
		sub {
			my $got      = shift;
			my $expected = shift;
			unshift @_, $got, qr/\Q$expected\E/;
			goto \&Test::More::like;
		},
	);
	*lacks_string = $wrap->(
		'Test::LongString::lacks_string',
		sub {
			my $got      = shift;
			my $expected = shift;
			unshift @_, $got, qr/\Q$expected\E/;
			goto \&Test::More::unlike;
		},
	);
}

sub _generate_TD
{
	my $_td = bless(do { my $x = 1; \$x }, 'Test::Modern::_TD');
	return sub () { $_td };
}

sub Test::Modern::_TD::AUTOLOAD
{
	shift;
	my ($method) = ($Test::Modern::_TD::AUTOLOAD =~ /(\w+)\z/);
	return if $method eq 'DESTROY';
	my $coderef = 'Test::Deep'->can($method)
		or die("Test::Deep::$method not found");
	$coderef->(@_);
}

# Stolen from Test::CleanNamespaces; eliminated Package::Stash and
# Sub::Name dependencies; massively cleaned up; don't use Test::Builder
# directly; instead just call Test::More's exported functions.
#
{
	my $_dirt = sub
	{
		my $ns = shift;
		require_module($ns);

		my %symbols = do {
			no strict qw(refs);
			map   { /([^:]+)$/; $1 => $_; }
			grep  { eval { *$_{CODE} } }
			values %{"$ns\::"};
		};

		my @imports;
		my $meta;
		if ($INC{ module_notional_filename('Moose::Util') }
			and $meta = Moose::Util::find_meta($ns))
		{
			my %subs = %symbols;
			delete @subs{ $meta->get_method_list };
			@imports = keys %subs;
		}
		elsif ($INC{ module_notional_filename('Mouse::Util') }
			and $meta = Mouse::Util::class_of($ns))
		{
			my %subs = %symbols;
			delete @subs{ $meta->get_method_list };
			@imports = keys %subs;
		}
		else
		{
			require B;
			no strict qw(refs);
			@imports = grep {
				my $stash = B::svref_2object(\&{"$ns\::$_"})->GV->STASH->NAME;
				$stash ne $ns
					and $stash ne 'Role::Tiny'
					and not eval { require Role::Tiny; Role::Tiny->is_role($stash) }
			} keys %symbols;
		}

		my %imports; @imports{@imports} = map substr("$symbols{$_}", 1), @imports;

		# But really it's better to inherit these rather than import them. :-)
		if (keys %imports) {
			delete @imports{qw(import unimport)};
		}

		if (keys %imports) {
			my @overloads = grep {
				/^\(/ or $imports{$_} eq 'overload::nil'
			} keys %imports;
			delete @imports{@overloads} if @overloads;
		}

		if (keys %imports and $] < 5.010) {
			my @constants = grep { $imports{$_} eq 'constant::__ANON__' } keys %imports;
			delete @imports{@constants} if @constants;
		}

		@imports = sort keys(%imports);
		my %sources;
		@sources{@imports} = map {
			B::svref_2object(\&{"$ns\::$_"})->GV->STASH->NAME;
		} @imports;

		my %does;
		for my $func (keys %sources) {
			my $role = $sources{$func};
			$does{$role} = !!eval { $ns->DOES($role) }
				unless exists $does{$role};
			delete $imports{$func}
				if $does{$role};
		}

		sort keys(%imports);
	};

	my $_diag_dirt = sub
	{
		require B;

		my $ns = shift;
		my @imports = @_;

		my %imports;
		@imports{@imports} = map {
			B::svref_2object(\&{"$ns\::$_"})->GV->STASH->NAME . "::$_";
		} @imports;
		diag explain('remaining imports: ' => \%imports);
	};

	my $_test_or_skip = sub
	{
		my $ns = shift;
		my $rv;
		try {
			my @imports = $ns->$_dirt;
			$rv = ok(!@imports, "${ns} contains no imported functions")
				or $ns->$_diag_dirt(@imports);
		}
		catch {
			SKIP: {
				skip "failed to load $ns: $_", 1;
				fail("failed to load module");
			};
		};
		return $rv;
	};

	sub namespaces_clean
	{
		local $Test::Builder::Level = $Test::Builder::Level + 1;

		# special case a single namespace
		return shift->$_test_or_skip if @_ == 1;

		my @namespaces = @_;
		return &subtest(
			sprintf("namespaces_clean: %s", join q(, ), @namespaces),
			sub {
				$_->$_test_or_skip for @namespaces;
				done_testing;
			},
		);
	}
}

# Release tests...
{
	sub _should_extended_test ()
	{
		$ENV{RELEASE_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{EXTENDED_TESTING};
	}

	sub _wrap
	{
		no strict qw(refs);
		my ($module, $function, %opt) = @_;

		my $code;
		($function, $code) = each(%$function)
			if ref($function) eq q(HASH);

		*$function = sub
		{
			if ($opt{extended} and not _should_extended_test)
			{
				SKIP: {
					skip 'Not running extended tests', 1;
					pass("skipped");
				}
				return 1;
			}

			if (eval "require $module")
			{
				$code ||= \&{"$module\::$function"};
				if ($opt{multi})
				{
					my @args = @_;
					@_ = ($function, sub {
						@_ = @args;
						goto $code;
					});
					goto \&Test::More::subtest;
				}
				else
				{
					goto $code;
				}
			}

			local $Test::Builder::Level = $Test::Builder::Level + 1;
			SKIP: {
				skip "$module only required for release testing", 1
					unless $ENV{RELEASE_TESTING};
				fail("$function");
				diag("$module not installed");
			}
			return;
		};
	}

	my $_VAS = sub
	{
		my ($dir, $name) = @_;
		$dir
			= defined $dir ? $dir
			: -d 'blib'    ? 'blib'
			:                'lib';
		return fail("$dir does not exist, or is not a directory")
			unless -d $dir;

		my @files = File::Find::Rule->perl_module->in($dir);
		$name ||= "all modules in $dir have the same version number";

		local $Test::Builder::Level = $Test::Builder::Level + 1;

		&subtest($name => sub
		{
			my %versions;
			for my $file (@files)
			{
				Test::Version::version_ok($file) or next;
				my $info = Module::Metadata->new_from_file($file);
				my $ver  = $info->version;
				$ver = '(undef)' unless defined $ver;
				push @{$versions{$ver}}, $file;
			}
			my $ok = keys(%versions) < 2;
			ok($ok, "single version number found");
			if (!$ok)
			{
				diag("Files with version $_: @{$versions{$_}}")
					for sort keys(%versions);
			}
			done_testing;
		});
	};

	_wrap("Test::Pod", "pod_file_ok", extended => 1);
	_wrap("Test::Pod", "all_pod_files_ok", extended => 1, multi => 1);
	_wrap("Test::Pod::Coverage", "pod_coverage_ok", extended => 1);
	_wrap("Test::Pod::Coverage", "all_pod_coverage_ok", extended => 1, multi => 1);
	_wrap("Test::Version", "version_ok", extended => 1);
	_wrap("Test::Version", "version_all_ok", extended => 1, multi => 1);
	_wrap("Test::Version", { "version_all_same" => $_VAS }, extended => 1);
}

sub shouldnt_warn (&)
{
	my @warnings = do {
		local $Test::Builder::Level = $Test::Builder::Level + 3;
		&Test::Warnings::warnings(@_);
	};

	my $old = $TODO;
	$TODO = "shouldn't warn block";
	local $Test::Builder::Level = $Test::Builder::Level + 1;
	ok(scalar(@warnings)==0, "no (unexpected) warnings");
	diag("Saw warning: $_") for @warnings;
	$TODO = $old;
}

{
	# When passed a string of code, Benchmark::timethis() evaluates
	# it in the caller package; need to fake that.
	my $_do = sub {
		my $caller = shift;
		my $sub    = shift;
		my $doer   = eval qq[ package $caller; sub { ${sub}(\@_) } ];
		$doer->(@_);
	};

	my $get_res = sub {
		require Benchmark;
		require Scalar::Util;
		my ($caller, $times, $sub) = @_;
		Scalar::Util::blessed($sub) && $sub->isa("Benchmark")
			? $sub
			: $caller->$_do('Benchmark::timethis', $times, $sub, "", "none");
	};

	sub is_fastest
	{
		require Benchmark;

		my $caller = caller;
		my ($which, $times, $marks, $desc) = @_;
		$desc = "$which is fastest" unless defined $desc;

		my @marks;
		while (my ($name, $sub) = each %$marks)
		{
			my $res = $get_res->($caller, $times, $sub);
			my ($r, $pu, $ps, $cu, $cs, $n) = @$res;

			push(@marks, {
				name => $name,
				res  => $res,
				n    => $n,
				s    => ($pu+$ps),
			});
		}

		@marks = sort {$b->{n} * $a->{s} <=> $a->{n} * $b->{s}} @marks;

		my $ok = $marks[0]->{name} eq $which;

		local $Test::Builder::Level = $Test::Builder::Level + 1;

		ok($ok, $desc);
		diag("$which was not the fastest") unless $ok;

		if ($VERBOSE or not $ok)
		{
			foreach my $mark (@marks)
			{
				diag("$mark->{name} - " . Benchmark::timestr($mark->{res}));
			}
		}

		$ok;
	}
}

1;

## no Test::Tabs

__END__