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

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