Acme-Sort-Sleep
view release on metacpan or search on metacpan
local/bin/config_data view on Meta::CPAN
desc => "Set a feature to 'true' or 'false'"},
set_config => {type => '=s%',
desc => 'Set a config option to the given value'},
eval => {type => '',
desc => 'eval() config values before setting'},
help => {type => '',
desc => 'Print a help message and exit'},
);
my %opts;
GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs);
print usage(%opt_defs) and exit(0)
if $opts{help};
my @exclusive = qw(feature config set_feature set_config);
die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs)
unless grep(exists $opts{$_}, @exclusive) == 1;
die "Option --module is required\n" . usage(%opt_defs)
unless $opts{module};
local/lib/perl5/Future.pm view on Meta::CPAN
$self->{failure} = [ $immediate_fail->failure ];
$self->_mark_ready( "needs_all" );
return $self;
}
my $pending = 0;
$_->{ready} or $pending++ for @subs;
# Look for immediate done
if( !$pending ) {
$self->{result} = [ map { $_->get } @subs ];
$self->_mark_ready( "needs_all" );
return $self;
}
weaken( my $weakself = $self );
my $sub_on_ready = sub {
return unless $weakself;
return if $weakself->{result} or $weakself->{failure}; # don't recurse on child ->cancel
if( $_[0]->{cancelled} ) {
local/lib/perl5/Future.pm view on Meta::CPAN
$weakself->{failure} = \@failure;
foreach my $sub ( @subs ) {
$sub->cancel if !$sub->{ready};
}
$weakself->_mark_ready( "needs_all" );
}
else {
$pending--;
$pending and return;
$weakself->{result} = [ map { $_->get } @subs ];
$weakself->_mark_ready( "needs_all" );
}
};
foreach my $sub ( @subs ) {
$sub->{ready} or $sub->on_ready( $sub_on_ready );
}
return $self;
}
local/lib/perl5/Future/Phrasebook.pod view on Meta::CPAN
sub WALK
{
my @more = ( $root );
while( @more ) {
my $item = shift @more;
...
unshift @more, CHILDREN($item)
}
}
This arrangement then allows us to use C<fmap_void> to walk this structure
using Futures, possibly concurrently. A lexical array variable is captured
that holds the stack of remaining items, which is captured by the item code so
it can C<unshift> more into it, while also being used as the actual C<fmap>
control array.
my @more = ( $root );
my $f = fmap_void {
my $item = shift;
...->on_done( sub {
unshift @more, @CHILDREN;
})
} foreach => \@more;
By choosing to either C<unshift> or C<push> more items onto this list, the
tree can be walked in either depth-first or breadth-first order.
=head1 SHORT-CIRCUITING
local/lib/perl5/Future/Phrasebook.pod view on Meta::CPAN
my $f = Future->needs_all( FIRST_A(), FIRST_B() )
->then( sub { SECOND( @_ ) } );
The C<get> method of a C<needs_all> convergent Future returns a concatenated
list of the results of all its component Futures, as the only way it will
succeed is if all the components do.
=head2 Waiting on Multiple Calls of One Function
Because the C<wait_all> and C<needs_all> constructors take an entire list of
C<Future> instances, they can be conveniently used with C<map> to wait on the
result of calling a function concurrently once per item in a list.
my @RESULT = map { FUNC( $_ ) } @ITEMS;
PROCESS( @RESULT );
Again, the C<needs_all> version allows more convenient access to the list of
results.
my $f = Future->needs_all( map { F_FUNC( $_ ) } @ITEMS )
->then( sub {
my @RESULT = @_;
F_PROCESS( @RESULT )
} );
This form of the code starts every item's future concurrently, then waits for
all of them. If the list of C<@ITEMS> is potentially large, this may cause a
problem due to too many items running at once. Instead, the
C<Future::Utils::fmap> family of functions can be used to bound the
concurrency, keeping at most some given number of items running, starting new
ones as existing ones complete.
my $f = fmap {
my $item = shift;
F_FUNC( $item )
} foreach => \@ITEMS;
By itself, this will not actually act concurrently as it will only keep one
Future outstanding at a time. The C<concurrent> flag lets it keep a larger
number "in flight" at any one time:
my $f = fmap {
my $item = shift;
F_FUNC( $item )
} foreach => \@ITEMS, concurrent => 10;
The C<fmap> and C<fmap_scalar> functions return a Future that will eventually
give the collected results of the individual item futures, thus making them
similar to perl's C<map> operator.
Sometimes, no result is required, and the items are run in a loop simply for
some side-effect of the body.
foreach my $item ( @ITEMS ) {
FUNC( $item );
}
To avoid having to collect a potentially-large set of results only to throw
them away, the C<fmap_void> function variant of the C<fmap> family yields a
Future that completes with no result after all the items are complete.
my $f = fmap_void {
my $item = shift;
F_FIRST( $item )
} foreach => \@ITEMS, concurrent => 10;
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
}
our @EXPORT_OK = qw(
call
call_with_escape
repeat
try_repeat try_repeat_until_success
repeat_until_success
fmap fmap_concat
fmap1 fmap_scalar
fmap0 fmap_void
);
use Carp;
our @CARP_NOT = qw( Future );
use Future;
=head1 NAME
C<Future::Utils> - utility functions for working with C<Future> objects
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
};
my $eventual_f = try_repeat_until_success {
my $item = shift;
...
return $trial_f;
} foreach => \@items;
Z<>
use Future::Utils qw( fmap_concat fmap_scalar fmap_void );
my $result_f = fmap_concat {
my $item = shift;
...
return $item_f;
} foreach => \@items, concurrent => 4;
my $result_f = fmap_scalar {
my $item = shift;
...
return $item_f;
} foreach => \@items, concurrent => 8;
my $done_f = fmap_void {
my $item = shift;
...
return $item_f;
} foreach => \@items, concurrent => 10;
Unless otherwise noted, the following functions require at least version
I<0.08>.
=cut
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
# defeat prototype
&try_repeat( $code, while => sub { shift->failure }, %args );
}
# Legacy name
*repeat_until_success = \&try_repeat_until_success;
=head1 APPLYING A FUNCTION TO A LIST
The C<fmap> family of functions provide a way to call a block of code that
returns a L<Future> (called here an "item future") once per item in a given
list, or returned by a generator function. The C<fmap*> functions themselves
return a C<Future> to represent the ongoing operation, which completes when
every item's future has completed.
While this behaviour can also be implemented using C<repeat>, the main reason
to use an C<fmap> function is that the individual item operations are
considered as independent, and thus more than one can be outstanding
concurrently. An argument can be passed to the function to indicate how many
items to start initially, and thereafter it will keep that many of them
running concurrently until all of the items are done, or until any of them
fail. If an individual item future fails, the overall result future will be
marked as failing with the same failure, and any other pending item futures
that are outstanding at the time will be cancelled.
The following named arguments are common to each C<fmap*> function:
=over 8
=item foreach => ARRAY
Provides the list of items to iterate over, as an C<ARRAY> reference.
The referenced array will be modified by this operation, C<shift>ing one item
from it each time. The can C<push> more items to this array as it runs, and
they will be included in the iteration.
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
In each case, the main code block will be called once for each item in the
list, passing in the item as the only argument:
$item_f = $code->( $item )
The expected return value from each item's future, and the value returned from
the result future will differ in each function's case; they are documented
below.
For similarity with perl's core C<map> function, the item is also available
aliased as C<$_>.
=cut
# This function is invoked in two circumstances:
# a) to create an item Future in a slot,
# b) once a non-immediate item Future is complete, to check its results
# It can tell which circumstance by whether the slot itself is defined or not
sub _fmap_slot
{
my ( $slots, undef, $code, $generator, $collect, $results, $return ) = @_;
SLOT: while(1) {
# Capture args each call because we mutate them
my ( undef, $idx ) = my @args = @_;
unless( $slots->[$idx] ) {
# No item Future yet (case a), so create one
my $item;
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
my $r = \$results->[-1];
$f->on_done( sub { $$r = $_[0] });
}
}
my $f = $slots->[$idx];
# Slot is non-immediate; arrange for us to be invoked again later when it's ready
if( !$f->is_ready ) {
$args[-1] = ( $return ||= $f->new );
$f->on_done( sub { _fmap_slot( @args ) } );
$f->on_fail( $return );
# Try looking for more that might be ready
my $i = $idx + 1;
while( $i != $idx ) {
$i++;
$i %= @$slots;
next if defined $slots->[$i];
$_[1] = $i;
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
$return ||= $f->new;
$return->fail( $f->failure );
return $return;
}
undef $slots->[$idx];
# next
}
}
sub _fmap
{
my $code = shift;
my %args = @_;
my $concurrent = $args{concurrent} || 1;
my @slots;
my $results = [];
my $future = $args{return};
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
}
elsif( my $array = $args{foreach} ) {
$generator = sub { return unless @$array; shift @$array };
}
else {
croak "Expected either 'generate' or 'foreach'";
}
# If any of these immediately fail, don't bother continuing
foreach my $idx ( 0 .. $concurrent-1 ) {
$future = _fmap_slot( \@slots, $idx, $code, $generator, $args{collect}, $results, $future );
last if $future->is_ready;
}
$future->on_fail( sub {
!defined $_ or $_->is_ready or $_->cancel for @slots;
});
$future->on_cancel( sub {
$_->cancel for @slots;
});
return $future;
}
=head2 fmap_concat
$future = fmap_concat { CODE } ...
I<Since version 0.14.>
This version of C<fmap> expects each item future to return a list of zero or
more values, and the overall result will be the concatenation of all these
results. It acts like a future-based equivalent to Perl's C<map> operator.
The results are returned in the order of the original input values, not in the
order their futures complete in. Because of the intermediate storage of
C<ARRAY> references and final flattening operation used to implement this
behaviour, this function is slightly less efficient than C<fmap_scalar> or
C<fmap_void> in cases where item futures are expected only ever to return one,
or zero values, respectively.
This function is also available under the name of simply C<fmap> to emphasise
its similarity to perl's C<map> keyword.
=cut
sub fmap_concat(&@)
{
my $code = shift;
my %args = @_;
_fmap( $code, %args, collect => "array" )->then( sub {
return Future->done( map { @$_ } @_ );
});
}
*fmap = \&fmap_concat;
=head2 fmap_scalar
$future = fmap_scalar { CODE } ...
I<Since version 0.14.>
This version of C<fmap> acts more like the C<map> functions found in Scheme or
Haskell; it expects that each item future returns only one value, and the
overall result will be a list containing these, in order of the original input
items. If an item future returns more than one value the others will be
discarded. If it returns no value, then C<undef> will be substituted in its
place so that the result list remains in correspondence with the input list.
This function is also available under the shorter name of C<fmap1>.
=cut
sub fmap_scalar(&@)
{
my $code = shift;
my %args = @_;
_fmap( $code, %args, collect => "scalar" )
}
*fmap1 = \&fmap_scalar;
=head2 fmap_void
$future = fmap_void { CODE } ...
I<Since version 0.14.>
This version of C<fmap> does not collect any results from its item futures, it
simply waits for them all to complete. Its result future will provide no
values.
While not a map in the strictest sense, this variant is still useful as a way
to control concurrency of a function call iterating over a list of items,
obtaining its results by some other means (such as side-effects on captured
variables, or some external system).
This function is also available under the shorter name of C<fmap0>.
=cut
sub fmap_void(&@)
{
my $code = shift;
my %args = @_;
_fmap( $code, %args, collect => "void" )
}
*fmap0 = \&fmap_void;
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
0x55AA;
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
# some operating systems ignore this position, expecting it to indeed be
# the primary GID.
# See
# https://rt.cpan.org/Ticket/Display.html?id=65127
@groups = grep { $_ != $gid } @groups;
$) = "$gid $gid " . join " ", @groups; my $saved_errno = $!;
# No easy way to detect success or failure. Just check that we have all and
# only the right groups
my %gotgroups = map { $_ => 1 } split ' ', "$)";
$! = $saved_errno;
$gotgroups{$_}-- or return undef for @groups;
keys %gotgroups or return undef;
return 1;
}
# Internal constructor
sub new
local/lib/perl5/IO/Async/Debug.pm view on Meta::CPAN
use strict;
use warnings;
our $VERSION = '0.70';
our $DEBUG = $ENV{IO_ASYNC_DEBUG} || 0;
our $DEBUG_FD = $ENV{IO_ASYNC_DEBUG_FD};
our $DEBUG_FILE = $ENV{IO_ASYNC_DEBUG_FILE};
our $DEBUG_FH;
our %DEBUG_FLAGS = map { $_ => 1 } split m/,/, $ENV{IO_ASYNC_DEBUG_FLAGS} || "";
=head1 NAME
C<IO::Async::Debug> - debugging control and support for L<IO::Async>
=head1 DESCRIPTION
The following methods and behaviours are still experimental and may change or
even be removed in future.
local/lib/perl5/IO/Async/Debug.pm view on Meta::CPAN
};
printf $DEBUG_FH $fmt, @args;
}
sub log_hexdump
{
my ( $bytes ) = @_;
foreach my $chunk ( $bytes =~ m/(.{1,16})/sg ) {
my $chunk_hex = join " ", map { sprintf "%02X", ord $_ } split //, $chunk;
( my $chunk_safe = $chunk ) =~ s/[^\x20-\x7e]/./g;
logf " | %-48s | %-16s |\n", $chunk_hex, $chunk_safe;
}
}
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
local/lib/perl5/IO/Async/Function.pm view on Meta::CPAN
{
my $self = shift;
return scalar grep { !$_->{busy} } $self->_worker_objects;
}
sub _new_worker
{
my $self = shift;
my $worker = IO::Async::Function::Worker->new(
( map { $_ => $self->{$_} } qw( model init_code code setup exit_on_die ) ),
max_calls => $self->{max_worker_calls},
on_finish => $self->_capture_weakself( sub {
my $self = shift or return;
my ( $worker ) = @_;
return if $self->{stopping};
$self->_new_worker if $self->workers < $self->{min_workers};
local/lib/perl5/IO/Async/Handle.pm view on Meta::CPAN
sub connect
{
my $self = shift;
my %args = @_;
my $loop = $self->loop or croak "Cannot ->connect a Handle that is not in a Loop";
$self->debug_printf( "CONNECT " . join( ", ",
# These args should be stringy
( map { defined $args{$_} ? "$_=$args{$_}" : () } qw( host service family socktype protocol local_host local_service ) )
) );
return $self->loop->connect( %args, handle => $self );
}
=head1 SEE ALSO
=over 4
=item *
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
@notifiers = $loop->notifiers
Returns a list of all the notifier objects currently stored in the Loop.
=cut
sub notifiers
{
my $self = shift;
# Sort so the order remains stable under additions/removals
return map { $self->{notifiers}->{$_} } sort keys %{ $self->{notifiers} };
}
###################
# Looping support #
###################
=head1 LOOPING CONTROL
The following methods control the actual run cycle of the loop, and hence the
program.
local/lib/perl5/IO/Async/LoopTests.pm view on Meta::CPAN
undef $exitcode;
wait_for { defined $exitcode };
is( ($exitcode & 0x7f), SIGTERM, 'WTERMSIG($exitcode) after SIGTERM' );
}
my %kids;
$loop->watch_child( 0 => sub { my ( $kid ) = @_; delete $kids{$kid} } );
%kids = map { run_in_child { exit 0 } => 1 } 1 .. 3;
is( scalar keys %kids, 3, 'Waiting for 3 child processes' );
wait_for { !keys %kids };
ok( !keys %kids, 'All child processes reclaimed' );
}
=head2 control
Tests that the C<run>, C<stop>, C<loop_once> and C<loop_forever> methods
local/lib/perl5/IO/Async/OS/linux.pm view on Meta::CPAN
opendir my $fd_path, "/proc/$$/fd" or do {
warn "Cannot open /proc/$$/fd, falling back to generic method - $!";
return $class->SUPER::potentially_open_fds
};
# Skip ., .., our directory handle itself and any other cruft
# except fileno() isn't available for the handle so we'll
# end up with that in the output anyway. As long as we're
# called just before the relevant close() loop, this
# should be harmless enough.
my @fd = map { m/^([0-9]+)$/ ? $1 : () } readdir $fd_path;
closedir $fd_path;
return @fd;
}
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
local/lib/perl5/IO/Async/Resolver.pm view on Meta::CPAN
return $future;
}
}
my $future = $self->resolve(
type => "getaddrinfo",
data => [
host => $host,
service => $service,
flags => $flags,
map { exists $args{$_} ? ( $_ => $args{$_} ) : () } qw( family socktype protocol ),
],
timeout => $args{timeout},
);
$future->on_done( $args{on_resolved} ) if $args{on_resolved};
$future->on_fail( $args{on_error} ) if $args{on_error};
return $future if defined wantarray;
# Caller is not going to keep hold of the Future, so we have to ensure it
local/lib/perl5/IO/Async/Resolver.pm view on Meta::CPAN
$hints{family} = $family if defined $family;
$hints{socktype} = $socktype if defined $socktype;
$hints{protocol} = $protocol if defined $protocol;
$hints{flags} = $flags if defined $flags;
my ( $err, @addrs ) = Socket::getaddrinfo( $host, $service, \%hints );
die [ "$err", $err+0 ] if $err;
# Convert the @addrs list into a list of ARRAY refs of 5 values each
return map {
[ $_->{family}, $_->{socktype}, $_->{protocol}, $_->{addr}, $_->{canonname} ]
} @addrs;
};
register_resolver getnameinfo => sub {
my ( $addr, $flags ) = @_;
my ( $err, $host, $service ) = Socket::getnameinfo( $addr, $flags || 0 );
die [ "$err", $err+0 ] if $err;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
} 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 ) {
if (defined $exe) {
$thisperl .= $exe unless $thisperl =~ m/$exe$/i;
}
if ( -f $thisperl && $proto->_perl_is_same($thisperl) ) {
return $thisperl;
}
}
# 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";
}
# Adapted from IPC::Cmd::can_run()
sub find_command {
my ($self, $command) = @_;
if( File::Spec->file_name_is_absolute($command) ) {
return $self->_maybe_command($command);
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
return grep exists( $valid_properties{$_}{$prop} ), $class->_mb_classes;
}
sub valid_properties {
return keys %{ shift->valid_properties_defaults() };
}
sub valid_properties_defaults {
my %out;
for my $class (reverse shift->_mb_classes) {
@out{ keys %{ $valid_properties{$class} } } = map {
$_->()
} values %{ $valid_properties{$class} };
}
return \%out;
}
sub array_properties {
map { exists $additive_properties{$_}->{ARRAY} ? @{$additive_properties{$_}->{ARRAY}} : () } shift->_mb_classes;
}
sub hash_properties {
map { exists $additive_properties{$_}->{HASH} ? @{$additive_properties{$_}->{HASH}} : () } shift->_mb_classes;
}
sub add_property {
my ($class, $property) = (shift, shift);
die "Property '$property' already exists"
if $class->valid_property($property);
my %p = @_ == 1 ? ( default => shift ) : @_;
my $type = ref $p{default};
$valid_properties{$class}{$property} =
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my %seen = ($in_stack[0] => 1);
my ($current, @out);
while (@in_stack) {
next unless defined($current = shift @in_stack)
&& $current->isa('Module::Build::Base');
push @out, $current;
next if $current eq 'Module::Build::Base';
no strict 'refs';
unshift @in_stack,
map {
my $c = $_; # copy, to avoid being destructive
substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
# Canonize the :: -> main::, ::foo -> main::foo thing.
# Should I ever canonize the Foo'Bar = Foo::Bar thing?
$seen{$c}++ ? () : $c;
} @{"$current\::ISA"};
# I.e., if this class has any parents (at least, ones I've never seen
# before), push them, in order, onto the stack of classes I need to
# explore.
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
sub _unlink_on_exit {
my $self = shift;
for my $f ( @_ ) {
push @{$unlink_list_for_pid{$$}}, $f if -f $f;
}
return 1;
}
END {
for my $f ( map glob($_), @{ $unlink_list_for_pid{$$} || [] } ) {
next unless -e $f;
File::Path::rmtree($f, 0, 0);
}
}
}
sub add_to_cleanup {
my $self = shift;
my %files = map {$self->localize_file_path($_), 1} @_;
$self->{phash}{cleanup}->write(\%files);
}
sub cleanup {
my $self = shift;
my $all = $self->{phash}{cleanup}->read;
return wantarray ? sort keys %$all : keys %$all;
}
sub config_file {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
close $fh;
}
sub write_config {
my ($self) = @_;
File::Path::mkpath($self->{properties}{config_dir});
-d $self->{properties}{config_dir} or die "Can't mkdir $self->{properties}{config_dir}: $!";
my @items = @{ $self->prereq_action_types };
$self->_write_data('prereqs', { map { $_, $self->$_() } @items });
$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));
$self->{phash}{$_}->write() foreach qw(notes cleanup features auto_features config_data runtime_params);
}
{
# packfile map -- keys are guts of regular expressions; If they match,
# values are module names corresponding to the packlist
my %packlist_map = (
'^File::Spec' => 'Cwd',
'^Devel::AssertOS' => 'Devel::CheckOS',
);
sub _find_packlist {
my ($self, $inst, $mod) = @_;
my $lookup = $mod;
my $packlist = eval { $inst->packlist($lookup) };
if ( ! $packlist ) {
# try from packlist_map
while ( my ($re, $new_mod) = each %packlist_map ) {
if ( $mod =~ qr/$re/ ) {
$lookup = $new_mod;
$packlist = eval { $inst->packlist($lookup) };
last;
}
}
}
return $packlist ? $lookup : undef;
}
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
# ExtUtils::Installed is buggy about finding additions to default @INC
my $inst = eval { ExtUtils::Installed->new(extra_libs => [@INC]) };
if ($@) {
$self->log_warn( << "EUI_ERROR" );
Bundling in inc/ is disabled because ExtUtils::Installed could not
create a list of your installed modules. Here is the error:
$@
EUI_ERROR
return;
}
my @bundle_list = map { [ $_, 0 ] } inc::latest->loaded_modules;
# XXX TODO: Need to get ordering of prerequisites correct so they are
# are loaded in the right order. Use an actual tree?!
while( @bundle_list ) {
my ($mod, $prereq) = @{ shift @bundle_list };
# XXX TODO: Append prereqs to list
# skip if core or already in bundle or preload lists
# push @bundle_list, [$_, 1] for prereqs()
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
sub check_autofeatures {
my ($self) = @_;
my $features = $self->auto_features;
return 1 unless %$features;
# TODO refactor into ::Util
my $longest = sub {
my @str = @_ or croak("no strings given");
my @len = map({length($_)} @str);
my $max = 0;
my $longest;
for my $i (0..$#len) {
($max, $longest) = ($len[$i], $str[$i]) if($len[$i] > $max);
}
return($longest);
};
my $max_name_len = length($longest->(keys %$features));
my ($num_disabled, $log_text) = (0, "\nChecking optional features...\n");
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
$self->log_verbose("Adding to $type\: $module => $version\n");
$p->{$type}{$module} = $version;
return 1;
}
sub prereq_failures {
my ($self, $info) = @_;
my @types = @{ $self->prereq_action_types };
$info ||= {map {$_, $self->$_()} @types};
my $out;
foreach my $type (@types) {
my $prereqs = $info->{$type};
for my $modname ( keys %$prereqs ) {
my $spec = $prereqs->{$modname};
my $status = $self->check_installed_status($modname, $spec);
if ($type =~ /^(?:\w+_)?conflicts$/) {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
if ($status->{ok}) {
return $status->{have} if $status->{have} and "$status->{have}" ne '<none>';
return '0 but true';
}
$@ = $status->{message};
return 0;
}
sub make_executable {
# Perl's chmod() is mapped to useful things on various non-Unix
# platforms, so we use it in the base class even though it looks
# Unixish.
my $self = shift;
foreach (@_) {
my $current_mode = (stat $_)[2];
chmod $current_mode | oct(111), $_;
}
}
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my $closedata="";
my $config_requires;
if ( -f $self->metafile ) {
my $meta = eval { $self->read_metafile( $self->metafile ) };
$config_requires = $meta && $meta->{prereqs}{configure}{requires}{'Module::Build'};
}
$config_requires ||= 0;
my %q = map {$_, $self->$_()} qw(config_dir base_dir);
$q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish;
$q{magic_numfile} = $self->config_file('magicnum');
my @myINC = $self->_added_to_INC;
for (@myINC, values %q) {
$_ = File::Spec->canonpath( $_ ) unless $self->is_vmsish;
s/([\\\'])/\\$1/g;
}
my $quoted_INC = join ",\n", map " '$_'", @myINC;
my $shebang = $self->_startperl;
my $magic_number = $self->magic_number;
print $fh <<EOF;
$shebang
use strict;
use Cwd;
use File::Basename;
use File::Spec;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
sub create_build_script {
my ($self) = @_;
$self->write_config;
$self->create_mymeta;
# Create Build
my ($build_script, $dist_name, $dist_version)
= map $self->$_(), qw(build_script dist_name dist_version);
if ( $self->delete_filetree($build_script) ) {
$self->log_verbose("Removed previous script '$build_script'\n");
}
$self->log_info("Creating new '$build_script' script for ",
"'$dist_name' version '$dist_version'\n");
open(my $fh, '>', $build_script) or die "Can't create '$build_script': $!";
$self->print_build_script($fh);
close $fh;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
return $args, @ARGV;
}
sub unparse_args {
my ($self, $args) = @_;
my @out;
foreach my $k (sort keys %$args) {
my $v = $args->{$k};
push @out, (ref $v eq 'HASH' ? map {+"--$k", "$_=$v->{$_}"} sort keys %$v :
ref $v eq 'ARRAY' ? map {+"--$k", $_} @$v :
("--$k", $v));
}
return @out;
}
sub args {
my $self = shift;
return wantarray ? %{ $self->{args} } : $self->{args} unless @_;
my $key = shift;
$self->{args}{$key} = shift if @_;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
use_tap_harness
tap_harness_args
cpan_client
pureperl_only
allow_pureperl
); # normalize only selected option names
return $opt;
}
my %singular_argument = map { ($_ => 1) } qw/install_base prefix destdir installdirs verbose quiet uninst debug sign/;
sub _read_arg {
my ($self, $args, $key, $val) = @_;
$key = $self->_translate_option($key);
if ( exists $args->{$key} and not $singular_argument{$key} ) {
$args->{$key} = [ $args->{$key} ] unless ref $args->{$key};
push @{$args->{$key}}, $val;
} else {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
# Look for a home directory on various systems.
sub _home_dir {
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 ) {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my( $self, $action, %cmdline_opts ) = @_;
my %rc_opts = $self->read_modulebuildrc( $action || $self->{action} || 'build' );
my %new_opts = $self->_merge_arglist( \%cmdline_opts, \%rc_opts );
$self->merge_args( $action, %new_opts );
}
sub merge_args {
my ($self, $action, %args) = @_;
$self->{action} = $action if defined $action;
my %additive = map { $_ => 1 } $self->hash_properties;
# Extract our 'properties' from $cmd_args, the rest are put in 'args'.
while (my ($key, $val) = each %args) {
$self->{phash}{runtime_params}->access( $key => $val )
if $self->valid_property($key);
if ($key eq 'config') {
$self->config($_ => $val->{$_}) foreach keys %$val;
} else {
my $add_to = $additive{$key} ? $self->{properties}{$key} :
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
$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 . '::' } ) {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
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 (sort keys %$info) {
my $prereqs = $info->{$type};
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
print "\nRun `Build help <action>` for details on an individual action.\n";
print "See `perldoc Module::Build` for complete documentation.\n";
}
sub _action_listing {
my ($self, $actions) = @_;
# Flow down columns, not across rows
my @actions = sort keys %$actions;
@actions = map $actions[($_ + ($_ % 2) * @actions) / 2], 0..$#actions;
my $out = '';
while (my ($one, $two) = splice @actions, 0, 2) {
$out .= sprintf(" %-12s %-12s\n", $one, $two||'');
}
$out =~ s{\s*$}{}mg; # remove trailing spaces
return $out;
}
sub ACTION_retest {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
default => $p->{test_file_exts},
(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} = [ map { ref $_ ? @$_ : $_ } @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
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
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) = @_;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
from => $file, to => File::Spec->catfile( $share_prefix, $files->{$file} )
);
}
}
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 ( sort 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;
}
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
$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 (ref $files eq 'ARRAY') {
return { map {$_, [/^(.*)\.PL$/]}
map $self->localize_file_path($_),
@$files };
} elsif (ref $files eq '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 = [sort keys %$files] if ref $files eq '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 {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my @rootdirs = ($type eq 'bin') ? qw(bin) :
$self->installdirs eq 'core' ? qw(lib) : qw(site lib);
my $podroot = $ENV{PERL_CORE}
? File::Basename::dirname($ENV{PERL_CORE})
: $self->original_prefix('core');
my $htmlroot = $self->install_sets('core')->{libhtml};
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) );
$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]),''
);
my ($with_ActiveState, $htmltool);
if ( $with_ActiveState = $self->_is_ActivePerl
&& eval { require ActivePerl::DocTools::Pod; 1 }
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
if ( $with_ActiveState ) {
my $depth = @rootdirs + @dirs;
my %opts = ( infile => $infile,
outfile => $tmpfile,
( defined($podpath) ? (podpath => $podpath) : ()),
podroot => $podroot,
index => 1,
depth => $depth,
);
eval {
ActivePerl::DocTools::Pod::pod2html(map { ($_, $opts{$_}) } sort keys %opts);
1;
} or $self->log_warn("[$htmltool] pod2html (" .
join(", ", map { "q{$_} => q{$opts{$_}}" } (sort keys %opts)) . ") failed: $@");
} else {
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) );
$title .= " - $abstract" if $abstract;
my @opts = (
"--title=$title",
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
push( @opts, ('--header', '--backlink') );
} elsif ( eval{Pod::Html->VERSION(1.03)} ) {
push( @opts, ('--header', '--backlink=Back to Top') );
}
$self->log_verbose("P::H::pod2html @opts\n");
{
my $orig = Cwd::getcwd();
eval { Pod::Html::pod2html(@opts); 1 }
or $self->log_warn("[$htmltool] pod2html( " .
join(", ", map { "q{$_}" } @opts) . ") failed: $@");
chdir($orig);
}
}
# We now have to cleanup the resulting html file
if ( ! -r $tmpfile ) {
$errors++;
next POD;
}
open(my $fh, '<', $tmpfile) or die "Can't read $tmpfile: $!";
my $html = join('',<$fh>);
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
# For systems that don't have 'diff' executable, should use Algorithm::Diff
sub ACTION_diff {
my $self = shift;
$self->depends_on('build');
my $local_lib = File::Spec->rel2abs('lib');
my @myINC = grep {$_ ne $local_lib} @INC;
# The actual install destination might not be in @INC, so check there too.
push @myINC, map $self->install_destination($_), qw(lib arch);
my @flags = @{$self->{args}{ARGV}};
@flags = $self->split_like_shell($self->{args}{flags} || '') unless @flags;
my $installmap = $self->install_map;
delete $installmap->{read};
delete $installmap->{write};
my $text_suffix = $self->file_qr('\.(pm|pod)$');
foreach my $localdir (sort keys %$installmap) {
my @localparts = File::Spec->splitdir($localdir);
my $files = $self->rscan_dir($localdir, sub {-f});
foreach my $file (@$files) {
my @parts = File::Spec->splitdir($file);
@parts = @parts[@localparts .. $#parts]; # Get rid of blib/lib or similar
my $installed = Module::Metadata->find_module_by_name(
join('::', @parts), \@myINC );
if (not $installed) {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
sub ACTION_install {
my ($self) = @_;
require ExtUtils::Install;
$self->depends_on('build');
# 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 {
ExtUtils::Install::install(
$self->install_map, $self->verbose, 0, $self->{args}{uninst}||0
);
});
if ($self->_is_ActivePerl && $self->{_completed_actions}{html}) {
$self->log_info("Building ActivePerl Table of Contents\n");
eval { ActivePerl::DocTools::WriteTOC(verbose => $self->verbose ? 1 : 0); 1; }
or $self->log_warn("AP::DT:: WriteTOC() failed: $@");
}
if ($self->_is_ActivePPM) {
# We touch 'lib/perllocal.pod'. There is an existing logic in subroutine _init_db()
# of 'ActivePerl/PPM/InstallArea.pm' that says that if 'lib/perllocal.pod' has a 'date-last-touched'
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
require ExtUtils::Install;
my $eui_version = ExtUtils::Install->VERSION;
if ( $eui_version < 1.32 ) {
$self->log_warn(
"The 'fakeinstall' action requires Extutils::Install 1.32 or later.\n"
. "(You only have version $eui_version)."
);
return;
}
$self->depends_on('build');
ExtUtils::Install::install($self->install_map, !$self->quiet, 1, $self->{args}{uninst}||0);
}
sub ACTION_versioninstall {
my ($self) = @_;
die "You must have only.pm 0.25 or greater installed for this operation: $@\n"
unless eval { require only; 'only'->VERSION(0.25); 1 };
$self->depends_on('build');
my %onlyargs = map {exists($self->{args}{$_}) ? ($_ => $self->{args}{$_}) : ()}
qw(version versionlib);
only::install::install(%onlyargs);
}
sub ACTION_installdeps {
my ($self) = @_;
# XXX include feature prerequisites as optional prereqs?
my $info = $self->_enum_prereqs;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my ($command, @opts) = $self->split_like_shell($self->cpan_client);
# relative command should be relative to our active Perl
# so we need to locate that command
if ( ! File::Spec->file_name_is_absolute( $command ) ) {
# prefer site to vendor to core
my @loc = ( 'site', 'vendor', '' );
my @bindirs = File::Basename::dirname($self->perl);
push @bindirs,
map {
($self->config->{"install${_}bin"}, $self->config->{"install${_}script"})
} @loc;
for my $d ( @bindirs ) {
my $abs_cmd = $self->find_command(File::Spec->catfile( $d, $command ));
if ( defined $abs_cmd ) {
$command = $abs_cmd;
last;
}
}
}
$self->do_system($command, @opts, @install);
}
sub ACTION_clean {
my ($self) = @_;
$self->log_info("Cleaning up build files\n");
foreach my $item (map glob($_), $self->cleanup) {
$self->delete_filetree($item);
}
}
sub ACTION_realclean {
my ($self) = @_;
$self->depends_on('clean');
$self->log_info("Cleaning up configuration files\n");
$self->delete_filetree(
$self->config_dir, $self->mymetafile, $self->mymetafile2, $self->build_script
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my $mode = (stat $manifest)[2];
chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!";
open(my $fh, '<', $manifest) or die "Can't read $manifest: $!";
my $last_line = (<$fh>)[-1] || "\n";
my $has_newline = $last_line =~ /\n$/;
close $fh;
open($fh, '>>', $manifest) or die "Can't write to $manifest: $!";
print $fh "\n" unless $has_newline;
print $fh map "$_\n", @$lines;
close $fh;
chmod($mode, $manifest);
$self->log_verbose(map "Added to $manifest: $_\n", @$lines);
}
sub _sign_dir {
my ($self, $dir) = @_;
unless (eval { require Module::Signature; 1 }) {
$self->log_warn("Couldn't load Module::Signature for 'distsign' action:\n $@\n");
return;
}
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
sub script_files {
my $self = shift;
for ($self->{properties}{script_files}) {
$_ = shift if @_;
next unless $_;
# Always coerce into a hash
return $_ if ref $_ eq 'HASH';
return $_ = { map {$_,1} @$_ } if ref $_ eq 'ARRAY';
die "'script_files' must be a hashref, arrayref, or string" if ref();
return $_ = { map {$_,1} $self->_files_in( $_ ) } if -d $_;
return $_ = {$_ => 1};
}
my %pl_files = map {
File::Spec->canonpath( $_ ) => 1
} keys %{ $self->PL_files || {} };
my @bin_files = $self->_files_in('bin');
my %bin_map = map {
$_ => File::Spec->canonpath( $_ )
} @bin_files;
return $_ = { map {$_ => 1} grep !$pl_files{$bin_map{$_}}, @bin_files };
}
BEGIN { *scripts = \&script_files; }
{
my %licenses = (
perl => 'Perl_5',
apache => 'Apache_2_0',
apache_1_1 => 'Apache_1_1',
artistic => 'Artistic_1',
artistic_2 => 'Artistic_2',
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
LICENSE: for my $l ( $self->valid_licenses->{ $license }, $license ) {
next unless defined $l;
my $trial = "Software::License::" . $l;
if ( eval "require Software::License; Software::License->VERSION(0.014); require $trial; 1" ) {
return $trial;
}
}
return;
}
# use mapping or license name directly
sub _software_license_object {
my ($self) = @_;
return unless defined( my $license = $self->license );
my $class = $self->_software_license_class($license) or return;
# Software::License requires a 'holder' argument
my $author = join( " & ", @{ $self->dist_author }) || 'unknown';
my $sl = eval { $class->new({holder=>$author}) };
if ( $@ ) {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
# normalize string tuples without "v": "1.2.3" -> "v1.2.3"
$version = "v$version";
}
else {
# leave alone
}
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/runtime recommends/ ],
conflicts => [ qw/runtime conflicts/ ],
);
sub _normalize_prereqs {
my ($self) = @_;
my $p = $self->{properties};
# 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} and keys %{ $p->{$type} }) {
my ($phase, $relation) = @{ $prereq_map{$type} };
for my $mod ( keys %{ $p->{$type} } ) {
$prereq_types{$phase}{$relation}{$mod} = $self->normalize_version($p->{$type}{$mod});
}
}
}
return \%prereq_types;
}
sub _get_license {
my $self = shift;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my $self = shift;
# Only packages in .pm files are candidates for inclusion here.
# Only include things in the MANIFEST, not things in developer's
# private stock.
my $manifest = $self->_read_manifest('MANIFEST')
or die "Can't find dist packages without a MANIFEST file\nRun 'Build manifest' to generate one\n";
# Localize
my %dist_files = map { $self->localize_file_path($_) => $_ }
keys %$manifest;
my @pm_files = sort grep { $_ !~ m{^t} } # skip things in t/
grep {exists $dist_files{$_}}
keys %{ $self->find_pm_files };
return $self->find_packages_in_files(\@pm_files, \%dist_files);
}
# XXX Do not document this function; mst wrote it and now says the API is
# stupid and needs to be fixed and it shouldn't become a public API until then
sub find_packages_in_files {
my ($self, $file_list, $filename_map) = @_;
# First, we enumerate all packages & versions,
# separating into primary & alternative candidates
my( %prime, %alt );
foreach my $file (@{$file_list}) {
my $mapped_filename = $filename_map->{$file};
my @path = split( /\//, $mapped_filename );
(my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//;
my $pm_info = Module::Metadata->new_from_file( $file );
foreach my $package ( $pm_info->packages_inside ) {
next if $package eq 'main'; # main can appear numerous times, ignore
next if $package eq 'DB'; # special debugging package, ignore
next if grep /^_/, split( /::/, $package ); # private package, ignore
my $version = $pm_info->version( $package );
if ( $package eq $prime_package ) {
if ( exists( $prime{$package} ) ) {
# Module::Metadata will handle this conflict
die "Unexpected conflict in '$package'; multiple versions found.\n";
} else {
$prime{$package}{file} = $mapped_filename;
$prime{$package}{version} = $version if defined( $version );
}
} else {
push( @{$alt{$package}}, {
file => $mapped_filename,
version => $version,
} );
}
}
}
# Then we iterate over all the packages found above, identifying conflicts
# and selecting the "best" candidate for recording the file & version
# for each package.
foreach my $package ( sort keys( %alt ) ) {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
}
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_sets {
# Usage: install_sets('site'), install_sets('site', 'lib'),
# or install_sets('site', 'lib' => $value);
my ($self, $dirs, $key, $value) = @_;
$dirs = $self->installdirs unless defined $dirs;
# update property before merging with defaults
if ( @_ == 4 && defined $dirs && defined $key) {
# $value can be undef; will mask default
$self->{properties}{install_sets}{$dirs}{$key} = $value;
}
my $map = { $self->_merge_arglist(
$self->{properties}{install_sets},
$self->_default_install_paths->{install_sets}
)};
if ( defined $dirs && defined $key ) {
return $map->{$dirs}{$key};
}
elsif ( defined $dirs ) {
return $map->{$dirs};
}
else {
croak "Can't determine installdirs for install_sets()";
}
}
sub original_prefix {
# Usage: original_prefix(), original_prefix('lib'),
# or original_prefix('lib' => $value);
my ($self, $key, $value) = @_;
# update property before merging with defaults
if ( @_ == 3 && defined $key) {
# $value can be undef; will mask default
$self->{properties}{original_prefix}{$key} = $value;
}
my $map = { $self->_merge_arglist(
$self->{properties}{original_prefix},
$self->_default_install_paths->{original_prefix}
)};
return $map unless defined $key;
return $map->{$key}
}
sub install_base_relpaths {
# Usage: install_base_relpaths(), install_base_relpaths('lib'),
# or install_base_relpaths('lib' => $value);
my $self = shift;
if ( @_ > 1 ) { # change values before merge
$self->_set_relpaths($self->{properties}{install_base_relpaths}, @_);
}
my $map = { $self->_merge_arglist(
$self->{properties}{install_base_relpaths},
$self->_default_install_paths->{install_base_relpaths}
)};
return $map unless @_;
my $relpath = $map->{$_[0]};
return defined $relpath ? File::Spec->catdir( @$relpath ) : undef;
}
# Defaults to use in case the config install paths cannot be prefixified.
sub prefix_relpaths {
# Usage: prefix_relpaths('site'), prefix_relpaths('site', 'lib'),
# or prefix_relpaths('site', 'lib' => $value);
my $self = shift;
my $installdirs = shift || $self->installdirs
or croak "Can't determine installdirs for prefix_relpaths()";
if ( @_ > 1 ) { # change values before merge
$self->{properties}{prefix_relpaths}{$installdirs} ||= {};
$self->_set_relpaths($self->{properties}{prefix_relpaths}{$installdirs}, @_);
}
my $map = {$self->_merge_arglist(
$self->{properties}{prefix_relpaths}{$installdirs},
$self->_default_install_paths->{prefix_relpaths}{$installdirs}
)};
return $map unless @_;
my $relpath = $map->{$_[0]};
return defined $relpath ? File::Spec->catdir( @$relpath ) : undef;
}
sub _set_relpaths {
my $self = shift;
my( $map, $type, $value ) = @_;
Carp::croak( 'Type argument missing' )
unless defined( $type );
# set undef if $value is literal undef()
if ( ! defined( $value ) ) {
$map->{$type} = undef;
return;
}
# 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);
my @value = split( /\//, $value );
$map->{$type} = \@value;
}
}
# Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX
sub prefix_relative {
my ($self, $type) = @_;
my $installdirs = $self->installdirs;
my $relpath = $self->install_sets($installdirs)->{$type};
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
%types = %{$self->prefix_relpaths};
} else {
%types = %{$self->install_sets($self->installdirs)};
}
%types = (%types, %{$self->install_path});
return sort keys %types;
}
sub install_map {
my ($self, $blib) = @_;
$blib ||= $self->blib;
my( %map, @skipping );
foreach my $type ($self->install_types) {
my $localdir = File::Spec->catdir( $blib, $type );
next unless -e $localdir;
# the line "...next if (($type eq 'bindoc'..." was one of many changes introduced for
# improving HTML generation on ActivePerl, see https://rt.cpan.org/Public/Bug/Display.html?id=53478
# Most changes were ok, but this particular line caused test failures in t/manifypods.t on windows,
# therefore it is commented out.
# ********* next if (($type eq 'bindoc' || $type eq 'libdoc') && not $self->is_unixish);
if (my $dest = $self->install_destination($type)) {
$map{$localdir} = $dest;
} else {
push( @skipping, $type );
}
}
$self->log_warn(
"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.
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->catfile($archdir, 'auto', @ext, '.packlist');
}
# Handle destdir
if (length(my $destdir = $self->destdir || '')) {
foreach (keys %map) {
# Need to remove volume from $map{$_} using splitpath, or else
# we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
# VMS will always have the file separate than the path.
my ($volume, $path, $file) = File::Spec->splitpath( $map{$_}, 0 );
# catdir needs a list of directories, or it will create something
# crazy like volume:[Foo.Bar.volume.Baz.Quux]
my @dirs = File::Spec->splitdir($path);
# First merge the directories
$path = File::Spec->catdir($destdir, @dirs);
# Then put the file back on if there is one.
if ($file ne '') {
$map{$_} = File::Spec->catfile($path, $file)
} else {
$map{$_} = $path;
}
}
}
$map{read} = ''; # To keep ExtUtils::Install quiet
return \%map;
}
sub depends_on {
my $self = shift;
foreach my $action (@_) {
$self->_call_action($action);
}
}
sub rscan_dir {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
filename => $file,
prototypes => 0,
output => $args{outfile},
);
} else {
# Ok, I give up. Just use backticks.
my $xsubpp = Module::Metadata->find_module_by_name('ExtUtils::xsubpp')
or die "Can't find ExtUtils::xsubpp in INC (@INC)";
my @typemaps;
push @typemaps, Module::Metadata->find_module_by_name(
'ExtUtils::typemap', \@INC
);
my $lib_typemap = Module::Metadata->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");
open(my $fh, '>', $args{outfile}) or die "Couldn't write $args{outfile}: $!";
print {$fh} $self->_backticks(@command);
close $fh;
}
}
sub split_like_shell {
my ($self, $string) = @_;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
return 0 if -M $derived > $most_recent_source;
}
return 1;
}
sub dir_contains {
my ($self, $first, $second) = @_;
# File::Spec doesn't have an easy way to check whether one directory
# is inside another, unfortunately.
($first, $second) = map File::Spec->canonpath($_), ($first, $second);
my @first_dirs = File::Spec->splitdir($first);
my @second_dirs = File::Spec->splitdir($second);
return 0 if @second_dirs < @first_dirs;
my $is_same = ( $self->_case_tolerant
? sub {lc(shift()) eq lc(shift())}
: sub {shift() eq shift()} );
while (@first_dirs) {
local/lib/perl5/Module/Build/Bundling.pod view on Meta::CPAN
The C<inc::latest> module creates bundled directories based on the packlist
file of an installed distribution. Even though C<inc::latest> takes module
name arguments, it is better to think of it as bundling and making
available entire I<distributions>. When a module is loaded through
C<inc::latest>, it looks in all bundled distributions in C<inc/> for a
newer module than can be found in the existing C<@INC> array.
Thus, the module-name provided should usually be the "top-level" module
name of a distribution, though this is not strictly required. For example,
L<Module::Build> has a number of heuristics to map module names to
packlists, allowing users to do things like this:
use inc::latest 'Devel::AssertOS::Unix';
even though Devel::AssertOS::Unix is contained within the Devel-CheckOS
distribution.
At the current time, packlists are required. Thus, bundling dual-core
modules, I<including Module::Build>, may require a 'forced install' over
versions in the latest version of perl in order to create the necessary
local/lib/perl5/Module/Build/Compat.pm view on Meta::CPAN
my %convert_installdirs = (
PERL => 'core',
SITE => 'site',
VENDOR => 'vendor',
);
my %makefile_to_build =
(
TEST_VERBOSE => 'verbose',
VERBINST => 'verbose',
INC => sub { map {(extra_compiler_flags => $_)} Module::Build->split_like_shell(shift) },
POLLUTE => sub { (extra_compiler_flags => '-DPERL_POLLUTE') },
INSTALLDIRS => sub { (installdirs => $convert_installdirs{uc shift()}) },
LIB => sub {
my $lib = shift;
my %config = (
installprivlib => $lib,
installsitelib => $lib,
installarchlib => "$lib/$Config{archname}",
installsitearch => "$lib/$Config{archname}"
);
return map { (config => "$_=$config{$_}") } sort keys %config;
},
# Convert INSTALLVENDORLIB and friends.
(
map {
my $name = $_;
$name => sub {
my @ret = (config => lc($name) . "=" . shift );
print STDERR "# Converted to @ret\n";
return @ret;
}
} qw(
INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH
INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB
INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN
INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT
INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR
INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR
)
),
# Some names they have in common
map {$_, lc($_)} qw(DESTDIR PREFIX INSTALL_BASE UNINST),
);
my %macro_to_build = %makefile_to_build;
# "LIB=foo make" is not the same as "perl Makefile.PL LIB=foo"
delete $macro_to_build{LIB};
sub _merge_prereq {
my ($req, $breq) = @_;
$req ||= {};
$breq ||= {};
local/lib/perl5/Module/Build/Compat.pm view on Meta::CPAN
? (NAME => $build->module_name)
: (DISTNAME => $build->dist_name));
my %version = ($build->dist_version_from
? (VERSION_FROM => $build->dist_version_from)
: (VERSION => $build->dist_version)
);
%MM_Args = (%name, %version);
%prereq = _merge_prereq( $build->requires, $build->build_requires );
%prereq = map {$_, $prereq{$_}} sort keys %prereq;
delete $prereq{perl};
$MM_Args{PREREQ_PM} = \%prereq;
$MM_Args{INSTALLDIRS} = $build->installdirs eq 'core' ? 'perl' : $build->installdirs;
$MM_Args{EXE_FILES} = [ sort keys %{$build->script_files} ] if $build->script_files;
$MM_Args{PL_FILES} = $build->PL_files || {};
local/lib/perl5/Module/Build/Compat.pm view on Meta::CPAN
use ExtUtils::MakeMaker;
WriteMakefile
$args;
EOF
}
}
sub _test_globs {
my ($self, $build) = @_;
return map { File::Spec->catfile($_, '*.t') }
@{$build->rscan_dir('t', sub { -d $File::Find::name })};
}
sub subclass_dir {
my ($self, $build) = @_;
return (Module::Metadata->find_module_dir_by_name(ref $build)
|| File::Spec->catdir($build->config_dir, 'lib'));
}
local/lib/perl5/Module/Build/Compat.pm view on Meta::CPAN
my $noop = ($class->is_windowsish ? 'rem>nul' :
$self->_is_vms_mms ? 'Continue' :
'true');
my $filetype = $class->is_vmsish ? '.COM' : '';
my $Build = 'Build' . $filetype . ' --makefile_env_macros 1';
my $unlink = $class->oneliner('1 while unlink $ARGV[0]', [], [$args{makefile}]);
$unlink =~ s/\$/\$\$/g unless $class->is_vmsish;
my $maketext = join '', map { "$_=\n" } sort keys %macro_to_build;
$maketext .= ($^O eq 'os2' ? "SHELL = sh\n\n"
: $^O eq 'MSWin32' && $Config{make} =~ /gmake/
? "SHELL = $ENV{COMSPEC}\n\n" : "\n\n");
$maketext .= <<"EOF";
all : force_do_it
$perl $Build
realclean : force_do_it
$perl $Build realclean
local/lib/perl5/Module/Build/PPMMaker.pm view on Meta::CPAN
$dist{$info} = $build->$method() or die "Can't determine distribution's $info\n";
}
$self->_simple_xml_escape($_) foreach $dist{abstract}, @{$dist{author}};
# TODO: could add <LICENSE HREF=...> tag if we knew what the URLs were for
# various licenses
my $ppd = <<"PPD";
<SOFTPKG NAME=\"$dist{name}\" VERSION=\"$dist{version}\">
<ABSTRACT>$dist{abstract}</ABSTRACT>
@{[ join "\n", map " <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
<IMPLEMENTATION>
PPD
# We don't include recommended dependencies because PPD has no way
# to distinguish them from normal dependencies. We don't include
# build_requires dependencies because the PPM installer doesn't
# build or test before installing. And obviously we don't include
# conflicts either.
foreach my $type (qw(requires)) {
local/lib/perl5/Module/Build/Platform/MacOS.pm view on Meta::CPAN
}
sub dispatch {
my $self = shift;
if( !@_ and !@ARGV ) {
require MacPerl;
# What comes first in the action list.
my @action_list = qw(build test install);
my %actions = map {+($_, 1)} $self->known_actions;
delete @actions{@action_list};
push @action_list, sort { $a cmp $b } keys %actions;
my %toolserver = map {+$_ => 1} qw(test disttest diff testdb);
foreach (@action_list) {
$_ .= ' *' if $toolserver{$_};
}
my $cmd = MacPerl::Pick("What build command? ('*' requires ToolServer)", @action_list);
return unless defined $cmd;
$cmd =~ s/ \*$//;
$ARGV[0] = ($cmd);
my $args = MacPerl::Ask('Any extra arguments? (ie. verbose=1)', '');
local/lib/perl5/Module/Build/Platform/MacOS.pm view on Meta::CPAN
sub ACTION_install {
my $self = shift;
return $self->SUPER::ACTION_install(@_)
if eval {ExtUtils::Install->VERSION('1.30'); 1};
local $^W = 0; # Avoid a 'redefine' warning
local *ExtUtils::Install::find = sub {
my ($code, @dirs) = @_;
@dirs = map { $_ eq '.' ? File::Spec->curdir : $_ } @dirs;
return File::Find::find($code, @dirs);
};
return $self->SUPER::ACTION_install(@_);
}
1;
__END__
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
# proper quoting so that the subprocess sees this same list of args,
# or if we get a single arg that is an array reference, quote the
# elements of it and return the reference.
my ($self, @args) = @_;
my $got_arrayref = (scalar(@args) == 1
&& ref $args[0] eq 'ARRAY')
? 1
: 0;
# Do not quote qualifiers that begin with '/'.
map { if (!/^\//) {
$_ =~ s/\"/""/g; # escape C<"> by doubling
$_ = q(").$_.q(");
}
}
($got_arrayref ? @{$args[0]}
: @args
);
return $got_arrayref ? $args[0]
: join(' ', @args);
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
=item ACTION_clean
The home-grown glob() expands a bit too aggressively when given a bare name,
so default in a zero-length extension.
=cut
sub ACTION_clean {
my ($self) = @_;
foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
$self->delete_filetree($item);
}
}
# Need to look up the feature settings. The preferred way is to use the
# VMS::Feature module, but that may not be available to dual life modules.
my $use_feature;
BEGIN {
local/lib/perl5/Struct/Dumb.pm view on Meta::CPAN
push @values, delete $values{$_};
}
if( my ( $extrakey ) = keys %values ) {
croak "usage: $pkg does not recognise '$extrakey'";
}
bless \@values, $pkg;
};
}
else {
my $fieldcount = @$fields;
my $argnames = join ", ", map "\$$_", @$fields;
$constructor = sub {
@_ == $fieldcount or croak "usage: $pkg($argnames)";
bless [ @_ ], $pkg;
};
}
no strict 'refs';
*{"${pkg}::$_"} = $subs{$_} for keys %subs;
*{"${caller}::$name"} = $constructor;
local/lib/perl5/Test/Future.pm view on Meta::CPAN
$code->();
my @pending = grep { !$_->is_ready } @futures;
return $tb->ok( 1, $name ) if !@pending;
my $ok = $tb->ok( 0, $name );
$tb->diag( "The following Futures are still pending:" );
$tb->diag( join ", ", map { sprintf "0x%x", refaddr $_ } @pending );
if( HAVE_DEVEL_MAT_DUMPER ) {
my $file = $0;
my $num = $tb->current_test;
# Trim the .t off first then append -$num.pmat, in case $0 wasn't a .t file
$file =~ s/\.(?:t|pm|pl)$//;
$file .= "-$num.pmat";
$tb->diag( "Writing heap dump to $file" );
( run in 0.922 second using v1.01-cache-2.11-cpan-49f99fa48dc )