cpan/Devel-PPPort/devel/devtools.pl

   1 ################################################################################
   2 #
   3 #  devtools.pl -- various utility functions
   4 #
   5 ################################################################################
   6 #
   7 #  $Revision: 5 $
   8 #  $Author: mhx $
   9 #  $Date: 2009/01/18 14:10:50 +0100 $
  10 #
  11 ################################################################################
  12 #
  13 #  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
  14 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
  15 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  16 #
  17 #  This program is free software; you can redistribute it and/or
  18 #  modify it under the same terms as Perl itself.
  19 #
  20 ################################################################################
  21
  22 use IO::File;
  23
  24 eval "use Term::ANSIColor";
  25 $@ and eval "sub colored { pop; @_ }";
  26
  27 my @argvcopy = @ARGV;
  28
  29 sub verbose
  30 {
  31   if ($opt{verbose}) {
  32     my @out = @_;
  33     s/^(.*)/colored("($0) ", 'bold blue').colored($1, 'blue')/eg for @out;
  34     print STDERR @out;
  35   }
  36 }
  37
  38 sub ddverbose
  39 {
  40   return $opt{verbose} ? ('--verbose') : ();
  41 }
  42
  43 sub runtool
  44 {
  45   my $opt = ref $_[0] ? shift @_ : {};
  46   my($prog, @args) = @_;
  47   my $sysstr = join ' ', map { "'$_'" } $prog, @args;
  48   $sysstr .= " >$opt->{'out'}"  if exists $opt->{'out'};
  49   $sysstr .= " 2>$opt->{'err'}" if exists $opt->{'err'};
  50   verbose("running $sysstr\n");
  51   my $rv = system $sysstr;
  52   verbose("$prog => exit code $rv\n");
  53   return not $rv;
  54 }
  55
  56 sub runperl
  57 {
  58   my $opt = ref $_[0] ? shift @_ : {};
  59   runtool($opt, $^X, @_);
  60 }
  61
  62 sub run
  63 {
  64   my $prog = shift;
  65   my @args = @_;
  66
  67   runtool({ 'out' => 'tmp.out', 'err' => 'tmp.err' }, $prog, @args);
  68
  69   my $out = IO::File->new("tmp.out") or die "tmp.out: $!\n";
  70   my $err = IO::File->new("tmp.err") or die "tmp.err: $!\n";
  71
  72   my %rval = (
  73     status    => $? >> 8,
  74     stdout    => [<$out>],
  75     stderr    => [<$err>],
  76     didnotrun => 0,
  77   );
  78
  79   unlink "tmp.out", "tmp.err";
  80
  81   $? & 128 and $rval{core}   = 1;
  82   $? & 127 and $rval{signal} = $? & 127;
  83
  84   return \%rval;
  85 }
  86
  87 sub ident_str
  88 {
  89   return "$^X $0 @argvcopy";
  90 }
  91
  92 sub identify
  93 {
  94   verbose(ident_str() . "\n");
  95 }
  96
  97 sub ask($)
  98 {
  99   my $q = shift;
 100   my $a;
 101   local $| = 1;
 102   print "\n$q [y/n] ";
 103   do { $a = <>; } 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 1;