File Coverage

blib/lib/filtered.pm

Criterion	Covered	Total	%
statement	138	143	96.5
branch	58	66	87.8
condition	4	6	66.6
subroutine	17	17	100.0
pod			n/a
total	217	232	93.5

use strict;
use warnings;

my $pkg2file = sub {
	my ($pkg) = shift;
	$pkg =~ s@::@/@g;
	$pkg .= '.pm';
	return $pkg;
};

package filtered; # for Pod::Weaver

# ABSTRACT: Apply source filter on external module
our $VERSION = 'v0.0.7'; # VERSION

package filtered::hook; ## no critic (RequireFilenameMatchesPackage)

our $VERSION = 'v0.0.7'; # VERSION

use File::Path;
use File::Basename;

my %MYINC;

sub new
{
	my ($self, %arg)  = @_;
	my $class = ref($self) || $self;
	return bless  {
		_FILTER => $arg{FILTER},
	}, $class;
}

# NOTE: To store data in object is probably not good idea because this prohibits re-entrance.
sub init
{
	my ($self, $target, $as, $with, $ppi, $prev) = @_;

	$self->{_TARGET} = $target;
	$self->{_AS} = $as;
	$self->{_WITH} = $with;
	$self->{_PPI} = $ppi;
	$self->{_PREV} = $prev;
	return $self;
}

sub _filter_by_ppi
{
	my ($self, $ref) = @_;

	require PPI::Transform::PackageName;
	my $trans = PPI::Transform::PackageName->new(
		-all => sub { s/^$self->{_TARGET}\b/$self->{_AS}/ }
	);
	$trans->apply($ref);
}

sub filtered::hook::INC
{
	my ($self, $filename) = @_;
	if($pkg2file->($self->{_TARGET}) ne $filename) {
		warn "Unexpected loading of $filename against $self->{_TARGET}";
		return;
	}

	$self->{_FILENAME} = $filename;
	shift @INC; # TODO: Gain robustness # NOTE: Just one time application

#print "SELF: $self / FILTER: $self->{_FILTER} / AS: $self->{_AS} / FILENAME: $filename\n";

# NOTE: The following part is based on perldoc -f require
	if (exists $MYINC{$self}{$filename}) {
		# return 1 in original require
		return (sub {
			if($_[1]) {
				delete $INC{$filename};
				$INC{$filename} = $self->{_PREV}[1] if($self->{_PREV}[0]);
				$_ = "1;\n";
				$_[1] = 0;
				return 1;
			} else {
				return 0;
			}
		}, 1) if $MYINC{$self}{$filename};
		die "Compilation failed in require";
	}
	my ($realfilename,$result);
	ITER: {
		foreach my $prefix (@INC) {
			$realfilename = "$prefix/$filename";
			if (-f $realfilename) {
				$MYINC{$self}{$filename} = $realfilename;
				last ITER;
			}
		}
		die "Can't find $filename in \@INC";
	}

	my ($qr1, $qr2);
	open my $fh, '<', $realfilename;
	if(defined $self->{_AS}) {
		if($self->{_PPI}) {
			local $/;
			my $content = <$fh>;
			close $fh;
			undef $fh;
			$self->_filter_by_ppi(\$content);
			open $fh, '<', \$content;
		} else {
			$qr1 = qr/\b(package\s+)$self->{_TARGET}\b/;
			$qr2 = qr/\b$self->{_TARGET}::\b/;
		}
	}
	return (sub {
		my ($sub, $state) = @_;
		if($state == 1) { # Inject filter at the beginning
			delete $INC{$filename};
			$INC{$filename} = $self->{_PREV}[1] if($self->{_PREV}[0]);
			$_ = 'use '.$self->{_FILTER};
			if(defined $self->{_WITH}) {
				$_ .= ' '.$self->{_WITH};
			}
			if(exists $ENV{FILTERED_ROOT}) {
				if(eval { require Filter::tee; }) {
					my $asfile;
					if(defined($self->{_AS})) {
						$asfile = $self->{_AS};
						$asfile =~ s@::@/@g;
						$asfile .= '.pm';
					} else {
						$asfile = $filename;
					}
					my $dir = dirname($ENV{FILTERED_ROOT}.'/'.$asfile);
					File::Path::make_path($dir) if ! -d $dir;
					$_ .= "; use Filter::tee '".$ENV{FILTERED_ROOT}.'/'.$asfile."'";
				} else {
					warn 'Ignore environment variable FILTERED_ROOT because Filter::tee is not available';
				}
			}
			$_ .= ";\n";
			$_[1] = 0;
		} elsif(eof($fh)) {
			close $fh;
			return 0;
		} elsif(defined $self->{_AS} && ! $self->{_PPI}) {
			$_ = <$fh>;
			s {$qr1} {${1}$self->{_AS}};
			s {$qr2} {$self->{_AS}::};
		} else {
			$_ = <$fh>;
		}
		return 1;
	}, 1);
}

package filtered;


use Carp;

my %hook;
my $USE_PPI;
BEGIN { $USE_PPI = eval { require PPI; }; }

sub import
{
	my ($class, @args) = @_;
	my ($filter, $target, $as, $with);
	my $ppi = $USE_PPI;
	while(1) {
		last unless @args;
		if($args[0] eq 'by') {
			shift @args;
			$filter = shift @args;
		} elsif($args[0] eq 'as') {
			shift @args;
			$as = shift @args;
		} elsif($args[0] eq 'with') {
			shift @args;
			$with = shift @args;
		} elsif($args[0] eq 'use_ppi') {
			shift @args;
			$ppi = shift @args;
		} elsif($args[0] eq 'on') {
			shift @args;
			$target = shift @args;
		} else {
			$target = shift @args unless defined $target;
			last;
		}
	}

	croak '`by\' must be specified' if ! defined($filter);
	croak '`on\' or target name must be specified' if ! defined($target);
	$hook{$filter} = filtered::hook->new(FILTER => $filter) if ! exists $hook{$filter};
	my $prev = [exists($INC{$pkg2file->($target)}), (exists($INC{$pkg2file->($target)}) ? $INC{$pkg2file->($target)} : '')];
	unshift @INC, $hook{$filter}->init($target, $as, $with, $ppi, $prev);
	delete $INC{$pkg2file->($target)};
	if(!defined eval "require $target") {
		delete $INC{$hook{$filter}{_FILENAME}}; # For error in internal require;
		$INC{$hook{$filter}{_FILENAME}} = $prev->[1] if $prev->[0];
		croak "Can't load $target by $@";
	}
	if(defined $as) {
		@_ = ($as, @args);
	} else {
		@_ = ($target, @args);
	}
	{
		no strict 'refs'; ## no critic (ProhibitNoStrict)
		no warnings 'once';
		my $import = $_[0]->can('import');
		if(defined $import) {
			goto &$import;
		} elsif ($_[0]->isa('Exporter')) {
			$_[0]->export_to_level(1, @_);
		}
	}
}

1;

__END__