dist/Devel-PPPort/devel/devtools.pl

   1 ################################################################################
   2 #
   3 #  devtools.pl -- various utility functions
   4 #
   5 ################################################################################
   6 #
   7 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
   8 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
   9 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  10 #
  11 #  This program is free software; you can redistribute it and/or
  12 #  modify it under the same terms as Perl itself.
  13 #
  14 ################################################################################
  15
  16 use IO::File;
  17
  18 eval "use Term::ANSIColor";
  19 $@ and eval "sub colored { pop; @_ }";
  20
  21 my @argvcopy = @ARGV;
  22
  23 sub verbose
  24 {
  25   if ($opt{verbose}) {
  26     my @out = @_;
  27     s/^(.*)/colored("($0) ", 'bold blue').colored($1, 'blue')/eg for @out;
  28     print STDERR @out;
  29   }
  30 }
  31
  32 sub ddverbose
  33 {
  34   return $opt{verbose} ? ('--verbose') : ();
  35 }
  36
  37 sub runtool
  38 {
  39   my $opt = ref $_[0] ? shift @_ : {};
  40   my($prog, @args) = @_;
  41   my $sysstr = join ' ', map { "'$_'" } $prog, @args;
  42   $sysstr .= " >$opt->{'out'}"  if exists $opt->{'out'};
  43   $sysstr .= " 2>$opt->{'err'}" if exists $opt->{'err'};
  44   verbose("running $sysstr\n");
  45   my $rv = system $sysstr;
  46   verbose("$prog => exit code $rv\n");
  47   return not $rv;
  48 }
  49
  50 sub runperl
  51 {
  52   my $opt = ref $_[0] ? shift @_ : {};
  53   runtool($opt, $^X, @_);
  54 }
  55
  56 sub run
  57 {
  58   my $prog = shift;
  59   my @args = @_;
  60
  61   runtool({ 'out' => 'tmp.out', 'err' => 'tmp.err' }, $prog, @args);
  62
  63   my $out = IO::File->new("tmp.out") or die "tmp.out: $!\n";
  64   my $err = IO::File->new("tmp.err") or die "tmp.err: $!\n";
  65
  66   my %rval = (
  67     status    => $? >> 8,
  68     stdout    => [<$out>],
  69     stderr    => [<$err>],
  70     didnotrun => 0,
  71   );
  72
  73   unlink "tmp.out", "tmp.err";
  74
  75   $? & 128 and $rval{core}   = 1;
  76   $? & 127 and $rval{signal} = $? & 127;
  77
  78   return \%rval;
  79 }
  80
  81 sub ident_str
  82 {
  83   return "$^X $0 @argvcopy";
  84 }
  85
  86 sub identify
  87 {
  88   verbose(ident_str() . "\n");
  89 }
  90
  91 sub ask($)
  92 {
  93   my $q = shift;
  94   my $a;
  95   local $| = 1;
  96   do {
  97     print "\a\n$q [y/n] ";
  98     $a = <>; }
  99   while ($a !~ /^\s*([yn])\s*$/i);
 100   return lc $1 eq 'y';
 101 }
 102
 103 sub quit_now
 104 {
 105   print "\nSorry, cannot continue.\n\n";
 106   exit 1;
 107 }
 108
 109 sub ask_or_quit
 110 {
 111   quit_now unless &ask;
 112 }
 113
 114 sub eta
 115 {
 116   my($start, $i, $n) = @_;
 117   return "--:--:--" if $i < 3;
 118   my $elapsed = tv_interval($start);
 119   my $h = int($elapsed*($n-$i)/$i);
 120   my $s = $h % 60; $h /= 60;
 121   my $m = $h % 60; $h /= 60;
 122   return sprintf "%02d:%02d:%02d", $h, $m, $s;
 123 }
 124
 125 sub get_and_sort_perls($)
 126 {
 127     my $opt = shift;
 128
 129     # Get blead and all other perls
 130     my @perls = $opt->{blead};
 131     for my $dir (split ",", $opt->{install}) {
 132         push @perls, grep !/-RC\d+/, glob "$dir/bin/perl5.*";
 133     }
 134
 135     # Sort in descending version order.  Each element is a hash describing a perl,
 136     # with keys 'version' and 'path'
 137     @perls = sort { $b->{version} <=> $a->{version} }
 138
 139                                 # Call the perl to get it to print out it's $]
 140                                 # version
 141                 map { { version => `$_ -e 'printf "%.6f", \$]'`,
 142                         path => $_ }
 143                     }
 144                 @perls;
 145
 146     # Override blead's version if specified.
 147     if (exists $opt->{'blead-version'}) {
 148         $perls[0]{version} = format_version($opt->{'blead-version'});
 149     }
 150
 151     my %seen;
 152
 153     # blead's todo is its version plus 1.  Otherwise, each todo is the
 154     # previous one's.  Also get rid of duplicate versions.
 155     $perls[0]{todo} = $perls[0]{version} + 1;
 156     $seen{$perls[0]{version}} = 1;
 157     for my $i (1 .. $#perls) {
 158         last unless defined $perls[$i];
 159         if (    exists $seen{$perls[$i]{version}}) {
 160             splice @perls, $i, 1;
 161             redo;
 162         }
 163
 164         $seen{$perls[$i]{version}} = 1;
 165         $perls[$i]{todo} = $perls[$i-1]{version};
 166     }
 167
 168     return \@perls;
 169 }
 170
 171 1;