lib/Catalyst/Authentication/User/Hash.pm

   1 package Catalyst::Authentication::User::Hash;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/Catalyst::Authentication::User/;
   7
   8 sub new {
   9     my $class = shift;
  10
  11     bless { ( @_ > 1 ) ? @_ : %{ $_[0] } }, $class;
  12 }
  13
  14 sub AUTOLOAD {
  15     my $self = shift;
  16     ( my $key ) = ( our $AUTOLOAD =~ m/([^:]*)$/ );
  17
  18     $self->_accessor( $key, @_ );
  19 }
  20
  21 # this class effectively handles any method calls
  22 sub can { 1 }
  23
  24 sub id {
  25     my $self = shift;
  26     $self->_accessor( "id", @_ );
  27 }
  28
  29 ## deprecated. Let the base class handle this.
  30 #    sub store {
  31 #        my $self = shift;
  32 #        $self->_accessor( "store", @_ ) || ref $self;
  33 #    }
  34
  35 sub _accessor {
  36     my $self = shift;
  37     my $key  = shift;
  38
  39     if (@_) {
  40         my $arr = $self->{__hash_obj_key_is_array}{$key} = @_ > 1;
  41         $self->{$key} = $arr ? [@_] : shift;
  42     }
  43
  44     my $data = $self->{$key};
  45     ( $self->{__hash_obj_key_is_array}{$key} || $key =~ /roles/ )
  46       ? @{ $data || [] }
  47       : $data;
  48 }
  49
  50 ## password portion of this is no longer necessary, but here for backwards compatibility.
  51 my %features = (
  52     password => {
  53         clear      => ["password"],
  54         crypted    => ["crypted_password"],
  55         hashed     => [qw/hashed_password hash_algorithm/],
  56         self_check => undef,
  57     },
  58     roles   => ["roles"],
  59     session => 1,
  60 );
  61
  62 sub supports {
  63     my ( $self, @spec ) = @_;
  64
  65     my $cursor = \%features;
  66
  67     return 1 if @spec == 1 and exists $self->{ $spec[0] };
  68
  69     # traverse the feature list,
  70     for (@spec) {
  71         return if ref($cursor) ne "HASH";
  72         $cursor = $cursor->{$_};
  73     }
  74
  75     if ( ref $cursor ) {
  76         die "bad feature spec: @spec" unless ref $cursor eq "ARRAY";
  77
  78         # check that all the keys required for a feature are in here
  79         foreach my $key (@$cursor) {
  80             return undef unless exists $self->{$key};
  81         }
  82
  83         return 1;
  84     }
  85     else {
  86         return $cursor;
  87     }
  88 }
  89
  90 sub for_session {
  91     my $self = shift;
  92
  93     return $self; # we serialize the whole user
  94 }
  95
  96 sub from_session {
  97     my ( $self, $c, $user ) = @_;
  98     $user;
  99 }
 100
 101 __PACKAGE__;
 102
 103 __END__
 104
 105 =pod
 106
 107 =head1 NAME
 108
 109 Catalyst::Authentication::User::Hash - An easy authentication user
 110 object based on hashes.
 111
 112 =head1 SYNOPSIS
 113
 114         use Catalyst::Authentication::User::Hash;
 115
 116         Catalyst::Authentication::User::Hash->new(
 117                 password => "s3cr3t",
 118         );
 119
 120 =head1 DESCRIPTION
 121
 122 This implementation of authentication user handles is supposed to go hand in
 123 hand with L<Catalyst::Authentication::Store::Minimal>.
 124
 125 =head1 METHODS
 126
 127 =head2 new( @pairs )
 128
 129 Create a new object with the key-value-pairs listed in the arg list.
 130
 131 =head2 supports( )
 132
 133 Checks for existence of keys that correspond with features.
 134
 135 =head2 for_session( )
 136
 137 Just returns $self, expecting it to be serializable.
 138
 139 =head2 from_session( )
 140
 141 Just passes returns the unserialized object, hoping it's intact.
 142
 143 =head2 AUTOLOAD( )
 144
 145 Accessor for the key whose name is the method.
 146
 147 =head2 store( )
 148
 149 Accessors that override superclass's dying virtual methods.
 150
 151 =head2 id( )
 152
 153 =head2 can( )
 154
 155 =head1 SEE ALSO
 156
 157 L<Hash::AsObject>
 158
 159 =cut
 160
 161