|
Packit |
7d6a7d |
################################################################################
|
|
Packit |
7d6a7d |
#
|
|
Packit |
7d6a7d |
# devtools.pl -- various utility functions
|
|
Packit |
7d6a7d |
#
|
|
Packit |
7d6a7d |
################################################################################
|
|
Packit |
7d6a7d |
#
|
|
Packit |
7d6a7d |
# Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
|
|
Packit |
7d6a7d |
# Version 2.x, Copyright (C) 2001, Paul Marquess.
|
|
Packit |
7d6a7d |
# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
|
|
Packit |
7d6a7d |
#
|
|
Packit |
7d6a7d |
# This program is free software; you can redistribute it and/or
|
|
Packit |
7d6a7d |
# modify it under the same terms as Perl itself.
|
|
Packit |
7d6a7d |
#
|
|
Packit |
7d6a7d |
################################################################################
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
use IO::File;
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
eval "use Term::ANSIColor";
|
|
Packit |
7d6a7d |
$@ and eval "sub colored { pop; @_ }";
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
my @argvcopy = @ARGV;
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub verbose
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
if ($opt{verbose}) {
|
|
Packit |
7d6a7d |
my @out = @_;
|
|
Packit |
7d6a7d |
s/^(.*)/colored("($0) ", 'bold blue').colored($1, 'blue')/eg for @out;
|
|
Packit |
7d6a7d |
print STDERR @out;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub ddverbose
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
return $opt{verbose} ? ('--verbose') : ();
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub runtool
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
my $opt = ref $_[0] ? shift @_ : {};
|
|
Packit |
7d6a7d |
my($prog, @args) = @_;
|
|
Packit |
7d6a7d |
my $sysstr = join ' ', map { "'$_'" } $prog, @args;
|
|
Packit |
7d6a7d |
$sysstr .= " >$opt->{'out'}" if exists $opt->{'out'};
|
|
Packit |
7d6a7d |
$sysstr .= " 2>$opt->{'err'}" if exists $opt->{'err'};
|
|
Packit |
7d6a7d |
verbose("running $sysstr\n");
|
|
Packit |
7d6a7d |
my $rv = system $sysstr;
|
|
Packit |
7d6a7d |
verbose("$prog => exit code $rv\n");
|
|
Packit |
7d6a7d |
return not $rv;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub runperl
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
my $opt = ref $_[0] ? shift @_ : {};
|
|
Packit |
7d6a7d |
runtool($opt, $^X, @_);
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub run
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
my $prog = shift;
|
|
Packit |
7d6a7d |
my @args = @_;
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
runtool({ 'out' => 'tmp.out', 'err' => 'tmp.err' }, $prog, @args);
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
my $out = IO::File->new("tmp.out") or die "tmp.out: $!\n";
|
|
Packit |
7d6a7d |
my $err = IO::File->new("tmp.err") or die "tmp.err: $!\n";
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
my %rval = (
|
|
Packit |
7d6a7d |
status => $? >> 8,
|
|
Packit |
7d6a7d |
stdout => [<$out>],
|
|
Packit |
7d6a7d |
stderr => [<$err>],
|
|
Packit |
7d6a7d |
didnotrun => 0,
|
|
Packit |
7d6a7d |
);
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
unlink "tmp.out", "tmp.err";
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
$? & 128 and $rval{core} = 1;
|
|
Packit |
7d6a7d |
$? & 127 and $rval{signal} = $? & 127;
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
return \%rval;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub ident_str
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
return "$^X $0 @argvcopy";
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub identify
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
verbose(ident_str() . "\n");
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub ask($)
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
my $q = shift;
|
|
Packit |
7d6a7d |
my $a;
|
|
Packit |
7d6a7d |
local $| = 1;
|
|
Packit |
7d6a7d |
print "\n$q [y/n] ";
|
|
Packit |
7d6a7d |
do { $a = <>; } while ($a !~ /^\s*([yn])\s*$/i);
|
|
Packit |
7d6a7d |
return lc $1 eq 'y';
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub quit_now
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
print "\nSorry, cannot continue.\n\n";
|
|
Packit |
7d6a7d |
exit 1;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub ask_or_quit
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
quit_now unless &ask;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
sub eta
|
|
Packit |
7d6a7d |
{
|
|
Packit |
7d6a7d |
my($start, $i, $n) = @_;
|
|
Packit |
7d6a7d |
return "--:--:--" if $i < 3;
|
|
Packit |
7d6a7d |
my $elapsed = tv_interval($start);
|
|
Packit |
7d6a7d |
my $h = int($elapsed*($n-$i)/$i);
|
|
Packit |
7d6a7d |
my $s = $h % 60; $h /= 60;
|
|
Packit |
7d6a7d |
my $m = $h % 60; $h /= 60;
|
|
Packit |
7d6a7d |
return sprintf "%02d:%02d:%02d", $h, $m, $s;
|
|
Packit |
7d6a7d |
}
|
|
Packit |
7d6a7d |
|
|
Packit |
7d6a7d |
1;
|