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