view release on metacpan or  search on metacpan

script/perlall  view on Meta::CPAN

#!/usr/local/bin/perl
eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
    if 0; # not running under some shell

# XXX 5.20-24 do not work with App::Rad

#BEGIN {$DB::single=1} # debug into attribute handling
# TODO:
#   tee make test with -v (unbuffered IPC::Run or via fork-like callback?)
#   maketest or -q: mark FAIL tests *RED*, p line bold black (see t/testc.sh)
#   implement smoke, bench
#   maketest --all (locally and testvm --all)
#   more testvm_ctl: xen-shell, vmrun, VBoXManage
#   uninstall: packfile of installed files instead of rather unsafe globbing
#   cmd --help
#   get msys compiled, bootstrap a mingw perl without strawberry
#   build win32 from win32/
# TEST:
#   init-modules: \ handling and `` expansion
#   testvm logs back from forks
#   fix testvm forked and --fork arg
#   'perlall=5.8* perlall do -m' should filter only main 5.8*
#   testvm max balancing
#   init is unstable (IO::Tee in IPC::Run) - refactored
#   --as explicit and implicit - looks good, but no test
# non-critical TODO:
#   5.8.8 (centos5) fails with Attribute::Handler 0.78_02. monkeypatch or fail?
#   build: test perlbrew and HOME friendly (no hardcoded paths)
#   windows support (paths, tee, tools), die on other non-POSIX exots (VMS)...
#   CPAN::Shell->expand("Devel::*"), not easy todo with metacpan.

use strict;
use 5.006;
our $VERSION = '0.51';
use Config;
use Cwd ();
use File::Spec ();
use File::Basename 'basename';
use Fcntl ();

my @extuse;
BEGIN { # check platform support: perldoc perlport
  @extuse = qw(App::Rad IPC::Cmd IO::Scalar Devel::Platform::Info Devel::PatchPerl);
  if ($^O !~ /^linux|freebsd|darwin|solaris|openbsd|cygwin$/) {
    if ($^O =~ /^vms|dos|bsdos$/) {
      die "unsupported OS $^O"; # fixes welcome
    } elsif ($^O =~ /^MSWin32|msys/) {
      warn "$^O not yet fully supported\n";
    } else { # should theoretically work:
             #   netbsd sunos aix haiku beos hpux irix next svr4 unicos* plan9
             # scary: VOS os390 os400 posix-bc vmesa riscos amigaos mpeix
      warn "untested OS $^O. Feedback welcome";
      # VOS forbids slashes in filenames. no big deal
    }
  }
  sub _auto_use { # autoinstall the non-core modules, and use them
    my @m;
    for (@_) { push @m, $_ unless eval "require $_;" }
    if (@m) { # Checked the API back to 1.76_01 (v5.8.4)
      require CPAN; CPAN->import;
      # TODO: skip core modules, perl-5
      warn "CPAN::Shell->install(qw(@m))\n"; CPAN::Shell->install(@m); }
    $_->import for @m;
  }
  _auto_use( @extuse );
}
# 5.8.4: solaris, 5.8.5: centos4, 5.8.8: centos5
# below dynamically parsed from git tags
our @main_releases = qw(5.6.2 5.8.4 5.8.5 5.8.8 5.8.9 5.10.1 5.12.5 5.14.4 5.16.3
  5.18.4 5.20.3 5.22.4 5.24.4 5.26.3 5.28.2 5.30.0);

script/perlall  view on Meta::CPAN

	      (?:                    # (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;
      }