Hook::Filter::RulePool - A pool of filter rules

Hook-Filter documentation Contained in the Hook-Filter distribution.

Index

Code Index:

NAME

Top

Hook::Filter::RulePool - A pool of filter rules

SYNOPSIS

Top

    use Hook::Filter::RulePool qw(get_rule_pool);

    my $pool = get_rule_pool();

    # add a rule that is always true
    $pool->add_rule("1");

    # add a more complex rule
    $pool->add_rule("arg(0) =~ /bob/ && from =~ /my_module/");

    if ($pool->eval_rules) {
        # call is allowed
    }

    foreach my $rule ($pool->get_rules) {
        print "pool has rule [$rule]\n";
    }

    $pool->flush_rules;

DESCRIPTION

Top

Hook::Filter::RulePool contains all the filtering rules that should be eval-ed each time a filtered subroutine is called.

Using Hook::Filter::RulePool, you can modify the filtering rules at runtime. You can flush all rules or inject new ones.

INTERFACE

Top

my $pool = get_rule_pool();

Return the pool containing all known filtering rules. get_rule_pool is not exported by default so you have to import it explicitly:

    use Hook::Filter::RulePool qw(get_rule_pool);
$pool->eval_rules()

Evaluate all the rules in the pool. If one evaluates to true, return true. If one of them dies/croaks/confesses, return true. If none evaluates to true, return false. If the pool contained no rules, return true.

$pool->add_rule($rule)

Add the rule $rule to the pool and return $pool. $rule must be an instance of Hook::Filter::Rule, or a string representing valid perl code that evaluates to either true or false.

$pool->flush_rules()

Remove all rules from the pool and return $pool. All filtered calls will then be allowed by default since the pool is empty.

$pool->get_rules()

Return a list of all the rules registered in the pool, as instances of Hook::Filter::Rule.

new()

Hook::Filter::RulePool implements the singleton pattern. Therefore, do not use new() to instantiate a rule pool, use get_rule_pool instead.

DIAGNOSTICS

Top

$pool->add_rule() croaks if its argument is not an instance of Hook::Filter::Rule or a string.
new() always croaks. Use get_rule_pool instead.

SEE ALSO

Top

See Hook::Filter, Hook::Filter::Rule, Hook::Filter::Hooker, Hook::Filter::Plugins::Library.

VERSION

Top

$Id: RulePool.pm,v 1.3 2007/05/23 08:26:15 erwan_lemonnier Exp $

AUTHOR

Top

Erwan Lemonnier <erwan@cpan.org>

LICENSE

Top

See Hook::Filter.

Hook-Filter documentation Contained in the Hook-Filter distribution. 
#################################################################
#
#   Hook::Filter::RulePool - A pool of filter rules
#
#   $Id: RulePool.pm,v 1.3 2007/05/23 08:26:15 erwan_lemonnier Exp $
#
#   070516 erwan Started
#   070522 erwan flush_rules returns self
#

package Hook::Filter::RulePool;

use strict;
use warnings;
use Carp qw(croak);
use Data::Dumper;
use Hook::Filter::Rule;

use base qw(Exporter);

our @EXPORT = ();
our @EXPORT_OK = ('get_rule_pool');


# the filter rules
my @rules;

#---------------------------------------------------------------
#
#   A singleton pattern with lazy initialization and embedded constructor
#

my $pool;

sub get_rule_pool {
    if (!defined $pool) {
	$pool = bless({},__PACKAGE__);
    }
    return $pool;
}

# make sure no one calls the constructor
sub new {
    croak "use get_pool() instead of new()";
}

#----------------------------------------------------------------
#
#   add_rule - add a rule to the pool
#

sub add_rule {
    my ($self,$obj) = @_;

    if (!defined $obj || (ref $obj ne "Hook::Filter::Rule" && ref \$obj ne "SCALAR") || scalar @_ != 2) {
	shift @_;
	croak "invalid parameters: Hook::Filter::RulePool->add_rule expects an instance of Hook::Filter::Rule or a rule string, and not [".Dumper(@_)."]";
    }

    if (ref \$obj eq "SCALAR") {
	# $obj is just a string containing a rule in text form
	my $rule = new Hook::Filter::Rule($obj);

	my ($pkg,$line) = (caller(0))[0,2];
	my $fnc = (caller(1))[3] || "main";
	$rule->source("added by ".$pkg."::".$fnc.", l.$line");

	push @rules, $rule;
    } else {
	# $obj is an instance of Hook::Filter::Rule
	push @rules, $obj;
    }

    return $self;
}

#----------------------------------------------------------------
#
#   flush_rules - remove all rules
#

sub flush_rules {
    @rules = ();
    return $_[0];
}

#----------------------------------------------------------------
#
#   get_rules - return all registered rules
#

sub get_rules {
    return @rules;
}

#----------------------------------------------------------------
#
#   eval_rules - eval all rules and return true if one is true or none is registered (fail safe)
#

sub eval_rules {
    my $self = shift;

    # if no rules are registered, default to true (allow call)
    return 1 if (!@rules);

    # evaluate all rules, until one is found to be true or all are found to be false
    foreach my $rule (@rules) {
	return 1 if ($rule->eval());
    }

    return 0;
}

1;

__END__