CatalystX-SimpleLogin-0.18/ 000755 000765 000024 00000000000 12002530505 015431 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/.gitignore 000644 000765 000024 00000000237 11631360300 017424 0 ustar 00t0m staff 000000 000000 MYMETA.*
MANIFEST.bak
*.swp
cover_db
META.yml
Makefile
blib
inc
pm_to_blib
MANIFEST
Makefile.old
README
CatalystX-SimpleLogin-*
t/lib/TestAppDBIC/testdbic.db
CatalystX-SimpleLogin-0.18/Changes 000644 000765 000024 00000007307 12002530405 016732 0 ustar 00t0m staff 000000 000000 0.18 Sat, 21 July 2012 14:39:00 +0100
* Stop depending on the now unused Catalyst::Controller::ActionRole
RT#78500
0.17 Sun, 15 July 2012 18:23:00 +0100
* Better fix for Catalyst versions >= 5.90013 RT#78340, one module
and some documentation was missed.
0.16 Fri, 13 July 2012 15:41:00 +0100
* Ensure that temp directories created in tests get removed.
* Fix for Catalyst versions >= 5.90013 RT#78340
0.15 Tue, 6 Sept 2011 09:59:00 +0100
* Various documentation fixes and improvements
* Add tab index to forms
* Fix login redirect to just use the URI, rather than trying to compose
an action, as in some cases we may not have an action.
(E.g. when you have a sub default : Private { action)
0.14 Tue, 12 Oct 2010 17:54:00 +0100
* Large improvements in the documentation to pass all POD coverage tests
and document examples well thanks to Shlomi Fish.
0.13 Thu, 07 Oct 2010 09:35:00 +0100
* Fix the docs to make it clearer how to remove traits and use your own
login form.
0.12
* Fix test failures with various DBIC versions by relying on the DBIC
dependency magic (RT#58307).
0.11
* Add a chunk of documentation (Drew Taylour)
0.10 Wed, 02 Jul 2010 17:03:41 +0000
* Add a clear_session_on_logout config setting which will blow away the
contents of the session on logout.
0.09 Sat, 20 Feb 2010 18:05:05 +0000
* Add actions for people using Chained controllers to chain off.
/login/required and /login/not_required
* Point new users to the manual at the top of the POD so they know it's there.
* Add SQL::Translator as a test dependency.
0.08 Wed, 27 Jan 2010 22:02:11 +0000
* Fix Login controller so that it works with the RequiresLogin action
role without the WithRedirect trait composed.
* Added redirect_after_login_uri configuration key to Controller::Login which
can be used to set the path to redirect the user after login (if the
WithRedirect trait is not used)
* Added redirect_after_logout_uri configuration key to Controller::Login which
can be used to set the path to redirect the user after logout.
* Fix manual typo (Curtis 'Ovid' Poe)
0.07 Sun, 13 Dec 2009 20:00:23 +0000
* Fix so that you can pass parameters to the login form from config to change
the keys used in the $c->authenticate call, so that you can use an arbitrary
DBIC schema result class.
* Add tests with a DBIC using app.
* Significant refactoring in the test suite to reduce code and template duplication
between the test applications.
0.06 Fri, 11 Dec 2009 00:01:23 +0000
* Fix Catalyst::ActionRole::NeedsLogin to correctly detach from
action chains + tests.
* Add an experimental controller for OpenID support.
0.05 Wed, 09 Dec 2009 22:50:23 +0000
* WARNING: BREAKING CHANGE - The WithRedirect and RenderAsTTTemplate
traits are now composed as default to reduce the amount of config
needed in the tutorial, and as these are mostly what people want.
If you don't want these traits, then you'll have to remove them with
config.
* Various documentation cleanups.
* Remove dependency on Test::MockModule
* Make OpenID support optional so that people don't get stuck installing
Crypt::DH without the support modules which stop it taking forever.
0.04 Sun, 06 Dec 2009 13:25:23 +0000
* Fix too low a dependency on HTML::Formhandler
* Clean up a couple of things in the controller code to use $self
rather than $c->controller('Login').
0.03 Sat, 14 Nov 2009 16:28:23 +0000
* Fix dependency on Authentication::Credential::OpenID
* Doc fixes
0.02 Sat, 07 Nov 2009 21:20:00 +0000
* Much more documentation
* Traits are automatically merged
* Added OpenID support
0.01 Wed, 30 Sep 2009 02:17:00 +0200
* Initial release.
CatalystX-SimpleLogin-0.18/inc/ 000755 000765 000024 00000000000 12002530505 016202 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/ 000755 000765 000024 00000000000 12002530505 016177 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/Makefile.PL 000644 000765 000024 00000003505 12002530306 017405 0 ustar 00t0m staff 000000 000000 use strict;
use warnings;
use inc::Module::Install 0.91;
use Module::Install::AuthorTests;
use Module::Install::AuthorRequires;
name 'CatalystX-SimpleLogin';
all_from 'lib/CatalystX/SimpleLogin.pm';
requires 'Moose';
requires 'Catalyst::Runtime' => '5.80013';
requires 'MooseX::MethodAttributes' => '0.18';
requires 'Catalyst::Action::REST' => '0.74';
requires 'Catalyst::Plugin::Authentication';
requires 'Catalyst::View::TT';
requires 'CatalystX::InjectComponent';
requires 'CatalystX::Component::Traits' => '0.13';
requires 'Moose::Autobox' => '0.09';
requires 'MooseX::Types::Common';
requires 'MooseX::Types';
requires 'MooseX::RelatedClassRoles' => '0.004';
requires 'Moose::Autobox';
requires 'HTML::FormHandler' => '0.28001';
requires 'namespace::autoclean';
requires 'Catalyst::Plugin::Session' => '0.27'; # Required as we use the 'Plugin::Session' config key in ::Manual
test_requires 'Test::More' => '0.94';
test_requires 'Test::Exception';
test_requires 'File::Temp';
test_requires 'Catalyst::Action::RenderView';
test_requires 'Catalyst::Plugin::Session::State::Cookie';
test_requires 'Catalyst::Plugin::Session::Store::File';
test_requires 'HTTP::Request::Common';
test_requires 'Catalyst::ActionRole::ACL';
test_requires 'CatalystX::InjectComponent';
test_requires 'SQL::Translator';
author_requires 'Test::EOL' => '0.3';
author_requires 'Test::NoTabs';
author_requires 'Test::Pod' => '1.14';
author_requires 'Test::Pod::Coverage' => '1.08';
author_requires 'Catalyst::Model::DBIC::Schema';
author_requires 'Catalyst::Authentication::Store::DBIx::Class';
license 'perl';
resources repository => 'git://github.com/bobtfish/catalystx-simplelogin.git';
tests 't/*.t';
author_tests 't/author';
if ($Module::Install::AUTHOR) {
system("pod2text lib/CatalystX/SimpleLogin.pm > README") and die;
}
auto_install;
auto_provides;
WriteAll();
CatalystX-SimpleLogin-0.18/MANIFEST 000644 000765 000024 00000004646 12000031655 016574 0 ustar 00t0m staff 000000 000000 .gitignore
Changes
inc/Module/AutoInstall.pm
inc/Module/Install.pm
inc/Module/Install/AuthorRequires.pm
inc/Module/Install/AuthorTests.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/ActionRole/NeedsLogin.pm
lib/CatalystX/SimpleLogin.pm
lib/CatalystX/SimpleLogin/Controller/Login.pm
lib/CatalystX/SimpleLogin/Form/Login.pm
lib/CatalystX/SimpleLogin/Form/LoginOpenID.pm
lib/CatalystX/SimpleLogin/Manual.pod
lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/Logout.pm
lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/OpenID.pm
lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/RenderAsTTTemplate.pm
lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/WithRedirect.pm
Makefile.PL
MANIFEST This list of files
MANIFEST.SKIP
META.yml
README
t/00-load.t
t/01-live-test.t
t/02-redirect-test.t
t/03-login-form.t
t/04-test-role-apply-order.t
t/05-login-redirect-custom-message.t
t/06-rendertt.t
t/07-openid-live.t
t/08-dbic-mappedfields.t
t/09-clearsession.t
t/10-form-args.t
t/author/eol.t
t/author/notabs.t
t/author/pod-coverage.t
t/author/pod.t
t/chained_parts.t
t/lib/Catalyst/Authentication/Credential/MockOpenID.pm
t/lib/script/testapp_server.pl
t/lib/TestApp.pm
t/lib/TestApp/Controller/ChainedExample.pm
t/lib/TestApp/Controller/NeedsAuth.pm
t/lib/TestApp/root/chainedexample/index.tt
t/lib/TestApp/root/chainedexample/item.tt
t/lib/TestApp/root/chainedexample/public.tt
t/lib/TestApp/root/login/login.tt
t/lib/TestAppBase.pm
t/lib/TestAppBase/Controller/Root.pm
t/lib/TestAppBase/root/index.tt
t/lib/TestAppBase/root/wrapper.tt
t/lib/TestAppBase/Script/Server.pm
t/lib/TestAppBase/View/HTML.pm
t/lib/TestAppClearSession.pm
t/lib/TestAppClearSession/Controller/Root.pm
t/lib/TestAppClearSession/root/login/login.tt
t/lib/TestAppDBIC.pm
t/lib/TestAppDBIC/Controller/Root.pm
t/lib/TestAppDBIC/Model/DB.pm
t/lib/TestAppDBIC/Schema.pm
t/lib/TestAppDBIC/Schema/Result/User.pm
t/lib/TestAppDBIC/View/HTML.pm
t/lib/TestAppFormArgs.pm
t/lib/TestAppFormArgs/Controller/NeedsAuth.pm
t/lib/TestAppFormArgs/root/login/login.tt
t/lib/TestAppOpenID.pm
t/lib/TestAppOpenID/.exists
t/lib/TestAppRedirect.pm
t/lib/TestAppRedirect/Controller/Root.pm
t/lib/TestAppRedirect/root/login/login.tt
t/lib/TestAppRenderTT.pm
t/lib/TestAppRenderTT/.exists
CatalystX-SimpleLogin-0.18/MANIFEST.SKIP 000644 000765 000024 00000000246 11631360314 017337 0 ustar 00t0m staff 000000 000000 ^MYMETA\.
^t/lib/TestAppDBIC/testdbic.db$
\..*.swp
^TODO
.git/
blib
pm_to_blib
MANIFEST.bak
MANIFEST.SKIP~
cover_db
Makefile$
Makefile.old$
^CatalystX-SimpleLogin-.*
CatalystX-SimpleLogin-0.18/META.yml 000644 000765 000024 00000004451 12002530435 016710 0 ustar 00t0m staff 000000 000000 ---
abstract: 'Provide a simple Login controller which can be reused'
author:
- '=over'
build_requires:
Catalyst::Action::RenderView: 0
Catalyst::ActionRole::ACL: 0
Catalyst::Plugin::Session::State::Cookie: 0
Catalyst::Plugin::Session::Store::File: 0
CatalystX::InjectComponent: 0
ExtUtils::MakeMaker: 6.36
File::Temp: 0
HTTP::Request::Common: 0
SQL::Translator: 0
Test::Exception: 0
Test::More: 0.94
configure_requires:
ExtUtils::MakeMaker: 6.36
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: CatalystX-SimpleLogin
no_index:
directory:
- inc
- t
provides:
Catalyst::ActionRole::NeedsLogin:
file: lib/Catalyst/ActionRole/NeedsLogin.pm
CatalystX::SimpleLogin:
file: lib/CatalystX/SimpleLogin.pm
version: 0.18
CatalystX::SimpleLogin::Controller::Login:
file: lib/CatalystX/SimpleLogin/Controller/Login.pm
CatalystX::SimpleLogin::Form::Login:
file: lib/CatalystX/SimpleLogin/Form/Login.pm
CatalystX::SimpleLogin::Form::LoginOpenID:
file: lib/CatalystX/SimpleLogin/Form/LoginOpenID.pm
CatalystX::SimpleLogin::TraitFor::Controller::Login::Logout:
file: lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/Logout.pm
CatalystX::SimpleLogin::TraitFor::Controller::Login::OpenID:
file: lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/OpenID.pm
CatalystX::SimpleLogin::TraitFor::Controller::Login::RenderAsTTTemplate:
file: lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/RenderAsTTTemplate.pm
CatalystX::SimpleLogin::TraitFor::Controller::Login::WithRedirect:
file: lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/WithRedirect.pm
requires:
Catalyst::Action::REST: 0.74
Catalyst::Plugin::Authentication: 0
Catalyst::Plugin::Session: 0.27
Catalyst::Runtime: 5.80013
Catalyst::View::TT: 0
CatalystX::Component::Traits: 0.13
CatalystX::InjectComponent: 0
HTML::FormHandler: 0.28001
Moose: 0
Moose::Autobox: 0
MooseX::MethodAttributes: 0.18
MooseX::RelatedClassRoles: 0.004
MooseX::Types: 0
MooseX::Types::Common: 0
namespace::autoclean: 0
resources:
license: http://dev.perl.org/licenses/
repository: git://github.com/bobtfish/catalystx-simplelogin.git
version: 0.18
CatalystX-SimpleLogin-0.18/README 000644 000765 000024 00000012123 12002530434 016311 0 ustar 00t0m staff 000000 000000 NAME
CatalystX::SimpleLogin - Provide a simple Login controller which can be
reused
SYNOPSIS
package MyApp;
use Moose;
use namespace::autoclean;
use Catalyst qw/
+CatalystX::SimpleLogin
Authentication
Session
Session::State::Cookie
Session::Store::File
/;
extends 'Catalyst';
__PACKAGE__->config(
'Plugin::Authentication' => { # Auth config here }
);
__PACKAGE__->config(
'Controller::Login' => { # SimpleLogin config here }
);
__PACKAGE__->setup;
ATTENTION!
If you're new here, you should start by reading
CatalystX::SimpleLogin::Manual, which provides a gentler introduction to
using this code. Come back here when you're done there.
DESCRIPTION
CatalystX::SimpleLogin is an application class Moose::Role which will
inject a Catalyst::Controller which is an instance of
CatalystX::SimpleLogin::Controller::Login into your application. This
provides a simple login and logout page with the adition of only one
line of code and one template to your application.
REQUIREMENTS
A Catalyst application
Working authentication configuration
Working session configuration
A view
CUSTOMISATION
CatalystX::SimpleLogin is a prototype for CatalystX::Elements. As such,
one of the goals is to make it easy for users to customise the provided
component to the maximum degree possible, and also, to have a linear
relationship between effort invested and level of customisation
achieved.
Three traits are shipped with SimpleLogin: WithRedirect, Logout, and
RenderAsTTTemplate. These traits are set in the config:
__PACKAGE__->config(
'Controller::Login' => {
traits => [qw/ Logout WithRedirect RenderAsTTTemplate /],
login_form_args => { # see the login form },
);
COMPONENTS
* CatalystX::SimpleLogin::Controller::Login - first point of call for
customisation. Override the action configs to reconfigure the paths
of the login or logout actions. Subclass to be able to apply method
modifiers to run before / after the login or logout actions or
override methods.
* CatalystX::SimpleLogin::TraitFor::Controller::Login::Logout -
provides the "logout" action and associated methods. You can compose
this manually yourself if you want just that action.
This trait is set by default, but if you set another trait in your
config, you will have to include it.
* CatalystX::SimpleLogin::TraitFor::Controller::Login::WithRedirect -
provides the "login" action with a wrapper to redirect to a page
which needs authentication, from which the user was previously
redirected. Goes hand in hand with Catalyst::ActionRole::NeedsLogin
* CatalystX::SimpleLogin::TraitFor::Controller::Login::RenderAsTTTempl
ate - sets the stash variable 'template' to point to a string
reference containing the rendered template so that it's not
necessary to have a login.tt template file.
* CatalystX::SimpleLogin::Form::Login - the HTML::FormHandler form for
the login form.
* Catalyst::ActionRole::NeedsLogin - Used to cause a specific path to
redirect to the login page if a user is not authenticated.
TODO
Here's a list of what I think needs working on, in no particular order.
Please feel free to add to or re-arrange this list :)
Fix extension documentation
Document all this stuff.
Examples of use / customisation in documentation
Fixing one uninitialized value warning in LoginRedirect
Disable the use of NeedsLogin ActionRole when WithRedirect is not loaded
SOURCE CODE
http://github.com/bobtfish/catalystx-simplelogin/tree/master
git://github.com/bobtfish/catalystx-simplelogin.git
Forks and patches are welcome. #formhandler or #catalyst (irc.perl.org)
are both good places to ask about using or developing this code.
SEE ALSO
* Catalyst
* Moose and Moose::Role
* MooseX::MethodAttributes::Role - Actions composed from Moose::Role.
* CatalystX::InjectComponent - Injects the controller class
* HTML::FormHandler - Generates the login form
* Catalyst::Plugin::Authentication - Responsible for the actual heavy
lifting of authenticating the user
* Catalyst::Plugin::Session
* Catalyst::Controller - Allows you to decorate actions with roles
(E.g Catalyst::ActionRole::NeedsLogin)
* CatalystX::Component::Traits - Allows Moose::Role to be composed
onto components from config
AUTHORS
Tomas Doran (t0m) "bobtfish@bobtfish.net"
Zbigniew Lukasiak
Stephan Jauernick (stephan48) "stephan@stejau.de"
Gerda Shank (gshank) "gshank@cpan.org"
Florian Ragwitz "rafl@debian.org"
Shlomi Fish
Oleg Kostyuk (cub-uanic) "cub@cpan.org"
LICENSE
Copyright 2009 Tomas Doran. Some rights reserved.
This sofware is free software, and is licensed under the same terms as
perl itself.
CatalystX-SimpleLogin-0.18/t/ 000755 000765 000024 00000000000 12002530505 015674 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/00-load.t 000644 000765 000024 00000000270 11233534244 017225 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 2;
use_ok 'CatalystX::SimpleLogin' or BAIL_OUT;
use_ok 'CatalystX::SimpleLogin::Controller::Login' or BAIL_OUT;
CatalystX-SimpleLogin-0.18/t/01-live-test.t 000644 000765 000024 00000003755 11330132751 020231 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More 'no_plan';
use HTTP::Request::Common;
# setup library path
use FindBin qw($Bin);
use lib "$Bin/lib";
use Catalyst::Test 'TestApp';
my ($res, $c);
ok(request('/')->is_success, 'Get /');
ok(request('/login')->is_success, 'Get /login');
is(request('/logout')->code, 302, 'Get 302 from /logout');
is(request('/needsauth')->code, 302, 'Get 302 from /needsauth');
($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 'aaaa']);
is($res->code, 200, 'get errors in login form');
like($c->res->body, qr/Wrong username or password/, 'login error');
like($c->res->body, qr/submit/, 'submit button on form');
($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 's00p3r']);
ok( ($c->session_expires-time()-7200) <= 0, 'Session length low when no "remember"');
($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 's00p3r', remember => 1]);
TODO: {
local $TODO = "Session expiry doesn't work";
ok( ($c->session_expires-time()-7200) >= 0, 'Long session set when "remember"');
}
is($res->code, 302, 'get 302 redirect');
my $cookie = $res->header('Set-Cookie');
ok($cookie, 'Have a cookie');
is($res->header('Location'), 'http://localhost/', 'Redirect to /');
ok($c->user, 'Have a user in $c');
($res, $c) = ctx_request(GET 'http://localhost/', Cookie => $cookie);
like($c->res->body, qr/Logged in/, 'Am logged in');
$res = request(GET 'http://localhost/needsauth', Cookie => $cookie);
is($res->code, 200, '/needsauth 200OK now');
($res, $c) = ctx_request(GET 'http://localhost/logout', Cookie => $cookie);
is($res->code, 302, '/logout with cookie redirects');
is($res->header('Location'), 'http://localhost/', 'Redirect to / after logout');
ok($res->header('Set-Cookie'), 'Cookie is reset by /logout');
($res, $c) = ctx_request(GET 'http://localhost/', Cookie => $cookie);
ok($res->is_success, '/ success');
unlike($c->res->body, qr/Logged in/, 'Am logged out');
CatalystX-SimpleLogin-0.18/t/02-redirect-test.t 000755 000765 000024 00000002750 11313165604 021075 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
use HTTP::Request::Common;
use FindBin qw($Bin);
use lib "$Bin/lib";
use Catalyst::Test 'TestAppRedirect';
foreach my $path (qw|needslogin needslogin_chained needslogin_chained_subpart|) {
my ($res, $c) = ctx_request(GET "/$path");
is($res->code, 302, 'get 302 redirect for /' . $path);
is($res->header('Location'), 'http://localhost/login', 'Redirect to /login');
ok(!$res->header('X-Action-Run'), 'Action shouldnt run! ' . ($res->header('X-Action-Run')||''));
}
{
my ($res, $c) = ctx_request(GET "/needslogin_chained_subpart");
ok($res->header('X-Start-Chain-Run'), 'Start of chain actions run when needslogin at end of chain');
}
{
my ($res, $c) = ctx_request('/needslogin');
# FIXME
# ok($c->session->{redirect_to_after_login}, '$c->session->{redirect_to_after_login} set');
my $cookie = $res->header('Set-Cookie');
ok($cookie, 'Have a cookie');
($res, $c) = ctx_request(POST '/login', [username => 'bob', password => 's00p3r'], Cookie => $cookie);
ok(!exists($c->session->{redirect_to_after_login}), '$c->session->{redirect_to_after_login} cleared');
ok($c->user, 'Have a user in $c');
is($res->code, 302, 'get 302 redirect to needslogin');
is($res->header('Location'), 'http://localhost/needslogin', 'Redirect to /needslogin');
($res, $c) = ctx_request(GET '/needslogin', Cookie => $cookie);
is($res->code, 200, 'get 200 ok for page which needs login');
}
done_testing;
CatalystX-SimpleLogin-0.18/t/03-login-form.t 000644 000765 000024 00000002001 11275362116 020357 0 ustar 00t0m staff 000000 000000 #!/usr/bin env perl
use strict;
use warnings;
use Test::More;
my $form_class = 'CatalystX::SimpleLogin::Form::Login';
use_ok( $form_class );
my $form = $form_class->new;
ok( $form, 'form created OK' );
my $rendered = $form->render;
ok( $rendered, 'form renders' );
# mock up ctx/authenticate
{
package Catalyst;
use Moose;
sub authenticate { 1 }
}
my $ctx = Catalyst->new;
my $values = { username => 'Bob', password => 'bobpw' };
my $result = $form->run( ctx => $ctx, params => $values );
ok( $result, 'result created' );
ok( $result->validated, 'result validated' );
$values->{remember} = 0;
is_deeply( $result->value, $values, 'values correct' );
$form = $form_class->new( field_list => [ '+username' => { accessor => 'user_name' },
'+password' => { accessor => 'pw' } ] );
$result = $form->run( ctx => $ctx, params => $values );
my $custom_values = { user_name => 'Bob', pw => 'bobpw', remember => 0 };
is_deeply( $result->value, $custom_values, 'accessors used for fields' );
done_testing;
CatalystX-SimpleLogin-0.18/t/04-test-role-apply-order.t 000644 000765 000024 00000000622 11233534244 022465 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More 'no_plan';
use HTTP::Request::Common;
# setup library path
use FindBin qw($Bin);
use lib "$Bin/lib";
use Catalyst::Test 'TestAppRedirect';
my ($res, $c);
($res, $c) = ctx_request(GET 'http://localhost/needsloginandhasacl');
TODO: {
local $TODO = 'Known broken';
is($res->code, 302, 'ACL Role got applied before NeedsLogin role');
}
CatalystX-SimpleLogin-0.18/t/05-login-redirect-custom-message.t 000644 000765 000024 00000001157 11233534244 024161 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More 'no_plan';
use HTTP::Request::Common;
use Data::Dumper;
# setup library path
use FindBin qw($Bin);
use lib "$Bin/lib";
use Catalyst::Test 'TestAppRedirect';
my ($res, $c);
($res, $c) = ctx_request(GET 'http://localhost/needslogincustommsg');
is($res->header('Location'), 'http://localhost/login', 'Redirect to /login');
my $cookie = $res->header('Set-Cookie');
ok($cookie, 'Have a cookie');
($res, $c) = ctx_request(GET 'http://localhost/login', Cookie => $cookie);
like($c->res->body, qr/Please Login to view this Test Action/, 'check for custom login msg'); CatalystX-SimpleLogin-0.18/t/06-rendertt.t 000644 000765 000024 00000003366 11275362116 020157 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
use HTTP::Request::Common;
use FindBin qw($Bin);
use lib "$Bin/lib";
use Catalyst::Test 'TestAppRenderTT';
my ($res, $c);
ok(request('/')->is_success, 'Get /');
ok(request('/login')->is_success, 'Get /login');
is(request('/logout')->code, 302, 'Get 302 from /logout');
($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 'aaaa']);
is($res->code, 200, 'get errors in login form');
like($c->res->body, qr/Wrong username or password/, 'login error');
($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 's00p3r']);
ok( ($c->session_expires-time()-7200) <= 0, 'Session length low when no "remember"');
($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 's00p3r', remember => 1]);
TODO: {
local $TODO = "Session expiry doesn't work";
ok( ($c->session_expires-time()-7200) >= 0, 'Long session set when "remember"');
}
is($res->code, 302, 'get 302 redirect');
my $cookie = $res->header('Set-Cookie');
ok($cookie, 'Have a cookie');
is($res->header('Location'), 'http://localhost/', 'Redirect to /');
ok($c->user, 'Have a user in $c');
($res, $c) = ctx_request(GET 'http://localhost/', Cookie => $cookie);
like($c->res->body, qr/Logged in/, 'Am logged in');
($res, $c) = ctx_request(GET 'http://localhost/logout', Cookie => $cookie);
is($res->code, 302, '/logout with cookie redirects');
is($res->header('Location'), 'http://localhost/', 'Redirect to / after logout');
ok($res->header('Set-Cookie'), 'Cookie is reset by /logout');
($res, $c) = ctx_request(GET 'http://localhost/', Cookie => $cookie);
ok($res->is_success, '/ success');
unlike($c->res->body, qr/Logged in/, 'Am logged out');
done_testing;
CatalystX-SimpleLogin-0.18/t/07-openid-live.t 000644 000765 000024 00000002224 11310024366 020524 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
use HTTP::Request::Common;
# setup library path
use FindBin qw($Bin);
use lib "$Bin/lib";
BEGIN {
unless (
eval { require Crypt::DH } &&
eval { require Catalyst::Authentication::Credential::OpenID; }
) {
plan skip_all => 'OpenID dependencies not installed';
}
}
use Catalyst::Test 'TestAppOpenID';
my ($res, $c);
ok(request('/login')->is_success, 'Get /login');
($res, $c) = ctx_request(POST 'http://localhost/login', [ openid_identifier => 'aaa' ]);
is($res->code, 200, 'get login form');
ok( $res->content =~ /class="error_message">Invalid OpenID 'http://mock.open.id.server' ]);
is($res->code, 302, 'get redirect to openid server');
is($res->header( 'location' ), 'http://localhost/login?openid-check=1', 'Redir location');
($res, $c) = ctx_request(POST 'http://localhost/login?openid-check=1', );
my $user = $c->user;
is( $user->{url}, 'http://mock.open.id.server', 'user url' );
is( $user->{display}, 'mocked_user', 'user display' );
done_testing;
CatalystX-SimpleLogin-0.18/t/08-dbic-mappedfields.t 000644 000765 000024 00000003370 11405767227 021670 0 ustar 00t0m staff 000000 000000 use strict;
use warnings;
use Test::More;
use Test::Exception;
use Class::MOP;
use HTTP::Request::Common;
use FindBin qw/$Bin/;
use lib "$Bin/lib";
BEGIN {
my @needed = qw/
Catalyst::Model::DBIC::Schema
Catalyst::Authentication::Store::DBIx::Class
DBIx::Class::Optional::Dependencies
/;
plan skip_all => "One of the required classes for this test $@ (" . join(',', @needed) . ") not found."
unless eval {
Class::MOP::load_class($_) for @needed; 1;
};
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
unless DBIx::Class::Optional::Dependencies->req_ok_for('admin');
}
use Catalyst::Test qw/TestAppDBIC/;
my $db_file = "$Bin/lib/TestAppDBIC/testdbic.db";
unlink $db_file if -e $db_file;
use_ok('TestAppDBIC::Schema');
my $schema;
lives_ok { $schema = TestAppDBIC::Schema->connect("DBI:SQLite:$db_file") }
'Connect';
ok $schema;
lives_ok { $schema->deploy } 'deploy schema';
$schema->resultset('User')->create({
user_name => 'bob',
password => 'bbbb',
});
ok(request('/')->is_success, 'Get /');
ok(request('/login')->is_success, 'Get /login');
is(request('/logout')->code, 302, 'Get 302 from /logout');
{
my ($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 'aaaa']);
is($res->code, 200, 'get 200 ok as login page redisplayed when bullshit');
($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 'bbbb']);
is($res->code, 302, 'get 302 redirect');
my $cookie = $res->header('Set-Cookie');
ok($cookie, 'Have a cookie');
is($res->header('Location'), 'http://localhost/', 'Redirect to /');
ok($c->user, 'Have a user in $c');
}
done_testing;
CatalystX-SimpleLogin-0.18/t/09-clearsession.t 000644 000765 000024 00000005321 11401500402 020775 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
use LWP::UserAgent;
use HTTP::Request::Common;
use FindBin qw($Bin);
use lib "$Bin/lib";
use Catalyst::Test 'TestAppClearSession';
####################################################################
# This test will is here to see if 'clear_session_on_logout' works.#
####################################################################
# __PACKAGE__->config('Controller::Login' => { clear_session_on_logout => 1 });
####################################################################
# Can we request the index of the correct test app?..
my ($res, $c) = ctx_request(GET "/");
like($c->res->body, qr/BLARRRMOO/, '');
# Can we request that something be set in the session?..
($res, $c) = ctx_request(GET "/setsess");
is($res->code, 200, 'Set session requested (not logged in)');
# Did we get a cookie?..
my $cookie = $res->header('Set-Cookie');
ok($cookie, 'Got cookie - 001');
# Is there something in the session?..
($res, $c) = ctx_request(GET '/viewsess', Cookie => $cookie);
like($c->res->body, qr/session_var1_set=someval1/, '');
# Can we request that something else be set in the session .... even thou we have not yet logged in?
#... should not be able to as this action 'NeedsLogin'...
($res, $c) = ctx_request(GET "/needsloginsetsess", Cookie => $cookie );
is($res->code, 302, 'Set session requested (logged in) ... we are not yet logged in');
# Can we login?...
($res, $c) = ctx_request(POST 'login', [ username => 'william', password => 's3cr3t' ], Cookie => $cookie );
is($res->code, 302, 'Logged in so therefore got 302 redirect');
# Is there still something in the session?..
($res, $c) = ctx_request(GET '/viewsess', Cookie => $cookie);
like($c->res->body, qr/session_var1_set=someval1/, '');
# Can we request that something else be set in the session now we are logged in?..
($res, $c) = ctx_request(GET "/needsloginsetsess", Cookie => $cookie );
is($res->code, 200, 'Set session requested (logged in)');
# Is there something new in the session?..
($res, $c) = ctx_request(GET '/viewsess', Cookie => $cookie);
like($c->res->body, qr/session_var2_set=someval2/, '');
# Can we logout?..
($res, $c) = ctx_request(GET 'logout', Cookie => $cookie );
is($res->code, 302, 'Logged out so therefore got 302 redirect');
# Ensure we are logged out, by requesting something at 'NeedsLogin'..
($res, $c) = ctx_request(GET "/needsloginsetsess", Cookie => $cookie );
is($res->code, 302, 'Set session requested (logged in)');
# Now lets have look at the session.. it should be clear..
# Is there something new in the session?..
($res, $c) = ctx_request(GET '/viewsess', Cookie => $cookie);
like($c->res->body, qr/In the session::/, 'Should be seeing a cleared session');
done_testing;
CatalystX-SimpleLogin-0.18/t/10-form-args.t 000644 000765 000024 00000001077 11631243672 020216 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More 'no_plan';
use HTTP::Request::Common;
# setup library path
use FindBin qw($Bin);
use lib "$Bin/lib";
use Catalyst::Test 'TestAppFormArgs';
my ($res, $c);
ok(request('/')->is_success, 'Get /');
ok(request('/login')->is_success, 'Get /login');
($res, $c) = ctx_request(GET 'http://localhost/login' );
like( $c->res->body, qr/Testing Form Args/, 'extra form field added' );
like( $c->res->body, qr/\/, 'submit button modified' );
CatalystX-SimpleLogin-0.18/t/author/ 000755 000765 000024 00000000000 12002530505 017176 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/chained_parts.t 000644 000765 000024 00000002172 11340022536 020673 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
use HTTP::Request::Common;
# setup library path
use FindBin qw($Bin);
use lib "$Bin/lib";
use Catalyst::Test 'TestApp';
my ($res, $c);
ok(request('/')->is_success, 'Get /');
ok(request('/login')->is_success, 'Get /login');
is(request('/chainedexample')->code, 302, 'Get 302 from /chainedexample');
is(request('/chainedexample/foo')->code, 302, 'Get 302 from /chainedexample/foo');
($res, $c) = ctx_request(GET 'http://localhost/chainedexample/public');
like($c->res->body, qr/page is public/, 'Public page is public.');
($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 's00p3r']);
is($res->code, 302, 'get 302 redirect');
my $cookie = $res->header('Set-Cookie');
ok($cookie, 'Have a cookie');
ok($c->user, 'Have a user in $c');
($res, $c) = ctx_request(GET 'http://localhost/chainedexample', Cookie => $cookie);
like($c->res->body, qr/Welcome bob/, 'Am logged in');
($res, $c) = ctx_request(GET 'http://localhost/chainedexample/foo', Cookie => $cookie);
like($c->res->body, qr/bob you inputted foo/, 'Works for sub path');
done_testing;
CatalystX-SimpleLogin-0.18/t/lib/ 000755 000765 000024 00000000000 12002530505 016442 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/Catalyst/ 000755 000765 000024 00000000000 12002530505 020226 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/script/ 000755 000765 000024 00000000000 12002530505 017746 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestApp/ 000755 000765 000024 00000000000 12002530505 020022 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestApp.pm 000644 000765 000024 00000000440 11311226162 020361 0 ustar 00t0m staff 000000 000000 package TestApp;
use Moose;
use namespace::autoclean;
extends 'TestAppBase';
__PACKAGE__->config(
'Controller::Login' => {
# Doing our own templates, without the redirect stuff.
traits => ['-WithRedirect', '-RenderAsTTTemplate'],
},
);
__PACKAGE__->setup;
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/ 000755 000765 000024 00000000000 12002530505 020615 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppBase.pm 000644 000765 000024 00000003402 12000031437 021150 0 ustar 00t0m staff 000000 000000 package TestAppBase;
use Moose;
use CatalystX::InjectComponent;
use File::Temp qw/ tempdir /;
use namespace::autoclean;
use Catalyst qw/
+CatalystX::SimpleLogin
Authentication
Session
Session::Store::File
Session::State::Cookie
/;
extends 'Catalyst';
# HULK SMASH.
# Catalyst->import calls setup_home, which results in config for
# the root directory being set if not already set. Ergo we end
# up with the templates for this class, rather than the subclass,
# which is fail..
# FIXME - Do the appropriate handwave here to tell TT about the extra
# base app include path, rather than throwing the root dir
# away..
__PACKAGE__->config(home => undef, root => undef);
# Normal default config.
__PACKAGE__->config(
'Plugin::Authentication' => {
default => {
credential => {
class => 'Password',
password_field => 'password',
password_type => 'clear'
},
store => {
class => 'Minimal',
users => {
bob => {
password => "s00p3r",
},
william => {
password => "s3cr3t",
},
},
},
},
},
'Plugin::Session' => {
storage => tempdir( CLEANUP => 1 ),
},
);
after 'setup_components' => sub {
my ($app) = @_;
CatalystX::InjectComponent->inject(
into => $app,
component => 'TestAppBase::Controller::Root',
as => 'Root',
) unless $app->controller('Root');
CatalystX::InjectComponent->inject(
into => $app,
component => 'TestAppBase::View::HTML',
as => 'HTML',
) unless $app->view('HTML');
};
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppClearSession/ 000755 000765 000024 00000000000 12002530505 022335 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppClearSession.pm 000644 000765 000024 00000000422 11401500402 022664 0 ustar 00t0m staff 000000 000000 package TestAppClearSession;
use Moose;
use namespace::autoclean;
extends 'TestAppBase';
__PACKAGE__->config(
'Controller::Login' => {
clear_session_on_logout => 1
},
'Plugin::Session' => {
flash_to_stash => 1
}
);
__PACKAGE__->setup;
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/ 000755 000765 000024 00000000000 12002530505 020444 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC.pm 000644 000765 000024 00000001512 11311243564 021011 0 ustar 00t0m staff 000000 000000 package TestAppDBIC;
use Moose;
use namespace::autoclean;
extends 'TestAppBase';
__PACKAGE__->setup_home;
__PACKAGE__->config(
'Controller::Login' => {
login_form_args => {
authenticate_username_field_name => 'user_name',
},
},
'Model::DB' => {
connect_info => {
dsn => 'dbi:SQLite:' . __PACKAGE__->path_to('testdbic.db'),
user => '',
password => '',
},
},
'Plugin::Authentication' => {
default => {
credential => {
class => 'Password',
password_field => 'password',
password_type => 'clear'
},
store => {
class => 'DBIx::Class',
user_model => 'DB::User',
},
},
},
);
__PACKAGE__->setup;
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppFormArgs/ 000755 000765 000024 00000000000 12002530505 021463 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppFormArgs.pm 000644 000765 000024 00000000776 11445653515 022054 0 ustar 00t0m staff 000000 000000 package TestAppFormArgs;
use Moose;
use namespace::autoclean;
extends 'TestAppBase';
__PACKAGE__->config(
'Controller::Login' => {
# Doing our own templates, without the redirect stuff.
traits => ['-WithRedirect', '-RenderAsTTTemplate'],
login_form_args => {
field_list => [
extra_field => { type => 'Text', label => 'Testing Form Args' },
'+submit' => { value => 'Login' },
],
},
},
);
__PACKAGE__->setup;
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppOpenID/ 000755 000765 000024 00000000000 12002530505 021061 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppOpenID.pm 000644 000765 000024 00000000735 11453302764 021441 0 ustar 00t0m staff 000000 000000 package TestAppOpenID;
use Moose;
use namespace::autoclean;
extends 'TestAppBase';
__PACKAGE__->config(
'Plugin::Authentication' => {
default => {
credential => {
class => 'MockOpenID',
},
store => {
class => 'Null',
}
},
},
'Controller::Login' => {
login_form_class_roles => [ 'CatalystX::SimpleLogin::Form::LoginOpenID']
},
);
__PACKAGE__->setup;
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppRedirect/ 000755 000765 000024 00000000000 12002530505 021504 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppRedirect.pm 000644 000765 000024 00000000413 11311225347 022047 0 ustar 00t0m staff 000000 000000 package TestAppRedirect;
use Moose;
use namespace::autoclean;
extends 'TestAppBase';
__PACKAGE__->config(
'Controller::Login' => {
traits => 'WithRedirect',
},
'Plugin::Session' => {
flash_to_stash => 1
}
);
__PACKAGE__->setup;
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppRenderTT/ 000755 000765 000024 00000000000 12002530505 021432 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppRenderTT.pm 000644 000765 000024 00000000352 11311243351 021772 0 ustar 00t0m staff 000000 000000 package TestAppRenderTT;;
use Moose;
use namespace::autoclean;
extends 'TestAppBase';
__PACKAGE__->config(
'Controller::Login' => {
# No config needed, you get renderastt by default :)
},
);
__PACKAGE__->setup;
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppRenderTT/.exists 000644 000765 000024 00000000063 11311243554 022760 0 ustar 00t0m staff 000000 000000 # Must be here for Catalyst home detection to work
CatalystX-SimpleLogin-0.18/t/lib/TestAppRedirect/Controller/ 000755 000765 000024 00000000000 12002530505 023627 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppRedirect/root/ 000755 000765 000024 00000000000 12002530505 022467 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppRedirect/root/login/ 000755 000765 000024 00000000000 12002530505 023577 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppRedirect/root/login/login.tt 000644 000765 000024 00000000030 11263225203 025255 0 ustar 00t0m staff 000000 000000 [% render_login_form %]
CatalystX-SimpleLogin-0.18/t/lib/TestAppRedirect/Controller/Root.pm 000644 000765 000024 00000002564 11311227150 025120 0 ustar 00t0m staff 000000 000000 package TestAppRedirect::Controller::Root;
use Moose;
use namespace::autoclean;
BEGIN { extends 'TestAppBase::Controller::Root' }
after index => sub {
my ($self, $c) = @_;
$c->res->body("MOO");
};
sub _needslogin {
my ($self, $ctx) = @_;
$ctx->res->body('NeedsLogin works!');
$ctx->res->header('X-Action-Run'
=> ($ctx->res->header('X-Action-Run')||'')
. $ctx->action
);
}
sub needslogin :Local :Does('NeedsLogin') {shift->_needslogin(shift)}
sub base : Chained('/') PathPart('') CaptureArgs(0) :Does('NeedsLogin') {shift->_needslogin(shift)}
sub needslogin_chained : Chained('base') Args(0) {shift->_needslogin(shift)}
sub base2 : Chained('/') PathPart('') CaptureArgs(0) { $_[1]->res->header('X-Start-Chain-Run', 1) }
sub needslogin_chained_subpart : Chained('base2') Args(0) :Does('NeedsLogin') {shift->_needslogin(shift)}
sub needslogincustommsg :Local :Does('NeedsLogin') :LoginRedirectMessage('Please Login to view this Test Action') {
my ($self, $c) = @_;
$c->res->body('NeedsLogin works!');
}
sub needsloginandhasacl :Local :Does('NeedsLogin') :Does('ACL') :RequiresRole('abc') :ACLDetachTo('denied') {
my ($self, $c) = @_;
$c->res->body('NeedsLogin with ACL works!');
}
sub denied :Private {
my ($self, $c) = @_;
$c->res->status('403');
$c->res->body('Denied!');
}
__PACKAGE__->meta->make_immutable;
CatalystX-SimpleLogin-0.18/t/lib/TestAppOpenID/.exists 000644 000765 000024 00000000063 11311243554 022407 0 ustar 00t0m staff 000000 000000 # Must be here for Catalyst home detection to work
CatalystX-SimpleLogin-0.18/t/lib/TestAppFormArgs/Controller/ 000755 000765 000024 00000000000 12002530505 023606 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppFormArgs/root/ 000755 000765 000024 00000000000 12002530505 022446 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppFormArgs/root/login/ 000755 000765 000024 00000000000 12002530505 023556 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppFormArgs/root/login/login.tt 000644 000765 000024 00000000030 11445653515 025251 0 ustar 00t0m staff 000000 000000 [% render_login_form %]
CatalystX-SimpleLogin-0.18/t/lib/TestAppFormArgs/Controller/NeedsAuth.pm 000644 000765 000024 00000000447 12000016045 026025 0 ustar 00t0m staff 000000 000000 package TestAppFormArgs::Controller::NeedsAuth;
use Moose;
use namespace::autoclean;
BEGIN { extends 'Catalyst::Controller' }
sub foo : Chained('/') PathPart('needsauth') Args(0) Does('NeedsLogin') {
my ($self, $c) = @_;
$c->res->body("SEKRIT");
}
__PACKAGE__->meta->make_immutable;
CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/Controller/ 000755 000765 000024 00000000000 12002530505 022567 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/Model/ 000755 000765 000024 00000000000 12002530505 021504 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/Schema/ 000755 000765 000024 00000000000 12002530505 021644 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/Schema.pm 000644 000765 000024 00000000174 11311243564 022214 0 ustar 00t0m staff 000000 000000 package TestAppDBIC::Schema;
use strict;
use warnings;
use base 'DBIx::Class::Schema';
__PACKAGE__->load_namespaces;
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/View/ 000755 000765 000024 00000000000 12002530505 021356 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/View/HTML.pm 000644 000765 000024 00000000156 11311243564 022472 0 ustar 00t0m staff 000000 000000 package TestAppDBIC::View::HTML;
use Moose;
use namespace::autoclean;
extends 'TestAppBase::View::HTML';
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/Schema/Result/ 000755 000765 000024 00000000000 12002530505 023122 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/Schema/Result/User.pm 000644 000765 000024 00000000702 11311243564 024405 0 ustar 00t0m staff 000000 000000 package TestAppDBIC::Schema::Result::User;
use strict;
use warnings;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/ Core /);
__PACKAGE__->table ('user');
__PACKAGE__->add_columns (
id => { data_type => 'int', is_auto_increment => 1 },
user_name => { data_type => 'varchar', }, # Note this is not the standard 'username' field used by simplelogin
password => { data_type => 'varchar', },
);
__PACKAGE__->set_primary_key ('id');
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/Model/DB.pm 000644 000765 000024 00000000254 11311243564 022340 0 ustar 00t0m staff 000000 000000 package TestAppDBIC::Model::DB;
use strict;
use warnings;
use base 'Catalyst::Model::DBIC::Schema';
__PACKAGE__->config(
schema_class => 'TestAppDBIC::Schema',
);
1;
CatalystX-SimpleLogin-0.18/t/lib/TestAppDBIC/Controller/Root.pm 000644 000765 000024 00000000243 11311243564 024057 0 ustar 00t0m staff 000000 000000 package TestAppDBIC::Controller::Root;
use Moose;
use namespace::autoclean;
BEGIN { extends 'TestAppBase::Controller::Root' }
__PACKAGE__->meta->make_immutable;
CatalystX-SimpleLogin-0.18/t/lib/TestAppClearSession/Controller/ 000755 000765 000024 00000000000 12002530505 024460 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppClearSession/root/ 000755 000765 000024 00000000000 12002530505 023320 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppClearSession/root/login/ 000755 000765 000024 00000000000 12002530505 024430 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppClearSession/root/login/login.tt 000644 000765 000024 00000000030 11401500402 026075 0 ustar 00t0m staff 000000 000000 [% render_login_form %]
CatalystX-SimpleLogin-0.18/t/lib/TestAppClearSession/Controller/Root.pm 000644 000765 000024 00000001560 11401500402 025736 0 ustar 00t0m staff 000000 000000
package TestAppClearSession::Controller::Root;
use Moose;
use namespace::autoclean;
BEGIN { extends 'TestAppBase::Controller::Root' }
after index => sub {
my ($self, $c) = @_;
$c->res->body("BLARRRMOO");
};
sub setsess :Local
{
my ($self, $ctx) = @_;
$ctx->session->{session_var1_set} = 'someval1';
$ctx->res->body('Set the session');
}
sub needsloginsetsess :Local :Does('NeedsLogin')
{
my ($self, $ctx) = @_;
$ctx->session->{session_var2_set} = 'someval2';
$ctx->res->body('Logged in and set the session');
}
sub viewsess :Local
{
my ($self, $ctx) = @_;
my $session_string = '';
foreach ( keys %{ $ctx->session } )
{
next if $_ =~ /^\_\_/;
$session_string .= $_ . '=' . $ctx->session->{$_} . ';'
}
$ctx->res->body('In the session:' . $session_string . ':');
}
__PACKAGE__->meta->make_immutable;
CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/Controller/ 000755 000765 000024 00000000000 12002530505 022740 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/root/ 000755 000765 000024 00000000000 12002530505 021600 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/Script/ 000755 000765 000024 00000000000 12002530505 022061 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/View/ 000755 000765 000024 00000000000 12002530505 021527 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/View/HTML.pm 000644 000765 000024 00000000277 11311226162 022642 0 ustar 00t0m staff 000000 000000 package TestAppBase::View::HTML;
use Moose;
use namespace::autoclean;
extends 'Catalyst::View::TT';
__PACKAGE__->config(
WRAPPER => 'wrapper.tt',
TEMPLATE_EXTENSION => '.tt',
);
1; CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/Script/Server.pm 000644 000765 000024 00000001435 11311226162 023673 0 ustar 00t0m staff 000000 000000 package TestAppBase::Script::Server;
use Moose;
use MooseX::Types::Moose qw/Str/;
use Moose::Util::TypeConstraints;
use namespace::autoclean;
extends 'Catalyst::Script::Server';
my $appname = do {
my $re = q{^TestApp(|DBIC|OpenID|Redirect|RenderTT)$};
subtype Str,
where { /$re/ },
message { "Application name must match /$re/" };
};
# FIXME
# Gross, but overriding NoGetopt with Getopt doesn't work
# right, and nor does +application_name with cmd_aliases
# (as Moose uses a white list of options you can change
# with has +).
__PACKAGE__->meta->remove_attribute('application_name');
has application_name => (
isa => $appname,
traits => [qw/Getopt/],
cmd_aliases => ['app', 'name'],
is => 'ro',
required => 1,
);
__PACKAGE__->meta->make_immutable;
CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/root/index.tt 000644 000765 000024 00000000054 11311243525 023264 0 ustar 00t0m staff 000000 000000 It works. [% IF c.user %]Logged in[% END %]
CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/root/wrapper.tt 000644 000765 000024 00000000122 11311243525 023631 0 ustar 00t0m staff 000000 000000
[% error_msg || c.flash.error_msg %]
[% content %]
CatalystX-SimpleLogin-0.18/t/lib/TestAppBase/Controller/Root.pm 000644 000765 000024 00000000643 12000016040 024213 0 ustar 00t0m staff 000000 000000 package TestAppBase::Controller::Root;
use Moose;
use namespace::autoclean;
BEGIN { extends 'Catalyst::Controller' }
__PACKAGE__->config(
namespace => '',
);
sub auto : Action {
my ($self, $c) = @_;
$c->stash->{additional_template_paths} =
[$c->config->{home} . '/../TestAppBase/root'];
1;
}
sub index : Path { }
sub end : ActionClass('RenderView') {}
__PACKAGE__->meta->make_immutable;
CatalystX-SimpleLogin-0.18/t/lib/TestApp/Controller/ 000755 000765 000024 00000000000 12002530505 022145 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestApp/root/ 000755 000765 000024 00000000000 12002530505 021005 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestApp/root/chainedexample/ 000755 000765 000024 00000000000 12002530505 023754 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestApp/root/login/ 000755 000765 000024 00000000000 12002530505 022115 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/TestApp/root/login/login.tt 000644 000765 000024 00000000030 11263225203 023573 0 ustar 00t0m staff 000000 000000 [% render_login_form %]
CatalystX-SimpleLogin-0.18/t/lib/TestApp/root/chainedexample/index.tt 000644 000765 000024 00000000031 11340022536 025432 0 ustar 00t0m staff 000000 000000 Welcome [% c.user.id %].
CatalystX-SimpleLogin-0.18/t/lib/TestApp/root/chainedexample/item.tt 000644 000765 000024 00000000433 11340022536 025267 0 ustar 00t0m staff 000000 000000 [% c.user.id %] you inputted [% arg1 | html %].
[%# N.B. Trusting your safety to XSS attacks from arbitrary
user input to a lone | html in TT is probably
a stupendously bad idea. I'd recommend being
significantly more paranoid if doing anything 'real' -%]
CatalystX-SimpleLogin-0.18/t/lib/TestApp/root/chainedexample/public.tt 000644 000765 000024 00000000024 11340022536 025603 0 ustar 00t0m staff 000000 000000 This page is public. CatalystX-SimpleLogin-0.18/t/lib/TestApp/Controller/ChainedExample.pm 000644 000765 000024 00000001244 12000016034 025345 0 ustar 00t0m staff 000000 000000 package TestApp::Controller::ChainedExample;
use Moose;
use namespace::autoclean;
BEGIN { extends 'Catalyst::Controller' }
sub base : Chained('/login/required') PathPart('chainedexample') CaptureArgs(0) {} # Chain everything in the controller off of here.
sub index : Chained('base') PathPart('') Args(0) { # /chainedexample
}
sub item : Chained('base') PathPart('') Args(1) { #/chainedexample/$arg1
my ($self, $c, $arg1) = @_;
$c->stash->{arg1} = $arg1;
}
sub no_auth_base : Chained('/login/not_required') PathPart('chainedexample') CaptureArgs(0) {}
sub public : Chained('no_auth_base') Args(0) {} # /chainedexample/public
__PACKAGE__->meta->make_immutable;
CatalystX-SimpleLogin-0.18/t/lib/TestApp/Controller/NeedsAuth.pm 000644 000765 000024 00000000437 12000016036 024363 0 ustar 00t0m staff 000000 000000 package TestApp::Controller::NeedsAuth;
use Moose;
use namespace::autoclean;
BEGIN { extends 'Catalyst::Controller' }
sub foo : Chained('/') PathPart('needsauth') Args(0) Does('NeedsLogin') {
my ($self, $c) = @_;
$c->res->body("SEKRIT");
}
__PACKAGE__->meta->make_immutable;
CatalystX-SimpleLogin-0.18/t/lib/script/testapp_server.pl 000644 000765 000024 00000000310 11445656735 023373 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use strict;
use warnings;
use FindBin qw/$Bin/;
use lib "$Bin/../../../lib", "$Bin/../";
use TestAppBase::Script::Server;
TestAppBase::Script::Server->new_with_options->run;
1;
CatalystX-SimpleLogin-0.18/t/lib/Catalyst/Authentication/ 000755 000765 000024 00000000000 12002530505 023205 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/Catalyst/Authentication/Credential/ 000755 000765 000024 00000000000 12002530505 025257 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/t/lib/Catalyst/Authentication/Credential/MockOpenID.pm 000644 000765 000024 00000001701 11310023472 027545 0 ustar 00t0m staff 000000 000000 package Catalyst::Authentication::Credential::MockOpenID;
use strict;
use warnings;
use base qw/Catalyst::Authentication::Credential::OpenID/;
sub authenticate {
my ( $self, $c, $realm, $authinfo ) = @_;
my $claimed_uri = $authinfo->{ 'openid_identifier' };
if ( $claimed_uri ) {
if( $claimed_uri eq 'aaa' ){
return;
}
if( $claimed_uri eq 'http://mock.open.id.server' ){
$c->res->redirect( 'http://localhost/login?openid-check=1' );
$c->detach();
}
}
elsif ( $c->req->params->{'openid-check'} ){
my $user = {
url => 'http://mock.open.id.server' ,
display => 'mocked_user' ,
rss => '',
atom => '',
foaf => '',
declared_rss => '',
declared_atom => '',
declared_foaf => '',
foafmaker => '',
};
return $realm->find_user($user, $c);
}
}
1;
CatalystX-SimpleLogin-0.18/t/author/eol.t 000644 000765 000024 00000000312 11233534244 020147 0 ustar 00t0m staff 000000 000000 #!/usr/bin/env perl
use Test::More;
eval {require Test::EOL; };
if ($@) {
plan skip_all => 'Need Test::EOL installed for line ending tests';
exit 0;
}
Test::EOL->import;
all_perl_files_ok();
CatalystX-SimpleLogin-0.18/t/author/notabs.t 000644 000765 000024 00000000232 11233534244 020657 0 ustar 00t0m staff 000000 000000
use Test::More;
eval { require Test::NoTabs; };
if ($@) { plan skip_all => 'Test::NoTabs not installed'; exit 0; }
Test::NoTabs::all_perl_files_ok();
CatalystX-SimpleLogin-0.18/t/author/pod-coverage.t 000644 000765 000024 00000000252 12000017115 021730 0 ustar 00t0m staff 000000 000000 #!perl
use Test::More;
eval "use Test::Pod::Coverage 1.08";
plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@;
all_pod_coverage_ok();
CatalystX-SimpleLogin-0.18/t/author/pod.t 000644 000765 000024 00000000214 11233534244 020153 0 ustar 00t0m staff 000000 000000 #!perl -T
use Test::More;
eval "use Test::Pod 1.14";
plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
all_pod_files_ok();
CatalystX-SimpleLogin-0.18/lib/Catalyst/ 000755 000765 000024 00000000000 12002530505 017763 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/CatalystX/ 000755 000765 000024 00000000000 12002530505 020113 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/ 000755 000765 000024 00000000000 12002530505 022335 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin.pm 000644 000765 000024 00000012740 12002530412 022674 0 ustar 00t0m staff 000000 000000 package CatalystX::SimpleLogin;
use Moose::Role;
use CatalystX::InjectComponent;
use namespace::autoclean;
our $VERSION = '0.18';
after 'setup_components' => sub {
my $class = shift;
CatalystX::InjectComponent->inject(
into => $class,
component => 'CatalystX::SimpleLogin::Controller::Login',
as => 'Controller::Login'
);
};
=head1 NAME
CatalystX::SimpleLogin - Provide a simple Login controller which can be reused
=head1 SYNOPSIS
package MyApp;
use Moose;
use namespace::autoclean;
use Catalyst qw/
+CatalystX::SimpleLogin
Authentication
Session
Session::State::Cookie
Session::Store::File
/;
extends 'Catalyst';
__PACKAGE__->config(
'Plugin::Authentication' => { # Auth config here }
);
__PACKAGE__->config(
'Controller::Login' => { # SimpleLogin config here }
);
__PACKAGE__->setup;
=head1 ATTENTION!
If you're new here, you should start by reading
L, which provides a gentler introduction to
using this code. Come back here when you're done there.
=head1 DESCRIPTION
CatalystX::SimpleLogin is an application class L which will
inject a L
which is an instance of L into your
application. This provides a simple login and logout page with the adition
of only one line of code and one template to your application.
=head1 REQUIREMENTS
=over
=item A Catalyst application
=item Working authentication configuration
=item Working session configuration
=item A view
=back
=head1 CUSTOMISATION
CatalystX::SimpleLogin is a prototype for CatalystX::Elements. As such, one of the goals
is to make it easy for users to customise the provided component to the maximum degree
possible, and also, to have a linear relationship between effort invested and level of
customisation achieved.
Three traits are shipped with SimpleLogin: WithRedirect, Logout, and RenderAsTTTemplate.
These traits are set in the config:
__PACKAGE__->config(
'Controller::Login' => {
traits => [qw/ Logout WithRedirect RenderAsTTTemplate /],
login_form_args => { # see the login form },
);
=head1 COMPONENTS
=over
=item *
L - first point of call for customisation.
Override the action configs to reconfigure the paths of the login or logout actions.
Subclass to be able to apply method modifiers to run before / after the login or
logout actions or override methods.
=item *
L - provides the C action
and associated methods. You can compose this manually yourself if you want just that
action.
This trait is set by default, but if you set another trait in your config, you
will have to include it.
=item *
L - provides the C
action with a wrapper to redirect to a page which needs authentication, from which the
user was previously redirected. Goes hand in hand with L
=item *
L - sets
the stash variable 'template' to point to a string reference containing the
rendered template so that it's not necessary to have a login.tt template file.
=item *
L - the L form for the login form.
=item *
L - Used to cause a specific path to redirect to the login
page if a user is not authenticated.
=back
=head1 TODO
Here's a list of what I think needs working on, in no particular order.
Please feel free to add to or re-arrange this list :)
=over
=item Fix extension documentation
=item Document all this stuff.
=item Examples of use / customisation in documentation
=item Fixing one uninitialized value warning in LoginRedirect
=item Disable the use of NeedsLogin ActionRole when WithRedirect is not loaded
=back
=head1 SOURCE CODE
http://github.com/bobtfish/catalystx-simplelogin/tree/master
git://github.com/bobtfish/catalystx-simplelogin.git
Forks and patches are welcome. #formhandler or #catalyst (irc.perl.org)
are both good places to ask about using or developing this code.
=head1 SEE ALSO
=over
=item *
L
=item *
L and L
=item *
L - Actions composed from L.
=item *
L - Injects the controller class
=item *
L - Generates the login form
=item *
L - Responsible for the actual heavy lifting of authenticating the user
=item *
L
=item *
L - Allows you to decorate actions with roles (E.g L)
=item *
L - Allows L to be composed onto components from config
=back
=head1 AUTHORS
=over
=item Tomas Doran (t0m) C<< bobtfish@bobtfish.net >>
=item Zbigniew Lukasiak
=item Stephan Jauernick (stephan48) C<< stephan@stejau.de >>
=item Gerda Shank (gshank) C<< gshank@cpan.org >>
=item Florian Ragwitz C<< rafl@debian.org >>
=item Shlomi Fish
=item Oleg Kostyuk (cub-uanic) C<< cub@cpan.org >>
=back
=head1 LICENSE
Copyright 2009 Tomas Doran. Some rights reserved.
This sofware is free software, and is licensed under the same terms as perl itself.
=cut
1;
CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/Controller/ 000755 000765 000024 00000000000 12002530505 024460 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/Form/ 000755 000765 000024 00000000000 12002530505 023240 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/Manual.pod 000644 000765 000024 00000015703 12000576142 024271 0 ustar 00t0m staff 000000 000000 =head1 NAME
CatalystX::SimpleLogin::Manual - How to use and customise CatalystX::SimpleLogin.
=head2 Tutorial
We're using a sample application here, to make the instructions a little
easier. This assumes that you have Catalyst, Catalyst::Devel,
Template Toolkit, and the Catalyst authentication and session plugins
installed.
catalyst.pl MyApp
cd MyApp
script/myapp_create.pl view HTML TT
Edit lib/MyApp.pm and add CatalystX::SimpleLogin, Authenticate, and the
Session plugins to the use Catalyst plugin list:
use Catalyst qw/-Debug
ConfigLoader
+CatalystX::SimpleLogin
Authentication
Session
Session::Store::File
Session::State::Cookie
Static::Simple/;
Add the following config for authentication, including two sample users:
__PACKAGE__->config(
'Plugin::Authentication' => {
default => {
credential => {
class => 'Password',
password_field => 'password',
password_type => 'clear'
},
store => {
class => 'Minimal',
users => {
bob => {
password => "bobpw",
},
william => {
password => "billpw",
},
},
},
},
},
);
Execute C< script/myapp_server.pl > and, as part of the debug output, you should see:
[debug] Loaded Chained actions:
.-------------------------------------+--------------------------------------.
| Path Spec | Private |
+-------------------------------------+--------------------------------------+
| /login | /login/login |
| /logout | /login/logout |
'-------------------------------------+--------------------------------------'
Go to C< localhost:3000 > and you should see the Catalyst welcome screen. Go to
C< localhost:3000/login > and you should get a login screen containing username and
password text fields, a 'Remember' checkbox, and a 'Login' button. Enter 'bob' and
'bobpw'. You should be logged in and taken to the welcome screen. If you execute
C< localhost:3000/logout > you will be logged out, and should see this in the
debug output (the welcome screen will stay the same).
Now go to C< lib/MyApp/Controller/Root.pm > and remove the lines saying:
use strict;
use warnings;
use parent 'Catalyst::Controller';
and add the following lines:
use Moose;
use namespace::autoclean;
BEGIN { extends 'Catalyst::Controller' }
Now add a new action to C< lib/MyApp/Controller/Root.pm > and include
C< Does('NeedsLogin') > to use the Catalyst ActionRole that is part of SimpleLogin:
sub hello_user : Local Does('NeedsLogin') {
my ( $self, $c ) = @_;
$c->res->body('
Hello, user!
');
}
Restart the server and you can see the new action. Go to C<< htp://localhost:3000/hello_user >>
and you'll get the 'Hello, user!' page. Now execute C<< http://localhost:3000/logout >> and try
C<< http://localhost:3000/hello_user >> again. You will be presented with a login screen.
=head3 Authorization
CatalystX::SimpleLogin also provides /login/required and /login/not_required for easy
chaining off of for actions which should only be available to authenticated users.
package MyApp::Controller::Secure;
sub setup : Chained('/login/required') PathPart('') CaptureArgs(1) {
my ( $self, $c, $id ) = @_;
# setup actions for authenticated-user-only access
$c->stash->{id} = $id;
}
sub something_secure : Chained('setup') PathPart Args(0) {
my ( $self, $c ) = @_;
# only authenticated users will have access to this action
}
sub open_to_all : Chained('/login/not_required') PathPart Args(0) {
my ( $self, $c ) = @_;
# this is available to everyone
}
For more fine-grained control, you can use ACL checks to refine access
control policies. This functionality is provided via L.
Please consult the ACL documentation for steps to setup your application.
The ACL checks work by allowing you to add additional attributes on your
actions which control the particular role(s) required or allowed.
package MyApp;
__PACKAGE__->config(
'Controller::Login' => {
actions => {
required => {
Does => ['ACL'],
AllowedRole => ['admin', 'poweruser'], # ANY of these
# RequiresRole => ['extranet'], # ALL of these
ACLDetachTo => 'login',
},
},
},
);
package MyApp::Controller::Foo;
BEGIN { extends 'Catalyst::Controller' }
sub do_something : Chained('/login/required')
: Does('ACL') RequiresRole('createinvoice') ACLDetachTo('/login') {}
You can also add a message, which will be put into the flash key 'error_msg'. Add
the following to the hello_user action:
: LoginRedirectMessage('Please Login to view this Action')
Now we'll create a Template Toolkit template that can be customized. Create a
C< root/login/login.tt > file with the following lines.
[% error_msg %]
[% render_login_form %]
Now edit C< lib/MyApp.pm > and add the config shown below
to remove the 'RenderAsTTTemplate' trait, and add
'flash_to_stash' for L
(to allow the error message to be passed to the next request):
__PACKAGE__->config(
'Plugin::Session' => {
flash_to_stash => 1
},
'Controller::Login' => {
traits => ['-RenderAsTTTemplate'],
},
# Other config..
);
Restart the server and try to view the hello_user page without being logged in.
You should be reredireced to the login page with the error message displayed at
the top.
You can replace C< [% render_login_form %] > with your own html, and customize
it as you please.
[% error_msg %]
Or you can customize it using L HTML rendering features, and
the 'login_form_args' config key.
=cut
CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/TraitFor/ 000755 000765 000024 00000000000 12002530505 024067 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/TraitFor/Controller/ 000755 000765 000024 00000000000 12002530505 026212 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/ 000755 000765 000024 00000000000 12002530505 027262 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/Logout.pm 000644 000765 000024 00000004130 11751211070 031072 0 ustar 00t0m staff 000000 000000 package CatalystX::SimpleLogin::TraitFor::Controller::Login::Logout;
use MooseX::MethodAttributes::Role;
use MooseX::Types::Moose qw/Str Bool/;
use namespace::autoclean;
sub logout : Chained('/') PathPart('logout') Args(0) {
my ($self, $c) = @_;
$c->logout;
$self->do_clear_session_on_logout($c) if $self->clear_session_on_logout;
$c->res->redirect($self->redirect_after_logout_uri($c));
}
has clear_session_on_logout => (
isa => Bool,
is => 'ro',
default => 0,
);
sub do_clear_session_on_logout {
my ($self, $c) = @_;
$c->delete_session;
}
sub redirect_after_logout_uri {
my ($self, $c) = @_;
$c->uri_for($self->_redirect_after_logout_uri);
}
has _redirect_after_logout_uri => (
isa => Str,
default => '/',
init_arg => 'redirect_after_logout_uri',
is => 'ro',
);
1;
=head1 NAME
CatalystX::SimpleLogin::TraitFor::Controller::Login::Logout - log users out
=head1 DESCRIPTION
Simple controller role for logging users out. Provides a
C action (at /logout by default) which redirects
the user to the homepage by default.
=head1 ACTIONS
=head2 logout : Chained('/') PathPart('logout') Args(0)
Calls C<< $c->logout >>, then redirects to the logout uri
retuned by C<< $self->redirect_after_logout_uri >>.
=head1 METHODS
=head2 redirect_after_logout_uri
Returns the uri to redirect to after logout.
Defaults to C<< $c->uri_for('/'); >> you can override this
by setting the C<> key in config
to a path to be passed to C<< $c->uri_for >>.
Alternatively, you can write your own redirect_after_logout_uri
in your Login controller if you are extending CatalystX::SimpleLogin
and it will override the method from this role.
=head2 do_clear_session_on_logout
Deletes the session after a logout.
To enable this use the following in your config:
__PACKAGE__->config('Controller::Login' => { clear_session_on_logout => 1 });
=head1 SEE ALSO
=over
=item L
=back
=head1 AUTHORS
See L for authors.
=head1 LICENSE
See L for license.
=cut
CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/OpenID.pm 000644 000765 000024 00000003536 12000576147 030757 0 ustar 00t0m staff 000000 000000 package CatalystX::SimpleLogin::TraitFor::Controller::Login::OpenID;
use MooseX::MethodAttributes ();
use MooseX::Types::Common::String qw/ NonEmptySimpleStr /;
use Moose::Role -traits => 'MethodAttributes';
use namespace::autoclean;
has 'openid_realm' => (
is => 'ro',
isa => NonEmptySimpleStr,
required => 1,
default => 'openid',
);
around 'login_GET' => sub {
my $orig = shift;
my $self = shift;
my ( $c) = @_;
if($c->req->param("openid.mode"))
{
if($c->authenticate({},$self->openid_realm)) {
$c->flash(success_msg => "You signed in with OpenID!");
$c->res->redirect($self->redirect_after_login_uri($c));
}
else
{
$c->flash(error_msg => "Failed to sign in with OpenID!");
}
}
else
{
return $self->$orig(@_);
}
};
=head1 NAME
CatalystX::SimpleLogin::TraitFor::Controller::Login::OpenID - allows a User to login via OpenID
=head1 SYNOPSIS
package MyApp::Controller::NeedsAuth;
sub something : Path Does('NeedsLogin') {
# Redirects to /login if not logged in
}
# Turn on in config
MyApp->config('Contoller::Login' => { traits => 'Login::OpenID' });
=head1 DESCRIPTION
Provides the C action with a wrapper to redirect to a page which needs
authentication, from which the user was previously redirected. Goes hand in
hand with L .
=head1 WRAPPED METHODS
=head2 login_GET
Wrap around an openid authentication if the C<'openid.mode'> request parameter
is set. Otherwise, use the default login_GET() method.
=head1 SEE ALSO
=over
=item L
=item L
=back
=head1 AUTHORS
See L for authors.
=head1 LICENSE
See L for license.
=cut
1;
CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/RenderAsTTTemplate.pm000644 000765 000024 00000001763 11751211070 033301 0 ustar 00t0m staff 000000 000000 package CatalystX::SimpleLogin::TraitFor::Controller::Login::RenderAsTTTemplate;
use MooseX::MethodAttributes::Role;
use namespace::autoclean;
requires qw/
login
login_form_stash_key
/;
after 'login' => sub {
my ( $self, $ctx ) = @_;
my $rendered_form = $ctx->stash->{$self->login_form_stash_key}->render;
$ctx->stash( template => \$rendered_form );
};
1;
=head1 NAME
CatalystX::SimpleLogin::TraitFor::Controller::Login::RenderAsTTTemplate - render a login form with no template file
=head1 DESCRIPTION
Simple controller role to allow rendering a login form with no
template file. Sets the stash 'template' key to a string reference
containing the rendered form.
=head1 METHODS
=head2 after 'login'
$ctx->stash( template => \$self->render_login_form($ctx, $result) );
=head1 SEE ALSO
=over
=item L
=back
=head1 AUTHORS
See L for authors.
=head1 LICENSE
See L for license.
=cut
CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/TraitFor/Controller/Login/WithRedirect.pm 000644 000765 000024 00000004376 12000576152 032235 0 ustar 00t0m staff 000000 000000 package CatalystX::SimpleLogin::TraitFor::Controller::Login::WithRedirect;
use MooseX::MethodAttributes::Role;
use Moose::Autobox;
use namespace::autoclean;
requires qw/
redirect_after_login_uri
/;
around 'redirect_after_login_uri' => sub {
my ($orig, $self, $c, @args) = @_;
if (!$c->can('session')) {
$c->log->warn('No $c->session, cannot do ' . __PACKAGE__);
return $self->$orig($c, @args);
}
return $c->session->{redirect_to_after_login}
? delete $c->session->{redirect_to_after_login}
: $self->$orig($c, @args);
};
before login_redirect => sub {
my ($self, $c, $message) = @_;
$c->flash->{error_msg} = $message; # FIXME - Flash horrible
$c->session->{redirect_to_after_login}
= $c->req->uri->as_string;
};
1;
__END__
=head1 NAME
CatalystX::SimpleLogin::TraitFor::Controller::Login::WithRedirect - redirect
users who login back to the page they originally requested.
=head1 SYNOPSIS
package MyApp::Controller::NeedsAuth;
use Moose;
use namespace::autoclean;
# One needs to inherit from Catalyst::Controller in order
# to get the Does('NeedsLogin') functionality.
BEGIN { extends 'Catalyst::Controller'; }
sub inbox : Path Does('NeedsLogin') {
# Redirects to /login if not logged in
my ($self, $c) = @_;
$c->stash->{template} = "inbox.tt2";
return;
}
# Turn on in config
MyApp->config('Contoller::Login' => { traits => 'WithRedirect' });
=head1 DESCRIPTION
Provides the C
action with a wrapper to redirect to a page which needs authentication, from which the
user was previously redirected. Goes hand in hand with L
=head1 WRAPPED METHODS
=head2 redirect_after_login_uri
Make it use and extract C<< $c->session->{redirect_to_after_login} >>
if it exists.
=head1 METHODS
=head2 $controller->login_redirect($c, $message)
This sets the error message to $message and sets
C<< $c->session->{redirect_to_after_login} >> to the current URL.
=head1 SEE ALSO
=over
=item L
=item L
=back
=head1 AUTHORS
See L for authors.
=head1 LICENSE
See L for license.
=cut
CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/Form/Login.pm 000644 000765 000024 00000010016 11631243721 024654 0 ustar 00t0m staff 000000 000000 package CatalystX::SimpleLogin::Form::Login;
use HTML::FormHandler::Moose;
use namespace::autoclean;
extends 'HTML::FormHandler';
use MooseX::Types::Moose qw/ HashRef /;
use MooseX::Types::Common::String qw/ NonEmptySimpleStr /;
has '+name' => ( default => 'login_form' );
has authenticate_args => (
is => 'ro',
isa => HashRef,
predicate => 'has_authenticate_args',
);
has authenticate_realm => (
is => 'ro',
isa => NonEmptySimpleStr,
predicate => 'has_authenticate_realm',
);
has 'login_error_message' => (
is => 'ro',
isa => NonEmptySimpleStr,
required => 1,
default => 'Wrong username or password',
);
foreach my $type (qw/ username password /) {
has sprintf("authenticate_%s_field_name", $type) => (
is => 'ro',
isa => NonEmptySimpleStr,
default => $type
);
# FIXME - be able to change field names in rendered form also!
}
has_field 'username' => ( type => 'Text', tabindex => 1 );
has_field 'password' => ( type => 'Password', tabindex => 2 );
has_field 'remember' => ( type => 'Checkbox', tabindex => 3 );
has_field 'submit' => ( type => 'Submit', value => 'Login', tabindex => 4 );
sub validate {
my $self = shift;
my %values = %{$self->values}; # copy the values
unless (
$self->ctx->authenticate(
{
(map {
my $param_name = sprintf("authenticate_%s_field_name", $_);
($self->can($param_name) ? $self->$param_name() : $_) => $self->values->{$_};
}
grep { ! /remember/ }
keys %{ $self->values }),
($self->has_authenticate_args ? %{ $self->authenticate_args } : ()),
},
($self->has_authenticate_realm ? $self->authenticate_realm : ()),
)
) {
$self->add_auth_errors;
return;
}
return 1;
}
sub add_auth_errors {
my $self = shift;
$self->field( 'password' )->add_error( $self->login_error_message )
if $self->field( 'username' )->has_value && $self->field( 'password' )->has_value;
}
__PACKAGE__->meta->make_immutable;
=head1 NAME
CatalystX::SimpleLogin::Form::Login - validation for the login form
=head1 DESCRIPTION
A L form for the login form.
=head1 FIELDS
=over
=item username
=item password
=item remember
=item submit
=back
=head1 METHODS
=over
=item validate
=item add_auth_errors
=back
=head1 SEE ALSO
=over
=item L
=back
=head1 CUSTOMIZATION
By default, the params passed to authenticate() are 'username' and
'password'. If you need to use different names, then you'll need to
set the correct value(s) via login_form_args in the configuration.
The keys are 'authenticate_username_field_name' and/or
'authenticate_password_field_name'.
__PACKAGE__->config(
'Controller::Login' => {
login_form_args => {
authenticate_username_field_name => 'name',
authenticate_password_field_name => 'password2',
},
},
);
You can also change the way that the form is displayed by setting
attributes. In MyApp.pm:
__PACKAGE__->config(
'Controller::Login' => {
login_form_args => {
login_error_message => 'Login failed',
field_list => [
'+submit' => { value => 'Login' },
]
}
},
);
Additional fields can be added:
field_list => [
'foo' => ( type => 'MyField' ),
'bar' => { type => 'Text' },
]
Additional arguments to the authenticate call can be added:
If your user table has a column C and you want only those with Cto be able to log .in
__PACKAGE__->config(
'Controller::Login' => {
login_form_args => {
authenticate_args => { status => 1 },
},
},
};
=head1 AUTHORS
See L for authors.
=head1 LICENSE
See L for license.
=cut
CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/Form/LoginOpenID.pm 000644 000765 000024 00000002656 11310024544 025720 0 ustar 00t0m staff 000000 000000 package CatalystX::SimpleLogin::Form::LoginOpenID;
use HTML::FormHandler::Moose::Role;
use MooseX::Types::Common::String qw/ NonEmptySimpleStr /;
BEGIN {
unless (
eval { require Crypt::DH } &&
eval { require Catalyst::Authentication::Credential::OpenID; }
) {
warn("Cannot load " . __PACKAGE__ . " - Catalyst OpenID authentication credential not installed\n");
exit 1;
}
}
has_field 'openid_identifier' => ( type => 'Text' );
has_field 'openid-check' => ( widget => 'no_render' );
has 'openid_error_message' => (
is => 'ro',
isa => NonEmptySimpleStr,
required => 1,
default => 'Invalid OpenID',
);
after 'add_auth_errors' => sub {
my $self = shift;
$self->field( 'openid_identifier' )->add_error( $self->openid_error_message )
if $self->field( 'openid-check' )->value or defined $self->field( 'openid_identifier' )->value;
};
1;
=head1 NAME
CatalystX::SimpleLogin::Form::LoginOpenID - OpenID validation role for the login form
=head1 DESCRIPTION
A L role form for the login form.
=head1 FIELDS
=over
=item openid_identifier
=item openid-check
=item openid_error_message
=back
=head1 METHODS
=over
=item add_auth_errors
=back
=head1 SEE ALSO
=over
=item L
=back
=head1 AUTHORS
See L for authors.
=head1 LICENSE
See L for license.
=cut
CatalystX-SimpleLogin-0.18/lib/CatalystX/SimpleLogin/Controller/Login.pm 000644 000765 000024 00000015141 12000576137 026101 0 ustar 00t0m staff 000000 000000 package CatalystX::SimpleLogin::Controller::Login;
use Moose;
use Moose::Autobox;
use MooseX::Types::Moose qw/ HashRef ArrayRef ClassName Object Str /;
use MooseX::Types::Common::String qw/ NonEmptySimpleStr /;
use CatalystX::SimpleLogin::Form::Login;
use namespace::autoclean;
BEGIN { extends 'Catalyst::Controller'; }
with qw(
CatalystX::Component::Traits
Catalyst::Component::ContextClosure
);
has '+_trait_merge' => (default => 1);
__PACKAGE__->config(
traits => [qw/
WithRedirect
RenderAsTTTemplate
Logout
/],
);
sub BUILD {
my $self = shift;
$self->login_form; # Build login form at construction time
}
has login_form_class => (
isa => ClassName,
is => 'rw',
default => 'CatalystX::SimpleLogin::Form::Login',
);
has login_form_class_roles => (
isa => ArrayRef[NonEmptySimpleStr],
is => 'ro',
default => sub { [] },
);
has login_form => (
isa => Object,
is => 'ro',
lazy_build => 1,
);
has login_form_args => (
isa => HashRef,
is => 'ro',
default => sub { {} },
);
has login_form_stash_key => (
is => 'ro',
isa => Str,
default => 'login_form',
);
has render_login_form_stash_key => (
is => 'ro',
isa => Str,
default => 'render_login_form',
);
with 'MooseX::RelatedClassRoles' => { name => 'login_form' };
sub _build_login_form {
my $self = shift;
$self->apply_login_form_class_roles($self->login_form_class_roles->flatten)
if scalar $self->login_form_class_roles->flatten; # FIXME - Should MX::RelatedClassRoles
# do this automagically?
return $self->login_form_class->new($self->login_form_args);
}
sub render_login_form {
my ($self, $ctx, $form) = @_;
return $form->render;
}
sub not_required
:Chained('/')
:PathPart('')
:CaptureArgs(0)
{}
sub required
:Chained('/')
:PathPart('')
:CaptureArgs(0)
:Does('NeedsLogin')
{}
sub login
:Chained('not_required')
:PathPart('login')
:Args(0)
{
my ($self, $ctx) = @_;
my $form = $self->login_form;
my $p = $ctx->req->parameters;
if( $form->process(ctx => $ctx, params => $p) ) {
$self->do_post_login_redirect($ctx);
$ctx->extend_session_expires(999999999999)
if $form->field( 'remember' )->value;
}
$ctx->stash(
$self->login_form_stash_key => $form,
$self->render_login_form_stash_key => $self->make_context_closure(sub {
my ($ctx) = @_;
$self->render_login_form($ctx, $form);
}, $ctx),
);
}
sub do_post_login_redirect {
my ($self, $ctx) = @_;
$ctx->res->redirect($self->redirect_after_login_uri($ctx));
}
sub login_redirect {
my ($self, $ctx) = @_;
$ctx->response->redirect($ctx->uri_for($self->action_for("login")));
$ctx->detach;
}
sub redirect_after_login_uri {
my ($self, $ctx) = @_;
$ctx->uri_for($self->_redirect_after_login_uri);
}
has _redirect_after_login_uri => (
is => Str,
is => 'ro',
init_arg => 'redirect_after_login_uri',
default => '/',
);
1;
=head1 NAME
CatalystX::SimpleLogin::Controller::Login - Configurable login controller
=head1 SYNOPSIS
# For simple useage exmple, see CatalystX::SimpleLogin, this is a
# full config example
__PACKAGE__->config(
'Controller::Login' => {
traits => [
'WithRedirect', # Optional, enables redirect-back feature
'-RenderAsTTTemplate', # Optional, allows you to use your own template
],
actions => {
login => { # Also optional
PathPart => ['theloginpage'], # Change login action to /theloginpage
},
},
},
);
See L for configuring the form.
=head1 DESCRIPTION
Controller base class which exists to have login roles composed onto it
for the login and logout actions.
=head1 ATTRIBUTES
=head2 login_form_class
A class attribute containing the class of the form to be initialised. One
can override it in a derived class with the class of a new form, possibly
subclassing L. For example:
package MyApp::Controller::Login;
use Moose;
extends('CatalystX::SimpleLogin::Controller::Login');
has '+login_form_class' => (
default => "MyApp::Form::Login",
);
1;
=head2 login_form_class_roles
An attribute containing an array reference of roles to be consumed by
the form. One can override it in a similar way to C:
package MyApp::Controller::Login;
use Moose;
extends('CatalystX::SimpleLogin::Controller::Login');
has '+login_form_class_roles' => (
default => sub { [qw(MyApp::FormRole::Foo MyApp::FormRole::Bar)] },
);
1;
=head1 METHODS
=head2 BUILD
Cause form instance to be built at application startup.
=head2 do_post_login_redirect
This method does a post-login redirect. B for BOBTFISH - should it even
be public? If it does need to be public, then document it because the Pod
coverage test failed.
=head2 login
Login action.
=head2 login_redirect
Redirect to the login action.
=head2 login_GET
Displays the login form
=head2 login_POST
Processes a submitted login form, and if correct, logs the user in
and redirects
=head2 not_required
A stub action that is anchored at the root of the site ("/") and does not
require registration (hence the name).
=head2 redirect_after_login_uri
If you are using WithRedirect (i.e. by default), then this methd is overridden
to redirect the user back to the page they intially hit which required
authentication.
Note that even if the original URI was a post, then the redirect back will only
be a GET.
If you choose B to compose the WithRedirect trait, then you can set the
uri users are redirected to with the C config key,
or by overriding the redirect_after_login_uri method in your own login
controller if you need custom logic.
=head2 render_login_form
Renders the login form. By default it just calls the form's render method. If
you want to do something different, like rendering the form with a template
through your view, this is the place to hook into.
=head2 required
A stub action that is anchored at the root of the site ("/") and does
require registration (hence the name).
=head1 SEE ALSO
=over
=item L
=item L
=back
=head1 AUTHORS
See L for authors.
=head1 LICENSE
See L for license.
=cut
CatalystX-SimpleLogin-0.18/lib/Catalyst/ActionRole/ 000755 000765 000024 00000000000 12002530505 022022 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/lib/Catalyst/ActionRole/NeedsLogin.pm 000644 000765 000024 00000004104 12000576131 024411 0 ustar 00t0m staff 000000 000000 package Catalyst::ActionRole::NeedsLogin;
use Moose::Role;
use namespace::autoclean;
around execute => sub {
my $orig = shift;
my $self = shift;
my ($controller, $c, @args) = @_;
if (!$c->user) {
my $message = ($self->attributes->{LoginRedirectMessage}[0])
? $self->attributes->{LoginRedirectMessage}[0]
:'You need to login to view this page!';
$c->controller('Login')->login_redirect($c, $message, @args);
$c->detach;
}
else {
return $self->$orig(@_);
}
};
1;
__END__
=head1 NAME
Catalyst::ActionRole::NeedsLogin - checks if a user is logged in and if not redirects him to login page
=head1 SYNOPSIS
package MyApp::Controller::NeedsAuth;
use Moose;
use namespace::autoclean;
# One needs to inherit from Catalyst::Controller in order
# to get the Does('NeedsLogin') functionality.
BEGIN { extends 'Catalyst::Controller'; }
sub inbox : Path Does('NeedsLogin') {
# Redirects to /login if not logged in
my ($self, $c) = @_;
$c->stash->{template} = "inbox.tt2";
return;
}
sub inbox : Path Does('NeedsLogin') :LoginRedirectMessage('Your custom Message') {
# Redirects to /login if not logged in-
}
# Turn on in config
MyApp->config('Contoller::Login' => { traits => ['WithRedirect'] });
=head1 DESCRIPTION
Provides a ActionRole for forcing the user to login.
=head1 WRAPPED METHODS
=head2 execute
If there is no logged-in user, call the login_redirect() method in the
C<'Login'> controller with the Catalyst context object, $c, and the
message specified by the C<:LoginRedirectMessage('Message here')> method
attribute (see the synopsis).
If there is a user logged-in (i.e: C<< $c->user >> is true), execute the body
of the action as it is.
=head1 SEE ALSO
=over
=item L
=item L
=item L
=back
=head1 AUTHORS
See L for authors.
=head1 LICENSE
See L for license.
=cut
CatalystX-SimpleLogin-0.18/inc/Module/ 000755 000765 000024 00000000000 12002530505 017427 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/inc/Module/AutoInstall.pm 000644 000765 000024 00000062162 12002530434 022234 0 ustar 00t0m staff 000000 000000 #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
CatalystX-SimpleLogin-0.18/inc/Module/Install/ 000755 000765 000024 00000000000 12002530505 021035 5 ustar 00t0m staff 000000 000000 CatalystX-SimpleLogin-0.18/inc/Module/Install.pm 000644 000765 000024 00000030135 12002530431 021373 0 ustar 00t0m staff 000000 000000 #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.
CatalystX-SimpleLogin-0.18/inc/Module/Install/AuthorRequires.pm 000644 000765 000024 00000001131 12002530432 024350 0 ustar 00t0m staff 000000 000000 #line 1
use strict;
use warnings;
package Module::Install::AuthorRequires;
use base 'Module::Install::Base';
# cargo cult
BEGIN {
our $VERSION = '0.02';
our $ISCORE = 1;
}
sub author_requires {
my $self = shift;
return $self->{values}->{author_requires}
unless @_;
my @added;
while (@_) {
my $mod = shift or last;
my $version = shift || 0;
push @added, [$mod => $version];
}
push @{ $self->{values}->{author_requires} }, @added;
$self->admin->author_requires(@added);
return map { @$_ } @added;
}
1;
__END__
#line 92
CatalystX-SimpleLogin-0.18/inc/Module/Install/AuthorTests.pm 000644 000765 000024 00000002215 12002530434 023661 0 ustar 00t0m staff 000000 000000 #line 1
package Module::Install::AuthorTests;
use 5.005;
use strict;
use Module::Install::Base;
use Carp ();
#line 16
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.002';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
#line 42
sub author_tests {
my ($self, @dirs) = @_;
_add_author_tests($self, \@dirs, 0);
}
#line 56
sub recursive_author_tests {
my ($self, @dirs) = @_;
_add_author_tests($self, \@dirs, 1);
}
sub _wanted {
my $href = shift;
sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 }
}
sub _add_author_tests {
my ($self, $dirs, $recurse) = @_;
return unless $Module::Install::AUTHOR;
my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t';
# XXX: pick a default, later -- rjbs, 2008-02-24
my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests";
@dirs = grep { -d } @dirs;
if ($recurse) {
require File::Find;
my %test_dir;
File::Find::find(_wanted(\%test_dir), @dirs);
$self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir );
} else {
$self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs );
}
}
#line 107
1;
CatalystX-SimpleLogin-0.18/inc/Module/Install/AutoInstall.pm 000644 000765 000024 00000004162 12002530434 023636 0 ustar 00t0m staff 000000 000000 #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;
CatalystX-SimpleLogin-0.18/inc/Module/Install/Base.pm 000644 000765 000024 00000002147 12002530432 022250 0 ustar 00t0m staff 000000 000000 #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
CatalystX-SimpleLogin-0.18/inc/Module/Install/Can.pm 000644 000765 000024 00000006157 12002530432 022104 0 ustar 00t0m staff 000000 000000 #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
CatalystX-SimpleLogin-0.18/inc/Module/Install/Fetch.pm 000644 000765 000024 00000004627 12002530435 022437 0 ustar 00t0m staff 000000 000000 #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;
CatalystX-SimpleLogin-0.18/inc/Module/Install/Include.pm 000644 000765 000024 00000001015 12002530434 022754 0 ustar 00t0m staff 000000 000000 #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;
CatalystX-SimpleLogin-0.18/inc/Module/Install/Makefile.pm 000644 000765 000024 00000027437 12002530432 023124 0 ustar 00t0m staff 000000 000000 #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
CatalystX-SimpleLogin-0.18/inc/Module/Install/Metadata.pm 000644 000765 000024 00000043277 12002530432 023127 0 ustar 00t0m staff 000000 000000 #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;
CatalystX-SimpleLogin-0.18/inc/Module/Install/Win32.pm 000644 000765 000024 00000003403 12002530435 022277 0 ustar 00t0m staff 000000 000000 #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;
CatalystX-SimpleLogin-0.18/inc/Module/Install/WriteAll.pm 000644 000765 000024 00000002376 12002530435 023130 0 ustar 00t0m staff 000000 000000 #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;