1#line 1 2package Module::Install::Metadata; 3 4use strict 'vars'; 5use Module::Install::Base; 6 7use vars qw{$VERSION $ISCORE @ISA}; 8BEGIN { 9 $VERSION = '0.68'; 10 $ISCORE = 1; 11 @ISA = qw{Module::Install::Base}; 12} 13 14my @scalar_keys = qw{ 15 name module_name abstract author version license 16 distribution_type perl_version tests installdirs 17}; 18 19my @tuple_keys = qw{ 20 build_requires requires recommends bundles 21}; 22 23sub Meta { shift } 24sub Meta_ScalarKeys { @scalar_keys } 25sub Meta_TupleKeys { @tuple_keys } 26 27foreach 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 36foreach 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 60sub configure_requires { 1 } 61 62# Aliases for build_requires that will have alternative 63# meanings in some future version of META.yml. 64sub test_requires { shift->build_requires(@_) } 65sub install_requires { shift->build_requires(@_) } 66 67# Aliases for installdirs options 68sub install_as_core { $_[0]->installdirs('perl') } 69sub install_as_cpan { $_[0]->installdirs('site') } 70sub install_as_site { $_[0]->installdirs('site') } 71sub install_as_vendor { $_[0]->installdirs('vendor') } 72 73sub 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 80sub 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 90sub 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 116sub provides { 117 my $self = shift; 118 my $provides = ( $self->{values}{provides} ||= {} ); 119 %$provides = (%$provides, @_) if @_; 120 return $provides; 121} 122 123sub 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 147sub 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 176sub 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 186sub 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 193sub 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 215sub write { 216 my $self = shift; 217 return $self unless $self->is_admin; 218 $self->admin->write_meta; 219 return $self; 220} 221 222sub version_from { 223 my ( $self, $file ) = @_; 224 require ExtUtils::MM_Unix; 225 $self->version( ExtUtils::MM_Unix->parse_version($file) ); 226} 227 228sub 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 239sub _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 247sub 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 270sub 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 291sub 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 3361; 337