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 = '1.01'; 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 181sub all_from { 182 my ( $self, $file ) = @_; 183 184 unless ( defined($file) ) { 185 my $name = $self->name or die( 186 "all_from called with no args without setting name() first" 187 ); 188 $file = join('/', 'lib', split(/-/, $name)) . '.pm'; 189 $file =~ s{.*/}{} unless -e $file; 190 unless ( -e $file ) { 191 die("all_from cannot find $file from $name"); 192 } 193 } 194 unless ( -f $file ) { 195 die("The path '$file' does not exist, or is not a file"); 196 } 197 198 $self->{values}{all_from} = $file; 199 200 # Some methods pull from POD instead of code. 201 # If there is a matching .pod, use that instead 202 my $pod = $file; 203 $pod =~ s/\.pm$/.pod/i; 204 $pod = $file unless -e $pod; 205 206 # Pull the different values 207 $self->name_from($file) unless $self->name; 208 $self->version_from($file) unless $self->version; 209 $self->perl_version_from($file) unless $self->perl_version; 210 $self->author_from($pod) unless @{$self->author || []}; 211 $self->license_from($pod) unless $self->license; 212 $self->abstract_from($pod) unless $self->abstract; 213 214 return 1; 215} 216 217sub provides { 218 my $self = shift; 219 my $provides = ( $self->{values}->{provides} ||= {} ); 220 %$provides = (%$provides, @_) if @_; 221 return $provides; 222} 223 224sub auto_provides { 225 my $self = shift; 226 return $self unless $self->is_admin; 227 unless (-e 'MANIFEST') { 228 warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; 229 return $self; 230 } 231 # Avoid spurious warnings as we are not checking manifest here. 232 local $SIG{__WARN__} = sub {1}; 233 require ExtUtils::Manifest; 234 local *ExtUtils::Manifest::manicheck = sub { return }; 235 236 require Module::Build; 237 my $build = Module::Build->new( 238 dist_name => $self->name, 239 dist_version => $self->version, 240 license => $self->license, 241 ); 242 $self->provides( %{ $build->find_dist_packages || {} } ); 243} 244 245sub feature { 246 my $self = shift; 247 my $name = shift; 248 my $features = ( $self->{values}->{features} ||= [] ); 249 my $mods; 250 251 if ( @_ == 1 and ref( $_[0] ) ) { 252 # The user used ->feature like ->features by passing in the second 253 # argument as a reference. Accomodate for that. 254 $mods = $_[0]; 255 } else { 256 $mods = \@_; 257 } 258 259 my $count = 0; 260 push @$features, ( 261 $name => [ 262 map { 263 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ 264 } @$mods 265 ] 266 ); 267 268 return @$features; 269} 270 271sub features { 272 my $self = shift; 273 while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { 274 $self->feature( $name, @$mods ); 275 } 276 return $self->{values}->{features} 277 ? @{ $self->{values}->{features} } 278 : (); 279} 280 281sub no_index { 282 my $self = shift; 283 my $type = shift; 284 push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; 285 return $self->{values}->{no_index}; 286} 287 288sub read { 289 my $self = shift; 290 $self->include_deps( 'YAML::Tiny', 0 ); 291 292 require YAML::Tiny; 293 my $data = YAML::Tiny::LoadFile('META.yml'); 294 295 # Call methods explicitly in case user has already set some values. 296 while ( my ( $key, $value ) = each %$data ) { 297 next unless $self->can($key); 298 if ( ref $value eq 'HASH' ) { 299 while ( my ( $module, $version ) = each %$value ) { 300 $self->can($key)->($self, $module => $version ); 301 } 302 } else { 303 $self->can($key)->($self, $value); 304 } 305 } 306 return $self; 307} 308 309sub write { 310 my $self = shift; 311 return $self unless $self->is_admin; 312 $self->admin->write_meta; 313 return $self; 314} 315 316sub version_from { 317 require ExtUtils::MM_Unix; 318 my ( $self, $file ) = @_; 319 $self->version( ExtUtils::MM_Unix->parse_version($file) ); 320 321 # for version integrity check 322 $self->makemaker_args( VERSION_FROM => $file ); 323} 324 325sub abstract_from { 326 require ExtUtils::MM_Unix; 327 my ( $self, $file ) = @_; 328 $self->abstract( 329 bless( 330 { DISTNAME => $self->name }, 331 'ExtUtils::MM_Unix' 332 )->parse_abstract($file) 333 ); 334} 335 336# Add both distribution and module name 337sub name_from { 338 my ($self, $file) = @_; 339 if ( 340 Module::Install::_read($file) =~ m/ 341 ^ \s* 342 package \s* 343 ([\w:]+) 344 \s* ; 345 /ixms 346 ) { 347 my ($name, $module_name) = ($1, $1); 348 $name =~ s{::}{-}g; 349 $self->name($name); 350 unless ( $self->module_name ) { 351 $self->module_name($module_name); 352 } 353 } else { 354 die("Cannot determine name from $file\n"); 355 } 356} 357 358sub _extract_perl_version { 359 if ( 360 $_[0] =~ m/ 361 ^\s* 362 (?:use|require) \s* 363 v? 364 ([\d_\.]+) 365 \s* ; 366 /ixms 367 ) { 368 my $perl_version = $1; 369 $perl_version =~ s{_}{}g; 370 return $perl_version; 371 } else { 372 return; 373 } 374} 375 376sub perl_version_from { 377 my $self = shift; 378 my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); 379 if ($perl_version) { 380 $self->perl_version($perl_version); 381 } else { 382 warn "Cannot determine perl version info from $_[0]\n"; 383 return; 384 } 385} 386 387sub author_from { 388 my $self = shift; 389 my $content = Module::Install::_read($_[0]); 390 if ($content =~ m/ 391 =head \d \s+ (?:authors?)\b \s* 392 ([^\n]*) 393 | 394 =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* 395 .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* 396 ([^\n]*) 397 /ixms) { 398 my $author = $1 || $2; 399 400 # XXX: ugly but should work anyway... 401 if (eval "require Pod::Escapes; 1") { 402 # Pod::Escapes has a mapping table. 403 # It's in core of perl >= 5.9.3, and should be installed 404 # as one of the Pod::Simple's prereqs, which is a prereq 405 # of Pod::Text 3.x (see also below). 406 $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } 407 { 408 defined $2 409 ? chr($2) 410 : defined $Pod::Escapes::Name2character_number{$1} 411 ? chr($Pod::Escapes::Name2character_number{$1}) 412 : do { 413 warn "Unknown escape: E<$1>"; 414 "E<$1>"; 415 }; 416 }gex; 417 } 418 elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { 419 # Pod::Text < 3.0 has yet another mapping table, 420 # though the table name of 2.x and 1.x are different. 421 # (1.x is in core of Perl < 5.6, 2.x is in core of 422 # Perl < 5.9.3) 423 my $mapping = ($Pod::Text::VERSION < 2) 424 ? \%Pod::Text::HTML_Escapes 425 : \%Pod::Text::ESCAPES; 426 $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } 427 { 428 defined $2 429 ? chr($2) 430 : defined $mapping->{$1} 431 ? $mapping->{$1} 432 : do { 433 warn "Unknown escape: E<$1>"; 434 "E<$1>"; 435 }; 436 }gex; 437 } 438 else { 439 $author =~ s{E<lt>}{<}g; 440 $author =~ s{E<gt>}{>}g; 441 } 442 $self->author($author); 443 } else { 444 warn "Cannot determine author info from $_[0]\n"; 445 } 446} 447 448#Stolen from M::B 449my %license_urls = ( 450 perl => 'http://dev.perl.org/licenses/', 451 apache => 'http://apache.org/licenses/LICENSE-2.0', 452 apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', 453 artistic => 'http://opensource.org/licenses/artistic-license.php', 454 artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', 455 lgpl => 'http://opensource.org/licenses/lgpl-license.php', 456 lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', 457 lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', 458 bsd => 'http://opensource.org/licenses/bsd-license.php', 459 gpl => 'http://opensource.org/licenses/gpl-license.php', 460 gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', 461 gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', 462 mit => 'http://opensource.org/licenses/mit-license.php', 463 mozilla => 'http://opensource.org/licenses/mozilla1.1.php', 464 open_source => undef, 465 unrestricted => undef, 466 restrictive => undef, 467 unknown => undef, 468); 469 470sub license { 471 my $self = shift; 472 return $self->{values}->{license} unless @_; 473 my $license = shift or die( 474 'Did not provide a value to license()' 475 ); 476 $license = __extract_license($license) || lc $license; 477 $self->{values}->{license} = $license; 478 479 # Automatically fill in license URLs 480 if ( $license_urls{$license} ) { 481 $self->resources( license => $license_urls{$license} ); 482 } 483 484 return 1; 485} 486 487sub _extract_license { 488 my $pod = shift; 489 my $matched; 490 return __extract_license( 491 ($matched) = $pod =~ m/ 492 (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) 493 (=head \d.*|=cut.*|)\z 494 /xms 495 ) || __extract_license( 496 ($matched) = $pod =~ m/ 497 (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) 498 (=head \d.*|=cut.*|)\z 499 /xms 500 ); 501} 502 503sub __extract_license { 504 my $license_text = shift or return; 505 my @phrases = ( 506 '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, 507 '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 508 'Artistic and GPL' => 'perl', 1, 509 'GNU general public license' => 'gpl', 1, 510 'GNU public license' => 'gpl', 1, 511 'GNU lesser general public license' => 'lgpl', 1, 512 'GNU lesser public license' => 'lgpl', 1, 513 'GNU library general public license' => 'lgpl', 1, 514 'GNU library public license' => 'lgpl', 1, 515 'GNU Free Documentation license' => 'unrestricted', 1, 516 'GNU Affero General Public License' => 'open_source', 1, 517 '(?:Free)?BSD license' => 'bsd', 1, 518 'Artistic license 2\.0' => 'artistic_2', 1, 519 'Artistic license' => 'artistic', 1, 520 'Apache (?:Software )?license' => 'apache', 1, 521 'GPL' => 'gpl', 1, 522 'LGPL' => 'lgpl', 1, 523 'BSD' => 'bsd', 1, 524 'Artistic' => 'artistic', 1, 525 'MIT' => 'mit', 1, 526 'Mozilla Public License' => 'mozilla', 1, 527 'Q Public License' => 'open_source', 1, 528 'OpenSSL License' => 'unrestricted', 1, 529 'SSLeay License' => 'unrestricted', 1, 530 'zlib License' => 'open_source', 1, 531 'proprietary' => 'proprietary', 0, 532 ); 533 while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { 534 $pattern =~ s#\s+#\\s+#gs; 535 if ( $license_text =~ /\b$pattern\b/i ) { 536 return $license; 537 } 538 } 539 return ''; 540} 541 542sub license_from { 543 my $self = shift; 544 if (my $license=_extract_license(Module::Install::_read($_[0]))) { 545 $self->license($license); 546 } else { 547 warn "Cannot determine license info from $_[0]\n"; 548 return 'unknown'; 549 } 550} 551 552sub _extract_bugtracker { 553 my @links = $_[0] =~ m#L<( 554 https?\Q://rt.cpan.org/\E[^>]+| 555 https?\Q://github.com/\E[\w_]+/[\w_]+/issues| 556 https?\Q://code.google.com/p/\E[\w_\-]+/issues/list 557 )>#gx; 558 my %links; 559 @links{@links}=(); 560 @links=keys %links; 561 return @links; 562} 563 564sub bugtracker_from { 565 my $self = shift; 566 my $content = Module::Install::_read($_[0]); 567 my @links = _extract_bugtracker($content); 568 unless ( @links ) { 569 warn "Cannot determine bugtracker info from $_[0]\n"; 570 return 0; 571 } 572 if ( @links > 1 ) { 573 warn "Found more than one bugtracker link in $_[0]\n"; 574 return 0; 575 } 576 577 # Set the bugtracker 578 bugtracker( $links[0] ); 579 return 1; 580} 581 582sub requires_from { 583 my $self = shift; 584 my $content = Module::Install::_readperl($_[0]); 585 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 586 while ( @requires ) { 587 my $module = shift @requires; 588 my $version = shift @requires; 589 $self->requires( $module => $version ); 590 } 591} 592 593sub test_requires_from { 594 my $self = shift; 595 my $content = Module::Install::_readperl($_[0]); 596 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 597 while ( @requires ) { 598 my $module = shift @requires; 599 my $version = shift @requires; 600 $self->test_requires( $module => $version ); 601 } 602} 603 604# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to 605# numbers (eg, 5.006001 or 5.008009). 606# Also, convert double-part versions (eg, 5.8) 607sub _perl_version { 608 my $v = $_[-1]; 609 $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; 610 $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; 611 $v =~ s/(\.\d\d\d)000$/$1/; 612 $v =~ s/_.+$//; 613 if ( ref($v) ) { 614 # Numify 615 $v = $v + 0; 616 } 617 return $v; 618} 619 620sub add_metadata { 621 my $self = shift; 622 my %hash = @_; 623 for my $key (keys %hash) { 624 warn "add_metadata: $key is not prefixed with 'x_'.\n" . 625 "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; 626 $self->{values}->{$key} = $hash{$key}; 627 } 628} 629 630 631###################################################################### 632# MYMETA Support 633 634sub WriteMyMeta { 635 die "WriteMyMeta has been deprecated"; 636} 637 638sub write_mymeta_yaml { 639 my $self = shift; 640 641 # We need YAML::Tiny to write the MYMETA.yml file 642 unless ( eval { require YAML::Tiny; 1; } ) { 643 return 1; 644 } 645 646 # Generate the data 647 my $meta = $self->_write_mymeta_data or return 1; 648 649 # Save as the MYMETA.yml file 650 print "Writing MYMETA.yml\n"; 651 YAML::Tiny::DumpFile('MYMETA.yml', $meta); 652} 653 654sub write_mymeta_json { 655 my $self = shift; 656 657 # We need JSON to write the MYMETA.json file 658 unless ( eval { require JSON; 1; } ) { 659 return 1; 660 } 661 662 # Generate the data 663 my $meta = $self->_write_mymeta_data or return 1; 664 665 # Save as the MYMETA.yml file 666 print "Writing MYMETA.json\n"; 667 Module::Install::_write( 668 'MYMETA.json', 669 JSON->new->pretty(1)->canonical->encode($meta), 670 ); 671} 672 673sub _write_mymeta_data { 674 my $self = shift; 675 676 # If there's no existing META.yml there is nothing we can do 677 return undef unless -f 'META.yml'; 678 679 # We need Parse::CPAN::Meta to load the file 680 unless ( eval { require Parse::CPAN::Meta; 1; } ) { 681 return undef; 682 } 683 684 # Merge the perl version into the dependencies 685 my $val = $self->Meta->{values}; 686 my $perl = delete $val->{perl_version}; 687 if ( $perl ) { 688 $val->{requires} ||= []; 689 my $requires = $val->{requires}; 690 691 # Canonize to three-dot version after Perl 5.6 692 if ( $perl >= 5.006 ) { 693 $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e 694 } 695 unshift @$requires, [ perl => $perl ]; 696 } 697 698 # Load the advisory META.yml file 699 my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); 700 my $meta = $yaml[0]; 701 702 # Overwrite the non-configure dependency hashs 703 delete $meta->{requires}; 704 delete $meta->{build_requires}; 705 delete $meta->{recommends}; 706 if ( exists $val->{requires} ) { 707 $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; 708 } 709 if ( exists $val->{build_requires} ) { 710 $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; 711 } 712 713 return $meta; 714} 715 7161; 717