File Coverage

blib/lib/Catalyst/Authentication/User/Hash.pm

Criterion	Covered	Total	%
statement	33	42	78.5
branch	14	20	70.0
condition	4	6	66.6
subroutine	7	11	63.6
pod	6	6	100.0
total	64	85	75.2

package Catalyst::Authentication::User::Hash;

use strict;
use warnings;

use base qw/Catalyst::Authentication::User/;

sub new {
    my $class = shift;

    bless { ( @_ > 1 ) ? @_ : %{ $_[0] } }, $class;
}

sub AUTOLOAD {
    my $self = shift;
    ( my $key ) = ( our $AUTOLOAD =~ m/([^:]*)$/ );

    $self->_accessor( $key, @_ );
}

# this class effectively handles any method calls
sub can { 1 }

sub id {
    my $self = shift;
    $self->_accessor( "id", @_ );
}

## deprecated. Let the base class handle this.
#    sub store {
#        my $self = shift;
#        $self->_accessor( "store", @_ ) || ref $self;
#    }

sub _accessor {
    my $self = shift;
    my $key  = shift;

    if (@_) {
        my $arr = $self->{__hash_obj_key_is_array}{$key} = @_ > 1;
        $self->{$key} = $arr ? [@_] : shift;
    }

    my $data = $self->{$key};
    ( $self->{__hash_obj_key_is_array}{$key} || $key =~ /roles/ )
      ? @{ $data || [] }
      : $data;
}

## password portion of this is no longer necessary, but here for backwards compatibility.
my %features = (
    password => {
        clear      => ["password"],
        crypted    => ["crypted_password"],
        hashed     => [qw/hashed_password hash_algorithm/],
        self_check => undef,
    },
    roles   => ["roles"],
    session => 1,
);

sub supports {
    my ( $self, @spec ) = @_;

    my $cursor = \%features;

    return 1 if @spec == 1 and exists $self->{ $spec[0] };

    # traverse the feature list,
    for (@spec) {
        return if ref($cursor) ne "HASH";
        $cursor = $cursor->{$_};
    }

    if ( ref $cursor ) {
        die "bad feature spec: @spec" unless ref $cursor eq "ARRAY";

        # check that all the keys required for a feature are in here
        foreach my $key (@$cursor) {
            return undef unless exists $self->{$key};
        }

        return 1;
    }
    else {
        return $cursor;
    }
}

sub for_session {
    my $self = shift;

    return $self; # we serialize the whole user
}

sub from_session {
    my ( $self, $c, $user ) = @_;
    $user;
}

__PACKAGE__;

__END__

=pod

=head1 NAME

Catalyst::Authentication::User::Hash - An easy authentication user
object based on hashes.

=head1 SYNOPSIS

    use Catalyst::Authentication::User::Hash;

    Catalyst::Authentication::User::Hash->new(
        password => "s3cr3t",
    );

=head1 DESCRIPTION

This implementation of authentication user handles is supposed to go hand in
hand with L<Catalyst::Authentication::Store::Minimal>.

=head1 METHODS

=head2 new( @pairs )

Create a new object with the key-value-pairs listed in the arg list.

=head2 supports( )

Checks for existence of keys that correspond with features.

=head2 for_session( )

Just returns $self, expecting it to be serializable.

=head2 from_session( )

Just passes returns the unserialized object, hoping it's intact.

=head2 AUTOLOAD( )

Accessor for the key whose name is the method.

=head2 store( )

Accessors that override superclass's dying virtual methods.

=head2 id( )

=head2 can( )

=head1 SEE ALSO

L<Hash::AsObject>

=cut