1#line 1 2package Module::Install::Metadata; 3 4use strict 'vars'; 5use Module::Install::Base (); 6 7use vars qw{$VERSION @ISA $ISCORE}; 8BEGIN { 9 $VERSION = '0.95'; 10 @ISA = 'Module::Install::Base'; 11 $ISCORE = 1; 12} 13 14my @boolean_keys = qw{ 15 sign 16}; 17 18my @scalar_keys = qw{ 19 name 20 module_name 21 abstract 22 version 23 distribution_type 24 tests 25 installdirs 26}; 27 28my @tuple_keys = qw{ 29 configure_requires 30 build_requires 31 requires 32 recommends 33 bundles 34 resources 35}; 36 37my @resource_keys = qw{ 38 homepage 39 bugtracker 40 repository 41}; 42 43my @array_keys = qw{ 44 keywords 45 author 46}; 47 48*authors = \&author; 49 50sub Meta { shift } 51sub Meta_BooleanKeys { @boolean_keys } 52sub Meta_ScalarKeys { @scalar_keys } 53sub Meta_TupleKeys { @tuple_keys } 54sub Meta_ResourceKeys { @resource_keys } 55sub Meta_ArrayKeys { @array_keys } 56 57foreach my $key ( @boolean_keys ) { 58 *$key = sub { 59 my $self = shift; 60 if ( defined wantarray and not @_ ) { 61 return $self->{values}->{$key}; 62 } 63 $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); 64 return $self; 65 }; 66} 67 68foreach my $key ( @scalar_keys ) { 69 *$key = sub { 70 my $self = shift; 71 return $self->{values}->{$key} if defined wantarray and !@_; 72 $self->{values}->{$key} = shift; 73 return $self; 74 }; 75} 76 77foreach my $key ( @array_keys ) { 78 *$key = sub { 79 my $self = shift; 80 return $self->{values}->{$key} if defined wantarray and !@_; 81 $self->{values}->{$key} ||= []; 82 push @{$self->{values}->{$key}}, @_; 83 return $self; 84 }; 85} 86 87foreach my $key ( @resource_keys ) { 88 *$key = sub { 89 my $self = shift; 90 unless ( @_ ) { 91 return () unless $self->{values}->{resources}; 92 return map { $_->[1] } 93 grep { $_->[0] eq $key } 94 @{ $self->{values}->{resources} }; 95 } 96 return $self->{values}->{resources}->{$key} unless @_; 97 my $uri = shift or die( 98 "Did not provide a value to $key()" 99 ); 100 $self->resources( $key => $uri ); 101 return 1; 102 }; 103} 104 105foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { 106 *$key = sub { 107 my $self = shift; 108 return $self->{values}->{$key} unless @_; 109 my @added; 110 while ( @_ ) { 111 my $module = shift or last; 112 my $version = shift || 0; 113 push @added, [ $module, $version ]; 114 } 115 push @{ $self->{values}->{$key} }, @added; 116 return map {@$_} @added; 117 }; 118} 119 120# Resource handling 121my %lc_resource = map { $_ => 1 } qw{ 122 homepage 123 license 124 bugtracker 125 repository 126}; 127 128sub resources { 129 my $self = shift; 130 while ( @_ ) { 131 my $name = shift or last; 132 my $value = shift or next; 133 if ( $name eq lc $name and ! $lc_resource{$name} ) { 134 die("Unsupported reserved lowercase resource '$name'"); 135 } 136 $self->{values}->{resources} ||= []; 137 push @{ $self->{values}->{resources} }, [ $name, $value ]; 138 } 139 $self->{values}->{resources}; 140} 141 142# Aliases for build_requires that will have alternative 143# meanings in some future version of META.yml. 144sub test_requires { shift->build_requires(@_) } 145sub install_requires { shift->build_requires(@_) } 146 147# Aliases for installdirs options 148sub install_as_core { $_[0]->installdirs('perl') } 149sub install_as_cpan { $_[0]->installdirs('site') } 150sub install_as_site { $_[0]->installdirs('site') } 151sub install_as_vendor { $_[0]->installdirs('vendor') } 152 153sub dynamic_config { 154 my $self = shift; 155 unless ( @_ ) { 156 warn "You MUST provide an explicit true/false value to dynamic_config\n"; 157 return $self; 158 } 159 $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; 160 return 1; 161} 162 163sub perl_version { 164 my $self = shift; 165 return $self->{values}->{perl_version} unless @_; 166 my $version = shift or die( 167 "Did not provide a value to perl_version()" 168 ); 169 170 # Normalize the version 171 $version = $self->_perl_version($version); 172 173 # We don't support the reall old versions 174 unless ( $version >= 5.005 ) { 175 die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; 176 } 177 178 $self->{values}->{perl_version} = $version; 179} 180 181#Stolen from M::B 182my %license_urls = ( 183 perl => 'http://dev.perl.org/licenses/', 184 apache => 'http://apache.org/licenses/LICENSE-2.0', 185 artistic => 'http://opensource.org/licenses/artistic-license.php', 186 artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', 187 lgpl => 'http://opensource.org/licenses/lgpl-license.php', 188 lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', 189 lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', 190 bsd => 'http://opensource.org/licenses/bsd-license.php', 191 gpl => 'http://opensource.org/licenses/gpl-license.php', 192 gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', 193 gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', 194 mit => 'http://opensource.org/licenses/mit-license.php', 195 mozilla => 'http://opensource.org/licenses/mozilla1.1.php', 196 open_source => undef, 197 unrestricted => undef, 198 restrictive => undef, 199 unknown => undef, 200); 201 202sub license { 203 my $self = shift; 204 return $self->{values}->{license} unless @_; 205 my $license = shift or die( 206 'Did not provide a value to license()' 207 ); 208 $self->{values}->{license} = $license; 209 210 # Automatically fill in license URLs 211 if ( $license_urls{$license} ) { 212 $self->resources( license => $license_urls{$license} ); 213 } 214 215 return 1; 216} 217 218sub all_from { 219 my ( $self, $file ) = @_; 220 221 unless ( defined($file) ) { 222 my $name = $self->name or die( 223 "all_from called with no args without setting name() first" 224 ); 225 $file = join('/', 'lib', split(/-/, $name)) . '.pm'; 226 $file =~ s{.*/}{} unless -e $file; 227 unless ( -e $file ) { 228 die("all_from cannot find $file from $name"); 229 } 230 } 231 unless ( -f $file ) { 232 die("The path '$file' does not exist, or is not a file"); 233 } 234 235 $self->{values}{all_from} = $file; 236 237 # Some methods pull from POD instead of code. 238 # If there is a matching .pod, use that instead 239 my $pod = $file; 240 $pod =~ s/\.pm$/.pod/i; 241 $pod = $file unless -e $pod; 242 243 # Pull the different values 244 $self->name_from($file) unless $self->name; 245 $self->version_from($file) unless $self->version; 246 $self->perl_version_from($file) unless $self->perl_version; 247 $self->author_from($pod) unless @{$self->author || []}; 248 $self->license_from($pod) unless $self->license; 249 $self->abstract_from($pod) unless $self->abstract; 250 251 return 1; 252} 253 254sub provides { 255 my $self = shift; 256 my $provides = ( $self->{values}->{provides} ||= {} ); 257 %$provides = (%$provides, @_) if @_; 258 return $provides; 259} 260 261sub auto_provides { 262 my $self = shift; 263 return $self unless $self->is_admin; 264 unless (-e 'MANIFEST') { 265 warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; 266 return $self; 267 } 268 # Avoid spurious warnings as we are not checking manifest here. 269 local $SIG{__WARN__} = sub {1}; 270 require ExtUtils::Manifest; 271 local *ExtUtils::Manifest::manicheck = sub { return }; 272 273 require Module::Build; 274 my $build = Module::Build->new( 275 dist_name => $self->name, 276 dist_version => $self->version, 277 license => $self->license, 278 ); 279 $self->provides( %{ $build->find_dist_packages || {} } ); 280} 281 282sub feature { 283 my $self = shift; 284 my $name = shift; 285 my $features = ( $self->{values}->{features} ||= [] ); 286 my $mods; 287 288 if ( @_ == 1 and ref( $_[0] ) ) { 289 # The user used ->feature like ->features by passing in the second 290 # argument as a reference. Accomodate for that. 291 $mods = $_[0]; 292 } else { 293 $mods = \@_; 294 } 295 296 my $count = 0; 297 push @$features, ( 298 $name => [ 299 map { 300 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ 301 } @$mods 302 ] 303 ); 304 305 return @$features; 306} 307 308sub features { 309 my $self = shift; 310 while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { 311 $self->feature( $name, @$mods ); 312 } 313 return $self->{values}->{features} 314 ? @{ $self->{values}->{features} } 315 : (); 316} 317 318sub no_index { 319 my $self = shift; 320 my $type = shift; 321 push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; 322 return $self->{values}->{no_index}; 323} 324 325sub read { 326 my $self = shift; 327 $self->include_deps( 'YAML::Tiny', 0 ); 328 329 require YAML::Tiny; 330 my $data = YAML::Tiny::LoadFile('META.yml'); 331 332 # Call methods explicitly in case user has already set some values. 333 while ( my ( $key, $value ) = each %$data ) { 334 next unless $self->can($key); 335 if ( ref $value eq 'HASH' ) { 336 while ( my ( $module, $version ) = each %$value ) { 337 $self->can($key)->($self, $module => $version ); 338 } 339 } else { 340 $self->can($key)->($self, $value); 341 } 342 } 343 return $self; 344} 345 346sub write { 347 my $self = shift; 348 return $self unless $self->is_admin; 349 $self->admin->write_meta; 350 return $self; 351} 352 353sub version_from { 354 require ExtUtils::MM_Unix; 355 my ( $self, $file ) = @_; 356 $self->version( ExtUtils::MM_Unix->parse_version($file) ); 357} 358 359sub abstract_from { 360 require ExtUtils::MM_Unix; 361 my ( $self, $file ) = @_; 362 $self->abstract( 363 bless( 364 { DISTNAME => $self->name }, 365 'ExtUtils::MM_Unix' 366 )->parse_abstract($file) 367 ); 368} 369 370# Add both distribution and module name 371sub name_from { 372 my ($self, $file) = @_; 373 if ( 374 Module::Install::_read($file) =~ m/ 375 ^ \s* 376 package \s* 377 ([\w:]+) 378 \s* ; 379 /ixms 380 ) { 381 my ($name, $module_name) = ($1, $1); 382 $name =~ s{::}{-}g; 383 $self->name($name); 384 unless ( $self->module_name ) { 385 $self->module_name($module_name); 386 } 387 } else { 388 die("Cannot determine name from $file\n"); 389 } 390} 391 392sub _extract_perl_version { 393 if ( 394 $_[0] =~ m/ 395 ^\s* 396 (?:use|require) \s* 397 v? 398 ([\d_\.]+) 399 \s* ; 400 /ixms 401 ) { 402 my $perl_version = $1; 403 $perl_version =~ s{_}{}g; 404 return $perl_version; 405 } else { 406 return; 407 } 408} 409 410sub perl_version_from { 411 my $self = shift; 412 my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); 413 if ($perl_version) { 414 $self->perl_version($perl_version); 415 } else { 416 warn "Cannot determine perl version info from $_[0]\n"; 417 return; 418 } 419} 420 421sub author_from { 422 my $self = shift; 423 my $content = Module::Install::_read($_[0]); 424 if ($content =~ m/ 425 =head \d \s+ (?:authors?)\b \s* 426 ([^\n]*) 427 | 428 =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* 429 .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* 430 ([^\n]*) 431 /ixms) { 432 my $author = $1 || $2; 433 434 # XXX: ugly but should work anyway... 435 if (eval "require Pod::Escapes; 1") { 436 # Pod::Escapes has a mapping table. 437 # It's in core of perl >= 5.9.3, and should be installed 438 # as one of the Pod::Simple's prereqs, which is a prereq 439 # of Pod::Text 3.x (see also below). 440 $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } 441 { 442 defined $2 443 ? chr($2) 444 : defined $Pod::Escapes::Name2character_number{$1} 445 ? chr($Pod::Escapes::Name2character_number{$1}) 446 : do { 447 warn "Unknown escape: E<$1>"; 448 "E<$1>"; 449 }; 450 }gex; 451 } 452 elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { 453 # Pod::Text < 3.0 has yet another mapping table, 454 # though the table name of 2.x and 1.x are different. 455 # (1.x is in core of Perl < 5.6, 2.x is in core of 456 # Perl < 5.9.3) 457 my $mapping = ($Pod::Text::VERSION < 2) 458 ? \%Pod::Text::HTML_Escapes 459 : \%Pod::Text::ESCAPES; 460 $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } 461 { 462 defined $2 463 ? chr($2) 464 : defined $mapping->{$1} 465 ? $mapping->{$1} 466 : do { 467 warn "Unknown escape: E<$1>"; 468 "E<$1>"; 469 }; 470 }gex; 471 } 472 else { 473 $author =~ s{E<lt>}{<}g; 474 $author =~ s{E<gt>}{>}g; 475 } 476 $self->author($author); 477 } else { 478 warn "Cannot determine author info from $_[0]\n"; 479 } 480} 481 482sub _extract_license { 483 my $pod = shift; 484 my $matched; 485 return __extract_license( 486 ($matched) = $pod =~ m/ 487 (=head \d \s+ (?:licen[cs]e|licensing)\b.*?) 488 (=head \d.*|=cut.*|)\z 489 /ixms 490 ) || __extract_license( 491 ($matched) = $pod =~ m/ 492 (=head \d \s+ (?:copyrights?|legal)\b.*?) 493 (=head \d.*|=cut.*|)\z 494 /ixms 495 ); 496} 497 498sub __extract_license { 499 my $license_text = shift or return; 500 my @phrases = ( 501 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1, 502 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 503 'Artistic and GPL' => 'perl', 1, 504 'GNU general public license' => 'gpl', 1, 505 'GNU public license' => 'gpl', 1, 506 'GNU lesser general public license' => 'lgpl', 1, 507 'GNU lesser public license' => 'lgpl', 1, 508 'GNU library general public license' => 'lgpl', 1, 509 'GNU library public license' => 'lgpl', 1, 510 'BSD license' => 'bsd', 1, 511 'Artistic license' => 'artistic', 1, 512 'GPL' => 'gpl', 1, 513 'LGPL' => 'lgpl', 1, 514 'BSD' => 'bsd', 1, 515 'Artistic' => 'artistic', 1, 516 'MIT' => 'mit', 1, 517 'proprietary' => 'proprietary', 0, 518 ); 519 while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { 520 $pattern =~ s#\s+#\\s+#gs; 521 if ( $license_text =~ /\b$pattern\b/i ) { 522 return $license; 523 } 524 } 525} 526 527sub license_from { 528 my $self = shift; 529 if (my $license=_extract_license(Module::Install::_read($_[0]))) { 530 $self->license($license); 531 } else { 532 warn "Cannot determine license info from $_[0]\n"; 533 return 'unknown'; 534 } 535} 536 537sub _extract_bugtracker { 538 my @links = $_[0] =~ m#L<( 539 \Qhttp://rt.cpan.org/\E[^>]+| 540 \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| 541 \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list 542 )>#gx; 543 my %links; 544 @links{@links}=(); 545 @links=keys %links; 546 return @links; 547} 548 549sub bugtracker_from { 550 my $self = shift; 551 my $content = Module::Install::_read($_[0]); 552 my @links = _extract_bugtracker($content); 553 unless ( @links ) { 554 warn "Cannot determine bugtracker info from $_[0]\n"; 555 return 0; 556 } 557 if ( @links > 1 ) { 558 warn "Found more than one bugtracker link in $_[0]\n"; 559 return 0; 560 } 561 562 # Set the bugtracker 563 bugtracker( $links[0] ); 564 return 1; 565} 566 567sub requires_from { 568 my $self = shift; 569 my $content = Module::Install::_readperl($_[0]); 570 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 571 while ( @requires ) { 572 my $module = shift @requires; 573 my $version = shift @requires; 574 $self->requires( $module => $version ); 575 } 576} 577 578sub test_requires_from { 579 my $self = shift; 580 my $content = Module::Install::_readperl($_[0]); 581 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 582 while ( @requires ) { 583 my $module = shift @requires; 584 my $version = shift @requires; 585 $self->test_requires( $module => $version ); 586 } 587} 588 589# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to 590# numbers (eg, 5.006001 or 5.008009). 591# Also, convert double-part versions (eg, 5.8) 592sub _perl_version { 593 my $v = $_[-1]; 594 $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; 595 $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; 596 $v =~ s/(\.\d\d\d)000$/$1/; 597 $v =~ s/_.+$//; 598 if ( ref($v) ) { 599 # Numify 600 $v = $v + 0; 601 } 602 return $v; 603} 604 605 606 607 608 609###################################################################### 610# MYMETA Support 611 612sub WriteMyMeta { 613 die "WriteMyMeta has been deprecated"; 614} 615 616sub write_mymeta_yaml { 617 my $self = shift; 618 619 # We need YAML::Tiny to write the MYMETA.yml file 620 unless ( eval { require YAML::Tiny; 1; } ) { 621 return 1; 622 } 623 624 # Generate the data 625 my $meta = $self->_write_mymeta_data or return 1; 626 627 # Save as the MYMETA.yml file 628 print "Writing MYMETA.yml\n"; 629 YAML::Tiny::DumpFile('MYMETA.yml', $meta); 630} 631 632sub write_mymeta_json { 633 my $self = shift; 634 635 # We need JSON to write the MYMETA.json file 636 unless ( eval { require JSON; 1; } ) { 637 return 1; 638 } 639 640 # Generate the data 641 my $meta = $self->_write_mymeta_data or return 1; 642 643 # Save as the MYMETA.yml file 644 print "Writing MYMETA.json\n"; 645 Module::Install::_write( 646 'MYMETA.json', 647 JSON->new->pretty(1)->canonical->encode($meta), 648 ); 649} 650 651sub _write_mymeta_data { 652 my $self = shift; 653 654 # If there's no existing META.yml there is nothing we can do 655 return undef unless -f 'META.yml'; 656 657 # We need Parse::CPAN::Meta to load the file 658 unless ( eval { require Parse::CPAN::Meta; 1; } ) { 659 return undef; 660 } 661 662 # Merge the perl version into the dependencies 663 my $val = $self->Meta->{values}; 664 my $perl = delete $val->{perl_version}; 665 if ( $perl ) { 666 $val->{requires} ||= []; 667 my $requires = $val->{requires}; 668 669 # Canonize to three-dot version after Perl 5.6 670 if ( $perl >= 5.006 ) { 671 $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e 672 } 673 unshift @$requires, [ perl => $perl ]; 674 } 675 676 # Load the advisory META.yml file 677 my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); 678 my $meta = $yaml[0]; 679 680 # Overwrite the non-configure dependency hashs 681 delete $meta->{requires}; 682 delete $meta->{build_requires}; 683 delete $meta->{recommends}; 684 if ( exists $val->{requires} ) { 685 $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; 686 } 687 if ( exists $val->{build_requires} ) { 688 $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; 689 } 690 691 return $meta; 692} 693 6941; 695