3 # Copyright (C) 2004-2010 Ole Tange, http://ole.tange.dk
5 # Copyright (C) 2010-2019 Ole Tange, http://ole.tange.dk and
6 # Free Software Foundation, Inc.
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.
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.
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
25 $Global::progname
="niceload";
26 $Global::version
= 20190722;
27 Getopt
::Long
::Configure
("bundling","require_order");
28 get_options_from_array
(\
@ARGV) || die_usage
();
37 if($opt::factor
and $opt::suspend
) {
38 # You cannot have --suspend and --factor
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
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
; }
62 if(defined $opt::load
) { multiply_binary_prefix
($opt::load
); }
63 if(defined $opt::baseline
) { collect_net_baseline
(); }
65 my $limit = Limit
->new();
66 my $process = Process
->new($opt::nice
,@ARGV);
69 # Find all pids of prg
70 my($children_of, $parent_of, $name_of) = pid_table
();
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);
80 @exact_name_pids = grep { $_ != $$ } @exact_name_pids;
81 @substr_name_pids = grep { $_ != $$ } @substr_name_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.");
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+ //;
93 $name_of->{$_} =~ s/ .*//;
94 push @
{$name_pids{$name_of->{$_}}},$_;
96 warning
("Niceloading",
97 map { "$_ (".(join" ",sort @
{$name_pids{$_}}).")" } keys %name_pids
99 @pids = @substr_name_pids;
101 error
("@opt::prg no matches.");
104 $process->set_pid(@pids);
105 $::resume_process
= $process;
106 $SIG{TERM
} = $SIG{INT
} = \
&resume
;
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
;
114 # Wait until limit is below start_limit and run_limit
115 while($limit->over_start_limit()
117 ($limit->hard() and $limit->over_run_limit())) {
118 $limit->sleep_for_recheck();
123 while($process->is_alive()) {
124 if($limit->over_run_limit()) {
126 $limit->sleep_for_recheck();
127 if(not $limit->hard()) {
129 $limit->sleep_while_running();
133 $limit->sleep_while_running();
140 my %pid_parentpid_cmd;
144 # %children_of = { pid -> children of pid }
145 # %parent_of = { pid -> pid of parent }
146 # %name_of = { pid -> commandname }
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] $_}" );
156 my $bsd = q
(ps
-o pid
,ppid
,command
-ax
);
176 'syllable' => "echo ps not supported",
179 $pid_parentpid_cmd{$^O
} or ::die_bug
("pid_parentpid_cmd for $^O missing");
181 my (@pidtable,%parent_of,%children_of,%name_of);
182 # Table with pid -> children of pid
183 @pidtable = `$pid_parentpid_cmd{$^O}`;
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+.*)/
191 $^O
eq "darwin" and /^\s*(\S+)\s+(\S+)\s+()$/) {
193 push @
{$children_of{$2}}, $1;
196 ::die_bug
("pidtable format: $_");
199 return(\
%children_of, \
%parent_of, \
%name_of);
204 $::resume_process
->resume();
217 my $prog = $Global::progname
|| "niceload";
218 status
(map { ($prog, ": Warning: ", $_, "\n"); } @w);
223 my $prog = $Global::progname
|| "niceload";
224 status
(map { ($prog, ": Error: ", $_, "\n"); } @w);
228 # Remove duplicates and return unique values
229 return keys %{{ map { $_ => 1 } @_ }};
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
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;
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;
263 sub get_options_from_array
{
264 # Run GetOptions on @array
266 # true if parsing worked
267 # false if parsing failed
269 my $array_ref = shift;
270 # A bit of shuffling of @ARGV needed as GetOptionsFromArray is not
271 # supported everywhere
273 my $this_is_ARGV = (\@
::ARGV
== $array_ref);
274 if(not $this_is_ARGV) {
275 @save_argv = @
::ARGV
;
276 @
::ARGV
= @
{$array_ref};
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
,
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
,
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
,
293 "sm|startmem|start-mem=s" => \
$opt::start_mem
,
294 "rm|runmem|run-mem=s" => \
$opt::run_mem
,
295 "mem|M=s" => \
$opt::mem
,
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
,
301 "battery|B" => \
$opt::battery
,
303 "nethops=i" => \
$opt::nethops
,
304 "baseline" => \
$opt::baseline
,
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
,
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 $?');
330 # niceload -l 0.01 --sensor 'netsensor_script'
331 $opt::sensor
= netsensor_script
($opt::nethops
);
334 if(not $this_is_ARGV) {
335 @
{$array_ref} = @
::ARGV
;
336 @
::ARGV
= @save_argv;
341 sub shell_quote_scalar
{
342 # Quote for other shells
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)
351 # quote newline as '\n'
352 ($a =~ s/[\n]/'\n'/go)) {
353 # A string was replaced
354 # No need to test for "" or \0
357 } elsif($a eq "\0") {
373 niceload [-v] [-n niceness] [-L loadavg] [-I io] [-N] [-M mem]
374 [-s suspend_sec|-f factor] [-H] [-S]
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",
390 "If you get the error on smaller/fewer files, please include those instead.\n");
395 # Returns time since epoch as in seconds with 3 decimals
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 };";
404 eval "sub TimeHiRestime { return time() };";
406 $Global::use{"Time::HiRes"} = 1;
409 return (int(TimeHiRestime
()*1000))/1000;
413 # Sleep this many milliseconds.
415 ::debug
("Sleeping ",$ms," millisecs\n");
419 # Something makes 'select' wake up too early
420 # when using --sensor
421 select(undef, undef, undef, $ms/1000);
423 } while($now < $start + $ms/1000);
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);";
440 # Data::Dump not installed
441 eval "use Data
::Dumper
;";
443 my $err = "Neither Data
::Dump nor Data
::Dumper is installed
\n".
444 "Not dumping output
\n";
448 return Dumper(@dump_this);
451 eval "use Data
::Dump
qw(dump);";
452 return (Data::Dump::dump(@dump_this));
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
.",
467 "Web site
: http
://www
.gnu
.org
/software/parallel
\n"
474 # Maximum value of array
479 defined $max or do { $max = $_; next; }; # Set $_ to the first non-undef
480 $max = ($max > $_) ? $max : $_;
487 # Minimum value of array
492 defined $min or do { $min = $_; next; }; # Set $_ to the first non-undef
493 $min = ($min < $_) ? $min : $_;
498 sub collect_net_baseline {
499 # Collect what a normal (unloaded) net connection looks line
503 sub netsensor_script {
504 # Script for --sensor when using --net
510 my $medtrc = MedianTraceroute->new(shift);
511 $medtrc->set_remedian($medtrc->ping());
512 $medtrc->set_remedian($medtrc->ping());
514 my $ms = $medtrc->ping();
515 my $m = $medtrc->remedian();
517 # Bad 1 = median*1.5 < current latency
519 # OK 0 = median*1.5 > current latency
520 $medtrc->set_remedian($ms);
522 printf("%d\n",$m*1.5 < $ms);
526 package MedianTraceroute;
532 my $tr = Net::Traceroute->new(host => "8.8.8.8",
535 $host = $tr->hop_query_host($hop, 0);
537 # ns1.censurfridns.dk
538 $tr = Net::Traceroute->new(host => "89.233.43.71",
541 $host = $tr->hop_query_host($hop, 0);
543 die("Cannot traceroute to
8.8.8.8 and 89.233.43.71");
546 my $p = Net::Ping->new();
554 'remedian_arr' => [],
556 }, ref($class) || $class;
562 # Ping should never take longer than 5.5 sec
563 my ($ret, $duration, $ip) =
564 $self->{'pinger'}->ping($self->{'host'}, 5.5);
569 warn("Ping failed
3 times.");
574 return $self->{'remedian'};
578 # Set median of the last 999^3 (=997002999) values using Remedian
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.
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];
593 return "perl -e ".shell_quote_scalar
($perlscript)." $hops";
604 unshift(@ARGV, "nice", "-n", $nice);
607 'running' => 0, # Is the process running now?
608 'command' => [@ARGV],
609 }, ref($class) || $class;
615 if(not $self->{'pgrp'}) {
616 for(@
{$self->{'pids'}}) {
617 push @pgrp,-getpgrp($_);
619 @pgrp = ::uniq
(@pgrp);
620 @
{$self->{'pgrp'}} = @pgrp;
622 return @
{$self->{'pgrp'}};
627 push(@
{$self->{'pids'}},@_);
628 $self->{'running'} = 1;
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);
648 ::debug
("Child pid: $$, pgrp: ",getpgrp $$,"\n");
649 ::debug
("@{$self->{'command'}}\n");
651 system(@
{$self->{'command'}});
653 system("@{$self->{'command'}}");
655 $::exitstatus
= $?
>> 8;
656 $::exitsignal
= $?
& 127;
657 ::debug
("Child exit $::exitstatus\n");
662 use POSIX
":sys_wait_h";
663 use POSIX
qw(:sys_wait_h);
667 while (($stiff = waitpid(-1, &WNOHANG
)) > 0) {
668 # do something with $stiff if you want
669 $::exitstatus
= $?
>> 8;
670 $::exitsignal
= $?
& 127;
672 $SIG{CHLD
} = \
&REAPER
; # install *after* calling waitpid
676 sub kill_child_CONT
{
677 my $self = $Global::process
;
678 ::debug
("SIGCONT received. Killing @{$self->{'pgrp'}}\n");
679 kill CONT
=> $self->pgrp();
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();
693 my $self = $Global::process
;
694 ::debug
("SIGINT received.\n");
696 ::debug
("Killing $self->{'pid'} Exit\n");
697 kill INT
=> $self->pgrp();
699 ::debug
("Continue pids $self->{'pid'} Exit\n");
700 kill CONT
=> $self->pgrp();
708 ::debug
("Resume @{$self->{'pids'}}\n");
709 if(not $self->{'running'}) {
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;
721 ::debug
("Suspend @{$self->{'pids'}}\n");
722 if($self->{'running'}) {
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;
733 # The process is dead if none of the pids exist
736 for my $pid (@
{$self->{'pids'}}) {
737 if(kill 0 => $pid) { $exists++ }
739 ::debug
("is_alive: $exists\n");
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
763 'recheck' => $recheck,
765 'startio' => $startio,
766 'runload' => $runload,
767 'startload' => $startload,
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;
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);
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'});
802 # Stop if the load is below the limit (for sensor)
803 $status += ::max
(0,-$load - $self->{'runload'});
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'}));
813 if($self->{'runio'}) {
814 my $io = $self->io_status();
815 $status += ::max
(0,$io - $self->{'runio'});
817 $self->{'over_run_limit'} = $status;
818 if(not $opt::recheck
) {
819 $self->{'recheck'} = $self->{'factor'} * $self->{'over_run_limit'};
821 ::debug
("over_run_limit: $status\n");
822 return $self->{'over_run_limit'};
825 sub over_start_limit
{
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);
837 if($self->{'startload'}) {
838 # load should be between 0-10ish
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'});
846 # Stop if the load is below the limit (for sensor)
847 $status += ::max
(0,-$load - $self->{'startload'});
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'}));
857 if($self->{'startio'}) {
858 my $io = $self->io_status();
859 $status += ::max
(0,$io - $self->{'startio'});
861 $self->{'over_start_limit'} = $status;
862 if(not $opt::recheck
) {
863 $self->{'recheck'} = $self->{'factor'} * $self->{'over_start_limit'};
865 ::debug
("over_start_limit: $status\n");
866 return $self->{'over_start_limit'};
872 return $self->{'hard'};
878 return $self->{'verbose'};
882 sub sleep_for_recheck
{
884 if($self->{'recheck'} < 0.01) {
885 # Never sleep less than 0.01 sec
886 $self->{'recheck'} = 0.01;
888 if($self->verbose()) {
889 $self->{'recheck'} = int($self->{'recheck'}*100)/100;
890 print STDERR
"Sleeping $self->{'recheck'}s\n";
892 ::debug
("recheck in $self->{'recheck'}s\n");
893 ::usleep
(1000*$self->{'recheck'});
897 sub sleep_while_running
{
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";
904 ::usleep
(1000*$self->{'runtime'});
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) = @_;
914 $timeout = 0 unless defined $timeout;
916 $::nonblockGetLines_last
{$fh} = ''
917 unless defined $::nonblockGetLines_last
{$fh};
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);
924 my $n = sysread($fh,$buf,1024*1024);
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]*)$//)
935 $buf ?
($eof,split(/\n/,$buf)) : ($eof);
940 ::debug
("read_sensor: ");
941 my $fh = $self->{'sensor_fh'};
944 $self->{'sensor_pid'} =
945 open($fh, "-|", $opt::sensor
) ||
946 ::die_bug
("Cannot open: $opt::sensor");
947 $self->{'sensor_fh'} = $fh;
949 # Read as much as we can (non_block)
950 my ($eof,@lines) = nonblockGetLines
($fh);
952 # new load = last full line
953 foreach my $line (@lines) {
955 ::debug
("Pipe saw: [$line] eof=$eof\n");
956 $Global::last_sensor_reading
= $line;
960 # End of file => Restart the sensor
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;
969 return $Global::last_sensor_reading
;
974 # loadavg or sensor measurement
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'}) {
983 $self->{'load_status'} = $self->read_sensor();
985 $self->{'load_status_cache_time'} = time - 0.001;
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;
997 ::debug
("load_status: ".$self->{'load_status'}."\n");
998 return $self->{'load_status'};
1007 sub load_status_linux
{
1009 if(open(IN
,"/proc/loadavg")) {
1010 # Linux specific (but fast)
1011 my $upString = <IN
>;
1012 if($upString =~ m/^(\d+\.\d+)/) {
1015 ::die_bug
("proc_loadavg");
1018 } elsif (open(IN
,"LANG=C uptime|")) {
1019 my $upString = <IN
>;
1020 if($upString =~ m/averages?.\s*(\d+\.\d+)/) {
1023 ::die_bug
("uptime");
1030 sub load_status_darwin
{
1031 my $loadavg = `sysctl vm.loadavg`;
1032 if($loadavg =~ /vm\.loadavg: \{ ([0-9.]+) ([0-9.]+) ([0-9.]+) \}/) {
1034 } elsif (open(IN
,"LANG=C uptime|")) {
1035 my $upString = <IN
>;
1036 if($upString =~ m/averages?.\s*(\d+\.\d+)/) {
1039 ::die_bug
("uptime");
1049 # (swap in)*(swap out) kb
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;
1060 ::debug
("swap_status: $self->{'swap_status'}\n");
1061 return $self->{'swap_status'};
1065 sub swap_status_linux
{
1067 $swap_activity = "vmstat 1 2 | tail -n1 | awk '{print \$7*\$8}'";
1068 # Run swap_activity measuring.
1069 return qx{ $swap_activity };
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;
1088 # number of bytes (free+cache)
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;
1097 ::debug
("mem_status: $self->{'mem_status'}\n");
1098 return $self->{'mem_status'};
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
1108 my $free = (split(/\s+/,$free[2]))[3];
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;
1128 # max percent for all devices
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;
1137 ::debug
("io_status: $self->{'io_status'}\n");
1138 return $self->{'io_status'};
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
1148 for(reverse @iostat_out) {
1150 push @iostat, (split(/\s+/,$_))[13];
1152 my $io = ::max
(@iostat);
1153 return undef_as_zero
($io)/10;
1156 sub io_status_darwin
{
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);
1168 $::exitsignal
= $::exitstatus
= 0; # Dummy