Fix calling User->can() as a class method. RT#90715
[catagits/Catalyst-Authentication-Store-DBIx-Class.git] / lib / Catalyst / Authentication / Store / DBIx / Class / User.pm
index b39970e..18282a4 100644 (file)
@@ -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.10.
+This documentation refers to version 0.1503.
 
 =head1 SYNOPSIS
 
@@ -328,6 +386,14 @@ By default, auto_update will call the C<auto_update()> 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) <mst@shadowcat.co.uk>
+
+(fixes wrt can/AUTOLOAD sponsored by L<http://reask.com/>)
+
 =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.