src/niceload

   1 #!/usr/bin/perl -w
   2
   3 # Copyright (C) 2004-2010 Ole Tange, http://ole.tange.dk
   4 #
   5 # Copyright (C) 2010-2019 Ole Tange, http://ole.tange.dk and
   6 # Free Software Foundation, Inc.
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, see <http://www.gnu.org/licenses/>
  20 # or write to the Free Software Foundation, Inc., 51 Franklin St,
  21 # Fifth Floor, Boston, MA 02110-1301 USA
  22
  23 use strict;
  24 use Getopt::Long;
  25 $Global::progname="niceload";
  26 $Global::version = 20181223;
  27 Getopt::Long::Configure("bundling","require_order");
  28 get_options_from_array(\@ARGV) || die_usage();
  29 if($opt::version) {
  30     version();
  31     exit 0;
  32 }
  33 if($opt::help) {
  34     help();
  35     exit 0;
  36 }
  37 if($opt::factor and $opt::suspend) {
  38     # You cannot have --suspend and --factor
  39     help();
  40     exit;
  41 }
  42
  43 if(not (defined $opt::start_io or defined $opt::run_io
  44         or defined $opt::start_load or defined $opt::run_load
  45         or defined $opt::start_mem or defined $opt::run_mem
  46         or defined $opt::start_noswap or defined $opt::run_noswap
  47         or defined $opt::io or defined $opt::load
  48         or defined $opt::mem or defined $opt::noswap)) {
  49     # Default is --runload=1
  50     $opt::run_load = 1;
  51 }
  52
  53 if(not defined $opt::start_io) { $opt::start_io = $opt::io; }
  54 if(not defined $opt::run_io) { $opt::run_io = $opt::io; }
  55 if(not defined $opt::start_load) { $opt::start_load = $opt::load; }
  56 if(not defined $opt::run_load) { $opt::run_load = $opt::load; }
  57 if(not defined $opt::start_mem) { $opt::start_mem = $opt::mem; }
  58 if(not defined $opt::run_mem) { $opt::run_mem = $opt::mem; }
  59 if(not defined $opt::start_noswap) { $opt::start_noswap = $opt::noswap; }
  60 if(not defined $opt::run_noswap) { $opt::run_noswap = $opt::noswap; }
  61
  62 if(defined $opt::load) { multiply_binary_prefix($opt::load); }
  63 if(defined $opt::baseline) { collect_net_baseline(); }
  64
  65 my $limit = Limit->new();
  66 my $process = Process->new($opt::nice,@ARGV);
  67 $::exitstatus = 0;
  68 if(@opt::prg) {
  69     # Find all pids of prg
  70     my($children_of, $parent_of, $name_of) = pid_table();
  71     my @exact_name_pids;
  72     my @substr_name_pids;
  73     for my $name (@opt::prg) {
  74         push(@exact_name_pids,
  75              grep { index($name_of->{$_},$name) == 0 and $_ } keys %$name_of);
  76         push(@substr_name_pids,
  77              grep { index($name_of->{$_},$name) != -1 and $_ } keys %$name_of);
  78     }
  79     # Remove current pid
  80     @exact_name_pids = grep { $_ != $$ } @exact_name_pids;
  81     @substr_name_pids = grep { $_ != $$ } @substr_name_pids;
  82     my @pids;
  83     if(@exact_name_pids) {
  84         @pids = @exact_name_pids;
  85     } elsif(@substr_name_pids) {
  86         warning("@opt::prg no exact matches. Using substrings.");
  87         my %name_pids;
  88         for(sort @substr_name_pids) {
  89             # If the process has run for long, then time column will
  90             # enter the name, so remove leading digits
  91             $name_of->{$_} =~ s/^\d+ //;
  92             # Remove arguments
  93             $name_of->{$_} =~ s/ .*//;
  94             push @{$name_pids{$name_of->{$_}}},$_;
  95         }
  96         warning("Niceloading",
  97                 map { "$_ (".(join" ",sort @{$name_pids{$_}}).")" } keys %name_pids
  98                 );
  99         @pids = @substr_name_pids;
 100     } else {
 101         error("@opt::prg no matches.");
 102         exit(1);
 103     }
 104     $process->set_pid(@pids);
 105     $::resume_process = $process;
 106     $SIG{TERM} = $SIG{INT} = \&resume;
 107 } elsif(@opt::pid) {
 108     # Support --pid 3567,25678
 109     @opt::pid = map { split /,/, $_ } @opt::pid;
 110     $process->set_pid(@opt::pid);
 111     $::resume_process = $process;
 112     $SIG{TERM} = $SIG{INT} = \&resume;
 113 } elsif (@ARGV) {
 114     # Wait until limit is below start_limit and run_limit
 115     while($limit->over_start_limit()
 116           or
 117           ($limit->hard() and $limit->over_run_limit())) {
 118         $limit->sleep_for_recheck();
 119     }
 120     $process->start();
 121 }
 122
 123 while($process->is_alive()) {
 124     if($limit->over_run_limit()) {
 125         $process->suspend();
 126         $limit->sleep_for_recheck();
 127         if(not $limit->hard()) {
 128             $process->resume();
 129             $limit->sleep_while_running();
 130         }
 131     } else {
 132         $process->resume();
 133         $limit->sleep_while_running();
 134     }
 135 }
 136
 137 exit($::exitstatus);
 138
 139 {
 140     my %pid_parentpid_cmd;
 141
 142     sub pid_table {
 143         # Returns:
 144         #   %children_of = { pid -> children of pid }
 145         #   %parent_of = { pid -> pid of parent }
 146         #   %name_of = { pid -> commandname }
 147
 148         if(not %pid_parentpid_cmd) {
 149             # Filter for SysV-style `ps`
 150             my $sysv = q( ps -ef | perl -ane '1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;).
 151                 q(s/^.{$s}//; print "@F[1,2] $_"' );
 152             # Crazy msys: ' is not accepted on the cmd line, but " are treated as '
 153             my $msys = q( ps -ef | perl -ane "1..1 and /^(.*)CO?MM?A?N?D/ and $s=length $1;).
 154                 q(s/^.{$s}//; print qq{@F[1,2] $_}" );
 155             # BSD-style `ps`
 156             my $bsd = q(ps -o pid,ppid,command -ax);
 157             %pid_parentpid_cmd =
 158             (
 159              'aix' => $sysv,
 160              'cygwin' => $sysv,
 161              'darwin' => $bsd,
 162              'dec_osf' => $sysv,
 163              'dragonfly' => $bsd,
 164              'freebsd' => $bsd,
 165              'gnu' => $sysv,
 166              'hpux' => $sysv,
 167              'linux' => $sysv,
 168              'mirbsd' => $bsd,
 169              'msys' => $msys,
 170              'MSWin32' => $sysv,
 171              'netbsd' => $bsd,
 172              'nto' => $sysv,
 173              'openbsd' => $bsd,
 174              'solaris' => $sysv,
 175              'svr5' => $sysv,
 176              'syllable' => "echo ps not supported",
 177             );
 178         }
 179         $pid_parentpid_cmd{$^O} or ::die_bug("pid_parentpid_cmd for $^O missing");
 180
 181         my (@pidtable,%parent_of,%children_of,%name_of);
 182         # Table with pid -> children of pid
 183         @pidtable = `$pid_parentpid_cmd{$^O}`;
 184         my $p=$$;
 185         for (@pidtable) {
 186             # must match: 24436 21224 busybox ash
 187             # must match: 24436 21224 <<empty on MacOSX running cubase>>
 188             #   or: perl -e 'while($0=" "){}'
 189             if(/^\s*(\S+)\s+(\S+)\s+(\S+.*)/
 190                or
 191                $^O eq "darwin" and /^\s*(\S+)\s+(\S+)\s+()$/) {
 192                 $parent_of{$1} = $2;
 193                 push @{$children_of{$2}}, $1;
 194                 $name_of{$1} = $3;
 195             } else {
 196                 ::die_bug("pidtable format: $_");
 197             }
 198         }
 199         return(\%children_of, \%parent_of, \%name_of);
 200     }
 201 }
 202
 203 sub resume {
 204     $::resume_process->resume();
 205     exit(0);
 206 }
 207
 208 sub status {
 209     my @w = @_;
 210     my $fh = *STDERR;
 211     print $fh @w;
 212     flush $fh;
 213 }
 214
 215 sub warning {
 216     my @w = @_;
 217     my $prog = $Global::progname || "niceload";
 218     status(map { ($prog, ": Warning: ", $_, "\n"); } @w);
 219 }
 220
 221 sub error {
 222     my @w = @_;
 223     my $prog = $Global::progname || "niceload";
 224     status(map { ($prog, ": Error: ", $_, "\n"); } @w);
 225 }
 226
 227 sub uniq {
 228     # Remove duplicates and return unique values
 229     return keys %{{ map { $_ => 1 } @_ }};
 230 }
 231
 232 sub multiply_binary_prefix {
 233     # Evalualte numbers with binary prefix
 234     # k=10^3, m=10^6, g=10^9, t=10^12, p=10^15, e=10^18, z=10^21, y=10^24
 235     # K=2^10, M=2^20, G=2^30, T=2^40, P=2^50, E=2^70, Z=2^80, Y=2^80
 236     # Ki=2^10, Mi=2^20, Gi=2^30, Ti=2^40, Pi=2^50, Ei=2^70, Zi=2^80, Yi=2^80
 237     # ki=2^10, mi=2^20, gi=2^30, ti=2^40, pi=2^50, ei=2^70, zi=2^80, yi=2^80
 238     # 13G = 13*1024*1024*1024 = 13958643712
 239     my $s = shift;
 240     $s =~ s/k/*1000/g;
 241     $s =~ s/M/*1000*1000/g;
 242     $s =~ s/G/*1000*1000*1000/g;
 243     $s =~ s/T/*1000*1000*1000*1000/g;
 244     $s =~ s/P/*1000*1000*1000*1000*1000/g;
 245     $s =~ s/E/*1000*1000*1000*1000*1000*1000/g;
 246     $s =~ s/Z/*1000*1000*1000*1000*1000*1000*1000/g;
 247     $s =~ s/Y/*1000*1000*1000*1000*1000*1000*1000*1000/g;
 248     $s =~ s/X/*1000*1000*1000*1000*1000*1000*1000*1000*1000/g;
 249
 250     $s =~ s/Ki?/*1024/gi;
 251     $s =~ s/Mi?/*1024*1024/gi;
 252     $s =~ s/Gi?/*1024*1024*1024/gi;
 253     $s =~ s/Ti?/*1024*1024*1024*1024/gi;
 254     $s =~ s/Pi?/*1024*1024*1024*1024*1024/gi;
 255     $s =~ s/Ei?/*1024*1024*1024*1024*1024*1024/gi;
 256     $s =~ s/Zi?/*1024*1024*1024*1024*1024*1024*1024/gi;
 257     $s =~ s/Yi?/*1024*1024*1024*1024*1024*1024*1024*1024/gi;
 258     $s =~ s/Xi?/*1024*1024*1024*1024*1024*1024*1024*1024*1024/gi;
 259     $s = eval $s;
 260     return $s;
 261 }
 262
 263 sub get_options_from_array {
 264     # Run GetOptions on @array
 265     # Returns:
 266     #   true if parsing worked
 267     #   false if parsing failed
 268     #   @array is changed
 269     my $array_ref = shift;
 270     # A bit of shuffling of @ARGV needed as GetOptionsFromArray is not
 271     # supported everywhere
 272     my @save_argv;
 273     my $this_is_ARGV = (\@::ARGV == $array_ref);
 274     if(not $this_is_ARGV) {
 275         @save_argv = @::ARGV;
 276         @::ARGV = @{$array_ref};
 277     }
 278     my @retval = GetOptions
 279         ("debug|D" => \$opt::debug,
 280          "factor|f=s" => \$opt::factor,
 281          "hard|H" => \$opt::hard,
 282          "soft|S" => \$opt::soft,
 283          "sensor=s" => \$opt::sensor,
 284
 285          "si|sio|startio|start-io=s" => \$opt::start_io,
 286          "ri|rio|runio|run-io=s" => \$opt::run_io,
 287          "io|I=s" => \$opt::io,
 288
 289          "sl|startload|start-load=s" => \$opt::start_load,
 290          "rl|runload|run-load=s" => \$opt::run_load,
 291          "load|L|l=s" => \$opt::load,
 292
 293          "sm|startmem|start-mem=s" => \$opt::start_mem,
 294          "rm|runmem|run-mem=s" => \$opt::run_mem,
 295          "mem|M=s" => \$opt::mem,
 296
 297          "sn|startnoswap|start-noswap|start-no-swap" => \$opt::start_noswap,
 298          "rn|runnoswap|run-noswap|run-no-swap" => \$opt::run_noswap,
 299          "noswap|N" => \$opt::noswap,
 300
 301          "battery|B" => \$opt::battery,
 302          "net" => \$opt::net,
 303          "nethops=i" => \$opt::nethops,
 304          "baseline" => \$opt::baseline,
 305
 306          "nice|n=i" => \$opt::nice,
 307          "program|prg=s" => \@opt::prg,
 308          "process|pid|p=s" => \@opt::pid,
 309          "suspend|s=s" => \$opt::suspend,
 310          "recheck|t=s" => \$opt::recheck,
 311          "quote|q" => \$opt::quote,
 312          "help|h" => \$opt::help,
 313          "verbose|v" => \$opt::verbose,
 314          "version|V" => \$opt::version,
 315         );
 316     if($opt::battery) {
 317         # niceload -l -1 --sensor \
 318         #   'cat /sys/class/power_supply/BAT0/status \
 319         #    /proc/acpi/battery/BAT0/state 2>/dev/null |
 320         #    grep -i -q discharging; echo $?'
 321         $opt::sensor = ('cat /sys/class/power_supply/BAT0/status '.
 322                         '/proc/acpi/battery/BAT0/state 2>/dev/null | '.
 323                         'grep -i -q discharging; echo $?');
 324         $opt::load = -1;
 325     }
 326     if($opt::net) {
 327         $opt::nethops ||= 3;
 328     }
 329     if($opt::nethops) {
 330         # niceload -l 0.01 --sensor 'netsensor_script'
 331         $opt::sensor = netsensor_script($opt::nethops);
 332         $opt::load ||= 0.01;
 333     }
 334     if(not $this_is_ARGV) {
 335         @{$array_ref} = @::ARGV;
 336         @::ARGV = @save_argv;
 337     }
 338     return @retval;
 339 }
 340
 341 sub shell_quote_scalar {
 342     # Quote for other shells
 343     my $a = $_[0];
 344     if(defined $a) {
 345         # zsh wants '=' quoted
 346         # Solaris sh wants ^ quoted.
 347         # $a =~ s/([\002-\011\013-\032\\\#\?\`\(\)\{\}\[\]\^\*\>\<\~\|\; \"\!\$\&\'\202-\377])/\\$1/g;
 348         # This is 1% faster than the above
 349         if(($a =~ s/[\002-\011\013-\032\\\#\?\`\(\)\{\}\[\]\^\*\<\=\>\~\|\; \"\!\$\&\'\202-\377]/\\$&/go)
 350            +
 351            # quote newline as '\n'
 352            ($a =~ s/[\n]/'\n'/go)) {
 353             # A string was replaced
 354             # No need to test for "" or \0
 355         } elsif($a eq "") {
 356             $a = "''";
 357         } elsif($a eq "\0") {
 358             $a = "";
 359         }
 360     }
 361     return $a;
 362 }
 363
 364 sub die_usage {
 365     help();
 366     exit 1;
 367 }
 368
 369
 370 sub help {
 371     print q{
 372 Usage:
 373    niceload [-v] [-n niceness] [-L loadavg] [-I io] [-N] [-M mem]
 374             [-s suspend_sec|-f factor] [-H] [-S]
 375             command or -p pid
 376 };
 377 }
 378
 379
 380 sub die_bug {
 381     my $bugid = shift;
 382     print STDERR
 383         ("$Global::progname: This should not happen. You have found a bug.\n",
 384          "Please contact <parallel\@gnu.org> and include:\n",
 385          "* The version number: $Global::version\n",
 386          "* The bugid: $bugid\n",
 387          "* The command line being run\n",
 388          "* The files being read (put the files on a webserver if they are big)\n",
 389          "\n",
 390          "If you get the error on smaller/fewer files, please include those instead.\n");
 391     exit(255);
 392 }
 393
 394 sub now {
 395     # Returns time since epoch as in seconds with 3 decimals
 396     # Uses:
 397     #   @Global::use
 398     # Returns:
 399     #   $time = time now with millisecond accuracy
 400     if(not $Global::use{"Time::HiRes"}) {
 401         if(eval "use Time::HiRes qw ( time );") {
 402             eval "sub TimeHiRestime { return Time::HiRes::time };";
 403         } else {
 404             eval "sub TimeHiRestime { return time() };";
 405         }
 406         $Global::use{"Time::HiRes"} = 1;
 407     }
 408
 409     return (int(TimeHiRestime()*1000))/1000;
 410 }
 411
 412 sub usleep {
 413     # Sleep this many milliseconds.
 414     my $ms = shift;
 415     ::debug("Sleeping ",$ms," millisecs\n");
 416     my $start = now();
 417     my $now;
 418     do {
 419         # Something makes 'select' wake up too early
 420         # when using --sensor
 421         select(undef, undef, undef, $ms/1000);
 422         $now = now();
 423     } while($now < $start + $ms/1000);
 424 }
 425
 426 sub debug {
 427     if($opt::debug) {
 428         print STDERR @_;
 429     }
 430 }
 431
 432
 433 sub my_dump {
 434     # Returns:
 435     #   ascii expression of object if Data::Dump(er) is installed
 436     #   error code otherwise
 437     my @dump_this = (@_);
 438     eval "use Data::Dump qw(dump);";
 439     if ($@) {
 440         # Data::Dump not installed
 441         eval "use Data::Dumper;";
 442         if ($@) {
 443             my $err =  "Neither Data::Dump nor Data::Dumper is installed\n".
 444                 "Not dumping output\n";
 445             print STDERR $err;
 446             return $err;
 447         } else {
 448             return Dumper(@dump_this);
 449         }
 450     } else {
 451         eval "use Data::Dump qw(dump);";
 452         return (Data::Dump::dump(@dump_this));
 453     }
 454 }
 455
 456
 457 sub version {
 458     # Returns: N/A
 459     print join("\n",
 460                "GNU $Global::progname $Global::version",
 461                "Copyright (C) 2004,2005,2006,2007,2008,2009 Ole Tange",
 462                "Copyright (C) 2010,2011 Ole Tange and Free Software Foundation, Inc.",
 463                "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>",
 464                "This is free software: you are free to change and redistribute it.",
 465                "GNU $Global::progname comes with no warranty.",
 466                "",
 467                "Web site: http://www.gnu.org/software/parallel\n"
 468         );
 469 }
 470
 471
 472 sub max {
 473     # Returns:
 474     #   Maximum value of array
 475     my $max;
 476     for (@_) {
 477         # Skip undefs
 478         defined $_ or next;
 479         defined $max or do { $max = $_; next; }; # Set $_ to the first non-undef
 480         $max = ($max > $_) ? $max : $_;
 481     }
 482     return $max;
 483 }
 484
 485 sub min {
 486     # Returns:
 487     #   Minimum value of array
 488     my $min;
 489     for (@_) {
 490         # Skip undefs
 491         defined $_ or next;
 492         defined $min or do { $min = $_; next; }; # Set $_ to the first non-undef
 493         $min = ($min < $_) ? $min : $_;
 494     }
 495     return $min;
 496 }
 497
 498 sub collect_net_baseline {
 499     # Collect what a normal (unloaded) net connection looks line
 500 }
 501
 502
 503 sub netsensor_script {
 504     # Script for --sensor when using --net
 505     my $hops = shift;
 506     my $perlscript = q{
 507         use Net::Traceroute;
 508         use Net::Ping;
 509
 510         my $medtrc = MedianTraceroute->new(shift);
 511         $medtrc->set_remedian($medtrc->ping());
 512         $medtrc->set_remedian($medtrc->ping());
 513         while(1) {
 514             my $ms = $medtrc->ping();
 515             my $m = $medtrc->remedian();
 516             if($m*1.5 < $ms) {
 517                 # Bad 1 = median*1.5 < current latency
 518             } else {
 519                 # OK 0 = median*1.5 > current latency
 520                 $medtrc->set_remedian($ms);
 521             }
 522             printf("%d\n",$m*1.5 < $ms);
 523             sleep(1);
 524         }
 525
 526         package MedianTraceroute;
 527
 528         sub new {
 529             my $class = shift;
 530             my $hop = shift;
 531             # Find router
 532             my $tr = Net::Traceroute->new(host => "8.8.8.8",
 533                                           max_ttl => $hop);
 534             if($tr->found) {
 535                 $host = $tr->hop_query_host($hop, 0);
 536             } else {
 537                 # ns1.censurfridns.dk
 538                 $tr = Net::Traceroute->new(host => "89.233.43.71",
 539                                            max_ttl => $hop);
 540                 if($tr->found) {
 541                     $host = $tr->hop_query_host($hop, 0);
 542                 } else {
 543                     die("Cannot traceroute to 8.8.8.8 and 89.233.43.71");
 544                 }
 545             }
 546             my $p = Net::Ping->new();
 547             $p->hires();
 548
 549             return bless {
 550                 'hop' => $hop,
 551                 'host' => $host,
 552                 'pinger' => $p,
 553                 'remedian_idx' => 0,
 554                 'remedian_arr' => [],
 555                 'remedian' => undef,
 556             }, ref($class) || $class;
 557         }
 558
 559         sub ping {
 560             my $self = shift;
 561             for(1..3) {
 562                 # Ping should never take longer than 5.5 sec
 563                 my ($ret, $duration, $ip) =
 564                     $self->{'pinger'}->ping($self->{'host'}, 5.5);
 565                 if($ret) {
 566                     return $duration;
 567                 }
 568             }
 569             warn("Ping failed 3 times.");
 570         }
 571
 572         sub remedian {
 573             my $self = shift;
 574             return $self->{'remedian'};
 575         }
 576
 577         sub set_remedian {
 578             # Set median of the last 999^3 (=997002999) values using Remedian
 579             #
 580             # Rousseeuw, Peter J., and Gilbert W. Bassett Jr. "The remedian: A
 581             # robust averaging method for large data sets." Journal of the
 582             # American Statistical Association 85.409 (1990): 97-104.
 583             my $self = shift;
 584             my $val = shift;
 585             my $i = $self->{'remedian_idx'}++;
 586             my $rref = $self->{'remedian_arr'};
 587             $rref->[0][$i%999] = $val;
 588             $rref->[1][$i/999%999] = (sort @{$rref->[0]})[$#{$rref->[0]}/2];
 589             $rref->[2][$i/999/999%999] = (sort @{$rref->[1]})[$#{$rref->[1]}/2];
 590             $self->{'remedian'} = (sort @{$rref->[2]})[$#{$rref->[2]}/2];
 591         }
 592     };
 593     return "perl -e ".shell_quote_scalar($perlscript)." $hops";
 594 }
 595
 596
 597 package Process;
 598
 599 sub new {
 600     my $class = shift;
 601     my $nice = shift;
 602     my @ARGV = @_;
 603     if($nice) {
 604         unshift(@ARGV, "nice", "-n", $nice);
 605     }
 606     return bless {
 607         'running' => 0, # Is the process running now?
 608         'command' => [@ARGV],
 609     }, ref($class) || $class;
 610 }
 611
 612 sub pgrp {
 613     my $self = shift;
 614     my @pgrp;
 615     if(not $self->{'pgrp'}) {
 616         for(@{$self->{'pids'}}) {
 617             push @pgrp,-getpgrp($_);
 618         }
 619         @pgrp = ::uniq(@pgrp);
 620         @{$self->{'pgrp'}} = @pgrp;
 621     }
 622     return @{$self->{'pgrp'}};
 623 }
 624
 625 sub set_pid {
 626     my $self = shift;
 627     push(@{$self->{'pids'}},@_);
 628     $self->{'running'} = 1;
 629     $::exitstatus = 0;
 630 }
 631
 632 sub start {
 633     # Start the program
 634     my $self = shift;
 635     ::debug("Starting @{$self->{'command'}}\n");
 636     $self->{'running'} = 1;
 637     if($self->{'pid'} = fork) {
 638         # set signal handler to kill children if parent is killed
 639         push @{$self->{'pids'}}, $self->{'pid'};
 640         $Global::process = $self;
 641         $SIG{CHLD} = \&REAPER;
 642         $SIG{INT}=\&kill_child_INT;
 643         $SIG{TSTP}=\&kill_child_TSTP;
 644         $SIG{CONT}=\&kill_child_CONT;
 645         sleep 1; # Give child time to setpgrp(0,0);
 646     } else {
 647         setpgrp(0,0);
 648         ::debug("Child pid: $$, pgrp: ",getpgrp $$,"\n");
 649         ::debug("@{$self->{'command'}}\n");
 650         if($opt::quote) {
 651             system(@{$self->{'command'}});
 652         } else {
 653             system("@{$self->{'command'}}");
 654         }
 655         $::exitstatus = $? >> 8;
 656         $::exitsignal = $? & 127;
 657         ::debug("Child exit $::exitstatus\n");
 658         exit($::exitstatus);
 659     }
 660 }
 661
 662 use POSIX ":sys_wait_h";
 663 use POSIX qw(:sys_wait_h);
 664
 665 sub REAPER {
 666     my $stiff;
 667     while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
 668         # do something with $stiff if you want
 669         $::exitstatus = $? >> 8;
 670         $::exitsignal = $? & 127;
 671     }
 672     $SIG{CHLD} = \&REAPER;                  # install *after* calling waitpid
 673 }
 674
 675
 676 sub kill_child_CONT {
 677     my $self = $Global::process;
 678     ::debug("SIGCONT received. Killing @{$self->{'pgrp'}}\n");
 679     kill CONT => $self->pgrp();
 680 }
 681
 682
 683 sub kill_child_TSTP {
 684     my $self = $Global::process;
 685     ::debug("SIGTSTP received. Killing $self->{'pid'} and self ($$)\n");
 686     kill TSTP => $self->pgrp();
 687     kill STOP => -$$;
 688     kill STOP => $$;
 689 }
 690
 691
 692 sub kill_child_INT {
 693     my $self = $Global::process;
 694     ::debug("SIGINT received.\n");
 695     if(not @opt::pid) {
 696         ::debug("Killing $self->{'pid'} Exit\n");
 697         kill INT => $self->pgrp();
 698     } else {
 699         ::debug("Continue pids $self->{'pid'} Exit\n");
 700         kill CONT => $self->pgrp();
 701     }
 702     exit;
 703 }
 704
 705
 706 sub resume {
 707     my $self = shift;
 708     ::debug("Resume @{$self->{'pids'}}\n");
 709     if(not $self->{'running'}) {
 710         # - = PID group
 711         map { kill "CONT", -$_ } @{$self->{'pids'}};
 712         # If using -p it is not in a group
 713         map { kill "CONT", $_ } @{$self->{'pids'}};
 714         $self->{'running'} = 1;
 715     }
 716 }
 717
 718
 719 sub suspend {
 720     my $self = shift;
 721     ::debug("Suspend @{$self->{'pids'}}\n");
 722     if($self->{'running'}) {
 723         # - = PID group
 724         map { kill "STOP", -$_ } @{$self->{'pids'}};
 725         # If using -p it is not in a group
 726         map { kill "STOP", $_ } @{$self->{'pids'}};
 727         $self->{'running'} = 0;
 728     }
 729 }
 730
 731
 732 sub is_alive {
 733     # The process is dead if none of the pids exist
 734     my $self = shift;
 735     my ($exists) = 0;
 736     for my $pid (@{$self->{'pids'}}) {
 737         if(kill 0 => $pid) { $exists++ }
 738     }
 739     ::debug("is_alive: $exists\n");
 740     return $exists;
 741 }
 742
 743
 744 package Limit;
 745
 746 sub new {
 747     my $class = shift;
 748     my %limits = @_;
 749     my $hard = $opt::soft ? 0 : $opt::hard;
 750     my $runio = $opt::run_io ? ::multiply_binary_prefix($opt::run_io) : 0;
 751     my $startio = $opt::start_io ? ::multiply_binary_prefix($opt::start_io) : 0;
 752     my $runload = $opt::run_load ? ::multiply_binary_prefix($opt::run_load) : 0;
 753     my $startload = $opt::start_load ? ::multiply_binary_prefix($opt::start_load) : 0;
 754     my $runmem = $opt::run_mem ? ::multiply_binary_prefix($opt::run_mem) : 0;
 755     my $startmem = $opt::start_mem ? ::multiply_binary_prefix($opt::start_mem) : 0;
 756     my $runnoswap = $opt::run_noswap ? ::multiply_binary_prefix($opt::run_noswap) : 0;
 757     my $startnoswap = $opt::start_noswap ? ::multiply_binary_prefix($opt::start_noswap) : 0;
 758     my $recheck = $opt::recheck ? ::multiply_binary_prefix($opt::recheck) : 1; # Default
 759     my $runtime = $opt::suspend ? ::multiply_binary_prefix($opt::suspend) : 1; # Default
 760
 761     return bless {
 762         'hard' => $hard,
 763         'recheck' => $recheck,
 764         'runio' => $runio,
 765         'startio' => $startio,
 766         'runload' => $runload,
 767         'startload' => $startload,
 768         'runmem' => $runmem,
 769         'startmem' => $startmem,
 770         'runnoswap' => $runnoswap,
 771         'startnoswap' => $startnoswap,
 772         'factor' => $opt::factor || 1,
 773         'recheck' => $recheck,
 774         'runtime' => $runtime,
 775         'over_run_limit' => 1,
 776         'over_start_limit' => 1,
 777         'verbose' => $opt::verbose,
 778     }, ref($class) || $class;
 779 }
 780
 781
 782 sub over_run_limit {
 783     my $self = shift;
 784     my $status = 0;
 785     if($self->{'runmem'}) {
 786         # mem should be between 0-10ish
 787         # 100% available => 0 (1-1)
 788         # 50% available => 1 (2-1)
 789         # 10% available => 9 (10-1)
 790         my $mem = $self->mem_status();
 791         ::debug("Run memory: $self->{'runmem'}/$mem\n");
 792         $status += (::max(1,$self->{'runmem'}/$mem)-1);
 793     }
 794     if($self->{'runload'}) {
 795         # If used with other limits load should be between 0-10ish
 796         no warnings 'numeric';
 797         my $load = $self->load_status();
 798         if($self->{'runload'} > 0) {
 799             # Stop if the load is above the limit
 800             $status += ::max(0,$load - $self->{'runload'});
 801         } else {
 802             # Stop if the load is below the limit (for sensor)
 803             $status += ::max(0,-$load - $self->{'runload'});
 804         }
 805     }
 806     if($self->{'runnoswap'}) {
 807         # swap should be between 0-10ish
 808         # swap in or swap out or no swap = 0
 809         # else log(swapin*swapout)
 810         my $swap = $self->swap_status();
 811         $status += log(::max(1, $swap - $self->{'runnoswap'}));
 812     }
 813     if($self->{'runio'}) {
 814         my $io = $self->io_status();
 815         $status += ::max(0,$io - $self->{'runio'});
 816     }
 817     $self->{'over_run_limit'} = $status;
 818     if(not $opt::recheck) {
 819         $self->{'recheck'} = $self->{'factor'} * $self->{'over_run_limit'};
 820     }
 821     ::debug("over_run_limit: $status\n");
 822     return $self->{'over_run_limit'};
 823 }
 824
 825 sub over_start_limit {
 826     my $self = shift;
 827     my $status = 0;
 828     if($self->{'startmem'}) {
 829         # mem should be between 0-10ish
 830         # 100% available => 0 (1-1)
 831         # 50% available => 1 (2-1)
 832         # 10% available => 9 (10-1)
 833         my $mem = $self->mem_status();
 834         ::debug("Start memory: $self->{'startmem'}/$mem\n");
 835         $status += (::max(1,$self->{'startmem'}/$mem)-1);
 836     }
 837     if($self->{'startload'}) {
 838         # load should be between 0-10ish
 839         # 0 load => 0
 840         no warnings 'numeric';
 841         my $load = $self->load_status();
 842         if($self->{'startload'} > 0) {
 843             # Stop if the load is above the limit
 844             $status += ::max(0,$load - $self->{'startload'});
 845         } else {
 846             # Stop if the load is below the limit (for sensor)
 847             $status += ::max(0,-$load - $self->{'startload'});
 848         }
 849     }
 850     if($self->{'startnoswap'}) {
 851         # swap should be between 0-10ish
 852         # swap in or swap out or no swap = 0
 853         # else log(swapin*swapout)
 854         my $swap = $self->swap_status();
 855         $status += log(::max(1, $swap - $self->{'startnoswap'}));
 856     }
 857     if($self->{'startio'}) {
 858         my $io = $self->io_status();
 859         $status += ::max(0,$io - $self->{'startio'});
 860     }
 861     $self->{'over_start_limit'} = $status;
 862     if(not $opt::recheck) {
 863         $self->{'recheck'} = $self->{'factor'} * $self->{'over_start_limit'};
 864     }
 865     ::debug("over_start_limit: $status\n");
 866     return $self->{'over_start_limit'};
 867 }
 868
 869
 870 sub hard {
 871     my $self = shift;
 872     return $self->{'hard'};
 873 }
 874
 875
 876 sub verbose {
 877     my $self = shift;
 878     return $self->{'verbose'};
 879 }
 880
 881
 882 sub sleep_for_recheck {
 883     my $self = shift;
 884     if($self->{'recheck'} < 0.01) {
 885         # Never sleep less than 0.01 sec
 886         $self->{'recheck'} = 0.01;
 887     }
 888     if($self->verbose()) {
 889         $self->{'recheck'} = int($self->{'recheck'}*100)/100;
 890         print STDERR "Sleeping $self->{'recheck'}s\n";
 891     }
 892     ::debug("recheck in $self->{'recheck'}s\n");
 893     ::usleep(1000*$self->{'recheck'});
 894 }
 895
 896
 897 sub sleep_while_running {
 898     my $self = shift;
 899     ::debug("check in $self->{'runtime'}s\n");
 900     if($self->verbose()) {
 901         $self->{'runtime'} = int($self->{'runtime'}*100)/100;
 902         print STDERR "Running $self->{'runtime'}s\n";
 903     }
 904     ::usleep(1000*$self->{'runtime'});
 905 }
 906
 907
 908 sub nonblockGetLines {
 909     # An non-blocking filehandle read that returns an array of lines read
 910     # Returns:  ($eof,@lines)
 911     # Example: --sensor 'vmstat 1 | perl -ane '\''$|=1; 4..0 and print $F[8],"\n"'\'
 912     my ($fh,$timeout) = @_;
 913
 914     $timeout = 0 unless defined $timeout;
 915     my $rfd = '';
 916     $::nonblockGetLines_last{$fh} = ''
 917         unless defined $::nonblockGetLines_last{$fh};
 918
 919     vec($rfd,fileno($fh),1) = 1;
 920     return unless select($rfd, undef, undef, $timeout)>=0;
 921     # I'm not sure the following is necessary?
 922     return unless vec($rfd,fileno($fh),1);
 923     my $buf = '';
 924     my $n = sysread($fh,$buf,1024*1024);
 925
 926     my $eof = eof($fh);
 927     # If we're done, make sure to send the last unfinished line
 928     return ($eof,$::nonblockGetLines_last{$fh}) unless $n;
 929     # Prepend the last unfinished line
 930     $buf = $::nonblockGetLines_last{$fh}.$buf;
 931     # And save any newly unfinished lines
 932     $::nonblockGetLines_last{$fh} =
 933         (substr($buf,-1) !~ /[\r\n]/ && $buf =~ s/([^\r\n]*)$//)
 934         ? $1 : '';
 935     $buf ? ($eof,split(/\n/,$buf)) : ($eof);
 936 }
 937
 938 sub read_sensor {
 939     my $self = shift;
 940     ::debug("read_sensor: ");
 941     my $fh = $self->{'sensor_fh'};
 942     if(not $fh) {
 943         # Start the sensor
 944         $self->{'sensor_pid'} =
 945             open($fh, "-|", $opt::sensor) ||
 946             ::die_bug("Cannot open: $opt::sensor");
 947         $self->{'sensor_fh'} = $fh;
 948     }
 949     # Read as much as we can (non_block)
 950     my ($eof,@lines) = nonblockGetLines($fh);
 951
 952     # new load = last full line
 953     foreach my $line (@lines) {
 954         if(defined $line) {
 955             ::debug("Pipe saw: [$line] eof=$eof\n");
 956             $Global::last_sensor_reading = $line;
 957         }
 958     }
 959     if($eof) {
 960         # End of file => Restart the sensor
 961         close $fh;
 962 #       waitpid($self->{'sensor_pid'},0);
 963         $self->{'sensor_pid'} =
 964             open($fh, "-|", $opt::sensor) ||
 965             ::die_bug("Cannot open: $opt::sensor");
 966         $self->{'sensor_fh'} = $fh;
 967     }
 968
 969     return $Global::last_sensor_reading;
 970 }
 971
 972 sub load_status {
 973     # Returns:
 974     #   loadavg or sensor measurement
 975     my $self = shift;
 976
 977     if($opt::sensor) {
 978         if(not defined $self->{'load_status'} or
 979            $self->{'load_status_cache_time'} + $self->{'recheck'} < time) {
 980             $self->{'load_status'} = $self->read_sensor();
 981             while (not defined $self->{'load_status'}) {
 982                 sleep 1;
 983                 $self->{'load_status'} = $self->read_sensor();
 984             }
 985             $self->{'load_status_cache_time'} = time - 0.001;
 986         }
 987     } else {
 988         # Normal load avg
 989         # Cache for some seconds
 990         if(not defined $self->{'load_status'} or
 991            $self->{'load_status_cache_time'} + $self->{'recheck'} < time) {
 992             $self->{'load_status'} = load_status_linux() if $^O ne 'darwin';
 993             $self->{'load_status'} = load_status_darwin() if $^O eq 'darwin';
 994             $self->{'load_status_cache_time'} = time;
 995         }
 996     }
 997     ::debug("load_status: ".$self->{'load_status'}."\n");
 998     return $self->{'load_status'};
 999 }
1000
1001 sub undef_as_zero {
1002     my $a = shift;
1003     return $a ? $a : 0;
1004 }
1005
1006
1007 sub load_status_linux {
1008     my ($loadavg);
1009     if(open(IN,"/proc/loadavg")) {
1010         # Linux specific (but fast)
1011         my $upString = <IN>;
1012         if($upString =~ m/^(\d+\.\d+)/) {
1013             $loadavg = $1;
1014         } else {
1015             ::die_bug("proc_loadavg");
1016         }
1017         close IN;
1018     } elsif (open(IN,"LANG=C uptime|")) {
1019         my $upString = <IN>;
1020         if($upString =~ m/averages?.\s*(\d+\.\d+)/) {
1021             $loadavg = $1;
1022         } else {
1023             ::die_bug("uptime");
1024         }
1025         close IN;
1026     }
1027     return $loadavg;
1028 }
1029
1030 sub load_status_darwin {
1031     my $loadavg = `sysctl vm.loadavg`;
1032     if($loadavg =~ /vm\.loadavg: \{ ([0-9.]+) ([0-9.]+) ([0-9.]+) \}/) {
1033         $loadavg = $1;
1034     } elsif (open(IN,"LANG=C uptime|")) {
1035         my $upString = <IN>;
1036         if($upString =~ m/averages?.\s*(\d+\.\d+)/) {
1037             $loadavg = $1;
1038         } else {
1039             ::die_bug("uptime");
1040         }
1041         close IN;
1042     }
1043     return $loadavg;
1044 }
1045
1046
1047 sub swap_status {
1048     # Returns:
1049     #   (swap in)*(swap out) kb
1050     my $self = shift;
1051     my $status;
1052     # Cache for some seconds
1053     if(not defined $self->{'swap_status'} or
1054        $self->{'swap_status_cache_time'}+$self->{'recheck'} < time) {
1055         $status = swap_status_linux() if $^O ne 'darwin';
1056         $status = swap_status_darwin() if $^O eq 'darwin';
1057         $self->{'swap_status'} = ::max($status,0);
1058         $self->{'swap_status_cache_time'} = time;
1059     }
1060     ::debug("swap_status: $self->{'swap_status'}\n");
1061     return $self->{'swap_status'};
1062 }
1063
1064
1065 sub swap_status_linux {
1066     my $swap_activity;
1067     $swap_activity = "vmstat 1 2 | tail -n1 | awk '{print \$7*\$8}'";
1068     # Run swap_activity measuring.
1069     return qx{ $swap_activity };
1070 }
1071
1072 sub swap_status_darwin {
1073     # Mach Virtual Memory Statistics: (page size of 4096 bytes, cache hits 0%)
1074     #   free active   spec inactive   wire   faults     copy    0fill reactive  pageins  pageout
1075     # 298987 251463 162637    69437 265724 29730558   299022  2308237        1   110058        0
1076     # 298991 251479 162637    69437 265726       43        4       16        0        0        0
1077     my ($pagesize, $pageins, $pageouts);
1078     my @vm_stat = `vm_stat 1 | head -n4`;
1079     $pagesize = $1 if $vm_stat[0] =~ m/page size of (\d+) bytes/;
1080     $pageins = (split(/\s+/,$vm_stat[3]))[9];
1081     $pageouts = (split(/\s+/,$vm_stat[3]))[10];
1082     return ($pageins*$pageouts*$pagesize)/1024;
1083 }
1084
1085
1086 sub mem_status {
1087     # Returns:
1088     #   number of bytes (free+cache)
1089     my $self = shift;
1090     # Cache for one second
1091     if(not defined $self->{'mem_status'} or
1092        $self->{'mem_status_cache_time'}+$self->{'recheck'} < time) {
1093         $self->{'mem_status'} = mem_status_linux() if $^O ne 'darwin';
1094         $self->{'mem_status'} = mem_status_darwin() if $^O eq 'darwin';
1095         $self->{'mem_status_cache_time'} = time;
1096     }
1097     ::debug("mem_status: $self->{'mem_status'}\n");
1098     return $self->{'mem_status'};
1099 }
1100
1101
1102 sub mem_status_linux {
1103     #              total       used       free     shared    buffers     cached
1104     # Mem:       3366496    2901664     464832          0     179228    1850692
1105     # -/+ buffers/cache:     871744    2494752
1106     # Swap:      6445476    1396860    5048616
1107     my @free = `free`;
1108     my $free = (split(/\s+/,$free[2]))[3];
1109     return $free*1024;
1110 }
1111
1112 sub mem_status_darwin {
1113     # Mach Virtual Memory Statistics: (page size of 4096 bytes, cache hits 0%)
1114     #   free active   spec inactive   wire   faults     copy    0fill reactive  pageins  pageout
1115     # 298987 251463 162637    69437 265724 29730558   299022  2308237        1   110058        0
1116     # 298991 251479 162637    69437 265726       43        4       16        0        0        0
1117     my ($pagesize, $pages_free, $pages_speculative);
1118     my @vm_stat = `vm_stat 1 | head -n4`;
1119     $pagesize = $1 if $vm_stat[0] =~ m/page size of (\d+) bytes/;
1120     $pages_free = (split(/\s+/,$vm_stat[3]))[0];
1121     $pages_speculative = (split(/\s+/,$vm_stat[3]))[2];
1122     return ($pages_free+$pages_speculative)*$pagesize;
1123 }
1124
1125
1126 sub io_status {
1127     # Returns:
1128     #   max percent for all devices
1129     my $self = shift;
1130     # Cache for one second
1131     if(not defined $self->{'io_status'} or
1132        $self->{'io_status_cache_time'}+$self->{'recheck'} < time) {
1133         $self->{'io_status'} = io_status_linux() if $^O ne 'darwin';
1134         $self->{'io_status'} = io_status_darwin() if $^O eq 'darwin';
1135         $self->{'io_status_cache_time'} = time;
1136     }
1137     ::debug("io_status: $self->{'io_status'}\n");
1138     return $self->{'io_status'};
1139 }
1140
1141
1142 sub io_status_linux {
1143     # Device: rrqm/s   wrqm/s     r/s     w/s    rkB/s    wkB/s avgrq-sz avgqu-sz   await r_await w_await  svctm  %util
1144     # 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
1145     my @iostat_out = `LANG=C iostat -x 1 2`;
1146     # throw away all execpt the last Device:-section
1147     my @iostat;
1148     for(reverse @iostat_out) {
1149         /Device/ and last;
1150         push @iostat, (split(/\s+/,$_))[13];
1151     }
1152     my $io = ::max(@iostat);
1153     return undef_as_zero($io)/10;
1154 }
1155
1156 sub io_status_darwin {
1157     #           disk0           disk1           disk2
1158     #     KB/t tps  MB/s     KB/t tps  MB/s     KB/t tps  MB/s
1159     #    14.95  15  0.22    11.18  35  0.38     2.00   0  0.00
1160     #     0.00   0  0.00     0.00   0  0.00     0.00   0  0.00
1161     my @iostat_out = `LANG=C iostat -d -w 1 -c 2`;
1162     # return the MB/s of the last second (not the %util)
1163     my @iostat = split(/\s+/, $iostat_out[3]);
1164     my $io = $iostat[3] + $iostat[6] + $iostat[9];
1165     return ::min($io, 10);
1166 }
1167
1168 $::exitsignal = $::exitstatus = 0; # Dummy