[Jifty-commit] jifty-plugin-openid branch, plack, created. b49846be2868528b44285d3a5c8b9ff3b98cb791
Jifty commits
jifty-commit at lists.jifty.org
Mon Feb 8 07:04:35 EST 2010
The branch, plack has been created
at b49846be2868528b44285d3a5c8b9ff3b98cb791 (commit)
- Log -----------------------------------------------------------------
commit 7a429dfe08fb2fc82ae675aa4c830c34d74475ea
Author: Kang-min Liu <gugod at gugod.org>
Date: Fri May 18 18:33:19 2007 +0000
This is the OpenID plugin code.
Setting up your app to use OpenID isn't as easy as we thought
it to be. Will need a receipe to teach people how to cook it.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3248 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
new file mode 100644
index 0000000..8d6534f
--- /dev/null
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+
+package Jifty::Plugin::OpenID;
+use base qw/Jifty::Plugin/;
+
+1;
diff --git a/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm b/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
new file mode 100644
index 0000000..9dabea6
--- /dev/null
+++ b/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
@@ -0,0 +1,80 @@
+use warnings;
+use strict;
+
+=head1 NAME
+
+Jifty::Plugin::OpenID::Action::AuthenticateOpenID;
+
+=cut
+
+package Jifty::Plugin::OpenID::Action::AuthenticateOpenID;
+
+use base qw/Jifty::Action/;
+
+use LWPx::ParanoidAgent;
+use Net::OpenID::Consumer;
+use Cache::FileCache;
+
+=head2 arguments
+
+Return the OpenID URL field
+
+=cut
+
+use Jifty::Param::Schema;
+use Jifty::Action schema {
+ param 'openid' =>
+ label is _('OpenID URL'),
+ is mandatory,
+ hints is 'For example: you.livejournal.com';
+
+ param 'return_to' =>
+ default is '/openid/verify';
+};
+
+=head2 take_action
+
+Creates local user if non-existant and redirects to OpenID auth URL
+
+=cut
+
+sub take_action {
+ my $self = shift;
+ my $openid = $self->argument_value('openid');
+ my $path = $self->argument_value('return_to');
+
+ my $baseurl = Jifty->web->url;
+ my $csr = Net::OpenID::Consumer->new(
+ ua => LWPx::ParanoidAgent->new,
+ cache => Cache::FileCache->new,
+ args => scalar Jifty->handler->cgi->Vars,
+ consumer_secret => Jifty->config->app('OpenIDSecret'),
+ required_root => $baseurl
+ );
+
+ my $claimed_id = $csr->claimed_identity( $openid );
+
+ if ( not defined $claimed_id ) {
+ $self->result->error(_("Invalid OpenID URL. Please check to make sure it is correct. (@{[$csr->err]})"));
+ return;
+ }
+
+ $openid = $claimed_id->claimed_url;
+
+ my $return_to = Jifty->web->url( path => $path );
+ if(Jifty->web->request->continuation) {
+ $return_to .= ($return_to =~ /\?/) ? '&' : '?';
+ $return_to .= "J:C=" . Jifty->web->request->continuation->id;
+ }
+
+ my $check_url = $claimed_id->check_url(
+ return_to => $return_to,
+ trust_root => $baseurl,
+ delayed_return => 1
+ );
+
+ Jifty->web->_redirect( $check_url . '&openid.sreg.optional=nickname' );
+ return 1; # should never get here
+}
+
+1;
diff --git a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
new file mode 100644
index 0000000..b37e1ec
--- /dev/null
+++ b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
@@ -0,0 +1,102 @@
+use strict;
+use warnings;
+
+=head1 NAME
+
+Jifty::Plugin::OpenID::Action::CreateOpenIDUser
+
+=cut
+
+package Jifty::Plugin::OpenID::Action::CreateOpenIDUser;
+use base qw/Jifty::Action::Record/;
+
+sub record_class {
+ Jifty->app_class("Model", "User")
+}
+
+
+=head2 arguments
+
+The fields for C<CreateOpenIDUser> are:
+
+=over 4
+
+=item name: a nickname
+
+=back
+
+=cut
+
+sub arguments {
+ my $self = shift;
+ my $args = $self->SUPER::arguments;
+
+ my %fields = (
+ name => 1,
+ );
+
+ for ( keys %$args ){
+ delete $args->{$_} unless $fields{$_};
+ }
+
+ $args->{'name'}{'ajax_validates'} = 1;
+ return $args;
+}
+
+
+=head2 take_action
+
+=cut
+
+sub take_action {
+ my $self = shift;
+
+ my $openid = Jifty->web->session->get('openid');
+
+ if ( not $openid ) {
+ # Should never get here unless someone's trying weird things
+ $self->result->error("Invalid verification result: '$openid'");
+ return;
+ }
+
+ my $user = Jifty->app_class("Model", "User")->new(current_user => Jifty->app_class("CurrentUser")->superuser );
+
+ $user->load_by_cols( openid => $openid );
+
+ if ( $user->id ) {
+ $self->result->error( "That OpenID already has an account. Something's gone wrong." );
+ return;
+ }
+
+ $user->create( openid => $openid, name => $self->argument_value('name') );
+
+ if ( not $user->id ) {
+ $self->result->error( "Something bad happened and we couldn't log you in. Please try again later." );
+ return;
+ }
+
+ my $current_user = Jifty->app_class("CurrentUser")->new( openid => $openid );
+
+ # Actually do the signin thing.
+ Jifty->web->current_user($current_user);
+ Jifty->web->session->expires( undef );
+ Jifty->web->session->set_cookie;
+
+ $self->report_success if not $self->result->failure;
+ Jifty->web->session->remove('openid');
+
+ return 1;
+}
+
+=head2 report_success
+
+=cut
+
+sub report_success {
+ my $self = shift;
+ # Your success message here
+ $self->result->message( _("Welcome, ") . Jifty->web->current_user->user_object->name . "." );
+}
+
+1;
+
diff --git a/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm b/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
new file mode 100644
index 0000000..51f375a
--- /dev/null
+++ b/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
@@ -0,0 +1,73 @@
+use warnings;
+use strict;
+
+=head1 NAME
+
+Jifty::Plugin::OpenID::Action::VerifyOpenID;
+
+=cut
+
+package Jifty::Plugin::OpenID::Action::VerifyOpenID;
+use base qw/Jifty::Action/;
+
+use Net::OpenID::Consumer;
+use Cache::FileCache;
+use LWPx::ParanoidAgent;
+
+=head2 arguments
+
+No args
+
+=cut
+
+sub arguments { return ( {} ) }
+
+=head2 take_action
+
+Check the result of the login. If it's good, load the user
+and log them in. Otherwise, throw an error.
+
+=cut
+
+sub take_action {
+ my $self = shift;
+
+# XXX HACK: some OpenID servers (LJ and myopenid.com included) don't seem
+# to properly escape plus signs (+) in openid.sig when returning the user
+# back to us. We need to convert the pluses back from spaces to pluses again.
+ my $sig = Jifty->handler->cgi->param('openid.sig');
+ $sig =~ s/ /+/g;
+ Jifty->handler->cgi->param( 'openid.sig' => $sig );
+
+ my $csr = Net::OpenID::Consumer->new(
+ ua => LWPx::ParanoidAgent->new,
+ cache => Cache::FileCache->new,
+ args => scalar Jifty->handler->cgi->Vars,
+ consumer_secret => Jifty->config->app('OpenIDSecret')
+ );
+
+ if ( my $setup = $csr->user_setup_url ) {
+ Jifty->web->_redirect($setup);
+ }
+ elsif ( $csr->user_cancel ) {
+ $self->result->error(
+ _( 'OpenID verification failed. It looks like you cancelled the OpenID verification request.'
+ )
+ );
+ return;
+ }
+
+ my $ident = $csr->verified_identity;
+
+ if ( not defined $ident ) {
+ $self->result->error( _('OpenID verification failed: ') . $csr->err );
+ return;
+ }
+
+ Jifty->log( "identified as: " . $ident->url );
+ $self->result->content( openid => $ident->url );
+
+ return 1;
+}
+
+1;
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
new file mode 100644
index 0000000..b448979
--- /dev/null
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -0,0 +1,88 @@
+use strict;
+use warnings;
+
+package Jifty::Plugin::OpenID::Dispatcher;
+use Jifty::Dispatcher -base;
+
+before qr'^/(?:openid/link)' => run {
+ tangent('/openid/login') unless (Jifty->web->current_user->id)
+};
+
+before qr'^/openid/verify' => run {
+ Jifty->web->request->add_action(
+ class => 'VerifyOpenID',
+ moniker => 'verifyopenid'
+ );
+};
+
+on 'openid/verify_and_link' => run {
+ my $result = Jifty->web->response->result('verifyopenid');
+ my $user = Jifty->web->current_user;
+ if ( defined $result and $result->success and $user->id ) {
+ my $openid = $result->content('openid');
+ my ( $ret, $msg ) = $user->user_object->validate_openid( $openid );
+
+ if ( not $ret ) {
+ $result->error(_("It looks like someone is already using that OpenID."));
+ redirect '/openid/link';
+ }
+ else {
+ $user->user_object->link_to_openid( $openid );
+ $result->message(_("The OpenID '$openid' has been linked to your account."));
+ }
+ }
+ redirect '/';
+};
+
+on 'openid/verify_and_login' => run {
+ my $result = Jifty->web->response->result('verifyopenid');
+
+ if ( defined $result and $result->success ) {
+ my $openid = $result->content('openid');
+ my $user = Jifty->app_class('CurrentUser')->new( openid => $openid );
+ Jifty->log->info("User Class: $user. OpenID: $openid");
+
+ if ( $user->id ) {
+ # Set up our login message
+ $result->message( _("Welcome back, ") . $user->user_object->name . "." );
+
+ # Actually do the signin thing.
+ Jifty->web->current_user($user);
+ Jifty->web->session->expires( undef );
+ Jifty->web->session->set_cookie;
+
+ if(Jifty->web->request->continuation) {
+ Jifty->web->request->continuation->call;
+ } else {
+ redirect '/';
+ }
+ }
+ else {
+ # User needs to create account still
+ Jifty->web->session->set( openid => $openid );
+ Jifty->log->info("got openid: $openid");
+ my $nick = get('openid.sreg.nickname');
+ if ( $nick ) {
+ redirect( Jifty::Web::Form::Clickable->new( url => '/openid/create', parameters => { nickname => $nick, openid => $openid } ));
+ }
+ else {
+ redirect( Jifty::Web::Form::Clickable->new( url => '/openid/create' ) );
+ }
+ }
+ }
+ else {
+ redirect '/openid/login';
+ }
+};
+
+on 'openid/create' => run {
+ if ( not Jifty->web->session->get('openid') ) {
+ redirect '/';
+ }
+
+ set action => Jifty->web->new_action( class => 'CreateOpenIDUser', parameters => { openid => Jifty->web->session->get("openid") } );
+ set 'next' => Jifty->web->request->continuation ||
+ Jifty::Continuation->new( request => Jifty::Request->new( path => "/" ) );
+};
+
+1;
commit e4decdb2f731287363a669c4aec4349a997fdb30
Author: Kang-min Liu <gugod at gugod.org>
Date: Fri May 18 20:26:07 2007 +0000
Make render_action() simply render the form fields of AuthenticateOpenID
action properly.
Also, set action to AuthenticateOpenID in the dispatcher. This
should make it easier for people to use openid plugin since they
can write less code in their /openid/login view.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3250 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm b/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
index 9dabea6..798d09b 100644
--- a/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
@@ -29,7 +29,8 @@ use Jifty::Action schema {
hints is 'For example: you.livejournal.com';
param 'return_to' =>
- default is '/openid/verify';
+ render as 'Hidden',
+ default is '/openid/verify_and_login';
};
=head2 take_action
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index b448979..bd251cb 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -8,6 +8,13 @@ before qr'^/(?:openid/link)' => run {
tangent('/openid/login') unless (Jifty->web->current_user->id)
};
+before qr'^/openid/login' => run {
+ set action => Jifty->web->new_action(
+ class => 'AuthenticateOpenID',
+ moniker => 'authenticateopenid'
+ );
+};
+
before qr'^/openid/verify' => run {
Jifty->web->request->add_action(
class => 'VerifyOpenID',
commit f6635fb722425177e480825efa146158ccc8994a
Author: Kang-min Liu <gugod at gugod.org>
Date: Sat May 19 14:34:53 2007 +0000
Should directly call current_user->username() as in CurrentUser.pm's
POD.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3258 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index bd251cb..75c8550 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -51,7 +51,7 @@ on 'openid/verify_and_login' => run {
if ( $user->id ) {
# Set up our login message
- $result->message( _("Welcome back, ") . $user->user_object->name . "." );
+ $result->message( _("Welcome back, ") . $user->username . "." );
# Actually do the signin thing.
Jifty->web->current_user($user);
commit 023ba20fb14c1f3dbabd743952deb2bbbf83ff86
Author: Kang-min Liu <gugod at gugod.org>
Date: Sun May 27 11:17:13 2007 +0000
Should just call username there. instead of user_object->name. As
described in the CurrentUser POD.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3304 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
index b37e1ec..9b91217 100644
--- a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
@@ -95,7 +95,7 @@ sub take_action {
sub report_success {
my $self = shift;
# Your success message here
- $self->result->message( _("Welcome, ") . Jifty->web->current_user->user_object->name . "." );
+ $self->result->message( _("Welcome, ") . Jifty->web->current_user->username . "." );
}
1;
commit 7a6e85d2158659871d20866fbcc8d14284f93c79
Author: Kang-min Liu <gugod at gugod.org>
Date: Fri Jun 1 13:29:03 2007 +0000
The minimum required OpenID View for your app to mixin.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3311 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/View.pm b/lib/Jifty/Plugin/OpenID/View.pm
new file mode 100644
index 0000000..1033f6f
--- /dev/null
+++ b/lib/Jifty/Plugin/OpenID/View.pm
@@ -0,0 +1,60 @@
+package Jifty::Plugin::OpenID::View;
+use strict;
+use warnings;
+use Jifty::View::Declare -base;
+
+template 'login' => page {
+ { title is _ "Login with your OpenID" }
+ my $action = get('action');
+
+ div {
+ unless ( Jifty->web->current_user->id ) {
+ div {
+ attr { id => 'openid-login' };
+ outs(
+ p {
+ em {
+ _( qq{If you have a Livejournal or other OpenID account, you don\'t even need to sign up. Just log in.}
+ );
+ }
+ }
+ );
+ form {
+ render_action($action);
+ form_submit(
+ label => _("Go for it!"),
+ submit => $action
+ );
+ }
+ };
+ }
+ else {
+ outs( _("You already logged in.") );
+ }
+ }
+};
+
+template 'create' => page {
+ title is 'Set your username';
+ my ( $action, $next ) = get( 'action', 'next' );
+
+ p {
+ outs(
+ _( 'We need you to set a username or quickly check the one associated with your OpenID. Your username is what other people will see when you ask questions or make suggestions'
+ )
+ );
+ };
+ p {
+ outs(
+ _( 'If the username provided conflicts with an existing username or contains invalid characters, you will have to give us a new one.'
+ )
+ );
+ };
+ Jifty->web->form->start( call => $next );
+ render_param( $action, 'name', default_value => get('nickname') );
+ form_submit( label => _('Continue'), submit => $action );
+ Jifty->web->form->end;
+};
+
+
+1;
commit d9d010bc9810656f6e13af1b4639f2b03748ff8f
Author: Chia-liang Kao <clkao at bestpractical.com>
Date: Fri Jun 1 18:31:58 2007 +0000
* User model mixin for OpenID plugin.
* Make Authenticate::Password aware that there can be alternative
authentication systems.
* Make OpenID plugin work even when Authenticate::Password is
enabled.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3314 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
new file mode 100644
index 0000000..8f72528
--- /dev/null
+++ b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
@@ -0,0 +1,21 @@
+package Jifty::Plugin::OpenID::Mixin::Model::User;
+use strict;
+use warnings;
+use Jifty::DBI::Schema;
+use base 'Jifty::DBI::Record::Plugin';
+
+
+use Jifty::Plugin::OpenID::Record schema {
+
+column openid =>
+ type is 'text',
+ label is 'OpenID',
+ hints is q{You can use your OpenID to log in quickly and easily.},
+ is distinct,
+ is immutable;
+
+};
+
+sub has_alternative_auth { 1 }
+
+1;
diff --git a/lib/Jifty/Plugin/OpenID/View.pm b/lib/Jifty/Plugin/OpenID/View.pm
index 1033f6f..a2968ff 100644
--- a/lib/Jifty/Plugin/OpenID/View.pm
+++ b/lib/Jifty/Plugin/OpenID/View.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
use Jifty::View::Declare -base;
-template 'login' => page {
+template 'openid/login' => page {
{ title is _ "Login with your OpenID" }
my $action = get('action');
@@ -34,7 +34,7 @@ template 'login' => page {
}
};
-template 'create' => page {
+template 'openid/create' => page {
title is 'Set your username';
my ( $action, $next ) = get( 'action', 'next' );
commit 933cf6fa85b4d679d40f84154259926043977f2e
Author: Chia-liang Kao <clkao at bestpractical.com>
Date: Fri Jun 1 19:58:34 2007 +0000
openid related methods.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3315 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
index 8f72528..d2ab901 100644
--- a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
+++ b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
@@ -18,4 +18,47 @@ column openid =>
sub has_alternative_auth { 1 }
+
+use URI;
+
+sub validate_openid {
+ my $self = shift;
+ my $openid = shift;
+
+ my $uri = URI->new( $openid );
+
+ return ( 0, q{That doesn't look like an OpenID URL.} )
+ if not defined $uri;
+
+ my $temp_user = Doxory::Model::User->new;
+ $temp_user->load_by_cols( openid => $uri->canonical );
+
+ # It's ok if *we* have the openid we're looking for
+ return ( 0, q{It looks like somebody else has claimed that OpenID.} )
+ if $temp_user->id and ( not $self->id or $temp_user->id != $self->id );
+
+ return 1;
+}
+
+sub canonicalize_openid {
+ my $self = shift;
+ my $openid = shift;
+
+ return ''
+ if not defined $openid or not length $openid;
+
+ $openid = 'http://' . $openid
+ if $openid !~ m{^http://};
+
+ my $uri = URI->new( $openid );
+
+ return $uri->canonical;
+}
+
+sub link_to_openid {
+ my $self = shift;
+ my $openid = shift;
+ $self->__set( column => 'openid', value => $openid );
+}
+
1;
commit b0313fc48e5a228dd8f23a2f89eb639f040aa3d8
Author: Chia-liang Kao <clkao at bestpractical.com>
Date: Sat Jun 2 03:06:41 2007 +0000
Fix has_alternative_auth.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3319 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
index d2ab901..7e5781c 100644
--- a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
+++ b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
@@ -3,10 +3,12 @@ use strict;
use warnings;
use Jifty::DBI::Schema;
use base 'Jifty::DBI::Record::Plugin';
-
+use URI;
use Jifty::Plugin::OpenID::Record schema {
+our @EXPORT = qw(has_alternative_auth link_to_openid);
+
column openid =>
type is 'text',
label is 'OpenID',
@@ -18,8 +20,11 @@ column openid =>
sub has_alternative_auth { 1 }
-
-use URI;
+sub register_triggers {
+ my $self = shift;
+ $self->add_trigger(name => 'validate_openid', callback => \&validate_openid, abortable => 1);
+ $self->add_trigger(name => 'canonicalize_openid', callback => \&canonicalize_openid);
+}
sub validate_openid {
my $self = shift;
commit 581b860d9ca289375f14e41b88dd8359a61cc7c6
Author: Kang-min Liu <gugod at gugod.org>
Date: Tue Jun 5 06:13:01 2007 +0000
Not possible to be intended to put "Doxory::Model::User" there.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3358 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
index 7e5781c..ce746a3 100644
--- a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
+++ b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
@@ -35,7 +35,7 @@ sub validate_openid {
return ( 0, q{That doesn't look like an OpenID URL.} )
if not defined $uri;
- my $temp_user = Doxory::Model::User->new;
+ my $temp_user = Jifty->app_class("Model", "User")->new;
$temp_user->load_by_cols( openid => $uri->canonical );
# It's ok if *we* have the openid we're looking for
commit 20185edabf6a78312ff7ab603e80cfd1df79ca20
Author: Thomas Sibley <trs at bestpractical.com>
Date: Sun Jun 17 20:54:01 2007 +0000
Now with more POD! (and passing POD tests)
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3516 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 8d6534f..378045f 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -4,4 +4,14 @@ use warnings;
package Jifty::Plugin::OpenID;
use base qw/Jifty::Plugin/;
+=head1 NAME
+
+Jifty::Plugin::OpenID
+
+=head1 DESCRIPTION
+
+Provides OpenID authentication for your app
+
+=cut
+
1;
diff --git a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
index 9b91217..814f3a8 100644
--- a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
@@ -10,6 +10,12 @@ Jifty::Plugin::OpenID::Action::CreateOpenIDUser
package Jifty::Plugin::OpenID::Action::CreateOpenIDUser;
use base qw/Jifty::Action::Record/;
+=head2 record_class
+
+Returns the record class for this action
+
+=cut
+
sub record_class {
Jifty->app_class("Model", "User")
}
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index 75c8550..d00126b 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -4,6 +4,16 @@ use warnings;
package Jifty::Plugin::OpenID::Dispatcher;
use Jifty::Dispatcher -base;
+=head1 NAME
+
+Jifty::Plugin::OpenID::Dispatcher
+
+=head1 DESCRIPTION
+
+Dispatcher for L<Jifty::Plugin::OpenID>. Handles a lot of the work.
+
+=cut
+
before qr'^/(?:openid/link)' => run {
tangent('/openid/login') unless (Jifty->web->current_user->id)
};
diff --git a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
index ce746a3..898dae9 100644
--- a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
+++ b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
@@ -5,6 +5,16 @@ use Jifty::DBI::Schema;
use base 'Jifty::DBI::Record::Plugin';
use URI;
+=head1 NAME
+
+Jifty::Plugin::OpenID::Mixin::Model::User
+
+=head1 DESCRIPTION
+
+L<Jifty::Plugin::OpenID> mixin for the User model. Provides an 'openid' column.
+
+=cut
+
use Jifty::Plugin::OpenID::Record schema {
our @EXPORT = qw(has_alternative_auth link_to_openid);
@@ -18,14 +28,26 @@ column openid =>
};
+=head2 has_alternative_auth
+
+=cut
+
sub has_alternative_auth { 1 }
+=head2 register_triggers
+
+=cut
+
sub register_triggers {
my $self = shift;
$self->add_trigger(name => 'validate_openid', callback => \&validate_openid, abortable => 1);
$self->add_trigger(name => 'canonicalize_openid', callback => \&canonicalize_openid);
}
+=head2 validate_openid
+
+=cut
+
sub validate_openid {
my $self = shift;
my $openid = shift;
@@ -45,6 +67,10 @@ sub validate_openid {
return 1;
}
+=head2 canonicalize_openid
+
+=cut
+
sub canonicalize_openid {
my $self = shift;
my $openid = shift;
@@ -60,6 +86,12 @@ sub canonicalize_openid {
return $uri->canonical;
}
+=head2 link_to_openid
+
+Links User's account to the specified OpenID (bypassing ACLs)
+
+=cut
+
sub link_to_openid {
my $self = shift;
my $openid = shift;
diff --git a/lib/Jifty/Plugin/OpenID/View.pm b/lib/Jifty/Plugin/OpenID/View.pm
index a2968ff..e832326 100644
--- a/lib/Jifty/Plugin/OpenID/View.pm
+++ b/lib/Jifty/Plugin/OpenID/View.pm
@@ -3,6 +3,16 @@ use strict;
use warnings;
use Jifty::View::Declare -base;
+=head1 NAME
+
+Jifty::Plugin::OpenID::View
+
+=head1 DESCRIPTION
+
+The view class for L<Jifty::Plugin::OpenID>. Provides login and create pages.
+
+=cut
+
template 'openid/login' => page {
{ title is _ "Login with your OpenID" }
my $action = get('action');
commit 252e3627b9547654db67ade72ffc58ca377f78ae
Author: Thomas Sibley <trs at bestpractical.com>
Date: Sun Jun 17 20:54:09 2007 +0000
Fix typos
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3517 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/View.pm b/lib/Jifty/Plugin/OpenID/View.pm
index e832326..f67a65b 100644
--- a/lib/Jifty/Plugin/OpenID/View.pm
+++ b/lib/Jifty/Plugin/OpenID/View.pm
@@ -14,7 +14,7 @@ The view class for L<Jifty::Plugin::OpenID>. Provides login and create pages.
=cut
template 'openid/login' => page {
- { title is _ "Login with your OpenID" }
+ { title is _("Login with your OpenID") }
my $action = get('action');
div {
commit 98eb2e09568d192df148e488412a6de163fdeb9c
Author: Kang-min Liu <gugod at gugod.org>
Date: Fri Jun 22 05:23:43 2007 +0000
Add a "next" parameter so one can specify the next page to go after
openid login.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@3545 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/View.pm b/lib/Jifty/Plugin/OpenID/View.pm
index f67a65b..d0c3af7 100644
--- a/lib/Jifty/Plugin/OpenID/View.pm
+++ b/lib/Jifty/Plugin/OpenID/View.pm
@@ -15,7 +15,7 @@ The view class for L<Jifty::Plugin::OpenID>. Provides login and create pages.
template 'openid/login' => page {
{ title is _("Login with your OpenID") }
- my $action = get('action');
+ my ($action, $next) = get('action', 'next');
div {
unless ( Jifty->web->current_user->id ) {
@@ -29,13 +29,13 @@ template 'openid/login' => page {
}
}
);
- form {
- render_action($action);
- form_submit(
- label => _("Go for it!"),
- submit => $action
- );
- }
+ Jifty->web->form->start( call => $next );
+ render_action($action);
+ form_submit(
+ label => _("Go for it!"),
+ submit => $action
+ );
+ Jifty->web->form->end;
};
}
else {
commit 508a49824f3cea1fcb7d08a31f5f322978f9d722
Author: Kang-min Liu <gugod at gugod.org>
Date: Tue Nov 27 06:33:54 2007 +0000
Unbreak OpenID plugin with new Jifty::API implementation.
Give fully-qualified action class name here because Jifty::API does
not resolve action class names to those ones provided by plugins
(those under Jifty::Plugin::*::Action namespace) This is maybe a
bug, but need further discussion.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@4545 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index d00126b..eae4330 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -20,7 +20,7 @@ before qr'^/(?:openid/link)' => run {
before qr'^/openid/login' => run {
set action => Jifty->web->new_action(
- class => 'AuthenticateOpenID',
+ class => 'Jifty::Plugin::OpenID::Action::AuthenticateOpenID',
moniker => 'authenticateopenid'
);
};
@@ -97,7 +97,7 @@ on 'openid/create' => run {
redirect '/';
}
- set action => Jifty->web->new_action( class => 'CreateOpenIDUser', parameters => { openid => Jifty->web->session->get("openid") } );
+ set action => Jifty->web->new_action( class => 'Jifty::Plugin::OpenID::Action::CreateOpenIDUser', parameters => { openid => Jifty->web->session->get("openid") } );
set 'next' => Jifty->web->request->continuation ||
Jifty::Continuation->new( request => Jifty::Request->new( path => "/" ) );
};
commit 51310f817e430a331fe8def697aea3054f226a8a
Author: Kang-min Liu <gugod at gugod.org>
Date: Wed Nov 28 10:45:03 2007 +0000
revert its previous revision for it's fixed earler in classloader.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@4551 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index eae4330..d00126b 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -20,7 +20,7 @@ before qr'^/(?:openid/link)' => run {
before qr'^/openid/login' => run {
set action => Jifty->web->new_action(
- class => 'Jifty::Plugin::OpenID::Action::AuthenticateOpenID',
+ class => 'AuthenticateOpenID',
moniker => 'authenticateopenid'
);
};
@@ -97,7 +97,7 @@ on 'openid/create' => run {
redirect '/';
}
- set action => Jifty->web->new_action( class => 'Jifty::Plugin::OpenID::Action::CreateOpenIDUser', parameters => { openid => Jifty->web->session->get("openid") } );
+ set action => Jifty->web->new_action( class => 'CreateOpenIDUser', parameters => { openid => Jifty->web->session->get("openid") } );
set 'next' => Jifty->web->request->continuation ||
Jifty::Continuation->new( request => Jifty::Request->new( path => "/" ) );
};
commit 9eae33f39533dbcb069d1580765383190cd25d6d
Author: Shawn Moore <sartak at bestpractical.com>
Date: Mon Jan 28 15:51:44 2008 +0000
Allow AuthenticateOpenID and VerifyOpenID for some pages
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@4955 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index d00126b..fa8ffe0 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -19,6 +19,7 @@ before qr'^/(?:openid/link)' => run {
};
before qr'^/openid/login' => run {
+ Jifty->api->allow('AuthenticateOpenID');
set action => Jifty->web->new_action(
class => 'AuthenticateOpenID',
moniker => 'authenticateopenid'
@@ -26,6 +27,7 @@ before qr'^/openid/login' => run {
};
before qr'^/openid/verify' => run {
+ Jifty->api->allow('VerifyOpenID');
Jifty->web->request->add_action(
class => 'VerifyOpenID',
moniker => 'verifyopenid'
commit 365629d9a48b2bad18629836ddb2851888d2f262
Author: Chia-liang Kao <clkao at bestpractical.com>
Date: Tue Feb 5 14:46:15 2008 +0000
* don't prepend http:// on https:// openid urls.
* on verification failure, call continuation if there's one,
rather than always redirect to /openid/login.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@4994 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index fa8ffe0..1338a51 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -90,7 +90,11 @@ on 'openid/verify_and_login' => run {
}
}
else {
- redirect '/openid/login';
+ if(Jifty->web->request->continuation) {
+ Jifty->web->request->continuation->call;
+ } else {
+ redirect '/openid/login';
+ }
}
};
diff --git a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
index 898dae9..e617489 100644
--- a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
+++ b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
@@ -79,7 +79,7 @@ sub canonicalize_openid {
if not defined $openid or not length $openid;
$openid = 'http://' . $openid
- if $openid !~ m{^http://};
+ if $openid !~ m{^https?://};
my $uri = URI->new( $openid );
commit 0441408ce3f25567259419cad8e1fed36ffa6eec
Author: Chia-liang Kao <clkao at bestpractical.com>
Date: Tue Apr 22 09:23:53 2008 +0000
Refactor get_csr.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@5332 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 378045f..1fcf574 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -3,6 +3,7 @@ use warnings;
package Jifty::Plugin::OpenID;
use base qw/Jifty::Plugin/;
+use LWPx::ParanoidAgent;
=head1 NAME
@@ -14,4 +15,16 @@ Provides OpenID authentication for your app
=cut
+sub get_csr {
+ my $class = shift;
+
+ return Net::OpenID::Consumer->new(
+ ua => LWPx::ParanoidAgent->new,
+ cache => Cache::FileCache->new,
+ args => scalar Jifty->handler->cgi->Vars,
+ consumer_secret => Jifty->config->app('OpenIDSecret'),
+ @_,
+ );
+}
+
1;
diff --git a/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm b/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
index 798d09b..81da781 100644
--- a/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
@@ -45,13 +45,7 @@ sub take_action {
my $path = $self->argument_value('return_to');
my $baseurl = Jifty->web->url;
- my $csr = Net::OpenID::Consumer->new(
- ua => LWPx::ParanoidAgent->new,
- cache => Cache::FileCache->new,
- args => scalar Jifty->handler->cgi->Vars,
- consumer_secret => Jifty->config->app('OpenIDSecret'),
- required_root => $baseurl
- );
+ my $csr = Jifty::Plugin::OpenID->get_csr( required_root => $baseurl );
my $claimed_id = $csr->claimed_identity( $openid );
diff --git a/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm b/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
index 51f375a..60ad352 100644
--- a/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
@@ -12,7 +12,6 @@ use base qw/Jifty::Action/;
use Net::OpenID::Consumer;
use Cache::FileCache;
-use LWPx::ParanoidAgent;
=head2 arguments
@@ -39,12 +38,7 @@ sub take_action {
$sig =~ s/ /+/g;
Jifty->handler->cgi->param( 'openid.sig' => $sig );
- my $csr = Net::OpenID::Consumer->new(
- ua => LWPx::ParanoidAgent->new,
- cache => Cache::FileCache->new,
- args => scalar Jifty->handler->cgi->Vars,
- consumer_secret => Jifty->config->app('OpenIDSecret')
- );
+ my $csr = Jifty::Plugin::OpenID->get_csr;
if ( my $setup = $csr->user_setup_url ) {
Jifty->web->_redirect($setup);
commit 4b9330206b983486ee68ceed97fa027131336b37
Author: Chia-liang Kao <clkao at bestpractical.com>
Date: Tue Apr 22 15:37:54 2008 +0000
Make the openid plugin accept our local openid server (as whitelist)
in selenium tests.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@5333 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 1fcf574..3bc00b2 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -19,7 +19,7 @@ sub get_csr {
my $class = shift;
return Net::OpenID::Consumer->new(
- ua => LWPx::ParanoidAgent->new,
+ ua => LWPx::ParanoidAgent->new( whitelisted_hosts => [ $ENV{JIFTY_OPENID_WHITELIST_HOST} ] ),
cache => Cache::FileCache->new,
args => scalar Jifty->handler->cgi->Vars,
consumer_secret => Jifty->config->app('OpenIDSecret'),
commit 7ac44f4cd9afeefadaab4346608482a8d19f552f
Author: Yves Agostini <agostini at univ-metz.fr>
Date: Mon Jun 16 14:14:18 2008 +0000
one more patch from debian packaging about lintian complains on pods
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@5514 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 3bc00b2..b4bcffd 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -7,7 +7,7 @@ use LWPx::ParanoidAgent;
=head1 NAME
-Jifty::Plugin::OpenID
+Jifty::Plugin::OpenID - Provides OpenID authentication for your jifty app
=head1 DESCRIPTION
diff --git a/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm b/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
index 81da781..10d1991 100644
--- a/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/AuthenticateOpenID.pm
@@ -3,7 +3,7 @@ use strict;
=head1 NAME
-Jifty::Plugin::OpenID::Action::AuthenticateOpenID;
+Jifty::Plugin::OpenID::Action::AuthenticateOpenID - make OpenId authentication
=cut
diff --git a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
index 814f3a8..c2fcd1e 100644
--- a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
@@ -3,7 +3,7 @@ use warnings;
=head1 NAME
-Jifty::Plugin::OpenID::Action::CreateOpenIDUser
+Jifty::Plugin::OpenID::Action::CreateOpenIDUser - create 0penId user
=cut
diff --git a/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm b/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
index 60ad352..ec00ca6 100644
--- a/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
@@ -3,7 +3,7 @@ use strict;
=head1 NAME
-Jifty::Plugin::OpenID::Action::VerifyOpenID;
+Jifty::Plugin::OpenID::Action::VerifyOpenID - verify OpenID
=cut
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index 1338a51..24b6da7 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -6,7 +6,7 @@ use Jifty::Dispatcher -base;
=head1 NAME
-Jifty::Plugin::OpenID::Dispatcher
+Jifty::Plugin::OpenID::Dispatcher - Dispatcher for OpenID plugin
=head1 DESCRIPTION
diff --git a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
index e617489..9ea7495 100644
--- a/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
+++ b/lib/Jifty/Plugin/OpenID/Mixin/Model/User.pm
@@ -7,7 +7,7 @@ use URI;
=head1 NAME
-Jifty::Plugin::OpenID::Mixin::Model::User
+Jifty::Plugin::OpenID::Mixin::Model::User - Mixin model user
=head1 DESCRIPTION
diff --git a/lib/Jifty/Plugin/OpenID/View.pm b/lib/Jifty/Plugin/OpenID/View.pm
index d0c3af7..2877461 100644
--- a/lib/Jifty/Plugin/OpenID/View.pm
+++ b/lib/Jifty/Plugin/OpenID/View.pm
@@ -5,7 +5,7 @@ use Jifty::View::Declare -base;
=head1 NAME
-Jifty::Plugin::OpenID::View
+Jifty::Plugin::OpenID::View - Login and create pages for OpenID plugin
=head1 DESCRIPTION
commit 384c9ef08832c65d037b728cd3e87dfa8ff3c0d4
Author: Kang-min Liu <gugod at gugod.org>
Date: Fri Jun 27 17:59:04 2008 +0000
When OpenID plugin needs to create a new user, instead of assuming
there's a "name" column in "User" model, it is better just reading all
the arguments from CreateUser action.
The only column that is assumed have in user model is "openid", which
is defined in the model mixin.
Now the CreateOpenIDUser action is basically doing a CreateUser
action, but with some extra conditions. For example, the value of
openid must not be read from user input, but needs to be retrieved
from the session.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@5536 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
index c2fcd1e..01b96e9 100644
--- a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
@@ -35,21 +35,11 @@ The fields for C<CreateOpenIDUser> are:
sub arguments {
my $self = shift;
- my $args = $self->SUPER::arguments;
-
- my %fields = (
- name => 1,
- );
-
- for ( keys %$args ){
- delete $args->{$_} unless $fields{$_};
- }
-
- $args->{'name'}{'ajax_validates'} = 1;
+ my $args = $self->record_class->new->as_create_action->arguments;
+ delete $args->{openid};
return $args;
}
-
=head2 take_action
=cut
@@ -65,7 +55,7 @@ sub take_action {
return;
}
- my $user = Jifty->app_class("Model", "User")->new(current_user => Jifty->app_class("CurrentUser")->superuser );
+ my $user = $self->record_class->new(current_user => Jifty->app_class("CurrentUser")->superuser );
$user->load_by_cols( openid => $openid );
@@ -74,7 +64,7 @@ sub take_action {
return;
}
- $user->create( openid => $openid, name => $self->argument_value('name') );
+ $user->create( openid => $openid, %{$self->argument_values} );
if ( not $user->id ) {
$self->result->error( "Something bad happened and we couldn't log you in. Please try again later." );
diff --git a/lib/Jifty/Plugin/OpenID/View.pm b/lib/Jifty/Plugin/OpenID/View.pm
index 2877461..9b6db2a 100644
--- a/lib/Jifty/Plugin/OpenID/View.pm
+++ b/lib/Jifty/Plugin/OpenID/View.pm
@@ -61,7 +61,7 @@ template 'openid/create' => page {
);
};
Jifty->web->form->start( call => $next );
- render_param( $action, 'name', default_value => get('nickname') );
+ render_action($action);
form_submit( label => _('Continue'), submit => $action );
Jifty->web->form->end;
};
commit 387c0d9b3c7db5429cb3eb566aced99bc6c8dee9
Author: Chia-liang Kao <clkao at bestpractical.com>
Date: Tue Sep 9 15:01:35 2008 +0000
Fix Jifty::Script::Help.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@5817 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index 24b6da7..37dc3ad 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -14,6 +14,14 @@ Dispatcher for L<Jifty::Plugin::OpenID>. Handles a lot of the work.
=cut
+sub _continuation_or_redirect {
+ if(Jifty->web->request->continuation) {
+ Jifty->web->request->continuation->call;
+ } else {
+ redirect @_;
+ }
+}
+
before qr'^/(?:openid/link)' => run {
tangent('/openid/login') unless (Jifty->web->current_user->id)
};
@@ -43,14 +51,13 @@ on 'openid/verify_and_link' => run {
if ( not $ret ) {
$result->error(_("It looks like someone is already using that OpenID."));
- redirect '/openid/link';
}
else {
$user->user_object->link_to_openid( $openid );
$result->message(_("The OpenID '$openid' has been linked to your account."));
}
}
- redirect '/';
+ _continuation_or_redirect('/openid/link');
};
on 'openid/verify_and_login' => run {
@@ -70,11 +77,7 @@ on 'openid/verify_and_login' => run {
Jifty->web->session->expires( undef );
Jifty->web->session->set_cookie;
- if(Jifty->web->request->continuation) {
- Jifty->web->request->continuation->call;
- } else {
- redirect '/';
- }
+ _continuation_or_redirect('/');
}
else {
# User needs to create account still
@@ -90,11 +93,7 @@ on 'openid/verify_and_login' => run {
}
}
else {
- if(Jifty->web->request->continuation) {
- Jifty->web->request->continuation->call;
- } else {
- redirect '/openid/login';
- }
+ _continuation_or_redirect('/openid/login');
}
};
commit 0b9c0e68677fa358651ddef48433c53455171a4f
Author: Chia-liang Kao <clkao at bestpractical.com>
Date: Tue Sep 9 15:21:46 2008 +0000
revert r5817
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@5818 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index 37dc3ad..24b6da7 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -14,14 +14,6 @@ Dispatcher for L<Jifty::Plugin::OpenID>. Handles a lot of the work.
=cut
-sub _continuation_or_redirect {
- if(Jifty->web->request->continuation) {
- Jifty->web->request->continuation->call;
- } else {
- redirect @_;
- }
-}
-
before qr'^/(?:openid/link)' => run {
tangent('/openid/login') unless (Jifty->web->current_user->id)
};
@@ -51,13 +43,14 @@ on 'openid/verify_and_link' => run {
if ( not $ret ) {
$result->error(_("It looks like someone is already using that OpenID."));
+ redirect '/openid/link';
}
else {
$user->user_object->link_to_openid( $openid );
$result->message(_("The OpenID '$openid' has been linked to your account."));
}
}
- _continuation_or_redirect('/openid/link');
+ redirect '/';
};
on 'openid/verify_and_login' => run {
@@ -77,7 +70,11 @@ on 'openid/verify_and_login' => run {
Jifty->web->session->expires( undef );
Jifty->web->session->set_cookie;
- _continuation_or_redirect('/');
+ if(Jifty->web->request->continuation) {
+ Jifty->web->request->continuation->call;
+ } else {
+ redirect '/';
+ }
}
else {
# User needs to create account still
@@ -93,7 +90,11 @@ on 'openid/verify_and_login' => run {
}
}
else {
- _continuation_or_redirect('/openid/login');
+ if(Jifty->web->request->continuation) {
+ Jifty->web->request->continuation->call;
+ } else {
+ redirect '/openid/login';
+ }
}
};
commit 9033e2a63bf673311a9cc9a5d7c4918637127ce3
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Nov 14 22:34:58 2008 +0000
* Move log messages, whenever possible, to $self->log rather than Jifty->log
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@5990 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm b/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
index ec00ca6..d93c959 100644
--- a/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/VerifyOpenID.pm
@@ -58,7 +58,7 @@ sub take_action {
return;
}
- Jifty->log( "identified as: " . $ident->url );
+ $self->log->debug( "identified as: " . $ident->url );
$self->result->content( openid => $ident->url );
return 1;
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index 24b6da7..a0e84b2 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -59,7 +59,7 @@ on 'openid/verify_and_login' => run {
if ( defined $result and $result->success ) {
my $openid = $result->content('openid');
my $user = Jifty->app_class('CurrentUser')->new( openid => $openid );
- Jifty->log->info("User Class: $user. OpenID: $openid");
+ $Dispatcher->log->info("User Class: $user. OpenID: $openid");
if ( $user->id ) {
# Set up our login message
@@ -79,7 +79,7 @@ on 'openid/verify_and_login' => run {
else {
# User needs to create account still
Jifty->web->session->set( openid => $openid );
- Jifty->log->info("got openid: $openid");
+ $Dispatcher->log->info("got openid: $openid");
my $nick = get('openid.sreg.nickname');
if ( $nick ) {
redirect( Jifty::Web::Form::Clickable->new( url => '/openid/create', parameters => { nickname => $nick, openid => $openid } ));
commit 0c9a6b86c43b9ba736f91df98ae70895427a656b
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Feb 25 20:35:34 2009 +0000
Move appropriate tests into the right dists, and split out Makefile.PL's
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/jifty/trunk@6464 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..0060c80
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,13 @@
+use inc::Module::Install 0.46;
+name('Jifty-Plugin-OpenID');
+version_from('lib/Jifty/Plugin/OpenID.pm');
+
+requires('Jifty');
+requires('Net::OpenID::Consumer');
+requires('Cache::FileCache');
+requires('LWPx::ParanoidAgent');
+
+auto_install();
+tests(qw( t/*/t/*.t ));
+
+WriteAll;
commit a9e85abb8294633ab8e95958afa0a55634ad1810
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Thu Feb 26 20:32:20 2009 +0000
Move OpenID plugin out of core
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@6499 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
commit 7ab581b5cf289b41b95dcfe2705b9a4ea985b917
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Feb 27 20:34:18 2009 +0000
Add versions, inc/, META.yml to dists, and various other dist housecleaning
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@6524 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..77d13e5
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,19 @@
+---
+author: ~
+distribution_type: module
+generated_by: 'Module::Install version 0.79'
+license: unknown
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Jifty-Plugin-OpenID
+no_index:
+ directory:
+ - inc
+ - t
+requires:
+ Cache::FileCache: 0
+ Jifty: 0
+ LWPx::ParanoidAgent: 0
+ Net::OpenID::Consumer: 0
+version: undef
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
new file mode 100644
index 0000000..7efc552
--- /dev/null
+++ b/inc/Module/AutoInstall.pm
@@ -0,0 +1,768 @@
+#line 1
+package Module::AutoInstall;
+
+use strict;
+use Cwd ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.03';
+}
+
+# special map on pre-defined feature sets
+my %FeatureMap = (
+ '' => 'Core Features', # XXX: deprecated
+ '-core' => 'Core Features',
+);
+
+# various lexical flags
+my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
+my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
+my ( $PostambleActions, $PostambleUsed );
+
+# 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 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 =~ /^--default(?:deps)?$/ ) {
+ $AcceptDefault = 1;
+ }
+ elsif ( $arg =~ /^--check(?:deps)?$/ ) {
+ $CheckOnly = 1;
+ }
+ elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
+ $SkipInstall = 1;
+ }
+ elsif ( $arg =~ /^--test(?:only)?$/ ) {
+ $TestOnly = 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]
+ );
+
+ 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.
+ if (
+ defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
+ {
+ print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
+ push @Existing, $mod => $arg;
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+ else {
+ print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
+ push @required, $mod => $arg;
+ }
+ }
+
+ next unless @required;
+
+ my $mandatory = ( $feature eq '-core' or $core_all );
+
+ if (
+ !$SkipInstall
+ and (
+ $CheckOnly
+ 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;
+ }
+ }
+
+ $UnderCPAN = _check_lock(); # check for $UnderCPAN
+
+ if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
+ require Config;
+ print
+"*** Dependencies will be installed the next time you type '$Config::Config{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';
+}
+
+# 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;
+
+ if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
+ print <<'END_MESSAGE';
+
+*** Since we're running under CPANPLUS, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+ }
+
+ _load_cpan();
+
+ # 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() : <LOCK> == 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 ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ push @installed, $pkg;
+ }
+ else {
+ push @modules, $pkg, $ver;
+ }
+ }
+
+ 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 (<FAILED>) { 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() ) {
+ _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 ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ 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 defined( _version_check( $obj->{version}, $ver ) ) ) {
+ 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";
+ }
+ } 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$/; # pseudo-option
+ $CPAN::Config->{$opt} = $arg;
+ }
+
+ 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 defined( _version_check( $obj->cpan_version, $ver ) ) ) {
+ my $pathname = $pkg;
+ $pathname =~ s/::/\\W/;
+
+ foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
+ delete $INC{$inc};
+ }
+
+ my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
+ : 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 defined( _version_check( _load($class), $ver ) ); # 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; # class/instance doesn't matter
+ my $file = $mod;
+
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+
+ local $@;
+ return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
+}
+
+# Load CPAN.pm and it's configuration
+sub _load_cpan {
+ return if $CPAN::VERSION;
+ require CPAN;
+ if ( $CPAN::HandleConfig::VERSION ) {
+ # 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
+sub _version_check {
+ my ( $cur, $min ) = @_;
+ return unless defined $cur;
+
+ $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) ) ? $cur : undef );
+ }
+ 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 ) != -1 )
+ ? $cur
+ : undef );
+ }
+
+ 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 ? $cur : undef );
+}
+
+# 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
+ ? "\$(PERL) $0 --config=$config --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ 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;
+
+ return << ".";
+
+config :: installdeps
+\t\$(NOECHO) \$(NOOP)
+
+checkdeps ::
+\t\$(PERL) $0 --checkdeps
+
+installdeps ::
+\t$PostambleActions
+
+.
+
+}
+
+1;
+
+__END__
+
+#line 1003
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
new file mode 100644
index 0000000..b46be99
--- /dev/null
+++ b/inc/Module/Install.pm
@@ -0,0 +1,369 @@
+#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
+# }
+
+BEGIN {
+ require 5.004;
+}
+use strict 'vars';
+
+use vars qw{$VERSION};
+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 = '0.79';
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
+}
+
+
+
+
+
+# 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
+
+
+
+
+
+# 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 and (stat($0))[9] > time ) { die <<"END_DIE" }
+
+Your installer $0 has a modification time in the future.
+
+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));
+
+
+
+
+
+use Cwd ();
+use File::Find ();
+use File::Path ();
+use FindBin;
+
+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;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unless ( uc($1) eq $1 ) {
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')};
+ }
+ };
+}
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+
+ return 1;
+}
+
+sub preload {
+ my $self = shift;
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $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 ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
+}
+
+sub new {
+ my ($class, %args) = @_;
+
+ # 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) = @_;
+
+ unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $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;
+}
+
+
+
+
+
+#####################################################################
+# Utility Functions
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+sub _read {
+ local *FH;
+ open FH, "< $_[0]" or die "open($_[0]): $!";
+ my $str = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $str;
+}
+
+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]): $!";
+}
+
+# _version is for processing module versions (eg, 1.03_05) not
+# Perl versions (eg, 5.8.1).
+
+sub _version ($) {
+ my $s = shift || 0;
+ $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;
+}
+
+# Cloned from Params::Util::_CLASS
+sub _CLASS ($) {
+ (
+ defined $_[0]
+ and
+ ! ref $_[0]
+ and
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
+ ) ? $_[0] : undef;
+}
+
+1;
+
+# Copyright 2008 - 2009 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
new file mode 100644
index 0000000..343738e
--- /dev/null
+++ b/inc/Module/Install/AutoInstall.pm
@@ -0,0 +1,61 @@
+#line 1
+package Module::Install::AutoInstall;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.79';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+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;
+
+ Module::AutoInstall->import(
+ (@config ? (-config => \@config) : ()),
+ (@core ? (-core => \@core) : ()),
+ $self->features,
+ );
+
+ $self->makemaker_args( Module::AutoInstall::_make_args() );
+
+ my $class = ref($self);
+ $self->postamble(
+ "# --- $class section:\n" .
+ Module::AutoInstall::postamble()
+ );
+}
+
+sub auto_install_now {
+ my $self = shift;
+ $self->auto_install(@_);
+ Module::AutoInstall::do_install();
+}
+
+1;
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
new file mode 100644
index 0000000..1145fe4
--- /dev/null
+++ b/inc/Module/Install/Base.pm
@@ -0,0 +1,72 @@
+#line 1
+package Module::Install::Base;
+
+$VERSION = '0.79';
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+### This is the ONLY module that shouldn't have strict on
+# use strict;
+
+#line 41
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method ( qw(call load) ) {
+ *{"$class\::$method"} = sub {
+ shift()->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless( \%args, $class );
+}
+
+#line 61
+
+sub AUTOLOAD {
+ my $self = shift;
+ local $@;
+ my $autoload = eval { $self->_top->autoload } or return;
+ goto &$autoload;
+}
+
+#line 76
+
+sub _top { $_[0]->{_top} }
+
+#line 89
+
+sub admin {
+ $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+#line 101
+
+sub is_admin {
+ $_[0]->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+ $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 146
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
new file mode 100644
index 0000000..ac81dec
--- /dev/null
+++ b/inc/Module/Install/Can.pm
@@ -0,0 +1,83 @@
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Module::Install::Base;
+use Config ();
+### This adds a 5.005 Perl version dependency.
+### This is a bug and will be fixed.
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.79';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# 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 '';
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+# 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 158
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
new file mode 100644
index 0000000..41d9569
--- /dev/null
+++ b/inc/Module/Install/Fetch.pm
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.79';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+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 at 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;
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
new file mode 100644
index 0000000..742121a
--- /dev/null
+++ b/inc/Module/Install/Include.pm
@@ -0,0 +1,34 @@
+#line 1
+package Module::Install::Include;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.79';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+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;
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
new file mode 100644
index 0000000..689a4b7
--- /dev/null
+++ b/inc/Module/Install/Makefile.pm
@@ -0,0 +1,253 @@
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use Module::Install::Base;
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.79';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+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, always use defaults
+ if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
+}
+
+sub makemaker_args {
+ my $self = shift;
+ my $args = ( $self->{makemaker_args} ||= {} );
+ %$args = ( %$args, @_ );
+ return $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = sShift;
+ my $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 );
+}
+
+my %test_dir = ();
+
+sub _wanted_t {
+ /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
+}
+
+sub tests_recursive {
+ my $self = shift;
+ if ( $self->tests ) {
+ die "tests_recursive will not work if tests are already defined";
+ }
+ my $dir = shift || 't';
+ unless ( -d $dir ) {
+ die "tests_recursive dir '$dir' does not exist";
+ }
+ %test_dir = ();
+ require File::Find;
+ File::Find::find( \&_wanted_t, $dir );
+ $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ # Make sure we have a new enough
+ require ExtUtils::MakeMaker;
+
+ # MakeMaker can complain about module versions that include
+ # an underscore, even though its own version may contain one!
+ # Hence the funny regexp to get rid of it. See RT #35800
+ # for details.
+
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+
+ # Generate the
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{VERSION} = $self->version;
+ $args->{NAME} =~ s/-/::/g;
+ if ( $self->tests ) {
+ $args->{test} = { TESTS => $self->tests };
+ }
+ if ($] >= 5.005) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = $self->author;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ $args->{NO_META} = 1;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq,
+ map { @$_ }
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires, $self->requires)
+ );
+
+ # Remove any reference to perl, PREREQ_PM doesn't support it
+ delete $args->{PREREQ_PM}->{perl};
+
+ # merge both kinds of requires into prereq_pm
+ my $subdirs = ($args->{DIR} ||= []);
+ if ($self->bundles) {
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($file, $dir) = @$bundle;
+ push @$subdirs, $dir if -d $dir;
+ delete $prereq->{$file};
+ }
+ }
+
+ 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";
+ }
+
+ $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: $!";
+ my $makefile = do { local $/; <MAKEFILE> };
+ close MAKEFILE or die $!;
+
+ $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
+ $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
+ $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;
+
+ open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ 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 379
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
new file mode 100644
index 0000000..37d5eff
--- /dev/null
+++ b/inc/Module/Install/Metadata.pm
@@ -0,0 +1,510 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.79';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+my @scalar_keys = qw{
+ name
+ module_name
+ abstract
+ author
+ version
+ distribution_type
+ tests
+ installdirs
+};
+
+my @tuple_keys = qw{
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
+ resources
+};
+
+my @resource_keys = qw{
+ homepage
+ bugtracker
+ repository
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+sub Meta_ResourceKeys { @resource_keys }
+
+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 ( @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 sign {
+ my $self = shift;
+ return $self->{values}{sign} if defined wantarray and ! @_;
+ $self->{values}{sign} = ( @_ ? $_[0] : 1 );
+ return $self;
+}
+
+sub dynamic_config {
+ my $self = shift;
+ unless ( @_ ) {
+ warn "You MUST provide an explicit true/false value to dynamic_config\n";
+ return $self;
+ }
+ $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
+ return 1;
+}
+
+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 reall 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 license {
+ my $self = shift;
+ return $self->{values}{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $self->{values}{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license eq 'perl' ) {
+ $self->resources( license => 'http://dev.perl.org/licenses/' );
+ }
+
+ return 1;
+}
+
+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");
+ }
+
+ # 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) );
+}
+
+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 perl_version_from {
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ ^
+ (?:use|require) \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ ) {
+ my $perl_version = $1;
+ $perl_version =~ s{_}{}g;
+ $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;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ } else {
+ warn "Cannot determine author info from $_[0]\n";
+ }
+}
+
+sub license_from {
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyright|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms ) {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as perl itself' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+}
+
+sub bugtracker_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
+ unless ( @links ) {
+ warn "Cannot determine bugtracker info from $_[0]\n";
+ return 0;
+ }
+ if ( @links > 1 ) {
+ warn "Found more than on rt.cpan.org link in $_[0]\n";
+ return 0;
+ }
+
+ # Set the bugtracker
+ bugtracker( $links[0] );
+ return 1;
+}
+
+# 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) ) {
+ $v = $v + 0; # Numify
+ }
+ return $v;
+}
+
+
+
+
+
+######################################################################
+# MYMETA.yml Support
+
+sub WriteMyMeta {
+ $_[0]->write_mymeta;
+}
+
+sub write_mymeta {
+ my $self = shift;
+
+ # If there's no existing META.yml there is nothing we can do
+ return unless -f 'META.yml';
+
+ # 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
+ require YAML::Tiny;
+ my @yaml = YAML::Tiny::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} } };
+ }
+
+ # Save as the MYMETA.yml file
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+}
+
+1;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
new file mode 100644
index 0000000..2bd721a
--- /dev/null
+++ b/inc/Module/Install/Win32.pm
@@ -0,0 +1,64 @@
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '0.79';
+ @ISA = qw{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;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
new file mode 100644
index 0000000..3819d78
--- /dev/null
+++ b/inc/Module/Install/WriteAll.pm
@@ -0,0 +1,40 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '0.79';
+ @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->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+
+ if ( $args{inline} ) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+}
+
+1;
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index b4bcffd..9333f81 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -5,6 +5,8 @@ package Jifty::Plugin::OpenID;
use base qw/Jifty::Plugin/;
use LWPx::ParanoidAgent;
+our $VERSION = '0.01';
+
=head1 NAME
Jifty::Plugin::OpenID - Provides OpenID authentication for your jifty app
commit 0cf3213e32a3a3f7299d67aebfd66cdf647bbda7
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Feb 27 20:45:01 2009 +0000
Don't include inc/ or META.yml; svn:ignore them instead
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@6525 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/META.yml b/META.yml
deleted file mode 100644
index 77d13e5..0000000
--- a/META.yml
+++ /dev/null
@@ -1,19 +0,0 @@
----
-author: ~
-distribution_type: module
-generated_by: 'Module::Install version 0.79'
-license: unknown
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Jifty-Plugin-OpenID
-no_index:
- directory:
- - inc
- - t
-requires:
- Cache::FileCache: 0
- Jifty: 0
- LWPx::ParanoidAgent: 0
- Net::OpenID::Consumer: 0
-version: undef
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
deleted file mode 100644
index 7efc552..0000000
--- a/inc/Module/AutoInstall.pm
+++ /dev/null
@@ -1,768 +0,0 @@
-#line 1
-package Module::AutoInstall;
-
-use strict;
-use Cwd ();
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION};
-BEGIN {
- $VERSION = '1.03';
-}
-
-# special map on pre-defined feature sets
-my %FeatureMap = (
- '' => 'Core Features', # XXX: deprecated
- '-core' => 'Core Features',
-);
-
-# various lexical flags
-my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
-my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
-my ( $PostambleActions, $PostambleUsed );
-
-# 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 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 =~ /^--default(?:deps)?$/ ) {
- $AcceptDefault = 1;
- }
- elsif ( $arg =~ /^--check(?:deps)?$/ ) {
- $CheckOnly = 1;
- }
- elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
- $SkipInstall = 1;
- }
- elsif ( $arg =~ /^--test(?:only)?$/ ) {
- $TestOnly = 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]
- );
-
- 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.
- if (
- defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
- {
- print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
- push @Existing, $mod => $arg;
- $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
- }
- else {
- print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
- push @required, $mod => $arg;
- }
- }
-
- next unless @required;
-
- my $mandatory = ( $feature eq '-core' or $core_all );
-
- if (
- !$SkipInstall
- and (
- $CheckOnly
- 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;
- }
- }
-
- $UnderCPAN = _check_lock(); # check for $UnderCPAN
-
- if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
- require Config;
- print
-"*** Dependencies will be installed the next time you type '$Config::Config{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';
-}
-
-# 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;
-
- if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
- print <<'END_MESSAGE';
-
-*** Since we're running under CPANPLUS, I'll just let it take care
- of the dependency's installation later.
-END_MESSAGE
- return 1;
- }
-
- _load_cpan();
-
- # 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() : <LOCK> == 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 ( defined( _version_check( _load($pkg), $ver ) ) ) {
- push @installed, $pkg;
- }
- else {
- push @modules, $pkg, $ver;
- }
- }
-
- 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 (<FAILED>) { 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() ) {
- _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 ( defined( _version_check( _load($pkg), $ver ) ) ) {
- 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 defined( _version_check( $obj->{version}, $ver ) ) ) {
- 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";
- }
- } 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$/; # pseudo-option
- $CPAN::Config->{$opt} = $arg;
- }
-
- 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 defined( _version_check( $obj->cpan_version, $ver ) ) ) {
- my $pathname = $pkg;
- $pathname =~ s/::/\\W/;
-
- foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
- delete $INC{$inc};
- }
-
- my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
- : 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 defined( _version_check( _load($class), $ver ) ); # 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; # class/instance doesn't matter
- my $file = $mod;
-
- $file =~ s|::|/|g;
- $file .= '.pm';
-
- local $@;
- return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
-}
-
-# Load CPAN.pm and it's configuration
-sub _load_cpan {
- return if $CPAN::VERSION;
- require CPAN;
- if ( $CPAN::HandleConfig::VERSION ) {
- # 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
-sub _version_check {
- my ( $cur, $min ) = @_;
- return unless defined $cur;
-
- $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) ) ? $cur : undef );
- }
- 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 ) != -1 )
- ? $cur
- : undef );
- }
-
- 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 ? $cur : undef );
-}
-
-# 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
- ? "\$(PERL) $0 --config=$config --installdeps=$missing"
- : "\$(NOECHO) \$(NOOP)"
- );
-
- 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;
-
- return << ".";
-
-config :: installdeps
-\t\$(NOECHO) \$(NOOP)
-
-checkdeps ::
-\t\$(PERL) $0 --checkdeps
-
-installdeps ::
-\t$PostambleActions
-
-.
-
-}
-
-1;
-
-__END__
-
-#line 1003
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
deleted file mode 100644
index b46be99..0000000
--- a/inc/Module/Install.pm
+++ /dev/null
@@ -1,369 +0,0 @@
-#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
-# }
-
-BEGIN {
- require 5.004;
-}
-use strict 'vars';
-
-use vars qw{$VERSION};
-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 = '0.79';
-
- *inc::Module::Install::VERSION = *VERSION;
- @inc::Module::Install::ISA = __PACKAGE__;
-
-}
-
-
-
-
-
-# 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
-
-
-
-
-
-# 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 and (stat($0))[9] > time ) { die <<"END_DIE" }
-
-Your installer $0 has a modification time in the future.
-
-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));
-
-
-
-
-
-use Cwd ();
-use File::Find ();
-use File::Path ();
-use FindBin;
-
-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;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unless ( uc($1) eq $1 ) {
- unshift @_, ( $self, $1 );
- goto &{$self->can('call')};
- }
- };
-}
-
-sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- require "$self->{path}/$self->{dispatch}.pm";
- File::Path::mkpath("$self->{prefix}/$self->{author}");
- $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
- $self->{admin}->init;
- @_ = ($class, _self => $self);
- goto &{"$self->{name}::import"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
-
- return 1;
-}
-
-sub preload {
- my $self = shift;
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $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 ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
-}
-
-sub new {
- my ($class, %args) = @_;
-
- # 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) = @_;
-
- unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $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;
-}
-
-
-
-
-
-#####################################################################
-# Utility Functions
-
-sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
-}
-
-sub _read {
- local *FH;
- open FH, "< $_[0]" or die "open($_[0]): $!";
- my $str = do { local $/; <FH> };
- close FH or die "close($_[0]): $!";
- return $str;
-}
-
-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]): $!";
-}
-
-# _version is for processing module versions (eg, 1.03_05) not
-# Perl versions (eg, 5.8.1).
-
-sub _version ($) {
- my $s = shift || 0;
- $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;
-}
-
-# Cloned from Params::Util::_CLASS
-sub _CLASS ($) {
- (
- defined $_[0]
- and
- ! ref $_[0]
- and
- $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
- ) ? $_[0] : undef;
-}
-
-1;
-
-# Copyright 2008 - 2009 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
deleted file mode 100644
index 343738e..0000000
--- a/inc/Module/Install/AutoInstall.pm
+++ /dev/null
@@ -1,61 +0,0 @@
-#line 1
-package Module::Install::AutoInstall;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.79';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-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;
-
- Module::AutoInstall->import(
- (@config ? (-config => \@config) : ()),
- (@core ? (-core => \@core) : ()),
- $self->features,
- );
-
- $self->makemaker_args( Module::AutoInstall::_make_args() );
-
- my $class = ref($self);
- $self->postamble(
- "# --- $class section:\n" .
- Module::AutoInstall::postamble()
- );
-}
-
-sub auto_install_now {
- my $self = shift;
- $self->auto_install(@_);
- Module::AutoInstall::do_install();
-}
-
-1;
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
deleted file mode 100644
index 1145fe4..0000000
--- a/inc/Module/Install/Base.pm
+++ /dev/null
@@ -1,72 +0,0 @@
-#line 1
-package Module::Install::Base;
-
-$VERSION = '0.79';
-
-# Suspend handler for "redefined" warnings
-BEGIN {
- my $w = $SIG{__WARN__};
- $SIG{__WARN__} = sub { $w };
-}
-
-### This is the ONLY module that shouldn't have strict on
-# use strict;
-
-#line 41
-
-sub new {
- my ($class, %args) = @_;
-
- foreach my $method ( qw(call load) ) {
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- } unless defined &{"$class\::$method"};
- }
-
- bless( \%args, $class );
-}
-
-#line 61
-
-sub AUTOLOAD {
- my $self = shift;
- local $@;
- my $autoload = eval { $self->_top->autoload } or return;
- goto &$autoload;
-}
-
-#line 76
-
-sub _top { $_[0]->{_top} }
-
-#line 89
-
-sub admin {
- $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
-}
-
-#line 101
-
-sub is_admin {
- $_[0]->admin->VERSION;
-}
-
-sub DESTROY {}
-
-package Module::Install::Base::FakeAdmin;
-
-my $Fake;
-sub new { $Fake ||= bless(\@_, $_[0]) }
-
-sub AUTOLOAD {}
-
-sub DESTROY {}
-
-# Restore warning handler
-BEGIN {
- $SIG{__WARN__} = $SIG{__WARN__}->();
-}
-
-1;
-
-#line 146
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
deleted file mode 100644
index ac81dec..0000000
--- a/inc/Module/Install/Can.pm
+++ /dev/null
@@ -1,83 +0,0 @@
-#line 1
-package Module::Install::Can;
-
-use strict;
-use Module::Install::Base;
-use Config ();
-### This adds a 5.005 Perl version dependency.
-### This is a bug and will be fixed.
-use File::Spec ();
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.79';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-# 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 '';
- my $abs = File::Spec->catfile($dir, $_[1]);
- return $abs if (-x $abs or $abs = MM->maybe_command($abs));
- }
-
- return;
-}
-
-# 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 158
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
deleted file mode 100644
index 41d9569..0000000
--- a/inc/Module/Install/Fetch.pm
+++ /dev/null
@@ -1,93 +0,0 @@
-#line 1
-package Module::Install::Fetch;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.79';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-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 at 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;
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
deleted file mode 100644
index 742121a..0000000
--- a/inc/Module/Install/Include.pm
+++ /dev/null
@@ -1,34 +0,0 @@
-#line 1
-package Module::Install::Include;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.79';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-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;
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
deleted file mode 100644
index 689a4b7..0000000
--- a/inc/Module/Install/Makefile.pm
+++ /dev/null
@@ -1,253 +0,0 @@
-#line 1
-package Module::Install::Makefile;
-
-use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.79';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-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, always use defaults
- if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
- local $ENV{PERL_MM_USE_DEFAULT} = 1;
- goto &ExtUtils::MakeMaker::prompt;
- } else {
- goto &ExtUtils::MakeMaker::prompt;
- }
-}
-
-sub makemaker_args {
- my $self = shift;
- my $args = ( $self->{makemaker_args} ||= {} );
- %$args = ( %$args, @_ );
- return $args;
-}
-
-# For mm args that take multiple space-seperated args,
-# append an argument to the current list.
-sub makemaker_append {
- my $self = sShift;
- my $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 );
-}
-
-my %test_dir = ();
-
-sub _wanted_t {
- /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
-}
-
-sub tests_recursive {
- my $self = shift;
- if ( $self->tests ) {
- die "tests_recursive will not work if tests are already defined";
- }
- my $dir = shift || 't';
- unless ( -d $dir ) {
- die "tests_recursive dir '$dir' does not exist";
- }
- %test_dir = ();
- require File::Find;
- File::Find::find( \&_wanted_t, $dir );
- $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
-}
-
-sub write {
- my $self = shift;
- die "&Makefile->write() takes no arguments\n" if @_;
-
- # Make sure we have a new enough
- require ExtUtils::MakeMaker;
-
- # MakeMaker can complain about module versions that include
- # an underscore, even though its own version may contain one!
- # Hence the funny regexp to get rid of it. See RT #35800
- # for details.
-
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
-
- # Generate the
- my $args = $self->makemaker_args;
- $args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name;
- $args->{VERSION} = $self->version;
- $args->{NAME} =~ s/-/::/g;
- if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
- }
- if ($] >= 5.005) {
- $args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = $self->author;
- }
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
- }
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
- $args->{SIGN} = 1;
- }
- unless ( $self->is_admin ) {
- delete $args->{SIGN};
- }
-
- # merge both kinds of requires into prereq_pm
- my $prereq = ($args->{PREREQ_PM} ||= {});
- %$prereq = ( %$prereq,
- map { @$_ }
- map { @$_ }
- grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
- );
-
- # Remove any reference to perl, PREREQ_PM doesn't support it
- delete $args->{PREREQ_PM}->{perl};
-
- # merge both kinds of requires into prereq_pm
- my $subdirs = ($args->{DIR} ||= []);
- if ($self->bundles) {
- foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
- }
- }
-
- 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";
- }
-
- $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: $!";
- my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
-
- $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
- $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
- $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;
-
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- 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 379
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
deleted file mode 100644
index 37d5eff..0000000
--- a/inc/Module/Install/Metadata.pm
+++ /dev/null
@@ -1,510 +0,0 @@
-#line 1
-package Module::Install::Metadata;
-
-use strict 'vars';
-use Module::Install::Base;
-
-use vars qw{$VERSION $ISCORE @ISA};
-BEGIN {
- $VERSION = '0.79';
- $ISCORE = 1;
- @ISA = qw{Module::Install::Base};
-}
-
-my @scalar_keys = qw{
- name
- module_name
- abstract
- author
- version
- distribution_type
- tests
- installdirs
-};
-
-my @tuple_keys = qw{
- configure_requires
- build_requires
- requires
- recommends
- bundles
- resources
-};
-
-my @resource_keys = qw{
- homepage
- bugtracker
- repository
-};
-
-sub Meta { shift }
-sub Meta_ScalarKeys { @scalar_keys }
-sub Meta_TupleKeys { @tuple_keys }
-sub Meta_ResourceKeys { @resource_keys }
-
-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 ( @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 sign {
- my $self = shift;
- return $self->{values}{sign} if defined wantarray and ! @_;
- $self->{values}{sign} = ( @_ ? $_[0] : 1 );
- return $self;
-}
-
-sub dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config\n";
- return $self;
- }
- $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
- return 1;
-}
-
-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 reall 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 license {
- my $self = shift;
- return $self->{values}{license} unless @_;
- my $license = shift or die(
- 'Did not provide a value to license()'
- );
- $self->{values}{license} = $license;
-
- # Automatically fill in license URLs
- if ( $license eq 'perl' ) {
- $self->resources( license => 'http://dev.perl.org/licenses/' );
- }
-
- return 1;
-}
-
-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");
- }
-
- # 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) );
-}
-
-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 perl_version_from {
- my $self = shift;
- if (
- Module::Install::_read($_[0]) =~ m/
- ^
- (?:use|require) \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- ) {
- my $perl_version = $1;
- $perl_version =~ s{_}{}g;
- $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;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- $self->author($author);
- } else {
- warn "Cannot determine author info from $_[0]\n";
- }
-}
-
-sub license_from {
- my $self = shift;
- if (
- Module::Install::_read($_[0]) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /ixms ) {
- my $license_text = $1;
- my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- $self->license($license);
- return 1;
- }
- }
- }
-
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
-}
-
-sub bugtracker_from {
- my $self = shift;
- my $content = Module::Install::_read($_[0]);
- my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
- unless ( @links ) {
- warn "Cannot determine bugtracker info from $_[0]\n";
- return 0;
- }
- if ( @links > 1 ) {
- warn "Found more than on rt.cpan.org link in $_[0]\n";
- return 0;
- }
-
- # Set the bugtracker
- bugtracker( $links[0] );
- return 1;
-}
-
-# 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) ) {
- $v = $v + 0; # Numify
- }
- return $v;
-}
-
-
-
-
-
-######################################################################
-# MYMETA.yml Support
-
-sub WriteMyMeta {
- $_[0]->write_mymeta;
-}
-
-sub write_mymeta {
- my $self = shift;
-
- # If there's no existing META.yml there is nothing we can do
- return unless -f 'META.yml';
-
- # 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
- require YAML::Tiny;
- my @yaml = YAML::Tiny::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} } };
- }
-
- # Save as the MYMETA.yml file
- YAML::Tiny::DumpFile('MYMETA.yml', $meta);
-}
-
-1;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
deleted file mode 100644
index 2bd721a..0000000
--- a/inc/Module/Install/Win32.pm
+++ /dev/null
@@ -1,64 +0,0 @@
-#line 1
-package Module::Install::Win32;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.79';
- @ISA = qw{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;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
deleted file mode 100644
index 3819d78..0000000
--- a/inc/Module/Install/WriteAll.pm
+++ /dev/null
@@ -1,40 +0,0 @@
-#line 1
-package Module::Install::WriteAll;
-
-use strict;
-use Module::Install::Base;
-
-use vars qw{$VERSION @ISA $ISCORE};
-BEGIN {
- $VERSION = '0.79';
- @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->Meta->write if $args{meta};
- $self->admin->WriteAll(%args) if $self->is_admin;
-
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{PL_FILES} ) {
- $self->makemaker_args( PL_FILES => {} );
- }
-
- if ( $args{inline} ) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
-}
-
-1;
commit 1945b8e092610dc386ed76656a77777c18eb4ef0
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Mar 3 00:45:28 2009 +0000
Add install_share to modules that need it, and remove share/ from modules that don't
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@6531 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
commit ea0deead1efff0bf2554ca8d968ed41b1af6fafb
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Mon Mar 16 18:35:50 2009 +0000
More empty directory cleanup
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@6585 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
commit 909cffcfe0cf7880827d153ce8e2f80be6e4e803
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Thu Mar 26 03:00:04 2009 +0000
Bump VERSION of previously-core'd modules, to higher than the core they were bundled with
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@6705 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 9333f81..6dc21d3 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -5,7 +5,7 @@ package Jifty::Plugin::OpenID;
use base qw/Jifty::Plugin/;
use LWPx::ParanoidAgent;
-our $VERSION = '0.01';
+our $VERSION = '0.9';
=head1 NAME
commit 4e219c9294f882e31541f64a6eff1f4c06f05105
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 04:41:03 2009 +0000
- provide UserAgent class option for OpenID plugin.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@6987 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 6dc21d3..a890f79 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -3,9 +3,8 @@ use warnings;
package Jifty::Plugin::OpenID;
use base qw/Jifty::Plugin/;
-use LWPx::ParanoidAgent;
-our $VERSION = '0.9';
+our $VERSION = '0.10';
=head1 NAME
@@ -17,11 +16,39 @@ Provides OpenID authentication for your app
=cut
-sub get_csr {
+sub init {
+ my $self = shift;
+ my %opt = @_;
+ my $ua_class = $self->get_ua_class;
+ eval "require $ua_class";
+}
+
+sub get_ua_class {
+ return Jifty->config->app('OpenIDUA')
+ || $ENV{OpenIDUserAgent}
+ || 'LWPx::ParanoidAgent' ;
+}
+
+sub new_ua {
my $class = shift;
+ my $ua;
+ my $ua_class = $class->get_ua_class;
+ if( $ua_class eq 'LWPx::ParanoidAgent' ) {
+ $ua = LWPx::ParanoidAgent->new(
+ whitelisted_hosts => [ $ENV{JIFTY_OPENID_WHITELIST_HOST} ]
+ );
+ }
+ else {
+ $ua = $ua_class->new;
+ }
+ return $ua;
+}
+
+sub get_csr {
+ my $class = shift;
return Net::OpenID::Consumer->new(
- ua => LWPx::ParanoidAgent->new( whitelisted_hosts => [ $ENV{JIFTY_OPENID_WHITELIST_HOST} ] ),
+ ua => $class->new_ua ,
cache => Cache::FileCache->new,
args => scalar Jifty->handler->cgi->Vars,
consumer_secret => Jifty->config->app('OpenIDSecret'),
commit 1075f12c7646bfbd0bf7a3cfd09ed9d4a400a117
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 04:44:21 2009 +0000
should use Jifty->log instead of $Dispatcher->log
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@6988 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index a0e84b2..24b6da7 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -59,7 +59,7 @@ on 'openid/verify_and_login' => run {
if ( defined $result and $result->success ) {
my $openid = $result->content('openid');
my $user = Jifty->app_class('CurrentUser')->new( openid => $openid );
- $Dispatcher->log->info("User Class: $user. OpenID: $openid");
+ Jifty->log->info("User Class: $user. OpenID: $openid");
if ( $user->id ) {
# Set up our login message
@@ -79,7 +79,7 @@ on 'openid/verify_and_login' => run {
else {
# User needs to create account still
Jifty->web->session->set( openid => $openid );
- $Dispatcher->log->info("got openid: $openid");
+ Jifty->log->info("got openid: $openid");
my $nick = get('openid.sreg.nickname');
if ( $nick ) {
redirect( Jifty::Web::Form::Clickable->new( url => '/openid/create', parameters => { nickname => $nick, openid => $openid } ));
commit 51d5bf3ec97f42eb7769924b4ab9857077601269
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 07:55:03 2009 +0000
add testapp scarlffolding for openid testing
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7001 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/t/TestApp/bin/jifty b/t/TestApp/bin/jifty
new file mode 100755
index 0000000..118d895
--- /dev/null
+++ b/t/TestApp/bin/jifty
@@ -0,0 +1,16 @@
+#!/usr/bin/env perl
+use warnings;
+use strict;
+use UNIVERSAL::require;
+
+BEGIN {
+ Jifty::Util->require or die $UNIVERSAL::require::ERROR;
+ my $root = Jifty::Util->app_root(quiet => 1);
+ unshift @INC, "$root/lib" if ($root);
+}
+
+use Jifty;
+use Jifty::Script;
+
+local $SIG{INT} = sub { warn "Stopped\n"; exit; };
+Jifty::Script->dispatch();
diff --git a/t/TestApp/etc/config.yml b/t/TestApp/etc/config.yml
new file mode 100644
index 0000000..24c1874
--- /dev/null
+++ b/t/TestApp/etc/config.yml
@@ -0,0 +1,61 @@
+---
+application:
+ OpenIDSecret: 1234
+framework:
+ AdminMode: 1
+ ApplicationClass: TestApp
+ ApplicationName: TestApp
+ ApplicationUUID: B2B2509E-3EC4-11DE-A47C-73233554FF8D
+ ConfigFileVersion: 4
+ Database:
+ AutoUpgrade: 1
+ CheckSchema: 1
+ Database: testapp
+ Driver: SQLite
+ Host: localhost
+ Password: ""
+ RecordBaseClass: Jifty::DBI::Record::Cachable
+ User: ""
+ Version: 0.0.1
+ DevelMode: 1
+ L10N:
+ PoDir: share/po
+ LogLevel: INFO
+ Mailer: Sendmail
+ MailerArgs: []
+
+ Plugins:
+ - AdminUI: {}
+ - CompressedCSSandJS: {}
+ - ErrorTemplates: {}
+ - Halo: {}
+ - LetMe: {}
+ - OnlineDocs: {}
+ - REST: {}
+ - SkeletonApp: {}
+ - OpenID: {}
+
+ PubSub:
+ Backend: Memcached
+ Enable: ~
+ SkipAccessControl: 0
+ TemplateClass: TestApp::View
+ View:
+ Handlers:
+ - Jifty::View::Static::Handler
+ - Jifty::View::Declare::Handler
+ - Jifty::View::Mason::Handler
+ Web:
+ BaseURL: http://localhost
+ DataDir: var/mason
+ Globals: []
+
+ MasonConfig:
+ autoflush: 0
+ default_escape_flags: h
+ error_format: text
+ error_mode: fatal
+ Port: 8888
+ ServeStaticFiles: 1
+ StaticRoot: share/web/static
+ TemplateRoot: share/web/templates
diff --git a/t/TestApp/lib/TestApp/Action/User.pm b/t/TestApp/lib/TestApp/Action/User.pm
new file mode 100644
index 0000000..64f26e1
--- /dev/null
+++ b/t/TestApp/lib/TestApp/Action/User.pm
@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+=head1 NAME
+
+TestApp::Action::User
+
+=cut
+
+package TestApp::Action::User;
+use base qw/TestApp::Action Jifty::Action/;
+
+use Jifty::Param::Schema;
+use Jifty::Action schema {
+
+};
+
+=head2 take_action
+
+=cut
+
+sub take_action {
+ my $self = shift;
+
+ # Custom action code
+
+ $self->report_success if not $self->result->failure;
+
+ return 1;
+}
+
+=head2 report_success
+
+=cut
+
+sub report_success {
+ my $self = shift;
+ # Your success message here
+ $self->result->message('Success');
+}
+
+1;
+
diff --git a/t/TestApp/lib/TestApp/Model/User.pm b/t/TestApp/lib/TestApp/Model/User.pm
new file mode 100644
index 0000000..5918a8a
--- /dev/null
+++ b/t/TestApp/lib/TestApp/Model/User.pm
@@ -0,0 +1,16 @@
+use strict;
+use warnings;
+
+package TestApp::Model::User;
+use Jifty::DBI::Schema;
+
+use TestApp::Record schema {
+
+};
+
+use Jifty::Plugin::OpenID::Mixin::Model::User;
+
+# Your model-specific methods go here.
+
+1;
+
diff --git a/t/TestApp/lib/TestApp/View.pm b/t/TestApp/lib/TestApp/View.pm
new file mode 100644
index 0000000..1488a1e
--- /dev/null
+++ b/t/TestApp/lib/TestApp/View.pm
@@ -0,0 +1,41 @@
+package TestApp::View;
+use strict;
+use warnings;
+use Jifty::View::Declare -base;
+use Jifty::View::Declare::Helpers;
+
+
+template '/' => page {
+
+
+ form {
+ my $openid = new_action( class => 'AuthenticateOpenID',
+ moniker => 'authenticateopenid' );
+
+ div { { class is 'openid'};
+ div { { id is 'openid-login' };
+ render_action( $openid );
+ outs_raw(
+ Jifty->web->return(
+ to => '/openid_verify_done',
+ label => _("Login with OpenID"),
+ submit => $openid
+ ));
+ };
+ };
+ };
+
+
+};
+
+
+template '/openid_verify_done' => page {
+
+ h1 { "Done" };
+
+};
+
+
+
+
+1;
diff --git a/t/TestApp/t/00-action-User.t b/t/TestApp/t/00-action-User.t
new file mode 100644
index 0000000..ffc88d0
--- /dev/null
+++ b/t/TestApp/t/00-action-User.t
@@ -0,0 +1,15 @@
+#!/usr/bin/env perl
+use warnings;
+use strict;
+
+=head1 DESCRIPTION
+
+A (very) basic test harness for the User action.
+
+=cut
+
+use Jifty::Test tests => 1;
+
+# Make sure we can load the action
+use_ok('TestApp::Action::User');
+
diff --git a/t/TestApp/t/00-model-User.t b/t/TestApp/t/00-model-User.t
new file mode 100644
index 0000000..e7a604e
--- /dev/null
+++ b/t/TestApp/t/00-model-User.t
@@ -0,0 +1,49 @@
+#!/usr/bin/env perl
+use warnings;
+use strict;
+
+=head1 DESCRIPTION
+
+A basic test harness for the User model.
+
+=cut
+
+use Jifty::Test tests => 11;
+
+# Make sure we can load the model
+use_ok('TestApp::Model::User');
+
+# Grab a system user
+my $system_user = TestApp::CurrentUser->superuser;
+ok($system_user, "Found a system user");
+
+# Try testing a create
+my $o = TestApp::Model::User->new(current_user => $system_user);
+my ($id) = $o->create();
+ok($id, "User create returned success");
+ok($o->id, "New User has valid id set");
+is($o->id, $id, "Create returned the right id");
+
+# And another
+$o->create();
+ok($o->id, "User create returned another value");
+isnt($o->id, $id, "And it is different from the previous one");
+
+# Searches in general
+my $collection = TestApp::Model::UserCollection->new(current_user => $system_user);
+$collection->unlimit;
+is($collection->count, 2, "Finds two records");
+
+# Searches in specific
+$collection->limit(column => 'id', value => $o->id);
+is($collection->count, 1, "Finds one record with specific id");
+
+# Delete one of them
+$o->delete;
+$collection->redo_search;
+is($collection->count, 0, "Deleted row is gone");
+
+# And the other one is still there
+$collection->unlimit;
+is($collection->count, 1, "Still one left");
+
commit 33b38db85d9c3a741ed74cf45a08b90eba6a5748
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 08:02:47 2009 +0000
provide name column for openid testapp user model
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7005 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/t/TestApp/lib/TestApp/Model/User.pm b/t/TestApp/lib/TestApp/Model/User.pm
index 5918a8a..6591dca 100644
--- a/t/TestApp/lib/TestApp/Model/User.pm
+++ b/t/TestApp/lib/TestApp/Model/User.pm
@@ -6,6 +6,13 @@ use Jifty::DBI::Schema;
use TestApp::Record schema {
+
+column name =>
+ type is 'varchar';
+
+column email =>
+ type is 'varchar';
+
};
use Jifty::Plugin::OpenID::Mixin::Model::User;
commit b88c6f7f713eec42c99e8ef0c2c7f2c95b6190c6
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 08:35:39 2009 +0000
set OpenIDUA as LWP::UserAgent in TestApp config
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7006 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/t/TestApp/etc/config.yml b/t/TestApp/etc/config.yml
index 24c1874..e81c462 100644
--- a/t/TestApp/etc/config.yml
+++ b/t/TestApp/etc/config.yml
@@ -1,6 +1,7 @@
---
application:
OpenIDSecret: 1234
+ OpenIDUA: LWP::UserAgent
framework:
AdminMode: 1
ApplicationClass: TestApp
diff --git a/t/TestApp/lib/TestApp/Model/User.pm b/t/TestApp/lib/TestApp/Model/User.pm
index 6591dca..063e19d 100644
--- a/t/TestApp/lib/TestApp/Model/User.pm
+++ b/t/TestApp/lib/TestApp/Model/User.pm
@@ -10,9 +10,6 @@ use TestApp::Record schema {
column name =>
type is 'varchar';
-column email =>
- type is 'varchar';
-
};
use Jifty::Plugin::OpenID::Mixin::Model::User;
diff --git a/t/TestApp/lib/TestApp/View.pm b/t/TestApp/lib/TestApp/View.pm
index 1488a1e..c1b1154 100644
--- a/t/TestApp/lib/TestApp/View.pm
+++ b/t/TestApp/lib/TestApp/View.pm
@@ -6,12 +6,9 @@ use Jifty::View::Declare::Helpers;
template '/' => page {
-
-
form {
my $openid = new_action( class => 'AuthenticateOpenID',
moniker => 'authenticateopenid' );
-
div { { class is 'openid'};
div { { id is 'openid-login' };
render_action( $openid );
@@ -24,15 +21,11 @@ template '/' => page {
};
};
};
-
-
};
template '/openid_verify_done' => page {
-
h1 { "Done" };
-
};
commit 1b56ba763c74695785cf836988137fb03ab3c152
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 08:36:26 2009 +0000
provide document for OpenID Plugin
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7007 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index a890f79..a7b8951 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -14,6 +14,76 @@ Jifty::Plugin::OpenID - Provides OpenID authentication for your jifty app
Provides OpenID authentication for your app
+=head1 USAGE
+
+=head2 Config
+
+please provide C<OpenIDSecret> in your F<etc/config.yml> , the C<OpenIDUA> is
+B<optional> , OpenID Plugin will use L<LWPx::ParanoidAgent> by default.
+
+ ---
+ application:
+ OpenIDSecret: 1234
+ OpenIDUA: LWP::UserAgent
+
+or you can set C<OpenIDUserAgent> environment var in command-line:
+
+ OpenIDUserAgent=LWP::UserAgent bin/jifty server
+
+if you are using L<LWPx::ParanoidAgent> as your openid agent.
+you will need to provide C<JIFTY_OPENID_WHITELIST_HOST> for your own OpenID server.
+
+ export JIFTY_OPENID_WHITELIST_HOST=123.123.123.123
+
+=head2 User Model
+
+create your User model , add a column named C<name> to the model.
+and let User model use L<Jifty::Plugin::OpenID::Mixin::Model::User>.
+
+ use TestApp::Record schema {
+
+ column name =>
+ type is 'varchar';
+
+ };
+ use Jifty::Plugin::OpenID::Mixin::Model::User;
+
+=head2 View
+
+OpenID plugin provides AuthenticateOpenID Action. so that you can render an
+AuthenticateOpenID in your template:
+
+ form {
+ my $openid = new_action( class => 'AuthenticateOpenID',
+ moniker => 'authenticateopenid' );
+ render_action( $openid );
+ };
+
+this action renders a form which provides openid url field.
+and you will need to provide a submit button in your form.
+
+ form {
+ my $openid = new_action( class => 'AuthenticateOpenID',
+ moniker => 'authenticateopenid' );
+
+ # ....
+
+ render_action( $openid );
+ outs_raw(
+ Jifty->web->return(
+ to => '/openid_verify_done',
+ label => _("Login with OpenID"),
+ submit => $openid
+ ));
+ };
+
+the C<to> field is for verified user to redirect to.
+so that you will need to implement a template called C</openid_verify_done>:
+
+ template '/openid_verify_done' => page {
+ h1 { "Done" };
+ };
+
=cut
sub init {
commit ba044260e6a4637d2024d603831870cc762c6c5a
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 09:38:34 2009 +0000
provide openid test
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7010 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/View.pm b/lib/Jifty/Plugin/OpenID/View.pm
index 9b6db2a..8c3bc37 100644
--- a/lib/Jifty/Plugin/OpenID/View.pm
+++ b/lib/Jifty/Plugin/OpenID/View.pm
@@ -60,7 +60,7 @@ template 'openid/create' => page {
)
);
};
- Jifty->web->form->start( call => $next );
+ Jifty->web->form->start( call => $next , name => 'openid-user-create' );
render_action($action);
form_submit( label => _('Continue'), submit => $action );
Jifty->web->form->end;
diff --git a/t/TestApp/lib/TestApp/View.pm b/t/TestApp/lib/TestApp/View.pm
index c1b1154..3ea3f7b 100644
--- a/t/TestApp/lib/TestApp/View.pm
+++ b/t/TestApp/lib/TestApp/View.pm
@@ -6,6 +6,7 @@ use Jifty::View::Declare::Helpers;
template '/' => page {
+ with ( name => 'openid-form' ),
form {
my $openid = new_action( class => 'AuthenticateOpenID',
moniker => 'authenticateopenid' );
diff --git a/t/TestApp/t/00-openid-test.t b/t/TestApp/t/00-openid-test.t
new file mode 100644
index 0000000..565e1f2
--- /dev/null
+++ b/t/TestApp/t/00-openid-test.t
@@ -0,0 +1,61 @@
+#!/usr/bin/env perl
+use Jifty::Test tests => 12;
+use strict;
+use warnings;
+use Jifty::Test::WWW::Mechanize;
+
+
+
+use Test::OpenID::Server;
+my $test_openid_server = Test::OpenID::Server->new;
+my $test_openid_url = $test_openid_server->started_ok("server started ok");
+
+diag $test_openid_url;
+
+my $openid = "$test_openid_url/c9s";
+
+
+my $server = Jifty::Test->make_server;
+isa_ok( $server, 'Jifty::Server' );
+my $URL = $server->started_ok;
+my $mech = Jifty::Test::WWW::Mechanize->new;
+$mech->get_ok( $URL . '/' , "get mainpage" );
+$mech->content_contains( 'Login with OpenID' );
+$mech->content_contains( 'OpenID URL' );
+$mech->content_contains( 'For example:' );
+
+$mech->submit_form(
+ form_name => 'openid-form',
+ fields => {
+ 'J:A:F-openid-authenticateopenid' => $openid,
+ },
+ # button => 'Login with OpenID'
+);
+
+$mech->content_contains( 'Set your username' );
+
+
+# match this name="J:A:F-name-auto-86d3fcd1a158d85fd2e6165fc00113c7-1"
+my $content = $mech->content();
+my ($field_name) = ($content =~ m[name="(J:A:F-name-auto-\w+-\d)"]gsm);
+
+diag $field_name;
+
+$mech->submit_form(
+ form_name => 'openid-user-create',
+ fields => {
+ $field_name => 'c9s'
+ },
+ # button => 'Continue'
+);
+
+
+$mech->content_contains( 'Welcome' );
+
+
+my $u = TestApp::Model::User->new;
+$u->load_by_cols( name => 'c9s' );
+
+ok( $u->id , 'found user' );
+is( $u->name , 'c9s' , 'found openid register user' );
+is( $u->openid , $openid , 'match openid' );
commit e659dbf9cce8e8b0c075c5973ea4e84781e81b66
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 09:39:41 2009 +0000
update dependency
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7011 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/Makefile.PL b/Makefile.PL
index 0060c80..3d7acff 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -5,6 +5,7 @@ version_from('lib/Jifty/Plugin/OpenID.pm');
requires('Jifty');
requires('Net::OpenID::Consumer');
requires('Cache::FileCache');
+requires('Test::OpenID::Server' );
requires('LWPx::ParanoidAgent');
auto_install();
commit 1202b9d8dacd6a2ba566f0268629cfcb94c94e96
Author: Cornelius Lin <c9s at aiink.com>
Date: Tue May 12 18:18:46 2009 +0000
fix OpenID documentation (brief_description part)
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7013 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index a7b8951..924a909 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -37,17 +37,28 @@ you will need to provide C<JIFTY_OPENID_WHITELIST_HOST> for your own OpenID serv
=head2 User Model
-create your User model , add a column named C<name> to the model.
-and let User model use L<Jifty::Plugin::OpenID::Mixin::Model::User>.
+OpenID plugin calls UserModel->brief_description to get a meaningful value of
+an unique id of an user record
+
+so create your user model , add a C<name> method named to return the readable
+user identity. and let User model use
+L<Jifty::Plugin::OpenID::Mixin::Model::User> to mixin "openid" column.
use TestApp::Record schema {
- column name =>
+ column email =>
type is 'varchar';
};
use Jifty::Plugin::OpenID::Mixin::Model::User;
+ sub name {
+ my $self = shift;
+ return $self->email;
+ }
+
+See L<Jifty::Record> for C<brief_description> method.
+
=head2 View
OpenID plugin provides AuthenticateOpenID Action. so that you can render an
diff --git a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
index 01b96e9..440104c 100644
--- a/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
+++ b/lib/Jifty/Plugin/OpenID/Action/CreateOpenIDUser.pm
@@ -3,7 +3,7 @@ use warnings;
=head1 NAME
-Jifty::Plugin::OpenID::Action::CreateOpenIDUser - create 0penId user
+Jifty::Plugin::OpenID::Action::CreateOpenIDUser - Create OpenID user
=cut
diff --git a/t/TestApp/lib/TestApp/Model/User.pm b/t/TestApp/lib/TestApp/Model/User.pm
index 063e19d..8035b91 100644
--- a/t/TestApp/lib/TestApp/Model/User.pm
+++ b/t/TestApp/lib/TestApp/Model/User.pm
@@ -6,9 +6,8 @@ use Jifty::DBI::Schema;
use TestApp::Record schema {
-
-column name =>
- type is 'varchar';
+column email =>
+ type is 'varchar';
};
@@ -16,5 +15,11 @@ use Jifty::Plugin::OpenID::Mixin::Model::User;
# Your model-specific methods go here.
+# Openid Plugin use brief_description to get an user identity.
+sub name {
+ my $self = shift;
+ $self->email;
+}
+
1;
diff --git a/t/TestApp/t/00-openid-test.t b/t/TestApp/t/00-openid-test.t
index 565e1f2..c6e14a5 100644
--- a/t/TestApp/t/00-openid-test.t
+++ b/t/TestApp/t/00-openid-test.t
@@ -37,14 +37,15 @@ $mech->content_contains( 'Set your username' );
# match this name="J:A:F-name-auto-86d3fcd1a158d85fd2e6165fc00113c7-1"
my $content = $mech->content();
-my ($field_name) = ($content =~ m[name="(J:A:F-name-auto-\w+-\d)"]gsm);
+my ($field_name) = ($content =~ m[name="(J:A:F-email-auto-\w+-\d)"]gsm);
diag $field_name;
$mech->submit_form(
form_name => 'openid-user-create',
fields => {
- $field_name => 'c9s'
+ # $field_name => 'c9s'
+ $field_name => 'c9s at c9s'
},
# button => 'Continue'
);
@@ -54,8 +55,8 @@ $mech->content_contains( 'Welcome' );
my $u = TestApp::Model::User->new;
-$u->load_by_cols( name => 'c9s' );
+$u->load_by_cols( email => 'c9s at c9s' );
ok( $u->id , 'found user' );
-is( $u->name , 'c9s' , 'found openid register user' );
+is( $u->email , 'c9s at c9s' , 'found openid register user' );
is( $u->openid , $openid , 'match openid' );
commit b36d1b8be322fb5dce298b46dfbf69f9e3cfaf79
Author: Cornelius Lin <c9s at aiink.com>
Date: Wed May 13 05:36:14 2009 +0000
update openid plugin documentation. the brief_description part.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7023 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 924a909..613b143 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -37,11 +37,7 @@ you will need to provide C<JIFTY_OPENID_WHITELIST_HOST> for your own OpenID serv
=head2 User Model
-OpenID plugin calls UserModel->brief_description to get a meaningful value of
-an unique id of an user record
-
-so create your user model , add a C<name> method named to return the readable
-user identity. and let User model use
+Create your user model , and let it uses
L<Jifty::Plugin::OpenID::Mixin::Model::User> to mixin "openid" column.
use TestApp::Record schema {
@@ -52,12 +48,10 @@ L<Jifty::Plugin::OpenID::Mixin::Model::User> to mixin "openid" column.
};
use Jifty::Plugin::OpenID::Mixin::Model::User;
- sub name {
- my $self = shift;
- return $self->email;
- }
-
-See L<Jifty::Record> for C<brief_description> method.
+Note: if you are using SkeletonApp Plugin , you might need to declare a C<name>
+method. because C<salutation> template in SkeletonApp uses
+current_user->username , which calls C<brief_description> method. See
+L<Jifty::Record> for C<brief_description> method.
=head2 View
commit 292b481b93b6830bc06c934b69071f398048a222
Author: Cornelius Lin <c9s at aiink.com>
Date: Wed May 13 05:40:30 2009 +0000
not to use skeletonapp plugin in testapp
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7024 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/t/TestApp/etc/config.yml b/t/TestApp/etc/config.yml
index e81c462..5d62a9e 100644
--- a/t/TestApp/etc/config.yml
+++ b/t/TestApp/etc/config.yml
@@ -33,7 +33,7 @@ framework:
- LetMe: {}
- OnlineDocs: {}
- REST: {}
- - SkeletonApp: {}
+# - SkeletonApp: {}
- OpenID: {}
PubSub:
commit 7fffa896dd9217a5264d2e7d8d0f6d92ae4d795b
Author: Cornelius Lin <c9s at aiink.com>
Date: Wed May 13 05:41:48 2009 +0000
remove openid testapp action
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7025 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/t/TestApp/lib/TestApp/Action/User.pm b/t/TestApp/lib/TestApp/Action/User.pm
deleted file mode 100644
index 64f26e1..0000000
--- a/t/TestApp/lib/TestApp/Action/User.pm
+++ /dev/null
@@ -1,43 +0,0 @@
-use strict;
-use warnings;
-
-=head1 NAME
-
-TestApp::Action::User
-
-=cut
-
-package TestApp::Action::User;
-use base qw/TestApp::Action Jifty::Action/;
-
-use Jifty::Param::Schema;
-use Jifty::Action schema {
-
-};
-
-=head2 take_action
-
-=cut
-
-sub take_action {
- my $self = shift;
-
- # Custom action code
-
- $self->report_success if not $self->result->failure;
-
- return 1;
-}
-
-=head2 report_success
-
-=cut
-
-sub report_success {
- my $self = shift;
- # Your success message here
- $self->result->message('Success');
-}
-
-1;
-
commit 0af7e1b44cc16fe3dd2161a10350493bbd2b3a1b
Author: Cornelius Lin <c9s at aiink.com>
Date: Wed May 13 05:42:23 2009 +0000
remove openid testapp action test
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7026 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/t/TestApp/t/00-action-User.t b/t/TestApp/t/00-action-User.t
deleted file mode 100644
index ffc88d0..0000000
--- a/t/TestApp/t/00-action-User.t
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/usr/bin/env perl
-use warnings;
-use strict;
-
-=head1 DESCRIPTION
-
-A (very) basic test harness for the User action.
-
-=cut
-
-use Jifty::Test tests => 1;
-
-# Make sure we can load the action
-use_ok('TestApp::Action::User');
-
commit a3db82a28a7dcdb8850cf5f8e6f18f1471002954
Author: Cornelius Lin <c9s at aiink.com>
Date: Wed May 13 05:43:38 2009 +0000
remove name method from user model (since we dont use skeletonapp in testapp)
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7027 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/t/TestApp/lib/TestApp/Model/User.pm b/t/TestApp/lib/TestApp/Model/User.pm
index 8035b91..eddde41 100644
--- a/t/TestApp/lib/TestApp/Model/User.pm
+++ b/t/TestApp/lib/TestApp/Model/User.pm
@@ -13,13 +13,5 @@ column email =>
use Jifty::Plugin::OpenID::Mixin::Model::User;
-# Your model-specific methods go here.
-
-# Openid Plugin use brief_description to get an user identity.
-sub name {
- my $self = shift;
- $self->email;
-}
-
1;
commit f637005f601dbe2e0b8b1ed314034bfe9ce2211f
Author: Cornelius Lin <c9s at aiink.com>
Date: Wed May 13 05:51:15 2009 +0000
still need to provide name method for testapp user model.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7028 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID/Dispatcher.pm b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
index 24b6da7..9bcd086 100644
--- a/lib/Jifty/Plugin/OpenID/Dispatcher.pm
+++ b/lib/Jifty/Plugin/OpenID/Dispatcher.pm
@@ -82,7 +82,9 @@ on 'openid/verify_and_login' => run {
Jifty->log->info("got openid: $openid");
my $nick = get('openid.sreg.nickname');
if ( $nick ) {
- redirect( Jifty::Web::Form::Clickable->new( url => '/openid/create', parameters => { nickname => $nick, openid => $openid } ));
+ redirect( Jifty::Web::Form::Clickable->new( url => '/openid/create', parameters => {
+ nickname => $nick,
+ openid => $openid } ));
}
else {
redirect( Jifty::Web::Form::Clickable->new( url => '/openid/create' ) );
diff --git a/t/TestApp/etc/config.yml b/t/TestApp/etc/config.yml
index 5d62a9e..e81c462 100644
--- a/t/TestApp/etc/config.yml
+++ b/t/TestApp/etc/config.yml
@@ -33,7 +33,7 @@ framework:
- LetMe: {}
- OnlineDocs: {}
- REST: {}
-# - SkeletonApp: {}
+ - SkeletonApp: {}
- OpenID: {}
PubSub:
diff --git a/t/TestApp/lib/TestApp/Model/User.pm b/t/TestApp/lib/TestApp/Model/User.pm
index eddde41..6552d32 100644
--- a/t/TestApp/lib/TestApp/Model/User.pm
+++ b/t/TestApp/lib/TestApp/Model/User.pm
@@ -13,5 +13,10 @@ column email =>
use Jifty::Plugin::OpenID::Mixin::Model::User;
+sub name {
+ my $self = shift;
+ return $self->email;
+}
+
1;
diff --git a/t/TestApp/t/00-openid-test.t b/t/TestApp/t/00-openid-test.t
index c6e14a5..cebf1cf 100644
--- a/t/TestApp/t/00-openid-test.t
+++ b/t/TestApp/t/00-openid-test.t
@@ -50,7 +50,6 @@ $mech->submit_form(
# button => 'Continue'
);
-
$mech->content_contains( 'Welcome' );
commit e88c8f09b2e03a4566b9a6dcfacf602a2de33dbb
Author: Cornelius Lin <c9s at aiink.com>
Date: Wed May 13 05:55:34 2009 +0000
update openid plugin pod
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7029 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 613b143..9c41c16 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -39,6 +39,7 @@ you will need to provide C<JIFTY_OPENID_WHITELIST_HOST> for your own OpenID serv
Create your user model , and let it uses
L<Jifty::Plugin::OpenID::Mixin::Model::User> to mixin "openid" column.
+and a C<name> method.
use TestApp::Record schema {
@@ -48,10 +49,15 @@ L<Jifty::Plugin::OpenID::Mixin::Model::User> to mixin "openid" column.
};
use Jifty::Plugin::OpenID::Mixin::Model::User;
-Note: if you are using SkeletonApp Plugin , you might need to declare a C<name>
-method. because C<salutation> template in SkeletonApp uses
-current_user->username , which calls C<brief_description> method. See
-L<Jifty::Record> for C<brief_description> method.
+ sub name {
+ my $self = shift;
+ return $self->email;
+ }
+
+Note: you might need to declare a C<name> method. because the OpenID
+CreateOpenIDUser action and SkeletonApp needs current_user-E<>>username to show
+welcome message and success message , which calls C<brief_description> method.
+See L<Jifty::Record> for C<brief_description> method.
=head2 View
commit d48921d0e425887e6ea9c17440fab7caccbf8a3f
Author: Cornelius Lin <c9s at aiink.com>
Date: Fri May 15 09:41:17 2009 +0000
add tranditional chinese OpenID Tutorial doc.
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7039 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/doc/OpenID_zhtw.pod b/doc/OpenID_zhtw.pod
new file mode 100644
index 0000000..653e365
--- /dev/null
+++ b/doc/OpenID_zhtw.pod
@@ -0,0 +1,152 @@
+
+=encoding utf8
+
+=head1 NAME
+
+OpenIDAuthenticationGuide::zhtw - ç‚ºä½ çš„ Jifty 應用程å¼æä¾› OpenID é©—è‰
+
+=head1 DESCRIPTION
+
+ç‚ºä½ çš„ Jifty 應用程å¼æä¾› OpenID é©—è‰
+
+=head1 USAGE
+
+=head2 Config
+
+請在 F<etc/config.yml> è¨å®šæª”å…§æä¾› C<OpenIDSecret>
+欄ä½è¨å®šé©—è‰ç¢¼ã€‚å¦å¤–ä½ ä¹Ÿå¯ä»¥æä¾› C<OpenIDUA> 來使用ä¸åŒçš„代ç†å™¨ (UserAgent)
+類別 (éžå¿…è¦)。OpenID Plugin 則會é è¨ä½¿ç”¨ L<LWPx::ParanoidAgent> .
+
+ ---
+ application:
+ OpenIDSecret: 1234
+ OpenIDUA: LWP::UserAgent
+
+ä½ ä¹Ÿå¯ä»¥å¾žå‘½ä»¤åˆ—æŒ‡å®šä½ æ‰€è¦ä½¿ç”¨çš„代ç†å™¨ (UserAgent) 類別 ，用 C<OpenIDUserAgent>:
+
+ OpenIDUserAgent=LWP::UserAgent bin/jifty server
+
+å¦‚æžœä½ æƒ³ç”¨ L<LWPx::ParanoidAgent> ä¾†ä½œç‚ºä½ çš„ OpenID 代ç†å™¨ã€‚
+é‚£éº¼å¦‚æžœä½ éœ€è¦æä¾›ä½ è‡ªå·±çš„ OpenID 伺æœå™¨ä½œç‚ºé©—è‰ï¼Œè«‹å°‡ä½ 的伺æœå™¨ä½å€åŠ 入至
+
+C<JIFTY_OPENID_WHITELIST_HOST> 這個環境變數內:
+
+ export JIFTY_OPENID_WHITELIST_HOST=123.123.123.123
+
+=head2 User Model
+
+第一æ¥ï¼Œä½ 需è¦å»ºç«‹è‡ªå·±çš„ User 資料模型 ( Model ) 來å˜æ”¾ä½¿ç”¨è€…資料。
+
+ç„¶å¾Œä½ éœ€è¦å°‡ UserID æ’件æ供的使用者模型çµåˆä½ çš„ User è³‡æ–™æ¨¡åž‹ï¼Œè®“ä½ çš„
+模型å¯ä»¥åŒæ™‚æ“有 OpenID æ’件所定義的欄ä½ã€‚
+è«‹åœ¨ä½ çš„æ¨¡åž‹æª”æ¡ˆå…§åŠ å…¥
+
+ use Jifty::Plugin::OpenID::Mixin::Model::User
+
+æ¤å¤– OpenID æ’ä»¶æœƒå‘¼å« UserModel çš„ brief_description 函å¼ä¾†å–å¾—å¯é–±è®€çš„唯一值
+在使用 CurrentUser 物件時，會需è¦è®“ brief_description 函å¼ä¾†å–得有æ„義的使用者å稱
+
+æ‰€ä»¥ä½ éœ€è¦åœ¨ User æ¨¡åž‹å…§å¯¦åš C<name> 函å¼ã€‚
+
+大致上看來會åƒé€™æ¨£:
+
+ use TestApp::Record schema {
+
+ column email =>
+ type is 'varchar';
+
+ };
+ use Jifty::Plugin::OpenID::Mixin::Model::User;
+
+ sub name {
+ my $self = shift;
+ return $self->email;
+ }
+
+è«‹åƒè¦‹ L<Jifty::Record> 所定義的 C<brief_description> 函å¼ä¾†äº†è§£æ›´è©³ç´°çš„資訊。
+
+=head2 View
+
+OpenID æ’件æ供了 AuthenticateOpenID 的動作 (Action) ã€‚æ‰€ä»¥ä½ å¯ä»¥åœ¨ä½ 的樣æ¿ä¸
+來繪製 AuthenticationOpenID æ供的表單:
+
+ form {
+ my $openid = new_action( class => 'AuthenticateOpenID',
+ moniker => 'authenticateopenid' );
+ render_action( $openid );
+ };
+
+這個動作 (Action) 會繪製一個æä¾› OpenID 網å€çš„欄ä½ã€‚
+ç„¶å¾Œï¼Œä½ æŽ¥è‘—ä¹Ÿéœ€è¦åœ¨è¡¨å–®å…§æ供一個é€å‡ºçš„按鈕:
+
+ form {
+ my $openid = new_action( class => 'AuthenticateOpenID',
+ moniker => 'authenticateopenid' );
+
+ # ....
+
+ render_action( $openid );
+ outs_raw(
+ Jifty->web->return(
+ to => '/openid_verify_done',
+ label => _("Login with OpenID"),
+ submit => $openid
+ ));
+ };
+
+在 C<to> 欄ä½ï¼Œæ˜¯ç”¨ä¾†è®“已經確èªèº«ä»½çš„使用者確èªä¹‹å¾Œå°Žå‘çš„é é¢ã€‚
+æ‰€ä»¥ä½ éœ€è¦å¯¦åšä¸€å€‹ C</openid_verify_done> 的樣æ¿:
+
+ template '/openid_verify_done' => page {
+ h1 { "Done" };
+ };
+
+æ‰“é–‹ä½ çš„ Jifty ，測試一下å§!
+
+=head1 AUTHOR
+
+林佑安 C<<cornelius.howl _at_ gmail.com>> L<http://oulixe.us>
+
+=cut
+
+sub init {
+ my $self = shift;
+ my %opt = @_;
+ my $ua_class = $self->get_ua_class;
+ eval "require $ua_class";
+}
+
+sub get_ua_class {
+ return Jifty->config->app('OpenIDUA')
+ || $ENV{OpenIDUserAgent}
+ || 'LWPx::ParanoidAgent' ;
+}
+
+sub new_ua {
+ my $class = shift;
+ my $ua;
+ my $ua_class = $class->get_ua_class;
+ if( $ua_class eq 'LWPx::ParanoidAgent' ) {
+ $ua = LWPx::ParanoidAgent->new(
+ whitelisted_hosts => [ $ENV{JIFTY_OPENID_WHITELIST_HOST} ]
+ );
+ }
+ else {
+ $ua = $ua_class->new;
+ }
+ return $ua;
+}
+
+
+sub get_csr {
+ my $class = shift;
+ return Net::OpenID::Consumer->new(
+ ua => $class->new_ua ,
+ cache => Cache::FileCache->new,
+ args => scalar Jifty->handler->cgi->Vars,
+ consumer_secret => Jifty->config->app('OpenIDSecret'),
+ @_,
+ );
+}
+
+1;
commit 2d479dde3f37251c6cef60028f01052cbb368b02
Author: Cornelius Lin <c9s at aiink.com>
Date: Fri May 22 07:17:55 2009 +0000
jifty->log->info which useragent we are using (openid plugin)
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7097 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 9c41c16..2157db6 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -114,6 +114,9 @@ sub new_ua {
my $class = shift;
my $ua;
my $ua_class = $class->get_ua_class;
+
+ Jifty->log->info( "OpenID Plugin is using $ua_class as UserAgent" );
+
if( $ua_class eq 'LWPx::ParanoidAgent' ) {
$ua = LWPx::ParanoidAgent->new(
whitelisted_hosts => [ $ENV{JIFTY_OPENID_WHITELIST_HOST} ]
commit c2f74a49c5430d19c6d796ecb75f259ca87a2490
Author: Yves Agostini <agostini at univ-metz.fr>
Date: Tue Jun 9 20:43:31 2009 +0000
ready to upload to cpan
* update Makefile.PL for new Module::Install, all_from file
* add Changes and README
* add Author (from svn log) and copyright notice
* fix pod error
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7210 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..773fc0e
--- /dev/null
+++ b/Changes
@@ -0,0 +1,4 @@
+Revision history for Perl module Jifty::Plugin::OpenID
+
+0.10 Tue, 09 Jun 2009 22:28:10 +0200
+ - original version for CPAN
diff --git a/Makefile.PL b/Makefile.PL
index 3d7acff..51ef668 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,6 +1,6 @@
-use inc::Module::Install 0.46;
+use inc::Module::Install;
name('Jifty-Plugin-OpenID');
-version_from('lib/Jifty/Plugin/OpenID.pm');
+all_from('lib/Jifty/Plugin/OpenID.pm');
requires('Jifty');
requires('Net::OpenID::Consumer');
diff --git a/README b/README
new file mode 100644
index 0000000..33fa829
--- /dev/null
+++ b/README
@@ -0,0 +1,94 @@
+NAME
+ Jifty::Plugin::OpenID - Provides OpenID authentication for your jifty
+ app
+
+DESCRIPTION
+ Provides OpenID authentication for your app
+
+USAGE
+ Config
+ please provide "OpenIDSecret" in your etc/config.yml , the "OpenIDUA" is
+ optional , OpenID Plugin will use LWPx::ParanoidAgent by default.
+
+ ---
+ application:
+ OpenIDSecret: 1234
+ OpenIDUA: LWP::UserAgent
+
+ or you can set "OpenIDUserAgent" environment var in command-line:
+
+ OpenIDUserAgent=LWP::UserAgent bin/jifty server
+
+ if you are using LWPx::ParanoidAgent as your openid agent. you will need
+ to provide "JIFTY_OPENID_WHITELIST_HOST" for your own OpenID server.
+
+ export JIFTY_OPENID_WHITELIST_HOST=123.123.123.123
+
+ User Model
+ Create your user model , and let it uses
+ Jifty::Plugin::OpenID::Mixin::Model::User to mixin "openid" column. and
+ a "name" method.
+
+ use TestApp::Record schema {
+
+ column email =>
+ type is 'varchar';
+
+ };
+ use Jifty::Plugin::OpenID::Mixin::Model::User;
+
+ sub name {
+ my $self = shift;
+ return $self->email;
+ }
+
+ Note: you might need to declare a "name" method. because the OpenID
+ CreateOpenIDUser action and SkeletonApp needs current_user->username to
+ show welcome message and success message , which calls
+ "brief_description" method. See Jifty::Record for "brief_description"
+ method.
+
+ View
+ OpenID plugin provides AuthenticateOpenID Action. so that you can render
+ an AuthenticateOpenID in your template:
+
+ form {
+ my $openid = new_action( class => 'AuthenticateOpenID',
+ moniker => 'authenticateopenid' );
+ render_action( $openid );
+ };
+
+ this action renders a form which provides openid url field. and you will
+ need to provide a submit button in your form.
+
+ form {
+ my $openid = new_action( class => 'AuthenticateOpenID',
+ moniker => 'authenticateopenid' );
+
+ # ....
+
+ render_action( $openid );
+ outs_raw(
+ Jifty->web->return(
+ to => '/openid_verify_done',
+ label => _("Login with OpenID"),
+ submit => $openid
+ ));
+ };
+
+ the "to" field is for verified user to redirect to. so that you will
+ need to implement a template called "/openid_verify_done":
+
+ template '/openid_verify_done' => page {
+ h1 { "Done" };
+ };
+
+AUTHORS
+ Alex Vandiver, Cornelius <cornelius.howl {at} gmail.com >
+
+LICENSE
+ Copyright 2005-2009 Best Practical Solutions, LLC.
+
+ This program is free software and may be modified and distributed under
+ the same terms as Perl itself.
+
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 2157db6..6f04301 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -55,7 +55,7 @@ and a C<name> method.
}
Note: you might need to declare a C<name> method. because the OpenID
-CreateOpenIDUser action and SkeletonApp needs current_user-E<>>username to show
+CreateOpenIDUser action and SkeletonApp needs current_user->username to show
welcome message and success message , which calls C<brief_description> method.
See L<Jifty::Record> for C<brief_description> method.
@@ -140,4 +140,16 @@ sub get_csr {
);
}
+=head1 AUTHORS
+
+Alex Vandiver, Cornelius <cornelius.howl {at} gmail.com >
+
+=head1 LICENSE
+
+Copyright 2005-2009 Best Practical Solutions, LLC.
+
+This program is free software and may be modified and distributed under the same terms as Perl itself.
+
+=cut
+
1;
commit ad764750090c6a8710396d1f6269d9b8760b620c
Author: Yves Agostini <agostini at univ-metz.fr>
Date: Wed Jun 10 09:59:57 2009 +0000
* bump version number to avoid conflict with debian
* add minimal load test
* temporary suspend tests with Test::OpenID::Server
git-svn-id: svn+ssh://svn.bestpractical.com/svn/jifty.org/plugins/Jifty-Plugin-OpenID@7218 e84bef0a-9b06-0410-84ba-c4c9edb13aeb
diff --git a/Changes b/Changes
index 773fc0e..3031132 100644
--- a/Changes
+++ b/Changes
@@ -1,4 +1,9 @@
Revision history for Perl module Jifty::Plugin::OpenID
+1.00 Wed, 10 Jun 2009 11:55:15 +0200
+ - bump version number to avoid conflict with debian
+ - add minimal load test
+ - temporary suspend tests with Test::OpenID::Server
+
0.10 Tue, 09 Jun 2009 22:28:10 +0200
- original version for CPAN
diff --git a/Makefile.PL b/Makefile.PL
index 51ef668..cc5031a 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -5,10 +5,12 @@ all_from('lib/Jifty/Plugin/OpenID.pm');
requires('Jifty');
requires('Net::OpenID::Consumer');
requires('Cache::FileCache');
-requires('Test::OpenID::Server' );
+# suspend this test on 1.00 will be back in 1.01
+#requires('Test::OpenID::Server' );
requires('LWPx::ParanoidAgent');
auto_install();
-tests(qw( t/*/t/*.t ));
+#tests('t/*.t t/*/t/*.t');
+tests('t/*.t');
WriteAll;
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 6f04301..4c449c8 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -4,7 +4,7 @@ use warnings;
package Jifty::Plugin::OpenID;
use base qw/Jifty::Plugin/;
-our $VERSION = '0.10';
+our $VERSION = '1.00';
=head1 NAME
diff --git a/t/00-load.t b/t/00-load.t
new file mode 100644
index 0000000..9f34325
--- /dev/null
+++ b/t/00-load.t
@@ -0,0 +1,7 @@
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use Test::More tests => 1;
+use_ok('Jifty::Plugin::OpenID');
commit b49846be2868528b44285d3a5c8b9ff3b98cb791
Author: Shawn M Moore <sartak at gmail.com>
Date: Wed Dec 16 10:18:41 2009 -0500
Mention that you have to add OpenID to plugins
diff --git a/lib/Jifty/Plugin/OpenID.pm b/lib/Jifty/Plugin/OpenID.pm
index 4c449c8..c3a130e 100644
--- a/lib/Jifty/Plugin/OpenID.pm
+++ b/lib/Jifty/Plugin/OpenID.pm
@@ -18,7 +18,9 @@ Provides OpenID authentication for your app
=head2 Config
-please provide C<OpenIDSecret> in your F<etc/config.yml> , the C<OpenIDUA> is
+First add the C<OpenID> plugin to the list of plugins in F<etc/config.yml>.
+
+Please provide C<OpenIDSecret> in your F<etc/config.yml> , the C<OpenIDUA> is
B<optional> , OpenID Plugin will use L<LWPx::ParanoidAgent> by default.
---
-----------------------------------------------------------------------
More information about the Jifty-commit
mailing list