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