[Bps-public-commit] RT-Extension-Captcha branch, master, updated. c7c89c7f052efc5a0c90e712c4bd077436272b16
Ruslan Zakirov
ruz at bestpractical.com
Mon Mar 29 17:06:38 EDT 2010
The branch, master has been updated
via c7c89c7f052efc5a0c90e712c4bd077436272b16 (commit)
via d89d57dd8cc891669c4154b938bb72573b8fa776 (commit)
via 168010c58cd79b5056e868ca690571be9403f8a0 (commit)
via 1dc8a4ed7500a57e6eecba19a92349554e984266 (commit)
via 253bdbe5458458c9d62ad4cafc610bfdc773a21f (commit)
via 9acf80f303ce7c1d05fac882a40c78dc313bfdb7 (commit)
from 5af5b4c4e9e0e5c242e5f1da6b2d37362232f01b (commit)
Summary of changes:
.gitignore | 5 +
CHANGES | 10 +
MANIFEST | 3 +
META.yml | 8 +-
Makefile.PL | 1 +
README | 53 ++++-
etc/Captcha_Config.pm | 9 +
html/Helpers/Captcha | 25 ++-
inc/Module/Install.pm | 238 +++++++++++------
inc/Module/Install/Base.pm | 60 +++--
inc/Module/Install/Can.pm | 20 +-
inc/Module/Install/Fetch.pm | 12 +-
inc/Module/Install/Makefile.pm | 230 +++++++++++++---
inc/Module/Install/Metadata.pm | 500 ++++++++++++++++++++++++-----------
inc/Module/Install/RTx.pm | 9 +-
inc/Module/Install/ReadmeFromPod.pm | 36 +++
inc/Module/Install/Win32.pm | 6 +-
inc/Module/Install/WriteAll.pm | 31 ++-
lib/RT/Extension/Captcha.pm | 41 +++-
19 files changed, 951 insertions(+), 346 deletions(-)
create mode 100644 .gitignore
create mode 100644 CHANGES
create mode 100644 etc/Captcha_Config.pm
create mode 100644 inc/Module/Install/ReadmeFromPod.pm
- Log -----------------------------------------------------------------
commit 9acf80f303ce7c1d05fac882a40c78dc313bfdb7
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Mar 30 00:35:34 2010 +0400
add config
diff --git a/MANIFEST b/MANIFEST
index 70d065b..7546d11 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,3 +1,4 @@
+etc/Captcha_Config.pm
html/Callbacks/RT-Extension-Captcha/index.html/Initial
html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/BeforeCreate
html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
diff --git a/etc/Captcha_Config.pm b/etc/Captcha_Config.pm
new file mode 100644
index 0000000..4dede26
--- /dev/null
+++ b/etc/Captcha_Config.pm
@@ -0,0 +1,9 @@
+
+Set(%Captcha,
+ ImageProperties => {
+ width => 320,
+ height => 100,
+ ptsize => 40,
+ lines => 10,
+ },
+);
commit 253bdbe5458458c9d62ad4cafc610bfdc773a21f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Mar 30 00:36:42 2010 +0400
improve options and fonts handling
* use Captcha config option
* support new format of ChartFont option
* log error if font doesn't exist or is not readable
diff --git a/html/Helpers/Captcha b/html/Helpers/Captcha
index be7657f..e21b042 100644
--- a/html/Helpers/Captcha
+++ b/html/Helpers/Captcha
@@ -1,13 +1,28 @@
<%INIT>
-my $str = $session{'Captcha'}{'String'}
- ||= uc $session{'CurrentUser'}->GenerateRandomPassword(6, 9);
-my ($image, $type, $rnd) = GD::SecurityImage->new(
+my %props = (
width => 320,
height => 100,
ptsize => 40,
lines => 10,
- font => RT->Config->Get('ChartFont') || '/usr/share/fonts/corefonts/georgia.ttf',
-)->random( $str )->create( 'ttf', 'circle' )->particle->out;
+ %{ RT->Config->Get('Captcha')->{'ImageProperties'} },
+);
+unless ( $props{'font'} ) {
+ my $opt = RT->Config->Get('ChartFont');
+ $opt = $opt->{'others'} if ref $opt;
+ $props{'font'} = $opt;
+}
+if ( $props{'font'} && !(-e $props{'font'} && -r _) ) {
+ $RT::Logger->error(
+ "Font '$props{'font'}' doesn't exist or is not readable."
+ ." Captcha images will be blank. Check ChartFont option"
+ ." and Captcha->ImageProperties->font option."
+ );
+}
+
+my $str = $session{'Captcha'}{'String'}
+ ||= uc $session{'CurrentUser'}->GenerateRandomPassword(6, 9);
+my ($image, $type, $rnd) = GD::SecurityImage->new( %props )
+ ->random( $str )->create( 'ttf', 'circle' )->particle->out;
$session{'Captcha'}{'String'} = $str;
commit 1dc8a4ed7500a57e6eecba19a92349554e984266
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Mar 30 01:02:27 2010 +0400
update docs
diff --git a/Makefile.PL b/Makefile.PL
index c5a8384..4d68ae4 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -2,6 +2,7 @@ use inc::Module::Install;
RTx 'RT-Extension-Captcha';
all_from 'lib/RT/Extension/Captcha.pm';
+readme_from 'lib/RT/Extension/Captcha.pm';
{ # check RT version
my @v = split /\./, "$RT::VERSION";
diff --git a/README b/README
index bdf5cf9..fe2a007 100644
--- a/README
+++ b/README
@@ -1 +1,52 @@
-Read `perldoc lib/RT/Extension/Captcha.pm`
+NAME
+ RT::Extension::Captcha - solve a CAPTCHA before some actions in RT
+
+DESCRIPTION
+ This extension is for RT 3.8.1 or newer. At this point solving captchas
+ is required when user create a ticket using either regular interface or
+ quick create (with 3.8.2 or newer only) and on replies/comments
+ (updates).
+
+INSTALLATION
+ perl Makefile.PL
+ make
+ make install
+
+ In the RT config:
+
+ Set(@Plugins, 'RT::Extension::Captcha', ... other extensions ... );
+
+CONFIGURATION
+ No CAPTCHA rights
+ Users who have right 'NoCaptchaOnCreate' or 'NoCaptchaOnUpdate' will see
+ no captchas on corresponding actions.
+
+ Font
+ As GD's builtin font is kinda small. A ttf font is used instead. By
+ default font defined by ChartFont option (RT's option to set fonts for
+ charts) is used for CAPTCHA images.
+
+ As well, you can set font for cpatchas only using "%Captcha option"
+ described below.
+
+ %Captcha option
+ See etc/Captcha_Config.pm for defaults and example. %Captcha option is a
+ hash. Now, only ImageProperties key has meaning:
+
+ Set(%Captcha,
+ ImageProperties => {
+ option => value,
+ option => value,
+ ...
+ },
+ );
+
+ ImageProperties are passed into "new" in GD::SecurityImage. Read
+ documentation for the module for full list of options.
+
+LICENSE
+ Under the same terms as perl itself.
+
+AUTHOR
+ Ruslan Zakirov <ruz at bestpractical.com>
+
diff --git a/lib/RT/Extension/Captcha.pm b/lib/RT/Extension/Captcha.pm
index 618e9e9..3a37b3b 100644
--- a/lib/RT/Extension/Captcha.pm
+++ b/lib/RT/Extension/Captcha.pm
@@ -14,16 +14,9 @@ RT::Extension::Captcha - solve a CAPTCHA before some actions in RT
=head1 DESCRIPTION
-This extension for RT 3.8.1 or newer. At this point solving captchas is
+This extension is for RT 3.8.1 or newer. At this point solving captchas is
required when user create a ticket using either regular interface or
quick create (with 3.8.2 or newer only) and on replies/comments (updates).
-Users who have right 'OnCaptchaOnCreate' or 'OnCaptchaOnUpdate' will see
-no captchas on corresponding actions.
-
-As GD's built in font is kinda small, we enabled ttf support and
-it's not configurable at this point. Either hack this extension
-or set an absolute path to a ttf font via 'ChartFont' option in
-the RT config.
=head1 INSTALLATION
@@ -35,6 +28,38 @@ In the RT config:
Set(@Plugins, 'RT::Extension::Captcha', ... other extensions ... );
+=head1 CONFIGURATION
+
+=head2 No CAPTCHA rights
+
+Users who have right 'NoCaptchaOnCreate' or 'NoCaptchaOnUpdate'
+will see no captchas on corresponding actions.
+
+=head2 Font
+
+As GD's builtin font is kinda small. A ttf font is used instead.
+By default font defined by ChartFont option (RT's option to set
+fonts for charts) is used for CAPTCHA images.
+
+As well, you can set font for cpatchas only using L</%Captcha option>
+described below.
+
+=head2 %Captcha option
+
+See F<etc/Captcha_Config.pm> for defaults and example. C<%Captcha>
+option is a hash. Now, only ImageProperties key has meaning:
+
+ Set(%Captcha,
+ ImageProperties => {
+ option => value,
+ option => value,
+ ...
+ },
+ );
+
+ImageProperties are passed into L<GD::SecurityImage/new>. Read documentation
+for the module for full list of options.
+
=cut
use RT::Queue;
commit 168010c58cd79b5056e868ca690571be9403f8a0
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Mar 30 01:02:52 2010 +0400
update M::I
diff --git a/META.yml b/META.yml
index 7ac96d9..73fac47 100644
--- a/META.yml
+++ b/META.yml
@@ -2,8 +2,12 @@
abstract: 'solve a CAPTCHA before some actions in RT'
author:
- 'Ruslan Zakirov <ruz at bestpractical.com>'
+build_requires:
+ ExtUtils::MakeMaker: 6.42
+configure_requires:
+ ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.77'
+generated_by: 'Module::Install version 0.95'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -13,8 +17,6 @@ no_index:
directory:
- etc
- html
- - po
- - var
- inc
requires:
GD::SecurityImage: 0
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index eb449ca..bc055a9 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -17,12 +17,14 @@ package Module::Install;
# 3. The ./inc/ version of Module::Install loads
# }
-BEGIN {
- require 5.004;
-}
+use 5.005;
use strict 'vars';
+use Cwd ();
+use File::Find ();
+use File::Path ();
+use FindBin;
-use vars qw{$VERSION};
+use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
@@ -30,25 +32,35 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.77';
+ $VERSION = '0.95';
+
+ # Storage for the pseudo-singleton
+ $MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
-
-
-
-# Whether or not inc::Module::Install is actually loaded, the
-# $INC{inc/Module/Install.pm} is what will still get set as long as
-# the caller loaded module this in the documented manner.
-# If not set, the caller may NOT have loaded the bundled version, and thus
-# they may not have a MI version that works with the Makefile.PL. This would
-# result in false errors or unexpected behaviour. And we don't want that.
-my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
-unless ( $INC{$file} ) { die <<"END_DIE" }
+ #-------------------------------------------------------------
+ # all of the following checks should be included in import(),
+ # to allow "eval 'require Module::Install; 1' to test
+ # installation of Module::Install. (RT #51267)
+ #-------------------------------------------------------------
+
+ # Whether or not inc::Module::Install is actually loaded, the
+ # $INC{inc/Module/Install.pm} is what will still get set as long as
+ # the caller loaded module this in the documented manner.
+ # If not set, the caller may NOT have loaded the bundled version, and thus
+ # they may not have a MI version that works with the Makefile.PL. This would
+ # result in false errors or unexpected behaviour. And we don't want that.
+ my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+ unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
@@ -60,32 +72,42 @@ not:
END_DIE
+ # This reportedly fixes a rare Win32 UTC file time issue, but
+ # as this is a non-cross-platform XS module not in the core,
+ # we shouldn't really depend on it. See RT #24194 for detail.
+ # (Also, this module only supports Perl 5.6 and above).
+ eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
+ # If the script that is loading Module::Install is from the future,
+ # then make will detect this and cause it to re-run over and over
+ # again. This is bad. Rather than taking action to touch it (which
+ # is unreliable on some platforms and requires write permissions)
+ # for now we should catch this and refuse to run.
+ if ( -f $0 ) {
+ my $s = (stat($0))[9];
+ # If the modification time is only slightly in the future,
+ # sleep briefly to remove the problem.
+ my $a = $s - time;
+ if ( $a > 0 and $a < 5 ) { sleep 5 }
+ # Too far in the future, throw an error.
+ my $t = time;
+ if ( $s > $t ) { die <<"END_DIE" }
-# 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.
+Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
+ }
-
-
-
-# Build.PL was formerly supported, but no longer is due to excessive
-# difficulty in implementing every single feature twice.
-if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
+ # 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.
@@ -95,23 +117,36 @@ Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
+ #-------------------------------------------------------------
+ # To save some more typing in Module::Install installers, every...
+ # use inc::Module::Install
+ # ...also acts as an implicit use strict.
+ $^H |= strict::bits(qw(refs subs vars));
+ #-------------------------------------------------------------
+ unless ( -f $self->{file} ) {
+ 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"};
+ }
-# 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));
-
-
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+ # Save to the singleton
+ $MAIN = $self;
-use Cwd ();
-use File::Find ();
-use File::Path ();
-use FindBin;
+ return 1;
+}
sub autoload {
my $self = shift;
@@ -121,39 +156,23 @@ sub autoload {
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
- # delegate back to parent dirs
+ # 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')};
+ my $method = $1;
+ if ( uc($method) eq $method ) {
+ # Do nothing
+ return;
+ } elsif ( $method =~ /^_/ and $self->can($method) ) {
+ # Dispatch to the root M:I class
+ return $self->$method(@_);
}
- };
-}
-
-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;
+ # Dispatch to the appropriate plugin
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')};
+ };
}
sub preload {
@@ -166,8 +185,7 @@ sub preload {
my @exts = @{$self->{extensions}};
unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $admin->load_all_extensions;
+ @exts = $self->{admin}->load_all_extensions;
}
my %seen;
@@ -250,7 +268,7 @@ END_DIE
sub load_extensions {
my ($self, $path, $top) = @_;
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
@@ -314,7 +332,7 @@ sub find_extensions {
#####################################################################
-# Utility Functions
+# Common Utility Functions
sub _caller {
my $depth = 0;
@@ -326,33 +344,87 @@ sub _caller {
return $call;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _read {
+ local *FH;
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_NEW
sub _read {
local *FH;
- open FH, "< $_[0]" or die "open($_[0]): $!";
- my $str = do { local $/; <FH> };
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
- return $str;
+ return $string;
+}
+END_OLD
+
+sub _readperl {
+ my $string = Module::Install::_read($_[0]);
+ $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
+ $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
+ $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
+ return $string;
+}
+
+sub _readpod {
+ my $string = Module::Install::_read($_[0]);
+ $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
+ return $string if $_[0] =~ /\.pod\z/;
+ $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
+ $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
+ $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
+ $string =~ s/^\n+//s;
+ return $string;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
- open FH, "> $_[0]" or die "open($_[0]): $!";
- foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
close FH or die "close($_[0]): $!";
}
+END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
-
sub _version ($) {
my $s = shift || 0;
- $s =~ s/^(\d+)\.?//;
+ my $d =()= $s =~ /(\.)/g;
+ if ( $d >= 2 ) {
+ # Normalise multipart versions
+ $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
+ }
+ $s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
- my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
- $l = $l . '.' . join '', @v if @v;
+ my @v = map {
+ $_ . '0' x (3 - length $_)
+ } $s =~ /(\d{1,3})\D?/g;
+ $l = $l . '.' . join '', @v if @v;
return $l + 0;
}
+sub _cmp ($$) {
+ _version($_[0]) <=> _version($_[1]);
+}
+
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
@@ -360,10 +432,10 @@ sub _CLASS ($) {
and
! ref $_[0]
and
- $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
-# Copyright 2008 Adam Kennedy.
+# Copyright 2008 - 2010 Adam Kennedy.
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 433ebed..4224c4d 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -1,7 +1,11 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.77';
+use strict 'vars';
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '0.95';
+}
# Suspend handler for "redefined" warnings
BEGIN {
@@ -9,54 +13,56 @@ BEGIN {
$SIG{__WARN__} = sub { $w };
}
-### This is the ONLY module that shouldn't have strict on
-# use strict;
-
-#line 41
+#line 42
sub new {
- my ($class, %args) = @_;
-
- foreach my $method ( qw(call load) ) {
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- } unless defined &{"$class\::$method"};
- }
-
- bless( \%args, $class );
+ my $class = shift;
+ unless ( defined &{"${class}::call"} ) {
+ *{"${class}::call"} = sub { shift->_top->call(@_) };
+ }
+ unless ( defined &{"${class}::load"} ) {
+ *{"${class}::load"} = sub { shift->_top->load(@_) };
+ }
+ bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
- my $self = shift;
- local $@;
- my $autoload = eval { $self->_top->autoload } or return;
- goto &$autoload;
+ local $@;
+ my $func = eval { shift->_top->autoload } or return;
+ goto &$func;
}
-#line 76
+#line 75
-sub _top { $_[0]->{_top} }
+sub _top {
+ $_[0]->{_top};
+}
-#line 89
+#line 90
sub admin {
- $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+ $_[0]->_top->{admin}
+ or
+ Module::Install::Base::FakeAdmin->new;
}
-#line 101
+#line 106
sub is_admin {
- $_[0]->admin->VERSION;
+ $_[0]->admin->VERSION;
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
-my $Fake;
-sub new { $Fake ||= bless(\@_, $_[0]) }
+my $fake;
+
+sub new {
+ $fake ||= bless(\@_, $_[0]);
+}
sub AUTOLOAD {}
@@ -69,4 +75,4 @@ BEGIN {
1;
-#line 146
+#line 154
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 9025607..c9f91d1 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -2,18 +2,16 @@
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};
+use Config ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.77';
+ $VERSION = '0.95';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
# check if we can load some module
@@ -80,4 +78,4 @@ if ( $^O eq 'cygwin' ) {
__END__
-#line 158
+#line 156
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index d66aba5..c728bcd 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -2,24 +2,24 @@
package Module::Install::Fetch;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.77';
+ $VERSION = '0.95';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub get_file {
my ($self, %args) = @_;
- my ($scheme, $host, $path, $file) =
+ 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) =
+ ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 92cd1ef..431ec3f 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -2,14 +2,14 @@
package Module::Install::Makefile;
use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.77';
+ $VERSION = '0.95';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub Makefile { $_[0] }
@@ -25,8 +25,8 @@ sub prompt {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
- # In automated testing, always use defaults
- if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ # In automated testing or non-interactive session, always use defaults
+ if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
@@ -34,21 +34,110 @@ sub prompt {
}
}
+# Store a cleaned up version of the MakeMaker version,
+# since we need to behave differently in a variety of
+# ways based on the MM version.
+my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
+
+# If we are passed a param, do a "newer than" comparison.
+# Otherwise, just return the MakeMaker version.
+sub makemaker {
+ ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
+}
+
+# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
+# as we only need to know here whether the attribute is an array
+# or a hash or something else (which may or may not be appendable).
+my %makemaker_argtype = (
+ C => 'ARRAY',
+ CONFIG => 'ARRAY',
+# CONFIGURE => 'CODE', # ignore
+ DIR => 'ARRAY',
+ DL_FUNCS => 'HASH',
+ DL_VARS => 'ARRAY',
+ EXCLUDE_EXT => 'ARRAY',
+ EXE_FILES => 'ARRAY',
+ FUNCLIST => 'ARRAY',
+ H => 'ARRAY',
+ IMPORTS => 'HASH',
+ INCLUDE_EXT => 'ARRAY',
+ LIBS => 'ARRAY', # ignore ''
+ MAN1PODS => 'HASH',
+ MAN3PODS => 'HASH',
+ META_ADD => 'HASH',
+ META_MERGE => 'HASH',
+ PL_FILES => 'HASH',
+ PM => 'HASH',
+ PMLIBDIRS => 'ARRAY',
+ PMLIBPARENTDIRS => 'ARRAY',
+ PREREQ_PM => 'HASH',
+ CONFIGURE_REQUIRES => 'HASH',
+ SKIP => 'ARRAY',
+ TYPEMAPS => 'ARRAY',
+ XS => 'HASH',
+# VERSION => ['version',''], # ignore
+# _KEEP_AFTER_FLUSH => '',
+
+ clean => 'HASH',
+ depend => 'HASH',
+ dist => 'HASH',
+ dynamic_lib=> 'HASH',
+ linkext => 'HASH',
+ macro => 'HASH',
+ postamble => 'HASH',
+ realclean => 'HASH',
+ test => 'HASH',
+ tool_autosplit => 'HASH',
+
+ # special cases where you can use makemaker_append
+ CCFLAGS => 'APPENDABLE',
+ DEFINE => 'APPENDABLE',
+ INC => 'APPENDABLE',
+ LDDLFLAGS => 'APPENDABLE',
+ LDFROM => 'APPENDABLE',
+);
+
sub makemaker_args {
- my $self = shift;
+ my ($self, %new_args) = @_;
my $args = ( $self->{makemaker_args} ||= {} );
- %$args = ( %$args, @_ );
+ foreach my $key (keys %new_args) {
+ if ($makemaker_argtype{$key} eq 'ARRAY') {
+ $args->{$key} = [] unless defined $args->{$key};
+ unless (ref $args->{$key} eq 'ARRAY') {
+ $args->{$key} = [$args->{$key}]
+ }
+ push @{$args->{$key}},
+ ref $new_args{$key} eq 'ARRAY'
+ ? @{$new_args{$key}}
+ : $new_args{$key};
+ }
+ elsif ($makemaker_argtype{$key} eq 'HASH') {
+ $args->{$key} = {} unless defined $args->{$key};
+ foreach my $skey (keys %{ $new_args{$key} }) {
+ $args->{$key}{$skey} = $new_args{$key}{$skey};
+ }
+ }
+ elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
+ $self->makemaker_append($key => $new_args{$key});
+ }
+ else {
+ if (defined $args->{$key}) {
+ warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
+ }
+ $args->{$key} = $new_args{$key};
+ }
+ }
return $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
- my $self = sShift;
+ my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
- $args->{name} = defined $args->{$name}
- ? join( ' ', $args->{name}, @_ )
+ $args->{$name} = defined $args->{$name}
+ ? join( ' ', $args->{$name}, @_ )
: join( ' ', @_ );
}
@@ -64,7 +153,7 @@ sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
- %$clean,
+ %$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
@@ -73,7 +162,7 @@ sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
- %$realclean,
+ %$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
@@ -107,6 +196,9 @@ sub tests_recursive {
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
+ if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ File::Find::find( \&_wanted_t, 'xt' );
+ }
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
@@ -114,73 +206,133 @@ sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
- # Make sure we have a new enough
- require ExtUtils::MakeMaker;
+ # Check the current Perl version
+ my $perl_version = $self->perl_version;
+ if ( $perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+ }
- # 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.
+ # Make sure we have a new enough MakeMaker
+ require ExtUtils::MakeMaker;
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+ if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
+ # 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.
+ my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
+ $self->build_requires( 'ExtUtils::MakeMaker' => $v );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
+ } else {
+ # Allow legacy-compatibility with 5.005 by depending on the
+ # most recent EU:MM that supported 5.005.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ }
- # Generate the
+ # Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
- $args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
+ $args->{VERSION} = $self->version or die <<'EOT';
+ERROR: Can't determine distribution version. Please specify it
+explicitly via 'version' in Makefile.PL, or set a valid $VERSION
+in a module, and provide its file path via 'version_from' (or
+'all_from' if you prefer) in Makefile.PL.
+EOT
+
+ $DB::single = 1;
if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
+ my @tests = split ' ', $self->tests;
+ my %seen;
+ $args->{test} = {
+ TESTS => (join ' ', grep {!$seen{$_}++} @tests),
+ };
+ } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ $args->{test} = {
+ TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
+ };
}
- if ($] >= 5.005) {
+ if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = $self->author;
+ $args->{AUTHOR} = join ', ', @{$self->author || []};
}
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
+ if ( $self->makemaker(6.10) ) {
+ $args->{NO_META} = 1;
+ #$args->{NO_MYMETA} = 1;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
+ if ( $self->makemaker(6.31) and $self->license ) {
+ $args->{LICENSE} = $self->license;
+ }
- # merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
- map { @$_ }
+ map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
+ ($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
- # merge both kinds of requires into prereq_pm
+ # Merge both kinds of requires into BUILD_REQUIRES
+ my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
+ %$build_prereq = ( %$build_prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires)
+ );
+
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm
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};
+ delete $build_prereq->{$file}; #Delete from build prereqs only
}
}
+ unless ( $self->makemaker('6.55_03') ) {
+ %$prereq = (%$prereq,%$build_prereq);
+ delete $args->{BUILD_REQUIRES};
+ }
+
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
+
+ if ( $self->makemaker(6.48) ) {
+ $args->{MIN_PERL_VERSION} = $perl_version;
+ }
}
- $args->{INSTALLDIRS} = $self->installdirs;
+ if ($self->installdirs) {
+ warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
+ $args->{INSTALLDIRS} = $self->installdirs;
+ }
- my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+ my %args = map {
+ ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
+ } keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
- if (my $preop = $self->admin->preop($user_preop)) {
+ if ( my $preop = $self->admin->preop($user_preop) ) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
@@ -196,7 +348,7 @@ sub fix_up_makefile {
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
- my $preamble = $self->preamble
+ my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
@@ -250,4 +402,4 @@ sub postamble {
__END__
-#line 379
+#line 531
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 397fb97..162bde0 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -2,20 +2,23 @@
package Module::Install::Metadata;
use strict 'vars';
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.77';
+ $VERSION = '0.95';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
+my @boolean_keys = qw{
+ sign
+};
+
my @scalar_keys = qw{
name
module_name
abstract
- author
version
distribution_type
tests
@@ -37,16 +40,46 @@ my @resource_keys = qw{
repository
};
+my @array_keys = qw{
+ keywords
+ author
+};
+
+*authors = \&author;
+
sub Meta { shift }
+sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
+sub Meta_ArrayKeys { @array_keys }
+
+foreach my $key ( @boolean_keys ) {
+ *$key = sub {
+ my $self = shift;
+ if ( defined wantarray and not @_ ) {
+ return $self->{values}->{$key};
+ }
+ $self->{values}->{$key} = ( @_ ? $_[0] : 1 );
+ return $self;
+ };
+}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
- return $self->{values}{$key} if defined wantarray and !@_;
- $self->{values}{$key} = shift;
+ return $self->{values}->{$key} if defined wantarray and !@_;
+ $self->{values}->{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key ( @array_keys ) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}->{$key} if defined wantarray and !@_;
+ $self->{values}->{$key} ||= [];
+ push @{$self->{values}->{$key}}, @_;
return $self;
};
}
@@ -55,12 +88,12 @@ foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
- return () unless $self->{values}{resources};
+ return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
- @{ $self->{values}{resources} };
+ @{ $self->{values}->{resources} };
}
- return $self->{values}{resources}{$key} unless @_;
+ return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
@@ -69,54 +102,19 @@ foreach my $key ( @resource_keys ) {
};
}
-sub requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{requires} }, [ $module, $version ];
- }
- $self->{values}{requires};
-}
-
-sub build_requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{build_requires} }, [ $module, $version ];
- }
- $self->{values}{build_requires};
-}
-
-sub configure_requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{configure_requires} }, [ $module, $version ];
- }
- $self->{values}{configure_requires};
-}
-
-sub recommends {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{recommends} }, [ $module, $version ];
- }
- $self->{values}{recommends};
-}
-
-sub bundles {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{bundles} }, [ $module, $version ];
- }
- $self->{values}{bundles};
+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
@@ -135,29 +133,22 @@ sub resources {
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} ||= [];
+ push @{ $self->{values}->{resources} }, [ $name, $value ];
}
- $self->{values}{resources};
+ $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(@_) }
+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 install_as_core { $_[0]->installdirs('perl') }
+sub install_as_cpan { $_[0]->installdirs('site') }
+sub install_as_site { $_[0]->installdirs('site') }
+sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
@@ -165,42 +156,60 @@ sub dynamic_config {
warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
- $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
+ $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
return 1;
}
sub perl_version {
my $self = shift;
- return $self->{values}{perl_version} unless @_;
+ return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
- # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
- # numbers (eg, 5.006001 or 5.008009).
-
- $version =~ s/^(\d+)\.(\d+)\.(\d+)$/sprintf("%d.%03d%03d",$1,$2,$3)/e;
+ # Normalize the version
+ $version = $self->_perl_version($version);
- $version =~ s/_.+$//;
- $version = $version + 0; # Numify
+ # 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;
- return 1;
+
+ $self->{values}->{perl_version} = $version;
}
+#Stolen from M::B
+my %license_urls = (
+ perl => 'http://dev.perl.org/licenses/',
+ apache => 'http://apache.org/licenses/LICENSE-2.0',
+ artistic => 'http://opensource.org/licenses/artistic-license.php',
+ artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ lgpl => 'http://opensource.org/licenses/lgpl-license.php',
+ lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
+ lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
+ bsd => 'http://opensource.org/licenses/bsd-license.php',
+ gpl => 'http://opensource.org/licenses/gpl-license.php',
+ gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
+ gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
+ mit => 'http://opensource.org/licenses/mit-license.php',
+ mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
+ open_source => undef,
+ unrestricted => undef,
+ restrictive => undef,
+ unknown => undef,
+);
+
sub license {
my $self = shift;
- return $self->{values}{license} unless @_;
+ return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
- $self->{values}{license} = $license;
+ $self->{values}->{license} = $license;
# Automatically fill in license URLs
- if ( $license eq 'perl' ) {
- $self->resources( license => 'http://dev.perl.org/licenses/' );
+ if ( $license_urls{$license} ) {
+ $self->resources( license => $license_urls{$license} );
}
return 1;
@@ -223,6 +232,8 @@ sub all_from {
die("The path '$file' does not exist, or is not a file");
}
+ $self->{values}{all_from} = $file;
+
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
@@ -233,7 +244,7 @@ sub all_from {
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
- $self->author_from($pod) unless $self->author;
+ $self->author_from($pod) unless @{$self->author || []};
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
@@ -242,7 +253,7 @@ sub all_from {
sub provides {
my $self = shift;
- my $provides = ( $self->{values}{provides} ||= {} );
+ my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
@@ -271,7 +282,7 @@ sub auto_provides {
sub feature {
my $self = shift;
my $name = shift;
- my $features = ( $self->{values}{features} ||= [] );
+ my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
@@ -299,16 +310,16 @@ sub features {
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
- return $self->{values}{features}
- ? @{ $self->{values}{features} }
+ 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};
+ push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
+ return $self->{values}->{no_index};
}
sub read {
@@ -378,11 +389,10 @@ sub name_from {
}
}
-sub perl_version_from {
- my $self = shift;
+sub _extract_perl_version {
if (
- Module::Install::_read($_[0]) =~ m/
- ^
+ $_[0] =~ m/
+ ^\s*
(?:use|require) \s*
v?
([\d_\.]+)
@@ -391,6 +401,16 @@ sub perl_version_from {
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
+ return $perl_version;
+ } else {
+ return;
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
+ if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
@@ -410,70 +430,132 @@ sub author_from {
([^\n]*)
/ixms) {
my $author = $1 || $2;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
+
+ # XXX: ugly but should work anyway...
+ if (eval "require Pod::Escapes; 1") {
+ # Pod::Escapes has a mapping table.
+ # It's in core of perl >= 5.9.3, and should be installed
+ # as one of the Pod::Simple's prereqs, which is a prereq
+ # of Pod::Text 3.x (see also below).
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $Pod::Escapes::Name2character_number{$1}
+ ? chr($Pod::Escapes::Name2character_number{$1})
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
+ # Pod::Text < 3.0 has yet another mapping table,
+ # though the table name of 2.x and 1.x are different.
+ # (1.x is in core of Perl < 5.6, 2.x is in core of
+ # Perl < 5.9.3)
+ my $mapping = ($Pod::Text::VERSION < 2)
+ ? \%Pod::Text::HTML_Escapes
+ : \%Pod::Text::ESCAPES;
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $mapping->{$1}
+ ? $mapping->{$1}
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ else {
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ }
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
+sub _extract_license {
+ my $pod = shift;
+ my $matched;
+ return __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ (?:licen[cs]e|licensing)\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /ixms
+ ) || __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ (?:copyrights?|legal)\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /ixms
+ );
+}
+
+sub __extract_license {
+ my $license_text = shift or return;
+ my @phrases = (
+ 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
+ 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'Artistic and GPL' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ '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+#gs;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ return $license;
+ }
+ }
+}
+
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 ) {
- if ( $osi and $license_text =~ /All rights reserved/i ) {
- print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
- }
- $self->license($license);
- return 1;
- }
- }
+ if (my $license=_extract_license(Module::Install::_read($_[0]))) {
+ $self->license($license);
+ } else {
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
}
+}
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
+sub _extract_bugtracker {
+ my @links = $_[0] =~ m#L<(
+ \Qhttp://rt.cpan.org/\E[^>]+|
+ \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
+ \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ )>#gx;
+ my %links;
+ @links{@links}=();
+ @links=keys %links;
+ return @links;
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
- my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
+ my @links = _extract_bugtracker($content);
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";
+ warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
@@ -482,19 +564,131 @@ sub bugtracker_from {
return 1;
}
-sub install_script {
+sub requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->requires( $module => $version );
+ }
+}
+
+sub test_requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->test_requires( $module => $version );
+ }
+}
+
+# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
+# numbers (eg, 5.006001 or 5.008009).
+# Also, convert double-part versions (eg, 5.8)
+sub _perl_version {
+ my $v = $_[-1];
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
+ $v =~ s/(\.\d\d\d)000$/$1/;
+ $v =~ s/_.+$//;
+ if ( ref($v) ) {
+ # Numify
+ $v = $v + 0;
+ }
+ return $v;
+}
+
+
+
+
+
+######################################################################
+# MYMETA Support
+
+sub WriteMyMeta {
+ die "WriteMyMeta has been deprecated";
+}
+
+sub write_mymeta_yaml {
my $self = shift;
- my $args = $self->makemaker_args;
- my $exe = $args->{EXE_FILES} ||= [];
- foreach ( @_ ) {
- if ( -f $_ ) {
- push @$exe, $_;
- } elsif ( -d 'script' and -f "script/$_" ) {
- push @$exe, "script/$_";
- } else {
- die("Cannot find script '$_'");
+
+ # We need YAML::Tiny to write the MYMETA.yml file
+ unless ( eval { require YAML::Tiny; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.yml\n";
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+}
+
+sub write_mymeta_json {
+ my $self = shift;
+
+ # We need JSON to write the MYMETA.json file
+ unless ( eval { require JSON; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.json\n";
+ Module::Install::_write(
+ 'MYMETA.json',
+ JSON->new->pretty(1)->canonical->encode($meta),
+ );
+}
+
+sub _write_mymeta_data {
+ my $self = shift;
+
+ # If there's no existing META.yml there is nothing we can do
+ return undef unless -f 'META.yml';
+
+ # We need Parse::CPAN::Meta to load the file
+ unless ( eval { require Parse::CPAN::Meta; 1; } ) {
+ return undef;
+ }
+
+ # Merge the perl version into the dependencies
+ my $val = $self->Meta->{values};
+ my $perl = delete $val->{perl_version};
+ if ( $perl ) {
+ $val->{requires} ||= [];
+ my $requires = $val->{requires};
+
+ # Canonize to three-dot version after Perl 5.6
+ if ( $perl >= 5.006 ) {
+ $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
+ unshift @$requires, [ perl => $perl ];
+ }
+
+ # Load the advisory META.yml file
+ my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
+ my $meta = $yaml[0];
+
+ # Overwrite the non-configure dependency hashs
+ delete $meta->{requires};
+ delete $meta->{build_requires};
+ delete $meta->{recommends};
+ if ( exists $val->{requires} ) {
+ $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
}
+ if ( exists $val->{build_requires} ) {
+ $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
+ }
+
+ return $meta;
}
1;
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 7f69cd5..5480124 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -8,7 +8,7 @@ no warnings 'once';
use Module::Install::Base;
use base 'Module::Install::Base';
-our $VERSION = '0.23';
+our $VERSION = '0.25';
use FindBin;
use File::Glob ();
@@ -50,7 +50,8 @@ sub RTx {
until ( eval { require RT; $RT::LocalPath } ) {
warn
"Cannot find the location of RT.pm that defines \$RT::LocalPath in: @INC\n";
- $_ = $self->prompt("Path to your RT.pm:") or exit;
+ $_ = $self->prompt("Path to directory containing your RT.pm:") or exit;
+ $_ =~ s/\/RT\.pm$//;
push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
}
}
@@ -81,6 +82,8 @@ sub RTx {
# directories
my %path;
if ( $RT::LocalPluginPath ) {
+ die "Because of bugs in RT 3.8.0 this extension can not be installed.\n"
+ ."Upgrade to RT 3.8.1 or newer.\n" if $RT::VERSION =~ /^3\.8\.0/;
$path{$_} = $RT::LocalPluginPath . "/$original_name/$_"
foreach @DIRS;
} else {
@@ -186,4 +189,4 @@ sub RTxInit {
__END__
-#line 282
+#line 303
diff --git a/inc/Module/Install/ReadmeFromPod.pm b/inc/Module/Install/ReadmeFromPod.pm
new file mode 100644
index 0000000..41222fa
--- /dev/null
+++ b/inc/Module/Install/ReadmeFromPod.pm
@@ -0,0 +1,36 @@
+#line 1
+package Module::Install::ReadmeFromPod;
+
+use strict;
+use warnings;
+use base qw(Module::Install::Base);
+use vars qw($VERSION);
+
+$VERSION = '0.06';
+
+sub readme_from {
+ my $self = shift;
+ return unless $Module::Install::AUTHOR;
+ my $file = shift || return;
+ my $clean = shift;
+ require Pod::Text;
+ my $parser = Pod::Text->new();
+ open README, '> README' or die "$!\n";
+ $parser->output_fh( *README );
+ $parser->parse_file( $file );
+ return 1 unless $clean;
+ $self->postamble(<<"END");
+distclean :: license_clean
+
+license_clean:
+\t\$(RM_F) README
+END
+ return 1;
+}
+
+'Readme!';
+
+__END__
+
+#line 89
+
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index cff76a2..f55e166 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -2,12 +2,12 @@
package Module::Install::Win32;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.77';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '0.95';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index f35620f..6b3bba7 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -2,11 +2,11 @@
package Module::Install::WriteAll;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.77';
+ $VERSION = '0.95';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -22,19 +22,42 @@ sub WriteAll {
);
$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 => {} );
+ # XXX: This still may be a bit over-defensive...
+ unless ($self->makemaker(6.25)) {
+ $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
+ }
}
+ # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
+ # we clean it up properly ourself.
+ $self->realclean_files('MYMETA.yml');
+
if ( $args{inline} ) {
$self->Inline->write;
} else {
$self->Makefile->write;
}
+
+ # The Makefile write process adds a couple of dependencies,
+ # so write the META.yml files after the Makefile.
+ if ( $args{meta} ) {
+ $self->Meta->write;
+ }
+
+ # Experimental support for MYMETA
+ if ( $ENV{X_MYMETA} ) {
+ if ( $ENV{X_MYMETA} eq 'JSON' ) {
+ $self->Meta->write_mymeta_json;
+ } else {
+ $self->Meta->write_mymeta_yaml;
+ }
+ }
+
+ return 1;
}
1;
commit d89d57dd8cc891669c4154b938bb72573b8fa776
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Mar 30 01:03:13 2010 +0400
gitignore
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..5597ece
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,5 @@
+Makefile
+Makefile.old
+MANIFEST.bak
+pm_to_blib
+blib/
commit c7c89c7f052efc5a0c90e712c4bd077436272b16
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue Mar 30 01:06:44 2010 +0400
changelog
diff --git a/CHANGES b/CHANGES
new file mode 100644
index 0000000..8a208a2
--- /dev/null
+++ b/CHANGES
@@ -0,0 +1,10 @@
+0.02 2010-03-30
+
+ * better configuration
+ * better fonts handling
+ * more docs
+
+0.01 2008-12-05
+
+ * initial release
+
diff --git a/MANIFEST b/MANIFEST
index 7546d11..0c4a47a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,3 +1,4 @@
+CHANGES
etc/Captcha_Config.pm
html/Callbacks/RT-Extension-Captcha/index.html/Initial
html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/BeforeCreate
@@ -13,6 +14,7 @@ inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
+inc/Module/Install/ReadmeFromPod.pm
inc/Module/Install/RTx.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list