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