view release on metacpan or  search on metacpan

script/perlall  view on Meta::CPAN

  } @p;
  if ($c->options->{reverse}) { # oldest first
    sort { _strip2float($a) <=> _strip2float($b) } @p;
  } else {
    # sort reverse numerically, newest first
    sort { _strip2float($b) <=> _strip2float($a) } @p;
  }
}

# string of hash key=val...
sub _opts {
  my $h = shift;
  my $s = '';
  for (keys %$h) {
    my $v = $h->{$_};
    if (ref($v) eq 'ARRAY') {
      for my $v (@{$h->{$_}}) {
	$s .= ($v != 1 ? " --".$_."=$v" : " --".$_);
      }
    } else {
      $s .= ($v != 1 ? " --".$_."=$v" : " --".$_);
    }
  }
  substr($s,1);
}
# perl5.14.2d-nt => 14.2
sub _strip2float {
  my $p = shift;
  $p =~ s/^.*perl5\.//;
  $p =~ s/^5\.//;
  $p =~ s/(\.\d+)\D.*$/$1/;
  $p
}

# if p is older then ver
# $p gets full path
sub _older {
  my $c = shift;
  my ($p, $ver) = @_;
  $p =~ s/^.*perl5\.//;
  $p =~ s/^5\.//;
  $p =~ s/(\.\d+)\D.*$/$1/;
  # perl5.14.2d-nt@345aef vs 5.12 => 14.2 vs 12
  $ver =~ s/^5\.//;
  $c->debug("_older($_[0], $_[1]) => $p, $ver");
  return $p < $ver;
}

sub _dot_perlall {
  my ($c, $filename, $write) = (@_);
  $c->debug(($write?"writing":"loading")." configuration from $filename");
  open my $CONFIG, '<', $filename
    or Carp::croak "error opening $filename: $!\n";
  my ($s, $NEW);
  $write = undef if $c->options->{dryrun};
  if ($write) {
    open $NEW, '>', $filename.".tmp"
      or Carp::croak "error opening $filename.tmp: $!\n";
  }
  while (<$CONFIG>) {
    $s = $_ if $write; # backup
    chomp;
    s/#.*//;
    s/\s+$//;
    print $NEW $s if $s and !length;
    next unless length;

    if (/\\\s*$/) {
      my $t = '';
      do {
	s/\\\s*$//;
	s/#.*//;
	chomp;
	$t .= $_;
      } while ($_ = <$CONFIG> and $_ =~ /\\\s*$/);
      s/#.*//;
      chomp;
      $t .= $_;
      $_ = $t;
    }
    s/^\s+//;
    if ( m/^alias\s([^\=\:\s]+) # alias key=value
	   (?:=['"]?)   # ='
	   ([^'"]+)     # value
	  /x
       ) {
      my ($k,$v) = ($1, $2);
      if ($k eq 'perl-git') {
	$v =~ s/^cd //;
	$c->config->{$k} = $v;
	$v = "cd ".$v;
      } elsif ($k eq 'cdcperl') {
	$v =~ s/^cd //;
	$c->config->{$k} = $v;
	$v = "cd ".$v;
      } else {
	$c->config->{$k} = $v;
      }
      if ($write and $k eq 'p') {
	$v = $write;
      }
      print $NEW "alias $k='$v'\n" if $write;
    }
    elsif ( m/^([^\=\:\s]+)          # key
	      (?:                    # (value is optional)
		(?:\s*[\=\:]\s*|\s+) # separator ('=', ':', '"' or whitespace)
		(.+)                 # value
	      )?
	     /x
	  ) {
      my $v = $2;
      if (substr($v,0,1) eq '"' and substr($v,-1,1) eq '"') {
	$v = substr($v,1,-1);
      }
      $c->config->{$1} = $v;
      print $NEW $s if $write;
    } elsif ($write) {
      print $NEW $s;
    }
  }
  close $CONFIG;
  if ($write) {
    close $NEW;
    unlink $CONFIG;
    rename $filename.".tmp", $filename
      or Carp::croak "error writing $filename: $!\n";
  }
  scalar keys %{$c->config};
}

# store alias p if explicitly wished (2nd arg $p),
# or if only one version was selected. received with no perl prefix
sub _set_alias {
  my ($c, $p) = @_;
  my $f = "$ENV{HOME}/.perlall";
  unless ($p) {
    $p = $c->stash->{perlall}->[0] if @{$c->stash->{perlall}} == 1;
    $c->_dot_perlall($f, $p) if -f $f and $p; # set alias
  } else {
    $c->_dot_perlall($f, "perl$p") if -f $f and $p; # set alias
  }
  ""
}

sub _numonly {
  my $p = shift;
  $p =~ s/^.*perl//;
  $p =~ s/\-.+$//;
  $p =~ s/@.+$//;
  $p =~ s/thr$//;
  $p =~ s/d$//;
  return $p;
}

sub _short {
  my $p = shift;
  $p =~ s/^.*perl//;
  return $p;
}

sub _print {
  my $level = shift;
  if ($^O eq 'MSWin32') {
    print join(" ",@_),"\n";
  } elsif ($level == 0) { # bold green, highest level, headers
    print "\033[1;32m",join(" ",@_),"\033[0;0m\n";
  } elsif ($level == 1) { # bold red/black, major commands
    print "\033[1;39m",join(" ",@_),"\033[0;0m\n";
  }
}
sub _backup($) {
  my $f = shift;
  my $i = 1;
  while (-e "$f.$i") { $i++ }
  rename $f,"$f.$i";
}
sub __system {
  my $c = shift;
  unless ($c->options->{dryrun}) {
    # MSWin32 ExtUtils::Command methods (tools_other section)
    if ($^O eq 'MSWin32' and $_[0] =~ /^(rm|mv|mkdir) /) {
      my $what = join " ",@_;
      if ($what =~ /^rm -rf/) {
	system("$^X -MExtUtils::Command -e 'rm_rf' -- ",substr($what,6));
      } elsif ($what =~ /^rm /) {
	system("$^X -MExtUtils::Command -e 'rm_f' -- ",substr($what,5));
      } elsif ($what =~ /^mv /) {
	system("$^X -MExtUtils::Command -e 'mv' -- ",substr($what,3));
      } elsif ($what =~ /^mkdir (-p)?(.*)/) {
	system("$^X -MExtUtils::Command -e 'mkpath' -- $2");
      } else {
	die "unhandled $what";
      }
    # native chdir/rmdir/mkdir/unlink/rename
    } elsif ($_[0] =~ /^chdir|rmdir|mkdir|unlink|rename$/) {
      my $cmd = shift @_;
      my $what = join "','",@_;
      if ($cmd =~ /^mkdir -p/) {
	system(@_);
      } else {
	eval "$cmd('$what')";
      }
    } else {
      my $fh = $c->stash->{log_fh};
      if ($^O eq 'MSWin32') {
	# Need to replace ' with " otherwise we would need to write
        # perlall do -e"""print $^O""". Now we only need to do
        # perlall do '-e"print $^O"'
	map { s/\'/"/g } @_;
      }
      my ($success, $error_message, $full_buf, $stdout_buf, $stderr_buf) =
	IPC::Cmd::run('command' => [ @_ ],
		      ($c->options->{verbose}
		       ? ('verbose' => 1) : ()),
		      (defined $c->options->{timeout}
		       ? ('timeout' => $c->options->{timeout} )
		       : ())
	);
      if ($fh and !$c->options->{verbose} and @$full_buf) {
	print $fh $_ for @$full_buf;
	if (!$c->options->{quiet} and $c->cmd =~ /^smoke|do|make.*|cpan.*/) {
	  print $_ for @$stdout_buf;
	}
      }
      if (@$stderr_buf and !$c->options->{quiet}) {
	print STDERR $_ for @$stderr_buf;
      }
      $success;
    }
  }
}
sub _loginit {
  my $c = shift;
  my $q = $c->options->{quiet};
  my $v = $c->options->{verbose};
  my $dryrun = $c->options->{dryrun};
  my $log = $c->stash->{log};
  if ( !$dryrun and $log ) {
    _backup($log) if -e $log;
    $c->stash->{log_fh} = IO::File->new($v ? ">& $log" : "> $log");
  }
}

# $c->_log(level, @messages)
# -q   only print to log, STDOUT level 0
#      STDOUT level 1, STDOUT+STDERR >>log
# -v   tee to STDOUT (STDERR not yet) and log
sub _log {
  my $c = shift;
  my $level = shift;
  my $q = $c->options->{quiet};
  my $v = $c->options->{verbose};
  my $dryrun = $c->options->{dryrun};
  my $log = $c->stash->{log};
  my $fh  = $c->stash->{log_fh};
  local $| = 1;
  if ($log) {
    $c->_loginit unless $fh;
    $fh  = $c->stash->{log_fh};
    if (!$q) {
      if ($level ne '') {
	_print($level,@_);
      }
      if ($fh) {
	print $fh join(" ",@_),"\n";
	$fh->flush;
      } elsif ($level eq '') {
	print join(" ",@_),"\n"; # fails on my centos5
      }
    } elsif ($level == 0) {
      _print(0,@_);
    }
  } elsif ($v or $level == 0) {
    if ($level ne '') {
      _print($level,@_);
    } else {
      print join(" ",@_),"\n";
    }
  }
}

sub _system {
  my $c = shift;
  $c->_log('', @_) unless $c->options->{quiet};
  $c->__system(@_);
}
sub _system0 {
  my $c = shift;
  $c->_log(0,@_);
  $c->__system(@_);
}
sub _system1 {
  my $c = shift;
  $c->_log(1,@_);
  $c->__system(@_);
}

sub _check_lock {
  my $lock = Cwd::getcwd()."/perlall.lock";