Alien-ROOT
view release on metacpan or search on metacpan
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
version '$self->{properties}{mb_version}' but we are now using version '$mb_version'.
If errors occur, you must re-run the Build.PL or Makefile.PL script.
MISMATCH
}
}
$self->{invoked_action} = $self->{action} ||= 'build';
return $self;
}
sub new_from_context {
my ($package, %args) = @_;
$package->run_perl_script('Build.PL',[],[$package->unparse_args(\%args)]);
return $package->resume;
}
sub current {
# hmm, wonder what the right thing to do here is
local @ARGV;
return shift()->resume;
}
sub _construct {
my ($package, %input) = @_;
my $args = delete $input{args} || {};
my $config = delete $input{config} || {};
my $self = bless {
args => {%$args},
config => Module::Build::Config->new(values => $config),
properties => {
base_dir => $package->cwd,
mb_version => $Module::Build::VERSION,
%input,
},
phash => {},
stash => {}, # temporary caching, not stored in _build
}, $package;
$self->_set_defaults;
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, $_);
$ph->{$_} = Module::Build::Notes->new(file => $file);
$ph->{$_}->restore if -e $file;
if (exists $p->{$_}) {
my $vals = delete $p->{$_};
while (my ($k, $v) = each %$vals) {
$self->$_($k, $v);
}
}
}
# The following warning could be unnecessary if the user is running
# an embedded perl, but there aren't too many of those around, and
# embedded perls aren't usually used to install modules, and the
# installation process sometimes needs to run external scripts
# (e.g. to run tests).
$p->{perl} = $self->find_perl_interpreter
or $self->log_warn("Warning: Can't locate your perl binary");
my $blibdir = sub { File::Spec->catdir($p->{blib}, @_) };
$p->{bindoc_dirs} ||= [ $blibdir->("script") ];
$p->{libdoc_dirs} ||= [ $blibdir->("lib"), $blibdir->("arch") ];
$p->{dist_author} = [ $p->{dist_author} ] if defined $p->{dist_author} and not ref $p->{dist_author};
# Synonyms
$p->{requires} = delete $p->{prereq} if defined $p->{prereq};
$p->{script_files} = delete $p->{scripts} if defined $p->{scripts};
# Convert to from shell strings to arrays
for ('extra_compiler_flags', 'extra_linker_flags') {
$p->{$_} = [ $self->split_like_shell($p->{$_}) ] if exists $p->{$_};
}
# Convert to arrays
for ('include_dirs') {
$p->{$_} = [ $p->{$_} ] if exists $p->{$_} && !ref $p->{$_}
}
$self->add_to_cleanup( @{delete $p->{add_to_cleanup}} )
if $p->{add_to_cleanup};
return $self;
}
################## End constructors #########################
sub log_info {
my $self = shift;
print @_ if ref($self) && ( $self->verbose || ! $self->quiet );
}
sub log_verbose {
my $self = shift;
print @_ if ref($self) && $self->verbose;
}
sub log_debug {
my $self = shift;
print @_ if ref($self) && $self->debug;
}
sub log_warn {
# Try to make our call stack invisible
shift;
if (@_ and $_[-1] !~ /\n$/) {
my (undef, $file, $line) = caller();
warn @_, " at $file line $line.\n";
} else {
warn @_;
}
}
# install paths must be generated when requested to be sure all changes
# to config (from various sources) are included
sub _default_install_paths {
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
{
core => {
lib => [@libstyle],
arch => [@libstyle, $version, $arch],
bin => ['bin'],
script => ['bin'],
bindoc => ['man', 'man1'],
libdoc => ['man', 'man3'],
binhtml => ['html'],
libhtml => ['html'],
},
vendor => {
lib => [@libstyle],
arch => [@libstyle, $version, $arch],
bin => ['bin'],
script => ['bin'],
bindoc => ['man', 'man1'],
libdoc => ['man', 'man3'],
binhtml => ['html'],
libhtml => ['html'],
},
site => {
lib => [@libstyle, 'site_perl'],
arch => [@libstyle, 'site_perl', $version, $arch],
bin => ['bin'],
script => ['bin'],
bindoc => ['man', 'man1'],
libdoc => ['man', 'man3'],
binhtml => ['html'],
libhtml => ['html'],
},
};
return $p
}
sub _find_nested_builds {
my $self = shift;
my $r = $self->recurse_into or return;
my ($file, @r);
if (!ref($r) && $r eq 'auto') {
local *DH;
opendir DH, $self->base_dir
or die "Can't scan directory " . $self->base_dir . " for nested builds: $!";
while (defined($file = readdir DH)) {
my $subdir = File::Spec->catdir( $self->base_dir, $file );
next unless -d $subdir;
push @r, $subdir if -e File::Spec->catfile( $subdir, 'Build.PL' );
}
}
$self->recurse_into(\@r);
}
sub cwd {
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 @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/('+)/'"$1"'/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`;
}
}
# Tells us whether the construct open($fh, '-|', @command) is
# supported. It would probably be better to dynamically sense this.
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) = @_;
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;
}
# cache _discover_perl_interpreter() results
{
my $known_perl;
sub find_perl_interpreter {
my $self = shift;
return $known_perl if defined($known_perl);
return $known_perl = $self->_discover_perl_interpreter;
}
}
# Returns the absolute path of the perl interpreter 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 _discover_perl_interpreter {
my $proto = shift;
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 = Cwd::realpath( 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 user's
# PATH. We do not want to do either if we are running from an
# uninstalled perl in a perl source tree.
push( @potential_perls, $c->get('perlpath') );
push( @potential_perls,
map File::Spec->catfile($_, $perl_basename), File::Spec->path() );
}
# 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 ) {
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
my ($self, $dir) = @_;
my $exts = $self->{properties}{test_file_exts};
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 ($self) = @_;
local $self->{properties}{debugger} = 1;
$self->depends_on('test');
}
sub ACTION_testcover {
my ($self) = @_;
unless (Module::Build::ModuleInfo->find_module_by_name('Devel::Cover')) {
warn("Cannot run testcover action unless Devel::Cover is installed.\n");
return;
}
$self->add_to_cleanup('coverage', 'cover_db');
$self->depends_on('code');
# See whether any of the *.pm files have changed since last time
# testcover was run. If so, start over.
if (-e 'cover_db') {
my $pm_files = $self->rscan_dir
(File::Spec->catdir($self->blib, 'lib'), $self->file_qr('\.pm$') );
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)
&& $self->up_to_date($self->test_files, $cover_files);
}
local $Test::Harness::switches =
local $Test::Harness::Switches =
local $ENV{HARNESS_PERL_SWITCHES} = "-MDevel::Cover";
$self->depends_on('test');
$self->do_system('cover');
}
sub ACTION_code {
my ($self) = @_;
# All installable stuff gets created in blib/ .
# Create blib/arch to keep blib.pm happy
my $blib = $self->blib;
$self->add_to_cleanup($blib);
File::Path::mkpath( File::Spec->catdir($blib, 'arch') );
if (my $split = $self->autosplit) {
$self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split);
}
foreach my $element (@{$self->build_elements}) {
my $method = "process_${element}_files";
$method = "process_files_by_extension" unless $self->can($method);
$self->$method($element);
}
$self->depends_on('config_data');
}
sub ACTION_build {
my $self = shift;
$self->log_info("Building " . $self->dist_name . "\n");
$self->depends_on('code');
$self->depends_on('docs');
}
sub process_files_by_extension {
my ($self, $ext) = @_;
my $method = "find_${ext}_files";
my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext, 'lib');
while (my ($file, $dest) = each %$files) {
$self->copy_if_modified(from => $file, to => File::Spec->catfile($self->blib, $dest) );
}
}
sub process_support_files {
my $self = shift;
my $p = $self->{properties};
return unless $p->{c_source};
my $files;
if (ref($p->{c_source}) eq "ARRAY") {
push @{$p->{include_dirs}}, @{$p->{c_source}};
for my $path (@{$p->{c_source}}) {
push @$files, @{ $self->rscan_dir($path, $self->file_qr('\.c(c|p|pp|xx|\+\+)?$')) };
}
} else {
push @{$p->{include_dirs}}, $p->{c_source};
$files = $self->rscan_dir($p->{c_source}, $self->file_qr('\.c(c|p|pp|xx|\+\+)?$'));
}
foreach my $file (@$files) {
push @{$p->{objects}}, $self->compile_c($file);
}
}
sub process_share_dir_files {
my $self = shift;
my $files = $self->_find_share_dir_files;
return unless $files;
# root for all File::ShareDir paths
my $share_prefix = File::Spec->catdir($self->blib, qw/lib auto share/);
# copy all share files to blib
while (my ($file, $dest) = each %$files) {
$self->copy_if_modified(
from => $file, to => File::Spec->catfile( $share_prefix, $dest )
);
}
}
sub _find_share_dir_files {
my $self = shift;
my $share_dir = $self->share_dir;
return unless $share_dir;
my @file_map;
if ( $share_dir->{dist} ) {
my $prefix = "dist/".$self->dist_name;
push @file_map, $self->_share_dir_map( $prefix, $share_dir->{dist} );
}
if ( $share_dir->{module} ) {
for my $mod ( keys %{ $share_dir->{module} } ) {
(my $altmod = $mod) =~ s{::}{-}g;
my $prefix = "module/$altmod";
push @file_map, $self->_share_dir_map($prefix, $share_dir->{module}{$mod});
}
}
return { @file_map };
}
sub _share_dir_map {
my ($self, $prefix, $list) = @_;
my %files;
for my $dir ( @$list ) {
for my $f ( @{ $self->rscan_dir( $dir, sub {-f} )} ) {
$f =~ s{\A.*?\Q$dir\E/}{};
$files{"$dir/$f"} = "$prefix/$f";
}
}
return %files;
}
sub process_PL_files {
my ($self) = @_;
my $files = $self->find_PL_files;
while (my ($file, $to) = each %$files) {
unless ($self->up_to_date( $file, $to )) {
$self->run_perl_script($file, [], [@$to]) or die "$file failed";
$self->add_to_cleanup(@$to);
}
}
}
sub process_xs_files {
my $self = shift;
my $files = $self->find_xs_files;
while (my ($from, $to) = each %$files) {
unless ($from eq $to) {
$self->add_to_cleanup($to);
$self->copy_if_modified( from => $from, to => $to );
}
$self->process_xs($to);
}
}
sub process_pod_files { shift()->process_files_by_extension(shift()) }
sub process_pm_files { shift()->process_files_by_extension(shift()) }
sub process_script_files {
my $self = shift;
my $files = $self->find_script_files;
return unless keys %$files;
my $script_dir = File::Spec->catdir($self->blib, 'script');
File::Path::mkpath( $script_dir );
foreach my $file (keys %$files) {
my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
$self->fix_shebang_line($result) unless $self->is_vmsish;
$self->make_executable($result);
}
}
sub find_PL_files {
my $self = shift;
if (my $files = $self->{properties}{PL_files}) {
# 'PL_files' is given as a Unix file spec, so we localize_file_path().
if (UNIVERSAL::isa($files, 'ARRAY')) {
return { map {$_, [/^(.*)\.PL$/]}
map $self->localize_file_path($_),
@$files };
} elsif (UNIVERSAL::isa($files, 'HASH')) {
my %out;
while (my ($file, $to) = each %$files) {
$out{ $self->localize_file_path($file) } = [ map $self->localize_file_path($_),
ref $to ? @$to : ($to) ];
}
return \%out;
} else {
die "'PL_files' must be a hash reference or array reference";
}
}
return unless -d 'lib';
return {
map {$_, [/^(.*)\.PL$/i ]}
@{ $self->rscan_dir('lib', $self->file_qr('\.PL$')) }
};
}
sub find_pm_files { shift->_find_file_by_type('pm', 'lib') }
sub find_pod_files { shift->_find_file_by_type('pod', 'lib') }
sub find_xs_files { shift->_find_file_by_type('xs', 'lib') }
sub find_script_files {
my $self = shift;
if (my $files = $self->script_files) {
# Always given as a Unix file spec. Values in the hash are
# meaningless, but we preserve if present.
return { map {$self->localize_file_path($_), $files->{$_}} keys %$files };
}
# No default location for script files
return {};
}
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($_) : $_ }
map glob,
$self->split_like_shell($files)];
# Always given as a Unix file spec.
return [ map $self->localize_file_path($_), @$files ];
} else {
# Find all possible tests in t/ or test.pl
my @tests;
push @tests, 'test.pl' if -e 'test.pl';
push @tests, $self->expand_test_dir('t') if -e 't' and -d _;
return \@tests;
}
}
sub _find_file_by_type {
my ($self, $type, $dir) = @_;
if (my $files = $self->{properties}{"${type}_files"}) {
# Always given as a Unix file spec
return { map $self->localize_file_path($_), %$files };
}
return {} unless -d $dir;
return { map {$_, $_}
map $self->localize_file_path($_),
grep !/\.\#/,
@{ $self->rscan_dir($dir, $self->file_qr("\\.$type\$")) } };
}
sub localize_file_path {
my ($self, $path) = @_;
return File::Spec->catfile( split m{/}, $path );
}
sub localize_dir_path {
my ($self, $path) = @_;
return File::Spec->catdir( split m{/}, $path );
}
sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35
my ($self, @files) = @_;
my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
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";
chomp(my $line = <$FIXIN>);
next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file.
my ($cmd, $arg) = (split(' ', $line, 2), '');
next unless $cmd =~ /perl/i;
my $interpreter = $self->{properties}{perl};
$self->log_verbose("Changing sharpbang in $file to $interpreter\n");
my $shb = '';
$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->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";
# Print out the new #! line (or equivalent).
local $\;
undef $/; # Was localized above
print $FIXOUT $shb, <$FIXIN>;
close $FIXIN;
close $FIXOUT;
rename($file, "$file.bak")
or die "Can't rename $file to $file.bak: $!";
rename("$file.new", $file)
or die "Can't rename $file.new to $file: $!";
$self->delete_filetree("$file.bak")
or $self->log_warn("Couldn't clean up $file.bak, leaving it there");
$self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':';
}
}
sub ACTION_testpod {
my $self = shift;
$self->depends_on('docs');
eval q{use Test::Pod 0.95; 1}
or die "The 'testpod' action requires Test::Pod version 0.95";
my @files = sort keys %{$self->_find_pods($self->libdoc_dirs)},
keys %{$self->_find_pods
($self->bindoc_dirs,
exclude => [ $self->file_qr('\.bat$') ])}
or die "Couldn't find any POD files to test\n";
{ package # hide from PAUSE
Module::Build::PodTester; # Don't want to pollute the main namespace
Test::Pod->import( tests => scalar @files );
pod_file_ok($_) foreach @files;
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
$self->log_verbose("Checking if compiler tools configured... ");
my $b = eval { $self->cbuilder };
my $have = $b && eval { $b->have_compiler };
$self->log_verbose($have ? "ok.\n" : "failed.\n");
return $p->{_have_c_compiler} = $have;
}
sub compile_c {
my ($self, $file, %args) = @_;
if ( ! $self->have_c_compiler ) {
die "Error: no compiler detected to compile '$file'. Aborting\n";
}
my $b = $self->cbuilder;
my $obj_file = $b->object_file($file);
$self->add_to_cleanup($obj_file);
return $obj_file if $self->up_to_date($file, $obj_file);
$b->compile(source => $file,
defines => $args{defines},
object_file => $obj_file,
include_dirs => $self->include_dirs,
extra_compiler_flags => $self->extra_compiler_flags,
);
return $obj_file;
}
sub link_c {
my ($self, $spec) = @_;
my $p = $self->{properties}; # For convenience
$self->add_to_cleanup($spec->{lib_file});
my $objects = $p->{objects} || [];
return $spec->{lib_file}
if $self->up_to_date([$spec->{obj_file}, @$objects],
$spec->{lib_file});
my $module_name = $spec->{module_name} || $self->module_name;
$self->cbuilder->link(
module_name => $module_name,
objects => [$spec->{obj_file}, @$objects],
lib_file => $spec->{lib_file},
extra_linker_flags => $p->{extra_linker_flags} );
return $spec->{lib_file};
}
sub compile_xs {
my ($self, $file, %args) = @_;
$self->log_verbose("$file -> $args{outfile}\n");
if (eval {require ExtUtils::ParseXS; 1}) {
ExtUtils::ParseXS::process_file(
filename => $file,
prototypes => 0,
output => $args{outfile},
);
} else {
# Ok, I give up. Just use backticks.
my $xsubpp = Module::Build::ModuleInfo->find_module_by_name('ExtUtils::xsubpp')
or die "Can't find ExtUtils::xsubpp in INC (@INC)";
my @typemaps;
push @typemaps, Module::Build::ModuleInfo->find_module_by_name(
'ExtUtils::typemap', \@INC
);
my $lib_typemap = Module::Build::ModuleInfo->find_module_by_name(
'typemap', [File::Basename::dirname($file), File::Spec->rel2abs('.')]
);
push @typemaps, $lib_typemap if $lib_typemap;
@typemaps = map {+'-typemap', $_} @typemaps;
my $cf = $self->{config};
my $perl = $self->{properties}{perl};
my @command = ($perl, "-I".$cf->get('installarchlib'), "-I".$cf->get('installprivlib'), $xsubpp, '-noprototypes',
@typemaps, $file);
$self->log_info("@command\n");
my $fh = IO::File->new("> $args{outfile}") or die "Couldn't write $args{outfile}: $!";
print {$fh} $self->_backticks(@command);
close $fh;
}
}
sub split_like_shell {
my ($self, $string) = @_;
return () unless defined($string);
return @$string if UNIVERSAL::isa($string, 'ARRAY');
$string =~ s/^\s+|\s+$//g;
return () unless length($string);
return Text::ParseWords::shellwords($string);
}
sub oneliner {
# Returns a string that the shell can evaluate as a perl command.
# This should be avoided whenever possible, since "the shell" really
# means zillions of shells on zillions of platforms and it's really
# hard to get it right all the time.
# Some of this code is stolen with permission from ExtUtils::MakeMaker.
my($self, $cmd, $switches, $args) = @_;
$switches = [] unless defined $switches;
$args = [] unless defined $args;
# Strip leading and trailing newlines
$cmd =~ s{^\n+}{};
$cmd =~ s{\n+$}{};
my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
return $self->_quote_args($perl, @$switches, '-e', $cmd, @$args);
}
sub run_perl_script {
my ($self, $script, $preargs, $postargs) = @_;
foreach ($preargs, $postargs) {
$_ = [ $self->split_like_shell($_) ] unless ref();
}
return $self->run_perl_command([@$preargs, $script, @$postargs]);
}
sub run_perl_command {
# XXX Maybe we should accept @args instead of $args? Must resolve
# this before documenting.
my ($self, $args) = @_;
$args = [ $self->split_like_shell($args) ] unless ref($args);
my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter;
# Make sure our local additions to @INC are propagated to the subprocess
local $ENV{PERL5LIB} = join $self->config('path_sep'), $self->_added_to_INC;
return $self->do_system($perl, @$args);
}
# Infer various data from the path of the input filename
# that is needed to create output files.
# The input filename is expected to be of the form:
# lib/Module/Name.ext or Module/Name.ext
sub _infer_xs_spec {
my $self = shift;
my $file = shift;
my $cf = $self->{config};
my %spec;
my( $v, $d, $f ) = File::Spec->splitpath( $file );
my @d = File::Spec->splitdir( $d );
(my $file_base = $f) =~ s/\.[^.]+$//i;
$spec{base_name} = $file_base;
$spec{src_dir} = File::Spec->catpath( $v, $d, '' );
# the module name
shift( @d ) while @d && ($d[0] eq 'lib' || $d[0] eq '');
pop( @d ) while @d && $d[-1] eq '';
$spec{module_name} = join( '::', (@d, $file_base) );
$spec{archdir} = File::Spec->catdir($self->blib, 'arch', 'auto',
@d, $file_base);
$spec{bs_file} = File::Spec->catfile($spec{archdir}, "${file_base}.bs");
$spec{lib_file} = File::Spec->catfile($spec{archdir},
"${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->get('obj_ext') );
return \%spec;
}
sub process_xs {
my ($self, $file) = @_;
my $spec = $self->_infer_xs_spec($file);
# File name, minus the suffix
(my $file_base = $file) =~ s/\.[^.]+$//;
# .xs -> .c
$self->add_to_cleanup($spec->{c_file});
unless ($self->up_to_date($file, $spec->{c_file})) {
$self->compile_xs($file, outfile => $spec->{c_file});
}
# .c -> .o
my $v = $self->dist_version;
$self->compile_c($spec->{c_file},
defines => {VERSION => qq{"$v"}, XS_VERSION => qq{"$v"}});
# archdir
File::Path::mkpath($spec->{archdir}, 0, oct(777)) unless -d $spec->{archdir};
# .xs -> .bs
$self->add_to_cleanup($spec->{bs_file});
unless ($self->up_to_date($file, $spec->{bs_file})) {
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
utime((time)x2, $spec->{bs_file}); # touch
}
# .o -> .(a|bundle)
$self->link_c($spec);
}
sub do_system {
my ($self, @cmd) = @_;
$self->log_verbose("@cmd\n");
# 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 {
( run in 2.819 seconds using v1.01-cache-2.11-cpan-97f6503c9c8 )