################################################################# # # 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__ =head1 NAME Hook::Filter::Hooker - Wrap subroutines in a firewalling closure =head1 DESCRIPTION This module is used internaly by Hook::Filter to generate an anonymous sub that is wrapped around each filtered subroutine and either forwards the call to the subroutine or block it and spoofs return values (undef or an empty list depending on context). =head1 SYNOPSIS use Hook::Filter::Hooker; my $hooker = new Hook::Filter::Hooker(); $hooker->filter_sub("My::Package"); # mylog is declared in the current package $hooker->filter_sub("mylog"); =head1 INTERFACE C exports no functions by default. But the following functions can be explicitly imported upon using C: =over 4 =item C<< $hooker->filter_sub($subname) >> Add a filter around the subroutine C<$subname>. I<$subname> must either be a fully qualified function name, or the name of a function located in the current package. All calls to C<< $subname >> will thereafter be redirected to a wrapper closure that will evaluate all the rules registered in C using the method C on the pool. If C returns true, the call is forwarded, otherwise it is blocked. =back The following class functions are to be used by modules under C that implement specific test functions for use in filter rules. Any use of these functions in a different context than inside a plugin implementation is guaranteed to return only garbage. See C for a usage example. =over 4 =item C Return the name of the package calling the filtered subroutine. =item C Return the name of the file calling the filtered subroutine. =item C Return the line number at which the filtered subroutine was called. =item C Return the complete name (package+name) of the subroutine calling the filtered subroutine. If the subroutine was called directly from the main namespace, return an empty string. =item C Return the complete name of the filtered subroutine for which the rules are being eval-ed. =item C Return the list of arguments that would be passed to the filtered subroutine. =back =head1 DIAGNOSTICS =over 4 =item C<< $hook->filter_sub(I<$pkg>,I<$func>) >> croaks when passed invalid arguments. =item The closure wrapping all filtered subroutines emits a perl warning when a rule dies upon being eval-ed. =back =head1 BUGS AND LIMITATIONS See Hook::Filter =head1 SEE ALSO See Hook::Filter, Hook::Filter::Rule, Hook::Filter::RulePool, Hook::Filter::Plugins::Library. =head1 VERSION $Id: Hooker.pm,v 1.8 2007/05/24 14:58:09 erwan_lemonnier Exp $ =head1 AUTHOR Erwan Lemonnier C<< >>. =head1 LICENSE See Hook::Filter. =cut