src/niceload

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