inc/Module/Install/Metadata.pm

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