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.71'; 10 $ISCORE = 1; 11 @ISA = qw{Module::Install::Base}; 12} 13 14my @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 27my @tuple_keys = qw{ 28 configure_requires 29 build_requires 30 requires 31 recommends 32 bundles 33}; 34 35sub Meta { shift } 36sub Meta_ScalarKeys { @scalar_keys } 37sub Meta_TupleKeys { @tuple_keys } 38 39foreach 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 48sub 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 58sub 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 68sub 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 78sub 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 88sub 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. 100sub test_requires { shift->build_requires(@_) } 101sub install_requires { shift->build_requires(@_) } 102 103# Aliases for installdirs options 104sub install_as_core { $_[0]->installdirs('perl') } 105sub install_as_cpan { $_[0]->installdirs('site') } 106sub install_as_site { $_[0]->installdirs('site') } 107sub install_as_vendor { $_[0]->installdirs('vendor') } 108 109sub 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 116sub 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 126sub 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 154sub provides { 155 my $self = shift; 156 my $provides = ( $self->{values}{provides} ||= {} ); 157 %$provides = (%$provides, @_) if @_; 158 return $provides; 159} 160 161sub 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 182sub 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 208sub 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 218sub 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 225sub 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 246sub write { 247 my $self = shift; 248 return $self unless $self->is_admin; 249 $self->admin->write_meta; 250 return $self; 251} 252 253sub version_from { 254 require ExtUtils::MM_Unix; 255 my ( $self, $file ) = @_; 256 $self->version( ExtUtils::MM_Unix->parse_version($file) ); 257} 258 259sub 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 270sub 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 289sub 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 309sub 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 329sub 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 3711; 372