File Coverage

blib/lib/Hook/Filter.pm

Criterion	Covered	Total	%
statement	66	66	100.0
branch	27	28	96.4
condition	3	3	100.0
subroutine	14	14	100.0
pod			n/a
total	110	111	99.1

#################################################################
#
#   Hook::Filter - A runtime filtering layer on top of subroutine calls
#
#   $Id: Filter.pm,v 1.12 2008/08/26 08:13:30 erwan_lemonnier Exp $
#
#   051105 erwan Created
#   060301 erwan Recreated
#   070516 erwan Updated POD and license, added flush_rules and add_rule
#   070522 erwan More POD + don't use rule file unless 'rules' specified in import
#   070523 erwan Can use 'rules' multiple time if same rule file specified
#   070523 erwan POD updates
#   070524 erwan Import parameter 'hook' is now mandatory
#

package Hook::Filter;

use 5.006;
use strict;
use warnings;
use Carp qw(confess croak);
use File::Spec;
use Hook::Filter::Rule;
use Hook::Filter::RulePool qw(get_rule_pool);
use Hook::Filter::Hooker qw(filter_sub);
use base qw(Exporter);
use Data::Dumper;

our @EXPORT = qw();

our $VERSION = '0.10';

#----------------------------------------------------------------
#
#   Global vars
#
#----------------------------------------------------------------

# the rule file actually used by Hook::Filter, and as declared with parameter 'rules'
my $RULES_FILE;

# list of subs to hijack
my %HOOK_SUBS;

sub _queue_sub {
    my ($pkg,$name) = @_;
    ($name =~ /::/) ? $HOOK_SUBS{$name}=1 : $HOOK_SUBS{$pkg."::".$name}=1;
}

#----------------------------------------------------------------
#
#   import - verify import parameters, filter the subs and load the rule file
#

sub import {
    my($class,%args) = @_;
    my $pkg = caller(0);

    #
    # check parameter 'rules', indicating path to the rule file
    #

    if (exists $args{rules}) {

	croak "import parameter 'rules' for Hook::Filter should be a string, but was undef."
	    if (!defined $args{rules});

	croak "import parameter 'rules' for Hook::Filter should be a string, but was [".Dumper($args{rules})."]."
	    if (ref \$args{rules} ne 'SCALAR');

	croak "you tried to specify 2 different Hook::Filter rule file: [$RULES_FILE] and [".$args{rules}."]. you may have only 1 rule file."
	    if (defined $RULES_FILE && $RULES_FILE ne $args{rules});

	$RULES_FILE = $args{rules};
	delete $args{rules};

	#
	# load the rule file, if any
	#

	my $pool = get_rule_pool();

	if (-f $RULES_FILE) {
	    # TODO: support runtime monitoring of rules file and update of rules upon changes in file

	    open(IN,"$RULES_FILE")
		or confess "failed to open Hook::Filter rules file [$RULES_FILE]: $!";
	    while (my $line = ) {
		chomp $line;
		next if ($line =~ /^\s*\#/);
		next if ($line =~ /^\s*$/);

		my $rule = new Hook::Filter::Rule($line);
		$rule->source($RULES_FILE);
		$pool->add_rule($rule);
	    }
	    close(IN);
	}
    }

    #
    # check parameter 'hook', indicating which subroutines to filter
    #

    croak "you must call Hook::Filter with the import parameter 'hook' set to something"
	if (!exists $args{hook});

    croak "Invalid parameter: 'hook' should be a string or an array of strings, but was undef."
	if (!defined $args{hook});

    if (ref $args{hook} eq 'ARRAY') {
	foreach my $name (@{$args{hook}}) {
	    if (ref \$name ne 'SCALAR') {
		croak "Invalid parameter: 'hook' for Hook::Filter should be a string or an array of strings, but was [".Dumper($args{hook})."].";
	    }
	    _queue_sub($pkg,$name);
	}
    } elsif (ref \$args{hook} eq 'SCALAR') {
	_queue_sub($pkg,$args{hook});
    } else {
	croak "Invalid parameter: 'hook' for Hook::Filter should be a string or an array of strings, but was [".Dumper($args{hook})."].";
    }

    delete $args{hook};

    # propagate super class's import
    $class->export_to_level(1,undef,());
}

#
# when all is compiled, do filter all the subs
#

sub _filter_subs {
    map { filter_sub($_) } keys %HOOK_SUBS;
}

# this init block won't be executed if Hook::Filter is used from an eval/require
INIT {
    # add a filtering closure around each sub
    _filter_subs;
}

1;

__END__