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.68';
  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 # configure_requires is currently a null-op
  60 sub configure_requires { 1 }
  61
  62 # Aliases for build_requires that will have alternative
  63 # meanings in some future version of META.yml.
  64 sub test_requires      { shift->build_requires(@_)  }
  65 sub install_requires   { shift->build_requires(@_)  }
  66
  67 # Aliases for installdirs options
  68 sub install_as_core    { $_[0]->installdirs('perl')   }
  69 sub install_as_cpan    { $_[0]->installdirs('site')   }
  70 sub install_as_site    { $_[0]->installdirs('site')   }
  71 sub install_as_vendor  { $_[0]->installdirs('vendor') }
  72
  73 sub sign {
  74     my $self = shift;
  75     return $self->{'values'}{'sign'} if defined wantarray and ! @_;
  76     $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
  77     return $self;
  78 }
  79
  80 sub dynamic_config {
  81         my $self = shift;
  82         unless ( @_ ) {
  83                 warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
  84                 return $self;
  85         }
  86         $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
  87         return $self;
  88 }
  89
  90 sub all_from {
  91     my ( $self, $file ) = @_;
  92
  93     unless ( defined($file) ) {
  94         my $name = $self->name
  95             or die "all_from called with no args without setting name() first";
  96         $file = join('/', 'lib', split(/-/, $name)) . '.pm';
  97         $file =~ s{.*/}{} unless -e $file;
  98         die "all_from: cannot find $file from $name" unless -e $file;
  99     }
 100
 101     $self->version_from($file)      unless $self->version;
 102     $self->perl_version_from($file) unless $self->perl_version;
 103
 104     # The remaining probes read from POD sections; if the file
 105     # has an accompanying .pod, use that instead
 106     my $pod = $file;
 107     if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
 108         $file = $pod;
 109     }
 110
 111     $self->author_from($file)   unless $self->author;
 112     $self->license_from($file)  unless $self->license;
 113     $self->abstract_from($file) unless $self->abstract;
 114 }
 115
 116 sub provides {
 117     my $self     = shift;
 118     my $provides = ( $self->{values}{provides} ||= {} );
 119     %$provides = (%$provides, @_) if @_;
 120     return $provides;
 121 }
 122
 123 sub auto_provides {
 124     my $self = shift;
 125     return $self unless $self->is_admin;
 126
 127     unless (-e 'MANIFEST') {
 128         warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
 129         return $self;
 130     }
 131
 132     # Avoid spurious warnings as we are not checking manifest here.
 133
 134     local $SIG{__WARN__} = sub {1};
 135     require ExtUtils::Manifest;
 136     local *ExtUtils::Manifest::manicheck = sub { return };
 137
 138     require Module::Build;
 139     my $build = Module::Build->new(
 140         dist_name    => $self->name,
 141         dist_version => $self->version,
 142         license      => $self->license,
 143     );
 144     $self->provides(%{ $build->find_dist_packages || {} });
 145 }
 146
 147 sub feature {
 148     my $self     = shift;
 149     my $name     = shift;
 150     my $features = ( $self->{values}{features} ||= [] );
 151
 152     my $mods;
 153
 154     if ( @_ == 1 and ref( $_[0] ) ) {
 155         # The user used ->feature like ->features by passing in the second
 156         # argument as a reference.  Accomodate for that.
 157         $mods = $_[0];
 158     } else {
 159         $mods = \@_;
 160     }
 161
 162     my $count = 0;
 163     push @$features, (
 164         $name => [
 165             map {
 166                 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
 167                                                 : @$_
 168                         : $_
 169             } @$mods
 170         ]
 171     );
 172
 173     return @$features;
 174 }
 175
 176 sub features {
 177     my $self = shift;
 178     while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
 179         $self->feature( $name, @$mods );
 180     }
 181     return $self->{values}->{features}
 182         ? @{ $self->{values}->{features} }
 183         : ();
 184 }
 185
 186 sub no_index {
 187     my $self = shift;
 188     my $type = shift;
 189     push @{ $self->{values}{no_index}{$type} }, @_ if $type;
 190     return $self->{values}{no_index};
 191 }
 192
 193 sub read {
 194     my $self = shift;
 195     $self->include_deps( 'YAML', 0 );
 196
 197     require YAML;
 198     my $data = YAML::LoadFile('META.yml');
 199
 200     # Call methods explicitly in case user has already set some values.
 201     while ( my ( $key, $value ) = each %$data ) {
 202         next unless $self->can($key);
 203         if ( ref $value eq 'HASH' ) {
 204             while ( my ( $module, $version ) = each %$value ) {
 205                 $self->can($key)->($self, $module => $version );
 206             }
 207         }
 208         else {
 209             $self->can($key)->($self, $value);
 210         }
 211     }
 212     return $self;
 213 }
 214
 215 sub write {
 216     my $self = shift;
 217     return $self unless $self->is_admin;
 218     $self->admin->write_meta;
 219     return $self;
 220 }
 221
 222 sub version_from {
 223     my ( $self, $file ) = @_;
 224     require ExtUtils::MM_Unix;
 225     $self->version( ExtUtils::MM_Unix->parse_version($file) );
 226 }
 227
 228 sub abstract_from {
 229     my ( $self, $file ) = @_;
 230     require ExtUtils::MM_Unix;
 231     $self->abstract(
 232         bless(
 233             { DISTNAME => $self->name },
 234             'ExtUtils::MM_Unix'
 235         )->parse_abstract($file)
 236      );
 237 }
 238
 239 sub _slurp {
 240     my ( $self, $file ) = @_;
 241
 242     local *FH;
 243     open FH, "< $file" or die "Cannot open $file.pod: $!";
 244     do { local $/; <FH> };
 245 }
 246
 247 sub perl_version_from {
 248     my ( $self, $file ) = @_;
 249
 250     if (
 251         $self->_slurp($file) =~ m/
 252         ^
 253         use \s*
 254         v?
 255         ([\d_\.]+)
 256         \s* ;
 257     /ixms
 258       )
 259     {
 260         my $v = $1;
 261         $v =~ s{_}{}g;
 262         $self->perl_version($1);
 263     }
 264     else {
 265         warn "Cannot determine perl version info from $file\n";
 266         return;
 267     }
 268 }
 269
 270 sub author_from {
 271     my ( $self, $file ) = @_;
 272     my $content = $self->_slurp($file);
 273     if ($content =~ m/
 274         =head \d \s+ (?:authors?)\b \s*
 275         ([^\n]*)
 276         |
 277         =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
 278         .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
 279         ([^\n]*)
 280     /ixms) {
 281         my $author = $1 || $2;
 282         $author =~ s{E<lt>}{<}g;
 283         $author =~ s{E<gt>}{>}g;
 284         $self->author($author);
 285     }
 286     else {
 287         warn "Cannot determine author info from $file\n";
 288     }
 289 }
 290
 291 sub license_from {
 292     my ( $self, $file ) = @_;
 293
 294     if (
 295         $self->_slurp($file) =~ m/
 296         (
 297             =head \d \s+
 298             (?:licen[cs]e|licensing|copyright|legal)\b
 299             .*?
 300         )
 301         (=head\\d.*|=cut.*|)
 302         \z
 303     /ixms
 304       )
 305     {
 306         my $license_text = $1;
 307         my @phrases      = (
 308             'under the same (?:terms|license) as perl itself' => 'perl',        1,
 309             'GNU public license'                              => 'gpl',         1,
 310             'GNU lesser public license'                       => 'gpl',         1,
 311             'BSD license'                                     => 'bsd',         1,
 312             'Artistic license'                                => 'artistic',    1,
 313             'GPL'                                             => 'gpl',         1,
 314             'LGPL'                                            => 'lgpl',        1,
 315             'BSD'                                             => 'bsd',         1,
 316             'Artistic'                                        => 'artistic',    1,
 317             'MIT'                                             => 'mit',         1,
 318             'proprietary'                                     => 'proprietary', 0,
 319         );
 320         while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
 321             $pattern =~ s{\s+}{\\s+}g;
 322             if ( $license_text =~ /\b$pattern\b/i ) {
 323                 if ( $osi and $license_text =~ /All rights reserved/i ) {
 324                         warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
 325                 }
 326                 $self->license($license);
 327                 return 1;
 328             }
 329         }
 330     }
 331
 332     warn "Cannot determine license info from $file\n";
 333     return 'unknown';
 334 }
 335
 336 1;