Commit | Line | Data |
0c96388f |
1 | ################################################################################ |
2 | # |
3 | # devtools.pl -- various utility functions |
4 | # |
5 | ################################################################################ |
6 | # |
3f0c6e0c |
7 | # $Revision: 5 $ |
0c96388f |
8 | # $Author: mhx $ |
3f0c6e0c |
9 | # $Date: 2009/01/18 14:10:50 +0100 $ |
0c96388f |
10 | # |
11 | ################################################################################ |
12 | # |
3f0c6e0c |
13 | # Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz. |
0c96388f |
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 | |
ba120f6f |
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"; |
0c96388f |
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; |