@@ -0,0 +1,15 @@
+.*
+!.gitignore
+Makefile*
+!Makefile.PL
+META.yml
+blib
+build
+inc
+pm_to_blib
+MANIFEST*
+!MANIFEST.SKIP
+Debian*
+README
+Catalyst-Authentication-Store-DBIx-Class-*
+*.bs
@@ -1,33 +1,49 @@
Revision history for Catalyst-Plugin-Authentication-Store-DBIx-Class
+0.1400 2010-09-01
+ * Make can() work as well as AUTOLOADing.
+
+0.1300 2010-06-16
+ * Support columns with accessors that aren't the column name.
+ * Fix some documentation typos.
+ * Stop failing horribly when running the tests in parallel.
+ * Default to not running pod tests for users, even if the
+ required modules for that are available.
+
+0.1200 2010-04-10
+ Release 0.1100 as a stable version without further modifications.
+
+0.1100 2010-03-29 - development release
+ Support compound primary keys for looking up users.
+
0.1083 2010-03-03
- Tweaking exception message to better explain what people did wrong when
+ Tweaking exception message to better explain what people did wrong when
they pass bad columns to authenticate.
0.1082 2008-10-27
Documentation tweak to clarify user_class, store_user_class etc.
0.108 2008-09-25
- Adding SimpleDB realm to simplify basic auth configuration
- Changing user_class to user_model, per req. by mst to avoid confusing newbies.
+ Adding SimpleDB realm to simplify basic auth configuration
+ Changing user_class to user_model, per req. by mst to avoid confusing newbies.
0.107 2008-09-29
- Fix the typo in exception during authenticate
- Doc fixes and clarifications
- Added missing dependency on Catalyst::Model::DBIC::Schema to Makefile.PL
-
+ Fix the typo in exception during authenticate
+ Doc fixes and clarifications
+ Added missing dependency on Catalyst::Model::DBIC::Schema to Makefile.PL
+
0.105 2008-03-19
Throw an exception if no fields are provided during authenticate
- - better than retrieving a random user.
+ - better than retrieving a random user.
- still possible to do an empty search by using searchargs
-
+
0.104 2008-02-15
Added ability to avoid DB hits when restoring from session
0.103 2008-02-07
- Added missing DBIx::Class dependancy in Makefile.PL so
- that the damn test bots stop emailing me.
+ Added missing DBIx::Class dependancy in Makefile.PL so
+ that the damn test bots stop emailing me.
0.102 2008-01-23
Catalyst::Authentication::Store::DBIx::Class::User
@@ -48,6 +64,6 @@ Revision history for Catalyst-Plugin-Authentication-Store-DBIx-Class
0.02 2006-12-16 2pm CST
Rewritten to use proper accessors and clean up to match updated C::P::Authentication class naming
-
-0.01 2006-11-10
+
+0.01 2006-11-10
First version, worked internally, completely undocumented
@@ -1,3 +1,4 @@
+.gitignore
Changes
inc/Module/AutoInstall.pm
inc/Module/Install.pm
@@ -27,8 +28,9 @@ t/06-auth-roles-column.t
t/07-authsessions-cached.t
t/08-simpledb-auth-roles-relationship.t
t/09-simpledb-auth-roles-column.t
-t/lib/SetupDB.pm
+t/10-user-autoload.t
t/lib/TestApp.pm
+t/lib/TestApp/Controller/Root.pm
t/lib/TestApp/Model/TestApp.pm
t/lib/TestApp/Schema.pm
t/lib/TestApp/Schema/Role.pm
@@ -8,7 +8,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.91'
+generated_by: 'Module::Install version 0.99'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -18,13 +18,26 @@ no_index:
directory:
- inc
- t
+provides:
+ Catalyst::Authentication::Realm::SimpleDB:
+ file: lib/Catalyst/Authentication/Realm/SimpleDB.pm
+ Catalyst::Authentication::Store::DBIx::Class:
+ file: lib/Catalyst/Authentication/Store/DBIx/Class.pm
+ version: 0.1400
+ Catalyst::Authentication::Store::DBIx::Class::User:
+ file: lib/Catalyst/Authentication/Store/DBIx/Class/User.pm
requires:
Catalyst::Model::DBIC::Schema: 0.18
Catalyst::Plugin::Authentication: 0.10008
- Catalyst::Runtime: 0
- DBIx::Class: 0
+ Catalyst::Runtime: 5.8
+ DBIx::Class: 0.08
+ List::MoreUtils: 0
+ Moose: 0
+ Test::More: 0
+ Try::Tiny: 0
+ namespace::autoclean: 0
perl: 5.8.1
resources:
license: http://dev.perl.org/licenses/
- repository: http://dev.catalystframework.org/repos/Catalyst/trunk/Catalyst-Authentication-Store-DBIx-Class
-version: 0.1083
+ repository: http://dev.catalystframework.org/repos/Catalyst/Catalyst-Authentication-Store-DBIx-Class
+version: 0.1400
@@ -1,8 +1,9 @@
-use inc::Module::Install 0.87;
+use inc::Module::Install 0.91;
if( -e 'MANIFEST.SKIP' ) {
system( 'pod2text lib/Catalyst/Authentication/Store/DBIx/Class.pm > README' );
}
+realclean_files 'README';
## I'd love to use can_use - but I can't seem to test for success. :-/
eval { require Catalyst::Plugin::Authentication::Store::DBIx::Class or die 'footy'; };
@@ -16,7 +17,9 @@ if (!$@) { #} can_use("Catalyst::Plugin::Authentication::Store::DBIx::Class")
You have the Catalyst::Plugin::Authentication::Store::DBIx::Class installed.
The module you are installing supercedes it and it's presence has been known
to cause conflicts. We STRONGLY recommend you remove the old module before
-proceeding.
+proceeding.
+
+You can use CPANPLUS (the cpanp command) to remove the module.
You have 5 seconds to abort this install to remove the old module.
EOM
@@ -30,18 +33,21 @@ all_from 'lib/Catalyst/Authentication/Store/DBIx/Class.pm';
perl_version '5.8.1';
-requires ( 'Catalyst::Runtime' => 0,
- 'Catalyst::Plugin::Authentication' => '0.10008',
- 'Catalyst::Model::DBIC::Schema' => 0,
- 'DBIx::Class' => 0,
- 'Catalyst::Model::DBIC::Schema' => '0.18',
- );
-
+requires (
+ 'Catalyst::Runtime' => '5.8',
+ 'Catalyst::Plugin::Authentication' => '0.10008',
+ 'Catalyst::Model::DBIC::Schema' => '0.18',
+ 'DBIx::Class' => '0.08',
+ 'Moose' => 0,
+ 'namespace::autoclean' => 0,
+ 'List::MoreUtils' => 0,
+ 'Try::Tiny' => 0,
+);
test_requires 'Test::More';
-auto_install;
-resources repository => 'http://dev.catalystframework.org/repos/Catalyst/trunk/Catalyst-Authentication-Store-DBIx-Class';
+resources repository => 'http://dev.catalystframework.org/repos/Catalyst/Catalyst-Authentication-Store-DBIx-Class';
+auto_install;
+auto_provides;
WriteAll;
-
@@ -3,15 +3,15 @@ NAME
Catalyst Authentication using DBIx::Class
VERSION
- This documentation refers to version 0.108.
+ This documentation refers to version 0.1400.
SYNOPSIS
use Catalyst qw/
Authentication
Authorization::Roles/;
- __PACKAGE__->config->{authentication} =
- {
+ __PACKAGE__->config->{authentication} =
+ {
default_realm => 'members',
realms => {
members => {
@@ -24,27 +24,27 @@ SYNOPSIS
class => 'DBIx::Class',
user_model => 'MyApp::User',
role_relation => 'roles',
- role_field => 'rolename',
+ role_field => 'rolename',
}
}
}
};
# Log a user in:
-
- sub login : Global {
+
+ sub login : Global {
my ( $self, $c ) = @_;
-
- $c->authenticate({
- screen_name => $c->req->params->username,
- password => $c->req->params->password,
+
+ $c->authenticate({
+ screen_name => $c->req->params->{username},
+ password => $c->req->params->{password},
status => [ 'registered', 'loggedin', 'active']
}))
}
-
- # verify a role
-
- if ( $c->check_user_roles( 'editor' ) ) {
+
+ # verify a role
+
+ if ( $c->check_user_roles( 'editor' ) ) {
# do editor stuff
}
@@ -61,8 +61,8 @@ CONFIGURATION
The DBIx::Class storage module has several configuration options
- __PACKAGE__->config->{authentication} =
- {
+ __PACKAGE__->config->{authentication} =
+ {
default_realm => 'members',
realms => {
members => {
@@ -75,7 +75,7 @@ CONFIGURATION
role_relation => 'roles',
role_field => 'rolename',
ignore_fields_in_find => [ 'remote_name' ],
- use_userdata_from_session => 1,
+ use_userdata_from_session => 1,
}
}
}
@@ -178,7 +178,7 @@ USAGE
value pairs that should be used to locate the user in question. An
example of this usage is below:
- if ($c->authenticate({
+ if ($c->authenticate({
screen_name => $c->req->params->{'username'},
password => $c->req->params->{'password'},
status => [ 'registered', 'active', 'loggedin']
@@ -244,18 +244,18 @@ USAGE
example will probably make more sense:
if ($c->authenticate(
- {
+ {
password => $password,
- 'dbix_class' =>
+ 'dbix_class' =>
{
searchargs => [ { -or => [ username => $username,
email => $email,
- clientid => $clientid ]
+ clientid => $clientid ]
},
- { prefetch => qw/ preferences / }
+ { prefetch => qw/ preferences / }
]
}
- } ) )
+ } ) )
{
# do successful authentication actions here.
}
@@ -274,8 +274,8 @@ USAGE
my $rs = $c->model('MyApp::User')->search({ email => $c->request->params->{'email'} });
... # further $rs adjustments
-
- if ($c->authenticate({
+
+ if ($c->authenticate({
password => $password,
'dbix_class' => { resultset => $rs }
})) {
@@ -253,6 +253,8 @@ sub import {
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
+
+ return (@Existing, @Missing);
}
sub _running_under {
@@ -672,7 +674,20 @@ sub _load {
sub _load_cpan {
return if $CPAN::VERSION and $CPAN::Config and not @_;
require CPAN;
- if ( $CPAN::HandleConfig::VERSION ) {
+
+ # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to
+ # CPAN::HandleConfig->load. CPAN reports that the redirection
+ # is deprecated in a warning printed at the user.
+
+ # CPAN-1.81 expects CPAN::HandleConfig->load, does not have
+ # $CPAN::HandleConfig::VERSION but cannot handle
+ # CPAN::Config->load
+
+ # Which "versions expect CPAN::Config->load?
+
+ if ( $CPAN::HandleConfig::VERSION
+ || CPAN::HandleConfig->can('load')
+ ) {
# Newer versions of CPAN have a HandleConfig module
CPAN::HandleConfig->load;
} else {
@@ -802,4 +817,4 @@ END_MAKE
__END__
-#line 1056
+#line 1071
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.99';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -37,12 +37,25 @@ sub auto_install {
$self->include('Module::AutoInstall');
require Module::AutoInstall;
- Module::AutoInstall->import(
+ my @features_require = Module::AutoInstall->import(
(@config ? (-config => \@config) : ()),
(@core ? (-core => \@core) : ()),
$self->features,
);
+ my %seen;
+ my @requires = map @$_, map @$_, grep ref, $self->requires;
+ while (my ($mod, $ver) = splice(@requires, 0, 2)) {
+ $seen{$mod}{$ver}++;
+ }
+
+ my @deduped;
+ while (my ($mod, $ver) = splice(@features_require, 0, 2)) {
+ push @deduped, $mod => $ver unless $seen{$mod}{$ver}++;
+ }
+
+ $self->requires(@deduped);
+
$self->makemaker_args( Module::AutoInstall::_make_args() );
my $class = ref($self);
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.99';
}
# Suspend handler for "redefined" warnings
@@ -51,13 +51,18 @@ sub admin {
#line 106
sub is_admin {
- $_[0]->admin->VERSION;
+ ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = $Module::Install::Base::VERSION;
+}
+
my $fake;
sub new {
@@ -75,4 +80,4 @@ BEGIN {
1;
-#line 154
+#line 159
@@ -9,7 +9,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.99';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.99';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.99';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -4,10 +4,11 @@ package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
+use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.99';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -25,8 +26,8 @@ sub prompt {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
- # In automated testing, always use defaults
- if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ # In automated testing or non-interactive session, always use defaults
+ if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
@@ -34,21 +35,112 @@ sub prompt {
}
}
+# Store a cleaned up version of the MakeMaker version,
+# since we need to behave differently in a variety of
+# ways based on the MM version.
+my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
+
+# If we are passed a param, do a "newer than" comparison.
+# Otherwise, just return the MakeMaker version.
+sub makemaker {
+ ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
+}
+
+# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
+# as we only need to know here whether the attribute is an array
+# or a hash or something else (which may or may not be appendable).
+my %makemaker_argtype = (
+ C => 'ARRAY',
+ CONFIG => 'ARRAY',
+# CONFIGURE => 'CODE', # ignore
+ DIR => 'ARRAY',
+ DL_FUNCS => 'HASH',
+ DL_VARS => 'ARRAY',
+ EXCLUDE_EXT => 'ARRAY',
+ EXE_FILES => 'ARRAY',
+ FUNCLIST => 'ARRAY',
+ H => 'ARRAY',
+ IMPORTS => 'HASH',
+ INCLUDE_EXT => 'ARRAY',
+ LIBS => 'ARRAY', # ignore ''
+ MAN1PODS => 'HASH',
+ MAN3PODS => 'HASH',
+ META_ADD => 'HASH',
+ META_MERGE => 'HASH',
+ PL_FILES => 'HASH',
+ PM => 'HASH',
+ PMLIBDIRS => 'ARRAY',
+ PMLIBPARENTDIRS => 'ARRAY',
+ PREREQ_PM => 'HASH',
+ CONFIGURE_REQUIRES => 'HASH',
+ SKIP => 'ARRAY',
+ TYPEMAPS => 'ARRAY',
+ XS => 'HASH',
+# VERSION => ['version',''], # ignore
+# _KEEP_AFTER_FLUSH => '',
+
+ clean => 'HASH',
+ depend => 'HASH',
+ dist => 'HASH',
+ dynamic_lib=> 'HASH',
+ linkext => 'HASH',
+ macro => 'HASH',
+ postamble => 'HASH',
+ realclean => 'HASH',
+ test => 'HASH',
+ tool_autosplit => 'HASH',
+
+ # special cases where you can use makemaker_append
+ CCFLAGS => 'APPENDABLE',
+ DEFINE => 'APPENDABLE',
+ INC => 'APPENDABLE',
+ LDDLFLAGS => 'APPENDABLE',
+ LDFROM => 'APPENDABLE',
+);
+
sub makemaker_args {
- my $self = shift;
+ my ($self, %new_args) = @_;
my $args = ( $self->{makemaker_args} ||= {} );
- %$args = ( %$args, @_ );
+ foreach my $key (keys %new_args) {
+ if ($makemaker_argtype{$key}) {
+ if ($makemaker_argtype{$key} eq 'ARRAY') {
+ $args->{$key} = [] unless defined $args->{$key};
+ unless (ref $args->{$key} eq 'ARRAY') {
+ $args->{$key} = [$args->{$key}]
+ }
+ push @{$args->{$key}},
+ ref $new_args{$key} eq 'ARRAY'
+ ? @{$new_args{$key}}
+ : $new_args{$key};
+ }
+ elsif ($makemaker_argtype{$key} eq 'HASH') {
+ $args->{$key} = {} unless defined $args->{$key};
+ foreach my $skey (keys %{ $new_args{$key} }) {
+ $args->{$key}{$skey} = $new_args{$key}{$skey};
+ }
+ }
+ elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
+ $self->makemaker_append($key => $new_args{$key});
+ }
+ }
+ else {
+ if (defined $args->{$key}) {
+ warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
+ }
+ $args->{$key} = $new_args{$key};
+ }
+ }
return $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
- my $self = sShift;
+ my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
- $args->{name} = defined $args->{$name}
- ? join( ' ', $args->{name}, @_ )
+ $args->{$name} = defined $args->{$name}
+ ? join( ' ', $args->{$name}, @_ )
: join( ' ', @_ );
}
@@ -89,25 +181,22 @@ sub inc {
$self->makemaker_args( INC => shift );
}
-my %test_dir = ();
-
sub _wanted_t {
- /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
- if ( $self->tests ) {
- die "tests_recursive will not work if tests are already defined";
- }
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
- %test_dir = ();
+ my %tests = map { $_ => 1 } split / /, ($self->tests || '');
require File::Find;
- File::Find::find( \&_wanted_t, $dir );
- $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+ File::Find::find(
+ sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
+ $dir
+ );
+ $self->tests( join ' ', sort keys %tests );
}
sub write {
@@ -130,12 +219,13 @@ sub write {
# an underscore, even though its own version may contain one!
# Hence the funny regexp to get rid of it. See RT #35800
# for details.
- $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+ my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
+ $self->build_requires( 'ExtUtils::MakeMaker' => $v );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
}
@@ -143,59 +233,115 @@ sub write {
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
- $args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
+ $args->{VERSION} = $self->version or die <<'EOT';
+ERROR: Can't determine distribution version. Please specify it
+explicitly via 'version' in Makefile.PL, or set a valid $VERSION
+in a module, and provide its file path via 'version_from' (or
+'all_from' if you prefer) in Makefile.PL.
+EOT
+
+ $DB::single = 1;
if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
+ my @tests = split ' ', $self->tests;
+ my %seen;
+ $args->{test} = {
+ TESTS => (join ' ', grep {!$seen{$_}++} @tests),
+ };
+ } elsif ( $Module::Install::ExtraTests::use_extratests ) {
+ # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
+ # So, just ignore our xt tests here.
+ } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ $args->{test} = {
+ TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
+ };
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = $self->author;
+ $args->{AUTHOR} = join ', ', @{$self->author || []};
}
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
+ if ( $self->makemaker(6.10) ) {
+ $args->{NO_META} = 1;
+ #$args->{NO_MYMETA} = 1;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
+ if ( $self->makemaker(6.31) and $self->license ) {
+ $args->{LICENSE} = $self->license;
+ }
- # Merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
- map { @$_ }
+ map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
+ ($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
- # merge both kinds of requires into prereq_pm
- my $subdirs = ($args->{DIR} ||= []);
+ # Merge both kinds of requires into BUILD_REQUIRES
+ my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
+ %$build_prereq = ( %$build_prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires)
+ );
+
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm, add it to Makefile DIR
+ my $subdirs = ($args->{DIR} || []);
if ($self->bundles) {
+ my %processed;
foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
+ my ($mod_name, $dist_dir) = @$bundle;
+ delete $prereq->{$mod_name};
+ $dist_dir = File::Basename::basename($dist_dir); # dir for building this module
+ if (not exists $processed{$dist_dir}) {
+ if (-d $dist_dir) {
+ # List as sub-directory to be processed by make
+ push @$subdirs, $dist_dir;
+ }
+ # Else do nothing: the module is already present on the system
+ $processed{$dist_dir} = undef;
+ }
}
}
+ unless ( $self->makemaker('6.55_03') ) {
+ %$prereq = (%$prereq,%$build_prereq);
+ delete $args->{BUILD_REQUIRES};
+ }
+
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
+
+ if ( $self->makemaker(6.48) ) {
+ $args->{MIN_PERL_VERSION} = $perl_version;
+ }
}
- $args->{INSTALLDIRS} = $self->installdirs;
+ if ($self->installdirs) {
+ warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
+ $args->{INSTALLDIRS} = $self->installdirs;
+ }
- my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+ my %args = map {
+ ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
+ } keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
- if (my $preop = $self->admin->preop($user_preop)) {
+ if ( my $preop = $self->admin->preop($user_preop) ) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
@@ -219,9 +365,9 @@ sub fix_up_makefile {
. ($self->postamble || '');
local *MAKEFILE;
- open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ eval { flock MAKEFILE, LOCK_EX };
my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
@@ -241,7 +387,8 @@ sub fix_up_makefile {
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ seek MAKEFILE, 0, SEEK_SET;
+ truncate MAKEFILE, 0;
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
@@ -265,4 +412,4 @@ sub postamble {
__END__
-#line 394
+#line 541
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.99';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -19,7 +19,6 @@ my @scalar_keys = qw{
name
module_name
abstract
- author
version
distribution_type
tests
@@ -43,8 +42,11 @@ my @resource_keys = qw{
my @array_keys = qw{
keywords
+ author
};
+*authors = \&author;
+
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
@@ -176,43 +178,6 @@ sub perl_version {
$self->{values}->{perl_version} = $version;
}
-#Stolen from M::B
-my %license_urls = (
- perl => 'http://dev.perl.org/licenses/',
- apache => 'http://apache.org/licenses/LICENSE-2.0',
- artistic => 'http://opensource.org/licenses/artistic-license.php',
- artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
- lgpl => 'http://opensource.org/licenses/lgpl-license.php',
- lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
- lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
- bsd => 'http://opensource.org/licenses/bsd-license.php',
- gpl => 'http://opensource.org/licenses/gpl-license.php',
- gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
- gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
- mit => 'http://opensource.org/licenses/mit-license.php',
- mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
- open_source => undef,
- unrestricted => undef,
- restrictive => undef,
- unknown => undef,
-);
-
-sub license {
- my $self = shift;
- return $self->{values}->{license} unless @_;
- my $license = shift or die(
- 'Did not provide a value to license()'
- );
- $self->{values}->{license} = $license;
-
- # Automatically fill in license URLs
- if ( $license_urls{$license} ) {
- $self->resources( license => $license_urls{$license} );
- }
-
- return 1;
-}
-
sub all_from {
my ( $self, $file ) = @_;
@@ -230,6 +195,8 @@ sub all_from {
die("The path '$file' does not exist, or is not a file");
}
+ $self->{values}{all_from} = $file;
+
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
@@ -240,7 +207,7 @@ sub all_from {
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
- $self->author_from($pod) unless $self->author;
+ $self->author_from($pod) unless @{$self->author || []};
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
@@ -350,6 +317,9 @@ sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
+
+ # for version integrity check
+ $self->makemaker_args( VERSION_FROM => $file );
}
sub abstract_from {
@@ -360,7 +330,7 @@ sub abstract_from {
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
- );
+ );
}
# Add both distribution and module name
@@ -385,11 +355,10 @@ sub name_from {
}
}
-sub perl_version_from {
- my $self = shift;
+sub _extract_perl_version {
if (
- Module::Install::_read($_[0]) =~ m/
- ^
+ $_[0] =~ m/
+ ^\s*
(?:use|require) \s*
v?
([\d_\.]+)
@@ -398,6 +367,16 @@ sub perl_version_from {
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
+ return $perl_version;
+ } else {
+ return;
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
+ if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
@@ -417,59 +396,164 @@ sub author_from {
([^\n]*)
/ixms) {
my $author = $1 || $2;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
+
+ # XXX: ugly but should work anyway...
+ if (eval "require Pod::Escapes; 1") {
+ # Pod::Escapes has a mapping table.
+ # It's in core of perl >= 5.9.3, and should be installed
+ # as one of the Pod::Simple's prereqs, which is a prereq
+ # of Pod::Text 3.x (see also below).
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $Pod::Escapes::Name2character_number{$1}
+ ? chr($Pod::Escapes::Name2character_number{$1})
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
+ # Pod::Text < 3.0 has yet another mapping table,
+ # though the table name of 2.x and 1.x are different.
+ # (1.x is in core of Perl < 5.6, 2.x is in core of
+ # Perl < 5.9.3)
+ my $mapping = ($Pod::Text::VERSION < 2)
+ ? \%Pod::Text::HTML_Escapes
+ : \%Pod::Text::ESCAPES;
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $mapping->{$1}
+ ? $mapping->{$1}
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ else {
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ }
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
-sub license_from {
+#Stolen from M::B
+my %license_urls = (
+ perl => 'http://dev.perl.org/licenses/',
+ apache => 'http://apache.org/licenses/LICENSE-2.0',
+ apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
+ artistic => 'http://opensource.org/licenses/artistic-license.php',
+ artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ lgpl => 'http://opensource.org/licenses/lgpl-license.php',
+ lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
+ lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
+ bsd => 'http://opensource.org/licenses/bsd-license.php',
+ gpl => 'http://opensource.org/licenses/gpl-license.php',
+ gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
+ gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
+ mit => 'http://opensource.org/licenses/mit-license.php',
+ mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
+ open_source => undef,
+ unrestricted => undef,
+ restrictive => undef,
+ unknown => undef,
+);
+
+sub license {
my $self = shift;
- if (
- Module::Install::_read($_[0]) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /ixms ) {
- my $license_text = $1;
- my @phrases = (
- 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- $self->license($license);
- return 1;
- }
+ return $self->{values}->{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $license = __extract_license($license) || lc $license;
+ $self->{values}->{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license_urls{$license} ) {
+ $self->resources( license => $license_urls{$license} );
+ }
+
+ return 1;
+}
+
+sub _extract_license {
+ my $pod = shift;
+ my $matched;
+ return __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /xms
+ ) || __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /xms
+ );
+}
+
+sub __extract_license {
+ my $license_text = shift or return;
+ my @phrases = (
+ '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
+ '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'Artistic and GPL' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'GNU Free Documentation license' => 'unrestricted', 1,
+ 'GNU Affero General Public License' => 'open_source', 1,
+ '(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'Apache (?:Software )?license' => 'apache', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'Mozilla Public License' => 'mozilla', 1,
+ 'Q Public License' => 'open_source', 1,
+ 'OpenSSL License' => 'unrestricted', 1,
+ 'SSLeay License' => 'unrestricted', 1,
+ 'zlib License' => 'open_source', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s#\s+#\\s+#gs;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ return $license;
}
}
+ return '';
+}
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
+sub license_from {
+ my $self = shift;
+ if (my $license=_extract_license(Module::Install::_read($_[0]))) {
+ $self->license($license);
+ } else {
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+ }
}
sub _extract_bugtracker {
- my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
+ my @links = $_[0] =~ m#L<(
+ \Qhttp://rt.cpan.org/\E[^>]+|
+ \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
+ \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ )>#gx;
my %links;
@links{@links}=();
@links=keys %links;
@@ -485,7 +569,7 @@ sub bugtracker_from {
return 0;
}
if ( @links > 1 ) {
- warn "Found more than on rt.cpan.org link in $_[0]\n";
+ warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
@@ -532,8 +616,15 @@ sub _perl_version {
return $v;
}
-
-
+sub add_metadata {
+ my $self = shift;
+ my %hash = @_;
+ for my $key (keys %hash) {
+ warn "add_metadata: $key is not prefixed with 'x_'.\n" .
+ "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
+ $self->{values}->{$key} = $hash{$key};
+ }
+}
######################################################################
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.99';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';;
+ $VERSION = '0.99';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -26,7 +26,10 @@ sub WriteAll {
$self->check_nmake if $args{check_nmake};
unless ( $self->makemaker_args->{PL_FILES} ) {
- $self->makemaker_args( PL_FILES => {} );
+ # XXX: This still may be a bit over-defensive...
+ unless ($self->makemaker(6.25)) {
+ $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
+ }
}
# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
@@ -19,6 +19,9 @@ package Module::Install;
use 5.005;
use strict 'vars';
+use Cwd ();
+use File::Find ();
+use File::Path ();
use vars qw{$VERSION $MAIN};
BEGIN {
@@ -28,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.91';
+ $VERSION = '0.99';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -38,18 +41,25 @@ BEGIN {
}
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
-
-
-
-# Whether or not inc::Module::Install is actually loaded, the
-# $INC{inc/Module/Install.pm} is what will still get set as long as
-# the caller loaded module this in the documented manner.
-# If not set, the caller may NOT have loaded the bundled version, and thus
-# they may not have a MI version that works with the Makefile.PL. This would
-# result in false errors or unexpected behaviour. And we don't want that.
-my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
-unless ( $INC{$file} ) { die <<"END_DIE" }
+ #-------------------------------------------------------------
+ # all of the following checks should be included in import(),
+ # to allow "eval 'require Module::Install; 1' to test
+ # installation of Module::Install. (RT #51267)
+ #-------------------------------------------------------------
+
+ # Whether or not inc::Module::Install is actually loaded, the
+ # $INC{inc/Module/Install.pm} is what will still get set as long as
+ # the caller loaded module this in the documented manner.
+ # If not set, the caller may NOT have loaded the bundled version, and thus
+ # they may not have a MI version that works with the Makefile.PL. This would
+ # result in false errors or unexpected behaviour. And we don't want that.
+ my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+ unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
@@ -61,26 +71,28 @@ not:
END_DIE
-
-
-
-
-# If the script that is loading Module::Install is from the future,
-# then make will detect this and cause it to re-run over and over
-# again. This is bad. Rather than taking action to touch it (which
-# is unreliable on some platforms and requires write permissions)
-# for now we should catch this and refuse to run.
-if ( -f $0 ) {
- my $s = (stat($0))[9];
-
- # If the modification time is only slightly in the future,
- # sleep briefly to remove the problem.
- my $a = $s - time;
- if ( $a > 0 and $a < 5 ) { sleep 5 }
-
- # Too far in the future, throw an error.
- my $t = time;
- if ( $s > $t ) { die <<"END_DIE" }
+ # This reportedly fixes a rare Win32 UTC file time issue, but
+ # as this is a non-cross-platform XS module not in the core,
+ # we shouldn't really depend on it. See RT #24194 for detail.
+ # (Also, this module only supports Perl 5.6 and above).
+ eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
+
+ # If the script that is loading Module::Install is from the future,
+ # then make will detect this and cause it to re-run over and over
+ # again. This is bad. Rather than taking action to touch it (which
+ # is unreliable on some platforms and requires write permissions)
+ # for now we should catch this and refuse to run.
+ if ( -f $0 ) {
+ my $s = (stat($0))[9];
+
+ # If the modification time is only slightly in the future,
+ # sleep briefly to remove the problem.
+ my $a = $s - time;
+ if ( $a > 0 and $a < 5 ) { sleep 5 }
+
+ # Too far in the future, throw an error.
+ my $t = time;
+ if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
@@ -89,15 +101,12 @@ This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
-}
-
-
-
+ }
-# Build.PL was formerly supported, but no longer is due to excessive
-# difficulty in implementing every single feature twice.
-if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
+ # Build.PL was formerly supported, but no longer is due to excessive
+ # difficulty in implementing every single feature twice.
+ if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
@@ -107,23 +116,42 @@ Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
+ #-------------------------------------------------------------
+ # To save some more typing in Module::Install installers, every...
+ # use inc::Module::Install
+ # ...also acts as an implicit use strict.
+ $^H |= strict::bits(qw(refs subs vars));
+ #-------------------------------------------------------------
+ unless ( -f $self->{file} ) {
+ foreach my $key (keys %INC) {
+ delete $INC{$key} if $key =~ /Module\/Install/;
+ }
-# To save some more typing in Module::Install installers, every...
-# use inc::Module::Install
-# ...also acts as an implicit use strict.
-$^H |= strict::bits(qw(refs subs vars));
-
+ local $^W;
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+ local $^W;
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{'inc/Module/Install.pm'};
+ delete $INC{'Module/Install.pm'};
+ # Save to the singleton
+ $MAIN = $self;
-use Cwd ();
-use File::Find ();
-use File::Path ();
-use FindBin;
+ return 1;
+}
sub autoload {
my $self = shift;
@@ -136,7 +164,21 @@ sub autoload {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unless ($$sym =~ s/([^:]+)$//) {
+ # XXX: it looks like we can't retrieve the missing function
+ # via $$sym (usually $main::AUTOLOAD) in this case.
+ # I'm still wondering if we should slurp Makefile.PL to
+ # get some context or not ...
+ my ($package, $file, $line) = caller;
+ die <<"EOT";
+Unknown function is found at $file line $line.
+Execution of $file aborted due to runtime errors.
+
+If you're a contributor to a project, you may need to install
+some Module::Install extensions from CPAN (or other repository).
+If you're a user of a module, please contact the author.
+EOT
+ }
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
@@ -152,33 +194,6 @@ sub autoload {
};
}
-sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- require "$self->{path}/$self->{dispatch}.pm";
- File::Path::mkpath("$self->{prefix}/$self->{author}");
- $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
- $self->{admin}->init;
- @_ = ($class, _self => $self);
- goto &{"$self->{name}::import"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
-
- # Save to the singleton
- $MAIN = $self;
-
- return 1;
-}
-
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
@@ -204,6 +219,7 @@ sub preload {
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
+ local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
@@ -214,12 +230,14 @@ sub preload {
sub new {
my ($class, %args) = @_;
+ delete $INC{'FindBin.pm'};
+ require FindBin;
+
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
-
return $args{_self} if $args{_self};
$args{dispatch} ||= 'Admin';
@@ -272,8 +290,10 @@ END_DIE
sub load_extensions {
my ($self, $path, $top) = @_;
+ my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
+ $should_reload = 1;
}
foreach my $rv ( $self->find_extensions($path) ) {
@@ -281,12 +301,13 @@ sub load_extensions {
next if $self->{pathnames}{$pkg};
local $@;
- my $new = eval { require $file; $pkg->can('new') };
+ my $new = eval { local $^W; require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
- $self->{pathnames}{$pkg} = delete $INC{$file};
+ $self->{pathnames}{$pkg} =
+ $should_reload ? delete $INC{$file} : $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
@@ -348,17 +369,24 @@ sub _caller {
return $call;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
- if ( $] >= 5.006 ) {
- open( FH, '<', $_[0] ) or die "open($_[0]): $!";
- } else {
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
- }
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
+END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
@@ -379,18 +407,26 @@ sub _readpod {
return $string;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
- if ( $] >= 5.006 ) {
- open( FH, '>', $_[0] ) or die "open($_[0]): $!";
- } else {
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
}
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
+END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
@@ -427,4 +463,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2009 Adam Kennedy.
+# Copyright 2008 - 2010 Adam Kennedy.
@@ -7,7 +7,7 @@ use base qw/Catalyst::Authentication::Realm/;
sub new {
my ($class, $realmname, $config, $app) = @_;
-
+
my $newconfig = {
credential => {
class => 'Password',
@@ -20,19 +20,19 @@ sub new {
use_userdata_from_session => '1'
}
};
-
+
if (!defined($config->{'user_model'})) {
Catalyst::Exception->throw("Unable to initialize authentication, no user_model specified in SimpleDB config.");
}
-
- ## load any overrides for the credential
+
+ ## load any overrides for the credential
foreach my $key (qw/ password_type password_field password_hash_type/) {
if (exists($config->{$key})) {
$newconfig->{credential}{$key} = $config->{$key};
}
- }
-
+ }
+
## load any overrides for the store
foreach my $key (qw/ user_model role_relation role_field role_column use_userdata_from_session/) {
if (exists($config->{$key})) {
@@ -43,7 +43,7 @@ sub new {
delete $newconfig->{'store'}{'role_relation'};
delete $newconfig->{'store'}{'role_field'};
}
-
+
return $class->SUPER::new($realmname, $newconfig, $app);
}
@@ -60,8 +60,8 @@ Catalyst::Authentication::Realm::SimpleDB - A simplified Catalyst authentication
Authentication
/;
- __PACKAGE__->config->{'Plugin::Authentication'} =
- {
+ __PACKAGE__->config->{'Plugin::Authentication'} =
+ {
default => {
class => 'SimpleDB',
user_model => 'MyApp::Schema::Users',
@@ -69,17 +69,17 @@ Catalyst::Authentication::Realm::SimpleDB - A simplified Catalyst authentication
}
# later on ...
- $c->authenticate({ username => 'myusername',
+ $c->authenticate({ username => 'myusername',
password => 'mypassword' });
my $age = $c->user->get('age');
- $c->logout;
+ $c->logout;
=head1 DESCRIPTION
-The Catalyst::Authentication::Realm::SimpleDB provides a simple way to configure Catalyst Authentication
+The Catalyst::Authentication::Realm::SimpleDB provides a simple way to configure Catalyst Authentication
when using the most common configuration of a password protected user retrieved from an SQL database.
=head1 CONFIGURATION
@@ -116,17 +116,17 @@ More information on these options can be found in
L<Catalyst::Authentication::Credential::Password> and
L<Catalyst::Authentication::Store::DBIx::Class>.
-=over
+=over
=item user_model
Contains the class name (as passed to $c->model() ) of the DBIx::Class schema
to use as the source for user information. This config item is B<REQUIRED>.
-=item password_field
+=item password_field
If your password field is not 'password' set this option to the name of your password field. Note that if you change this
-to, say 'users_password' you will need to use that in the authenticate call:
+to, say 'users_password' you will need to use that in the authenticate call:
$c->authenticate({ username => 'bob', users_password => 'foo' });
@@ -134,27 +134,27 @@ to, say 'users_password' you will need to use that in the authenticate call:
If the password is not stored in plaintext you will need to define what format the password is in. The common options are
B<crypted> and B<hashed>. Crypted uses the standard unix crypt to encrypt the password. Hashed uses the L<Digest> modules to
-perform password hashing.
+perform password hashing.
=item password_hash_type
-If you use a hashed password type - this defines the type of hashing. See L<Catalyst::Authentication::Credential::Password>
-for more details on this setting.
+If you use a hashed password type - this defines the type of hashing. See L<Catalyst::Authentication::Credential::Password>
+for more details on this setting.
=item role_column
-If your users roles are stored directly in your user table, set this to the column name that contains your roles. For
-example, if your user table contains a field called 'permissions', the value of role_column would be 'permissions'.
-B<NOTE>: If multiple values are stored in the role column, they should be space or pipe delimited.
+If your users roles are stored directly in your user table, set this to the column name that contains your roles. For
+example, if your user table contains a field called 'permissions', the value of role_column would be 'permissions'.
+B<NOTE>: If multiple values are stored in the role column, they should be space or pipe delimited.
=item role_relation and role_field
-These define an alternate role relationship name and the column that holds the role's name in plain text. See
+These define an alternate role relationship name and the column that holds the role's name in plain text. See
L<Catalyst::Authentication::Store::DBIx::Class/CONFIGURATION> for more details on these settings.
=item use_userdata_from_session
-This is a simple 1 / 0 setting which determines how a user's data is saved / restored from the session. If
+This is a simple 1 / 0 setting which determines how a user's data is saved / restored from the session. If
it is set to 1, the user's complete information (at the time of authentication) is cached between requests.
If it is set to 0, the users information is loaded from the database on each request.
@@ -205,15 +205,15 @@ C<lib/MyApp/Schema/UserRoles.pm>:
__PACKAGE__->belongs_to(role => 'MyApp::Schema::Roles', 'role_id');
-=head1 MIGRATION
+=head1 MIGRATION
If and when your application becomes complex enough that you need more features
than SimpleDB gives you access to, you can migrate to a standard Catalyst
Authentication configuration fairly easily. SimpleDB simply creates a standard
Auth config based on the inputs you give it. The config SimpleDB creates by default
-looks like this:
+looks like this:
- MyApp->config('Plugin::Authentication') = {
+ MyApp->config('Plugin::Authentication') = {
default => {
credential => {
class => 'Password',
@@ -227,7 +227,7 @@ looks like this:
user_model => $user_model_from_simpledb_config
}
}
- };
+ };
=head1 SEE ALSO
@@ -235,9 +235,9 @@ looks like this:
This module relies on a number of other modules to do it's job. For more information
you can refer to the following:
-=over
+=over
-=item *
+=item *
L<Catalyst::Manual::Tutorial::Authentication>
=item *
@@ -1,20 +1,22 @@
package Catalyst::Authentication::Store::DBIx::Class::User;
-use strict;
-use warnings;
-use base qw/Catalyst::Authentication::User/;
-use base qw/Class::Accessor::Fast/;
+use Moose;
+use namespace::autoclean;
+extends 'Catalyst::Authentication::User';
-BEGIN {
- __PACKAGE__->mk_accessors(qw/config resultset _user _roles/);
-}
+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) = @_;
- if (!defined($config->{'user_model'})) {
- $config->{'user_model'} = $config->{'user_class'};
- }
+ $config->{user_model} = $config->{user_class}
+ unless defined $config->{user_model};
my $self = {
resultset => $c->model($config->{'user_model'}),
@@ -22,39 +24,36 @@ sub new {
_roles => undef,
_user => undef
};
-
+
bless $self, $class;
-
+ Catalyst::Exception->throw(
+ "\$c->model('${ \$self->config->{user_model} }') did not return a resultset."
+ . " Did you set user_model correctly?"
+ ) unless $self->{resultset};
- if (not $self->{'resultset'}) {
- Catalyst::Exception->throw("\$c->model('${ \$self->config->{user_model} }') did not return a resultset. Did you set user_model correctly?");
- }
+ $self->config->{'id_field'} = [$self->{'resultset'}->result_source->primary_columns]
+ unless exists $self->config->{'id_field'};
- ## Note to self- add handling of multiple-column primary keys.
- if (!exists($self->config->{'id_field'})) {
- my @pks = $self->{'resultset'}->result_source->primary_columns;
- if ($#pks == 0) {
- $self->config->{'id_field'} = $pks[0];
- } else {
- Catalyst::Exception->throw("user table does not contain a single primary key column - please specify 'id_field' in config!");
- }
- }
+ $self->config->{'id_field'} = [$self->config->{'id_field'}]
+ unless ref $self->config->{'id_field'} eq 'ARRAY';
+
+ Catalyst::Exception->throw(
+ "id_field set to "
+ . join(q{,} => @{ $self->config->{'id_field'} })
+ . " but user table has no column by that name!"
+ ) unless all { $self->{'resultset'}->result_source->has_column($_) } @{ $self->config->{'id_field'} };
- if (!$self->{'resultset'}->result_source->has_column($self->config->{'id_field'})) {
- Catalyst::Exception->throw("id_field set to " . $self->config->{'id_field'} . " but user table has no column by that name!");
- }
-
## if we have lazyloading turned on - we should not query the DB unless something gets read.
## that's the idea anyway - still have to work out how to manage that - so for now we always force
## lazyload to off.
$self->config->{lazyload} = 0;
-
+
# if (!$self->config->{lazyload}) {
# return $self->load_user($authinfo, $c);
# } else {
# ## what do we do with a lazyload?
-# ## presumably this is coming out of session storage.
+# ## presumably this is coming out of session storage.
# ## use $authinfo to fill in the user in that case?
# }
@@ -64,26 +63,26 @@ sub new {
sub load {
my ($self, $authinfo, $c) = @_;
-
+
my $dbix_class_config = 0;
-
+
if (exists($authinfo->{'dbix_class'})) {
$authinfo = $authinfo->{'dbix_class'};
$dbix_class_config = 1;
}
-
+
## 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.
- ## these options are only available when using the dbix_class authinfo hash.
+ ## these options are only available when using the dbix_class authinfo hash.
if ($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);
+ $self->_user($self->resultset->search(@{$authinfo->{'searchargs'}})->first);
} else {
## merge the ignore fields array into a hash - so we can do an easy check while building the query
- my %ignorefields = map { $_ => 1} @{$self->config->{'ignore_fields_in_find'}};
+ my %ignorefields = map { $_ => 1} @{$self->config->{'ignore_fields_in_find'}};
my $searchargs = {};
-
+
# now we walk all the fields passed in, and build up a search hash.
foreach my $key (grep {!$ignorefields{$_}} keys %{$authinfo}) {
if ($self->resultset->result_source->has_column($key)) {
@@ -93,7 +92,12 @@ sub load {
if (keys %{$searchargs}) {
$self->_user($self->resultset->search($searchargs)->first);
} else {
- Catalyst::Exception->throw("Failed to load user data. You passed [" . join(',', keys %{$authinfo}) . "] to authenticate() but your user source (" . $self->config->{'user_model'} . ") only has these columns: [" . join( ",", $self->resultset->result_source->columns ) . "] Check your authenticate() call.");
+ Catalyst::Exception->throw(
+ "Failed to load user data. You passed [" . join(',', keys %{$authinfo}) . "]"
+ . " to authenticate() but your user source (" . $self->config->{'user_model'} . ")"
+ . " only has these columns: [" . join( ",", $self->resultset->result_source->columns ) . "]"
+ . " Check your authenticate() call."
+ );
}
}
@@ -123,18 +127,22 @@ sub roles {
if (ref $self->_roles eq 'ARRAY') {
return(@{$self->_roles});
}
-
+
my @roles = ();
if (exists($self->config->{'role_column'})) {
my $role_data = $self->get($self->config->{'role_column'});
- if ($role_data) {
+ if ($role_data) {
@roles = split /[\s,\|]+/, $self->get($self->config->{'role_column'});
}
$self->_roles(\@roles);
} elsif (exists($self->config->{'role_relation'})) {
my $relation = $self->config->{'role_relation'};
if ($self->_user->$relation->result_source->has_column($self->config->{'role_field'})) {
- @roles = map { $_->get_column($self->config->{'role_field'}) } $self->_user->$relation->search(undef, { columns => [ $self->config->{'role_field'}]})->all();
+ @roles = map {
+ $_->get_column($self->config->{role_field})
+ } $self->_user->$relation->search(undef, {
+ columns => [ $self->config->{role_field} ]
+ })->all;
$self->_roles(\@roles);
} else {
Catalyst::Exception->throw("role table does not have a column called " . $self->config->{'role_field'});
@@ -148,59 +156,64 @@ sub roles {
sub for_session {
my $self = shift;
-
+
#return $self->get($self->config->{'id_field'});
-
+
#my $frozenuser = $self->_user->result_source->schema->freeze( $self->_user );
#return $frozenuser;
-
+
my %userdata = $self->_user->get_columns();
return \%userdata;
}
sub from_session {
my ($self, $frozenuser, $c) = @_;
-
+
#my $obj = $self->resultset->result_source->schema->thaw( $frozenuser );
#$self->_user($obj);
-
+
#if (!exists($self->config->{'use_userdata_from_session'}) || $self->config->{'use_userdata_from_session'} == 0) {
# $self->_user->discard_changes();
# }
-#
+#
# return $self;
-#
+#
## 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)
- {
+ if (exists($self->config->{'use_userdata_from_session'}) && $self->config->{'use_userdata_from_session'} != 0) {
my $obj = $self->resultset->new_result({ %$frozenuser });
$obj->in_storage(1);
$self->_user($obj);
return $self;
- } else {
- my $id;
- if (ref($frozenuser) eq 'HASH') {
- $id = $frozenuser->{$self->config->{'id_field'}};
- } else {
- $id = $frozenuser;
- }
- return $self->load( { $self->config->{'id_field'} => $id }, $c);
}
+
+ if (ref $frozenuser eq 'HASH') {
+ return $self->load({
+ map { ($_ => $frozenuser->{$_}) }
+ @{ $self->config->{id_field} }
+ });
+ }
+
+ return $self->load( { $self->config->{'id_field'} => $frozenuser }, $c);
}
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;
}
}
sub get_object {
my ($self, $force) = @_;
-
+
if ($force) {
$self->_user->discard_changes;
}
@@ -210,7 +223,7 @@ sub get_object {
sub obj {
my ($self, $force) = @_;
-
+
return $self->get_object($force);
}
@@ -225,14 +238,40 @@ sub auto_update {
$self->_user->auto_update( @_ );
}
+sub can {
+ my $self = shift;
+ return $self->SUPER::can(@_) || do {
+ my ($method) = @_;
+ if (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(@_);
+ 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__
@@ -244,7 +283,7 @@ module.
=head1 VERSION
-This documentation refers to version 0.10.
+This documentation refers to version 0.1400.
=head1 SYNOPSIS
@@ -253,7 +292,7 @@ L<Catalyst::Authentication::Store::DBIx::Class> for details on how to
use this module. If you need more information than is present there, read the
source.
-
+
=head1 DESCRIPTION
@@ -262,11 +301,11 @@ connected to an underlying DBIx::Class schema object.
=head1 SUBROUTINES / METHODS
-=head2 new
+=head2 new
Constructor.
-=head2 load ( $authinfo, $c )
+=head2 load ( $authinfo, $c )
Retrieves a user from storage using the information provided in $authinfo.
@@ -280,18 +319,18 @@ Returns an array of roles associated with this user, if roles are configured for
=head2 for_session
-Returns a serialized user for storage in the session.
+Returns a serialized user for storage in the session.
=head2 from_session
-Revives a serialized user from storage in the session.
+Revives a serialized user from storage in the session.
=head2 get ( $fieldname )
-Returns the value of $fieldname for the user in question. Roughly translates to a call to
+Returns the value of $fieldname for the user in question. Roughly translates to a call to
the DBIx::Class::Row's get_column( $fieldname ) routine.
-=head2 get_object
+=head2 get_object
Retrieves the DBIx::Class object that corresponds to this user
@@ -301,8 +340,8 @@ Synonym for get_object
=head2 auto_create
-This is called when the auto_create_user option is turned on in
-Catalyst::Plugin::Authentication and a user matching the authinfo provided is not found.
+This is called when the auto_create_user option is turned on in
+Catalyst::Plugin::Authentication and a user matching the authinfo provided is not found.
By default, this will call the C<auto_create()> method of the resultset associated
with this object. It is up to you to implement that method.
@@ -322,6 +361,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 underlieing user row.
+
+=head2 can
+
+Delegates handling of the C<< can >> method to the underlieing user row.
+
=head1 BUGS AND LIMITATIONS
None known currently, please email the author if you find any.
@@ -330,9 +377,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.
@@ -4,7 +4,7 @@ use strict;
use warnings;
use base qw/Class::Accessor::Fast/;
-our $VERSION= "0.1083";
+our $VERSION= "0.1400";
BEGIN {
@@ -15,16 +15,16 @@ BEGIN {
sub new {
my ( $class, $config, $app ) = @_;
- ## figure out if we are overriding the default store user class
+ ## figure out if we are overriding the default store user class
$config->{'store_user_class'} = (exists($config->{'store_user_class'})) ? $config->{'store_user_class'} :
"Catalyst::Authentication::Store::DBIx::Class::User";
## make sure the store class is loaded.
Catalyst::Utils::ensure_class_loaded( $config->{'store_user_class'} );
-
+
## fields can be specified to be ignored during user location. This allows
## the store to ignore certain fields in the authinfo hash.
-
+
$config->{'ignore_fields_in_find'} ||= [ ];
my $self = {
@@ -39,7 +39,7 @@ sub new {
## let's use DBIC's get_columns method to return a hash and save / restore that
## from the session. Then we can respond to get() calls, etc. in most cases without
## resorting to a DB call. If user_object is called, THEN we can hit the DB and
-## return a real object.
+## return a real object.
sub from_session {
my ( $self, $c, $frozenuser ) = @_;
@@ -51,13 +51,13 @@ sub from_session {
sub for_session {
my ($self, $c, $user) = @_;
-
+
return $user->for_session($c);
}
sub find_user {
my ( $self, $authinfo, $c ) = @_;
-
+
my $user = $self->config->{'store_user_class'}->new($self->{'config'}, $c);
return $user->load($authinfo, $c);
@@ -92,7 +92,7 @@ Catalyst::Authentication::Store::DBIx::Class - A storage class for Catalyst Auth
=head1 VERSION
-This documentation refers to version 0.108.
+This documentation refers to version 0.1400.
=head1 SYNOPSIS
@@ -100,8 +100,8 @@ This documentation refers to version 0.108.
Authentication
Authorization::Roles/;
- __PACKAGE__->config->{authentication} =
- {
+ __PACKAGE__->config->{authentication} =
+ {
default_realm => 'members',
realms => {
members => {
@@ -114,33 +114,33 @@ This documentation refers to version 0.108.
class => 'DBIx::Class',
user_model => 'MyApp::User',
role_relation => 'roles',
- role_field => 'rolename',
+ role_field => 'rolename',
}
}
}
};
# Log a user in:
-
+
sub login : Global {
my ( $self, $c ) = @_;
-
- $c->authenticate({
- screen_name => $c->req->params->username,
- password => $c->req->params->password,
+
+ $c->authenticate({
+ screen_name => $c->req->params->{username},
+ password => $c->req->params->{password},
status => [ 'registered', 'loggedin', 'active']
}))
}
-
- # verify a role
-
+
+ # verify a role
+
if ( $c->check_user_roles( 'editor' ) ) {
# do editor stuff
}
-
+
=head1 DESCRIPTION
-The Catalyst::Authentication::Store::DBIx::Class class provides
+The Catalyst::Authentication::Store::DBIx::Class class provides
access to authentication information stored in a database via DBIx::Class.
=head1 CONFIGURATION
@@ -154,8 +154,8 @@ L<Catalyst::Authentication::Realm::SimpleDB> for a simplified setup.
The DBIx::Class storage module has several configuration options
- __PACKAGE__->config->{authentication} =
- {
+ __PACKAGE__->config->{authentication} =
+ {
default_realm => 'members',
realms => {
members => {
@@ -168,7 +168,7 @@ The DBIx::Class storage module has several configuration options
role_relation => 'roles',
role_field => 'rolename',
ignore_fields_in_find => [ 'remote_name' ],
- use_userdata_from_session => 1,
+ use_userdata_from_session => 1,
}
}
}
@@ -186,7 +186,7 @@ contains the class name of the store to be used.
Contains the model name (as passed to $c->model()) of the DBIx::Class schema
to use as the source for user information. This config item is B<REQUIRED>.
-(Note that this option used to be called C<< user_class >>. C<< user_class >> is
+(Note that this option used to be called C<< user_class >>. C<< user_class >> is
still functional, but should be used only for compatibility with previous configs.
The setting called C<< user_class >> on other authentication stores is
present, but named C<< store_user_class >> in this store)
@@ -196,21 +196,21 @@ present, but named C<< store_user_class >> in this store)
If your role information is stored in the same table as the rest of your user
information, this item tells the module which field contains your role
information. The DBIx::Class authentication store expects the data in this
-field to be a series of role names separated by some combination of spaces,
-commas, or pipe characters.
+field to be a series of role names separated by some combination of spaces,
+commas, or pipe characters.
=item role_relation
If your role information is stored in a separate table, this is the name of
-the relation that will lead to the roles the user is in. If this is
+the relation that will lead to the roles the user is in. If this is
specified, then a role_field is also required. Also when using this method
-it is expected that your role table will return one row for each role
+it is expected that your role table will return one row for each role
the user is in.
=item role_field
-This is the name of the field in the role table that contains the string
-identifying the role.
+This is the name of the field in the role table that contains the string
+identifying the role.
=item ignore_fields_in_find
@@ -223,64 +223,64 @@ If this doesn't make sense to you, you probably don't need it.
=item use_userdata_from_session
-Under normal circumstances, on each request the user's data is re-retrieved
-from the database using the primary key for the user table. When this flag
+Under normal circumstances, on each request the user's data is re-retrieved
+from the database using the primary key for the user table. When this flag
is set in the configuration, it causes the DBIx::Class store to avoid this
-database hit on session restore. Instead, the user object's column data
-is retrieved from the session and used as-is.
+database hit on session restore. Instead, the user object's column data
+is retrieved from the session and used as-is.
B<NOTE>: Since the user object's column
-data is only stored in the session during the initial authentication of
+data is only stored in the session during the initial authentication of
the user, turning this on can potentially lead to a situation where the data
in $c->user is different from what is stored the database. You can force
a reload of the data from the database at any time by calling $c->user->get_object(1);
-Note that this will update $c->user for the remainder of this request.
+Note that this will update $c->user for the remainder of this request.
It will NOT update the session. If you need to update the session
-you should call $c->update_user_in_session() as well.
+you should call $c->update_user_in_session() as well.
=item store_user_class
-This allows you to override the authentication user class that the
+This allows you to override the authentication user class that the
DBIx::Class store module uses to perform its work. Most of the
-work done in this module is actually done by the user class,
+work done in this module is actually done by the user class,
L<Catalyst::Authentication::Store::DBIx::Class::User>, so
overriding this doesn't make much sense unless you are using your
-own class to extend the functionality of the existing class.
+own class to extend the functionality of the existing class.
Chances are you do not want to set this.
=item id_field
In most cases, this config variable does not need to be set, as
Catalyst::Authentication::Store::DBIx::Class will determine the primary
-key of the user table on its own. If you need to override the default,
+key of the user table on its own. If you need to override the default,
or your user table has multiple primary keys, then id_field
should contain the column name that should be used to restore the user.
A given value in this column should correspond to a single user in the database.
-Note that this is used B<ONLY> when restoring a user from the session and
+Note that this is used B<ONLY> when restoring a user from the session and
has no bearing whatsoever in the initial authentication process. Note also
that if use_userdata_from_session is enabled, this config parameter
is not used at all.
=back
-=head1 USAGE
+=head1 USAGE
The L<Catalyst::Authentication::Store::DBIx::Class> storage module
-is not called directly from application code. You interface with it
-through the $c->authenticate() call.
+is not called directly from application code. You interface with it
+through the $c->authenticate() call.
There are three methods you can use to retrieve information from the DBIx::Class
storage module. They are Simple retrieval, and the advanced retrieval methods
Searchargs and Resultset.
-=head2 Simple Retrieval
+=head2 Simple Retrieval
The first, and most common, method is simple retrieval. As its name implies
simple retrieval allows you to simply to provide the column => value pairs
that should be used to locate the user in question. An example of this usage
is below:
- if ($c->authenticate({
+ if ($c->authenticate({
screen_name => $c->req->params->{'username'},
password => $c->req->params->{'password'},
status => [ 'registered', 'active', 'loggedin']
@@ -289,7 +289,7 @@ is below:
# ... authenticated user code here
}
-The above example would attempt to retrieve a user whose username column (here,
+The above example would attempt to retrieve a user whose username column (here,
screen_name) matched the username provided, and whose status column matched one of the
values provided. These name => value pairs are used more or less directly in
the DBIx::Class search() routine, so in most cases, you can use DBIx::Class
@@ -314,16 +314,16 @@ functionality, see the 'searchargs' method below.
The Searchargs and Resultset retrieval methods are used when more advanced
features of the underlying L<DBIx::Class> schema are required. These methods
provide a direct interface with the DBIx::Class schema and therefore
-require a better understanding of the DBIx::Class module.
+require a better understanding of the DBIx::Class module.
=head3 The dbix_class key
Since the format of these arguments are often complex, they are not keys in
-the base authinfo hash. Instead, both of these arguments are placed within
-a hash attached to the store-specific 'dbix_class' key in the base $authinfo
+the base authinfo hash. Instead, both of these arguments are placed within
+a hash attached to the store-specific 'dbix_class' key in the base $authinfo
hash. When the DBIx::Class authentication store sees the 'dbix_class' key
in the passed authinfo hash, all the other information in the authinfo hash
-is ignored and only the values within the 'dbix_class' hash are used as
+is ignored and only the values within the 'dbix_class' hash are used as
though they were passed directly within the authinfo hash. In other words, if
'dbix_class' is present, it replaces the authinfo hash for processing purposes.
@@ -332,7 +332,7 @@ DBIx::Class authentication store. Reasons to do this are to avoid credential
modification of the authinfo hash, or to avoid overlap between credential and
store key names. It's a good idea to avoid using it in this way unless you are
sure you have an overlap/modification issue. However, the two advanced
-retrieval methods, B<searchargs> and B<resultset>, require its use, as they
+retrieval methods, B<searchargs> and B<resultset>, require its use, as they
are only processed as part of the 'dbix_class' hash.
=over 4
@@ -345,18 +345,18 @@ all other args are ignored, and the search args provided are used directly to lo
the user. An example will probably make more sense:
if ($c->authenticate(
- {
+ {
password => $password,
- 'dbix_class' =>
+ 'dbix_class' =>
{
searchargs => [ { -or => [ username => $username,
email => $email,
- clientid => $clientid ]
+ clientid => $clientid ]
},
- { prefetch => qw/ preferences / }
+ { prefetch => qw/ preferences / }
]
}
- } ) )
+ } ) )
{
# do successful authentication actions here.
}
@@ -374,13 +374,13 @@ within your login action and use it for retrieving the user. A simple example:
my $rs = $c->model('MyApp::User')->search({ email => $c->request->params->{'email'} });
... # further $rs adjustments
-
- if ($c->authenticate({
+
+ if ($c->authenticate({
password => $password,
'dbix_class' => { resultset => $rs }
})) {
# do successful authentication actions here.
- }
+ }
Be aware that the resultset method will not verify that you are passing a
resultset that is attached to the same user_model as specified in the config.
@@ -394,13 +394,13 @@ search(...)->first;
NOTE ALSO: The user info used to save the user to the session and to retrieve
it is the same regardless of what method of retrieval was used. In short,
-the value in the id field (see 'id_field' config item) is used to retrieve the
+the value in the id field (see 'id_field' config item) is used to retrieve the
user from the database upon restoring from the session. When the DBIx::Class storage
module does this, it does so by doing a simple search using the id field. In other
-words, it will not use the same arguments you used to request the user initially.
-This is especially important to those using the advanced methods of user retrieval.
+words, it will not use the same arguments you used to request the user initially.
+This is especially important to those using the advanced methods of user retrieval.
If you need more complicated logic when reviving the user from the session, you will
-most likely want to subclass the L<Catalyst::Authentication::Store::DBIx::Class::User> class
+most likely want to subclass the L<Catalyst::Authentication::Store::DBIx::Class::User> class
and provide your own for_session and from_session routines.
=back
@@ -408,10 +408,10 @@ and provide your own for_session and from_session routines.
=head1 METHODS
-There are no publicly exported routines in the DBIx::Class authentication
-store (or indeed in most authentication stores). However, below is a
-description of the routines required by L<Catalyst::Plugin::Authentication>
-for all authentication stores. Please see the documentation for
+There are no publicly exported routines in the DBIx::Class authentication
+store (or indeed in most authentication stores). However, below is a
+description of the routines required by L<Catalyst::Plugin::Authentication>
+for all authentication stores. Please see the documentation for
L<Catalyst::Plugin::Authentication::Internals> for more information.
@@ -419,7 +419,7 @@ L<Catalyst::Plugin::Authentication::Internals> for more information.
Constructs a new store object.
-=head2 find_user ( $authinfo, $c )
+=head2 find_user ( $authinfo, $c )
Finds a user using the information provided in the $authinfo hashref and
returns the user, or undef on failure. This is usually called from the
@@ -438,7 +438,7 @@ Currently treats $frozenuser as an id and retrieves a user with a matching id.
=head2 user_supports
-Provides information about what the user object supports.
+Provides information about what the user object supports.
=head2 auto_update_user( $authinfo, $c, $res )
@@ -1,6 +1,10 @@
-#!perl -T
+#!perl
use Test::More;
+
+plan skip_all => 'Set TEST_POD to enable pod tests' unless $ENV{TEST_POD};
+
eval "use Test::Pod 1.14";
plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+
all_pod_files_ok();
@@ -1,6 +1,10 @@
-#!perl -T
+#!perl
use Test::More;
+
+plan skip_all => 'Set TEST_POD to enable pod tests' unless $ENV{TEST_POD};
+
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+
all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::CountParents' });
@@ -19,8 +19,6 @@ BEGIN {
plan tests => 17;
- $ENV{TESTAPP_DB_FILE} = "$FindBin::Bin/auth.db" unless exists($ENV{TESTAPP_DB_FILE});
-
$ENV{TESTAPP_CONFIG} = {
name => 'TestApp',
authentication => {
@@ -46,8 +44,6 @@ BEGIN {
];
}
-use SetupDB;
-
use Catalyst::Test 'TestApp';
# log a user in
@@ -105,10 +101,3 @@ use Catalyst::Test 'TestApp';
my $res = request('http://localhost/user_login?username=joeuser&password=hackme');
like( $res->content, qr/\$\Qc->model('Nonexistent::Class') did not return a resultset. Did you set user_model correctly?/, 'test for wrong user_class' );
}
-
-
-
-
-
-# clean up
-unlink $ENV{TESTAPP_DB_FILE};
@@ -21,7 +21,7 @@ BEGIN {
or plan skip_all =>
"DBIx::Class is required for this test";
- eval { require Catalyst::Plugin::Session;
+ eval { require Catalyst::Plugin::Session;
die unless $Catalyst::Plugin::Session::VERSION >= 0.02 }
or plan skip_all =>
"Catalyst::Plugin::Session >= 0.02 is required for this test";
@@ -33,8 +33,6 @@ BEGIN {
plan tests => 8;
- $ENV{TESTAPP_DB_FILE} = "$FindBin::Bin/auth.db" unless exists($ENV{TESTAPP_DB_FILE});
-
$ENV{TESTAPP_CONFIG} = {
name => 'TestApp',
authentication => {
@@ -65,8 +63,6 @@ BEGIN {
];
}
-use SetupDB;
-
use Test::WWW::Mechanize::Catalyst 'TestApp';
my $m = Test::WWW::Mechanize::Catalyst->new;
@@ -93,6 +89,3 @@ my $m = Test::WWW::Mechanize::Catalyst->new;
$m->get_ok( 'http://localhost/get_session_user', undef, 'request ok' );
$m->content_is( '', "user's session deleted" );
}
-
-# clean up
-unlink $ENV{TESTAPP_DB_FILE};
@@ -23,9 +23,6 @@ BEGIN {
plan tests => 8;
- $ENV{TESTAPP_DB_FILE} = "$FindBin::Bin/auth.db" unless exists($ENV{TESTAPP_DB_FILE});
-
-
$ENV{TESTAPP_CONFIG} = {
name => 'TestApp',
authentication => {
@@ -55,8 +52,6 @@ BEGIN {
];
}
-use SetupDB;
-
use Catalyst::Test 'TestApp';
# test user's admin access
@@ -82,6 +77,3 @@ use Catalyst::Test 'TestApp';
ok( my $res = request('http://localhost/user_login?username=nuffin&password=much&detach=is_admin_user'), 'request ok' );
is( $res->content, 'failed', 'user is not an admin and a user' );
}
-
-# clean up
-unlink $ENV{TESTAPP_DB_FILE};
@@ -23,9 +23,6 @@ BEGIN {
plan tests => 8;
- $ENV{TESTAPP_DB_FILE} = "$FindBin::Bin/auth.db" unless exists($ENV{TESTAPP_DB_FILE});
-
-
$ENV{TESTAPP_CONFIG} = {
name => 'TestApp',
authentication => {
@@ -54,8 +51,6 @@ BEGIN {
];
}
-use SetupDB;
-
use Catalyst::Test 'TestApp';
# test user's admin access
@@ -81,6 +76,3 @@ use Catalyst::Test 'TestApp';
ok( my $res = request('http://localhost/user_login?username=joeuser&password=hackme&detach=is_admin_user'), 'request ok' );
is( $res->content, 'failed', 'user is not an admin and a user' );
}
-
-# clean up
-unlink $ENV{TESTAPP_DB_FILE};
@@ -21,7 +21,7 @@ BEGIN {
or plan skip_all =>
"DBIx::Class is required for this test";
- eval { require Catalyst::Plugin::Session;
+ eval { require Catalyst::Plugin::Session;
die unless $Catalyst::Plugin::Session::VERSION >= 0.02 }
or plan skip_all =>
"Catalyst::Plugin::Session >= 0.02 is required for this test";
@@ -33,8 +33,6 @@ BEGIN {
plan tests => 8;
- $ENV{TESTAPP_DB_FILE} = "$FindBin::Bin/auth.db" unless exists($ENV{TESTAPP_DB_FILE});
-
$ENV{TESTAPP_CONFIG} = {
name => 'TestApp',
authentication => {
@@ -65,8 +63,6 @@ BEGIN {
];
}
-use SetupDB;
-
use Test::WWW::Mechanize::Catalyst 'TestApp';
my $m = Test::WWW::Mechanize::Catalyst->new;
@@ -93,6 +89,3 @@ my $m = Test::WWW::Mechanize::Catalyst->new;
$m->get_ok( 'http://localhost/get_session_user', undef, 'request ok' );
$m->content_is( '', "user's session deleted" );
}
-
-# clean up
-unlink $ENV{TESTAPP_DB_FILE};
@@ -23,9 +23,6 @@ BEGIN {
plan tests => 8;
- $ENV{TESTAPP_DB_FILE} = "$FindBin::Bin/auth.db" unless exists($ENV{TESTAPP_DB_FILE});
-
-
$ENV{TESTAPP_CONFIG} = {
name => 'TestApp',
'Plugin::Authentication' => {
@@ -44,8 +41,6 @@ BEGIN {
];
}
-use SetupDB;
-
use Catalyst::Test 'TestApp';
# test user's admin access
@@ -71,6 +66,3 @@ use Catalyst::Test 'TestApp';
ok( my $res = request('http://localhost/user_login?username=nuffin&password=much&detach=is_admin_user'), 'request ok' );
is( $res->content, 'failed', 'user is not an admin and a user' );
}
-
-# clean up
-unlink $ENV{TESTAPP_DB_FILE};
@@ -23,9 +23,6 @@ BEGIN {
plan tests => 8;
- $ENV{TESTAPP_DB_FILE} = "$FindBin::Bin/auth.db" unless exists($ENV{TESTAPP_DB_FILE});
-
-
$ENV{TESTAPP_CONFIG} = {
name => 'TestApp',
'Plugin::Authentication' => {
@@ -36,7 +33,7 @@ BEGIN {
password_type => 'clear'
}
}
-
+
};
$ENV{TESTAPP_PLUGINS} = [
@@ -46,8 +43,6 @@ BEGIN {
];
}
-use SetupDB;
-
use Catalyst::Test 'TestApp';
# test user's admin access
@@ -73,6 +68,3 @@ use Catalyst::Test 'TestApp';
ok( my $res = request('http://localhost/user_login?username=joeuser&password=hackme&detach=is_admin_user'), 'request ok' );
is( $res->content, 'failed', 'user is not an admin and a user' );
}
-
-# clean up
-unlink $ENV{TESTAPP_DB_FILE};
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+use Test::More;
+use Catalyst::Authentication::Store::DBIx::Class::User;
+
+my $message = 'I exist';
+
+{
+ package My::Test;
+
+ sub exists { $message }
+}
+
+my $o = bless({
+ _user => bless({}, 'My::Test'),
+}, 'Catalyst::Authentication::Store::DBIx::Class::User');
+
+is($o->exists, $message, 'AUTOLOAD proxies ok');
+
+ok(my $meth = $o->can('exists'), 'can returns true');
+
+is($o->$meth, $message, 'can returns right coderef');
+
+is($o->can('non_existent_method'), undef, 'can on non existent method returns undef');
+
+done_testing;
@@ -1,37 +0,0 @@
-# create the database
-my $db_file = $ENV{TESTAPP_DB_FILE};
-unlink $db_file if -e $db_file;
-
-my $dbh = DBI->connect( "dbi:SQLite:$db_file" ) or die $DBI::errstr;
-my $sql = q{
- CREATE TABLE user (
- id INTEGER PRIMARY KEY,
- username TEXT,
- email TEXT,
- password TEXT,
- status TEXT,
- role_text TEXT,
- session_data TEXT
- );
- CREATE TABLE role (
- id INTEGER PRIMARY KEY,
- role TEXT
- );
- CREATE TABLE user_role (
- id INTEGER PRIMARY KEY,
- user INTEGER,
- roleid INTEGER
- );
-
- INSERT INTO user VALUES (1, 'joeuser', 'joeuser@nowhere.com', 'hackme', 'active', 'admin', NULL);
- INSERT INTO user VALUES (2, 'spammer', 'bob@spamhaus.com', 'broken', 'disabled', NULL, NULL);
- INSERT INTO user VALUES (3, 'jayk', 'j@cpants.org', 'letmein', 'active', NULL, NULL);
- INSERT INTO user VALUES (4, 'nuffin', 'nada@mucho.net', 'much', 'registered', 'user admin', NULL);
- INSERT INTO role VALUES (1, 'admin');
- INSERT INTO role VALUES (2, 'user');
- INSERT INTO user_role VALUES (1, 3, 1);
- INSERT INTO user_role VALUES (2, 3, 2);
- INSERT INTO user_role VALUES (3, 4, 2)
-};
-$dbh->do( $_ ) for split /;/, $sql;
-$dbh->disconnect;
\ No newline at end of file
@@ -0,0 +1,192 @@
+package TestApp::Controller::Root;
+
+use Moose;
+
+BEGIN { extends 'Catalyst::Controller' }
+
+__PACKAGE__->config(namespace => '');
+
+sub user_login : Global {
+ my ( $self, $c ) = @_;
+
+ ## this allows anyone to login regardless of status.
+ eval {
+ $c->authenticate({ username => $c->request->params->{'username'},
+ password => $c->request->params->{'password'}
+ });
+ 1;
+ } or do {
+ return $c->res->body($@);
+ };
+
+ if ( $c->user_exists ) {
+ if ( $c->req->params->{detach} ) {
+ $c->detach( $c->req->params->{detach} );
+ }
+ $c->res->body( $c->user->get('username') . ' logged in' );
+ }
+ else {
+ $c->res->body( 'not logged in' );
+ }
+}
+
+
+sub notdisabled_login : Global {
+ my ( $self, $c ) = @_;
+
+ $c->authenticate({ username => $c->request->params->{'username'},
+ password => $c->request->params->{'password'},
+ status => [ 'active', 'registered' ]
+ });
+
+ if ( $c->user_exists ) {
+ if ( $c->req->params->{detach} ) {
+ $c->detach( $c->req->params->{detach} );
+ }
+ $c->res->body( $c->user->get('username') . ' logged in' );
+ }
+ else {
+ $c->res->body( 'not logged in' );
+ }
+}
+
+sub searchargs_login : Global {
+ my ( $self, $c ) = @_;
+
+ my $username = $c->request->params->{'username'} || '';
+ my $email = $c->request->params->{'email'} || '';
+
+ $c->authenticate({
+ password => $c->request->params->{'password'},
+ dbix_class => {
+ searchargs => [ { "-or" => [ username => $username,
+ email => $email ]},
+ { prefetch => qw/ map_user_role /}
+ ]
+ }
+ });
+
+ if ( $c->user_exists ) {
+ if ( $c->req->params->{detach} ) {
+ $c->detach( $c->req->params->{detach} );
+ }
+ $c->res->body( $c->user->get('username') . ' logged in' );
+ }
+ else {
+ $c->res->body( 'not logged in' );
+ }
+}
+
+sub resultset_login : Global {
+ my ( $self, $c ) = @_;
+
+ my $username = $c->request->params->{'username'} || '';
+ my $email = $c->request->params->{'email'} || '';
+
+
+ my $rs = $c->model('TestApp::User')->search({ "-or" => [ username => $username,
+ email => $email ]});
+
+ $c->authenticate({
+ password => $c->request->params->{'password'},
+ dbix_class => { resultset => $rs }
+ });
+
+ if ( $c->user_exists ) {
+ if ( $c->req->params->{detach} ) {
+ $c->detach( $c->req->params->{detach} );
+ }
+ $c->res->body( $c->user->get('username') . ' logged in' );
+ }
+ else {
+ $c->res->body( 'not logged in' );
+ }
+}
+
+sub bad_login : Global {
+ my ( $self, $c ) = @_;
+
+ ## this allows anyone to login regardless of status.
+ eval {
+ $c->authenticate({ william => $c->request->params->{'username'},
+ the_bum => $c->request->params->{'password'}
+ });
+ 1;
+ } or do {
+ return $c->res->body($@);
+ };
+
+ if ( $c->user_exists ) {
+ if ( $c->req->params->{detach} ) {
+ $c->detach( $c->req->params->{detach} );
+ }
+ $c->res->body( $c->user->get('username') . ' logged in' );
+ }
+ else {
+ $c->res->body( 'not logged in' );
+ }
+}
+
+## need to add a resultset login test and a search args login test
+
+sub user_logout : Global {
+ my ( $self, $c ) = @_;
+
+ $c->logout;
+
+ if ( ! $c->user ) {
+ $c->res->body( 'logged out' );
+ }
+ else {
+ $c->res->body( 'not logged ok' );
+ }
+}
+
+sub get_session_user : Global {
+ my ( $self, $c ) = @_;
+
+ if ( $c->user_exists ) {
+ $c->res->body($c->user->get('username')); # . " " . Dumper($c->user->get_columns()) );
+ }
+}
+
+sub is_admin : Global {
+ my ( $self, $c ) = @_;
+
+ eval {
+ if ( $c->assert_user_roles( qw/admin/ ) ) {
+ $c->res->body( 'ok' );
+ }
+ };
+ if ($@) {
+ $c->res->body( 'failed' );
+ }
+}
+
+sub is_admin_user : Global {
+ my ( $self, $c ) = @_;
+
+ eval {
+ if ( $c->assert_user_roles( qw/admin user/ ) ) {
+ $c->res->body( 'ok' );
+ }
+ };
+ if ($@) {
+ $c->res->body( 'failed' );
+ }
+}
+
+sub set_usersession : Global {
+ my ( $self, $c, $value ) = @_;
+ $c->user_session->{foo} = $value;
+ $c->res->body( 'ok' );
+}
+
+sub get_usersession : Global {
+ my ( $self, $c ) = @_;
+ $c->res->body( $c->user_session->{foo} || '' );
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
@@ -3,17 +3,46 @@ package TestApp::Model::TestApp;
use base qw/Catalyst::Model::DBIC::Schema/;
use strict;
-
-our $db_file = $ENV{TESTAPP_DB_FILE};
+my @deployment_statements = split /;/, q{
+ CREATE TABLE user (
+ id INTEGER PRIMARY KEY,
+ username TEXT,
+ email TEXT,
+ password TEXT,
+ status TEXT,
+ role_text TEXT,
+ session_data TEXT
+ );
+ CREATE TABLE role (
+ id INTEGER PRIMARY KEY,
+ role TEXT
+ );
+ CREATE TABLE user_role (
+ id INTEGER PRIMARY KEY,
+ user INTEGER,
+ roleid INTEGER
+ );
+
+ INSERT INTO user VALUES (1, 'joeuser', 'joeuser@nowhere.com', 'hackme', 'active', 'admin', NULL);
+ INSERT INTO user VALUES (2, 'spammer', 'bob@spamhaus.com', 'broken', 'disabled', NULL, NULL);
+ INSERT INTO user VALUES (3, 'jayk', 'j@cpants.org', 'letmein', 'active', NULL, NULL);
+ INSERT INTO user VALUES (4, 'nuffin', 'nada@mucho.net', 'much', 'registered', 'user admin', NULL);
+ INSERT INTO role VALUES (1, 'admin');
+ INSERT INTO role VALUES (2, 'user');
+ INSERT INTO user_role VALUES (1, 3, 1);
+ INSERT INTO user_role VALUES (2, 3, 2);
+ INSERT INTO user_role VALUES (3, 4, 2)
+};
__PACKAGE__->config(
schema_class => 'TestApp::Schema',
- connect_info => [ "dbi:SQLite:$db_file",
- '',
- '',
- { AutoCommit => 1 },
- ],
-
+ connect_info => [
+ "dbi:SQLite:dbname=:memory:",
+ '',
+ '',
+ { AutoCommit => 1 },
+ { on_connect_do => \@deployment_statements },
+ ],
);
# Load all of the classes
@@ -7,7 +7,11 @@ use base 'DBIx::Class';
__PACKAGE__->load_components(qw/ Core /);
__PACKAGE__->table( 'user' );
-__PACKAGE__->add_columns( qw/id username email password status role_text session_data/ );
+
+__PACKAGE__->add_columns( qw/id username email status role_text session_data/ );
+
+__PACKAGE__->add_column(password => { accessor => 'password_accessor' });
+
__PACKAGE__->set_primary_key( 'id' );
__PACKAGE__->has_many( 'map_user_role' => 'TestApp::Schema::UserRole' => 'user' );
@@ -8,186 +8,4 @@ TestApp->config( $ENV{TESTAPP_CONFIG} );
TestApp->setup( @{$ENV{TESTAPP_PLUGINS}} );
-sub user_login : Global {
- my ( $self, $c ) = @_;
-
- ## this allows anyone to login regardless of status.
- eval {
- $c->authenticate({ username => $c->request->params->{'username'},
- password => $c->request->params->{'password'}
- });
- 1;
- } or do {
- return $c->res->body($@);
- };
-
- if ( $c->user_exists ) {
- if ( $c->req->params->{detach} ) {
- $c->detach( $c->req->params->{detach} );
- }
- $c->res->body( $c->user->get('username') . ' logged in' );
- }
- else {
- $c->res->body( 'not logged in' );
- }
-}
-
-
-sub notdisabled_login : Global {
- my ( $self, $c ) = @_;
-
- $c->authenticate({ username => $c->request->params->{'username'},
- password => $c->request->params->{'password'},
- status => [ 'active', 'registered' ]
- });
-
- if ( $c->user_exists ) {
- if ( $c->req->params->{detach} ) {
- $c->detach( $c->req->params->{detach} );
- }
- $c->res->body( $c->user->get('username') . ' logged in' );
- }
- else {
- $c->res->body( 'not logged in' );
- }
-}
-
-sub searchargs_login : Global {
- my ( $self, $c ) = @_;
-
- my $username = $c->request->params->{'username'} || '';
- my $email = $c->request->params->{'email'} || '';
-
- $c->authenticate({
- password => $c->request->params->{'password'},
- dbix_class => {
- searchargs => [ { "-or" => [ username => $username,
- email => $email ]},
- { prefetch => qw/ map_user_role /}
- ]
- }
- });
-
- if ( $c->user_exists ) {
- if ( $c->req->params->{detach} ) {
- $c->detach( $c->req->params->{detach} );
- }
- $c->res->body( $c->user->get('username') . ' logged in' );
- }
- else {
- $c->res->body( 'not logged in' );
- }
-}
-
-sub resultset_login : Global {
- my ( $self, $c ) = @_;
-
- my $username = $c->request->params->{'username'} || '';
- my $email = $c->request->params->{'email'} || '';
-
-
- my $rs = $c->model('TestApp::User')->search({ "-or" => [ username => $username,
- email => $email ]});
-
- $c->authenticate({
- password => $c->request->params->{'password'},
- dbix_class => { resultset => $rs }
- });
-
- if ( $c->user_exists ) {
- if ( $c->req->params->{detach} ) {
- $c->detach( $c->req->params->{detach} );
- }
- $c->res->body( $c->user->get('username') . ' logged in' );
- }
- else {
- $c->res->body( 'not logged in' );
- }
-}
-
-sub bad_login : Global {
- my ( $self, $c ) = @_;
-
- ## this allows anyone to login regardless of status.
- eval {
- $c->authenticate({ william => $c->request->params->{'username'},
- the_bum => $c->request->params->{'password'}
- });
- 1;
- } or do {
- return $c->res->body($@);
- };
-
- if ( $c->user_exists ) {
- if ( $c->req->params->{detach} ) {
- $c->detach( $c->req->params->{detach} );
- }
- $c->res->body( $c->user->get('username') . ' logged in' );
- }
- else {
- $c->res->body( 'not logged in' );
- }
-}
-
-## need to add a resultset login test and a search args login test
-
-sub user_logout : Global {
- my ( $self, $c ) = @_;
-
- $c->logout;
-
- if ( ! $c->user ) {
- $c->res->body( 'logged out' );
- }
- else {
- $c->res->body( 'not logged ok' );
- }
-}
-
-sub get_session_user : Global {
- my ( $self, $c ) = @_;
-
- if ( $c->user_exists ) {
- $c->res->body($c->user->get('username')); # . " " . Dumper($c->user->get_columns()) );
- }
-}
-
-sub is_admin : Global {
- my ( $self, $c ) = @_;
-
- eval {
- if ( $c->assert_user_roles( qw/admin/ ) ) {
- $c->res->body( 'ok' );
- }
- };
- if ($@) {
- $c->res->body( 'failed' );
- }
-}
-
-sub is_admin_user : Global {
- my ( $self, $c ) = @_;
-
- eval {
- if ( $c->assert_user_roles( qw/admin user/ ) ) {
- $c->res->body( 'ok' );
- }
- };
- if ($@) {
- $c->res->body( 'failed' );
- }
-}
-
-sub set_usersession : Global {
- my ( $self, $c, $value ) = @_;
- $c->user_session->{foo} = $value;
- $c->res->body( 'ok' );
-}
-
-sub get_usersession : Global {
- my ( $self, $c ) = @_;
- $c->res->body( $c->user_session->{foo} || '' );
-}
-
-
1;