File Coverage

blib/lib/Test/Load/Helper.pm

Criterion	Covered	Total	%
statement	70	72	97.2
branch	22	26	84.6
condition	5	6	83.3
subroutine	15	15	100.0
pod	0	5	0.0
total	112	124	90.3

use v5.14;
use warnings;

package Test::Load::Helper v1.0.0 {

	use Carp qw (croak);
	use Path::Tiny qw ();

	our $DEFAULT_FILENAME = q (test-helper.pl);

	sub eval_helper {
		my ($class, %args) = @_;

		my $key = $class->inc_key (%args);

		return 1
			if exists $INC{$key}
			;

		my $file = $args{file};
		my $code = $file->slurp_utf8;

		{
			no strict q (refs);
			eval <<"END_OF_EVAL";
package $args{into};
use strict;
use warnings;
#line 1 "$file"
$code;
1;
END_OF_EVAL
		}

		croak qq (Test::Load::Helper: Error compiling '$file': $@)
			if $@
			;

		$INC{$key} = "$file";
		return 1;
	}

	sub identify_caller_file {
		my ($class, %args) = @_;

		my $level = 0;
		while (my @info = caller ($level++)) {
			my $file = $info[1];
			next if $file eq __FILE__;
			return Path::Tiny::->new ($file)
				if -f $file
				;
		}

		return path ('.');
	}

	sub identify_caller_package {
		my ($class, %args) = @_;

		return $args{into}
			if exists $args{into}
			;

		my $level = 0;
		while (my @info = caller ($level++)) {
			my $package = $info[0];
			next if $package eq __PACKAGE__;
			return $package;
		}

		return q (main);
	}

	sub identify_helper_file {
		my ($class, %args) = @_;
		my $file = $args{file} // $DEFAULT_FILENAME;

		my $caller_file = exists $args{caller_file}
			? Path::Tiny::->new ($args{caller_file})
			: $class->identify_caller_file (%args)
			;

		my $caller_dir  = $caller_file->parent->absolute;

		my $root = $ENV{TEST_LOAD_ROOT}
			? Path::Tiny::->new ($ENV{TEST_LOAD_ROOT})->absolute
			: Path::Tiny::->new (q (/))
			;

		while (1) {
			my $candidate = $caller_dir->child ($file);

			return $candidate
				if $candidate ne $caller_file
				&& $candidate->exists
				;

			last
				if $caller_dir eq $root
				;

			my $parent = $caller_dir->parent;

			last
				if $parent eq $caller_dir
				;

			$caller_dir = $parent;
		}

		return;
	}

	sub import {
		my ($class, %args) = @_;

		return
			unless my $caller_package = $class->identify_caller_package (%args)
			;

		return 1
			unless my $helper_file = $class->identify_helper_file (%args)
			;

		$class->eval_helper (
			into => $caller_package,
			file => $helper_file,
		);
	}

	sub inc_key {
		my ($class, %args) = @_;

		my $into = $args{into};
		my $file = $args{file};

		# File can be loaded into multiple target packages
		qq (${file}{${into}});
	}

	1;
}

__END__