Commit | Line | Data |
---|---|---|
0c96388f MHM |
1 | ################################################################################ |
2 | # | |
3 | # devtools.pl -- various utility functions | |
4 | # | |
5 | ################################################################################ | |
6 | # | |
7 | # $Revision: 1 $ | |
8 | # $Author: mhx $ | |
9 | # $Date: 2006/05/25 17:19:22 +0200 $ | |
10 | # | |
11 | ################################################################################ | |
12 | # | |
13 | # Version 3.x, Copyright (C) 2004-2006, 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 = new IO::File "tmp.out" || die "tmp.out: $!\n"; | |
70 | my $err = new IO::File "tmp.err" || 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; |