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