summaryrefslogtreecommitdiffstats
path: root/src/niceload
diff options
context:
space:
mode:
Diffstat (limited to 'src/niceload')
-rwxr-xr-xsrc/niceload1173
1 files changed, 1173 insertions, 0 deletions
diff --git a/src/niceload b/src/niceload
new file mode 100755
index 0000000..2e59aee
--- /dev/null
+++ b/src/niceload
@@ -0,0 +1,1173 @@
+#!/usr/bin/perl -w
+
+# Copyright (C) 2004-2010 Ole Tange, http://ole.tange.dk
+#
+# Copyright (C) 2010-2022 Ole Tange, http://ole.tange.dk and
+# Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, see <http://www.gnu.org/licenses/>
+# or write to the Free Software Foundation, Inc., 51 Franklin St,
+# Fifth Floor, Boston, MA 02110-1301 USA
+#
+# SPDX-FileCopyrightText: 2021-2022 Ole Tange, http://ole.tange.dk and Free Software and Foundation, Inc.
+# SPDX-License-Identifier: GPL-3.0-or-later
+
+use strict;
+use Getopt::Long;
+$Global::progname="niceload";
+$Global::version = 20221122;
+Getopt::Long::Configure("bundling","require_order");
+get_options_from_array(\@ARGV) || die_usage();
+if($opt::version) {
+ version();
+ exit 0;
+}
+if($opt::help) {
+ help();
+ exit 0;
+}
+if($opt::factor and $opt::suspend) {
+ # You cannot have --suspend and --factor
+ help();
+ exit;
+}
+
+if(not (defined $opt::start_io or defined $opt::run_io
+ or defined $opt::start_load or defined $opt::run_load
+ or defined $opt::start_mem or defined $opt::run_mem
+ or defined $opt::start_noswap or defined $opt::run_noswap
+ or defined $opt::io or defined $opt::load
+ or defined $opt::mem or defined $opt::noswap)) {
+ # Default is --runload=1
+ $opt::run_load = 1;
+}
+
+if(not defined $opt::start_io) { $opt::start_io = $opt::io; }
+if(not defined $opt::run_io) { $opt::run_io = $opt::io; }
+if(not defined $opt::start_load) { $opt::start_load = $opt::load; }
+if(not defined $opt::run_load) { $opt::run_load = $opt::load; }
+if(not defined $opt::start_mem) { $opt::start_mem = $opt::mem; }
+if(not defined $opt::run_mem) { $opt::run_mem = $opt::mem; }
+if(not defined $opt::start_noswap) { $opt::start_noswap = $opt::noswap; }
+if(not defined $opt::run_noswap) { $opt::run_noswap = $opt::noswap; }
+
+if(defined $opt::load) { multiply_binary_prefix($opt::load); }
+if(defined $opt::baseline) { collect_net_baseline(); }
+
+my $limit = Limit->new();
+my $process = Process->new($opt::nice,@ARGV);
+$::exitstatus = 0;
+if(@opt::prg) {
+ # Find all pids of prg
+ my($children_of, $parent_of, $name_of) = pid_table();
+ my @exact_name_pids;
+ my @substr_name_pids;
+ for my $name (@opt::prg) {
+ push(@exact_name_pids,
+ grep { index($name_of->{$_},$name) == 0 and $_ } keys %$name_of);
+ push(@substr_name_pids,
+ grep { index($name_of->{$_},$name) != -1 and $_ } keys %$name_of);
+ }
+ # Remove current pid
+ @exact_name_pids = grep { $_ != $$ } @exact_name_pids;
+ @substr_name_pids = grep { $_ != $$ } @substr_name_pids;
+ my @pids;
+ if(@exact_name_pids) {
+ @pids = @exact_name_pids;
+ } elsif(@substr_name_pids) {
+ warning("@opt::prg no exact matches. Using substrings.");
+ my %name_pids;
+ for(sort @substr_name_pids) {
+ # If the process has run for long, then time column will
+ # enter the name, so remove leading digits
+ $name_of->{$_} =~ s/^\d+ //;
+ # Remove arguments
+ $name_of->{$_} =~ s/ .*//;
+ push @{$name_pids{$name_of->{$_}}},$_;
+ }
+ warning("Niceloading",
+ map { "$_ (".(join" ",sort @{$name_pids{$_}}).")" } keys %name_pids
+ );
+ @pids = @substr_name_pids;
+ } else {
+ error("@opt::prg no matches.");
+ exit(1);
+ }
+ $process->set_pid(@pids);
+ $::resume_process = $process;
+ $SIG{TERM} = $SIG{INT} = \&resume;
+} elsif(@opt::pid) {
+ # Support --pid 3567,25678
+ @opt::pid = map { split /,/, $_ } @opt::pid;
+ $process->set_pid(@opt::pid);
+ $::resume_process = $process;
+ $SIG{TERM} = $SIG{INT} = \&resume;
+} elsif (@ARGV) {
+ # Wait until limit is below start_limit and run_limit
+ while($limit->over_start_limit()
+ or
+ ($limit->hard() and $limit->over_run_limit())) {
+ $limit->sleep_for_recheck();
+ }
+ $process->start();
+}
+
+while($process->is_alive()) {
+ if($limit->over_run_limit()) {
+ $process->suspend();
+ $limit->sleep_for_recheck();
+ if(not $limit->hard()) {
+ $process->resume();
+ $limit->sleep_while_running();
+ }
+ } else {
+ $process->resume();
+ $limit->sleep_while_running();
+ }
+}
+
+exit($::exitstatus);
+
+{
+ my %pid_parentpid_cmd;
+
+ sub pid_table {
+ # Returns:
+ # %children_of = { pid -> children of pid }
+ # %parent_of = { pid -> pid of parent }
+ # %name_of = { pid -> commandname }
+
+ if(not %pid_parentpid_cmd) {
+ # Filter for SysV-style `ps`
+ my $sysv = q( ps -ef | perl -ane '1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;).
+ q(s/^.{$s}//; print "@F[1,2] $_"' );
+ # Crazy msys: ' is not accepted on the cmd line, but " are treated as '
+ my $msys = q( ps -ef | perl -ane "1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;).
+ q(s/^.{$s}//; print qq{@F[1,2] $_}" );
+ # BSD-style `ps`
+ my $bsd = q(ps -o pid,ppid,command -ax);
+ %pid_parentpid_cmd =
+ (
+ 'aix' => $sysv,
+ 'cygwin' => $sysv,
+ 'darwin' => $bsd,
+ 'dec_osf' => $sysv,
+ 'dragonfly' => $bsd,
+ 'freebsd' => $bsd,
+ 'gnu' => $sysv,
+ 'hpux' => $sysv,
+ 'linux' => $sysv,
+ 'mirbsd' => $bsd,
+ 'msys' => $msys,
+ 'MSWin32' => $sysv,
+ 'netbsd' => $bsd,
+ 'nto' => $sysv,
+ 'openbsd' => $bsd,
+ 'solaris' => $sysv,
+ 'svr5' => $sysv,
+ 'syllable' => "echo ps not supported",
+ );
+ }
+ $pid_parentpid_cmd{$^O} or ::die_bug("pid_parentpid_cmd for $^O missing");
+
+ my (@pidtable,%parent_of,%children_of,%name_of);
+ # Table with pid -> children of pid
+ @pidtable = `$pid_parentpid_cmd{$^O}`;
+ my $p=$$;
+ for (@pidtable) {
+ # must match: 24436 21224 busybox ash
+ # must match: 24436 21224 <<empty on MacOSX running cubase>>
+ # or: perl -e 'while($0=" "){}'
+ if(/^\s*(\S+)\s+(\S+)\s+(\S+.*)/
+ or
+ $^O eq "darwin" and /^\s*(\S+)\s+(\S+)\s+()$/) {
+ $parent_of{$1} = $2;
+ push @{$children_of{$2}}, $1;
+ $name_of{$1} = $3;
+ } else {
+ ::die_bug("pidtable format: $_");
+ }
+ }
+ return(\%children_of, \%parent_of, \%name_of);
+ }
+}
+
+sub resume {
+ $::resume_process->resume();
+ exit(0);
+}
+
+sub status {
+ my @w = @_;
+ my $fh = *STDERR;
+ print $fh @w;
+ flush $fh;
+}
+
+sub warning {
+ my @w = @_;
+ my $prog = $Global::progname || "niceload";
+ status(map { ($prog, ": Warning: ", $_, "\n"); } @w);
+}
+
+sub error {
+ my @w = @_;
+ my $prog = $Global::progname || "niceload";
+ status(map { ($prog, ": Error: ", $_, "\n"); } @w);
+}
+
+sub uniq {
+ # Remove duplicates and return unique values
+ return keys %{{ map { $_ => 1 } @_ }};
+}
+
+sub multiply_binary_prefix {
+ # Evalualte numbers with binary prefix
+ # k=10^3, m=10^6, g=10^9, t=10^12, p=10^15, e=10^18, z=10^21, y=10^24
+ # K=2^10, M=2^20, G=2^30, T=2^40, P=2^50, E=2^70, Z=2^80, Y=2^80
+ # Ki=2^10, Mi=2^20, Gi=2^30, Ti=2^40, Pi=2^50, Ei=2^70, Zi=2^80, Yi=2^80
+ # ki=2^10, mi=2^20, gi=2^30, ti=2^40, pi=2^50, ei=2^70, zi=2^80, yi=2^80
+ # 13G = 13*1024*1024*1024 = 13958643712
+ my $s = shift;
+ $s =~ s/k/*1000/g;
+ $s =~ s/M/*1000*1000/g;
+ $s =~ s/G/*1000*1000*1000/g;
+ $s =~ s/T/*1000*1000*1000*1000/g;
+ $s =~ s/P/*1000*1000*1000*1000*1000/g;
+ $s =~ s/E/*1000*1000*1000*1000*1000*1000/g;
+ $s =~ s/Z/*1000*1000*1000*1000*1000*1000*1000/g;
+ $s =~ s/Y/*1000*1000*1000*1000*1000*1000*1000*1000/g;
+ $s =~ s/X/*1000*1000*1000*1000*1000*1000*1000*1000*1000/g;
+
+ $s =~ s/Ki?/*1024/gi;
+ $s =~ s/Mi?/*1024*1024/gi;
+ $s =~ s/Gi?/*1024*1024*1024/gi;
+ $s =~ s/Ti?/*1024*1024*1024*1024/gi;
+ $s =~ s/Pi?/*1024*1024*1024*1024*1024/gi;
+ $s =~ s/Ei?/*1024*1024*1024*1024*1024*1024/gi;
+ $s =~ s/Zi?/*1024*1024*1024*1024*1024*1024*1024/gi;
+ $s =~ s/Yi?/*1024*1024*1024*1024*1024*1024*1024*1024/gi;
+ $s =~ s/Xi?/*1024*1024*1024*1024*1024*1024*1024*1024*1024/gi;
+ $s = eval $s;
+ return $s;
+}
+
+sub get_options_from_array {
+ # Run GetOptions on @array
+ # Returns:
+ # true if parsing worked
+ # false if parsing failed
+ # @array is changed
+ my $array_ref = shift;
+ # A bit of shuffling of @ARGV needed as GetOptionsFromArray is not
+ # supported everywhere
+ my @save_argv;
+ my $this_is_ARGV = (\@::ARGV == $array_ref);
+ if(not $this_is_ARGV) {
+ @save_argv = @::ARGV;
+ @::ARGV = @{$array_ref};
+ }
+ my @retval = GetOptions
+ ("debug|D" => \$opt::debug,
+ "factor|f=s" => \$opt::factor,
+ "hard|H" => \$opt::hard,
+ "soft|S" => \$opt::soft,
+ "sensor=s" => \$opt::sensor,
+
+ "si|sio|startio|start-io=s" => \$opt::start_io,
+ "ri|rio|runio|run-io=s" => \$opt::run_io,
+ "io|I=s" => \$opt::io,
+
+ "sl|startload|start-load=s" => \$opt::start_load,
+ "rl|runload|run-load=s" => \$opt::run_load,
+ "load|L|l=s" => \$opt::load,
+
+ "sm|startmem|start-mem=s" => \$opt::start_mem,
+ "rm|runmem|run-mem=s" => \$opt::run_mem,
+ "mem|M=s" => \$opt::mem,
+
+ "sn|startnoswap|start-noswap|start-no-swap" => \$opt::start_noswap,
+ "rn|runnoswap|run-noswap|run-no-swap" => \$opt::run_noswap,
+ "noswap|N" => \$opt::noswap,
+
+ "battery|B" => \$opt::battery,
+ "net" => \$opt::net,
+ "nethops=i" => \$opt::nethops,
+ "baseline" => \$opt::baseline,
+
+ "nice|n=i" => \$opt::nice,
+ "program|prg=s" => \@opt::prg,
+ "process|pid|p=s" => \@opt::pid,
+ "suspend|s=s" => \$opt::suspend,
+ "recheck|t=s" => \$opt::recheck,
+ "quote|q" => \$opt::quote,
+ "help|h" => \$opt::help,
+ "verbose|v" => \$opt::verbose,
+ "version|V" => \$opt::version,
+ );
+ if($opt::battery) {
+ # niceload -l -1 --sensor \
+ # 'cat /sys/class/power_supply/BAT0/status \
+ # /proc/acpi/battery/BAT0/state 2>/dev/null |
+ # grep -i -q discharging; echo $?'
+ $opt::sensor = ('cat /sys/class/power_supply/BAT0/status '.
+ '/proc/acpi/battery/BAT0/state 2>/dev/null | '.
+ 'grep -i -q discharging; echo $?');
+ $opt::load = -1;
+ }
+ if($opt::net) {
+ $opt::nethops ||= 3;
+ }
+ if($opt::nethops) {
+ # niceload -l 0.01 --sensor 'netsensor_script'
+ $opt::sensor = netsensor_script($opt::nethops);
+ $opt::load ||= 0.01;
+ }
+ if(not $this_is_ARGV) {
+ @{$array_ref} = @::ARGV;
+ @::ARGV = @save_argv;
+ }
+ return @retval;
+}
+
+sub shell_quote_scalar {
+ # Quote for other shells
+ my $a = $_[0];
+ if(defined $a) {
+ # zsh wants '=' quoted
+ # Solaris sh wants ^ quoted.
+ # $a =~ s/([\002-\011\013-\032\\\#\?\`\(\)\{\}\[\]\^\*\>\<\~\|\; \"\!\$\&\'\202-\377])/\\$1/g;
+ # This is 1% faster than the above
+ if(($a =~ s/[\002-\011\013-\032\\\#\?\`\(\)\{\}\[\]\^\*\<\=\>\~\|\; \"\!\$\&\'\202-\377]/\\$&/go)
+ +
+ # quote newline as '\n'
+ ($a =~ s/[\n]/'\n'/go)) {
+ # A string was replaced
+ # No need to test for "" or \0
+ } elsif($a eq "") {
+ $a = "''";
+ } elsif($a eq "\0") {
+ $a = "";
+ }
+ }
+ return $a;
+}
+
+sub die_usage {
+ help();
+ exit 1;
+}
+
+
+sub help {
+ print q{
+Usage:
+ niceload [-v] [-n niceness] [-L loadavg] [-I io] [-N] [-M mem]
+ [-s suspend_sec|-f factor] [-H] [-S]
+ command or -p pid
+};
+}
+
+
+sub die_bug {
+ my $bugid = shift;
+ print STDERR
+ ("$Global::progname: This should not happen. You have found a bug.\n",
+ "Please contact <parallel\@gnu.org> and include:\n",
+ "* The version number: $Global::version\n",
+ "* The bugid: $bugid\n",
+ "* The command line being run\n",
+ "* The files being read (put the files on a webserver if they are big)\n",
+ "\n",
+ "If you get the error on smaller/fewer files, please include those instead.\n");
+ exit(255);
+}
+
+sub now {
+ # Returns time since epoch as in seconds with 3 decimals
+ # Uses:
+ # @Global::use
+ # Returns:
+ # $time = time now with millisecond accuracy
+ if(not $Global::use{"Time::HiRes"}) {
+ if(eval "use Time::HiRes qw ( time );") {
+ eval "sub TimeHiRestime { return Time::HiRes::time };";
+ } else {
+ eval "sub TimeHiRestime { return time() };";
+ }
+ $Global::use{"Time::HiRes"} = 1;
+ }
+
+ return (int(TimeHiRestime()*1000))/1000;
+}
+
+sub usleep {
+ # Sleep this many milliseconds.
+ my $ms = shift;
+ ::debug("Sleeping ",$ms," millisecs\n");
+ my $start = now();
+ my $now;
+ do {
+ # Something makes 'select' wake up too early
+ # when using --sensor
+ select(undef, undef, undef, $ms/1000);
+ $now = now();
+ } while($now < $start + $ms/1000);
+}
+
+sub debug {
+ if($opt::debug) {
+ print STDERR @_;
+ }
+}
+
+
+sub my_dump {
+ # Returns:
+ # ascii expression of object if Data::Dump(er) is installed
+ # error code otherwise
+ my @dump_this = (@_);
+ eval "use Data::Dump qw(dump);";
+ if ($@) {
+ # Data::Dump not installed
+ eval "use Data::Dumper;";
+ if ($@) {
+ my $err = "Neither Data::Dump nor Data::Dumper is installed\n".
+ "Not dumping output\n";
+ print STDERR $err;
+ return $err;
+ } else {
+ return Dumper(@dump_this);
+ }
+ } else {
+ eval "use Data::Dump qw(dump);";
+ return (Data::Dump::dump(@dump_this));
+ }
+}
+
+
+sub version {
+ # Returns: N/A
+ print join("\n",
+ "GNU $Global::progname $Global::version",
+ "Copyright (C) 2004,2005,2006,2007,2008,2009 Ole Tange",
+ "Copyright (C) 2010,2011 Ole Tange and Free Software Foundation, Inc.",
+ "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>",
+ "This is free software: you are free to change and redistribute it.",
+ "GNU $Global::progname comes with no warranty.",
+ "",
+ "Web site: http://www.gnu.org/software/parallel\n"
+ );
+}
+
+
+sub max {
+ # Returns:
+ # Maximum value of array
+ my $max;
+ for (@_) {
+ # Skip undefs
+ defined $_ or next;
+ defined $max or do { $max = $_; next; }; # Set $_ to the first non-undef
+ $max = ($max > $_) ? $max : $_;
+ }
+ return $max;
+}
+
+sub min {
+ # Returns:
+ # Minimum value of array
+ my $min;
+ for (@_) {
+ # Skip undefs
+ defined $_ or next;
+ defined $min or do { $min = $_; next; }; # Set $_ to the first non-undef
+ $min = ($min < $_) ? $min : $_;
+ }
+ return $min;
+}
+
+sub collect_net_baseline {
+ # Collect what a normal (unloaded) net connection looks line
+}
+
+
+sub netsensor_script {
+ # Script for --sensor when using --net
+ my $hops = shift;
+ my $perlscript = q{
+ use Net::Traceroute;
+ use Net::Ping;
+
+ my $medtrc = MedianTraceroute->new(shift);
+ $medtrc->set_remedian($medtrc->ping());
+ $medtrc->set_remedian($medtrc->ping());
+ while(1) {
+ my $ms = $medtrc->ping();
+ my $m = $medtrc->remedian();
+ if($m*1.5 < $ms) {
+ # Bad 1 = median*1.5 < current latency
+ } else {
+ # OK 0 = median*1.5 > current latency
+ $medtrc->set_remedian($ms);
+ }
+ printf("%d\n",$m*1.5 < $ms);
+ sleep(1);
+ }
+
+ package MedianTraceroute;
+
+ sub new {
+ my $class = shift;
+ my $hop = shift;
+ # Find router
+ my $tr = Net::Traceroute->new(host => "8.8.8.8",
+ max_ttl => $hop);
+ if($tr->found) {
+ $host = $tr->hop_query_host($hop, 0);
+ } else {
+ # ns1.censurfridns.dk
+ $tr = Net::Traceroute->new(host => "89.233.43.71",
+ max_ttl => $hop);
+ if($tr->found) {
+ $host = $tr->hop_query_host($hop, 0);
+ } else {
+ die("Cannot traceroute to 8.8.8.8 and 89.233.43.71");
+ }
+ }
+ my $p = Net::Ping->new();
+ $p->hires();
+
+ return bless {
+ 'hop' => $hop,
+ 'host' => $host,
+ 'pinger' => $p,
+ 'remedian_idx' => 0,
+ 'remedian_arr' => [],
+ 'remedian' => undef,
+ }, ref($class) || $class;
+ }
+
+ sub ping {
+ my $self = shift;
+ for(1..3) {
+ # Ping should never take longer than 5.5 sec
+ my ($ret, $duration, $ip) =
+ $self->{'pinger'}->ping($self->{'host'}, 5.5);
+ if($ret) {
+ return $duration;
+ }
+ }
+ warn("Ping failed 3 times.");
+ }
+
+ sub remedian {
+ my $self = shift;
+ return $self->{'remedian'};
+ }
+
+ sub set_remedian {
+ # Set median of the last 999^3 (=997002999) values using Remedian
+ #
+ # Rousseeuw, Peter J., and Gilbert W. Bassett Jr. "The remedian: A
+ # robust averaging method for large data sets." Journal of the
+ # American Statistical Association 85.409 (1990): 97-104.
+ my $self = shift;
+ my $val = shift;
+ my $i = $self->{'remedian_idx'}++;
+ my $rref = $self->{'remedian_arr'};
+ $rref->[0][$i%999] = $val;
+ $rref->[1][$i/999%999] = (sort @{$rref->[0]})[$#{$rref->[0]}/2];
+ $rref->[2][$i/999/999%999] = (sort @{$rref->[1]})[$#{$rref->[1]}/2];
+ $self->{'remedian'} = (sort @{$rref->[2]})[$#{$rref->[2]}/2];
+ }
+ };
+ return "perl -e ".shell_quote_scalar($perlscript)." $hops";
+}
+
+
+package Process;
+
+sub new {
+ my $class = shift;
+ my $nice = shift;
+ my @ARGV = @_;
+ if($nice) {
+ unshift(@ARGV, "nice", "-n", $nice);
+ }
+ return bless {
+ 'running' => 0, # Is the process running now?
+ 'command' => [@ARGV],
+ }, ref($class) || $class;
+}
+
+sub pgrp {
+ my $self = shift;
+ my @pgrp;
+ if(not $self->{'pgrp'}) {
+ for(@{$self->{'pids'}}) {
+ push @pgrp,-getpgrp($_);
+ }
+ @pgrp = ::uniq(@pgrp);
+ @{$self->{'pgrp'}} = @pgrp;
+ }
+ return @{$self->{'pgrp'}};
+}
+
+sub set_pid {
+ my $self = shift;
+ push(@{$self->{'pids'}},@_);
+ $self->{'running'} = 1;
+ $::exitstatus = 0;
+}
+
+sub start {
+ # Start the program
+ my $self = shift;
+ ::debug("Starting @{$self->{'command'}}\n");
+ $self->{'running'} = 1;
+ if($self->{'pid'} = fork) {
+ # set signal handler to kill children if parent is killed
+ push @{$self->{'pids'}}, $self->{'pid'};
+ $Global::process = $self;
+ $SIG{CHLD} = \&REAPER;
+ $SIG{INT}=\&kill_child_INT;
+ $SIG{TSTP}=\&kill_child_TSTP;
+ $SIG{CONT}=\&kill_child_CONT;
+ sleep 1; # Give child time to setpgrp(0,0);
+ } else {
+ setpgrp(0,0);
+ ::debug("Child pid: $$, pgrp: ",getpgrp $$,"\n");
+ ::debug("@{$self->{'command'}}\n");
+ if($opt::quote) {
+ system(@{$self->{'command'}});
+ } else {
+ system("@{$self->{'command'}}");
+ }
+ $::exitstatus = $? >> 8;
+ $::exitsignal = $? & 127;
+ ::debug("Child exit $::exitstatus\n");
+ exit($::exitstatus);
+ }
+}
+
+use POSIX ":sys_wait_h";
+use POSIX qw(:sys_wait_h);
+
+sub REAPER {
+ my $stiff;
+ while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
+ # do something with $stiff if you want
+ $::exitstatus = $? >> 8;
+ $::exitsignal = $? & 127;
+ }
+ $SIG{CHLD} = \&REAPER; # install *after* calling waitpid
+}
+
+
+sub kill_child_CONT {
+ my $self = $Global::process;
+ ::debug("SIGCONT received. Killing @{$self->{'pgrp'}}\n");
+ kill CONT => $self->pgrp();
+}
+
+
+sub kill_child_TSTP {
+ my $self = $Global::process;
+ ::debug("SIGTSTP received. Killing $self->{'pid'} and self ($$)\n");
+ kill TSTP => $self->pgrp();
+ kill STOP => -$$;
+ kill STOP => $$;
+}
+
+
+sub kill_child_INT {
+ my $self = $Global::process;
+ ::debug("SIGINT received.\n");
+ if(not @opt::pid) {
+ ::debug("Killing $self->{'pid'} Exit\n");
+ kill INT => $self->pgrp();
+ } else {
+ ::debug("Continue pids $self->{'pid'} Exit\n");
+ kill CONT => $self->pgrp();
+ }
+ exit;
+}
+
+
+sub resume {
+ my $self = shift;
+ ::debug("Resume @{$self->{'pids'}}\n");
+ if(not $self->{'running'}) {
+ # - = PID group
+ map { kill "CONT", -$_ } @{$self->{'pids'}};
+ # If using -p it is not in a group
+ map { kill "CONT", $_ } @{$self->{'pids'}};
+ $self->{'running'} = 1;
+ }
+}
+
+
+sub suspend {
+ my $self = shift;
+ ::debug("Suspend @{$self->{'pids'}}\n");
+ if($self->{'running'}) {
+ # - = PID group
+ map { kill "STOP", -$_ } @{$self->{'pids'}};
+ # If using -p it is not in a group
+ map { kill "STOP", $_ } @{$self->{'pids'}};
+ $self->{'running'} = 0;
+ }
+}
+
+
+sub is_alive {
+ # The process is dead if none of the pids exist
+ my $self = shift;
+ my ($exists) = 0;
+ for my $pid (@{$self->{'pids'}}) {
+ if(kill 0 => $pid) { $exists++ }
+ }
+ ::debug("is_alive: $exists\n");
+ return $exists;
+}
+
+
+package Limit;
+
+sub new {
+ my $class = shift;
+ my %limits = @_;
+ my $hard = $opt::soft ? 0 : $opt::hard;
+ my $runio = $opt::run_io ? ::multiply_binary_prefix($opt::run_io) : 0;
+ my $startio = $opt::start_io ? ::multiply_binary_prefix($opt::start_io) : 0;
+ my $runload = $opt::run_load ? ::multiply_binary_prefix($opt::run_load) : 0;
+ my $startload = $opt::start_load ? ::multiply_binary_prefix($opt::start_load) : 0;
+ my $runmem = $opt::run_mem ? ::multiply_binary_prefix($opt::run_mem) : 0;
+ my $startmem = $opt::start_mem ? ::multiply_binary_prefix($opt::start_mem) : 0;
+ my $runnoswap = $opt::run_noswap ? ::multiply_binary_prefix($opt::run_noswap) : 0;
+ my $startnoswap = $opt::start_noswap ? ::multiply_binary_prefix($opt::start_noswap) : 0;
+ my $recheck = $opt::recheck ? ::multiply_binary_prefix($opt::recheck) : 1; # Default
+ my $runtime = $opt::suspend ? ::multiply_binary_prefix($opt::suspend) : 1; # Default
+
+ return bless {
+ 'hard' => $hard,
+ 'recheck' => $recheck,
+ 'runio' => $runio,
+ 'startio' => $startio,
+ 'runload' => $runload,
+ 'startload' => $startload,
+ 'runmem' => $runmem,
+ 'startmem' => $startmem,
+ 'runnoswap' => $runnoswap,
+ 'startnoswap' => $startnoswap,
+ 'factor' => $opt::factor || 1,
+ 'recheck' => $recheck,
+ 'runtime' => $runtime,
+ 'over_run_limit' => 1,
+ 'over_start_limit' => 1,
+ 'verbose' => $opt::verbose,
+ }, ref($class) || $class;
+}
+
+
+sub over_run_limit {
+ my $self = shift;
+ my $status = 0;
+ if($self->{'runmem'}) {
+ # mem should be between 0-10ish
+ # 100% available => 0 (1-1)
+ # 50% available => 1 (2-1)
+ # 10% available => 9 (10-1)
+ my $mem = $self->mem_status();
+ ::debug("Run memory: $self->{'runmem'}/$mem\n");
+ $status += (::max(1,$self->{'runmem'}/$mem)-1);
+ }
+ if($self->{'runload'}) {
+ # If used with other limits load should be between 0-10ish
+ no warnings 'numeric';
+ my $load = $self->load_status();
+ if($self->{'runload'} > 0) {
+ # Stop if the load is above the limit
+ $status += ::max(0,$load - $self->{'runload'});
+ } else {
+ # Stop if the load is below the limit (for sensor)
+ $status += ::max(0,-$load - $self->{'runload'});
+ }
+ }
+ if($self->{'runnoswap'}) {
+ # swap should be between 0-10ish
+ # swap in or swap out or no swap = 0
+ # else log(swapin*swapout)
+ my $swap = $self->swap_status();
+ $status += log(::max(1, $swap - $self->{'runnoswap'}));
+ }
+ if($self->{'runio'}) {
+ my $io = $self->io_status();
+ $status += ::max(0,$io - $self->{'runio'});
+ }
+ $self->{'over_run_limit'} = $status;
+ if(not $opt::recheck) {
+ $self->{'recheck'} = $self->{'factor'} * $self->{'over_run_limit'};
+ }
+ ::debug("over_run_limit: $status\n");
+ return $self->{'over_run_limit'};
+}
+
+sub over_start_limit {
+ my $self = shift;
+ my $status = 0;
+ if($self->{'startmem'}) {
+ # mem should be between 0-10ish
+ # 100% available => 0 (1-1)
+ # 50% available => 1 (2-1)
+ # 10% available => 9 (10-1)
+ my $mem = $self->mem_status();
+ ::debug("Start memory: $self->{'startmem'}/$mem\n");
+ $status += (::max(1,$self->{'startmem'}/$mem)-1);
+ }
+ if($self->{'startload'}) {
+ # load should be between 0-10ish
+ # 0 load => 0
+ no warnings 'numeric';
+ my $load = $self->load_status();
+ if($self->{'startload'} > 0) {
+ # Stop if the load is above the limit
+ $status += ::max(0,$load - $self->{'startload'});
+ } else {
+ # Stop if the load is below the limit (for sensor)
+ $status += ::max(0,-$load - $self->{'startload'});
+ }
+ }
+ if($self->{'startnoswap'}) {
+ # swap should be between 0-10ish
+ # swap in or swap out or no swap = 0
+ # else log(swapin*swapout)
+ my $swap = $self->swap_status();
+ $status += log(::max(1, $swap - $self->{'startnoswap'}));
+ }
+ if($self->{'startio'}) {
+ my $io = $self->io_status();
+ $status += ::max(0,$io - $self->{'startio'});
+ }
+ $self->{'over_start_limit'} = $status;
+ if(not $opt::recheck) {
+ $self->{'recheck'} = $self->{'factor'} * $self->{'over_start_limit'};
+ }
+ ::debug("over_start_limit: $status\n");
+ return $self->{'over_start_limit'};
+}
+
+
+sub hard {
+ my $self = shift;
+ return $self->{'hard'};
+}
+
+
+sub verbose {
+ my $self = shift;
+ return $self->{'verbose'};
+}
+
+
+sub sleep_for_recheck {
+ my $self = shift;
+ if($self->{'recheck'} < 0.01) {
+ # Never sleep less than 0.01 sec
+ $self->{'recheck'} = 0.01;
+ }
+ if($self->verbose()) {
+ $self->{'recheck'} = int($self->{'recheck'}*100)/100;
+ print STDERR "Sleeping $self->{'recheck'}s\n";
+ }
+ ::debug("recheck in $self->{'recheck'}s\n");
+ ::usleep(1000*$self->{'recheck'});
+}
+
+
+sub sleep_while_running {
+ my $self = shift;
+ ::debug("check in $self->{'runtime'}s\n");
+ if($self->verbose()) {
+ $self->{'runtime'} = int($self->{'runtime'}*100)/100;
+ print STDERR "Running $self->{'runtime'}s\n";
+ }
+ ::usleep(1000*$self->{'runtime'});
+}
+
+
+sub nonblockGetLines {
+ # An non-blocking filehandle read that returns an array of lines read
+ # Returns: ($eof,@lines)
+ # Example: --sensor 'vmstat 1 | perl -ane '\''$|=1; 4..0 and print $F[8],"\n"'\'
+ my ($fh,$timeout) = @_;
+
+ $timeout = 0 unless defined $timeout;
+ my $rfd = '';
+ $::nonblockGetLines_last{$fh} = ''
+ unless defined $::nonblockGetLines_last{$fh};
+
+ vec($rfd,fileno($fh),1) = 1;
+ return unless select($rfd, undef, undef, $timeout)>=0;
+ # I'm not sure the following is necessary?
+ return unless vec($rfd,fileno($fh),1);
+ my $buf = '';
+ my $n = sysread($fh,$buf,1024*1024);
+
+ my $eof = eof($fh);
+ # If we're done, make sure to send the last unfinished line
+ return ($eof,$::nonblockGetLines_last{$fh}) unless $n;
+ # Prepend the last unfinished line
+ $buf = $::nonblockGetLines_last{$fh}.$buf;
+ # And save any newly unfinished lines
+ $::nonblockGetLines_last{$fh} =
+ (substr($buf,-1) !~ /[\r\n]/ && $buf =~ s/([^\r\n]*)$//)
+ ? $1 : '';
+ $buf ? ($eof,split(/\n/,$buf)) : ($eof);
+}
+
+sub read_sensor {
+ my $self = shift;
+ ::debug("read_sensor: ");
+ my $fh = $self->{'sensor_fh'};
+ if(not $fh) {
+ # Start the sensor
+ $self->{'sensor_pid'} =
+ open($fh, "-|", $opt::sensor) ||
+ ::die_bug("Cannot open: $opt::sensor");
+ $self->{'sensor_fh'} = $fh;
+ }
+ # Read as much as we can (non_block)
+ my ($eof,@lines) = nonblockGetLines($fh);
+
+ # new load = last full line
+ foreach my $line (@lines) {
+ if(defined $line) {
+ ::debug("Pipe saw: [$line] eof=$eof\n");
+ $Global::last_sensor_reading = $line;
+ }
+ }
+ if($eof) {
+ # End of file => Restart the sensor
+ close $fh;
+# waitpid($self->{'sensor_pid'},0);
+ $self->{'sensor_pid'} =
+ open($fh, "-|", $opt::sensor) ||
+ ::die_bug("Cannot open: $opt::sensor");
+ $self->{'sensor_fh'} = $fh;
+ }
+
+ return $Global::last_sensor_reading;
+}
+
+sub load_status {
+ # Returns:
+ # loadavg or sensor measurement
+ my $self = shift;
+
+ if($opt::sensor) {
+ if(not defined $self->{'load_status'} or
+ $self->{'load_status_cache_time'} + $self->{'recheck'} < time) {
+ $self->{'load_status'} = $self->read_sensor();
+ while (not defined $self->{'load_status'}) {
+ sleep 1;
+ $self->{'load_status'} = $self->read_sensor();
+ }
+ $self->{'load_status_cache_time'} = time - 0.001;
+ }
+ } else {
+ # Normal load avg
+ # Cache for some seconds
+ if(not defined $self->{'load_status'} or
+ $self->{'load_status_cache_time'} + $self->{'recheck'} < time) {
+ $self->{'load_status'} = load_status_linux() if $^O ne 'darwin';
+ $self->{'load_status'} = load_status_darwin() if $^O eq 'darwin';
+ $self->{'load_status_cache_time'} = time;
+ }
+ }
+ ::debug("load_status: ".$self->{'load_status'}."\n");
+ return $self->{'load_status'};
+}
+
+sub undef_as_zero {
+ my $a = shift;
+ return $a ? $a : 0;
+}
+
+
+sub load_status_linux {
+ my ($loadavg);
+ if(open(IN,"/proc/loadavg")) {
+ # Linux specific (but fast)
+ my $upString = <IN>;
+ if($upString =~ m/^(\d+\.\d+)/) {
+ $loadavg = $1;
+ } else {
+ ::die_bug("proc_loadavg");
+ }
+ close IN;
+ } elsif (open(IN,"LANG=C uptime|")) {
+ my $upString = <IN>;
+ if($upString =~ m/averages?.\s*(\d+\.\d+)/) {
+ $loadavg = $1;
+ } else {
+ ::die_bug("uptime");
+ }
+ close IN;
+ }
+ return $loadavg;
+}
+
+sub load_status_darwin {
+ my $loadavg = `sysctl vm.loadavg`;
+ if($loadavg =~ /vm\.loadavg: \{ ([0-9.]+) ([0-9.]+) ([0-9.]+) \}/) {
+ $loadavg = $1;
+ } elsif (open(IN,"LANG=C uptime|")) {
+ my $upString = <IN>;
+ if($upString =~ m/averages?.\s*(\d+\.\d+)/) {
+ $loadavg = $1;
+ } else {
+ ::die_bug("uptime");
+ }
+ close IN;
+ }
+ return $loadavg;
+}
+
+
+sub swap_status {
+ # Returns:
+ # (swap in)*(swap out) kb
+ my $self = shift;
+ my $status;
+ # Cache for some seconds
+ if(not defined $self->{'swap_status'} or
+ $self->{'swap_status_cache_time'}+$self->{'recheck'} < time) {
+ $status = swap_status_linux() if $^O ne 'darwin';
+ $status = swap_status_darwin() if $^O eq 'darwin';
+ $self->{'swap_status'} = ::max($status,0);
+ $self->{'swap_status_cache_time'} = time;
+ }
+ ::debug("swap_status: $self->{'swap_status'}\n");
+ return $self->{'swap_status'};
+}
+
+
+sub swap_status_linux {
+ my $swap_activity;
+ $swap_activity = "vmstat 1 2 | tail -n1 | awk '{print \$7*\$8}'";
+ # Run swap_activity measuring.
+ return qx{ $swap_activity };
+}
+
+sub swap_status_darwin {
+ # Mach Virtual Memory Statistics: (page size of 4096 bytes, cache hits 0%)
+ # free active spec inactive wire faults copy 0fill reactive pageins pageout
+ # 298987 251463 162637 69437 265724 29730558 299022 2308237 1 110058 0
+ # 298991 251479 162637 69437 265726 43 4 16 0 0 0
+ my ($pagesize, $pageins, $pageouts);
+ my @vm_stat = `vm_stat 1 | head -n4`;
+ $pagesize = $1 if $vm_stat[0] =~ m/page size of (\d+) bytes/;
+ $pageins = (split(/\s+/,$vm_stat[3]))[9];
+ $pageouts = (split(/\s+/,$vm_stat[3]))[10];
+ return ($pageins*$pageouts*$pagesize)/1024;
+}
+
+
+sub mem_status {
+ # Returns:
+ # number of bytes (free+cache)
+ my $self = shift;
+ # Cache for one second
+ if(not defined $self->{'mem_status'} or
+ $self->{'mem_status_cache_time'}+$self->{'recheck'} < time) {
+ $self->{'mem_status'} = mem_status_linux() if $^O ne 'darwin';
+ $self->{'mem_status'} = mem_status_darwin() if $^O eq 'darwin';
+ $self->{'mem_status_cache_time'} = time;
+ }
+ ::debug("mem_status: $self->{'mem_status'}\n");
+ return $self->{'mem_status'};
+}
+
+
+sub mem_status_linux {
+ # total used free shared buffers cached
+ # Mem: 3366496 2901664 464832 0 179228 1850692
+ # -/+ buffers/cache: 871744 2494752
+ # Swap: 6445476 1396860 5048616
+ my @free = `free`;
+ my $free = (split(/\s+/,$free[2]))[3];
+ return $free*1024;
+}
+
+sub mem_status_darwin {
+ # Mach Virtual Memory Statistics: (page size of 4096 bytes, cache hits 0%)
+ # free active spec inactive wire faults copy 0fill reactive pageins pageout
+ # 298987 251463 162637 69437 265724 29730558 299022 2308237 1 110058 0
+ # 298991 251479 162637 69437 265726 43 4 16 0 0 0
+ my ($pagesize, $pages_free, $pages_speculative);
+ my @vm_stat = `vm_stat 1 | head -n4`;
+ $pagesize = $1 if $vm_stat[0] =~ m/page size of (\d+) bytes/;
+ $pages_free = (split(/\s+/,$vm_stat[3]))[0];
+ $pages_speculative = (split(/\s+/,$vm_stat[3]))[2];
+ return ($pages_free+$pages_speculative)*$pagesize;
+}
+
+
+sub io_status {
+ # Returns:
+ # max percent for all devices
+ my $self = shift;
+ # Cache for one second
+ if(not defined $self->{'io_status'} or
+ $self->{'io_status_cache_time'}+$self->{'recheck'} < time) {
+ $self->{'io_status'} = io_status_linux() if $^O ne 'darwin';
+ $self->{'io_status'} = io_status_darwin() if $^O eq 'darwin';
+ $self->{'io_status_cache_time'} = time;
+ }
+ ::debug("io_status: $self->{'io_status'}\n");
+ return $self->{'io_status'};
+}
+
+
+sub io_status_linux {
+ # Device rrqm/s wrqm/s r/s w/s rkB/s wkB/s avgrq-sz avgqu-sz await r_await w_await svctm %util
+ # sda 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00
+ my @iostat_out = `LANG=C iostat -x 1 2`;
+ # throw away all execpt the last Device-section
+ my @iostat;
+ for(reverse @iostat_out) {
+ /Device/ and last;
+ my @col = (split(/\s+/,$_));
+ # Util% is last column
+ push @iostat, pop @col;
+ }
+ my $io = ::max(@iostat);
+ return undef_as_zero($io)/10;
+}
+
+sub io_status_darwin {
+ # disk0 disk1 disk2
+ # KB/t tps MB/s KB/t tps MB/s KB/t tps MB/s
+ # 14.95 15 0.22 11.18 35 0.38 2.00 0 0.00
+ # 0.00 0 0.00 0.00 0 0.00 0.00 0 0.00
+ my @iostat_out = `LANG=C iostat -d -w 1 -c 2`;
+ # return the MB/s of the last second (not the %util)
+ my @iostat = split(/\s+/, $iostat_out[3]);
+ my $io = $iostat[3] + $iostat[6] + $iostat[9];
+ return ::min($io, 10);
+}
+
+$::exitsignal = $::exitstatus = 0; # Dummy