Alien-ROOT
view release on metacpan or search on metacpan
}
# Ask the user if they'd like to install this; if not, then exit
$builder->y_n('ROOT was not found on your system or you forced a recompile. Build and install it now?', 'y')
or exit;
$builder->notes(build_ROOT => 1);
# Ask the user what 'make' program to invoke
my $make;
if (exists($ENV{MAKE}) && length($ENV{MAKE})) {
$make = $ENV{MAKE};
}
else {
use Config '%Config';
$make = $Config{make};
# Probe for GNU Make (useful on BSD/Unix variants)
if ($make eq 'make' && grep { -x $_ . '/gmake' } @PATH) {
$make = 'gmake';
if ($^O =~ /bsd$/) {
inc/inc_Archive-Extract/Archive/Extract.pm view on Meta::CPAN
my @files = map { chomp;
!ON_SOLARIS ? $_
: (m|^ x \s+ # 'xtract' -- sigh
(.+?), # the actual file name
\s+ [\d,.]+ \s bytes,
\s+ [\d,.]+ \s tape \s blocks
|x ? $1 : $_);
### only STDOUT, see above. Sometimes, extra whitespace
### is present, so make sure we only pick lines with
### a length
} grep { length } map { split $/, $_ } join '', @{$out[3]};
### store the files that are in the archive ###
$self->files(\@files);
}
}
### now actually extract it ###
{ my $cmd =
$self->is_tgz ? [$self->bin_gzip, '-cdf', $archive, '|',
$self->bin_tar, '-xf', '-'] :
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
### file://hostname/...
### file://hostname/...
### normalize file://localhost with file:///
$href->{host} = $parts[0] || '';
### index in @parts where the path components begin;
my $index = 1;
### file:////hostname/sharename/blah.txt
if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
$href->{host} = $parts[2] || ''; # avoid warnings
$href->{share} = $parts[3] || ''; # avoid warnings
$index = 4 # index after the share
### file:///D|/blah.txt
### file:///D:/blah.txt
} elsif (HAS_VOL) {
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
my $path = File::Spec::Unix->catfile( $self->path, $self->file );
my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
$sock->send( $req );
my $select = IO::Select->new( $sock );
my $resp = '';
my $normal = 0;
while ( $select->can_read( $TIMEOUT || 60 ) ) {
my $ret = $sock->sysread( $resp, 4096, length($resp) );
if ( !defined $ret or $ret == 0 ) {
$select->remove( $sock );
$normal++;
}
}
close $sock;
unless ( $normal ) {
return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
}
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
return;
};
$cmd = _quote_args_vms( $cmd ) if IS_VMS;
### strip any empty elements from $cmd if present
if ( $ALLOW_NULL_ARGS ) {
$cmd = [ grep { defined } @$cmd ] if ref $cmd;
}
else {
$cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
}
my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
### did the user pass us a buffer to fill or not? if so, set this
### flag so we know what is expected of us
### XXX this is now being ignored. in the future, we could add diagnostic
### messages based on this logic
#my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
$pipe->(*TO_CHLD_R, *TO_CHLD_W ) or die $^E;
$pipe->(*FR_CHLD_R, *FR_CHLD_W ) or die $^E;
$pipe->(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $^E;
my $pid = IPC::Open3::open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_);
return ( $pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R );
};
$cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
$cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
my ($pid, $to_chld, $fr_chld, $fr_chld_err) =
$open3->( ( ref $cmd ? @$cmd : $cmd ) );
my $in_sel = IO::Select->new();
my $out_sel = IO::Select->new();
my %objs;
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
$in_sel->add( $fr_chld_err );
close($to_chld);
while ($in_sel->count() + $out_sel->count()) {
my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef);
for my $fh (@$ins) {
my $obj = $objs{ fileno($fh) };
my $buf;
my $bytes_read = sysread($fh, $buf, 64*1024 ); #, length($buf));
if (!$bytes_read) {
$in_sel->remove($fh);
}
else {
$obj->( "$buf" );
}
}
for my $fh (@$outs) {
}
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
# Unix command-parsing. Double-quotes mean different things,
# backslashes don't necessarily mean escapes, and so on. So we
# 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.
local $_ = shift;
my @argv;
return @argv unless defined() && length();
my $arg = '';
my( $i, $quote_mode ) = ( 0, 0 );
while ( $i < length() ) {
my $ch = substr( $_, $i , 1 );
my $next_ch = substr( $_, $i+1, 1 );
if ( $ch eq '\\' && $next_ch eq '"' ) {
$arg .= '"';
$i++;
} elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
$arg .= '\\';
$i++;
} elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
$quote_mode = !$quote_mode;
$arg .= '"';
$i++;
} elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
( $i + 2 == length() ||
substr( $_, $i + 2, 1 ) eq ' ' )
) { # for cases like: a"" => [ 'a' ]
push( @argv, $arg );
$arg = '';
$i += 2;
} elsif ( $ch eq '"' ) {
$quote_mode = !$quote_mode;
} elsif ( $ch eq ' ' && !$quote_mode ) {
push( @argv, $arg ) if defined( $arg ) && length( $arg );
$arg = '';
++$i while substr( $_, $i + 1, 1 ) eq ' ';
} else {
$arg .= $ch;
}
$i++;
}
push( @argv, $arg ) if defined( $arg ) && length( $arg );
return @argv;
}
{ use File::Spec;
use Symbol;
my %Map = (
STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
inc/inc_Locale-Maketext-Simple/Locale/Maketext/Simple.pm view on Meta::CPAN
*{caller(0) . "::$args{Export}_lang"} = $loc_lang || sub { 1 };
}
my %Loc;
sub reload_loc { %Loc = () }
sub load_loc {
my ($class, %args) = @_;
my $pkg = join('::', grep { defined and length } $args{Class}, $args{Subclass});
return $Loc{$pkg} if exists $Loc{$pkg};
eval { require Locale::Maketext::Lexicon; 1 } or return;
$Locale::Maketext::Lexicon::VERSION > 0.20 or return;
eval { require File::Spec; 1 } or return;
my $path = $args{Path} || $class->auto_path($args{Class}) or return;
my $pattern = File::Spec->catfile($path, '*.[pm]o');
my $decode = $args{Decode} || 0;
my $encoding = $args{Encoding} || undef;
inc/inc_Module-Build/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.
inc/inc_Module-Build/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) = @_;
inc/inc_Module-Build/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 ) {
inc/inc_Module-Build/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";
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
return () unless $modulebuildrc;
}
my $fh = IO::File->new( $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;
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
my $info = $self->prereq_data;
my $output = '';
foreach my $type (keys %$info) {
my $prereqs = $info->{$type};
$output .= "\n$type:\n";
my $mod_len = 2;
my $ver_len = 4;
my %mods;
while ( my ($modname, $spec) = each %$prereqs ) {
my $len = length $modname;
$mod_len = $len if $len > $mod_len;
$spec ||= '0';
$len = length $spec;
$ver_len = $len if $len > $ver_len;
my $mod = $self->check_installed_status($modname, $spec);
$mod->{name} = $modname;
$mod->{ok} ||= 0;
$mod->{ok} = ! $mod->{ok} if $type =~ /^(\w+_)?conflicts$/;
$mods{lc $modname} = $mod;
}
inc/inc_Module-Build/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 {
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
# Work around a Test::Harness bug that loses the particular perl
# we're running under. $self->perl is trustworthy, but $^X isn't.
local $^X = $self->perl;
# Do everything in our power to work with all versions of Test::Harness
local $Test::Harness::switches = join ' ', grep defined, $Test::Harness::switches, @harness_switches;
local $Test::Harness::Switches = join ' ', grep defined, $Test::Harness::Switches, @harness_switches;
local $ENV{HARNESS_PERL_SWITCHES} = join ' ', grep defined, $ENV{HARNESS_PERL_SWITCHES}, @harness_switches;
$Test::Harness::switches = undef unless length $Test::Harness::switches;
$Test::Harness::Switches = undef unless length $Test::Harness::Switches;
delete $ENV{HARNESS_PERL_SWITCHES} unless length $ENV{HARNESS_PERL_SWITCHES};
local ($Test::Harness::verbose,
$Test::Harness::Verbose,
$ENV{TEST_VERBOSE},
$ENV{HARNESS_VERBOSE}) = ($p->{verbose} || 0) x 4;
Test::Harness::runtests(@$tests);
}
sub run_visual_script {
inc/inc_Module-Build/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;
inc/inc_Module-Build/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;
my $fh = IO::File->new(">> $file")
or die "Can't open $file: $!";
print $fh "$skip\n";
$fh->close();
}
sub _write_default_maniskip {
my $self = shift;
my $file = shift || 'MANIFEST.SKIP';
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
my ($metafile, $struct) = @_;
return unless $self->try_require("CPAN::Meta", "2.110420");
my $meta = CPAN::Meta->new( $struct );
return $meta->save( $metafile, { version => "1.4" } );
}
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' ||
ref $version eq 'Module::Build::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"
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
# A little helper sub
my $add_node = sub {
my ($name, $val) = @_;
$node->{$name} = $val;
push @$keys, $name if $keys;
};
# 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);
}
}
}
inc/inc_Module-Build/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);
}
}
inc/inc_Module-Build/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");
inc/inc_Module-Build/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);
inc/inc_Module-Build/Module/Build/Base.pm view on Meta::CPAN
close $fh;
}
}
sub split_like_shell {
my ($self, $string) = @_;
return () unless defined($string);
return @$string if UNIVERSAL::isa($string, 'ARRAY');
$string =~ s/^\s+|\s+$//g;
return () unless length($string);
return Text::ParseWords::shellwords($string);
}
sub oneliner {
# Returns a string that the shell can evaluate as a perl command.
# This should be avoided whenever possible, since "the shell" really
# means zillions of shells on zillions of platforms and it's really
# hard to get it right all the time.
inc/inc_Module-Build/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
{
inc/inc_Module-Build/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
while (my ($macro, $trans) = each %macro_to_build) {
# 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";
inc/inc_Module-Build/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 );
inc/inc_Module-Build/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);
}
}
inc/inc_Module-Build/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() && UNIVERSAL::isa($_, 'ARRAY');
my @argv;
return @argv unless defined() && length();
my $arg = '';
my( $i, $quote_mode ) = ( 0, 0 );
while ( $i < length() ) {
my $ch = substr( $_, $i , 1 );
my $next_ch = substr( $_, $i+1, 1 );
if ( $ch eq '\\' && $next_ch eq '"' ) {
$arg .= '"';
$i++;
} elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
$arg .= '\\';
$i++;
} elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
$quote_mode = !$quote_mode;
$arg .= '"';
$i++;
} elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
( $i + 2 == length() ||
substr( $_, $i + 2, 1 ) eq ' ' )
) { # for cases like: a"" => [ 'a' ]
push( @argv, $arg );
$arg = '';
$i += 2;
} elsif ( $ch eq '"' ) {
$quote_mode = !$quote_mode;
} elsif ( $ch eq ' ' && !$quote_mode ) {
push( @argv, $arg ) if $arg;
$arg = '';
++$i while substr( $_, $i + 1, 1 ) eq ' ';
} else {
$arg .= $ch;
}
$i++;
}
push( @argv, $arg ) if defined( $arg ) && length( $arg );
return @argv;
}
# 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);
inc/inc_version/version/vpp.pm view on Meta::CPAN
return 1;
}
else {
return 0;
}
}
sub _un_vstring {
my $value = shift;
# may be a v-string
if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/
&& (ord($value) < ord('0') || ord($value) > ord('9')) ) {
my $tvalue = sprintf("v%vd",$value);
if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
# must be a v-string
$value = $tvalue;
}
}
return $value;
}
( run in 0.625 second using v1.01-cache-2.11-cpan-65fba6d93b7 )