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