diff options
Diffstat (limited to 'src/niceload')
| -rwxr-xr-x | src/niceload | 1173 |
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 |