X-Git-Url: http://git.home-dn.net/?p=manu%2FRT-Extension-SearchResults-XLS.git;a=blobdiff_plain;f=inc%2FModule%2FInstall%2FMetadata.pm;h=cfe45b3f0ab72dc6679a369cadecc4c08dd51874;hp=7acf8fd76141a26bd8e3da7f05260c354478db5d;hb=47c2ccb6812acb71dff5fbca2e8f272ab395f8d1;hpb=2df927d640cb12b4e1e7597dd641d710c38c5953 diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm index 7acf8fd..cfe45b3 100644 --- a/inc/Module/Install/Metadata.pm +++ b/inc/Module/Install/Metadata.pm @@ -1,24 +1,26 @@ +#line 1 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.72'; + $VERSION = '1.00'; + @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 - license distribution_type - perl_version tests installdirs }; @@ -29,110 +31,172 @@ my @tuple_keys = qw{ requires recommends bundles + resources +}; + +my @resource_keys = qw{ + homepage + bugtracker + repository }; -sub Meta { shift } -sub Meta_ScalarKeys { @scalar_keys } -sub Meta_TupleKeys { @tuple_keys } +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 (@scalar_keys) { +foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; - return $self->{values}{$key} if defined wantarray and !@_; - $self->{values}{$key} = shift; + if ( defined wantarray and not @_ ) { + return $self->{values}->{$key}; + } + $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } -sub requires { - my $self = shift; - while ( @_ ) { - my $module = shift or last; - my $version = shift || 0; - push @{ $self->{values}->{requires} }, [ $module, $version ]; - } - $self->{values}{requires}; +foreach my $key ( @scalar_keys ) { + *$key = sub { + my $self = shift; + return $self->{values}->{$key} if defined wantarray and !@_; + $self->{values}->{$key} = shift; + return $self; + }; } -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}; +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; + }; } -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}; +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; + }; } -sub recommends { - my $self = shift; - while ( @_ ) { - my $module = shift or last; - my $version = shift || 0; - push @{ $self->{values}->{recommends} }, [ $module, $version ]; - } - $self->{values}{recommends}; +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; + }; } -sub bundles { +# Resource handling +my %lc_resource = map { $_ => 1 } qw{ + homepage + license + bugtracker + repository +}; + +sub resources { my $self = shift; while ( @_ ) { - my $module = shift or last; - my $version = shift || 0; - push @{ $self->{values}->{bundles} }, [ $module, $version ]; + 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}{bundles}; + $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; unless ( @_ ) { - warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; + warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } - $self->{values}{dynamic_config} = $_[0] ? 1 : 0; - 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 all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { - my $name = $self->name - or die "all_from called with no args without setting name() first"; + 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; - die "all_from: cannot find $file from $name" unless -e $file; + unless ( -e $file ) { + die("all_from cannot find $file from $name"); + } + } + unless ( -f $file ) { + die("The path '$file' does not exist, or is not a file"); } + $self->{values}{all_from} = $file; + # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; @@ -143,7 +207,7 @@ sub all_from { $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; - $self->author_from($pod) unless $self->author; + $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; @@ -152,7 +216,7 @@ sub all_from { sub provides { my $self = shift; - my $provides = ( $self->{values}{provides} ||= {} ); + my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } @@ -181,7 +245,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] ) ) { @@ -217,8 +281,8 @@ sub 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 { @@ -253,6 +317,9 @@ sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); + + # for version integrity check + $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { @@ -263,34 +330,36 @@ sub abstract_from { { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) - ); + ); } +# Add both distribution and module name sub name_from { - my $self = shift; + my ($self, $file) = @_; if ( - Module::Install::_read($_[0]) =~ m/ + Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { - my $name = $1; + 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 $_[0]\n"; - return; + die("Cannot determine name from $file\n"); } } -sub perl_version_from { - my $self = shift; +sub _extract_perl_version { if ( - Module::Install::_read($_[0]) =~ m/ - ^ - use \s* + $_[0] =~ m/ + ^\s* + (?:use|require) \s* v? ([\d_\.]+) \s* ; @@ -298,6 +367,16 @@ sub perl_version_from { ) { my $perl_version = $1; $perl_version =~ s{_}{}g; + return $perl_version; + } else { + return; + } +} + +sub perl_version_from { + my $self = shift; + my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); + if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; @@ -317,69 +396,320 @@ sub author_from { ([^\n]*) /ixms) { my $author = $1 || $2; - $author =~ s{E}{<}g; - $author =~ s{E}{>}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}{<}g; + $author =~ s{E}{>}g; + } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } -sub license_from { +#Stolen from M::B +my %license_urls = ( + perl => 'http://dev.perl.org/licenses/', + apache => 'http://apache.org/licenses/LICENSE-2.0', + apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', + artistic => 'http://opensource.org/licenses/artistic-license.php', + artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', + lgpl => 'http://opensource.org/licenses/lgpl-license.php', + lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', + lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', + bsd => 'http://opensource.org/licenses/bsd-license.php', + gpl => 'http://opensource.org/licenses/gpl-license.php', + gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', + gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', + mit => 'http://opensource.org/licenses/mit-license.php', + mozilla => 'http://opensource.org/licenses/mozilla1.1.php', + open_source => undef, + unrestricted => undef, + restrictive => undef, + unknown => undef, +); + +sub license { my $self = shift; - if ( - Module::Install::_read($_[0]) =~ m/ - ( - =head \d \s+ - (?:licen[cs]e|licensing|copyright|legal)\b - .*? - ) - (=head\\d.*|=cut.*|) - \z - /ixms ) { - my $license_text = $1; - my @phrases = ( - 'under the same (?:terms|license) as perl itself' => 'perl', 1, - 'GNU public license' => 'gpl', 1, - 'GNU lesser 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 ) { - warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it."; - } - $self->license($license); - return 1; - } + return $self->{values}->{license} unless @_; + my $license = shift or die( + 'Did not provide a value to license()' + ); + $license = __extract_license($license) || lc $license; + $self->{values}->{license} = $license; + + # Automatically fill in license URLs + if ( $license_urls{$license} ) { + $self->resources( license => $license_urls{$license} ); + } + + return 1; +} + +sub _extract_license { + my $pod = shift; + my $matched; + return __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) + (=head \d.*|=cut.*|)\z + /xms + ) || __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) + (=head \d.*|=cut.*|)\z + /xms + ); +} + +sub __extract_license { + my $license_text = shift or return; + my @phrases = ( + '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, + '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, + 'Artistic and GPL' => 'perl', 1, + 'GNU general public license' => 'gpl', 1, + 'GNU public license' => 'gpl', 1, + 'GNU lesser general public license' => 'lgpl', 1, + 'GNU lesser public license' => 'lgpl', 1, + 'GNU library general public license' => 'lgpl', 1, + 'GNU library public license' => 'lgpl', 1, + 'GNU Free Documentation license' => 'unrestricted', 1, + 'GNU Affero General Public License' => 'open_source', 1, + '(?:Free)?BSD license' => 'bsd', 1, + 'Artistic license' => 'artistic', 1, + 'Apache (?:Software )?license' => 'apache', 1, + 'GPL' => 'gpl', 1, + 'LGPL' => 'lgpl', 1, + 'BSD' => 'bsd', 1, + 'Artistic' => 'artistic', 1, + 'MIT' => 'mit', 1, + 'Mozilla Public License' => 'mozilla', 1, + 'Q Public License' => 'open_source', 1, + 'OpenSSL License' => 'unrestricted', 1, + 'SSLeay License' => 'unrestricted', 1, + 'zlib License' => 'open_source', 1, + 'proprietary' => 'proprietary', 0, + ); + while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { + $pattern =~ s#\s+#\\s+#gs; + if ( $license_text =~ /\b$pattern\b/i ) { + return $license; } } + return ''; +} + +sub license_from { + my $self = shift; + if (my $license=_extract_license(Module::Install::_read($_[0]))) { + $self->license($license); + } else { + warn "Cannot determine license info from $_[0]\n"; + return 'unknown'; + } +} + +sub _extract_bugtracker { + my @links = $_[0] =~ m#L<( + \Qhttp://rt.cpan.org/\E[^>]+| + \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 = _extract_bugtracker($content); + unless ( @links ) { + warn "Cannot determine bugtracker info from $_[0]\n"; + return 0; + } + if ( @links > 1 ) { + warn "Found more than one bugtracker link in $_[0]\n"; + return 0; + } + + # Set the bugtracker + bugtracker( $links[0] ); + return 1; +} + +sub requires_from { + my $self = shift; + my $content = Module::Install::_readperl($_[0]); + my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\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 ); + } +} - warn "Cannot determine license info from $_[0]\n"; - return 'unknown'; +# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to +# numbers (eg, 5.006001 or 5.008009). +# Also, convert double-part versions (eg, 5.8) +sub _perl_version { + my $v = $_[-1]; + $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; + $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; + $v =~ s/(\.\d\d\d)000$/$1/; + $v =~ s/_.+$//; + if ( ref($v) ) { + # Numify + $v = $v + 0; + } + return $v; +} + +sub add_metadata { + my $self = shift; + my %hash = @_; + for my $key (keys %hash) { + warn "add_metadata: $key is not prefixed with 'x_'.\n" . + "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; + $self->{values}->{$key} = $hash{$key}; + } } -sub install_script { + +###################################################################### +# 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;