File Coverage

blib/lib/Hook/Filter/Hooker.pm

Criterion	Covered	Total	%
statement	66	66	100.0
branch	12	12	100.0
condition	7	7	100.0
subroutine	18	18	100.0
pod	7	7	100.0
total	110	110	100.0

#################################################################
#
#   Hook::Filter::Hooker - Wrap subroutines in a firewalling closure
#
#   $Id: Hooker.pm,v 1.8 2007/05/24 14:58:09 erwan_lemonnier Exp $
#
#   060302 erwan Created
#   070516 erwan Use the rule pool
#

package Hook::Filter::Hooker;

use strict;
use warnings;
use Carp qw(croak);
use Data::Dumper;
use Symbol;
use base qw(Exporter);
use Hook::Filter::RulePool qw(get_rule_pool);

our @EXPORT = qw();
our @EXPORT_OK = qw( get_caller_package
		     get_caller_file
		     get_caller_line
		     get_caller_subname
		     get_subname
		     get_arguments
		     filter_sub
		     );



use vars qw( $CALLER_PACKAGE
	     $CALLER_FILE
	     $CALLER_LINE
	     $CALLER_SUBNAME
	     $SUBNAME
	     @ARGUMENTS );

# singleton instance of Hook::Filter::RulePool
my $pool = get_rule_pool();

# a hash whose keys are the fully qualified names of all filtered
# subroutines, to avoid filtering one twice
my %subs;

#----------------------------------------------------------------
#
#   accessors for use in Hook::Filter::Plugins:: modules
#

sub get_caller_package   { return $CALLER_PACKAGE; };
sub get_caller_file      { return $CALLER_FILE;    };
sub get_caller_line      { return $CALLER_LINE;    };
sub get_caller_subname   { return $CALLER_SUBNAME; };
sub get_subname          { return $SUBNAME;        };
sub get_arguments        { return @ARGUMENTS;      };

#----------------------------------------------------------------
#
#   filter_sub - build a filter closure wrapping calls to the provided sub
#

sub filter_sub {
    my $subname = shift;

    if (!defined $subname || ref \$subname ne "SCALAR" || scalar @_) {
	shift @_;
	croak "invalid parameter: Hook::Filter::Hooker->filter_sub expects a subroutine name, but got [".Dumper($subname,@_)."].";
    }

    if ($subname !~ /^(.+)::([^:]+)$/) {
	croak "invalid parameter: [$subname] is not a valid subroutine name (must include package name).";
    }

    my ($pkg,$func) = ($1,$2);

    # check whether subroutine is already filtered, and skip if so
    return if (exists $subs{$subname});

    my $filtered_func = *{ qualify_to_ref($func,$pkg) }{CODE};

    # create the closure that will replace $func in package $pkg
    my $filter = sub {
	my (@args) = @_;

	# TODO: looking at source for Hook::WrapSub, it might be a good idea to copy/paste some of its code here, to build a valid caller stack
	# TODO: look at Hook::LexWrap and fix so that caller() work in subroutines

	# set global variables
	$CALLER_PACKAGE  = (caller(0))[0];
	$CALLER_FILE     = (caller(0))[1];
	$CALLER_LINE     = (caller(0))[2];
	$CALLER_SUBNAME  = (caller(1))[3] || "";
	$SUBNAME         = $subname;
	@ARGUMENTS       = @args;

	# evaluate all rules. if true is returned, forward the call
	if ($pool->eval_rules) {
	    if (wantarray) {
		my @results = $filtered_func->(@args);
		return @results;
	    } else {
		my $result = $filtered_func->(@args);
		return $result;
	    }
	}

	# the call was blocked. fake a return value (ugly.)
	if (wantarray) {
	    return ();
	}
	return;
    };

    # keep track of already hooked subroutines
    $subs{$subname} = 1;

    # replace $package::$func with our closure
    no strict 'refs';
    no warnings;

    *{ qualify_to_ref($func,$pkg) } = $filter;
}

1;

__END__