File Coverage

blib/lib/Data/Passphrase/Ruleset.pm

Criterion	Covered	Total	%
statement	15	59	25.4
branch	0	34	0.0
condition	0	14	0.0
subroutine	5	10	50.0
pod	2	5	40.0
total	22	122	18.0

# $Id: Ruleset.pm,v 1.6 2007/08/14 15:45:51 ajk Exp $

use strict;
use warnings;

package Data::Passphrase::Ruleset; {
    use Object::InsideOut;

    use Data::Passphrase::Rule;
    use Carp;

    # object attributes
    my @debug         :Field( Std => 'debug',         Type => 'Numeric'  );
    my @file          :Field( Get => 'get_file',                         );
    my @passing_score :Field( Std => 'passing_score', Type => 'Numeric'  );
    my @rules         :Field( Get => 'get_rules',                        );

    my %init_args :InitArgs = (
        debug => {
            Def   => 0,
            Field => \@debug,
            Type  => 'Numeric',
        },
        file => {
            Field => \@file,
            Pre   => \&preprocess,
        },
        passing_score => {
            Def   => 0.6,
            Field => \@passing_score,
            Type  => 'Numeric',
        },
        rules => {
            Field => \@rules,
            Pre   => \&preprocess,
            Type  => 'Array_ref',
        },
    );

    sub preprocess {
        my ($class, $name, $init_ref, $self, $value) = @_;

        # file & rules attributes are mutually exclusive
        if (defined $value) {
            croak 'file & rules cannot be supplied simultaneously'
                if $name eq 'file'  && defined $self->get_rules()
                || $name eq 'rules' && defined $self->get_file ();
        }

        return $value;
    }
    # overload constructor so we can automatically load the rules file
    sub new {
        my ($class, $arg_ref) = @_;

        # unpack arguments
        my $debug = $arg_ref->{debug};

        $debug and warn 'initializing ', __PACKAGE__, ' object';

        # construct object
        my $self = $class->Object::InsideOut::new($arg_ref);

        # load rules from file
        if (exists $arg_ref->{file}) {
            $self->load();
        }

        return $self;
    }

    # cache rulesets by filename
    my %Rules_Cache;

    # load the rules file if we need to
    sub load {
        my ($self) = @_;

        # unpack arguments
        my $debug = $self->get_debug();
        my $file  = $self->get_file () or croak 'file attribute undefined';

        $debug and warn "$file: checking readability";
        my $last_modified = 0;
        if (-r $file) {

            # point the object attribute at the current ruleset
            $Rules_Cache{$file}{rules} ||= [];
            $self->set(\@rules, $Rules_Cache{$file}{rules});

            # don't re-read if file hasn't been modified since last time
            $last_modified = (stat _)[9];
            $debug and warn "$file: pid: $$, mod time: $last_modified, ",
                "last processed: ", $Rules_Cache{$file}{last_read};
            return if exists $Rules_Cache{$file}{last_read}
                          && $Rules_Cache{$file}{last_read} == $last_modified;

            # read the configuration file
            $debug and warn "$file: processing";
            my $rule_list = do $file;
            if (ref $rule_list ne 'ARRAY') {
                croak "$file: parse error: $@" if $@;
                croak "$file: $!"              if $!;
                croak "$file: must return a reference to an array of rules";
            }

            push @{ $Rules_Cache{$file}{rules} }, map {
                ref eq 'HASH'
                    ? Data::Passphrase::Rule->new(
                        { %$_, debug => $debug }
                      )
                    : $_
                    ;
            } @$rule_list;
        }

        # limp along if the file went away, unless this is the first run
        else {
            warn "$file: $!";
            die if !exists $Rules_Cache{$file}{last_read};
        }

        # cache the timestamp for comparison in later calls
        $Rules_Cache{$file}{last_read} = $last_modified;
    }

    # load the file after setting the file attribute
    sub set_file {
        my ($self, $value) = @_;
        my $return_value = $self->set(\@file, $value);
        if (defined $value) {
            $self->load();
        }
        return $return_value;
    }

    # clear file attribute if rules are loaded directly
    sub set_rules {
        my ($self, $value) = @_;

        # check type
        croak 'rules attribute may only be set to an array reference'
            if ref $value ne 'ARRAY';

        my $return_value = $self->set(\@rules, $value);
        $self->set_file();

        return $return_value;
    }
}

1;
__END__