Catalyst-Authentication-Store-DBIx-Class-0.1506/0000755000175000017500000000000012317004570020602 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/lib/0000755000175000017500000000000012317004570021350 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/0000755000175000017500000000000012317004570023134 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/Authentication/0000755000175000017500000000000012317004570026113 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/Authentication/Store/0000755000175000017500000000000012317004570027207 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/Authentication/Store/DBIx/0000755000175000017500000000000012317004570027775 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/Authentication/Store/DBIx/Class/0000755000175000017500000000000012317004570031042 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/Authentication/Store/DBIx/Class/User.pm0000644000175000017500000003060312317004226032316 0ustar ilmariilmaripackage Catalyst::Authentication::Store::DBIx::Class::User; use Moose; use namespace::autoclean; extends 'Catalyst::Authentication::User'; use List::MoreUtils 'all'; use Try::Tiny; has 'config' => (is => 'rw'); has 'resultset' => (is => 'rw'); has '_user' => (is => 'rw'); has '_roles' => (is => 'rw'); sub new { my ( $class, $config, $c) = @_; $config->{user_model} = $config->{user_class} unless defined $config->{user_model}; my $self = { resultset => $c->model($config->{'user_model'}), config => $config, _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}; $self->config->{'id_field'} = [$self->{'resultset'}->result_source->primary_columns] unless exists $self->config->{'id_field'}; $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 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. # ## use $authinfo to fill in the user in that case? # } return $self; } 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 retrieval. ## these options are only available when using the dbix_class authinfo hash. if ($dbix_class_config && exists($authinfo->{'result'})) { $self->_user($authinfo->{'result'}); } elsif ($dbix_class_config && exists($authinfo->{'resultset'})) { $self->_user($authinfo->{'resultset'}->first); } elsif ($dbix_class_config && exists($authinfo->{'searchargs'})) { $self->_user($self->resultset->search(@{$authinfo->{'searchargs'}})->first); } 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 $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)) { $searchargs->{$key} = $authinfo->{$key}; } } 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." ); } } if ($self->get_object) { return $self; } else { return undef; } } sub supported_features { my $self = shift; return { session => 1, roles => 1, }; } sub roles { my ( $self ) = shift; ## this used to load @wantedroles - but that doesn't seem to be used by the roles plugin, so I dropped it. ## shortcut if we have already retrieved them 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) { @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; $self->_roles(\@roles); } else { Catalyst::Exception->throw("role table does not have a column called " . $self->config->{'role_field'}); } } else { Catalyst::Exception->throw("user->roles accessed, but no role configuration found"); } return @{$self->_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(); # If use_userdata_from_session is set, then store all of the columns of the user obj in the session if (exists($self->config->{'use_userdata_from_session'}) && $self->config->{'use_userdata_from_session'} != 0) { return \%userdata; } else { # Otherwise, we just need the PKs for load() to use. my %pk_fields = map { ($_ => $userdata{$_}) } @{ $self->config->{id_field} }; return \%pk_fields; } } sub from_session { 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) { # We need to use inflate_result here since we -are- inflating a # result object from cached data, not creating a fresh one. # Components such as EncodedColumn wrap new() to ensure that a # provided password is hashed on the way in, and re-running the # hash function on data being restored is expensive and incorrect. my $class = $self->resultset->result_class; my $source = $self->resultset->result_source; my $obj = $class->inflate_result($source, { %$frozenuser }); $obj->in_storage(1); $self->_user($obj); return $self; } if (ref $frozenuser eq 'HASH') { return $self->load({ map { ($_ => $frozenuser->{$_}) } @{ $self->config->{id_field} } }, $c); } return $self->load( { $self->config->{'id_field'} => $frozenuser }, $c); } sub get { my ($self, $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; } return $self->_user; } sub obj { my ($self, $force) = @_; return $self->get_object($force); } sub auto_create { my $self = shift; $self->_user( $self->resultset->auto_create( @_ ) ); return $self; } sub auto_update { my $self = shift; $self->_user->auto_update( @_ ); } sub can { my $self = shift; return $self->SUPER::can(@_) || do { my ($method) = @_; if (not ref $self) { undef; } elsif (not $self->_user) { undef; } elsif (my $code = $self->_user->can($method)) { sub { shift->_user->$code(@_) } } elsif (my $accessor = try { $self->_user->result_source->column_info($method)->{accessor} }) { sub { shift->_user->$accessor } } else { undef; } }; } sub AUTOLOAD { my $self = shift; (my $method) = (our $AUTOLOAD =~ /([^:]+)$/); return if $method eq "DESTROY"; return unless ref $self; if (my $code = $self->_user->can($method)) { return $self->_user->$code(@_); } elsif (my $accessor = try { $self->_user->result_source->column_info($method)->{accessor} }) { return $self->_user->$accessor(@_); } else { # XXX this should also throw return undef; } } __PACKAGE__->meta->make_immutable(inline_constructor => 0); 1; __END__ =head1 NAME Catalyst::Authentication::Store::DBIx::Class::User - The backing user class for the Catalyst::Authentication::Store::DBIx::Class storage module. =head1 VERSION This documentation refers to version 0.1506. =head1 SYNOPSIS Internal - not used directly, please see L for details on how to use this module. If you need more information than is present there, read the source. =head1 DESCRIPTION The Catalyst::Authentication::Store::DBIx::Class::User class implements user storage connected to an underlying DBIx::Class schema object. =head1 SUBROUTINES / METHODS =head2 new Constructor. =head2 load ( $authinfo, $c ) Retrieves a user from storage using the information provided in $authinfo. =head2 supported_features Indicates the features supported by this class. These are currently Roles and Session. =head2 roles Returns an array of roles associated with this user, if roles are configured for this user class. =head2 for_session Returns a serialized user for storage in the session. =head2 from_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 the DBIx::Class::Row's get_column( $fieldname ) routine. =head2 get_object Retrieves the DBIx::Class object that corresponds to this user =head2 obj (method) 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. By default, this will call the C method of the resultset associated with this object. It is up to you to implement that method. =head2 auto_update This is called when the auto_update_user option is turned on in Catalyst::Plugin::Authentication. Note that by default the DBIx::Class store uses every field in the authinfo hash to match the user. This means any information you provide with the intent to update must be ignored during the user search process. Otherwise the information will most likely cause the user record to not be found. To ignore fields in the search process, you have to add the fields you wish to update to the 'ignore_fields_in_find' authinfo element. Alternately, you can use one of the advanced row retrieval methods (searchargs or resultset). By default, auto_update will call the C method of the DBIx::Class::Row object associated with the user. It is up to you to implement that method (probably in your schema file) =head2 AUTOLOAD Delegates method calls to the underlying user row. =head2 can Delegates handling of the C<< can >> method to the underlying user row. =head1 BUGS AND LIMITATIONS None known currently, please email the author if you find any. =head1 AUTHOR Jason Kuri (jayk@cpan.org) =head1 CONTRIBUTORS Matt S Trout (mst) (fixes wrt can/AUTOLOAD sponsored by L) =head1 LICENSE 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. =cut Catalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/Authentication/Store/DBIx/Class.pm0000644000175000017500000004402712317004226031405 0ustar ilmariilmaripackage Catalyst::Authentication::Store::DBIx::Class; use strict; use warnings; use base qw/Class::Accessor::Fast/; our $VERSION= "0.1506"; BEGIN { __PACKAGE__->mk_accessors(qw/config/); } sub new { my ( $class, $config, $app ) = @_; ## 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 = { config => $config }; bless $self, $class; } ## --jk note to self: ## 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. sub from_session { my ( $self, $c, $frozenuser ) = @_; # return $frozenuser if ref $frozenuser; my $user = $self->config->{'store_user_class'}->new($self->{'config'}, $c); return $user->from_session($frozenuser, $c); } 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); } sub user_supports { my $self = shift; # this can work as a class method on the user class $self->config->{'store_user_class'}->supports( @_ ); } sub auto_create_user { my( $self, $authinfo, $c ) = @_; my $res = $self->config->{'store_user_class'}->new($self->{'config'}, $c); return $res->auto_create( $authinfo, $c ); } sub auto_update_user { my( $self, $authinfo, $c, $res ) = @_; $res->auto_update( $authinfo, $c ); return $res; } __PACKAGE__; __END__ =head1 NAME Catalyst::Authentication::Store::DBIx::Class - A storage class for Catalyst Authentication using DBIx::Class =head1 VERSION This documentation refers to version 0.1506. =head1 SYNOPSIS use Catalyst qw/ Authentication Authorization::Roles/; __PACKAGE__->config('Plugin::Authentication' => { default_realm => 'members', realms => { members => { credential => { class => 'Password', password_field => 'password', password_type => 'clear' }, store => { class => 'DBIx::Class', user_model => 'MyApp::User', role_relation => 'roles', role_field => 'rolename', } } } }); # Log a user in: sub login : Global { my ( $self, $ctx ) = @_; $ctx->authenticate({ screen_name => $ctx->req->params->{username}, password => $ctx->req->params->{password}, status => [ 'registered', 'loggedin', 'active'] })) } # verify a role if ( $ctx->check_user_roles( 'editor' ) ) { # do editor stuff } =head1 DESCRIPTION The Catalyst::Authentication::Store::DBIx::Class class provides access to authentication information stored in a database via DBIx::Class. =head1 CONFIGURATION The DBIx::Class authentication store is activated by setting the store config's B element to DBIx::Class as shown above. See the L documentation for more details on configuring the store. You can also use L for a simplified setup. The DBIx::Class storage module has several configuration options __PACKAGE__->config('Plugin::Authentication' => { default_realm => 'members', realms => { members => { credential => { # ... }, store => { class => 'DBIx::Class', user_model => 'MyApp::User', role_relation => 'roles', role_field => 'rolename', ignore_fields_in_find => [ 'remote_name' ], use_userdata_from_session => 1, } } } }); =over 4 =item class Class is part of the core Catalyst::Plugin::Authentication module; it contains the class name of the store to be used. =item user_model Contains the model name (as passed to C<< $ctx->model() >>) of the DBIx::Class schema to use as the source for user information. This config item is B. (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) =item role_column 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. =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 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 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. =item ignore_fields_in_find This item is an array containing fields that may be passed to the C<< $ctx->authenticate() >> routine (and therefore find_user in the storage class), but which should be ignored when creating the DBIx::Class search to retrieve a user. This makes it possible to avoid problems when a credential requires an authinfo element whose name overlaps with a column name in your users table. 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 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. B: Since the user object's column 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<< $ctx->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<< $ctx->user->get_object(1); >> Note that this will update C<< $ctx->user >> for the remainder of this request. It will NOT update the session. If you need to update the session you should call C<< $ctx->update_user_in_session() >> as well. =item store_user_class 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, L, so overriding this doesn't make much sense unless you are using your 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, 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 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 The L storage module is not called directly from application code. You interface with it through the $ctx->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 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 ($ctx->authenticate({ screen_name => $ctx->req->params->{'username'}, password => $ctx->req->params->{'password'}, status => [ 'registered', 'active', 'loggedin'] })) { # ... authenticated user code 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 syntax to retrieve the user according to whatever rules you have. NOTE: Because the password in most cases is encrypted - it is not used directly but its encryption and comparison with the value provided is usually handled by the Password Credential. Part of the Password Credential's behavior is to remove the password argument from the authinfo that is passed to the storage module. See L. One thing you need to know about this retrieval method is that the name portion of the pair is checked against the user class's column list. Pairs are only used if a matching column is found. Other pairs will be ignored. This means that you can only provide simple name-value pairs, and that some more advanced DBIx::Class constructs, such as '-or', '-and', etc. are in most cases not possible using this method. For queries that require this level of functionality, see the 'searchargs' method below. =head2 Advanced Retrieval The Searchargs and Resultset retrieval methods are used when more advanced features of the underlying L 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. =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 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 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. The 'dbix_class' hash can be used to directly pass arguments to the 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, B and B, require its use, as they are only processed as part of the 'dbix_class' hash. =over 4 =item Searchargs The B method of retrieval allows you to specify an arrayref containing the two arguments to the search() method from L. If provided, all other args are ignored, and the search args provided are used directly to locate the user. An example will probably make more sense: if ($ctx->authenticate( { password => $password, 'dbix_class' => { searchargs => [ { -or => [ username => $username, email => $email, clientid => $clientid ] }, { prefetch => qw/ preferences / } ] } } ) ) { # do successful authentication actions here. } The above would allow authentication based on any of the three items - username, email, or clientid - and would prefetch the data related to that user from the preferences table. The searchargs array is passed directly to the search() method associated with the user_model. =item Result The B method of retrieval allows you to look up the user yourself and pass on the loaded user to the authentication store. my $user = $ctx->model('MyApp::User')->find({ ... }); if ($ctx->authenticate({ dbix_class => { result => $user } })) { ... } Be aware that the result method will not verify that you are passing a result that is attached to the same user_model as specified in the config or even loaded from the database, as opposed to existing only in memory. It's your responsibility to make sure of that. =item Resultset The B method of retrieval allows you to directly specify a resultset to be used for user retrieval. This allows you to create a resultset within your login action and use it for retrieving the user. A simple example: my $rs = $ctx->model('MyApp::User')->search({ email => $ctx->request->params->{'email'} }); ... # further $rs adjustments if ($ctx->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. NOTE: The resultset and searchargs methods of user retrieval, consider the first row returned to be the matching user. In most cases there will be only one matching row, but it is easy to produce multiple rows, especially when using the advanced retrieval methods. Remember, what you get when you use this module is what you would get when calling 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 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. If you need more complicated logic when reviving the user from the session, you will most likely want to subclass the L class and provide your own for_session and from_session routines. =back =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 for all authentication stores. Please see the documentation for L for more information. =head2 new ( $config, $app ) Constructs a new store object. =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 Credential. This translates directly to a call to L's load() method. =head2 for_session ( $c, $user ) Prepares a user to be stored in the session. Currently returns the value of the user's id field (as indicated by the 'id_field' config element) =head2 from_session ( $c, $frozenuser) Revives a user from the session based on the info provided in $frozenuser. 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. =head2 auto_update_user( $authinfo, $c, $res ) This method is called if the realm's auto_update_user setting is true. It will delegate to the user object's C method. =head2 auto_create_user( $authinfo, $c ) This method is called if the realm's auto_create_user setting is true. It will delegate to the user class's (resultset) C method. =head1 NOTES As of the current release, session storage consists of simply storing the user's id in the session, and then using that same id to re-retrieve the user's information from the database upon restoration from the session. More dynamic storage of user information in the session is intended for a future release. =head1 BUGS AND LIMITATIONS None known currently; please email the author if you find any. =head1 SEE ALSO L, L, and L =head1 AUTHOR Jason Kuri (jayk@cpan.org) =head1 LICENSE Copyright (c) 2007 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. =cut Catalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/Authentication/Realm/0000755000175000017500000000000012317004570027153 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/lib/Catalyst/Authentication/Realm/SimpleDB.pm0000644000175000017500000001771012317003621031152 0ustar ilmariilmaripackage Catalyst::Authentication::Realm::SimpleDB; use strict; use warnings; use Catalyst::Exception; use base qw/Catalyst::Authentication::Realm/; sub new { my ($class, $realmname, $config, $app) = @_; my $newconfig = { credential => { class => 'Password', password_type => 'clear' }, store => { class => 'DBIx::Class', role_relation => 'roles', role_field => 'role', 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 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})) { $newconfig->{store}{$key} = $config->{$key}; } } if (exists($newconfig->{'store'}{'role_column'})) { delete $newconfig->{'store'}{'role_relation'}; delete $newconfig->{'store'}{'role_field'}; } return $class->SUPER::new($realmname, $newconfig, $app); } 1; __END__ =head1 NAME Catalyst::Authentication::Realm::SimpleDB - A simplified Catalyst authentication configurator. =head1 SYNOPSIS use Catalyst qw/ Authentication /; __PACKAGE__->config->{'Plugin::Authentication'} = { default => { class => 'SimpleDB', user_model => 'MyApp::Schema::Users', } } # later on ... $c->authenticate({ username => 'myusername', password => 'mypassword' }); my $age = $c->user->get('age'); $c->logout; =head1 DESCRIPTION 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 The SimpleDB Realm class configures the Catalyst authentication system based on the following: =over =item * Your user data is stored in a table that is accessible via $c->model($cfg->{user_model}); =item * Your passwords are stored in the 'password' field in your users table and are not encrypted. =item * Your roles for users are stored in a separate table and are directly accessible via a DBIx::Class relationship called 'roles' and the text of the role is stored in a field called 'role' within the role table. =item * Your user information is stored in the session once the user is authenticated. =back For the above usage, only one configuration option is necessary, 'user_model'. B should contain the B. See the L section for info on how to set up your database for use with this module. If your system differs from the above, some minor configuration may be necessary. The options available are detailed below. These options match the configuration options used by the underlying credential and store modules. More information on these options can be found in L and L. =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. =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: $c->authenticate({ username => 'bob', users_password => 'foo' }); =item password_type If the password is not stored in plaintext you will need to define what format the password is in. The common options are B and B. Crypted uses the standard unix crypt to encrypt the password. Hashed uses the L modules to perform password hashing. =item password_hash_type If you use a hashed password type - this defines the type of hashing. See L 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: 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 L 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 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. =back =head1 PREPARATION This module makes several assumptions about the structure of your database. Below is an example of a table structure which will function with this module in it's default configuration. You can use this table structure as-is or add additional fields as necessary. B that this is the default SimpleDB configuration only. Your table structure can differ significantly from this when using the L directly. -- -- note that you can add any additional columns you require to the users table. -- CREATE TABLE users ( id INTEGER PRIMARY KEY, username TEXT, password TEXT, ); CREATE TABLE roles ( id INTEGER PRIMARY KEY, role TEXT ); CREATE TABLE user_roles ( user_id INTEGER, role_id INTEGER, PRIMARY KEY (user_id, role_id) ); Also, after you have loaded this table structure into your DBIx::Class schema, please be sure that you have a many_to_many DBIx::Class relationship defined for the users to roles relation. Your schema files should contain something along these lines: C: __PACKAGE__->has_many(map_user_role => 'MyApp::Schema::UserRoles', 'user_id'); __PACKAGE__->many_to_many(roles => 'map_user_role', 'role'); C: __PACKAGE__->belongs_to(role => 'MyApp::Schema::Roles', 'role_id'); =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: MyApp->config('Plugin::Authentication') = { default => { credential => { class => 'Password', password_type => 'clear' }, store => { class => 'DBIx::Class', role_relation => 'roles', role_field => 'role', use_userdata_from_session => '1', user_model => $user_model_from_simpledb_config } } }; =head1 SEE ALSO This module relies on a number of other modules to do it's job. For more information you can refer to the following: =over =item * L =item * L =item * L =item * L =item * L =back =cut Catalyst-Authentication-Store-DBIx-Class-0.1506/MANIFEST0000644000175000017500000000214512317004505021733 0ustar ilmariilmari.gitignore Changes inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Catalyst/Authentication/Realm/SimpleDB.pm lib/Catalyst/Authentication/Store/DBIx/Class.pm lib/Catalyst/Authentication/Store/DBIx/Class/User.pm Makefile.PL MANIFEST This list of files META.yml README t/00-load.t t/01-pod.t t/02-pod-coverage.t t/03-authtest.t t/04-authsessions.t t/05-auth-roles-relationship.t 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/10-user-autoload.t t/11-authsessions-load-app-context.t t/lib/Catalyst/Authentication/Store/Person.pm t/lib/Catalyst/Authentication/Store/Person/User.pm 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 t/lib/TestApp/Schema/User.pm t/lib/TestApp/Schema/UserRole.pm Catalyst-Authentication-Store-DBIx-Class-0.1506/README0000644000175000017500000004215012317004511021457 0ustar ilmariilmariNAME Catalyst::Authentication::Store::DBIx::Class - A storage class for Catalyst Authentication using DBIx::Class VERSION This documentation refers to version 0.1506. SYNOPSIS use Catalyst qw/ Authentication Authorization::Roles/; __PACKAGE__->config('Plugin::Authentication' => { default_realm => 'members', realms => { members => { credential => { class => 'Password', password_field => 'password', password_type => 'clear' }, store => { class => 'DBIx::Class', user_model => 'MyApp::User', role_relation => 'roles', role_field => 'rolename', } } } }); # Log a user in: sub login : Global { my ( $self, $ctx ) = @_; $ctx->authenticate({ screen_name => $ctx->req->params->{username}, password => $ctx->req->params->{password}, status => [ 'registered', 'loggedin', 'active'] })) } # verify a role if ( $ctx->check_user_roles( 'editor' ) ) { # do editor stuff } DESCRIPTION The Catalyst::Authentication::Store::DBIx::Class class provides access to authentication information stored in a database via DBIx::Class. CONFIGURATION The DBIx::Class authentication store is activated by setting the store config's class element to DBIx::Class as shown above. See the Catalyst::Plugin::Authentication documentation for more details on configuring the store. You can also use Catalyst::Authentication::Realm::SimpleDB for a simplified setup. The DBIx::Class storage module has several configuration options __PACKAGE__->config('Plugin::Authentication' => { default_realm => 'members', realms => { members => { credential => { # ... }, store => { class => 'DBIx::Class', user_model => 'MyApp::User', role_relation => 'roles', role_field => 'rolename', ignore_fields_in_find => [ 'remote_name' ], use_userdata_from_session => 1, } } } }); class Class is part of the core Catalyst::Plugin::Authentication module; it contains the class name of the store to be used. user_model Contains the model name (as passed to "$ctx->model()") of the DBIx::Class schema to use as the source for user information. This config item is REQUIRED. (Note that this option used to be called "user_class". "user_class" is still functional, but should be used only for compatibility with previous configs. The setting called "user_class" on other authentication stores is present, but named "store_user_class" in this store) role_column 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. 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 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 the user is in. role_field This is the name of the field in the role table that contains the string identifying the role. ignore_fields_in_find This item is an array containing fields that may be passed to the "$ctx->authenticate()" routine (and therefore find_user in the storage class), but which should be ignored when creating the DBIx::Class search to retrieve a user. This makes it possible to avoid problems when a credential requires an authinfo element whose name overlaps with a column name in your users table. If this doesn't make sense to you, you probably don't need it. 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 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. NOTE: Since the user object's column 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 "$ctx->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 "$ctx->user->get_object(1);" Note that this will update "$ctx->user" for the remainder of this request. It will NOT update the session. If you need to update the session you should call "$ctx->update_user_in_session()" as well. store_user_class 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, 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. Chances are you do not want to set this. 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, 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 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. USAGE The Catalyst::Authentication::Store::DBIx::Class storage module is not called directly from application code. You interface with it through the $ctx->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. 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 ($ctx->authenticate({ screen_name => $ctx->req->params->{'username'}, password => $ctx->req->params->{'password'}, status => [ 'registered', 'active', 'loggedin'] })) { # ... authenticated user code 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 syntax to retrieve the user according to whatever rules you have. NOTE: Because the password in most cases is encrypted - it is not used directly but its encryption and comparison with the value provided is usually handled by the Password Credential. Part of the Password Credential's behavior is to remove the password argument from the authinfo that is passed to the storage module. See Catalyst::Authentication::Credential::Password. One thing you need to know about this retrieval method is that the name portion of the pair is checked against the user class's column list. Pairs are only used if a matching column is found. Other pairs will be ignored. This means that you can only provide simple name-value pairs, and that some more advanced DBIx::Class constructs, such as '-or', '-and', etc. are in most cases not possible using this method. For queries that require this level of functionality, see the 'searchargs' method below. Advanced Retrieval The Searchargs and Resultset retrieval methods are used when more advanced features of the underlying 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. 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 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 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. The 'dbix_class' hash can be used to directly pass arguments to the 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, searchargs, result and resultset, require its use, as they are only processed as part of the 'dbix_class' hash. Searchargs The searchargs method of retrieval allows you to specify an arrayref containing the two arguments to the search() method from DBIx::Class::ResultSet. If provided, all other args are ignored, and the search args provided are used directly to locate the user. An example will probably make more sense: if ($ctx->authenticate( { password => $password, 'dbix_class' => { searchargs => [ { -or => [ username => $username, email => $email, clientid => $clientid ] }, { prefetch => qw/ preferences / } ] } } ) ) { # do successful authentication actions here. } The above would allow authentication based on any of the three items - username, email, or clientid - and would prefetch the data related to that user from the preferences table. The searchargs array is passed directly to the search() method associated with the user_model. Result The result method of retrieval allows you to look up the user yourself and pass on the loaded user to the authentication store. my $user = $ctx->model('MyApp::User')->find({ ... }); if ($ctx->authenticate({ dbix_class => { result => $user } })) { ... } Be aware that the result method will not verify that you are passing a result that is attached to the same user_model as specified in the config or even loaded from the database, as opposed to existing only in memory. It's your responsibility to make sure of that. Resultset The resultset method of retrieval allows you to directly specify a resultset to be used for user retrieval. This allows you to create a resultset within your login action and use it for retrieving the user. A simple example: my $rs = $ctx->model('MyApp::User')->search({ email => $ctx->request->params->{'email'} }); ... # further $rs adjustments if ($ctx->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. NOTE: The resultset and searchargs methods of user retrieval, consider the first row returned to be the matching user. In most cases there will be only one matching row, but it is easy to produce multiple rows, especially when using the advanced retrieval methods. Remember, what you get when you use this module is what you would get when calling 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 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. If you need more complicated logic when reviving the user from the session, you will most likely want to subclass the Catalyst::Authentication::Store::DBIx::Class::User class and provide your own for_session and from_session routines. 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 Catalyst::Plugin::Authentication for all authentication stores. Please see the documentation for Catalyst::Plugin::Authentication::Internals for more information. new ( $config, $app ) Constructs a new store object. 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 Credential. This translates directly to a call to Catalyst::Authentication::Store::DBIx::Class::User's load() method. for_session ( $c, $user ) Prepares a user to be stored in the session. Currently returns the value of the user's id field (as indicated by the 'id_field' config element) from_session ( $c, $frozenuser) Revives a user from the session based on the info provided in $frozenuser. Currently treats $frozenuser as an id and retrieves a user with a matching id. user_supports Provides information about what the user object supports. auto_update_user( $authinfo, $c, $res ) This method is called if the realm's auto_update_user setting is true. It will delegate to the user object's "auto_update" method. auto_create_user( $authinfo, $c ) This method is called if the realm's auto_create_user setting is true. It will delegate to the user class's (resultset) "auto_create" method. NOTES As of the current release, session storage consists of simply storing the user's id in the session, and then using that same id to re-retrieve the user's information from the database upon restoration from the session. More dynamic storage of user information in the session is intended for a future release. BUGS AND LIMITATIONS None known currently; please email the author if you find any. SEE ALSO Catalyst::Plugin::Authentication, Catalyst::Plugin::Authentication::Internals, and Catalyst::Plugin::Authorization::Roles AUTHOR Jason Kuri (jayk@cpan.org) LICENSE Copyright (c) 2007 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. Catalyst-Authentication-Store-DBIx-Class-0.1506/t/0000755000175000017500000000000012317004570021045 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/0000755000175000017500000000000012317004570021613 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/Catalyst/0000755000175000017500000000000012317004570023377 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/Catalyst/Authentication/0000755000175000017500000000000012317004570026356 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/Catalyst/Authentication/Store/0000755000175000017500000000000012317004570027452 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/Catalyst/Authentication/Store/Person.pm0000644000175000017500000000076712316777676031317 0ustar ilmariilmaripackage Catalyst::Authentication::Store::Person; use strict; use warnings; use base qw/Catalyst::Authentication::Store::DBIx::Class/; our $VERSION= "0.01"; sub new { my ( $class, $config, $app ) = @_; $config->{user_class} = 'TestApp::User'; $config->{store_user_class} = 'Catalyst::Authentication::Store::Person::User'; $config->{role_relation} = 'role'; $config->{role_field} = 'role'; return $class->SUPER::new( $config, $app ); } __PACKAGE__; __END__Catalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/Catalyst/Authentication/Store/Person/0000755000175000017500000000000012317004570030720 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/Catalyst/Authentication/Store/Person/User.pm0000644000175000017500000000117512316777676032227 0ustar ilmariilmaripackage Catalyst::Authentication::Store::Person::User; use strict; use warnings; use base qw/Catalyst::Authentication::Store::DBIx::Class::User/; use base qw/Class::Accessor::Fast/; use Data::Dump; sub load { my ($self, $authinfo, $c) = @_; if ( exists( $authinfo->{'id'} ) ) { $self->_user( $c->model('TestApp::User')->find($authinfo->{'id'}) ); } elsif ( exists( $authinfo->{'username'} ) ) { my $u = $c->model('TestApp::User')->find({ username => $authinfo->{'username'} }); $self->_user( $u ); } if ($self->get_object) { return $self; } else { return undef; } } 1; __END__Catalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp.pm0000644000175000017500000000010212316777676023551 0ustar ilmariilmaripackage TestApp; use strict; use Catalyst; use Data::Dumper; 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/0000755000175000017500000000000012317004570023173 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Model/0000755000175000017500000000000012317004570024233 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Model/TestApp.pm0000644000175000017500000000270312316777676026202 0ustar ilmariilmaripackage TestApp::Model::TestApp; use base qw/Catalyst::Model::DBIC::Schema/; use strict; 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:dbname=:memory:", '', '', { AutoCommit => 1 }, { on_connect_do => \@deployment_statements }, ], ); # Load all of the classes #__PACKAGE__->load_classes(qw/Role User UserRole/); 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Controller/0000755000175000017500000000000012317004570025316 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Controller/Root.pm0000644000175000017500000001263012316777676026630 0ustar ilmariilmaripackage 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 result_login : Global { my ($self, $ctx) = @_; my $user = $ctx->model('TestApp::User')->find({ email => $ctx->request->params->{email}, }); if ($user->password_accessor ne $ctx->request->params->{password}) { $ctx->response->status(403); $ctx->response->body('password mismatch'); $ctx->detach; } $ctx->authenticate({ dbix_class => { result => $user }, password => $ctx->request->params->{password}, }); if ($ctx->user_exists) { $ctx->res->body( $ctx->user->get('username') . ' logged in' ); } else { $ctx->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; Catalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Schema/0000755000175000017500000000000012317004570024373 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Schema/User.pm0000644000175000017500000000076712316777676025710 0ustar ilmariilmaripackage TestApp::Schema::User; use strict; use warnings; use base 'DBIx::Class'; __PACKAGE__->load_components(qw/ Core /); __PACKAGE__->table( 'user' ); __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' ); __PACKAGE__->many_to_many( roles => 'map_user_role', 'role'); 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Schema/Role.pm0000644000175000017500000000050412316777676025660 0ustar ilmariilmaripackage TestApp::Schema::Role; use strict; use warnings; use base 'DBIx::Class'; __PACKAGE__->load_components(qw/ Core /); __PACKAGE__->table( 'role' ); __PACKAGE__->add_columns( qw/id role/ ); __PACKAGE__->set_primary_key( 'id' ); #__PACKAGE__->has_many( map_user_role => 'TestApp::Schema::UserRole' => 'roleid' ); 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Schema/UserRole.pm0000644000175000017500000000053612316777676026524 0ustar ilmariilmaripackage TestApp::Schema::UserRole; use strict; use warnings; use base 'DBIx::Class'; __PACKAGE__->load_components(qw/ Core /); __PACKAGE__->table( 'user_role' ); __PACKAGE__->add_columns( qw/id user roleid/ ); __PACKAGE__->set_primary_key( qw/id/ ); __PACKAGE__->belongs_to('role', 'TestApp::Schema::Role', { 'foreign.id' => 'self.roleid'}); 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/t/lib/TestApp/Schema.pm0000644000175000017500000000027512316777676024764 0ustar ilmariilmaripackage TestApp::Schema; # Created by DBIx::Class::Schema::Loader v0.03007 @ 2006-10-18 12:38:33 use strict; use warnings; use base 'DBIx::Class::Schema'; __PACKAGE__->load_classes; 1;Catalyst-Authentication-Store-DBIx-Class-0.1506/t/09-simpledb-auth-roles-column.t0000644000175000017500000000343312316777676026665 0ustar ilmariilmari#!perl use strict; use warnings; use DBI; use File::Path; use FindBin; use Test::More; use lib "$FindBin::Bin/lib"; BEGIN { eval { require DBD::SQLite } or plan skip_all => "DBD::SQLite is required for this test"; eval { require DBIx::Class } or plan skip_all => "DBIx::Class is required for this test"; eval { require Catalyst::Plugin::Authorization::Roles } or plan skip_all => "Catalyst::Plugin::Authorization::Roles is required for this test"; plan tests => 8; use TestApp; TestApp->config( { name => 'TestApp', 'Plugin::Authentication' => { default => { class => 'SimpleDB', user_model => 'TestApp::User', role_column => 'role_text', password_type => 'clear' } } } ); TestApp->setup( qw/Authentication Authorization::Roles / ); } use Catalyst::Test 'TestApp'; # test user's admin access { ok( my $res = request('http://localhost/user_login?username=joeuser&password=hackme&detach=is_admin'), 'request ok' ); is( $res->content, 'ok', 'user is an admin' ); } # test unauthorized user's admin access { ok( my $res = request('http://localhost/user_login?username=jayk&password=letmein&detach=is_admin'), 'request ok' ); is( $res->content, 'failed', 'user is not an admin' ); } # test multiple auth roles { ok( my $res = request('http://localhost/user_login?username=nuffin&password=much&detach=is_admin_user'), 'request ok' ); is( $res->content, 'ok', 'user is an admin and a user' ); } # test multiple unauth roles { 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' ); } Catalyst-Authentication-Store-DBIx-Class-0.1506/t/05-auth-roles-relationship.t0000644000175000017500000000431712316777676026272 0ustar ilmariilmari#!perl use strict; use warnings; use DBI; use File::Path; use FindBin; use Test::More; use lib "$FindBin::Bin/lib"; BEGIN { eval { require DBD::SQLite } or plan skip_all => "DBD::SQLite is required for this test"; eval { require DBIx::Class } or plan skip_all => "DBIx::Class is required for this test"; eval { require Catalyst::Plugin::Authorization::Roles } or plan skip_all => "Catalyst::Plugin::Authorization::Roles is required for this test"; plan tests => 8; use TestApp; TestApp->config( { name => 'TestApp', authentication => { default_realm => "users", realms => { users => { credential => { 'class' => "Password", 'password_field' => 'password', 'password_type' => 'clear' }, store => { 'class' => 'DBIx::Class', 'user_model' => 'TestApp::User', 'role_relation' => 'roles', 'role_field' => 'role' }, }, }, }, } ); TestApp->setup( qw/Authentication Authorization::Roles / ); } use Catalyst::Test 'TestApp'; # test user's admin access { ok( my $res = request('http://localhost/user_login?username=jayk&password=letmein&detach=is_admin'), 'request ok' ); is( $res->content, 'ok', 'user is an admin' ); } # test unauthorized user's admin access { ok( my $res = request('http://localhost/user_login?username=nuffin&password=much&detach=is_admin'), 'request ok' ); is( $res->content, 'failed', 'user is not an admin' ); } # test multiple auth roles { ok( my $res = request('http://localhost/user_login?username=jayk&password=letmein&detach=is_admin_user'), 'request ok' ); is( $res->content, 'ok', 'user is an admin and a user' ); } # test multiple unauth roles { 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' ); } Catalyst-Authentication-Store-DBIx-Class-0.1506/t/10-user-autoload.t0000644000175000017500000000205412316777676024264 0ustar ilmariilmariuse strict; use warnings; use Test::More; use Try::Tiny; use Catalyst::Authentication::Store::DBIx::Class::User; my $message = 'I exist'; { package My::Test; sub exists { $message } } my $class = 'Catalyst::Authentication::Store::DBIx::Class::User'; my $o = bless({ _user => bless({}, 'My::Test'), }, $class); 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'); is($o->non_existent_method, undef, 'AUTOLOAD traps non existent method'); try { is($class->can('non_existent_method'), undef, "can on non existent class method"); } catch { my $e = $_; fail('can on non existent class method'); diag("Got exception: $e"); }; try { is($class->non_existent_method, undef, 'AUTOLOAD traps non existent class method'); } catch { my $e = $_; fail('AUTOLOAD traps non existent class method'); diag("Got exception: $e"); }; done_testing; Catalyst-Authentication-Store-DBIx-Class-0.1506/t/04-authsessions.t0000644000175000017500000000467712316777676024250 0ustar ilmariilmari#!perl use strict; use warnings; use DBI; use File::Path; use FindBin; use Test::More; use lib "$FindBin::Bin/lib"; BEGIN { eval { require Test::WWW::Mechanize::Catalyst } or plan skip_all => "Test::WWW::Mechanize::Catalyst is required for this test"; eval { require DBD::SQLite } or plan skip_all => "DBD::SQLite is required for this test"; eval { require DBIx::Class } or plan skip_all => "DBIx::Class is required for this test"; 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"; eval { require Catalyst::Plugin::Session::State::Cookie; } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie is required for this test"; plan tests => 8; use TestApp; TestApp->config( { name => 'TestApp', authentication => { default_realm => "users", realms => { users => { credential => { 'class' => "Password", 'password_field' => 'password', 'password_type' => 'clear' }, store => { 'class' => 'DBIx::Class', 'user_model' => 'TestApp::User', 'use_userdata_from_session' => 0, }, }, }, }, } ); TestApp->setup( qw/Authentication Session Session::Store::Dummy Session::State::Cookie / ); } use Test::WWW::Mechanize::Catalyst 'TestApp'; my $m = Test::WWW::Mechanize::Catalyst->new; # log a user in { $m->get_ok( 'http://localhost/user_login?username=joeuser&password=hackme', undef, 'request ok' ); $m->content_is( 'joeuser logged in', 'user logged in ok' ); } # verify the user is still logged in { $m->get_ok( 'http://localhost/get_session_user', undef, 'request ok' ); $m->content_is( 'joeuser', 'user still logged in' ); } # log the user out { $m->get_ok( 'http://localhost/user_logout', undef, 'request ok' ); $m->content_is( 'logged out', 'user logged out ok' ); } # verify there is no session { $m->get_ok( 'http://localhost/get_session_user', undef, 'request ok' ); $m->content_is( '', "user's session deleted" ); } Catalyst-Authentication-Store-DBIx-Class-0.1506/t/06-auth-roles-column.t0000644000175000017500000000424612316777676025070 0ustar ilmariilmari#!perl use strict; use warnings; use DBI; use File::Path; use FindBin; use Test::More; use lib "$FindBin::Bin/lib"; BEGIN { eval { require DBD::SQLite } or plan skip_all => "DBD::SQLite is required for this test"; eval { require DBIx::Class } or plan skip_all => "DBIx::Class is required for this test"; eval { require Catalyst::Plugin::Authorization::Roles } or plan skip_all => "Catalyst::Plugin::Authorization::Roles is required for this test"; plan tests => 8; use TestApp; TestApp->config( { name => 'TestApp', authentication => { default_realm => "users", realms => { users => { credential => { 'class' => "Password", 'password_field' => 'password', 'password_type' => 'clear' }, store => { 'class' => 'DBIx::Class', 'user_model' => 'TestApp::User', 'role_column' => 'role_text' }, }, }, }, } ); TestApp->setup( qw/Authentication Authorization::Roles / ); } use Catalyst::Test 'TestApp'; # test user's admin access { ok( my $res = request('http://localhost/user_login?username=joeuser&password=hackme&detach=is_admin'), 'request ok' ); is( $res->content, 'ok', 'user is an admin' ); } # test unauthorized user's admin access { ok( my $res = request('http://localhost/user_login?username=jayk&password=letmein&detach=is_admin'), 'request ok' ); is( $res->content, 'failed', 'user is not an admin' ); } # test multiple auth roles { ok( my $res = request('http://localhost/user_login?username=nuffin&password=much&detach=is_admin_user'), 'request ok' ); is( $res->content, 'ok', 'user is an admin and a user' ); } # test multiple unauth roles { 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' ); } Catalyst-Authentication-Store-DBIx-Class-0.1506/t/00-load.t0000644000175000017500000000036012316777676022414 0ustar ilmariilmari#!perl use Test::More tests => 1; BEGIN { use_ok( 'Catalyst::Authentication::Store::DBIx::Class' ); } diag( "Testing Catalyst::Authentication::Store::DBIx::Class $Catalyst::Authentication::Store::DBIx::Class::VERSION, Perl $], $^X" ); Catalyst-Authentication-Store-DBIx-Class-0.1506/t/01-pod.t0000644000175000017500000000032712316777676022263 0ustar ilmariilmari#!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(); Catalyst-Authentication-Store-DBIx-Class-0.1506/t/03-authtest.t0000644000175000017500000000637012316777676023350 0ustar ilmariilmari#!perl use strict; use warnings; use DBI; use File::Path; use FindBin; use Test::More; use lib "$FindBin::Bin/lib"; BEGIN { eval { require DBD::SQLite } or plan skip_all => "DBD::SQLite is required for this test"; eval { require DBIx::Class } or plan skip_all => "DBIx::Class is required for this test"; plan tests => 19; use TestApp; TestApp->config( { name => 'TestApp', authentication => { default_realm => "users", realms => { users => { credential => { 'class' => "Password", 'password_field' => 'password', 'password_type' => 'clear' }, store => { 'class' => 'DBIx::Class', 'user_model' => 'TestApp::User', }, }, }, }, } ); TestApp->setup( qw/Authentication/ ); } use Catalyst::Test 'TestApp'; # log a user in { ok( my $res = request('http://localhost/user_login?username=joeuser&password=hackme'), 'request ok' ); is( $res->content, 'joeuser logged in', 'user logged in ok' ); } # invalid user { ok( my $res = request('http://localhost/user_login?username=foo&password=bar'), 'request ok' ); is( $res->content, 'not logged in', 'user not logged in ok' ); } # disabled user - no disable check { ok( my $res = request('http://localhost/user_login?username=spammer&password=broken'), 'request ok' ); is( $res->content, 'spammer logged in', 'status check - disabled user logged in ok' ); } # disabled user - should fail login { ok( my $res = request('http://localhost/notdisabled_login?username=spammer&password=broken'), 'request ok' ); is( $res->content, 'not logged in', 'status check - disabled user not logged in ok' ); } # log the user out { ok( my $res = request('http://localhost/user_logout'), 'request ok' ); is( $res->content, 'logged out', 'user logged out ok' ); } # searchargs test { ok( my $res = request('http://localhost/searchargs_login?email=nada%40mucho.net&password=much'), 'request ok' ); is( $res->content, 'nuffin logged in', 'searchargs based login ok' ); } # result test { ok( my $res = request('http://localhost/result_login?email=j%40cpants.org&password=letmein'), 'request ok' ); is( $res->content, 'jayk logged in', 'resultset based login ok' ); } # resultset test { ok( my $res = request('http://localhost/resultset_login?email=j%40cpants.org&password=letmein'), 'request ok' ); is( $res->content, 'jayk logged in', 'resultset based login ok' ); } # invalid user { ok( my $res = request('http://localhost/bad_login?username=foo&password=bar'), 'request ok' ); like( $res->content, qr/only has these columns/, 'incorrect parameters to authenticate throws a useful exception' ); } { TestApp->config->{authentication}->{realms}->{users}->{store}->{user_model} = 'Nonexistent::Class'; 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' ); } Catalyst-Authentication-Store-DBIx-Class-0.1506/t/07-authsessions-cached.t0000644000175000017500000000467712316777676025460 0ustar ilmariilmari#!perl use strict; use warnings; use DBI; use File::Path; use FindBin; use Test::More; use lib "$FindBin::Bin/lib"; BEGIN { eval { require Test::WWW::Mechanize::Catalyst } or plan skip_all => "Test::WWW::Mechanize::Catalyst is required for this test"; eval { require DBD::SQLite } or plan skip_all => "DBD::SQLite is required for this test"; eval { require DBIx::Class } or plan skip_all => "DBIx::Class is required for this test"; 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"; eval { require Catalyst::Plugin::Session::State::Cookie; } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie is required for this test"; plan tests => 8; use TestApp; TestApp->config( { name => 'TestApp', authentication => { default_realm => "users", realms => { users => { credential => { 'class' => "Password", 'password_field' => 'password', 'password_type' => 'clear' }, store => { 'class' => 'DBIx::Class', 'user_model' => 'TestApp::User', 'use_userdata_from_session' => 1, }, }, }, }, } ); TestApp->setup( qw/Authentication Session Session::Store::Dummy Session::State::Cookie / ); } use Test::WWW::Mechanize::Catalyst 'TestApp'; my $m = Test::WWW::Mechanize::Catalyst->new; # log a user in { $m->get_ok( 'http://localhost/user_login?username=joeuser&password=hackme', undef, 'request ok' ); $m->content_is( 'joeuser logged in', 'user logged in ok' ); } # verify the user is still logged in { $m->get_ok( 'http://localhost/get_session_user', undef, 'request ok' ); $m->content_is( 'joeuser', 'user still logged in' ); } # log the user out { $m->get_ok( 'http://localhost/user_logout', undef, 'request ok' ); $m->content_is( 'logged out', 'user logged out ok' ); } # verify there is no session { $m->get_ok( 'http://localhost/get_session_user', undef, 'request ok' ); $m->content_is( '', "user's session deleted" ); } Catalyst-Authentication-Store-DBIx-Class-0.1506/t/11-authsessions-load-app-context.t0000644000175000017500000000404612316777676027411 0ustar ilmariilmari#!perl use strict; use warnings; use DBI; use File::Path; use FindBin; use Test::More; use lib "$FindBin::Bin/lib"; BEGIN { eval { require Test::WWW::Mechanize::Catalyst } or plan skip_all => "Test::WWW::Mechanize::Catalyst is required for this test"; eval { require DBD::SQLite } or plan skip_all => "DBD::SQLite is required for this test"; eval { require DBIx::Class } or plan skip_all => "DBIx::Class is required for this test"; 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"; eval { require Catalyst::Plugin::Session::State::Cookie; } or plan skip_all => "Catalyst::Plugin::Session::State::Cookie is required for this test"; plan tests => 4; use TestApp; TestApp->config( { name => 'TestApp', authentication => { default_realm => "users", realms => { users => { credential => { 'class' => 'Password', 'password_field' => 'password', }, store => { 'class' => 'Person', 'use_userdata_from_session' => 0, }, }, }, }, } ); TestApp->setup( qw/Authentication Session Session::Store::Dummy Session::State::Cookie / ); } use Test::WWW::Mechanize::Catalyst 'TestApp'; my $m = Test::WWW::Mechanize::Catalyst->new; # log a user in { $m->get_ok( 'http://localhost/user_login?username=joeuser&password=hackme', undef, 'request ok' ); $m->content_is( 'joeuser logged in', 'user logged in ok' ); } # verify the user is still logged in { $m->get_ok( 'http://localhost/get_session_user', undef, 'request ok' ); $m->content_is( 'joeuser', 'user still logged in' ); } Catalyst-Authentication-Store-DBIx-Class-0.1506/t/02-pod-coverage.t0000644000175000017500000000045212316777676024054 0ustar ilmariilmari#!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' }); Catalyst-Authentication-Store-DBIx-Class-0.1506/t/08-simpledb-auth-roles-relationship.t0000644000175000017500000000341512316777676030070 0ustar ilmariilmari#!perl use strict; use warnings; use DBI; use File::Path; use FindBin; use Test::More; use lib "$FindBin::Bin/lib"; BEGIN { eval { require DBD::SQLite } or plan skip_all => "DBD::SQLite is required for this test"; eval { require DBIx::Class } or plan skip_all => "DBIx::Class is required for this test"; eval { require Catalyst::Plugin::Authorization::Roles } or plan skip_all => "Catalyst::Plugin::Authorization::Roles is required for this test"; plan tests => 8; use TestApp; TestApp->config( { name => 'TestApp', 'Plugin::Authentication' => { default => { class => 'SimpleDB', user_model => 'TestApp::User', password_type => 'clear' } } } ); TestApp->setup( qw/Authentication Authorization::Roles / ); } use Catalyst::Test 'TestApp'; # test user's admin access { ok( my $res = request('http://localhost/user_login?username=jayk&password=letmein&detach=is_admin'), 'request ok' ); is( $res->content, 'ok', 'user is an admin' ); } # test unauthorized user's admin access { ok( my $res = request('http://localhost/user_login?username=nuffin&password=much&detach=is_admin'), 'request ok' ); is( $res->content, 'failed', 'user is not an admin' ); } # test multiple auth roles { ok( my $res = request('http://localhost/user_login?username=jayk&password=letmein&detach=is_admin_user'), 'request ok' ); is( $res->content, 'ok', 'user is an admin and a user' ); } # test multiple unauth roles { 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' ); } Catalyst-Authentication-Store-DBIx-Class-0.1506/Changes0000644000175000017500000000741412317004244022101 0ustar ilmariilmariRevision history for Catalyst-Plugin-Authentication-Store-DBIx-Class 0.1506 2014-04-02 * Fix doc bugs. RT#87372 * Fix calling User->can() as a class method. RT#90715 * Fix Catalyst tutorial link. RT#47043 0.1505 2013-06-10 * Fix RT#82944 - test fails on perl >= 5.17.3 * Return undef if there isn't a user. This will cause an exception but a more helpful exception (probably from DBIC) than the inability to call a method in this code. 0.1504 2012-10-05 * Make use_userdata_from_session use inflate_result since this is already-stored data, not a "new" object being created 0.1503 2011-12-08 * Change docs to show $c->config('Plugin::Authentication' => {... rather than $c->config->{authentication}. The new key, and method rather than hash access style are both preferred and recommended. 0.1502 2011-08-24 * Switch repository to git (fREW Schmidt) 0.1501 2011-06-17 * If use_userdata_from_session isn't set, then don't store more fields than we need in the session -- only the fields we need to load the object from the DB again. 0.1500 2010-11-16 * Allow specifying a fully loaded DBIC result in addition to resultsets of which only the first row is considered. 0.1401 2010-11-16 * Fix call to ->load which was not passing $c 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 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. 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 0.105 2008-03-19 Throw an exception if no fields are provided during authenticate - 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. 0.102 2008-01-23 Catalyst::Authentication::Store::DBIx::Class::User - Explicitly call auto_create() against resultset() - Explicitly call auto_update() against _user() - Document the above 0.101 2007-12-02 Implemented basic auto_update_user and auto_create_user support 0.10 2007-07-07 3pm CST Proper handling of missing id_field config (load from primary_key) Throw exception if id_field specified does not exist Full test suite added. (based loosely on old DBIC store) 0.03 XXX Switch to Module::Install 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 First version, worked internally, completely undocumented Catalyst-Authentication-Store-DBIx-Class-0.1506/Makefile.PL0000644000175000017500000000341612316777676022607 0ustar ilmariilmariuse 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'; }; if (!$@) { #} can_use("Catalyst::Plugin::Authentication::Store::DBIx::Class") ) { print STDERR < '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'; resources repository => 'git://git.shadowcat.co.uk/catagits/Catalyst-Authentication-Store-DBIx-Class.git', auto_install; auto_provides; WriteAll; Catalyst-Authentication-Store-DBIx-Class-0.1506/.gitignore0000644000175000017500000000025212316777676022620 0ustar ilmariilmariMYMETA.* .* !.gitignore Makefile* !Makefile.PL META.yml blib build inc pm_to_blib MANIFEST* !MANIFEST.SKIP Debian* README Catalyst-Authentication-Store-DBIx-Class-* *.bs Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/0000755000175000017500000000000012317004570021353 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/0000755000175000017500000000000012317004570022600 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/0000755000175000017500000000000012317004570024206 5ustar ilmariilmariCatalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/Fetch.pm0000644000175000017500000000462712317004511025601 0ustar ilmariilmari#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/Can.pm0000644000175000017500000000615712317004511025251 0ustar ilmariilmari#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/AutoInstall.pm0000644000175000017500000000416212317004511027001 0ustar ilmariilmari#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; 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 @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_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); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub installdeps_target { my ($self, @args) = @_; $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall::_installdeps_target(1); $self->auto_install(@args); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/Metadata.pm0000644000175000017500000004327712317004511026274 0ustar ilmariilmari#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { 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; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $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->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } 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 { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { 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"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # 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}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #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; 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 2\.0' => 'artistic_2', 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 ''; } 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<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } 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}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/Include.pm0000644000175000017500000000101512317004511026117 0ustar ilmariilmari#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612317004511026272 0ustar ilmariilmari#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $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 # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/Win32.pm0000644000175000017500000000340312317004511025441 0ustar ilmariilmari#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/Makefile.pm0000644000175000017500000002743712317004511026271 0ustar ilmariilmari#line 1 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 = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # 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 { goto &ExtUtils::MakeMaker::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, %new_args) = @_; my $args = ( $self->{makemaker_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 = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } 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.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $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 if ( $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} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } 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; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # 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 ($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; } } 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 $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install/Base.pm0000644000175000017500000000214712317004511025415 0ustar ilmariilmari#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[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 { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/AutoInstall.pm0000644000175000017500000006216212317004511025377 0ustar ilmariilmari#line 1 package Module::AutoInstall; use strict; use Cwd (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, $UpgradeDeps ); my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub _installdeps_target { $InstallDepsTarget = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { $UpgradeDeps = 1; __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _version_of($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or $InstallDepsTarget or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { require Config; my $make = $Config::Config{make}; if ($InstallDepsTarget) { print "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; } else { print "*** Dependencies will be installed the next time you type '$make'.\n"; } # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; if ($ENV{PERL5_CPANM_IS_RUNNING}) { return _running_under('cpanminus'); } my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } if ($UpgradeDeps) { push @modules, @installed; @installed = (); } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } push @config, 'prereqs', $value; } elsif ( $key eq 'force' ) { push @config, $key, $value; } elsif ( $key eq 'notest' ) { push @config, 'skiptest', $value; } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^(?:force|notest)$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } if ($args{notest} && (not CPAN::Shell->can('notest'))) { die "Your version of CPAN is too old to support the 'notest' pragma"; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = do { if ($args{force}) { CPAN::Shell->force( install => $pkg ) } elsif ($args{notest}) { CPAN::Shell->notest( install => $pkg ) } else { CPAN::Shell->install($pkg) } }; $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # report version without loading a module sub _version_of { my $mod = pop; # method/function doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; foreach my $dir ( @INC ) { next if ref $dir; my $path = File::Spec->catfile($dir, $file); next unless -e $path; require ExtUtils::MM_Unix; return ExtUtils::MM_Unix->parse_version($path); } return undef; } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # 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 { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); my $deps_list = join( ',', @Missing, @Existing ); $PostambleActionsUpgradeDeps = "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; my $config_notest = join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 'notest', 1 ) if $Config; $PostambleActionsNoTest = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); $PostambleActionsUpgradeDepsNoTest = "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; $PostambleActionsListDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); my @all = (@Missing, @Existing); $PostambleActionsListAllDeps = '@$(PERL) -le "print for @ARGV" ' . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; my $fragment; $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; config :: installdeps \t\$(NOECHO) \$(NOOP) AUTO_INSTALL $fragment .= <<"END_MAKE"; checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions installdeps_notest :: \t$PostambleActionsNoTest upgradedeps :: \t$PostambleActionsUpgradeDeps upgradedeps_notest :: \t$PostambleActionsUpgradeDepsNoTest listdeps :: \t$PostambleActionsListDeps listalldeps :: \t$PostambleActionsListAllDeps END_MAKE return $fragment; } 1; __END__ #line 1193 Catalyst-Authentication-Store-DBIx-Class-0.1506/inc/Module/Install.pm0000644000175000017500000003013512317004511024541 0ustar ilmariilmari#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # 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 = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # 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: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; 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). 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" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. 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/; } 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; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } 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 return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; 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'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } 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) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; 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 $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 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_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). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Catalyst-Authentication-Store-DBIx-Class-0.1506/META.yml0000644000175000017500000000233712317004511022053 0ustar ilmariilmari--- abstract: 'A storage class for Catalyst Authentication using DBIx::Class' author: - 'Jason Kuri (jayk@cpan.org)' build_requires: ExtUtils::MakeMaker: 6.59 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Catalyst-Authentication-Store-DBIx-Class 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.1506 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: 5.8 DBIx::Class: 0.08 List::MoreUtils: 0 Moose: 0 Try::Tiny: 0 namespace::autoclean: 0 perl: 5.8.1 resources: license: http://dev.perl.org/licenses/ repository: git://git.shadowcat.co.uk/catagits/Catalyst-Authentication-Store-DBIx-Class.git version: 0.1506