File Coverage

blib/lib/Data/Passphrase.pm

Criterion	Covered	Total	%
statement	34	112	30.3
branch	0	42	0.0
condition	0	12	0.0
subroutine	12	19	63.1
pod	5	7	71.4
total	51	192	26.5

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

use strict;
use warnings;

package Data::Passphrase; {
    use Object::InsideOut qw(Exporter);

    use Readonly;

    Readonly my  $DEFAULT_RULES_FILE => '/etc/passphrase_rules';
    Readonly my  $RULE_ERROR_CODE    => 550;

    # evaluate to passphrase text in string context
    sub as_string :Stringify { $_[0]->get_passphrase() }

    # evaluate to passphrase length in numeric context
    sub as_number :Numerify {
        my ($self) = @_;
        my $passphrase = $self->get_passphrase();
        return defined $passphrase ? length $passphrase : 0;
    }

    use version; our $VERSION = qv('0.0.7');

    use Data::Passphrase::Ruleset;
    use Carp;
    use Fatal qw(open close);
    use HTTP::Status;

    # export procedural subroutine
    BEGIN {
        our @EXPORT_OK = qw(validate_passphrase);
    }

    # object attributes
    my @code       :Field(Std => 'code',                         );
    my @custom     :Field(Std => 'custom',    Type => 'Hash_ref' );
    my @debug      :Field(Std => 'debug',     Type => 'Numeric'  );
    my @message    :Field(Std => 'message'                       );
    my @passphrase :Field(Std => 'passphrase'                    );
    my @ruleset    :Field(Std => 'ruleset',                      );
    my @score      :Field(Std => 'score',     Type => 'Numeric'  );
    my @username   :Field(Std => 'username'                      );

    my %init_args :InitArgs = (
        code       => { Field => \@code, Type => 'Numeric' },
        custom     => { Field => \@custom, Type => 'Hash_ref'},
        debug      => { Def => 0, Field => \@debug, Type => 'Numeric' },
        message    => { Field => \@message },
        passphrase => { Field => \@passphrase },
        ruleset    => { Field => \@ruleset },
        score      => { Field => \@score, Type => 'Numeric' },
        username   => { Field => \@username },
    );

    sub new {
        my ($class, $arg_ref) = @_;

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

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

        # select a default rules file
        my $rules_file;
        if (!exists $arg_ref->{ruleset}) {
            $debug and warn 'autoconstructing ruleset with default file';
            $rules_file = $DEFAULT_RULES_FILE;
        }

        # allow
        elsif (!ref $arg_ref->{ruleset}) {
            $rules_file = $arg_ref->{ruleset};
        }

        # autoconstruct ruleset object
        if ($rules_file) {
            $arg_ref->{ruleset} = Data::Passphrase::Ruleset->new({
                debug => $debug,
                file  => $rules_file,
            });
        }

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

        return $self;
    }

    # access a hash with custom user data for use in rules
    sub get_data {
        my ($self, $name) = @_;
        my $custom_data = $self->get_custom();
        return defined $name ? $custom_data->{$name} : $custom_data;
    }

    # set custom data values
    sub set_data {
        my ($self, $name, $value) = @_;
        my $custom_data = $self->get_custom();
        $custom_data->{$name} = $value;
        $self->set_custom($custom_data);
    }

    # check the passphrase against rules
    sub validate {
        my ($self) = @_;

        # unpack attributes
        my $debug      = $self->get_debug     ();
        my $passphrase = $self->get_passphrase();

        # reset code, message, & score
        $self->set_code   (undef);
        $self->set_message(undef);
        $self->set_score  (0    );

        # declare failure status variables
        my ($first_failure_code, $first_failure_message);

        # collect a score from each rule & remember the lowest
        my @scores = ();
        my $minimum_score;

        # iterate through rules
        my $ruleset       = $self->get_ruleset();
        my $passing_score = $ruleset->get_passing_score();
        my @rules         = @{ $ruleset->get_rules() };
        $debug and warn 'invoking ', scalar @rules, ' rules';
        foreach my $rule (@rules) {

            # unpack rule attributes
            my $code     = $rule->get_code    ();
            my $disabled = $rule->get_disabled();
            my $message  = $rule->get_message ();
            my $validate = $rule->get_validate();

            # skip test-only rules
            next if !defined $validate || $disabled;

            $debug and warn 'invoking rule: ',
                       defined $message ? $message : '[message not available]';

            # call the subroutine of the next rule, passing data hash
            my $score = eval { $validate->($self, $self->get_data()) };

            # catch errors
            if ($@) {
                carp $@;
                $self->set_code   ($RULE_ERROR_CODE);
                $self->set_message('rule error'    );
                return;
            }

            # the lowest score will be the resultant score for the ruleset
            if (!defined $minimum_score || $score < $minimum_score) {
                $minimum_score = $score;
            }

            # handle failure
            if ($score < $passing_score) {

                # let the validate method set these if it wants to
                if ( !defined $self->get_code() ) {
                    $self->set_code($code);
                }
                if ( !defined $self->get_message() ) {
                    $self->set_message($message);
                }

                # the first code & message will be resultant for the ruleset
                $first_failure_code    ||= $code;
                $first_failure_message ||= $message;
            }

            # a score of -1 means short-circuit
            last if $score == -1;
        }

        if (defined $first_failure_code) {
            $self->set_code   ($first_failure_code   );
            $self->set_message($first_failure_message);
        }
        else {
            $self->set_code(RC_OK);
            $self->set_message('acceptable');
        }

        # a passphrase is only as strong as its weakest link?
        $self->set_score( int( $minimum_score * 100 ) );

        return;
    }

=begin WSDL

_IN     request  $Data::Passphrase::Request  request parameters
_RETURN          $Data::Passphrase::Response response parameters
_DOC                                                   validate a passphrase

=end WSDL

=cut

    # procedural interface: given a passphrase and an optional
    # username, validate the passphrase
    sub validate_passphrase {
        my ($class, $arg_ref) = @_;

        # accept class as first argument for use with SOAP::Lite
        if (!defined $arg_ref) {
            $arg_ref = $class;
            $class = __PACKAGE__;
        }

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

        $debug and warn 'validating supplied passphrase';
        my $passphrase_object = $class->new($arg_ref);

        $debug and warn 'calling validate()';
        $passphrase_object->validate(1);

        return {
            code    => $passphrase_object->get_code   (),
            message => $passphrase_object->get_message(),
            score   => $passphrase_object->get_score  (),
        };
    }
}

1;
__END__