File Coverage

blib/lib/Acme/RunDoc.pm

Criterion	Covered	Total	%
statement	58	67	86.5
branch	6	22	27.2
condition	0	3	0.0
subroutine	17	17	100.0
pod	4	4	100.0
total	85	113	75.2

package Acme::RunDoc;

use strict;
use autodie;

BEGIN {
	$Acme::RunDoc::AUTHORITY = 'cpan:TOBYINK';
	$Acme::RunDoc::VERSION   = '0.002';
}

# 'undef' is Text::Extract::Word's default filter, and probably the only
# one that makes sense.
use constant FILTER => undef;

use Carp qw//;
use Data::Dumper qw//;
use File::Spec;
use IO::File;
use Text::Extract::Word;
use Module::Runtime qw//;

sub do
{
	my ($class, $file) = _args(@_);
	my $text = Text::Extract::Word->new($file)->get_body(FILTER)
		or CORE::do { $! = 'cannot read file'; return undef };
	return CORE::eval($text);
}

sub require_file
{
	my ($class, $file) = _args(@_);
	my $fh = IO::File->new($file, 'r')
		or Carp::croak("Could not require file $file: $!");
	$class->do($fh) or Carp::croak("Could not require file $file: $@");
}

sub require
{
	my ($class, $module) = _args(@_);
	(my $filename = Module::Runtime::module_notional_filename($module))
		=~ s{ \.pm $ }{ '.docm' }ex;
	my ($file) =
		grep { -e $_ }
		map { File::Spec->catfile($_, $filename) }
		@INC;
	Carp::croak("Could not find $filename in \@INC: ".join q{ }, @INC)
		unless defined $file;
	$class->require_file($file);
}

sub use
{
	my ($class, $module, @args) = _args(@_);
	$class->require($module);

	{
		my $import = $module->can('import');
		@_ = ($module, @args);
		goto $import if $import;
	}
}

sub import
{
	my ($class, @args) = _args(@_);
	my $caller = scalar caller;
	local $Data::Dumper::Indent = 0;
	while (@args)
	{
		my $module = shift @args;
		my $args   = ref $args[0] ? shift @args : undef;
		my $eval = sprintf(
			"{ package %s; my \@args = %s; Acme::RunDoc->use('%s', \@args); }",
			$caller,
			ref $args eq 'HASH'
				? sprintf('do { my %s; %%$VAR1 }', Data::Dumper::Dumper($args))
				: ref $args
				? sprintf('do { my %s; @$VAR1 }',  Data::Dumper::Dumper($args))
				: '()',
			$module,
			);
		eval "$eval; 1" or Carp::croak($@);
	}
}

sub _args
{
	my (@args) = @_;
	return @args if $args[0] eq __PACKAGE__;
	return @args if UNIVERSAL::can($args[0] => 'isa')
	             && $args[0]->isa(__PACKAGE__);
	unshift @args, __PACKAGE__;
	return @args;
}

__FILE__
__END__