dist/Devel-PPPort/devel/devtools.pl

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