Alien-ROOT
view release on metacpan or search on metacpan
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
of a file:// is considered to the be volume specification for the file.
Thus on Win32 this routine returns the volume, on other operating
systems this returns nothing.
On Windows this value may be empty if the uri is to a network share, in
which case the 'share' property will be defined. Additionally, volume
specifications that use '|' as ':' will be converted on read to use ':'.
On VMS, which has a volume concept, this field will be empty because VMS
file specifications are converted to absolute UNIX format and the volume
information is transparently included.
=item $ff->share
On systems with the concept of a network share (currently only Windows) returns
the sharename from a file://// url. On other operating systems returns empty.
=item $ff->path
The path from the uri, will be at least a single '/'.
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
$normal++;
}
}
close $sock;
unless ( $normal ) {
return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
}
# Check the "response"
# Strip preceding blank lines apparently they are allowed (RFC 2616 4.1)
$resp =~ s/^(\x0d?\x0a)+//;
# Check it is an HTTP response
unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
}
# Check for OK
my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
unless ( $code eq '200' ) {
return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
$opts = {} unless $opts;
my $child_in = FileHandle->new;
my $child_out = FileHandle->new;
my $child_err = FileHandle->new;
$child_out->autoflush(1);
$child_err->autoflush(1);
my $pid = open3($child_in, $child_out, $child_err, $cmd);
# push my child's pid to our parent
# so in case i am killed parent
# could stop my child (search for
# child_child_pid in parent code)
if ($opts->{'parent_info'}) {
my $ps = $opts->{'parent_info'};
print $ps "spawned $pid\n";
}
if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
# If the child process dies for any reason,
# the next write to CHLD_IN is likely to generate
# a SIGPIPE in the parent, which is fatal by default.
# So you may wish to handle this signal.
#
# from http://perldoc.perl.org/IPC/Open3.html,
# absolutely needed to catch piped commands errors.
#
local $SIG{'PIPE'} = sub { 1; };
print $child_in $opts->{'child_stdin'};
}
close($child_in);
my $child_output = {
'out' => $child_out->fileno,
'err' => $child_err->fileno,
$child_out->fileno => {
'parent_socket' => $opts->{'parent_stdout'},
'scalar_buffer' => "",
'child_handle' => $child_out,
'block_size' => ($child_out->stat)[11] || 1024,
},
$child_err->fileno => {
'parent_socket' => $opts->{'parent_stderr'},
'scalar_buffer' => "",
'child_handle' => $child_err,
'block_size' => ($child_err->stat)[11] || 1024,
},
};
my $select = IO::Select->new();
$select->add($child_out, $child_err);
# pass any signal to the child
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
$SIG{$s} = $sig_handler;
}
my $child_finished = 0;
my $got_sig_child = 0;
$SIG{'CHLD'} = sub { $got_sig_child = time(); };
while(!$child_finished && ($child_out->opened || $child_err->opened)) {
# parent was killed otherwise we would have got
# the same signal as parent and process it same way
if (getppid() eq "1") {
# end my process group with all the children
# (i am the process group leader, so my pid
# equals to the process group id)
#
# same thing which is done
# with $opts->{'clean_up_children'}
# in run_forked
#
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
Time::HiRes::usleep(1);
foreach my $fd ($select->can_read(1/100)) {
my $str = $child_output->{$fd->fileno};
psSnake::die("child stream not found: $fd") unless $str;
my $data;
my $count = $fd->sysread($data, $str->{'block_size'});
if ($count) {
if ($str->{'parent_socket'}) {
my $ph = $str->{'parent_socket'};
print $ph $data;
}
else {
$str->{'scalar_buffer'} .= $data;
}
}
elsif ($count eq 0) {
$select->remove($fd);
$fd->close();
}
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
psSnake::die("error during sysread: " . $!);
}
}
}
my $waitpid_ret = waitpid($pid, 0);
my $real_exit = $?;
my $exit_value = $real_exit >> 8;
# since we've successfully reaped the child,
# let our parent know about this.
#
if ($opts->{'parent_info'}) {
my $ps = $opts->{'parent_info'};
# child was killed, inform parent
if ($real_exit & 127) {
print $ps "$pid killed with " . ($real_exit & 127) . "\n";
}
print $ps "reaped $pid\n";
}
if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
return $exit_value;
}
else {
return {
'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
'exit_code' => $exit_value,
};
}
}
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
Coderef of a subroutine to call when a portion of data is received on
STDERR from the executing program.
=item C<discard_output>
Discards the buffering of the standard output and standard errors for return by run_forked().
With this option you have to use the std*_handlers to read what the command outputs.
Useful for commands that send a lot of output.
=item C<terminate_on_parent_sudden_death>
Enable this option if you wish all spawned processes to be killed if the initially spawned
process (the parent) is killed or dies without waiting for child processes.
=back
C<run_forked> will return a HASHREF with the following keys:
=over
=item C<exit_code>
The exit code of the executed program.
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
return;
}
$opts = {} unless $opts;
$opts->{'timeout'} = 0 unless $opts->{'timeout'};
$opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
# turned on by default
$opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});
# sockets to pass child stdout to parent
my $child_stdout_socket;
my $parent_stdout_socket;
# sockets to pass child stderr to parent
my $child_stderr_socket;
my $parent_stderr_socket;
# sockets for child -> parent internal communication
my $child_info_socket;
my $parent_info_socket;
socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
die ("socketpair: $!");
socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
die ("socketpair: $!");
socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
die ("socketpair: $!");
$child_stdout_socket->autoflush(1);
$parent_stdout_socket->autoflush(1);
$child_stderr_socket->autoflush(1);
$parent_stderr_socket->autoflush(1);
$child_info_socket->autoflush(1);
$parent_info_socket->autoflush(1);
my $start_time = time();
my $pid;
if ($pid = fork) {
# we are a parent
close($parent_stdout_socket);
close($parent_stderr_socket);
close($parent_info_socket);
my $flags;
# prepare sockets to read from child
$flags = 0;
fcntl($child_stdout_socket, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
$flags |= POSIX::O_NONBLOCK;
fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
# print "child $pid started\n";
my $child_timedout = 0;
my $child_finished = 0;
my $child_stdout = '';
my $child_stderr = '';
my $child_merged = '';
my $child_exit_code = 0;
my $child_killed_by_signal = 0;
my $parent_died = 0;
my $got_sig_child = 0;
my $got_sig_quit = 0;
my $orig_sig_child = $SIG{'CHLD'};
$SIG{'CHLD'} = sub { $got_sig_child = time(); };
if ($opts->{'terminate_on_signal'}) {
install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
}
my $child_child_pid;
while (!$child_finished) {
my $now = time();
if ($opts->{'terminate_on_parent_sudden_death'}) {
$opts->{'runtime'}->{'last_parent_check'} = 0
unless defined($opts->{'runtime'}->{'last_parent_check'});
# check for parent once each five seconds
if ($now - $opts->{'runtime'}->{'last_parent_check'} > 5) {
if (getppid() eq "1") {
kill_gently ($pid, {
'first_kill_type' => 'process_group',
'final_kill_type' => 'process_group',
'wait_time' => $opts->{'terminate_wait_time'}
});
$parent_died = 1;
}
$opts->{'runtime'}->{'last_parent_check'} = $now;
}
}
# user specified timeout
if ($opts->{'timeout'}) {
if ($now - $start_time > $opts->{'timeout'}) {
kill_gently ($pid, {
'first_kill_type' => 'process_group',
'final_kill_type' => 'process_group',
'wait_time' => $opts->{'terminate_wait_time'}
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
# child finished, catch it's exit status
if ($waitpid ne 0 && $waitpid ne -1) {
$child_exit_code = $? >> 8;
}
if ($waitpid eq -1) {
$child_finished = 1;
next;
}
# child -> parent simple internal communication protocol
while (my $l = <$child_info_socket>) {
if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) {
$child_child_pid = $1;
$l = $2;
}
if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) {
$child_child_pid = undef;
$l = $2;
}
if ($l =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) {
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
close($child_stdout_socket);
close($child_stderr_socket);
close($child_info_socket);
my $o = {
'stdout' => $child_stdout,
'stderr' => $child_stderr,
'merged' => $child_merged,
'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
'exit_code' => $child_exit_code,
'parent_died' => $parent_died,
'killed_by_signal' => $child_killed_by_signal,
'child_pgid' => $pid,
};
my $err_msg = '';
if ($o->{'exit_code'}) {
$err_msg .= "exited with code [$o->{'exit_code'}]\n";
}
if ($o->{'timeout'}) {
$err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
}
if ($o->{'parent_died'}) {
$err_msg .= "parent died\n";
}
if ($o->{'stdout'}) {
$err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
}
if ($o->{'stderr'}) {
$err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
}
if ($o->{'killed_by_signal'}) {
$err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
}
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
close($child_stdout_socket);
close($child_stderr_socket);
close($child_info_socket);
my $child_exit_code;
# allow both external programs
# and internal perl calls
if (!ref($cmd)) {
$child_exit_code = open3_run($cmd, {
'parent_info' => $parent_info_socket,
'parent_stdout' => $parent_stdout_socket,
'parent_stderr' => $parent_stderr_socket,
'child_stdin' => $opts->{'child_stdin'},
});
}
elsif (ref($cmd) eq 'CODE') {
$child_exit_code = $cmd->({
'opts' => $opts,
'parent_info' => $parent_info_socket,
'parent_stdout' => $parent_stdout_socket,
'parent_stderr' => $parent_stderr_socket,
'child_stdin' => $opts->{'child_stdin'},
});
}
else {
print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n";
$child_exit_code = 1;
}
close($parent_stdout_socket);
close($parent_stderr_socket);
close($parent_info_socket);
if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
$opts->{'child_END'}->();
}
POSIX::_exit $child_exit_code;
}
}
sub run {
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
$stdout_done = 1 if $h == $kidout and $len == 0;
$stderr_done = 1 if $h == $kiderror and $len == 0;
last OUTER if ($stdout_done && $stderr_done);
}
}
waitpid $pid, 0; # wait for it to die
### restore STDIN after duping, or STDIN will be closed for
### this current perl process!
### done in the parent call now
# $self->__reopen_fds( @fds_to_dup );
### some error occurred
if( $? ) {
$self->error( $self->_pp_child_error( $cmd, $? ) );
$self->ok( 0 );
return;
} else {
return $self->ok( 1 );
}
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
$self->_fds( \@fds_to_dup );
$self->__dup_fds( @fds_to_dup );
### system returns 'true' on failure -- the exit code of the cmd
$self->ok( 1 );
system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
$self->error( $self->_pp_child_error( $cmd, $? ) );
$self->ok( 0 );
};
### done in the parent call now
#$self->__reopen_fds( @fds_to_dup );
return unless $self->ok;
return $self->ok;
}
{ my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
sub __fix_cmd_whitespace_and_special_chars {
inc/inc_Module-Build/Module/Build.pm view on Meta::CPAN
use Module::Build::Base;
use vars qw($VERSION @ISA);
@ISA = qw(Module::Build::Base);
$VERSION = '0.4003';
$VERSION = eval $VERSION;
# Inserts the given module into the @ISA hierarchy between
# Module::Build and its immediate parent
sub _interpose_module {
my ($self, $mod) = @_;
eval "use $mod";
die $@ if $@;
no strict 'refs';
my $top_class = $mod;
while (@{"${top_class}::ISA"}) {
last if ${"${top_class}::ISA"}[0] eq $ISA[0];
$top_class = ${"${top_class}::ISA"}[0];
inc/inc_Module-Build/Module/Build/Authoring.pod view on Meta::CPAN
whatever>.
For information on providing compatibility with
C<ExtUtils::MakeMaker>, see L<Module::Build::Compat> and
L<http://www.makemaker.org/wiki/index.cgi?ModuleBuildConversionGuide>.
=head1 STRUCTURE
Module::Build creates a class hierarchy conducive to customization.
Here is the parent-child class hierarchy in classy ASCII art:
/--------------------\
| Your::Parent | (If you subclass Module::Build)
\--------------------/
|
|
/--------------------\ (Doesn't define any functionality
| Module::Build | of its own - just figures out what
\--------------------/ other modules to load.)
|
inc/inc_Module-Build/Module/Build/Authoring.pod view on Meta::CPAN
$build->create_build_script;
This is relatively straightforward, and is the best way to do things
if your My::Builder class contains lots of code. The
C<create_build_script()> method will ensure that the current value of
C<@INC> (including the C</nonstandard/library/path>) is propagated to
the Build script, so that My::Builder can be found when running build
actions. If you find that you need to C<chdir> into a different directories
in your subclass methods or actions, be sure to always return to the original
directory (available via the C<base_dir()> method) before returning control
to the parent class. This is important to avoid data serialization problems.
For very small additions, Module::Build provides a C<subclass()>
method that lets you subclass Module::Build more conveniently, without
creating a separate file for your module:
------ in Build.PL: ----------
#!/usr/bin/perl
use Module::Build;
my $class = Module::Build->subclass
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
);
}
########################################################################
{ # enclosing these lexicals -- TODO
my %valid_properties = ( __PACKAGE__, {} );
my %additive_properties;
sub _mb_classes {
my $class = ref($_[0]) || $_[0];
return ($class, $class->mb_parents);
}
sub valid_property {
my ($class, $prop) = @_;
return grep exists( $valid_properties{$_}{$prop} ), $class->_mb_classes;
}
sub valid_properties {
return keys %{ shift->valid_properties_defaults() };
}
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
my $c = ref($self) ? $self->{config} : 'Module::Build::Config';
return $c->all_config unless @_;
my $key = shift;
return $c->get($key) unless @_;
my $val = shift;
return $c->set($key => $val);
}
sub mb_parents {
# Code borrowed from Class::ISA.
my @in_stack = (shift);
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.
}
shift @out;
return @out;
}
sub extra_linker_flags { shift->_list_accessor('extra_linker_flags', @_) }
sub extra_compiler_flags { shift->_list_accessor('extra_compiler_flags', @_) }
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
die "No 'to' or 'to_dir' parameter given to copy_if_modified";
}
return if $self->up_to_date($file, $to_path); # Already fresh
{
local $self->{properties}{quiet} = 1;
$self->delete_filetree($to_path); # delete destination if exists
}
# Create parent directories
File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777));
$self->log_verbose("Copying $file -> $to_path\n");
if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite
chmod 0666, $to_path;
File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!";
} else {
File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!";
}
inc/inc_Module-Build/Module/Build/Bundling.pod view on Meta::CPAN
fields):
use Module::Build;
Module::Build->new(
module_name => 'Foo::Bar',
license => 'perl',
)->create_build_script;
A "bundling" Build.PL replaces the initial "use" line with a nearly
transparent replacement:
use inc::latest 'Module::Build';
Module::Build->new(
module_name => 'Foo::Bar',
license => 'perl',
)->create_build_script;
For I<authors>, when "Build dist" is run, Module::Build will be
automatically bundled into C<inc> according to the rules for
inc/inc_Module-Build/Module/Build/Platform/VMS.pm view on Meta::CPAN
=item _detildefy
The home-grown glob() does not currently handle tildes, so provide limited support
here. Expect only UNIX format file specifications for now.
=cut
sub _detildefy {
my ($self, $arg) = @_;
# Apparently double ~ are not translated.
return $arg if ($arg =~ /^~~/);
# Apparently ~ followed by whitespace are not translated.
return $arg if ($arg =~ /^~ /);
if ($arg =~ /^~/) {
my $spec = $arg;
# Remove the tilde
$spec =~ s/^~//;
# Remove any slash following the tilde if present.
$spec =~ s#^/##;
inc/inc_Module-Load-Conditional/Module/Load/Conditional.pm view on Meta::CPAN
$href->{uptodate} = 1;
} else {
### don't warn about the 'not numeric' stuff ###
local $^W;
### use qv(), as it will deal with developer release number
### ie ones containing _ as well. This addresses bug report
### #29348: Version compare logic doesn't handle alphas?
###
### Update from JPeacock: apparently qv() and version->new
### are different things, and we *must* use version->new
### here, or things like #30056 might start happening
### We have to wrap this in an eval as version-0.82 raises
### exceptions and not warnings now *sigh*
eval {
$href->{uptodate} =
version->new( $args->{version} ) <= version->new( $href->{version} )
inc/inc_Module-Load-Conditional/Module/Load/Conditional.pm view on Meta::CPAN
next if $CACHE->{$mod}->{usable} && !$args->{nocache};
### else, check if the hash key is defined already,
### meaning $mod => 0,
### indicating UNSUCCESSFUL prior attempt of usage
### use qv(), as it will deal with developer release number
### ie ones containing _ as well. This addresses bug report
### #29348: Version compare logic doesn't handle alphas?
###
### Update from JPeacock: apparently qv() and version->new
### are different things, and we *must* use version->new
### here, or things like #30056 might start happening
if ( !$args->{nocache}
&& defined $CACHE->{$mod}->{usable}
&& (version->new( $CACHE->{$mod}->{version}||0 )
>= version->new( $href->{$mod} ) )
) {
$error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
last BLOCK;
}
( run in 0.505 second using v1.01-cache-2.11-cpan-4d50c553e7e )