File Coverage

blib/lib/Authen/Credential.pm

Criterion	Covered	Total	%
statement	78	85	91.7
branch	26	38	68.4
condition	7	15	46.6
subroutine	14	15	93.3
pod	6	6	100.0
total	131	159	82.3

#+##############################################################################
#                                                                              #
# File: Authen/Credential.pm                                                   #
#                                                                              #
# Description: abstraction of a credential                                     #
#                                                                              #
#-##############################################################################

#
# module definition
#

package Authen::Credential;
use strict;
use warnings;
our $VERSION  = "1.2";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use No::Worries::Die qw(dief);
use Params::Validate qw(validate_with validate_pos :types);
use URI::Escape qw(uri_escape uri_unescape);

#
# global variables
#

our(
    $_IdRe,           # regexp matching an identifier
    $_ValChars,       # set of all allowed value characters
    $_SepChars,       # set of all allowed separator characters
    %_LoadedModule,   # hash of successfully loaded modules
    %ValidationSpec,  # per-scheme Params::Validate specification
    %Preparator,      # per-scheme and target preparator code
);

$_IdRe = qr{[a-z][a-z0-9]*};
$_ValChars = q{a-zA-Z0-9/\-\+\_\~\.\:};
$_SepChars = q{\,\ };

#+++############################################################################
#                                                                              #
# helper functions                                                             #
#                                                                              #
#---############################################################################

#
# make sure a module is loaded
#

sub _require ($) {
    my($module) = @_;

    return if $_LoadedModule{$module};
    eval("require $module"); ## no critic 'ProhibitStringyEval'
    if ($@) {
        $@ =~ s/\s+at\s.+?\sline\s+\d+\.?$//;
        dief("failed to load %s: %s", $module, $@);
    } else {
        $_LoadedModule{$module} = 1;
    }
}

#
# check that the data matches the per-scheme specification
#

sub _check ($@) {
    my($scheme);

    $scheme = shift(@_);
    dief("invalid credential scheme (missing validation spec): %s", $scheme)
        unless $ValidationSpec{$scheme};
    return(validate_with(
        params => \@_,
        spec => {
            %{ $ValidationSpec{$scheme} },
            scheme => {
                type    => SCALAR,
                regex   => qr/^\Q$scheme\E$/,
                default => $scheme,
            },
        },
        stack_skip => 2,
    ));
}

#+++############################################################################
#                                                                              #
# object oriented interface                                                    #
#                                                                              #
#---############################################################################

#
# constructors
#

sub new : method {
    my($class, %option, $cc, $scheme);

    $class = shift(@_);
    if ($class eq __PACKAGE__) {
        # toplevel constructor
        %option = validate_with(
            params => \@_,
            spec => {
                scheme => {
                    type    => SCALAR,
                    regex   => $_IdRe,
                    default => "none",
                },
            },
            allow_extra => 1,
        );
        $cc = $class . "::" . $option{scheme};
        _require($cc);
        return($cc->new(\%option));
    }
    # inherited constructor
    $scheme = substr($class, length(__PACKAGE__) + 2);
    return(bless({ _check($scheme, @_) }, $class));
}

sub parse : method {
    my($class, $string, @list, %option);

    $class = shift(@_);
    validate_pos(@_, { type => SCALAR })
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "";
    $string = shift(@_);
    return($class->new()) if $string eq "";
    dief("invalid credential string: %s", $string)
        unless $string =~ /^[${_ValChars}${_SepChars}\%\=]+$/o;
    @list = split(/[${_SepChars}]+/o, $string);
    dief("invalid credential string: %s", $string)
        unless @list and $list[0] =~ /^($_IdRe)$/o;
    %option = (scheme => shift(@list));
    foreach my $kv (@list) {
        if ($kv =~ /^($_IdRe)\=([$_ValChars\%]*)$/o) {
            dief("duplicate credential key: %s", $1)
                if exists($option{$1});
            $option{$1} = uri_unescape($2);
        } else {
            dief("invalid credential key=value: %s", $kv);
        }
    }
    return($class->new(\%option));
}

#
# transformers
#

sub hash : method {
    my($self);

    $self = shift(@_);
    validate_pos(@_) if @_;
    return($self) unless wantarray();
    return(%{ $self });
}

sub string : method {
    my($self, @parts);

    $self = shift(@_);
    validate_pos(@_) if @_;
    dief("invalid credential: no scheme") unless $self->{scheme};
    @parts = ($self->{scheme});
    foreach my $key (sort(keys(%{ $self }))) {
        next if $key eq "scheme";
        push(@parts, $key . "=" . uri_escape($self->{$key}, "^$_ValChars"));
    }
    return(join(" ", @parts));
}

#
# accessors
#

foreach my $name (qw(scheme)) {
    no strict "refs";
    *{ $name } = sub {
        my($self);
        $self = shift(@_);
        validate_pos(@_) if @_;
        return($self->{$name});
    };
}

#
# generic check method using the Params::Validate specification
#

sub check : method {
    my($self);

    $self = shift(@_);
    validate_pos(@_) if @_;
    return(_check($self->scheme(), $self));
}

#
# generic prepare method using the declared preparators
#

sub prepare : method {
    my($self, $target, $preparator);

    $self = shift(@_);
    validate_pos(@_, { type => SCALAR })
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "";
    $target = shift(@_);
    $preparator = $Preparator{$self->scheme()}{$target};
    return($preparator->($self)) if $preparator;
    dief("invalid %s credential preparation target: %s",
         $self->scheme(), $target);
}

1;

__DATA__