#line 1 "inc/Module/Install/Metadata.pm - /usr/local/lib/perl5/site_perl/5.8.7/Module/Install/Metadata.pm"
package Module::Install::Metadata;
use Module::Install::Base;
@ISA = qw(Module::Install::Base);
$VERSION = '0.04';
use strict 'vars';
use vars qw($VERSION);
sub Meta { shift }
my @scalar_keys = qw<
name module_name version abstract author license
distribution_type perl_version tests
>;
my @tuple_keys = qw<
build_requires requires recommends bundles
>;
foreach my $key (@scalar_keys) {
*$key = sub {
my $self = shift;
return $self->{'values'}{$key} unless @_;
$self->{'values'}{$key} = shift;
return $self;
};
}
sub sign {
my $self = shift;
$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
return $self;
}
foreach my $key (@tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{'values'}{$key} unless @_;
my @rv;
while (@_) {
my $module = shift or last;
my $version = shift || 0;
if ( $module eq 'perl' ) {
$version =~ s{^(\d+)\.(\d+)\.(\d+)}
{$1 + $2/1_000 + $3/1_000_000}e;
$self->perl_version($version);
next;
}
my $rv = [ $module, $version ];
push @rv, $rv;
}
push @{ $self->{'values'}{$key} }, @rv;
@rv;
};
}
sub all_from {
my ( $self, $file ) = @_;
$self->version_from($file);
$self->perl_version_from($file);
# The remaining probes read from POD sections; if the file
# has an accompanying .pod, use that instead
my $pod = $file;
if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
$file = $pod;
}
$self->abstract_from($file);
$self->license_from($file);
}
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'} };
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{'values'}{'no_index'}{$type} }, @_ if $type;
return $self->{'values'}{'no_index'};
}
sub _dump {
my $self = shift;
my $package = ref( $self->_top );
my $version = $self->_top->VERSION;
my %values = %{ $self->{'values'} };
delete $values{sign};
if ( my $perl_version = delete $values{perl_version} ) {
# Always canonical to three-dot version
$perl_version =~
s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e
if $perl_version >= 5.006;
$values{requires} =
[ [ perl => $perl_version ], @{ $values{requires} || [] }, ];
}
warn "No license specified, setting license = 'unknown'\n"
unless $values{license};
$values{license} ||= 'unknown';
$values{distribution_type} ||= 'module';
$values{name} ||= do {
my $name = $values{module_name};
$name =~ s/::/-/g;
$name;
} if $values{module_name};
if ( $values{name} =~ /::/ ) {
my $name = $values{name};
$name =~ s/::/-/g;
die "Error in name(): '$values{name}' should be '$name'!\n";
}
my $dump = '';
foreach my $key (@scalar_keys) {
$dump .= "$key: $values{$key}\n" if exists $values{$key};
}
foreach my $key (@tuple_keys) {
next unless exists $values{$key};
$dump .= "$key:\n";
foreach ( @{ $values{$key} } ) {
$dump .= " $_->[0]: $_->[1]\n";
}
}
if ( my $no_index = $values{no_index} ) {
push @{ $no_index->{'directory'} }, 'inc';
require YAML;
local $YAML::UseHeader = 0;
$dump .= YAML::Dump( { no_index => $no_index } );
}
else {
$dump .= << "META";
no_index:
directory:
- inc
META
}
$dump .= "generated_by: $package version $version\n";
return $dump;
}
sub read {
my $self = shift;
$self->include_deps( 'YAML', 0 );
require YAML;
my $data = YAML::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;
META_NOT_OURS: {
local *FH;
if ( open FH, "META.yml" ) {
while (<FH>) {
last META_NOT_OURS if /^generated_by: Module::Install\b/;
}
return $self if -s FH;
}
}
print "Writing META.yml\n";
local *META;
open META, "> META.yml" or warn "Cannot write to META.yml: $!";
print META $self->_dump;
close META;
return $self;
}
sub version_from {
my ( $self, $file ) = @_;
require ExtUtils::MM_Unix;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
my ( $self, $file ) = @_;
require ExtUtils::MM_Unix;
$self->abstract(
bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )
->parse_abstract($file) );
}
sub _slurp {
my ( $self, $file ) = @_;
local *FH;
open FH, "< $file" or die "Cannot open $file.pod: $!";
do { local $/; <FH> };
}
sub perl_version_from {
my ( $self, $file ) = @_;
if (
$self->_slurp($file) =~ m/
^
use \s*
v?
([\d\.]+)
\s* ;
/ixms
)
{
$self->perl_version($1);
}
else {
warn "Cannot determine perl version info from $file\n";
return;
}
}
sub license_from {
my ( $self, $file ) = @_;
if (
$self->_slurp($file) =~ 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',
'GNU public license' => 'gpl',
'GNU lesser public license' => 'gpl',
'BSD license' => 'bsd',
'Artistic license' => 'artistic',
'GPL' => 'gpl',
'LGPL' => 'lgpl',
'BSD' => 'bsd',
'Artistic' => 'artistic',
);
while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
$pattern =~ s{\s+}{\\s+}g;
if ( $license_text =~ /\b$pattern\b/i ) {
$self->license($license);
return 1;
}
}
}
warn "Cannot determine license info from $file\n";
return 'unknown';
}
1;