inc/Module/Install/Metadata.pm

   1 #line 1
   2 package Module::Install::Metadata;
   3
   4 use strict 'vars';
   5 use Module::Install::Base;
   6
   7 use vars qw{$VERSION $ISCORE @ISA};
   8 BEGIN {
   9         $VERSION = '0.65';
  10         $ISCORE  = 1;
  11         @ISA     = qw{Module::Install::Base};
  12 }
  13
  14 my @scalar_keys = qw{
  15     name module_name abstract author version license
  16     distribution_type perl_version tests installdirs
  17 };
  18
  19 my @tuple_keys = qw{
  20     build_requires requires recommends bundles
  21 };
  22
  23 sub Meta            { shift        }
  24 sub Meta_ScalarKeys { @scalar_keys }
  25 sub Meta_TupleKeys  { @tuple_keys  }
  26
  27 foreach my $key (@scalar_keys) {
  28     *$key = sub {
  29         my $self = shift;
  30         return $self->{values}{$key} if defined wantarray and !@_;
  31         $self->{values}{$key} = shift;
  32         return $self;
  33     };
  34 }
  35
  36 foreach my $key (@tuple_keys) {
  37     *$key = sub {
  38         my $self = shift;
  39         return $self->{values}{$key} unless @_;
  40
  41         my @rv;
  42         while (@_) {
  43             my $module = shift or last;
  44             my $version = shift || 0;
  45             if ( $module eq 'perl' ) {
  46                 $version =~ s{^(\d+)\.(\d+)\.(\d+)}
  47                              {$1 + $2/1_000 + $3/1_000_000}e;
  48                 $self->perl_version($version);
  49                 next;
  50             }
  51             my $rv = [ $module, $version ];
  52             push @rv, $rv;
  53         }
  54         push @{ $self->{values}{$key} }, @rv;
  55         @rv;
  56     };
  57 }
  58
  59 sub install_as_core   { $_[0]->installdirs('perl')   }
  60 sub install_as_cpan   { $_[0]->installdirs('site')   }
  61 sub install_as_site   { $_[0]->installdirs('site')   }
  62 sub install_as_vendor { $_[0]->installdirs('vendor') }
  63
  64 sub sign {
  65     my $self = shift;
  66     return $self->{'values'}{'sign'} if defined wantarray and !@_;
  67     $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
  68     return $self;
  69 }
  70
  71 sub dynamic_config {
  72         my $self = shift;
  73         unless ( @_ ) {
  74                 warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
  75                 return $self;
  76         }
  77         $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
  78         return $self;
  79 }
  80
  81 sub all_from {
  82     my ( $self, $file ) = @_;
  83
  84     unless ( defined($file) ) {
  85         my $name = $self->name
  86             or die "all_from called with no args without setting name() first";
  87         $file = join('/', 'lib', split(/-/, $name)) . '.pm';
  88         $file =~ s{.*/}{} unless -e $file;
  89         die "all_from: cannot find $file from $name" unless -e $file;
  90     }
  91
  92     $self->version_from($file)      unless $self->version;
  93     $self->perl_version_from($file) unless $self->perl_version;
  94
  95     # The remaining probes read from POD sections; if the file
  96     # has an accompanying .pod, use that instead
  97     my $pod = $file;
  98     if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
  99         $file = $pod;
 100     }
 101
 102     $self->author_from($file)   unless $self->author;
 103     $self->license_from($file)  unless $self->license;
 104     $self->abstract_from($file) unless $self->abstract;
 105 }
 106
 107 sub provides {
 108     my $self     = shift;
 109     my $provides = ( $self->{values}{provides} ||= {} );
 110     %$provides = (%$provides, @_) if @_;
 111     return $provides;
 112 }
 113
 114 sub auto_provides {
 115     my $self = shift;
 116     return $self unless $self->is_admin;
 117
 118     unless (-e 'MANIFEST') {
 119         warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
 120         return $self;
 121     }
 122
 123     # Avoid spurious warnings as we are not checking manifest here.
 124
 125     local $SIG{__WARN__} = sub {1};
 126     require ExtUtils::Manifest;
 127     local *ExtUtils::Manifest::manicheck = sub { return };
 128
 129     require Module::Build;
 130     my $build = Module::Build->new(
 131         dist_name    => $self->name,
 132         dist_version => $self->version,
 133         license      => $self->license,
 134     );
 135     $self->provides(%{ $build->find_dist_packages || {} });
 136 }
 137
 138 sub feature {
 139     my $self     = shift;
 140     my $name     = shift;
 141     my $features = ( $self->{values}{features} ||= [] );
 142
 143     my $mods;
 144
 145     if ( @_ == 1 and ref( $_[0] ) ) {
 146         # The user used ->feature like ->features by passing in the second
 147         # argument as a reference.  Accomodate for that.
 148         $mods = $_[0];
 149     } else {
 150         $mods = \@_;
 151     }
 152
 153     my $count = 0;
 154     push @$features, (
 155         $name => [
 156             map {
 157                 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
 158                                                 : @$_
 159                         : $_
 160             } @$mods
 161         ]
 162     );
 163
 164     return @$features;
 165 }
 166
 167 sub features {
 168     my $self = shift;
 169     while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
 170         $self->feature( $name, @$mods );
 171     }
 172     return $self->{values}->{features}
 173         ? @{ $self->{values}->{features} }
 174         : ();
 175 }
 176
 177 sub no_index {
 178     my $self = shift;
 179     my $type = shift;
 180     push @{ $self->{values}{no_index}{$type} }, @_ if $type;
 181     return $self->{values}{no_index};
 182 }
 183
 184 sub read {
 185     my $self = shift;
 186     $self->include_deps( 'YAML', 0 );
 187
 188     require YAML;
 189     my $data = YAML::LoadFile('META.yml');
 190
 191     # Call methods explicitly in case user has already set some values.
 192     while ( my ( $key, $value ) = each %$data ) {
 193         next unless $self->can($key);
 194         if ( ref $value eq 'HASH' ) {
 195             while ( my ( $module, $version ) = each %$value ) {
 196                 $self->can($key)->($self, $module => $version );
 197             }
 198         }
 199         else {
 200             $self->can($key)->($self, $value);
 201         }
 202     }
 203     return $self;
 204 }
 205
 206 sub write {
 207     my $self = shift;
 208     return $self unless $self->is_admin;
 209     $self->admin->write_meta;
 210     return $self;
 211 }
 212
 213 sub version_from {
 214     my ( $self, $file ) = @_;
 215     require ExtUtils::MM_Unix;
 216     $self->version( ExtUtils::MM_Unix->parse_version($file) );
 217 }
 218
 219 sub abstract_from {
 220     my ( $self, $file ) = @_;
 221     require ExtUtils::MM_Unix;
 222     $self->abstract(
 223         bless(
 224             { DISTNAME => $self->name },
 225             'ExtUtils::MM_Unix'
 226         )->parse_abstract($file)
 227      );
 228 }
 229
 230 sub _slurp {
 231     my ( $self, $file ) = @_;
 232
 233     local *FH;
 234     open FH, "< $file" or die "Cannot open $file.pod: $!";
 235     do { local $/; <FH> };
 236 }
 237
 238 sub perl_version_from {
 239     my ( $self, $file ) = @_;
 240
 241     if (
 242         $self->_slurp($file) =~ m/
 243         ^
 244         use \s*
 245         v?
 246         ([\d_\.]+)
 247         \s* ;
 248     /ixms
 249       )
 250     {
 251         my $v = $1;
 252         $v =~ s{_}{}g;
 253         $self->perl_version($1);
 254     }
 255     else {
 256         warn "Cannot determine perl version info from $file\n";
 257         return;
 258     }
 259 }
 260
 261 sub author_from {
 262     my ( $self, $file ) = @_;
 263     my $content = $self->_slurp($file);
 264     if ($content =~ m/
 265         =head \d \s+ (?:authors?)\b \s*
 266         ([^\n]*)
 267         |
 268         =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
 269         .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
 270         ([^\n]*)
 271     /ixms) {
 272         my $author = $1 || $2;
 273         $author =~ s{E<lt>}{<}g;
 274         $author =~ s{E<gt>}{>}g;
 275         $self->author($author);
 276     }
 277     else {
 278         warn "Cannot determine author info from $file\n";
 279     }
 280 }
 281
 282 sub license_from {
 283     my ( $self, $file ) = @_;
 284
 285     if (
 286         $self->_slurp($file) =~ m/
 287         (
 288             =head \d \s+
 289             (?:licen[cs]e|licensing|copyright|legal)\b
 290             .*?
 291         )
 292         (=head\\d.*|=cut.*|)
 293         \z
 294     /ixms
 295       )
 296     {
 297         my $license_text = $1;
 298         my @phrases      = (
 299             'under the same (?:terms|license) as perl itself' => 'perl',
 300             'GNU public license'                              => 'gpl',
 301             'GNU lesser public license'                       => 'gpl',
 302             'BSD license'                                     => 'bsd',
 303             'Artistic license'                                => 'artistic',
 304             'GPL'                                             => 'gpl',
 305             'LGPL'                                            => 'lgpl',
 306             'BSD'                                             => 'bsd',
 307             'Artistic'                                        => 'artistic',
 308             'MIT'                                             => 'MIT',
 309         );
 310         while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
 311             $pattern =~ s{\s+}{\\s+}g;
 312             if ( $license_text =~ /\b$pattern\b/i ) {
 313                 $self->license($license);
 314                 return 1;
 315             }
 316         }
 317     }
 318
 319     warn "Cannot determine license info from $file\n";
 320     return 'unknown';
 321 }
 322
 323 1;