inc/Module/Install/Metadata.pm

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