Alien-ROOT
view release on metacpan or search on metacpan
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
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 {
my $self = shift;
my $c = $self->{config};
my $p = {};
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->get('installman1dir') || undef;
my $libdoc = $c->get('installman3dir') || 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->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->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->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->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};
# Note: you might be tempted to use $Config{installstyle} here
# instead of hard-coding lib/perl5, but that's been considered and
# (at least for now) rejected. `perldoc Config` has some wisdom
# about it.
$p->{install_base_relpaths} =
{
lib => ['lib', 'perl5'],
arch => ['lib', 'perl5', $arch],
bin => ['bin'],
script => ['bin'],
bindoc => ['man', 'man1'],
libdoc => ['man', 'man3'],
binhtml => ['html'],
libhtml => ['html'],
};
$p->{prefix_relpaths} =
{
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;
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
}
}
}
sub cull_args {
my $self = shift;
my @arg_list = @_;
unshift @arg_list, $self->split_like_shell($ENV{PERL_MB_OPT})
if $ENV{PERL_MB_OPT};
my ($args, $action) = $self->read_args(@arg_list);
$self->merge_args($action, %$args);
$self->merge_modulebuildrc( $action, %$args );
}
sub super_classes {
my ($self, $class, $seen) = @_;
$class ||= ref($self) || $self;
$seen ||= {};
no strict 'refs';
my @super = grep {not $seen->{$_}++} $class, @{ $class . '::ISA' };
return @super, map {$self->super_classes($_,$seen)} @super;
}
sub known_actions {
my ($self) = @_;
my %actions;
no strict 'refs';
foreach my $class ($self->super_classes) {
foreach ( keys %{ $class . '::' } ) {
$actions{$1}++ if /^ACTION_(\w+)/;
}
}
return wantarray ? sort keys %actions : \%actions;
}
sub get_action_docs {
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 and determine the style
my $style;
while (<$fh>) {
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;
}
}
$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) {
$@ = "Couldn't find any documentation to search";
return;
}
unless (@docs) {
$@ = "Couldn't find any docs for action '$action'";
return;
}
return join '', @docs;
}
sub ACTION_prereq_report {
my $self = shift;
$self->log_info( $self->prereq_report );
}
sub ACTION_prereq_data {
my $self = shift;
$self->log_info( Module::Build::Dumper->_data_dump( $self->prereq_data ) );
}
sub prereq_data {
my $self = shift;
my @types = ('configure_requires', @{ $self->prereq_action_types } );
my $info = { map { $_ => $self->$_() } grep { %{$self->$_()} } @types };
return $info;
}
sub prereq_report {
my $self = shift;
my $info = $self->prereq_data;
my $output = '';
foreach my $type (keys %$info) {
my $prereqs = $info->{$type};
$output .= "\n$type:\n";
my $mod_len = 2;
my $ver_len = 4;
my %mods;
while ( my ($modname, $spec) = each %$prereqs ) {
my $len = length $modname;
$mod_len = $len if $len > $mod_len;
$spec ||= '0';
$len = length $spec;
$ver_len = $len if $len > $ver_len;
my $mod = $self->check_installed_status($modname, $spec);
$mod->{name} = $modname;
$mod->{ok} ||= 0;
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
}
}
else {
$self->run_test_harness($tests);
}
}
else {
$self->log_info("No tests defined.\n");
}
$self->run_visual_script;
}
sub run_tap_harness {
my ($self, $tests) = @_;
require TAP::Harness;
# TODO allow the test @INC to be set via our API?
my $aggregate = TAP::Harness->new({
lib => [@INC],
verbosity => $self->{properties}{verbose},
switches => [ $self->harness_switches ],
%{ $self->tap_harness_args },
})->runtests(@$tests);
return $aggregate;
}
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;
Test::Harness::runtests(@$tests);
}
sub run_visual_script {
my $self = shift;
# This will get run and the user will see the output. It doesn't
# emit Test::Harness-style output.
$self->run_perl_script('visual.pl', '-Mblib='.$self->blib)
if -e 'visual.pl';
}
sub harness_switches {
shift->{properties}{debugger} ? qw(-w -d) : ();
}
sub test_files {
my $self = shift;
my $p = $self->{properties};
if (@_) {
return $p->{test_files} = (@_ == 1 ? shift : [@_]);
}
return $self->find_test_files;
}
sub expand_test_dir {
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";
( run in 1.655 second using v1.01-cache-2.11-cpan-0068ddc7af1 )