File Coverage

lib/Aspect/Hook/LexWrap.pm

Criterion	Covered	Total	%
statement	51	67	76.1
branch	21	48	43.7
condition	5	17	29.4
subroutine	12	16	75.0
pod	0	1	0.0
total	89	149	59.7

package Aspect::Hook::LexWrap;

our $VERSION = '0.20';
use 5.006;
use Carp::Heavy; # added by eilara as hack around caller() core dump
use Carp;

*CORE::GLOBAL::caller = sub {
        my ($height) = ($_[0]||0);
        my $i=1;
        my $name_cache;
        while (1) {
                my @caller = CORE::caller($i++) or return;
                $caller[3] = $name_cache if $name_cache;
                $name_cache = $caller[0] eq 'Aspect::Hook::LexWrap' ? $caller[3] : '';
                next if $name_cache || $height-- != 0;
                return wantarray ? @_ ? @caller : @caller[0..2] : $caller[0];
        }
};

sub import { *{caller()."::wrap"} = \&wrap }

sub wrap (*@) {
	my ($typeglob, %wrapper) = @_;
	$typeglob = (ref $typeglob || $typeglob =~ /::/)
		? $typeglob
		: caller()."::$typeglob";
	my $original = ref $typeglob eq 'CODE' && $typeglob
		     || *$typeglob{CODE}
		     || croak "Can't wrap non-existent subroutine ", $typeglob;
	croak "'$_' value is not a subroutine reference"
		foreach grep {$wrapper{$_} && ref $wrapper{$_} ne 'CODE'}
			qw(pre post);
	no warnings 'redefine';
	my ($caller, $unwrap) = *CORE::GLOBAL::caller{CODE};
	$imposter = sub {
		if ($unwrap) { goto &$original }
		my ($return, $prereturn);
		if (wantarray) {
			$prereturn = $return = [];
			() = $wrapper{pre}->(\@_, $original, $return) if $wrapper{pre};
			if (ref $return eq 'ARRAY' && $return == $prereturn && !@$return) {
				$return = [ &$original(@_) ];
				() = $wrapper{post}->(\@_, $original, $return)
					if $wrapper{post};
			}
			return ref $return eq 'ARRAY' ? @$return : ($return);
		}
		elsif (defined wantarray) {
			$return = bless sub {$prereturn=1}, 'Aspect::Hook::LexWrap::Cleanup';
			my $dummy = $wrapper{pre}->(\@_, $original, $return) if $wrapper{pre};
			unless ($prereturn) {
				$return = &$original(@_);
				$dummy = scalar $wrapper{post}->(\@_, $original, $return)
					if $wrapper{post};
			}
			return $return;
		}
		else {
			$return = bless sub {$prereturn=1}, 'Aspect::Hook::LexWrap::Cleanup';
			$wrapper{pre}->(\@_, $original, $return) if $wrapper{pre};
			unless ($prereturn) {
				&$original(@_);
				$wrapper{post}->(\@_, $original, $return)
					if $wrapper{post};
			}
			return;
		}
	};
	ref $typeglob eq 'CODE' and return defined wantarray
		? $imposter
		: carp "Uselessly wrapped subroutine reference in void context";
	*{$typeglob} = $imposter;
	return unless defined wantarray;
	return bless sub{ $unwrap=1 }, 'Aspect::Hook::LexWrap::Cleanup';
}

package Aspect::Hook::LexWrap::Cleanup;

sub DESTROY { $_[0]->() }
use overload
	q{""}   => sub { undef },
	q{0+}   => sub { undef },
	q{bool} => sub { undef };

1;

__END__