use strict;
BEGIN { require 5.00503 }
+
+use Carp;
use Config;
use File::Copy ();
use File::Find ();
use Data::Dumper ();
use IO::File ();
use Text::ParseWords ();
-use Carp ();
use Module::Build::ModuleInfo;
use Module::Build::Notes;
+use Module::Build::Config;
#################### Constructors ###########################
" but we are now using '$perl'.\n");
}
- my $mb_version = $Module::Build::VERSION;
- die(" * ERROR: Configuration was initially created with Module::Build version '$self->{properties}{mb_version}',\n".
- " but we are now using version '$mb_version'. Please re-run the Build.PL or Makefile.PL script.\n")
- unless $mb_version eq $self->{properties}{mb_version};
-
$self->cull_args(@ARGV);
+
+ unless ($self->allow_mb_mismatch) {
+ my $mb_version = $Module::Build::VERSION;
+ die(" * ERROR: Configuration was initially created with Module::Build version '$self->{properties}{mb_version}',\n".
+ " but we are now using version '$mb_version'. Please re-run the Build.PL or Makefile.PL script,\n".
+ " or use --allow_mb_mismatch 1 to skip this version check.\n")
+ if $mb_version ne $self->{properties}{mb_version};
+ }
+
$self->{invoked_action} = $self->{action} ||= 'build';
return $self;
# as it is during resume() (and thereafter).
{
local @ARGV = $package->unparse_args(\%args);
- do 'Build.PL';
+ do './Build.PL';
die $@ if $@;
}
return $package->resume;
my $self = bless {
args => {%$args},
- config => {%Config, %$config},
+ config => Module::Build::Config->new(values => $config),
properties => {
base_dir => $package->cwd,
mb_version => $Module::Build::VERSION,
}, $package;
$self->_set_defaults;
- my ($p, $c, $ph) = ($self->{properties}, $self->{config}, $self->{phash});
+ my ($p, $ph) = ($self->{properties}, $self->{phash});
foreach (qw(notes config_data features runtime_params cleanup auto_features)) {
my $file = File::Spec->catfile($self->config_dir, $_);
sub _set_install_paths {
my $self = shift;
- my $c = $self->config;
+ my $c = $self->{config};
my $p = $self->{properties};
- my @libstyle = $c->{installstyle} ?
- File::Spec->splitdir($c->{installstyle}) : qw(lib perl5);
- my $arch = $c->{archname};
- my $version = $c->{version};
+ my @libstyle = $c->get('installstyle') ?
+ File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
+ my $arch = $c->get('archname');
+ my $version = $c->get('version');
- my $bindoc = $c->{installman1dir} || undef;
- my $libdoc = $c->{installman3dir} || undef;
+ my $bindoc = $c->get('installman1dir') || undef;
+ my $libdoc = $c->get('installman3dir') || undef;
- my $binhtml = $c->{installhtml1dir} || $c->{installhtmldir} || undef;
- my $libhtml = $c->{installhtml3dir} || $c->{installhtmldir} || undef;
+ my $binhtml = $c->get('installhtml1dir') || $c->get('installhtmldir') || undef;
+ my $libhtml = $c->get('installhtml3dir') || $c->get('installhtmldir') || undef;
$p->{install_sets} =
{
core => {
- lib => $c->{installprivlib},
- arch => $c->{installarchlib},
- bin => $c->{installbin},
- script => $c->{installscript},
+ lib => $c->get('installprivlib'),
+ arch => $c->get('installarchlib'),
+ bin => $c->get('installbin'),
+ script => $c->get('installscript'),
bindoc => $bindoc,
libdoc => $libdoc,
binhtml => $binhtml,
libhtml => $libhtml,
},
site => {
- lib => $c->{installsitelib},
- arch => $c->{installsitearch},
- bin => $c->{installsitebin} || $c->{installbin},
- script => $c->{installsitescript} ||
- $c->{installsitebin} || $c->{installscript},
- bindoc => $c->{installsiteman1dir} || $bindoc,
- libdoc => $c->{installsiteman3dir} || $libdoc,
- binhtml => $c->{installsitehtml1dir} || $binhtml,
- libhtml => $c->{installsitehtml3dir} || $libhtml,
+ lib => $c->get('installsitelib'),
+ arch => $c->get('installsitearch'),
+ bin => $c->get('installsitebin') || $c->get('installbin'),
+ script => $c->get('installsitescript') ||
+ $c->get('installsitebin') || $c->get('installscript'),
+ bindoc => $c->get('installsiteman1dir') || $bindoc,
+ libdoc => $c->get('installsiteman3dir') || $libdoc,
+ binhtml => $c->get('installsitehtml1dir') || $binhtml,
+ libhtml => $c->get('installsitehtml3dir') || $libhtml,
},
vendor => {
- lib => $c->{installvendorlib},
- arch => $c->{installvendorarch},
- bin => $c->{installvendorbin} || $c->{installbin},
- script => $c->{installvendorscript} ||
- $c->{installvendorbin} || $c->{installscript},
- bindoc => $c->{installvendorman1dir} || $bindoc,
- libdoc => $c->{installvendorman3dir} || $libdoc,
- binhtml => $c->{installvendorhtml1dir} || $binhtml,
- libhtml => $c->{installvendorhtml3dir} || $libhtml,
+ lib => $c->get('installvendorlib'),
+ arch => $c->get('installvendorarch'),
+ bin => $c->get('installvendorbin') || $c->get('installbin'),
+ script => $c->get('installvendorscript') ||
+ $c->get('installvendorbin') || $c->get('installscript'),
+ bindoc => $c->get('installvendorman1dir') || $bindoc,
+ libdoc => $c->get('installvendorman3dir') || $libdoc,
+ binhtml => $c->get('installvendorhtml1dir') || $binhtml,
+ libhtml => $c->get('installvendorhtml3dir') || $libhtml,
},
};
$p->{original_prefix} =
{
- core => $c->{installprefixexp} || $c->{installprefix} ||
- $c->{prefixexp} || $c->{prefix} || '',
- site => $c->{siteprefixexp},
- vendor => $c->{usevendorprefix} ? $c->{vendorprefixexp} : '',
+ core => $c->get('installprefixexp') || $c->get('installprefix') ||
+ $c->get('prefixexp') || $c->get('prefix') || '',
+ site => $c->get('siteprefixexp'),
+ vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '',
};
$p->{original_prefix}{site} ||= $p->{original_prefix}{core};
return Cwd::cwd();
}
+sub _quote_args {
+ # Returns a string that can become [part of] a command line with
+ # proper quoting so that the subprocess sees this same list of args.
+ my ($self, @args) = @_;
+
+ my $return_args = '';
+ my @quoted;
+
+ for (@args) {
+ if ( /^[^\s*?!$<>;\\|'"\[\]\{\}]+$/ ) {
+ # Looks pretty safe
+ push @quoted, $_;
+ } else {
+ # XXX this will obviously have to improve - is there already a
+ # core module lying around that does proper quoting?
+ s/"/"'"'"/g;
+ push @quoted, qq("$_");
+ }
+ }
+
+ return join " ", @quoted;
+}
+
+sub _backticks {
+ my ($self, @cmd) = @_;
+ if ($self->have_forkpipe) {
+ local *FH;
+ my $pid = open *FH, "-|";
+ if ($pid) {
+ return wantarray ? <FH> : join '', <FH>;
+ } else {
+ die "Can't execute @cmd: $!\n" unless defined $pid;
+ exec { $cmd[0] } @cmd;
+ }
+ } else {
+ my $cmd = $self->_quote_args(@cmd);
+ return `$cmd`;
+ }
+}
+
+sub have_forkpipe { 1 }
+
+# Determine whether a given binary is the same as the perl
+# (configuration) that started this process.
sub _perl_is_same {
my ($self, $perl) = @_;
- return `$perl -MConfig=myconfig -e print -e myconfig` eq Config->myconfig;
+
+ my @cmd = ($perl);
+
+ # When run from the perl core, @INC will include the directories
+ # where perl is yet to be installed. We need to reference the
+ # absolute path within the source distribution where it can find
+ # it's Config.pm This also prevents us from picking up a Config.pm
+ # from a different configuration that happens to be already
+ # installed in @INC.
+ if ($ENV{PERL_CORE}) {
+ push @cmd, '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib');
+ }
+
+ push @cmd, qw(-MConfig=myconfig -e print -e myconfig);
+ return $self->_backticks(@cmd) eq Config->myconfig;
}
+# Returns the absolute path of the perl interperter used to invoke
+# this process. The path is derived from $^X or $Config{perlpath}. On
+# some platforms $^X contains the complete absolute path of the
+# interpreter, on other it may contain a relative path, or simply
+# 'perl'. This can also vary depending on whether a path was supplied
+# when perl was invoked. Additionally, the value in $^X may omit the
+# executable extension on platforms that use one. It's a fatal error
+# if the interpreter can't be found because it can result in undefined
+# behavior by routines that depend on it (generating errors or
+# invoking the wrong perl.
sub find_perl_interpreter {
- return $^X if File::Spec->file_name_is_absolute($^X);
my $proto = shift;
- my $c = ref($proto) ? $proto->config : \%Config::Config;
- my $exe = $c->{exe_ext};
+ my $c = ref($proto) ? $proto->{config} : 'Module::Build::Config';
+
+ my $perl = $^X;
+ my $perl_basename = File::Basename::basename($perl);
+
+ my @potential_perls;
+
+ # Try 1, Check $^X for absolute path
+ push( @potential_perls, $perl )
+ if File::Spec->file_name_is_absolute($perl);
+
+ # Try 2, Check $^X for a valid relative path
+ my $abs_perl = File::Spec->rel2abs($perl);
+ push( @potential_perls, $abs_perl );
+
+ # Try 3, Last ditch effort: These two option use hackery to try to locate
+ # a suitable perl. The hack varies depending on whether we are running
+ # from an installed perl or an uninstalled perl in the perl source dist.
+ if ($ENV{PERL_CORE}) {
+
+ # Try 3.A, If we are in a perl source tree, running an uninstalled
+ # perl, we can keep moving up the directory tree until we find our
+ # binary. We wouldn't do this under any other circumstances.
+
+ # CBuilder is also in the core, so it should be available here
+ require ExtUtils::CBuilder;
+ my $perl_src = ExtUtils::CBuilder->perl_src;
+ if ( defined($perl_src) && length($perl_src) ) {
+ my $uninstperl =
+ File::Spec->rel2abs(File::Spec->catfile( $perl_src, $perl_basename ));
+ push( @potential_perls, $uninstperl );
+ }
+
+ } else {
+
+ # Try 3.B, First look in $Config{perlpath}, then search the users
+ # PATH. We do not want to do either if we are running from an
+ # uninstalled perl in a perl source tree.
- my $thisperl = $^X;
- if ($proto->os_type eq 'VMS') {
- # VMS might have a file version at the end
- $thisperl .= $exe unless $thisperl =~ m/$exe(;\d+)?$/i;
- } elsif (defined $exe) {
- $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
+ push( @potential_perls, $c->get('perlpath') );
+
+ push( @potential_perls,
+ map File::Spec->catfile($_, $perl_basename), File::Spec->path() );
}
-
- foreach my $perl ( $c->{perlpath},
- map File::Spec->catfile($_, $thisperl), File::Spec->path()
- ) {
- return $perl if -f $perl and $proto->_perl_is_same($perl);
+
+ # Now that we've enumerated the potential perls, it's time to test
+ # them to see if any of them match our configuration, returning the
+ # absolute path of the first successful match.
+ my $exe = $c->get('exe_ext');
+ foreach my $thisperl ( @potential_perls ) {
+
+ if (defined $exe and $proto->os_type ne 'VMS') {
+ $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
+ }
+
+ if ( -f $thisperl && $proto->_perl_is_same($thisperl) ) {
+ return $thisperl;
+ }
}
- return;
+
+ # We've tried all alternatives, and didn't find a perl that matches
+ # our configuration. Throw an exception, and list alternatives we tried.
+ my @paths = map File::Basename::dirname($_), @potential_perls;
+ die "Can't locate the perl binary used to run this script " .
+ "in (@paths)\n";
}
sub _is_interactive {
return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe?
}
-sub prompt {
+# NOTE this is a blocking operation if(-t STDIN)
+sub _is_unattended {
my $self = shift;
- my ($mess, $def) = @_;
- die "prompt() called without a prompt message" unless @_;
-
- ($def, my $dispdef) = defined $def ? ($def, "[$def] ") : ('', ' ');
+ return $ENV{PERL_MM_USE_DEFAULT} ||
+ ( !$self->_is_interactive && eof STDIN );
+}
- {
- local $|=1;
- print "$mess $dispdef";
- }
- my $ans;
- if ( ! $ENV{PERL_MM_USE_DEFAULT} &&
- ( $self->_is_interactive || ! eof STDIN ) ) {
- $ans = <STDIN>;
- if ( defined $ans ) {
- chomp $ans;
- } else { # user hit ctrl-D
- print "\n";
- }
+sub _readline {
+ my $self = shift;
+ return undef if $self->_is_unattended;
+
+ my $answer = <STDIN>;
+ chomp $answer if defined $answer;
+ return $answer;
+}
+
+sub prompt {
+ my $self = shift;
+ my $mess = shift
+ or die "prompt() called without a prompt message";
+
+ # use a list to distinguish a default of undef() from no default
+ my @def;
+ @def = (shift) if @_;
+ # use dispdef for output
+ my @dispdef = scalar(@def) ?
+ ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') :
+ (' ', '');
+
+ local $|=1;
+ print "$mess ", @dispdef;
+
+ if ( $self->_is_unattended && !@def ) {
+ die <<EOF;
+ERROR: This build seems to be unattended, but there is no default value
+for this question. Aborting.
+EOF
}
-
- unless (defined($ans) and length($ans)) {
- print "$def\n";
- $ans = $def;
+
+ my $ans = $self->_readline();
+
+ if ( !defined($ans) # Ctrl-D or unattended
+ or !length($ans) ) { # User hit return
+ print "$dispdef[1]\n";
+ $ans = scalar(@def) ? $def[0] : '';
}
-
+
return $ans;
}
sub y_n {
my $self = shift;
- die "y_n() called without a prompt message" unless @_;
- die "y_n() called without y or n default" unless ($_[1]||"")=~/^[yn]/i;
+ my ($mess, $def) = @_;
+
+ die "y_n() called without a prompt message" unless $mess;
+ die "Invalid default value: y_n() default must be 'y' or 'n'"
+ if $def && $def !~ /^[yn]/i;
- my $interactive = $self->_is_interactive;
my $answer;
- while (1) {
+ while (1) { # XXX Infinite or a large number followed by an exception ?
$answer = $self->prompt(@_);
return 1 if $answer =~ /^y/i;
return 0 if $answer =~ /^n/i;
+ local $|=1;
print "Please answer 'y' or 'n'.\n";
}
}
if ( $type eq 'HASH' ) {
*{"$class\::$property"} = sub {
my $self = shift;
- my $x = ( $property eq 'config' ) ? $self : $self->{properties};
+ my $x = $self->{properties};
return $x->{$property} unless @_;
if ( defined($_[0]) && !ref($_[0]) ) {
__PACKAGE__->add_property(metafile => 'META.yml');
__PACKAGE__->add_property(recurse_into => []);
__PACKAGE__->add_property(use_rcfile => 1);
+__PACKAGE__->add_property(create_packlist => 1);
+__PACKAGE__->add_property(allow_mb_mismatch => 0);
+__PACKAGE__->add_property(config => undef);
{
my $Is_ActivePerl = eval {require ActivePerl::DocTools};
}
__PACKAGE__->add_property($_ => {}) for qw(
- config
get_options
install_base_relpaths
install_path
xs_files
);
+sub config {
+ my $self = shift;
+ my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
+ return $c->all_config unless @_;
+
+ my $key = shift;
+ return $c->get($key) unless @_;
+
+ my $val = shift;
+ return $c->set($key => $val);
+}
sub mb_parents {
# Code borrowed from Class::ISA.
return $p->{dist_name} if defined $p->{dist_name};
die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter"
- unless $p->{module_name};
+ unless $self->module_name;
- ($p->{dist_name} = $p->{module_name}) =~ s/::/-/g;
+ ($p->{dist_name} = $self->module_name) =~ s/::/-/g;
return $p->{dist_name};
}
-sub _find_dist_version_from {
+sub dist_version_from {
my ($self) = @_;
my $p = $self->{properties};
if ($self->module_name) {
- return $p->{dist_version_from} ||=
+ $p->{dist_version_from} ||=
join( '/', 'lib', split(/::/, $self->module_name) ) . '.pm';
- } else {
- return undef;
}
+ return $p->{dist_version_from} || undef;
}
sub dist_version {
my $p = $self->{properties};
return $p->{dist_version} if defined $p->{dist_version};
-
- $self->_find_dist_version_from;
- if ( $p->{dist_version_from} ) {
- my $version_from = File::Spec->catfile( split( qr{/}, $p->{dist_version_from} ) );
+ 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} = $pm_info->version();
my ($self) = @_;
my $file = $self->config_file('build_params')
- or die "No 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': $!";
my $ref = eval do {local $/; <$fh>};
die if $@;
- ($self->{args}, $self->{config}, $self->{properties}) = @$ref;
+ my $c;
+ ($self->{args}, $c, $self->{properties}) = @$ref;
+ $self->{config} = Module::Build::Config->new(values => $c);
close $fh;
}
my @items = @{ $self->prereq_action_types };
$self->_write_data('prereqs', { map { $_, $self->$_() } @items });
- $self->_write_data('build_params', [$self->{args}, $self->{config}, $self->{properties}]);
+ $self->_write_data('build_params', [$self->{args}, $self->{config}->values_set, $self->{properties}]);
# Set a new magic number and write it to a file
$self->_write_data('magicnum', $self->magic_number(int rand 1_000_000));
} elsif ($type =~ /^(?:\w+_)?recommends$/) {
next if $status->{ok};
- $status->{message} = ($status->{have} eq '<none>'
+ $status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>'
? "Optional prerequisite $modname is not installed"
: "$modname ($status->{have}) is installed, but we prefer to have $spec");
} else {
my $xs_files = $self->find_xs_files;
if (keys %$xs_files && !$self->_mb_feature('C_support')) {
$self->log_warn("Warning: this distribution contains XS files, ".
- "but Module::Build is not configured with C_support");
+ "but Module::Build is not configured with C_support. ".
+ "Please install ExtUtils::CBuilder to enable C_support.\n");
}
# Check to see if there are any prereqs to check
sub compare_versions {
my $self = shift;
my ($v1, $op, $v2) = @_;
-
- # for alpha versions - this doesn't cover all cases, but should work for most:
- $v1 =~ s/_(\d+)\z/$1/;
- $v2 =~ s/_(\d+)\z/$1/;
+ $v1 = Module::Build::Version->new($v1)
+ unless UNIVERSAL::isa($v1,'Module::Build::Version');
my $eval_str = "\$v1 $op \$v2";
my $result = eval $eval_str;
my $self = shift;
foreach (@_) {
my $current_mode = (stat $_)[2];
- chmod $current_mode | 0111, $_;
+ chmod $current_mode | oct(111), $_;
}
}
+sub is_executable {
+ # We assume this does the right thing on generic platforms, though
+ # we do some other more specific stuff on Unixish platforms.
+ my ($self, $file) = @_;
+ return -x $file;
+}
+
sub _startperl { shift()->config('startperl') }
# Return any directories in @INC which are not in the default @INC for
my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
- my @inc = `$perl -le "print for \@INC"`;
+ my @inc = $self->_backticks($perl, '-le', 'print for @INC');
chomp @inc;
return @default_inc = @inc;
use $build_package;
# Some platforms have problems setting \$^X in shebang contexts, fix it up here
-\$^X = Module::Build->find_perl_interpreter
- unless File::Spec->file_name_is_absolute(\$^X);
+\$^X = Module::Build->find_perl_interpreter;
if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) {
warn "Warning: Build.PL has been altered. You may need to run 'perl Build.PL' again.\\n";
}
$args{ARGV} = \@argv;
+ for ('extra_compiler_flags', 'extra_linker_flags') {
+ $args{$_} = [ $self->split_like_shell($args{$_}) ] if exists $args{$_};
+ }
+
# Hashify these parameters
- for ($self->hash_properties) {
+ for ($self->hash_properties, 'config') {
next unless exists $args{$_};
my %hash;
$args{$_} ||= [];
}
+# (bash shell won't expand tildes mid-word: "--foo=~/thing")
+# TODO: handle ~user/foo
sub _detildefy {
my $arg = shift;
- my($new_arg) = glob($arg) if $arg =~ /^~/;
-
- return defined($new_arg) ? $new_arg : $arg;
+ return $arg =~ /^~/ ? (glob $arg)[0] : $arg;
}
return %new_opts;
}
-# Look for a home directory on various systems. CPANPLUS does something like this.
+# Look for a home directory on various systems.
sub _home_dir {
- my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN );
-
- foreach ( @os_home_envs ) {
- return $ENV{$_} if exists $ENV{$_} && defined $ENV{$_} && length $ENV{$_} && -d $ENV{$_};
+ my @home_dirs;
+ push( @home_dirs, $ENV{HOME} ) if $ENV{HOME};
+
+ push( @home_dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
+ if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
+
+ my @other_home_envs = qw( USERPROFILE APPDATA WINDIR SYS$LOGIN );
+ push( @home_dirs, map $ENV{$_}, grep $ENV{$_}, @other_home_envs );
+
+ my @real_home_dirs = grep -d, @home_dirs;
+
+ return wantarray ? @real_home_dirs : shift( @real_home_dirs );
+}
+
+sub _find_user_config {
+ my $self = shift;
+ my $file = shift;
+ foreach my $dir ( $self->_home_dir ) {
+ my $path = File::Spec->catfile( $dir, $file );
+ return $path if -e $path;
}
-
- return;
+ return undef;
}
# read ~/.modulebuildrc returning global options '*' and
"No options loaded\n");
return ();
} else {
- my $home = $self->_home_dir;
- return () unless defined $home;
- $modulebuildrc = File::Spec->catfile( $home, '.modulebuildrc' );
- return () unless -e $modulebuildrc;
+ $modulebuildrc = $self->_find_user_config( '.modulebuildrc' );
+ return () unless $modulebuildrc;
}
my $fh = IO::File->new( $modulebuildrc )
while (my ($key, $val) = each %args) {
$self->{phash}{runtime_params}->access( $key => $val )
if $self->valid_property($key);
- my $add_to = ( $key eq 'config' ? $self->{config}
- : $additive{$key} ? $self->{properties}{$key}
- : $self->valid_property($key) ? $self->{properties}
- : $self->{args});
- if ($additive{$key}) {
- $add_to->{$_} = $val->{$_} foreach keys %$val;
+ if ($key eq 'config') {
+ $self->config($_ => $val->{$_}) foreach keys %$val;
} else {
- $add_to->{$key} = $val;
+ my $add_to = ( $additive{$key} ? $self->{properties}{$key}
+ : $self->valid_property($key) ? $self->{properties}
+ : $self->{args});
+
+ if ($additive{$key}) {
+ $add_to->{$_} = $val->{$_} foreach keys %$val;
+ } else {
+ $add_to->{$key} = $val;
+ }
}
}
}
}
sub get_action_docs {
- my ($self, $action, $actions) = @_;
- $actions ||= $self->known_actions;
- $@ = '';
- ($@ = "No known action '$action'\n"), return
- unless $actions->{$action};
-
+ my ($self, $action) = @_;
+ my $actions = $self->known_actions;
+ die "No known action '$action'" unless $actions->{$action};
+
my ($files_found, @docs) = (0);
foreach my $class ($self->super_classes) {
(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;
$files_found++;
-
+
# Code below modified from /usr/bin/perldoc
-
+
# Skip to ACTIONS section
local $_;
while (<$fh>) {
last if /^=head1 ACTIONS\s/;
}
-
- # Look for our action
- my ($found, $inlist) = (0, 0);
+
+ # Look for our action and determine the style
+ my $style;
while (<$fh>) {
- if (/^=item\s+\Q$action\E\b/) {
- $found = 1;
- } elsif (/^=(item|back)/) {
- last if $found > 1 and not $inlist;
+ last if /^=head1 /;
+
+ # only item and head2 are allowed (3&4 are not in 5.005)
+ if(/^=(item|head2)\s+\Q$action\E\b/) {
+ $style = $1;
+ push @docs, $_;
+ last;
}
- next unless $found;
- push @docs, $_;
- ++$inlist if /^=over/;
- --$inlist if /^=back/;
- ++$found if /^\w/; # Found descriptive text
}
+ $style or next; # not here
+
+ # and the content
+ if($style eq 'item') {
+ my ($found, $inlist) = (0, 0);
+ while (<$fh>) {
+ if (/^=(item|back)/) {
+ last unless $inlist;
+ }
+ push @docs, $_;
+ ++$inlist if /^=over/;
+ --$inlist if /^=back/;
+ }
+ }
+ else { # head2 style
+ # stop at anything equal or greater than the found level
+ while (<$fh>) {
+ last if(/^=(?:head[12]|cut)/);
+ push @docs, $_;
+ }
+ }
+ # TODO maybe disallow overriding just pod for an action
+ # TODO and possibly: @docs and last;
}
unless ($files_found) {
my $actions = $self->known_actions;
if (@{$self->{args}{ARGV}}) {
- my $msg = $self->get_action_docs($self->{args}{ARGV}[0], $actions) || "$@\n";
- print $msg;
+ my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)};
+ print $@ ? "$@\n" : $msg;
return;
}
return $out;
}
+sub ACTION_retest {
+ my ($self) = @_;
+
+ # Protect others against our @INC changes
+ local @INC = @INC;
+
+ # Filter out nonsensical @INC entries - some versions of
+ # Test::Harness will really explode the number of entries here
+ @INC = grep {ref() || -d} @INC if @INC > 100;
+
+ $self->do_tests;
+}
+
+sub ACTION_testall {
+ my ($self) = @_;
+
+ my @types;
+ for my $action (grep { $_ ne 'all' } $self->get_test_types) {
+ # XXX We can't just dispatch because we get multiple summaries but
+ # we'll need to dispatch to support custom setup/teardown in the
+ # action. To support that, we'll need to call something besides
+ # Harness::runtests() because we'll need to collect the results in
+ # parts, then run the summary.
+ push(@types, $action);
+ #$self->_call_action( "test$action" );
+ }
+ $self->generic_test(types => ['default', @types]);
+}
+
+sub get_test_types {
+ my ($self) = @_;
+
+ my $t = $self->{properties}->{test_types};
+ return ( defined $t ? ( keys %$t ) : () );
+}
+
+
sub ACTION_test {
my ($self) = @_;
+ $self->generic_test(type => 'default');
+}
+
+sub generic_test {
+ my $self = shift;
+ (@_ % 2) and croak('Odd number of elements in argument hash');
+ my %args = @_;
+
my $p = $self->{properties};
- require Test::Harness;
-
+
+ my @types = (
+ (exists($args{type}) ? $args{type} : ()),
+ (exists($args{types}) ? @{$args{types}} : ()),
+ );
+ @types or croak "need some types of tests to check";
+
+ my %test_types = (
+ default => '.t',
+ (defined($p->{test_types}) ? %{$p->{test_types}} : ()),
+ );
+
+ for my $type (@types) {
+ croak "$type not defined in test_types!"
+ unless defined $test_types{ $type };
+ }
+
+ # we use local here because it ends up two method calls deep
+ local $p->{test_file_exts} = [ @test_types{@types} ];
$self->depends_on('code');
-
+
+ # Protect others against our @INC changes
+ local @INC = @INC;
+
+ # Make sure we test the module in blib/
+ unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
+ File::Spec->catdir($p->{base_dir}, $self->blib, 'arch'));
+
+ # Filter out nonsensical @INC entries - some versions of
+ # Test::Harness will really explode the number of entries here
+ @INC = grep {ref() || -d} @INC if @INC > 100;
+
+ $self->do_tests;
+}
+
+sub do_tests {
+ my $self = shift;
+ my $p = $self->{properties};
+ require Test::Harness;
+
# Do everything in our power to work with all versions of Test::Harness
my @harness_switches = $p->{debugger} ? qw(-w -d) : ();
local $Test::Harness::switches = join ' ', grep defined, $Test::Harness::switches, @harness_switches;
$ENV{TEST_VERBOSE},
$ENV{HARNESS_VERBOSE}) = ($p->{verbose} || 0) x 4;
- # Make sure we test the module in blib/
- local @INC = (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
- File::Spec->catdir($p->{base_dir}, $self->blib, 'arch'),
- @INC);
-
- # Filter out nonsensical @INC entries - some versions of
- # Test::Harness will really explode the number of entries here
- @INC = grep {ref() || -d} @INC if @INC > 100;
-
my $tests = $self->find_test_files;
if (@$tests) {
sub expand_test_dir {
my ($self, $dir) = @_;
- return sort @{$self->rscan_dir($dir, qr{^[^.].*\.t$})} if $self->recursive_test_files;
- return sort glob File::Spec->catfile($dir, "*.t");
+ my $exts = $self->{properties}{test_file_exts} || ['.t'];
+
+ return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts
+ if $self->recursive_test_files;
+
+ return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts;
}
sub ACTION_testdb {
my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/});
$self->do_system(qw(cover -delete))
- unless $self->up_to_date($pm_files, $cover_files);
+ unless $self->up_to_date($pm_files, $cover_files)
+ && $self->up_to_date($self->test_files, $cover_files);
}
local $Test::Harness::switches =
foreach my $file (keys %$files) {
my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
- $self->fix_shebang_line($result);
+ $self->fix_shebang_line($result) unless $self->is_vmsish;
$self->make_executable($result);
}
}
sub find_test_files {
my $self = shift;
my $p = $self->{properties};
-
+
if (my $files = $p->{test_files}) {
$files = [keys %$files] if UNIVERSAL::isa($files, 'HASH');
$files = [map { -d $_ ? $self->expand_test_dir($_) : $_ }
sub localize_file_path {
my ($self, $path) = @_;
+ $path =~ s/\.\z// if $self->is_vmsish;
return File::Spec->catfile( split m{/}, $path );
}
sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35
my ($self, @files) = @_;
- my $c = $self->config;
+ my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
- my ($does_shbang) = $c->{sharpbang} =~ /^\s*\#\!/;
+ my ($does_shbang) = $c->get('sharpbang') =~ /^\s*\#\!/;
for my $file (@files) {
my $FIXIN = IO::File->new($file) or die "Can't process '$file': $!";
local $/ = "\n";
$self->log_verbose("Changing sharpbang in $file to $interpreter");
my $shb = '';
- $shb .= "$c->{sharpbang}$interpreter $arg\n" if $does_shbang;
+ $shb .= $c->get('sharpbang')."$interpreter $arg\n" if $does_shbang;
# I'm not smart enough to know the ramifications of changing the
# embedded newlines here to \n, so I leave 'em in.
$shb .= qq{
eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
if 0; # not running under some shell
-} unless $self->os_type eq 'Windows'; # this won't work on win32, so don't
+} unless $self->is_windowsish; # this won't work on win32, so don't
my $FIXOUT = IO::File->new(">$file.new")
or die "Can't create new $file: $!\n";
rename("$file.new", $file)
or die "Can't rename $file.new to $file: $!";
- unlink "$file.bak"
+ $self->delete_filetree("$file.bak")
or $self->log_warn("Couldn't clean up $file.bak, leaving it there");
- $self->do_system($c->{eunicefix}, $file) if $c->{eunicefix} ne ':';
+ $self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':';
}
}
}
}
+sub ACTION_testpodcoverage {
+ my $self = shift;
+
+ $self->depends_on('docs');
+
+ eval q{use Test::Pod::Coverage 1.00; 1}
+ or die "The 'testpodcoverage' action requires ",
+ "Test::Pod::Coverage version 1.00";
+
+ # TODO this needs test coverage!
+
+ # XXX work-around a bug in Test::Pod::Coverage previous to v1.09
+ # Make sure we test the module in blib/
+ local @INC = @INC;
+ my $p = $self->{properties};
+ unshift(@INC,
+ # XXX any reason to include arch?
+ File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'),
+ #File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')
+ );
+
+ all_pod_coverage_ok();
+}
+
sub ACTION_docs {
my $self = shift;
return unless keys %$files;
my $mandir = File::Spec->catdir( $self->blib, 'bindoc' );
- File::Path::mkpath( $mandir, 0, 0777 );
+ File::Path::mkpath( $mandir, 0, oct(777) );
require Pod::Man;
foreach my $file (keys %$files) {
return unless keys %$files;
my $mandir = File::Spec->catdir( $self->blib, 'libdoc' );
- File::Path::mkpath( $mandir, 0, 0777 );
+ File::Path::mkpath( $mandir, 0, oct(777) );
require Pod::Man;
while (my ($file, $relfile) = each %$files) {
foreach my $spec (@$dirs) {
my $dir = $self->localize_dir_path($spec);
next unless -e $dir;
+
FILE: foreach my $file ( @{ $self->rscan_dir( $dir ) } ) {
foreach my $regexp ( @{ $args{exclude} } ) {
next FILE if $file =~ $regexp;
my $pods = $self->_find_pods( $self->{properties}{"${type}doc_dirs"},
exclude => [ qr/\.(?:bat|com|html)$/ ] );
- next unless %$pods; # nothing to do
+ return unless %$pods; # nothing to do
unless ( -d $htmldir ) {
- File::Path::mkpath($htmldir, 0, 0755)
+ File::Path::mkpath($htmldir, 0, oct(755))
or die "Couldn't mkdir $htmldir: $!";
}
next if $self->up_to_date($infile, $outfile);
unless ( -d $fulldir ){
- File::Path::mkpath($fulldir, 0, 0755)
+ File::Path::mkpath($fulldir, 0, oct(755))
or die "Couldn't mkdir $fulldir: $!";
}
($path2root,
$self->installdirs eq 'core' ? () : qw(site) ) );
- my $fh = IO::File->new($infile);
+ my $fh = IO::File->new($infile) or die "Can't read $infile: $!";
my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract();
my $title = join( '::', (@dirs, $name) );
$self->delete_filetree( $ppm );
}
+sub ACTION_pardist {
+ my ($self) = @_;
+
+ # Need PAR::Dist
+ if ( not eval { require PAR::Dist; PAR::Dist->VERSION(0.17) } ) {
+ $self->log_warn(
+ "In order to create .par distributions, you need to\n"
+ . "install PAR::Dist first."
+ );
+ return();
+ }
+
+ $self->depends_on( 'build' );
+
+ return PAR::Dist::blib_to_par(
+ name => $self->dist_name,
+ version => $self->dist_version,
+ );
+}
+
sub ACTION_dist {
my ($self) = @_;
sub ACTION_distcheck {
my ($self) = @_;
-
+
require ExtUtils::Manifest;
local $^W; # ExtUtils::Manifest is not warnings clean.
my ($missing, $extra) = ExtUtils::Manifest::fullcheck();
- die "MANIFEST appears to be out of sync with the distribution\n"
- if @$missing || @$extra;
+
+ return unless @$missing || @$extra;
+
+ my $msg = "MANIFEST appears to be out of sync with the distribution\n";
+ if ( $self->invoked_action eq 'distcheck' ) {
+ die $msg;
+ } else {
+ warn $msg;
+ }
}
sub _add_to_manifest {
or return;
my $mode = (stat $manifest)[2];
- chmod($mode | 0222, $manifest) or die "Can't make $manifest writable: $!";
+ chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!";
my $fh = IO::File->new("< $manifest") or die "Can't read $manifest: $!";
my $last_line = (<$fh>)[-1] || "\n";
sub _main_docfile {
my $self = shift;
- $self->_find_dist_version_from;
if ( my $pm_file = $self->dist_version_from ) {
(my $pod_file = $pm_file) =~ s/.pm$/.pod/;
return (-e $pod_file ? $pod_file : $pm_file);
foreach my $file (keys %$dist_files) {
my $new = $self->copy_if_modified(from => $file, to_dir => $dist_dir, verbose => 0);
- chmod +(stat $file)[2], $new
- or $self->log_warn("Couldn't set permissions on $new: $!");
}
$self->_sign_dir($dist_dir) if $self->{properties}{sign};
# Avoid Module::Build generated and utility files.
\bBuild$
+\bBuild.bat$
\b_build
# Avoid Devel::Cover generated files
}
}
-sub _yaml_quote_string {
- # XXX doesn't handle embedded newlines
-
- my ($self, $string) = @_;
- if ($string !~ /\"/) {
- $string =~ s{\\}{\\\\}g;
- return qq{"$string"};
- } else {
- $string =~ s{([\\'])}{\\$1}g;
- return qq{'$string'};
- }
-}
-
-sub _write_minimal_metadata {
- my $self = shift;
- my $p = $self->{properties};
-
- my $file = $self->metafile;
- my $fh = IO::File->new("> $file")
- or die "Can't open $file: $!";
-
- my @author = map $self->_yaml_quote_string($_), @{$self->dist_author};
- my $abstract = $self->_yaml_quote_string($self->dist_abstract);
-
- # XXX Add the meta_add & meta_merge stuff
-
- print $fh <<"EOF";
---- #YAML:1.0
-name: $p->{dist_name}
-version: $p->{dist_version}
-author:
-@{[ join "\n", map " - $_", @author ]}
-abstract: $abstract
-license: $p->{license}
-generated_by: Module::Build version $Module::Build::VERSION, without YAML.pm
-EOF
-}
-
sub ACTION_distmeta {
my ($self) = @_;
$self->{wrote_metadata} = $yaml_sub->($metafile, $node );
} else {
- $self->log_warn(<<EOF);
-
-Couldn't load YAML.pm, generating a minimal META.yml without it.
-Please check and edit the generated metadata, or consider installing YAML.pm.
-
-EOF
-
- $self->_write_minimal_metadata;
+ require Module::Build::YAML;
+ my (%node, @order_keys);
+ $self->prepare_metadata(\%node, \@order_keys);
+ $node{_order} = \@order_keys;
+ &Module::Build::YAML::DumpFile($metafile, \%node);
+ $self->{wrote_metadata} = 1;
}
$self->_add_to_manifest('MANIFEST', $metafile);
}
sub prepare_metadata {
- my ($self, $node) = @_;
+ my ($self, $node, $keys) = @_;
my $p = $self->{properties};
+ # A little helper sub
+ my $add_node = sub {
+ my ($name, $val) = @_;
+ $node->{$name} = $val;
+ push @$keys, $name if $keys;
+ };
+
foreach (qw(dist_name dist_version dist_author dist_abstract license)) {
(my $name = $_) =~ s/^dist_//;
- $node->{$name} = $self->$_();
- die "ERROR: Missing required field '$name' for META.yml\n"
+ $add_node->($name, $self->$_());
+ die "ERROR: Missing required field '$_' for META.yml\n"
unless defined($node->{$name}) && length($node->{$name});
}
+ $node->{version} = '' . $node->{version}; # Stringify version objects
if (defined( $self->license ) &&
defined( my $url = $self->valid_licenses->{ $self->license } )) {
}
foreach ( @{$self->prereq_action_types} ) {
- $node->{$_} = $p->{$_} if exists $p->{$_} and keys %{ $p->{$_} };
+ if (exists $p->{$_} and keys %{ $p->{$_} }) {
+ $add_node->($_, $p->{$_});
+ }
}
- $node->{dynamic_config} = $p->{dynamic_config} if exists $p->{dynamic_config};
+ if (exists $p->{dynamic_config}) {
+ $add_node->('dynamic_config', $p->{dynamic_config});
+ }
my $pkgs = eval { $self->find_dist_packages };
if ($@) {
- $self->log_warn("WARNING: Possible missing or corrupt 'MANIFEST' file.\n" .
+ $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" .
"Nothing to enter for 'provides' field in META.yml\n");
} else {
$node->{provides} = $pkgs if %$pkgs;
}
;
- $node->{no_index} = $p->{no_index} if exists $p->{no_index};
+ if (exists $p->{no_index}) {
+ $add_node->('no_index', $p->{no_index});
+ }
- $node->{generated_by} = "Module::Build version $Module::Build::VERSION";
-
- $node->{'meta-spec'} = {
- version => '1.2',
- url => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
- };
+ $add_node->('generated_by', "Module::Build version $Module::Build::VERSION");
+ $add_node->('meta-spec',
+ {version => '1.2',
+ url => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
+ });
while (my($k, $v) = each %{$self->meta_add}) {
- $node->{$k} = $v;
+ $add_node->($k, $v);
}
while (my($k, $v) = each %{$self->meta_merge}) {
}
}
+ # Stringify versions. Can't use exists() here because of bug in YAML::Node.
+ for (grep defined $_->{version}, values %prime) {
+ $_->{version} = '' . $_->{version};
+ }
+
return \%prime;
}
}
}
+sub install_path {
+ my $self = shift;
+ my( $type, $value ) = ( @_, '<empty>' );
+
+ Carp::croak( 'Type argument missing' )
+ unless defined( $type );
+
+ my $map = $self->{properties}{install_path};
+ return $map unless @_;
+
+ # delete existing value if $value is literal undef()
+ unless ( defined( $value ) ) {
+ delete( $map->{$type} );
+ return undef;
+ }
+
+ # return existing value if no new $value is given
+ if ( $value eq '<empty>' ) {
+ return undef unless exists $map->{$type};
+ return $map->{$type};
+ }
+
+ # set value if $value is a valid relative path
+ return $map->{$type} = $value;
+}
+
sub install_base_relpaths {
- # Usage: install_base_relpaths('lib') or install_base_relpaths();
+ # Usage: install_base_relpaths(), install_base_relpaths('lib'),
+ # or install_base_relpaths('lib' => $value);
my $self = shift;
my $map = $self->{properties}{install_base_relpaths};
return $map unless @_;
-
- my $type = shift;
- return unless exists $map->{$type};
- return File::Spec->catdir(@{$map->{$type}});
+ return $self->_relpaths($map, @_);
}
);
}
+sub _relpaths {
+ my $self = shift;
+ my( $map, $type, $value ) = ( @_, '<empty>' );
+
+ Carp::croak( 'Type argument missing' )
+ unless defined( $type );
+
+ my @value = ();
+
+ # delete existing value if $value is literal undef()
+ unless ( defined( $value ) ) {
+ delete( $map->{$type} );
+ return undef;
+ }
+
+ # return existing value if no new $value is given
+ elsif ( $value eq '<empty>' ) {
+ return undef unless exists $map->{$type};
+ @value = @{ $map->{$type} };
+ }
+
+ # set value if $value is a valid relative path
+ else {
+ Carp::croak( "Value must be a relative path" )
+ if File::Spec::Unix->file_name_is_absolute($value);
+
+ @value = split( /\//, $value );
+ $map->{$type} = \@value;
+ }
+
+ return File::Spec->catdir( @value );
+}
# Defaults to use in case the config install paths cannot be prefixified.
sub prefix_relpaths {
- # Usage: prefix_relpaths('site', 'lib') or prefix_relpaths('site');
+ # Usage: prefix_relpaths('site'), prefix_relpaths('site', 'lib'),
+ # or prefix_relpaths('site', 'lib' => $value);
my $self = shift;
my $installdirs = shift || $self->installdirs;
my $map = $self->{properties}{prefix_relpaths}{$installdirs};
return $map unless @_;
-
- my $type = shift;
- return unless exists $map->{$type};
- return File::Spec->catdir(@{$map->{$type}});
+ return $self->_relpaths($map, @_);
}
sub install_types {
my $self = shift;
- my %types = (%{$self->install_path}, %{ $self->install_sets($self->installdirs) });
+
+ my %types;
+ if ( $self->install_base ) {
+ %types = %{$self->install_base_relpaths};
+ } elsif ( $self->prefix ) {
+ %types = %{$self->prefix_relpaths};
+ } else {
+ %types = %{$self->install_sets($self->installdirs)};
+ }
+
+ %types = (%types, %{$self->install_path});
+
return sort keys %types;
}
"WARNING: Can't figure out install path for types: @skipping\n" .
"Files will not be installed.\n"
) if @skipping;
-
+
# Write the packlist into the same place as ExtUtils::MakeMaker.
- my $archdir = $self->install_destination('arch');
- my @ext = split /::/, $self->module_name;
- $map{write} = File::Spec->catdir($archdir, 'auto', @ext, '.packlist');
-
+ if ($self->create_packlist and my $module_name = $self->module_name) {
+ my $archdir = $self->install_destination('arch');
+ my @ext = split /::/, $module_name;
+ $map{write} = File::Spec->catdir($archdir, 'auto', @ext, '.packlist');
+ }
+
# Handle destdir
if (length(my $destdir = $self->destdir || '')) {
foreach (keys %map) {
if (defined $lib_typemap and -e $lib_typemap) {
push @typemaps, 'typemap';
}
- my $typemaps = join ' ', map qq{-typemap "$_"}, @typemaps;
+ @typemaps = map {+'-typemap', $_} @typemaps;
- my $cf = $self->config;
+ my $cf = $self->{config};
my $perl = $self->{properties}{perl};
- my $command = (qq{$perl "-I$cf->{installarchlib}" "-I$cf->{installprivlib}" "$xsubpp" -noprototypes } .
- qq{$typemaps "$file"});
+ my @command = ($perl, "-I".$cf->get('installarchlib'), "-I".$cf->get('installprivlib'), $xsubpp, '-noprototypes',
+ @typemaps, $file);
- $self->log_info("$command\n");
+ $self->log_info("@command\n");
my $fh = IO::File->new("> $args{outfile}") or die "Couldn't write $args{outfile}: $!";
- print $fh `$command`;
+ print {$fh} $self->_backticks(@command);
close $fh;
}
}
my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
# Make sure our local additions to @INC are propagated to the subprocess
- my $c = ref $self ? $self->config : \%Config::Config;
- local $ENV{PERL5LIB} = join $c->{path_sep}, $self->_added_to_INC;
+ local $ENV{PERL5LIB} = join $self->config('path_sep'), $self->_added_to_INC;
return $self->do_system($perl, @$args);
}
$spec{bs_file} = File::Spec->catfile($spec{archdir}, "${file_base}.bs");
$spec{lib_file} = File::Spec->catfile($spec{archdir},
- "${file_base}.$cf->{dlext}");
+ "${file_base}.".$cf->get('dlext'));
$spec{c_file} = File::Spec->catfile( $spec{src_dir},
"${file_base}.c" );
$spec{obj_file} = File::Spec->catfile( $spec{src_dir},
- "${file_base}$cf->{obj_ext}" );
+ "${file_base}".$cf->get('obj_ext') );
return \%spec;
}
sub process_xs {
my ($self, $file) = @_;
- my $cf = $self->config; # For convenience
my $spec = $self->_infer_xs_spec($file);
defines => {VERSION => qq{"$v"}, XS_VERSION => qq{"$v"}});
# archdir
- File::Path::mkpath($spec->{archdir}, 0, 0777) unless -d $spec->{archdir};
+ File::Path::mkpath($spec->{archdir}, 0, oct(777)) unless -d $spec->{archdir};
# .xs -> .bs
$self->add_to_cleanup($spec->{bs_file});
sub do_system {
my ($self, @cmd) = @_;
$self->log_info("@cmd\n");
- return !system(@cmd);
+
+ # Some systems proliferate huge PERL5LIBs, try to ameliorate:
+ my %seen;
+ my $sep = $self->config('path_sep');
+ local $ENV{PERL5LIB} =
+ ( !exists($ENV{PERL5LIB}) ? '' :
+ length($ENV{PERL5LIB}) < 500
+ ? $ENV{PERL5LIB}
+ : join $sep, grep { ! $seen{$_}++ and -d $_ } split($sep, $ENV{PERL5LIB})
+ );
+
+ my $status = system(@cmd);
+ if ($status and $! =~ /Argument list too long/i) {
+ my $env_entries = '';
+ foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " }
+ warn "'Argument list' was 'too long', env lengths are $env_entries";
+ }
+ return !$status;
}
sub copy_if_modified {
}
return if $self->up_to_date($file, $to_path); # Already fresh
-
+
+ {
+ local $self->{properties}{quiet} = 1;
+ $self->delete_filetree($to_path); # delete destination if exists
+ }
+
# Create parent directories
- File::Path::mkpath(File::Basename::dirname($to_path), 0, 0777);
+ File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777));
- $self->log_info("$file -> $to_path\n") if $args{verbose};
- File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
+ $self->log_info("Copying $file -> $to_path\n") if $args{verbose};
+
+ if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite
+ chmod 0666, $to_path;
+ File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!";
+ } else {
+ File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
+ }
+
+ # mode is read-only + (executable if source is executable)
+ my $mode = oct(444) | ( $self->is_executable($file) ? oct(111) : 0 );
+ chmod( $mode, $to_path );
+
return $to_path;
}
=head1 AUTHOR
-Ken Williams <ken@cpan.org>
+Ken Williams <kwilliams@cpan.org>
=head1 COPYRIGHT
-Copyright (c) 2001-2005 Ken Williams. All rights reserved.
+Copyright (c) 2001-2006 Ken Williams. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
perl(1), Module::Build(3)
=cut
+
+# vim:ts=8:sw=2:et:sta:sts=2
projects / p5sagit/p5-mst-13.2.git / blobdiff