Acme-Sort-Sleep
view release on metacpan or search on metacpan
local/bin/config_data view on Meta::CPAN
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};
my $cf = load_config($opts{module});
if (exists $opts{feature}) {
if (length $opts{feature}) {
print $cf->feature($opts{feature});
} else {
my %auto;
# note: need to support older ConfigData.pm's
@auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names");
print " Features defined in $cf:\n";
foreach my $name (sort $cf->feature_names) {
print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n";
}
}
} elsif (exists $opts{config}) {
require Data::Dumper;
local $Data::Dumper::Terse = 1;
if (length $opts{config}) {
print Data::Dumper::Dumper($cf->config($opts{config})), "\n";
} else {
print " Configuration defined in $cf:\n";
foreach my $name (sort $cf->config_names) {
print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n";
}
}
} elsif (exists $opts{set_feature}) {
my %to_set = %{$opts{set_feature}};
local/bin/config_data view on Meta::CPAN
$0 --module Foo::Bar --feature bazzable
$0 --module Foo::Bar --config magic_number
$0 --module Foo::Bar --set_feature bazzable=1
$0 --module Foo::Bar --set_config magic_number=42
EOF
return $out;
}
sub pad_line { $_[0] .= ' ' x ($_[1] - length($_[0]) + rindex($_[0], "\n")) }
__END__
=head1 NAME
config_data - Query or change configuration of Perl modules
=head1 SYNOPSIS
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
A variant of the C<send> method; this method pushes the byte record given.
This should be the result of a call to C<encode>.
=cut
sub send_encoded
{
my $self = shift;
my ( $record ) = @_;
my $bytes = pack( "I", length $record ) . $record;
defined $self->{mode} or die "Cannot ->send without being set up";
return $self->_send_sync( $bytes ) if $self->{mode} eq "sync";
return $self->_send_async( $bytes ) if $self->{mode} eq "async";
}
=head2 encode
$record = $channel->encode( $data )
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
# enable binmode
binmode $self->{fh};
$self->{fh}->autoflush(1);
}
sub _read_exactly
{
$_[1] = "";
while( length $_[1] < $_[2] ) {
my $n = read( $_[0], $_[1], $_[2]-length $_[1], length $_[1] );
defined $n or return undef;
$n or return "";
}
return $_[2];
}
sub _recv_sync
{
my $self = shift;
my $n = _read_exactly( $self->{fh}, my $lenbuffer, 4 );
defined $n or die "Cannot read - $!";
length $n or return undef;
my $len = unpack( "I", $lenbuffer );
$n = _read_exactly( $self->{fh}, my $record, $len );
defined $n or die "Cannot read - $!";
length $n or return undef;
return $self->{decode}->( $record );
}
sub _send_sync
{
my $self = shift;
my ( $bytes ) = @_;
$self->{fh}->print( $bytes );
}
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
my ( $stream, $buffref, $eof ) = @_;
if( $eof ) {
while( my $on_result = shift @{ $self->{on_result_queue} } ) {
$on_result->( $self, eof => );
}
$self->{on_eof}->( $self ) if $self->{on_eof};
return;
}
return 0 unless length( $$buffref ) >= 4;
my $len = unpack( "I", $$buffref );
return 0 unless length( $$buffref ) >= 4 + $len;
my $record = $self->{decode}->( substr( $$buffref, 4, $len ) );
substr( $$buffref, 0, 4 + $len ) = "";
if( my $on_result = shift @{ $self->{on_result_queue} } ) {
$on_result->( $self, recv => $record );
}
else {
$self->{on_recv}->( $self, $record );
}
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
use IO::Async::Stream;
use IO::Async::OS;
use Carp;
use Scalar::Util qw( weaken );
use POSIX qw( _exit dup dup2 nice );
use constant LENGTH_OF_I => length( pack( "I", 0 ) );
=head1 NAME
C<IO::Async::ChildManager> - facilitates the execution of child processes
=head1 SYNOPSIS
This object is used indirectly via an L<IO::Async::Loop>:
use IO::Async::Loop;
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
my $self = shift;
my ( $readpipe, $kid, $on_exit ) = @_;
my $loop = $self->{loop};
# We need to wait for both the errno pipe to close, and for waitpid
# to give us an exit code. We'll form two closures over these two
# variables so we can cope with those happening in either order
my $dollarbang;
my ( $dollarat, $length_dollarat );
my $exitcode;
my $pipeclosed = 0;
$loop->add( IO::Async::Stream->new(
notifier_name => "statuspipe,kid=$kid",
read_handle => $readpipe,
on_read => sub {
my ( $self, $buffref, $eof ) = @_;
if( !defined $dollarbang ) {
if( length( $$buffref ) >= 2 * LENGTH_OF_I ) {
( $dollarbang, $length_dollarat ) = unpack( "II", $$buffref );
substr( $$buffref, 0, 2 * LENGTH_OF_I, "" );
return 1;
}
}
elsif( !defined $dollarat ) {
if( length( $$buffref ) >= $length_dollarat ) {
$dollarat = substr( $$buffref, 0, $length_dollarat, "" );
return 1;
}
}
if( $eof ) {
$dollarbang = 0 if !defined $dollarbang;
if( !defined $length_dollarat ) {
$length_dollarat = 0;
$dollarat = "";
}
$pipeclosed = 1;
if( defined $exitcode ) {
local $! = $dollarbang;
$on_exit->( $kid, $exitcode, $!, $dollarat );
}
}
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
setgroups( @$value ) or die "Cannot setgroups() - $!";
}
}
}
$code->();
};
my $writebuffer = "";
$writebuffer .= pack( "I", $!+0 );
$writebuffer .= pack( "I", length( $@ ) ) . $@;
syswrite( $writepipe, $writebuffer );
return $exitvalue;
}
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
local/lib/perl5/IO/Async/Handle.pm view on Meta::CPAN
my $self = shift;
my ( $loop ) = @_;
$self->_watch_read(0);
$self->_watch_write(0);
}
sub notifier_name
{
my $self = shift;
if( length( my $name = $self->SUPER::notifier_name ) ) {
return $name;
}
my $r = $self->read_fileno;
my $w = $self->write_fileno;
return "rw=$r" if defined $r and defined $w and $r == $w;
return "r=$r,w=$w" if defined $r and defined $w;
return "r=$r" if defined $r;
return "w=$w" if defined $w;
return "no";
local/lib/perl5/IO/Async/Loop/Select.pm view on Meta::CPAN
my $self = shift;
my ( $readref, $writeref, $exceptref, $timeref ) = @_;
# BITWISE operations
$$readref |= $self->{rvec};
$$writeref |= $self->{wvec};
$$exceptref |= $self->{evec};
$self->_adjust_timeout( $timeref );
$$timeref = 0 if FAKE_ISREG_READY and length $self->{avec};
# Round up to nearest millisecond
if( $$timeref ) {
my $mils = $$timeref * 1000;
my $fraction = $mils - int $mils;
$$timeref += ( 1 - $fraction ) / 1000 if $fraction;
}
return;
}
local/lib/perl5/IO/Async/Notifier.pm view on Meta::CPAN
$IO::Async::Debug::DEBUG or return;
my $self = shift;
my ( $format, @args ) = @_;
my @id;
while( $self ) {
push @id, ref $self;
my $name = $self->notifier_name;
$id[-1] .= "{$name}" if defined $name and length $name;
$self = $self->parent;
}
s/^IO::Async::Protocol::/IaP:/,
s/^IO::Async::/Ia:/,
s/^Net::Async::/Na:/ for @id;
IO::Async::Debug::logf "[%s] $format\n", join("<-", @id), @args;
}
local/lib/perl5/IO/Async/PID.pm view on Meta::CPAN
{
my $self = shift;
my ( $loop ) = @_;
$loop->unwatch_child( $self->pid );
}
sub notifier_name
{
my $self = shift;
if( length( my $name = $self->SUPER::notifier_name ) ) {
return $name;
}
return $self->{pid};
}
=head1 METHODS
=cut
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
C<on_finish> is invoked instead, being passed just the exit code.
Since this is just the results of the underlying C<< $loop->spawn_child >>
C<on_exit> handler in a different order it is possible that the C<$exception>
field will be an empty string. It will however always be defined. This can be
used to distinguish the two cases:
on_exception => sub {
my ( $self, $exception, $errno, $exitcode ) = @_;
if( length $exception ) {
print STDERR "The process died with the exception $exception " .
"(errno was $errno)\n";
}
elsif( ( my $status = W_EXITSTATUS($exitcode) ) == 255 ) {
print STDERR "The process failed to exec() - $errno\n";
}
else {
print STDERR "The process exited with exit status $status\n";
}
}
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
sub DESTROY
{
my $self = shift;
$self->{finish_future}->cancel if $self->{finish_future};
}
sub notifier_name
{
my $self = shift;
if( length( my $name = $self->SUPER::notifier_name ) ) {
return $name;
}
return "nopid" unless my $pid = $self->pid;
return "[$pid]" unless $self->is_running;
return "$pid";
}
=head1 METHODS
local/lib/perl5/IO/Async/Signal.pm view on Meta::CPAN
my $self = shift;
my ( $loop ) = @_;
$loop->detach_signal( $self->{name}, $self->{id} );
undef $self->{id};
}
sub notifier_name
{
my $self = shift;
if( length( my $name = $self->SUPER::notifier_name ) ) {
return $name;
}
return $self->{name};
}
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
local/lib/perl5/IO/Async/Socket.pm view on Meta::CPAN
return if $! == EAGAIN || $! == EWOULDBLOCK || $! == EINTR;
my $errno = $!;
$self->maybe_invoke_event( on_recv_error => $errno )
or $self->close;
return;
}
if( !length $data ) {
$self->close;
return;
}
$self->invoke_event( on_recv => $data, $addr );
last unless $self->{recv_all};
}
}
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
Optional. Invoked when the C<syswrite> method on the write handle fails.
The C<on_read_error> and C<on_write_error> handlers are passed the value of
C<$!> at the time the error occured. (The C<$!> variable itself, by its
nature, may have changed from the original error by the time this handler
runs so it should always use the value passed in).
If an error occurs when the corresponding error callback is not supplied, and
there is not a handler for it, then the C<close> method is called instead.
=head2 on_read_high_watermark $length
=head2 on_read_low_watermark $length
Optional. Invoked when the read buffer grows larger than the high watermark
or smaller than the low watermark respectively. These are edge-triggered
events; they will only be triggered once per crossing, not continuously while
the buffer remains above or below the given limit.
If these event handlers are not defined, the default behaviour is to disable
read-ready notifications if the read buffer grows larger than the high
watermark (so as to avoid it growing arbitrarily if nothing is consuming it),
and re-enable notifications again once something has read enough to cause it to
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
=over 8
=item write_len => INT
Overrides the C<write_len> parameter for the data written by this call.
=item on_write => CODE
A CODE reference which will be invoked after every successful C<syswrite>
operation on the underlying filehandle. It will be passed the number of bytes
that were written by this call, which may not be the entire length of the
buffer - if it takes more than one C<syscall> operation to empty the buffer
then this callback will be invoked multiple times.
$on_write->( $stream, $len )
=item on_flush => CODE
A CODE reference which will be invoked once the data queued by this C<write>
call has been flushed. This will be invoked even if the buffer itself is not
yet empty; if more data has been queued since the call.
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
$head->data .= $second->data;
$head->on_write = $second->on_write;
$head->on_flush = $second->on_flush;
splice @$writequeue, 1, 1, ();
}
die "TODO: head data does not contain a plain string" if ref $head->data;
if( $IO::Async::Debug::DEBUG > 1 ) {
my $data = substr $head->data, 0, $head->writelen;
$self->debug_printf( "WRITE len=%d", length $data );
IO::Async::Debug::log_hexdump( $data ) if $IO::Async::Debug::DEBUG_FLAGS{Sw};
}
my $writer = $self->{writer};
my $len = $self->$writer( $self->write_handle, $head->data, $head->writelen );
if( !defined $len ) {
my $errno = $!;
if( $errno == EAGAIN or $errno == EWOULDBLOCK ) {
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
$self->maybe_invoke_event( on_write_error => $errno )
or $self->close_now;
return 0;
}
if( my $on_write = $head->on_write ) {
$on_write->( $self, $len );
}
if( !length $head->data ) {
$head->on_flush->( $self ) if $head->on_flush;
shift @{ $self->{writequeue} };
}
return 1;
}
sub write
{
my $self = shift;
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
my $ret;
if( $readqueue->[0] and my $on_read = $readqueue->[0]->on_read ) {
$ret = $on_read->( $self, \$self->{readbuff}, $eof );
}
else {
$ret = $self->invoke_event( on_read => \$self->{readbuff}, $eof );
}
if( defined $self->{read_low_watermark} and $self->{at_read_high_watermark} and
length $self->{readbuff} < $self->{read_low_watermark} ) {
undef $self->{at_read_high_watermark};
$self->invoke_event( on_read_low_watermark => length $self->{readbuff} );
}
if( ref $ret eq "CODE" ) {
# Replace the top CODE, or add it if there was none
$readqueue->[0] = Reader( $ret, undef );
return 1;
}
elsif( @$readqueue and !defined $ret ) {
shift @$readqueue;
return 1;
}
else {
return $ret && ( length( $self->{readbuff} ) > 0 || $eof );
}
}
sub _sysread
{
my $self = shift;
my ( $handle, undef, $len ) = @_;
return $handle->sysread( $_[1], $len );
}
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
foreach ( @{ $self->{readqueue} } ) {
$_->future->done( undef ) if $_->future;
}
undef @{ $self->{readqueue} };
return;
}
last unless $self->{read_all};
}
if( defined $self->{read_high_watermark} and length $self->{readbuff} >= $self->{read_high_watermark} ) {
$self->{at_read_high_watermark} or
$self->invoke_event( on_read_high_watermark => length $self->{readbuff} );
$self->{at_read_high_watermark} = 1;
}
}
sub on_read_high_watermark
{
my $self = shift;
$self->want_readready_for_read( 0 );
}
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
sub push_on_read
{
my $self = shift;
my ( $on_read, %args ) = @_;
# %args undocumented for internal use
push @{ $self->{readqueue} }, Reader( $on_read, $args{future} );
# TODO: Should this always defer?
return if $self->{flushing_read};
1 while length $self->{readbuff} and $self->_flush_one_read( 0 );
}
=head1 FUTURE-RETURNING READ METHODS
The following methods all return a L<Future> which will become ready when
enough data has been read by the Stream into its buffer. At this point, the
data is removed from the buffer and given to the C<Future> object to complete
it.
my $f = $stream->read_...
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
sub read_exactly
{
my $self = shift;
my ( $len ) = @_;
my $f = $self->_read_future;
$self->push_on_read( sub {
my ( undef, $buffref, $eof ) = @_;
return undef if $f->is_cancelled;
return 0 unless $eof or length $$buffref >= $len;
$f->done( substr( $$buffref, 0, $len, "" ), $eof );
return undef;
}, future => $f );
return $f;
}
=head2 read_until
( $string, $eof ) = $stream->read_until( $end )->get
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
=head2 Reading binary data
This C<on_read> method accepts incoming records in 16-byte chunks, printing
each one.
sub on_read
{
my ( $self, $buffref, $eof ) = @_;
if( length $$buffref >= 16 ) {
my $record = substr( $$buffref, 0, 16, "" );
print "Received a 16-byte record: $record\n";
return 1;
}
if( $eof and length $$buffref ) {
print "EOF: a partial record still exists\n";
}
return 0;
}
The 4-argument form of C<substr()> extracts the 16-byte record from the buffer
and assigns it to the C<$record> variable, if there was enough data in the
buffer to extract it.
A lot of protocols use a fixed-size header, followed by a variable-sized body
of data, whose size is given by one of the fields of the header. The following
C<on_read> method extracts messages in such a protocol.
sub on_read
{
my ( $self, $buffref, $eof ) = @_;
return 0 unless length $$buffref >= 8; # "N n n" consumes 8 bytes
my ( $len, $x, $y ) = unpack "N n n", $$buffref;
return 0 unless length $$buffref >= 8 + $len;
substr( $$buffref, 0, 8, "" );
my $data = substr( $$buffref, 0, $len, "" );
print "A record with values x=$x y=$y\n";
return 1;
}
In this example, the header is C<unpack()>ed first, to extract the body
length, and then the body is extracted. If the buffer does not have enough
data yet for a complete message then C<0> is returned, and the buffer is left
unmodified for next time. Only when there are enough bytes in total does it
use C<substr()> to remove them.
=head2 Dynamic replacement of C<on_read>
Consider the following protocol (inspired by IMAP), which consists of
C<\n>-terminated lines that may have an optional data block attached. The
presence of such a data block, as well as its size, is indicated by the line
prefix.
sub on_read
{
my $self = shift;
my ( $buffref, $eof ) = @_;
if( $$buffref =~ s/^DATA (\d+):(.*)\n// ) {
my $length = $1;
my $line = $2;
return sub {
my $self = shift;
my ( $buffref, $eof ) = @_;
return 0 unless length $$buffref >= $length;
# Take and remove the data from the buffer
my $data = substr( $$buffref, 0, $length, "" );
print "Received a line $line with some data ($data)\n";
return undef; # Restore the original method
}
}
elsif( $$buffref =~ s/^LINE:(.*)\n// ) {
my $line = $1;
print "Received a line $line with no data\n";
return 1;
}
else {
print STDERR "Unrecognised input\n";
# Handle it somehow
}
}
In the case where trailing data is supplied, a new temporary C<on_read>
callback is provided in a closure. This closure captures the C<$length>
variable so it knows how much data to expect. It also captures the C<$line>
variable so it can use it in the event report. When this method has finished
reading the data, it reports the event, then restores the original method by
returning C<undef>.
=head1 SEE ALSO
=over 4
=item *
local/lib/perl5/IO/Async/Test.pm view on Meta::CPAN
wait_for { defined $result };
is( $result, what_we_expected, 'The event happened' );
...
my $buffer = "";
my $handle = IO::Handle-> ...
wait_for_stream { length $buffer >= 10 } $handle => $buffer;
is( substr( $buffer, 0, 10, "" ), "0123456789", 'Buffer was correct' );
my $result = wait_for_future( $stream->read_until( "\n" ) )->get;
=head1 DESCRIPTION
This module provides utility functions that may be useful when writing test
scripts for code which uses L<IO::Async> (as well as being used in the
L<IO::Async> test scripts themselves).
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
# 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.
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
if ( $self->_is_unattended && !@def ) {
die <<EOF;
ERROR: This build seems to be unattended, but there is no default value
for this question. Aborting.
EOF
}
my $ans = $self->_readline();
if ( !defined($ans) # Ctrl-D or unattended
or !length($ans) ) { # User hit return
print "$dispdef[1]\n";
$ans = scalar(@def) ? $def[0] : '';
}
return $ans;
}
sub y_n {
my $self = shift;
my ($mess, $def) = @_;
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");
for my $name ( sort keys %$features ) {
$log_text .= $self->_feature_deps_msg($name, $max_name_len);
}
$num_disabled = () = $log_text =~ /disabled/g;
# warn user if features disabled
if ( $num_disabled ) {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
return 0;
}
else {
$self->log_verbose( $log_text );
return 1;
}
}
sub _feature_deps_msg {
my ($self, $name, $max_name_len) = @_;
$max_name_len ||= length $name;
my $features = $self->auto_features;
my $info = $features->{$name};
my $feature_text = "$name" . '.' x ($max_name_len - length($name) + 4);
my ($log_text, $disabled) = ('','');
if ( my $failures = $self->prereq_failures($info) ) {
$disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/,
keys %$failures ) ? 1 : 0;
$feature_text .= $disabled ? "disabled\n" : "enabled\n";
for my $type ( @{ $self->prereq_action_types } ) {
next unless exists $failures->{$type};
$feature_text .= " $type:\n";
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
return () unless $modulebuildrc;
}
open(my $fh, '<', $modulebuildrc )
or die "Can't open $modulebuildrc: $!";
my %options; my $buffer = '';
while (defined( my $line = <$fh> )) {
chomp( $line );
$line =~ s/#.*$//;
next unless length( $line );
if ( $line =~ /^\S/ ) {
if ( $buffer ) {
my( $action, $options ) = split( /\s+/, $buffer, 2 );
$options{$action} .= $options . ' ';
$buffer = '';
}
$buffer = $line;
} else {
$buffer .= $line;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my $output = '';
foreach my $type (sort keys %$info) {
my $prereqs = $info->{$type};
$output .= "\n$type:\n";
my $mod_len = 2;
my $ver_len = 4;
my %mods;
foreach my $modname (sort keys %$prereqs) {
my $spec = $prereqs->{$modname};
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;
$mod->{ok} = ! $mod->{ok} if $type =~ /^(\w+_)?conflicts$/;
$mods{lc $modname} = $mod;
}
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my $vline = q{-} x ($ver_len - 3);
my $disposition = ($type =~ /^(\w+_)?conflicts$/) ?
'Clash' : 'Need';
$output .=
" Module $space $disposition $vspace Have\n".
" ------$sline+------$vline-+----------\n";
for my $k (sort keys %mods) {
my $mod = $mods{$k};
my $space = q{ } x ($mod_len - length $k);
my $vspace = q{ } x ($ver_len - length $mod->{need});
my $f = $mod->{ok} ? ' ' : '!';
$output .=
" $f $mod->{name} $space $mod->{need} $vspace ".
(defined($mod->{have}) ? $mod->{have} : "")."\n";
}
}
return $output;
}
sub ACTION_help {
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
(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 }
) {
my $tool_v = ActiveState::DocTools::Pod->VERSION;
$htmltool = "ActiveState::DocTools::Pod";
$htmltool .= " $tool_v" if $tool_v && length $tool_v;
}
else {
require Module::Build::PodParser;
require Pod::Html;
$htmltool = "Pod::Html " . Pod::Html->VERSION;
}
$self->log_verbose("Converting Pod to HTML with $htmltool\n");
my $errors = 0;
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
else {
return File::Spec->case_tolerant;
}
}
sub _append_maniskip {
my $self = shift;
my $skip = shift;
my $file = shift || 'MANIFEST.SKIP';
return unless defined $skip && length $skip;
open(my $fh, '>>', $file)
or die "Can't open $file: $!";
print $fh "$skip\n";
close $fh;
}
sub _write_default_maniskip {
my $self = shift;
my $file = shift || 'MANIFEST.SKIP';
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my $self = shift;
my ($metafile) = @_;
return unless $self->try_require("CPAN::Meta", "2.110420");
my $meta = CPAN::Meta->load_file($metafile);
return $meta->as_struct( {version => "2.0"} );
}
sub normalize_version {
my ($self, $version) = @_;
$version = 0 unless defined $version and length $version;
if ( $version =~ /[=<>!,]/ ) { # logic, not just version
# take as is without modification
}
elsif ( ref $version eq 'version') { # version objects
$version = $version->is_qv ? $version->normal : $version->stringify;
}
elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
# normalize string tuples without "v": "1.2.3" -> "v1.2.3"
$version = "v$version";
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
my ($self, %args) = @_;
my $fatal = $args{fatal} || 0;
my $p = $self->{properties};
$self->auto_config_requires if $args{auto};
# validate required fields
foreach my $f (qw(dist_name dist_version dist_author dist_abstract license)) {
my $field = $self->$f();
unless ( defined $field and length $field ) {
my $err = "ERROR: Missing required field '$f' for metafile\n";
if ( $fatal ) {
die $err;
}
else {
$self->log_warn($err);
}
}
}
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
"See the documentation for the 'dist' action.\n";
my $files = $self->rscan_dir($dir);
# Archive::Tar versions >= 1.09 use the following to enable a compatibility
# hack so that the resulting archive is compatible with older clients.
# If no file path is 100 chars or longer, we disable the prefix field
# for maximum compatibility. If there are any long file paths then we
# need the prefix field after all.
$Archive::Tar::DO_NOT_USE_PREFIX =
(grep { length($_) >= 100 } @$files) ? 0 : 1;
my $tar = Archive::Tar->new;
$tar->add_files(@$files);
for my $f ($tar->get_files) {
$f->mode($f->mode & ~022); # chmod go-w
}
$tar->write("$file.tar.gz", 1);
}
}
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
}
# Translated from ExtUtils::MM_Unix::prefixify()
sub _prefixify {
my($self, $path, $sprefix, $type) = @_;
my $rprefix = $self->prefix;
$rprefix .= '/' if $sprefix =~ m|/$|;
$self->log_verbose(" prefixify $path from $sprefix to $rprefix\n")
if defined( $path ) && length( $path );
if( !defined( $path ) || ( length( $path ) == 0 ) ) {
$self->log_verbose(" no path to prefixify, falling back to default.\n");
return $self->_prefixify_default( $type, $rprefix );
} elsif( !File::Spec->file_name_is_absolute($path) ) {
$self->log_verbose(" path is relative, not prefixifying.\n");
} elsif( $path !~ s{^\Q$sprefix\E\b}{}s ) {
$self->log_verbose(" cannot prefixify, falling back to default.\n");
return $self->_prefixify_default( $type, $rprefix );
}
$self->log_verbose(" now $path in $rprefix\n");
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
) 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);
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
close $fh;
}
}
sub split_like_shell {
my ($self, $string) = @_;
return () unless defined($string);
return @$string if ref $string eq '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.
local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN
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 {
my $self = shift;
my %args = (@_ > 3
? ( @_ )
: ( from => shift, to_dir => shift, flatten => shift )
);
$args{verbose} = !$self->quiet
unless exists $args{verbose};
my $file = $args{from};
unless (defined $file and length $file) {
die "No 'from' parameter given to copy_if_modified";
}
# makes no sense to replicate an absolute path, so assume flatten
$args{flatten} = 1 if File::Spec->file_name_is_absolute( $file );
my $to_path;
if (defined $args{to} and length $args{to}) {
$to_path = $args{to};
} elsif (defined $args{to_dir} and length $args{to_dir}) {
$to_path = File::Spec->catfile( $args{to_dir}, $args{flatten}
? File::Basename::basename($file)
: $file );
} else {
die "No 'to' or 'to_dir' parameter given to copy_if_modified";
}
return if $self->up_to_date($file, $to_path); # Already fresh
{
local/lib/perl5/Module/Build/Compat.pm view on Meta::CPAN
return @out;
}
sub makefile_to_build_macros {
my @out;
my %config; # must accumulate and return as a hashref
foreach my $macro (sort keys %macro_to_build) {
my $trans = $macro_to_build{$macro};
# On some platforms (e.g. Cygwin with 'make'), the mere presence
# of "EXPORT: FOO" in the Makefile will make $ENV{FOO} defined.
# Therefore we check length() too.
next unless exists $ENV{$macro} && length $ENV{$macro};
my $val = $ENV{$macro};
my @args = ref($trans) ? $trans->($val) : ($trans => $val);
while (@args) {
my ($k, $v) = splice(@args, 0, 2);
if ( $k eq 'config' ) {
if ( $v =~ /^([^=]+)=(.*)$/ ) {
$config{$1} = $2;
}
else {
warn "Couldn't parse config '$v'\n";
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
$self->log_verbose(" prefixify $path from $sprefix to $rprefix\n");
# Translate $(PERLPREFIX) to a real path.
$rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
$sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
$self->log_verbose(" rprefix translated to $rprefix\n".
" sprefix translated to $sprefix\n");
if( length($path) == 0 ) {
$self->log_verbose(" no path to prefixify.\n")
}
elsif( !File::Spec->file_name_is_absolute($path) ) {
$self->log_verbose(" path is relative, not prefixifying.\n");
}
elsif( $sprefix eq $rprefix ) {
$self->log_verbose(" no new prefix.\n");
}
else {
my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
=cut
sub localize_dir_path {
my ($self, $path) = @_;
return VMS::Filespec::vmspath($path);
}
=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);
}
}
local/lib/perl5/Module/Build/Platform/Windows.pm view on Meta::CPAN
# can't use Text::ParseWords::shellwords() to break a command string
# into words. The algorithm below was bashed out by Randy and Ken
# (mostly Randy), and there are a lot of regression tests, so we
# should feel free to adjust if desired.
(my $self, local $_) = @_;
return @$_ if defined() && ref() eq 'ARRAY';
my @argv;
return @argv unless defined() && length();
my $length = length;
m/\G\s*/gc;
ARGS: until ( pos == $length ) {
my $quote_mode;
my $arg = '';
CHARS: until ( pos == $length ) {
if ( m/\G((?:\\\\)+)(?=\\?(")?)/gc ) {
if (defined $2) {
$arg .= '\\' x (length($1) / 2);
}
else {
$arg .= $1;
}
}
elsif ( m/\G\\"/gc ) {
$arg .= '"';
}
elsif ( m/\G"/gc ) {
if ( $quote_mode && m/\G"/gc ) {
local/lib/perl5/Module/Build/Platform/Windows.pm view on Meta::CPAN
# system(@cmd) does not like having double-quotes in it on Windows.
# So we quote them and run it as a single command.
sub do_system {
my ($self, @cmd) = @_;
my $cmd = $self->_quote_args(@cmd);
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;
}
# Copied from ExtUtils::MM_Win32
sub _maybe_command {
my($self,$file) = @_;
my @e = exists($ENV{'PATHEXT'})
? split(/;/, $ENV{PATHEXT})
: qw(.com .exe .bat .cmd);
( run in 1.286 second using v1.01-cache-2.11-cpan-65fba6d93b7 )