X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/58fa69461616f3c1e259c1a8e108d199448119ef..18b2aa6a0d8618a3be3fe009940a585eddae1e52:/cpan/Module-Build/lib/Module/Build/Base.pm?ds=inline diff --git a/cpan/Module-Build/lib/Module/Build/Base.pm b/cpan/Module-Build/lib/Module/Build/Base.pm index 795ed91..abd386f 100644 --- a/cpan/Module-Build/lib/Module/Build/Base.pm +++ b/cpan/Module-Build/lib/Module/Build/Base.pm @@ -4,9 +4,11 @@ package Module::Build::Base; use strict; use vars qw($VERSION); -$VERSION = '0.40'; +use warnings; + +$VERSION = '0.4200'; $VERSION = eval $VERSION; -BEGIN { require 5.00503 } +BEGIN { require 5.006001 } use Carp; use Cwd (); @@ -17,7 +19,6 @@ use File::Basename (); use File::Spec 0.82 (); use File::Compare (); use Module::Build::Dumper (); -use IO::File (); use Text::ParseWords (); use Module::Build::ModuleInfo; @@ -755,17 +756,11 @@ sub ACTION_config_data { } sub array_properties { - for (shift->_mb_classes) { - return @{$additive_properties{$_}->{ARRAY}} - if exists $additive_properties{$_}->{ARRAY}; - } + map { exists $additive_properties{$_}->{ARRAY} ? @{$additive_properties{$_}->{ARRAY}} : () } shift->_mb_classes; } sub hash_properties { - for (shift->_mb_classes) { - return @{$additive_properties{$_}->{'HASH'}} - if exists $additive_properties{$_}->{'HASH'}; - } + map { exists $additive_properties{$_}->{HASH} ? @{$additive_properties{$_}->{HASH}} : () } shift->_mb_classes; } sub add_property { @@ -796,10 +791,10 @@ sub ACTION_config_data { return $class; } - sub property_error { - my $self = shift; - die 'ERROR: ', @_; - } + sub property_error { + my $self = shift; + die 'ERROR: ', @_; + } sub _set_defaults { my $self = shift; @@ -829,7 +824,7 @@ sub ACTION_config_data { } } -} # end closure +} # end enclosure ######################################################################## sub _make_hash_accessor { my ($property, $p) = @_; @@ -920,6 +915,8 @@ __PACKAGE__->add_property(test_file_exts => ['.t']); __PACKAGE__->add_property(use_tap_harness => 0); __PACKAGE__->add_property(cpan_client => 'cpan'); __PACKAGE__->add_property(tap_harness_args => {}); +__PACKAGE__->add_property(pureperl_only => 0); +__PACKAGE__->add_property(allow_pureperl => 0); __PACKAGE__->add_property( 'installdirs', default => 'site', @@ -940,7 +937,7 @@ __PACKAGE__->add_property( } { - my @prereq_action_types = qw(requires build_requires conflicts recommends); + my @prereq_action_types = qw(requires build_requires test_requires conflicts recommends); foreach my $type (@prereq_action_types) { __PACKAGE__->add_property($type => {}); } @@ -1003,6 +1000,7 @@ __PACKAGE__->add_property($_) for qw( verbose debug xs_files + extra_manify_args ); sub config { @@ -1078,7 +1076,7 @@ sub subclass { File::Path::mkpath($filedir); die "Can't create directory $filedir: $!" unless -d $filedir; - my $fh = IO::File->new("> $filename") or die "Can't create $filename: $!"; + open(my $fh, '>', $filename) or die "Can't create $filename: $!"; print $fh <{properties}; - return $p->{dist_name} if defined $p->{dist_name}; + my $me = 'dist_name'; + return $p->{$me} if defined $p->{$me}; die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter" unless $self->module_name; - ($p->{dist_name} = $self->module_name) =~ s/::/-/g; + ($p->{$me} = $self->module_name) =~ s/::/-/g; - return $p->{dist_name}; + return $p->{$me}; } sub release_status { my ($self) = @_; + my $me = 'release_status'; my $p = $self->{properties}; - if ( ! defined $p->{release_status} ) { - $p->{release_status} = $self->_is_dev_version ? 'testing' : 'stable'; + if ( ! defined $p->{$me} ) { + $p->{$me} = $self->_is_dev_version ? 'testing' : 'stable'; } - unless ( $p->{release_status} =~ qr/\A(?:stable|testing|unstable)\z/ ) { - die "Illegal value '$p->{release_status}' for release_status\n"; + unless ( $p->{$me} =~ qr/\A(?:stable|testing|unstable)\z/ ) { + die "Illegal value '$p->{$me}' for $me\n"; } - if ( $p->{release_status} eq 'stable' && $self->_is_dev_version ) { + if ( $p->{$me} eq 'stable' && $self->_is_dev_version ) { my $version = $self->dist_version; - die "Illegal value '$p->{release_status}' with version '$version'\n"; + die "Illegal value '$p->{$me}' with version '$version'\n"; } - return $p->{release_status}; + return $p->{$me}; } sub dist_suffix { my ($self) = @_; my $p = $self->{properties}; - return $p->{dist_suffix} if defined $p->{dist_suffix}; + my $me = 'dist_suffix'; + + return $p->{$me} if defined $p->{$me}; if ( $self->release_status eq 'stable' ) { - $p->{dist_suffix} = ""; + $p->{$me} = ""; } else { # non-stable release but non-dev version number needs '-TRIAL' appended - $p->{dist_suffix} = $self->_is_dev_version ? "" : "TRIAL" ; + $p->{$me} = $self->_is_dev_version ? "" : "TRIAL" ; } - return $p->{dist_suffix}; + return $p->{$me}; } sub dist_version_from { my ($self) = @_; my $p = $self->{properties}; + my $me = 'dist_version_from'; + if ($self->module_name) { - $p->{dist_version_from} ||= + $p->{$me} ||= join( '/', 'lib', split(/::/, $self->module_name) ) . '.pm'; } - return $p->{dist_version_from} || undef; + return $p->{$me} || undef; } sub dist_version { my ($self) = @_; my $p = $self->{properties}; + my $me = 'dist_version'; - return $p->{dist_version} if defined $p->{dist_version}; + return $p->{$me} if defined $p->{$me}; if ( my $dist_version_from = $self->dist_version_from ) { my $version_from = File::Spec->catfile( split( qr{/}, $dist_version_from ) ); my $pm_info = Module::Build::ModuleInfo->new_from_file( $version_from ) or die "Can't find file $version_from to determine version"; - #$p->{dist_version} is undef here - $p->{dist_version} = $self->normalize_version( $pm_info->version() ); - unless (defined $p->{dist_version}) { + #$p->{$me} is undef here + $p->{$me} = $self->normalize_version( $pm_info->version() ); + unless (defined $p->{$me}) { die "Can't determine distribution version from $version_from"; } } die ("Can't determine distribution version, must supply either 'dist_version',\n". "'dist_version_from', or 'module_name' parameter") - unless defined $p->{dist_version}; + unless defined $p->{$me}; - return $p->{dist_version}; + return $p->{$me}; } sub _is_dev_version { @@ -1225,7 +1230,7 @@ sub _pod_parse { my $docfile = $self->_main_docfile or return; - my $fh = IO::File->new($docfile) + open(my $fh, '<', $docfile) or return; require Module::Build::PodParser; @@ -1285,13 +1290,13 @@ sub read_config { my $file = $self->config_file('build_params') or die "Can't find 'build_params' in " . $self->config_dir; - my $fh = IO::File->new($file) or die "Can't read '$file': $!"; + open(my $fh, '<', $file) or die "Can't read '$file': $!"; my $ref = eval do {local $/; <$fh>}; die if $@; + close $fh; my $c; ($self->{args}, $c, $self->{properties}) = @$ref; $self->{config} = Module::Build::Config->new(values => $c); - close $fh; } sub has_config_data { @@ -1303,13 +1308,14 @@ sub _write_data { my ($self, $filename, $data) = @_; my $file = $self->config_file($filename); - my $fh = IO::File->new("> $file") or die "Can't create '$file': $!"; + open(my $fh, '>', $file) or die "Can't create '$file': $!"; unless (ref($data)) { # e.g. magicnum print $fh $data; return; } print {$fh} Module::Build::Dumper->_data_dump($data); + close $fh; } sub write_config { @@ -1507,7 +1513,7 @@ sub auto_require { my ($self) = @_; my $p = $self->{properties}; - # If needs_compiler is not explictly set, automatically set it + # If needs_compiler is not explicitly set, automatically set it # If set, we need ExtUtils::CBuilder (and a compiler) my $xs_files = $self->find_xs_files; if ( ! defined $p->{needs_compiler} ) { @@ -1640,6 +1646,7 @@ sub perl_version_to_float { sub _parse_conditions { my ($self, $spec) = @_; + return ">= 0" if not defined $spec; if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores return (">= $spec"); } else { @@ -1809,7 +1816,7 @@ sub print_build_script { my @myINC = $self->_added_to_INC; for (@myINC, values %q) { - $_ = File::Spec->canonpath( $_ ); + $_ = File::Spec->canonpath( $_ ) unless $self->is_vmsish; s/([\\\'])/\\$1/g; } @@ -1827,10 +1834,10 @@ use File::Spec; sub magic_number_matches { return 0 unless -e '$q{magic_numfile}'; - local *FH; - open FH, '$q{magic_numfile}' or return 0; - my \$filenum = ; - close FH; + my \$FH; + open \$FH, '<','$q{magic_numfile}' or return 0; + my \$filenum = <\$FH>; + close \$FH; return \$filenum == $magic_number; } @@ -1897,52 +1904,27 @@ sub create_mymeta { if ( $self->try_require("CPAN::Meta", "2.110420") ) { for my $file ( @metafiles ) { next unless -f $file; - $meta_obj = eval { CPAN::Meta->load_file($file) }; + $meta_obj = eval { CPAN::Meta->load_file($file, { lazy_validation => 0 }) }; last if $meta_obj; } } # maybe get a copy in spec v2 format (regardless of original source) - $mymeta = $meta_obj->as_struct - if $meta_obj; + my $mymeta_obj = $self->_get_meta_object(quiet => 0, dynamic => 0, fatal => 1, auto => 0); # if we have metadata, just update it - if ( defined $mymeta ) { - my $prereqs = $self->_normalize_prereqs; - # XXX refactor this mapping somewhere - $mymeta->{prereqs}{runtime}{requires} = $prereqs->{requires}; - $mymeta->{prereqs}{build}{requires} = $prereqs->{build_requires}; - $mymeta->{prereqs}{runtime}{recommends} = $prereqs->{recommends}; - $mymeta->{prereqs}{runtime}{conflicts} = $prereqs->{conflicts}; - # delete empty entries - for my $phase ( keys %{$mymeta->{prereqs}} ) { - if ( ref $mymeta->{prereqs}{$phase} eq 'HASH' ) { - for my $type ( keys %{$mymeta->{prereqs}{$phase}} ) { - if ( ! defined $mymeta->{prereqs}{$phase}{$type} - || ! keys %{$mymeta->{prereqs}{$phase}{$type}} - ) { - delete $mymeta->{prereqs}{$phase}{$type}; - } - } - } - if ( ! defined $mymeta->{prereqs}{$phase} - || ! keys %{$mymeta->{prereqs}{$phase}} - ) { - delete $mymeta->{prereqs}{$phase}; - } - } - $mymeta->{dynamic_config} = 0; - $mymeta->{generated_by} = "Module::Build version $Module::Build::VERSION"; - eval { $meta_obj = CPAN::Meta->new( $mymeta, { lazy_validation => 1 } ) } - } - # or generate from scratch, ignoring errors if META doesn't exist - else { - $meta_obj = $self->_get_meta_object( - quiet => 0, dynamic => 0, fatal => 0, auto => 0 + if ($meta_obj && $mymeta_obj) { + my $prereqs = $mymeta_obj->effective_prereqs->with_merged_prereqs($meta_obj->effective_prereqs); + my %updated = ( + %{ $meta_obj->as_struct({ version => 2.0 }) }, + prereqs => $prereqs->as_string_hash, + dynamic_config => 0, + generated_by => "Module::Build version $Module::Build::VERSION", ); + $mymeta_obj = CPAN::Meta->new( \%updated, { lazy_validation => 0 } ); } - my @created = $self->_write_meta_files( $meta_obj, 'MYMETA' ); + my @created = $self->_write_meta_files( $mymeta_obj, 'MYMETA' ); $self->log_warn("Could not create MYMETA files\n") unless @created; @@ -1966,7 +1948,7 @@ sub create_build_script { $self->log_info("Creating new '$build_script' script for ", "'$dist_name' version '$dist_version'\n"); - my $fh = IO::File->new(">$build_script") or die "Can't create '$build_script': $!"; + open(my $fh, '>', $build_script) or die "Can't create '$build_script': $!"; $self->print_build_script($fh); close $fh; @@ -2116,6 +2098,8 @@ sub _translate_option { use_tap_harness tap_harness_args cpan_client + pureperl_only + allow_pureperl ); # normalize only selected option names return $opt; @@ -2156,6 +2140,8 @@ sub _optional_arg { debug sign use_tap_harness + pureperl_only + allow_pureperl ); # inverted boolean options; eg --noverbose or --no-verbose @@ -2330,7 +2316,7 @@ sub read_modulebuildrc { return () unless $modulebuildrc; } - my $fh = IO::File->new( $modulebuildrc ) + open(my $fh, '<', $modulebuildrc ) or die "Can't open $modulebuildrc: $!"; my %options; my $buffer = ''; @@ -2451,7 +2437,7 @@ sub get_action_docs { (my $file = $class) =~ s{::}{/}g; # NOTE: silently skipping relative paths if any chdir() happened $file = $INC{$file . '.pm'} or next; - my $fh = IO::File->new("< $file") or next; + open(my $fh, '<', $file) or next; $files_found++; # Code below modified from /usr/bin/perldoc @@ -2748,26 +2734,9 @@ sub run_tap_harness { sub run_test_harness { my ($self, $tests) = @_; require Test::Harness; - my $p = $self->{properties}; - my @harness_switches = $self->harness_switches; - - # Work around a Test::Harness bug that loses the particular perl - # we're running under. $self->perl is trustworthy, but $^X isn't. - local $^X = $self->perl; - - # Do everything in our power to work with all versions of Test::Harness - local $Test::Harness::switches = join ' ', grep defined, $Test::Harness::switches, @harness_switches; - local $Test::Harness::Switches = join ' ', grep defined, $Test::Harness::Switches, @harness_switches; - local $ENV{HARNESS_PERL_SWITCHES} = join ' ', grep defined, $ENV{HARNESS_PERL_SWITCHES}, @harness_switches; - $Test::Harness::switches = undef unless length $Test::Harness::switches; - $Test::Harness::Switches = undef unless length $Test::Harness::Switches; - delete $ENV{HARNESS_PERL_SWITCHES} unless length $ENV{HARNESS_PERL_SWITCHES}; - - local ($Test::Harness::verbose, - $Test::Harness::Verbose, - $ENV{TEST_VERBOSE}, - $ENV{HARNESS_VERBOSE}) = ($p->{verbose} || 0) x 4; + local $Test::Harness::verbose = $self->verbose || 0; + local $Test::Harness::switches = join ' ', $self->harness_switches; Test::Harness::runtests(@$tests); } @@ -2965,7 +2934,9 @@ sub process_PL_files { sub process_xs_files { my $self = shift; + return if $self->pureperl_only && $self->allow_pureperl; my $files = $self->find_xs_files; + croak 'Can\'t build xs files under --pureperl-only' if %$files && $self->pureperl_only; while (my ($from, $to) = each %$files) { unless ($from eq $to) { $self->add_to_cleanup($to); @@ -3092,10 +3063,10 @@ sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35 my ($does_shbang) = $c->get('sharpbang') =~ /^\s*\#\!/; for my $file (@files) { - my $FIXIN = IO::File->new($file) or die "Can't process '$file': $!"; + open(my $FIXIN, '<', $file) or die "Can't process '$file': $!"; local $/ = "\n"; chomp(my $line = <$FIXIN>); - next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. + next unless $line =~ s/^\s*\#!\s*//; # Not a shebang file. my ($cmd, $arg) = (split(' ', $line, 2), ''); next unless $cmd =~ /perl/i; @@ -3112,7 +3083,7 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' if 0; # not running under some shell } unless $self->is_windowsish; # this won't work on win32, so don't - my $FIXOUT = IO::File->new(">$file.new") + open(my $FIXOUT, '>', "$file.new") or die "Can't create new $file: $!\n"; # Print out the new #! line (or equivalent). @@ -3225,6 +3196,8 @@ sub ACTION_manpages { $self->depends_on('code'); + my %extra_manify_args = $self->{properties}{'extra_manify_args'} ? %{ $self->{properties}{'extra_manify_args'} } : (); + foreach my $type ( qw(bin lib) ) { next unless ( $self->invoked_action eq 'manpages' || $self->_is_default_installable("${type}doc")); my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"}, @@ -3232,12 +3205,13 @@ sub ACTION_manpages { next unless %$files; my $sub = $self->can("manify_${type}_pods"); - $self->$sub() if defined( $sub ); + $self->$sub( %extra_manify_args ) if defined( $sub ); } } sub manify_bin_pods { my $self = shift; + my %podman_args = (section => 1, @_); # binaries go in section 1 my $files = $self->_find_pods( $self->{properties}{bindoc_dirs}, exclude => [ $self->file_qr('\.bat$') ] ); @@ -3250,7 +3224,7 @@ sub manify_bin_pods { foreach my $file (keys %$files) { # Pod::Simple based parsers only support one document per instance. # This is expected to change in a future version (Pod::Simple > 3.03). - my $parser = Pod::Man->new( section => 1 ); # binaries go in section 1 + my $parser = Pod::Man->new( %podman_args ); my $manpage = $self->man1page_name( $file ) . '.' . $self->config( 'man1ext' ); my $outfile = File::Spec->catfile($mandir, $manpage); @@ -3264,6 +3238,7 @@ sub manify_bin_pods { sub manify_lib_pods { my $self = shift; + my %podman_args = (section => 3, @_); # libraries go in section 3 my $files = $self->_find_pods($self->{properties}{libdoc_dirs}); return unless keys %$files; @@ -3275,7 +3250,7 @@ sub manify_lib_pods { while (my ($file, $relfile) = each %$files) { # Pod::Simple based parsers only support one document per instance. # This is expected to change in a future version (Pod::Simple > 3.03). - my $parser = Pod::Man->new( section => 3 ); # libraries go in section 3 + my $parser = Pod::Man->new( %podman_args ); my $manpage = $self->man3page_name( $relfile ) . '.' . $self->config( 'man3ext' ); my $outfile = File::Spec->catfile( $mandir, $manpage); @@ -3298,6 +3273,7 @@ sub _find_pods { foreach my $regexp ( @{ $args{exclude} } ) { next FILE if $file =~ $regexp; } + $file = $self->localize_file_path($file); $files{$file} = File::Spec->abs2rel($file, $dir) if $self->contains_pod( $file ) } } @@ -3308,7 +3284,7 @@ sub contains_pod { my ($self, $file) = @_; return '' unless -T $file; # Only look at text files - my $fh = IO::File->new( $file ) or die "Can't open $file: $!"; + open(my $fh, '<', $file ) or die "Can't open $file: $!"; while (my $line = <$fh>) { return 1 if $line =~ /^\=(?:head|pod|item)/; } @@ -3355,15 +3331,18 @@ sub htmlify_pods { : $self->original_prefix('core'); my $htmlroot = $self->install_sets('core')->{libhtml}; - my @podpath = (map { File::Spec->abs2rel($_ ,$podroot) } grep { -d } - ( $self->install_sets('core', 'lib'), # lib - $self->install_sets('core', 'bin'), # bin - $self->install_sets('site', 'lib'), # site/lib - ) ), File::Spec->rel2abs($self->blib); + my $podpath; + unless (defined $self->args('html_links') and !$self->args('html_links')) { + my @podpath = ( (map { File::Spec->abs2rel($_ ,$podroot) } grep { -d } + ( $self->install_sets('core', 'lib'), # lib + $self->install_sets('core', 'bin'), # bin + $self->install_sets('site', 'lib'), # site/lib + ) ), File::Spec->rel2abs($self->blib) ); - my $podpath = $ENV{PERL_CORE} - ? File::Spec->catdir($podroot, 'lib') - : join(":", map { tr,:\\,|/,; $_ } @podpath); + $podpath = $ENV{PERL_CORE} + ? File::Spec->catdir($podroot, 'lib') + : join(":", map { tr,:\\,|/,; $_ } @podpath); + } my $blibdir = join('/', File::Spec->splitdir( (File::Spec->splitpath(File::Spec->rel2abs($htmldir),1))[1]),'' @@ -3413,7 +3392,7 @@ sub htmlify_pods { my $depth = @rootdirs + @dirs; my %opts = ( infile => $infile, outfile => $tmpfile, - podpath => $podpath, + ( defined($podpath) ? (podpath => $podpath) : ()), podroot => $podroot, index => 1, depth => $depth, @@ -3424,8 +3403,8 @@ sub htmlify_pods { } or $self->log_warn("[$htmltool] pod2html (" . join(", ", map { "q{$_} => q{$opts{$_}}" } (keys %opts)) . ") failed: $@"); } else { - my $path2root = join( '/', ('..') x (@rootdirs+@dirs) ); - my $fh = IO::File->new($infile) or die "Can't read $infile: $!"; + my $path2root = File::Spec->catdir((File::Spec->updir) x @dirs); + open(my $fh, '<', $infile) or die "Can't read $infile: $!"; my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract(); my $title = join( '::', (@dirs, $name) ); @@ -3433,11 +3412,11 @@ sub htmlify_pods { my @opts = ( "--title=$title", - "--podpath=$podpath", + ( defined($podpath) ? "--podpath=$podpath" : ()), "--infile=$infile", "--outfile=$tmpfile", "--podroot=$podroot", - "--htmlroot=$path2root", + ($path2root ? "--htmlroot=$path2root" : ()), ); unless ( eval{Pod::Html->VERSION(1.12)} ) { @@ -3464,9 +3443,9 @@ sub htmlify_pods { $errors++; next POD; } - my $fh = IO::File->new($tmpfile) or die "Can't read $tmpfile: $!"; + open(my $fh, '<', $tmpfile) or die "Can't read $tmpfile: $!"; my $html = join('',<$fh>); - $fh->close; + close $fh; if (!$self->_is_ActivePerl) { # These fixups are already done by AP::DT:P:pod2html # The output from pod2html is NOT XHTML! @@ -3481,9 +3460,9 @@ sub htmlify_pods { # Fixup links that point to our temp blib $html =~ s/\Q$blibdir\E//g; - $fh = IO::File->new(">$outfile") or die "Can't write $outfile: $!"; + open($fh, '>', $outfile) or die "Can't write $outfile: $!"; print $fh $html; - $fh->close; + close $fh; unlink($tmpfile); } @@ -3571,7 +3550,7 @@ sub ACTION_install { my ($self) = @_; require ExtUtils::Install; $self->depends_on('build'); - # RT#63003 suggest that odd cirmstances that we might wind up + # RT#63003 suggest that odd circumstances that we might wind up # in a different directory than we started, so wrap with _do_in_dir to # ensure we get back to where we started; hope this fixes it! $self->_do_in_dir( ".", sub { @@ -3682,10 +3661,6 @@ sub ACTION_installdeps { } } - if ( ! -x $command ) { - die "cpan_client '$command' is not executable\n"; - } - $self->do_system($command, @opts, @install); } @@ -3856,12 +3831,12 @@ sub _add_to_manifest { my $mode = (stat $manifest)[2]; chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!"; - my $fh = IO::File->new("< $manifest") or die "Can't read $manifest: $!"; + open(my $fh, '<', $manifest) or die "Can't read $manifest: $!"; my $last_line = (<$fh>)[-1] || "\n"; my $has_newline = $last_line =~ /\n$/; - $fh->close; + close $fh; - $fh = IO::File->new(">> $manifest") or die "Can't write to $manifest: $!"; + open($fh, '>>', $manifest) or die "Can't write to $manifest: $!"; print $fh "\n" unless $has_newline; print $fh map "$_\n", @$lines; close $fh; @@ -3957,7 +3932,7 @@ HERE $self->delete_filetree('LICENSE'); - my $fh = IO::File->new('> LICENSE') + open(my $fh, '>', 'LICENSE') or die "Can't write LICENSE file: $!"; print $fh $license->fulltext; close $fh; @@ -3989,8 +3964,7 @@ EOF } elsif ( eval {require Pod::Text; 1} ) { $self->log_info("Creating README using Pod::Text\n"); - my $fh = IO::File->new('> README'); - if ( defined($fh) ) { + if ( open(my $fh, '>', 'README') ) { local $^W = 0; no strict "refs"; @@ -4011,7 +3985,7 @@ EOF Pod::Text::pod2text( $docfile, $fh ); - $fh->close; + close $fh; } else { $self->log_warn( "Cannot create 'README' file: Can't open file for writing\n" ); @@ -4091,9 +4065,9 @@ sub ACTION_disttest { $self->run_perl_script('Build.PL') # XXX Should this be run w/ --nouse-rcfile or die "Error executing 'Build.PL' in dist directory: $!"; - $self->run_perl_script('Build') - or die "Error executing 'Build' in dist directory: $!"; - $self->run_perl_script('Build', [], ['test']) + $self->run_perl_script($self->build_script) + or die "Error executing $self->build_script in dist directory: $!"; + $self->run_perl_script($self->build_script, [], ['test']) or die "Error executing 'Build test' in dist directory"; }); } @@ -4107,9 +4081,9 @@ sub ACTION_distinstall { sub { $self->run_perl_script('Build.PL') or die "Error executing 'Build.PL' in dist directory: $!"; - $self->run_perl_script('Build') - or die "Error executing 'Build' in dist directory: $!"; - $self->run_perl_script('Build', [], ['install']) + $self->run_perl_script($self->build_script) + or die "Error executing $self->build_script in dist directory: $!"; + $self->run_perl_script($self->build_script, [], ['install']) or die "Error executing 'Build install' in dist directory"; } ); @@ -4205,17 +4179,17 @@ sub _append_maniskip { my $skip = shift; my $file = shift || 'MANIFEST.SKIP'; return unless defined $skip && length $skip; - my $fh = IO::File->new(">> $file") + open(my $fh, '>>', $file) or die "Can't open $file: $!"; print $fh "$skip\n"; - $fh->close(); + close $fh; } sub _write_default_maniskip { my $self = shift; my $file = shift || 'MANIFEST.SKIP'; - my $fh = IO::File->new("> $file") + open(my $fh, '>', $file) or die "Can't open $file: $!"; my $content = $self->_eumanifest_has_include ? "#!include_default\n" @@ -4241,6 +4215,8 @@ EOF $content .= '\b'.$self->dist_name.'-[\d\.\_]+'."\n"; print $fh $content; + + close $fh; return; } @@ -4565,7 +4541,7 @@ sub _get_meta_object { auto => $args{auto}, ); $data->{dynamic_config} = $args{dynamic} if defined $args{dynamic}; - $meta = CPAN::Meta->create( $data ); + $meta = CPAN::Meta->create($data); }; if ($@ && ! $args{quiet}) { $self->log_warn( @@ -4621,6 +4597,16 @@ sub normalize_version { return $version; } +my %prereq_map = ( + requires => [ qw/runtime requires/], + configure_requires => [qw/configure requires/], + build_requires => [ qw/build requires/ ], + test_requires => [ qw/test requires/ ], + test_recommends => [ qw/test recommends/ ], + recommends => [ qw/build recommends/ ], + conflicts => [ qw/build conflicts/ ], +); + sub _normalize_prereqs { my ($self) = @_; my $p = $self->{properties}; @@ -4628,46 +4614,97 @@ sub _normalize_prereqs { # copy prereq data structures so we can modify them before writing to META my %prereq_types; for my $type ( 'configure_requires', @{$self->prereq_action_types} ) { - if (exists $p->{$type}) { + if (exists $p->{$type} and keys %{ $p->{$type} }) { + my ($phase, $relation) = @{ $prereq_map{$type} }; for my $mod ( keys %{ $p->{$type} } ) { - $prereq_types{$type}{$mod} = - $self->normalize_version($p->{$type}{$mod}); + $prereq_types{$phase}{$relation}{$mod} = $self->normalize_version($p->{$type}{$mod}); } } } return \%prereq_types; } -# wrapper around old prepare_metadata API; -sub get_metadata { - my ($self, %args) = @_; - my $metadata = {}; - $self->prepare_metadata( $metadata, undef, \%args ); - return $metadata; +sub _get_license { + my $self = shift; + + my $license = $self->license; + my ($meta_license, $meta_license_url); + + my $valid_licenses = $self->valid_licenses(); + if ( my $sl = $self->_software_license_object ) { + $meta_license = $sl->meta2_name; + $meta_license_url = $sl->url; + } + elsif ( exists $valid_licenses->{$license} ) { + $meta_license = $valid_licenses->{$license} ? lc $valid_licenses->{$license} : $license; + $meta_license_url = $self->_license_url( $license ); + } + else { + $self->log_warn( "Can not determine license type for '" . $self->license + . "'\nSetting META license field to 'unknown'.\n"); + $meta_license = 'unknown'; + } + return ($meta_license, $meta_license_url); } -# To preserve compatibility with old API, $node *must* be a hashref -# passed in to prepare_metadata. $keys is an arrayref holding a -# list of keys -- it's use is optional and generally no longer needed -# but kept for back compatibility. $args is an optional parameter to -# support the new 'fatal' toggle +my %keep = map { $_ => 1 } qw/keywords dynamic_config provides no_index name version abstract/; +my %ignore = map { $_ => 1 } qw/distribution_type/; +my %reject = map { $_ => 1 } qw/private author license requires recommends build_requires configure_requires conflicts/; -sub prepare_metadata { - my ($self, $node, $keys, $args) = @_; - unless ( ref $node eq 'HASH' ) { - croak "prepare_metadata() requires a hashref argument to hold output\n"; +sub _upconvert_resources { + my ($input) = @_; + my %output; + for my $key (keys %{$input}) { + my $out_key = $key =~ /^\p{Lu}/ ? "x_\l$key" : $key; + if ($key eq 'repository') { + my $name = $input->{$key} =~ m{ \A http s? :// .* ( $input->{$key} }; + } + elsif ($key eq 'bugtracker') { + $output{$out_key} = { web => $input->{$key} } + } + else { + $output{$out_key} = $input->{$key}; + } } - my $fatal = $args->{fatal} || 0; - my $p = $self->{properties}; + return \%output +} +my %custom = ( + resources => \&_upconvert_resources, +); - $self->auto_config_requires if $args->{auto}; +sub _upconvert_metapiece { + my ($input, $type) = @_; + return $input if exists $input->{'meta-spec'} && $input->{'meta-spec'}{version} == 2; - # A little helper sub - my $add_node = sub { - my ($name, $val) = @_; - $node->{$name} = $val; - push @$keys, $name if $keys; - }; + my %ret; + for my $key (keys %{$input}) { + if ($keep{$key}) { + $ret{$key} = $input->{$key}; + } + elsif ($ignore{$key}) { + next; + } + elsif ($reject{$key}) { + croak "Can't $type $key, please use another mechanism"; + } + elsif (my $converter = $custom{$key}) { + $ret{$key} = $converter->($input->{$key}); + } + else { + warn "Unknown key $key\n" unless $key =~ / \A x_ /xi; + } + } + return \%ret; +} + +sub get_metadata { + my ($self, %args) = @_; + + my $fatal = $args{fatal} || 0; + my $p = $self->{properties}; + + $self->auto_config_requires if $args{auto}; # validate required fields foreach my $f (qw(dist_name dist_version dist_author dist_abstract license)) { @@ -4683,80 +4720,61 @@ sub prepare_metadata { } } + my %metadata = ( + name => $self->dist_name, + version => $self->normalize_version($self->dist_version), + author => $self->dist_author, + abstract => $self->dist_abstract, + generated_by => "Module::Build version $Module::Build::VERSION", + 'meta-spec' => { + version => '2', + url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', + }, + dynamic_config => exists $p->{dynamic_config} ? $p->{dynamic_config} : 1, + release_status => $self->release_status, + ); - # add dist_* fields - foreach my $f (qw(dist_name dist_version dist_author dist_abstract)) { - (my $name = $f) =~ s/^dist_//; - $add_node->($name, $self->$f()); - } - - # normalize version - $node->{version} = $self->normalize_version($node->{version}); - - # validate license information - my $license = $self->license; - my ($meta_license, $meta_license_url); - - # XXX this is still meta spec version 1 stuff - - # if Software::License::* exists, then we can use it to get normalized name - # for META files - - if ( my $sl = $self->_software_license_object ) { - $meta_license = $sl->meta_name; - $meta_license_url = $sl->url; - } - elsif ( exists $self->valid_licenses()->{$license} ) { - $meta_license = $license; - $meta_license_url = $self->_license_url( $license ); - } - else { - # if we didn't find a license from a Software::License class, - # then treat it as unknown - $self->log_warn( "Can not determine license type for '" . $self->license - . "'\nSetting META license field to 'unknown'.\n"); - $meta_license = 'unknown'; - } - - $node->{license} = $meta_license; - $node->{resources}{license} = $meta_license_url if defined $meta_license_url; + my ($meta_license, $meta_license_url) = $self->_get_license; + $metadata{license} = [ $meta_license ]; + $metadata{resources}{license} = [ $meta_license_url ] if defined $meta_license_url; - # add prerequisite data - my $prereqs = $self->_normalize_prereqs; - for my $t ( keys %$prereqs ) { - $add_node->($t, $prereqs->{$t}); - } + $metadata{prereqs} = $self->_normalize_prereqs; - if (exists $p->{dynamic_config}) { - $add_node->('dynamic_config', $p->{dynamic_config}); - } - my $pkgs = eval { $self->find_dist_packages }; - if ($@) { + if (exists $p->{no_index}) { + $metadata{no_index} = $p->{no_index}; + } elsif (my $pkgs = eval { $self->find_dist_packages }) { + $metadata{provides} = $pkgs if %$pkgs; + } else { $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" . "Nothing to enter for 'provides' field in metafile.\n"); - } else { - $node->{provides} = $pkgs if %$pkgs; } -; - if (exists $p->{no_index}) { - $add_node->('no_index', $p->{no_index}); + + my $meta_add = _upconvert_metapiece($self->meta_add, 'add'); + while (my($k, $v) = each %{$meta_add} ) { + $metadata{$k} = $v; } - $add_node->('generated_by', "Module::Build version $Module::Build::VERSION"); + my $meta_merge = _upconvert_metapiece($self->meta_merge, 'merge'); + while (my($k, $v) = each %{$meta_merge} ) { + $self->_hash_merge(\%metadata, $k, $v); + } - $add_node->('meta-spec', - {version => '1.4', - url => 'http://module-build.sourceforge.net/META-spec-v1.4.html', - }); + return \%metadata; +} - while (my($k, $v) = each %{$self->meta_add}) { - $add_node->($k, $v); - } +# To preserve compatibility with old API, $node *must* be a hashref +# passed in to prepare_metadata. $keys is an arrayref holding a +# list of keys -- it's use is optional and generally no longer needed +# but kept for back compatibility. $args is an optional parameter to +# support the new 'fatal' toggle - while (my($k, $v) = each %{$self->meta_merge}) { - $self->_hash_merge($node, $k, $v); +sub prepare_metadata { + my ($self, $node, $keys, $args) = @_; + unless ( ref $node eq 'HASH' ) { + croak "prepare_metadata() requires a hashref argument to hold output\n"; } - + croak 'Keys argument to prepare_metadata is no longer supported' if $keys; + %{$node} = %{ $self->get_meta(%{$args}) }; return $node; } @@ -5404,7 +5422,7 @@ sub compile_xs { @typemaps, $file); $self->log_info("@command\n"); - my $fh = IO::File->new("> $args{outfile}") or die "Couldn't write $args{outfile}: $!"; + open(my $fh, '>', $args{outfile}) or die "Couldn't write $args{outfile}: $!"; print {$fh} $self->_backticks(@command); close $fh; } @@ -5533,7 +5551,7 @@ sub process_xs { require ExtUtils::Mkbootstrap; $self->log_info("ExtUtils::Mkbootstrap::Mkbootstrap('$spec->{bs_file}')\n"); ExtUtils::Mkbootstrap::Mkbootstrap($spec->{bs_file}); # Original had $BSLOADLIBS - what's that? - {my $fh = IO::File->new(">> $spec->{bs_file}")} # create + open(my $fh, '>>', $spec->{bs_file}); # create utime((time)x2, $spec->{bs_file}); # touch }