X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FAuthentication%2FStore%2FDBIx%2FClass%2FUser.pm;h=18282a4ab35429aad42251707dab1d4e4022873b;hb=c30ad9df2c49e9f51435b03182a2bf263c69d63e;hp=983d3c71f380f6c5f129e526971746f790abca62;hpb=398dc576f42367e1a30b38a2a489edcdd7080caf;p=catagits%2FCatalyst-Authentication-Store-DBIx-Class.git diff --git a/lib/Catalyst/Authentication/Store/DBIx/Class/User.pm b/lib/Catalyst/Authentication/Store/DBIx/Class/User.pm index 983d3c7..18282a4 100644 --- a/lib/Catalyst/Authentication/Store/DBIx/Class/User.pm +++ b/lib/Catalyst/Authentication/Store/DBIx/Class/User.pm @@ -1,14 +1,16 @@ package Catalyst::Authentication::Store::DBIx::Class::User; -use strict; -use warnings; -use List::MoreUtils qw(all); -use base qw/Catalyst::Authentication::User/; -use base qw/Class::Accessor::Fast/; - -BEGIN { - __PACKAGE__->mk_accessors(qw/config resultset _user _roles/); -} +use Moose; +use namespace::autoclean; +extends 'Catalyst::Authentication::User'; + +use List::MoreUtils 'all'; +use Try::Tiny; + +has 'config' => (is => 'rw'); +has 'resultset' => (is => 'rw'); +has '_user' => (is => 'rw'); +has '_roles' => (is => 'rw'); sub new { my ( $class, $config, $c) = @_; @@ -70,9 +72,11 @@ sub load { } ## User can provide an arrayref containing the arguments to search on the user class. - ## or even provide a prepared resultset, allowing maximum flexibility for user retreival. + ## or even provide a prepared resultset, allowing maximum flexibility for user retrieval. ## these options are only available when using the dbix_class authinfo hash. - if ($dbix_class_config && exists($authinfo->{'resultset'})) { + if ($dbix_class_config && exists($authinfo->{'result'})) { + $self->_user($authinfo->{'result'}); + } elsif ($dbix_class_config && exists($authinfo->{'resultset'})) { $self->_user($authinfo->{'resultset'}->first); } elsif ($dbix_class_config && exists($authinfo->{'searchargs'})) { $self->_user($self->resultset->search(@{$authinfo->{'searchargs'}})->first); @@ -161,7 +165,14 @@ sub for_session { #return $frozenuser; my %userdata = $self->_user->get_columns(); - return \%userdata; + + # If use_userdata_from_session is set, then store all of the columns of the user obj in the session + if (exists($self->config->{'use_userdata_from_session'}) && $self->config->{'use_userdata_from_session'} != 0) { + return \%userdata; + } else { # Otherwise, we just need the PKs for load() to use. + my %pk_fields = map { ($_ => $userdata{$_}) } @{ $self->config->{id_field} }; + return \%pk_fields; + } } sub from_session { @@ -178,7 +189,17 @@ sub from_session { # ## if use_userdata_from_session is defined in the config, we fill in the user data from the session. if (exists($self->config->{'use_userdata_from_session'}) && $self->config->{'use_userdata_from_session'} != 0) { - my $obj = $self->resultset->new_result({ %$frozenuser }); + + # We need to use inflate_result here since we -are- inflating a + # result object from cached data, not creating a fresh one. + # Components such as EncodedColumn wrap new() to ensure that a + # provided password is hashed on the way in, and re-running the + # hash function on data being restored is expensive and incorrect. + + my $class = $self->resultset->result_class; + my $source = $self->resultset->result_source; + my $obj = $class->inflate_result($source, { %$frozenuser }); + $obj->in_storage(1); $self->_user($obj); return $self; @@ -188,7 +209,7 @@ sub from_session { return $self->load({ map { ($_ => $frozenuser->{$_}) } @{ $self->config->{id_field} } - }); + }, $c); } return $self->load( { $self->config->{'id_field'} => $frozenuser }, $c); @@ -197,9 +218,14 @@ sub from_session { sub get { my ($self, $field) = @_; - if ($self->_user->can($field)) { - return $self->_user->$field; + if (my $code = $self->_user->can($field)) { + return $self->_user->$code; + } + elsif (my $accessor = + try { $self->_user->result_source->column_info($field)->{accessor} }) { + return $self->_user->$accessor; } else { + # XXX this should probably throw return undef; } } @@ -231,14 +257,46 @@ sub auto_update { $self->_user->auto_update( @_ ); } +sub can { + my $self = shift; + return $self->SUPER::can(@_) || do { + my ($method) = @_; + if (not ref $self) { + undef; + } elsif (not $self->_user) { + undef; + } elsif (my $code = $self->_user->can($method)) { + sub { shift->_user->$code(@_) } + } elsif (my $accessor = + try { $self->_user->result_source->column_info($method)->{accessor} }) { + sub { shift->_user->$accessor } + } else { + undef; + } + }; +} + sub AUTOLOAD { my $self = shift; (my $method) = (our $AUTOLOAD =~ /([^:]+)$/); return if $method eq "DESTROY"; - $self->_user->$method(@_); + return unless ref $self; + + if (my $code = $self->_user->can($method)) { + return $self->_user->$code(@_); + } + elsif (my $accessor = + try { $self->_user->result_source->column_info($method)->{accessor} }) { + return $self->_user->$accessor(@_); + } else { + # XXX this should also throw + return undef; + } } +__PACKAGE__->meta->make_immutable(inline_constructor => 0); + 1; __END__ @@ -250,7 +308,7 @@ module. =head1 VERSION -This documentation refers to version 0.1200. +This documentation refers to version 0.1503. =head1 SYNOPSIS @@ -328,6 +386,14 @@ By default, auto_update will call the C method of the DBIx::Class::Row object associated with the user. It is up to you to implement that method (probably in your schema file) +=head2 AUTOLOAD + +Delegates method calls to the underlying user row. + +=head2 can + +Delegates handling of the C<< can >> method to the underlying user row. + =head1 BUGS AND LIMITATIONS None known currently, please email the author if you find any. @@ -336,9 +402,15 @@ None known currently, please email the author if you find any. Jason Kuri (jayk@cpan.org) +=head1 CONTRIBUTORS + +Matt S Trout (mst) + +(fixes wrt can/AUTOLOAD sponsored by L) + =head1 LICENSE -Copyright (c) 2007 the aforementioned authors. All rights +Copyright (c) 2007-2010 the aforementioned authors. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.