This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a60c6f3b1c1eb94c39192d03e81ebae5ced0f553
[perl5.git] / 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 1;