File Coverage

blib/lib/Proc/NiceSleep.pm

Criterion	Covered	Total	%
statement	144	218	66.0
branch	61	132	46.2
condition	6	38	15.7
subroutine	22	30	73.3
pod	12	24	50.0
total	245	442	55.4

package Proc::NiceSleep;

#############################################################################
# Proc::NiceSleep - intelligent sleeping library
#
# Copyright (c) 2002-2012 Josh Rabinowitz, licensed the same as
# perl itself, see COPYRIGHT below
#
# originally generated by joshr 20020216
#
# see full pod perldocs below after __END__  or via perldoc NiceSleep.pm
#
# $Id: NiceSleep.pm,v 1.36 2012/12/23 23:28:58 joshr Exp $
#############################################################################

use 5.004;	# tested this far back and up to 5.10.0
use strict;	# please
#use warnings;	# doesn't exist in 5.004

require Exporter;
#use AutoLoader qw(AUTOLOAD);	# we don't use this yet

# We do 'use vars' like this so we can work nicely in old versions of perl
use vars qw($VERSION);

$VERSION = '0.90';

# these are 'public'
use vars qw ( %EXPORT_TAGS @EXPORT_OK @ISA );

@ISA = qw(Exporter);

# This allows declaration	use Proc::NiceSleep ':all';
%EXPORT_TAGS = ( 'all' => [ qw(
	nice maybe_sleep max_load sleep_factor min_run_time min_sleep_time
	over_load_min_sleep_time over_load_sleep_drift
	load_function
	maybesleep maxload sleepfactor minruntime minsleeptime
	yield
) ] );

@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

# these are private.
use vars qw ( $_sleepfactor $_minruntime $_minsleeptime $_maxload
		$_over_load_minsleeptime $_over_load_sleep_drift
		$_totalsleeptime $_lastsleeptime $_lastmaybesleeptime $_lastloadchecktime
		$_numtimesslept $_numtimesmaybesleepcalled $_numtimesloadchecked
		@_lastloadavgs $_starttime
		$_havetimehires $_havetimehires $_havesetpriority
		$_haveprocprocesstable $_havesyscpuload $_havebsdresource
		$_loadfunction);
# variables prefixed by _ are intended to be private, here we explain them
#$_lastsleeptime;	# the last time we slept, from time()
#$_lastloadchecktime;	# the last time we checked load()
#@_lastloadavgs;	# the values from _GetCpuLoad last time we checked
#$_starttime;			# the time we finished init()
#$_sleepfactor;	# 1.0 means to sleep 1.0 times as long as we 'run'
				# 0.0 means don't sleep based on fraction of tmie
#$_minruntime;	# how long we run before considering yielding
#$_minsleeptime;	# minimum time to sleep, if we do
#$_maxload;		# the maximum 1-minute avg system load we yield at,
				# if supported and Sys::CpuLoad works
#					# does not include time sleeping in maybe_sleep()
#$_totalsleeptime;	# how long we slept in maybe_sleep(),
#						# in apparent wallclock seconds
#$_havetimehires;		# do we have Time::HiRes ?
#$_haveprocprocesstable;	# do we have Proc::ProcessTable?
#$_havesyscpuload;			# do we have Sys::CpuLoad?
#$_havesetpriority;		# do we have a setpriority() call?

# all through we use Time::HiRes or built-in versions of
# time() and sleep(), and get microsecond res ... or not.

#############################################################################
# Preloaded methods go here.
#############################################################################

# nice() this renices the process, like /bin/nice, if it can.
# if passed an integer parameter (between -20 to 20 inclusive)
#   it attempts to set the priority and returns the priority
#   it tried to set the process to.
# if called without a parameter, returns what it thinks its priority is
# does not work on win32 (always should return 0); use maybe_sleep() ! :)
sub nice {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my $param = shift;
	# 'man setpriority' on rh7.2: The setpriority call returns 0 if there
	# is no error, or -1 if there is.
		# even though man page says the above, setpriority(0,0,5) returns 1
		# on RH7.2
	if (defined($param)) {
		$param = int($param);	# pass me an int, holmes
		if ($_havesetpriority && setpriority(0,0,$param) != -1) {
			return $param;
		} else {
			return 0;
		}
	}
	return ($_havesetpriority ? getpriority(0,0) : 0);
	# no param, return what we think the nice value is.
}

# keep calling maybe_sleep() until maxsleep seconds have passed
# or it doesn't need to sleep anymore.
# pass '0' for infinite yield
sub yield {
	my $maxsleep = shift || 0;
	my $t1 = time();
	my $sleeptime = 0;
	my $slept = 0;
	do  {
		$slept = maybe_sleep();
		$sleeptime += $slept;
	} while ($slept && (!$maxsleep || $sleeptime <= $maxsleep));
	return $sleeptime;
}

# checks to see if we should sleep.
# returns how long we think we slept if we did, 0 otherwise
sub maybe_sleep {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	$_numtimesmaybesleepcalled++;
	my $t1 = ($_havetimehires ? Time::HiRes::time() : CORE::time());
	$_lastmaybesleeptime = $t1;
	my $timepassed = $t1 - $_lastsleeptime;
	my ($timetosleep, $timeslept) = (0, 0);
	if ($_minruntime && $timepassed < $_minruntime) { return 0; }
	if ($_sleepfactor) {
		if ($_totalsleeptime == 0) {
			$timetosleep = $_sleepfactor * $timepassed;
			#print "Debug1: timetosleep = $timetosleep\n";
		} else {
			my $totalruntime = $t1 - $_starttime - $_totalsleeptime;
				# we've actually seen $totalruntime be zero when there's no
				# Time::HiRes
			if ($totalruntime > 0) {	# avoid divide by zero below
				my $actualratio = $_totalsleeptime / $totalruntime;
				if ($actualratio < $_sleepfactor) {
					$timetosleep =
						$_sleepfactor * $totalruntime - $_totalsleeptime;
				}
			}
			$timetosleep = 0 if ($timetosleep < 0);
			#print "Debug2: timetosleep = $timetosleep\n";
		}
	}
	if ($_maxload && ($t1 - $_lastloadchecktime >= 0.5)) {
		# we only check the load a max of about once per half second
		my (@loads) = _GetCpuLoad();	# (1minavg, 5minavg, 15minavg)
		@_lastloadavgs = @loads;
		if ($loads[0] && $loads[0] > $_maxload) {
			# sleep if load is too high
			my $drift = rand($_over_load_sleep_drift);
			$timetosleep = MAX(
				$_over_load_minsleeptime    + $drift,
				4 * ($loads[0] - $_maxload) + $drift,	# diff between current load and max load
				$timetosleep,
				$_minsleeptime,
			);
		}
	}
	if ($timetosleep) {	# we should sleep... snore....
		if ($_minsleeptime && $timetosleep < $_minsleeptime) {
			if ($timetosleep <= 0) { $timetosleep = 0; } # can't be neg
			$timetosleep = $_minsleeptime;
		}
		if($_havetimehires) {
			Time::HiRes::sleep($timetosleep);	# yield the system via sleep
		} else {
			$timetosleep = int($timetosleep + .5);	# round off.
			if ($timetosleep <= 0) { $timetosleep = 1; } # can't be neg or 0
			CORE::sleep($timetosleep);	# actually yield the system via sleep
		}
		my $t2 = ($_havetimehires ? Time::HiRes::time() : CORE::time());
		my $actualsleeptime = $t2 - $t1;
		$_totalsleeptime += $actualsleeptime;	# how long we slept
		$_lastsleeptime = $t2;					# record this
		$timeslept = $actualsleeptime;				# for return
		$_numtimesslept++;
	}
	return $timeslept;	# in case they wonder. this is how long we slept
}
# sets or gets, depending on whether it gets param or not
sub sleep_factor {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my $param = shift;
	if (defined($param)) {
		$param = 0 if ($param < 0);	# don't allow negative sleep_factor
		$_sleepfactor = $param;
	}
	else { return $_sleepfactor; }
}
# sets or gets, depending on whether it gets param or not
sub min_sleep_time {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my $param = shift;
	if (defined($param)) {
		$param = 0 if ($param < 0);	# don't allow negative value
		$_minsleeptime = $param;
	}
	else { return $_minsleeptime; }
}
# sets or gets, depending on whether it gets param or not
sub min_run_time {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my $param = shift;
	if (defined($param)) {
		$param = 0 if ($param < 0);	# don't allow negative value
		$_minruntime = $param;
	}
	else { return $_minruntime; }
}
# sets or gets, depending on whether it gets param or not
sub max_load {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my $param = shift;
	if (defined($param)) {
		$param = 0 if ($param < 0);	# don't allow negative value
		$_maxload = $param;
	}
	else { return $_maxload; }
}
# sets or gets, depending on whether it gets param or not
sub over_load_min_sleep_time {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my $param = shift;
	if (defined($param)) {
		$param = 0 if ($param < 0);	# don't allow negative value
		$_over_load_minsleeptime = $param;
	}
	else { return $_over_load_minsleeptime; }
}
# sets or gets, depending on whether it gets param or not
sub over_load_sleep_drift {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my $param = shift;
	if (defined($param)) {
		$param = 0 if ($param < 0);	# don't allow negative value
		$_over_load_sleep_drift = $param;
	}
	else { return $_over_load_sleep_drift; }
}
# returns a ref to a hash with data about the progress...
# for informational purposes only. return values subject to change.
sub Dump {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my %hash = (
		#HAVE_TIME_HIRES => $_havetimehires,
		#HAVE_PROC_PROCESSTABLE => $_haveprocprocesstable,
		#HAVE_SYS_CPULOAD => $_havesyscpuload,
		#HAVE_SETPRIORITY => $_havesetpriority,
		LAST_LOAD_CHECK_TIME => dump_clock($_lastloadchecktime),
		LAST_LOAD_AVERAGES =>  join(" ", @_lastloadavgs),
		LAST_SLEEP_TIME => dump_clock($_lastsleeptime),
		LAST_MAYBE_SLEEP_TIME => dump_clock($_lastmaybesleeptime),
		MAX_LOAD => $_maxload,
		#LOAD_FUNCTION => $_loadfunction,
		MIN_RUN_TIME => $_minruntime,
		MIN_SLEEP_TIME => $_minsleeptime,
		SLEEP_FACTOR => $_sleepfactor,
		TOTAL_RUN_TIME =>
			(Proc::NiceSleep::time() - $_starttime - $_totalsleeptime),
		TOTAL_SLEEP_TIME => $_totalsleeptime,
		NUM_TIMES_SLEPT => $_numtimesslept,
		NUM_TIMES_LOAD_CHECKED => $_numtimesloadchecked,
		NUM_TIMES_MAYBE_SLEEP_CALLED => $_numtimesmaybesleepcalled,
		 # extra comma here is ok, cool!
	);
	return \%hash;
}
# this is for informational purposes only. Data and its output subject to change
# written to remove dependence on Data::Dumper in our examples
sub DumpText {
	# a convenient method to ascii-ify return of Dump() nicely for reporting.
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	my $hashref = Dump();
	my $str = "";
	for my $e (sort keys(%$hashref)) {	# the entry name
		my $v = $$hashref{$e};	# the value
		if (!defined($v)) {
			$str .= sprintf("  %-28s: (undef)\n", $e);
		} elsif ($v =~ /^([0-9.]+)$/ && (int($v) != $v) ) {
			$str .= sprintf("  %-28s: %1.3f\n", $e, $v);
		} else {
			$str .= sprintf("  %-28s: %s\n", $e, $v);
		}
	}
	return $str;	# returns a nice, ascii text page of the name/vals :)
}

# if called with param, sets the load
sub load_function {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	if (@_) {
		$_loadfunction = shift;
	} else { return $_loadfunction; }
}

# time() and sleep() are so test programs don't have to test for Time::HiRes
# they do hi-res if possible. They are also shown used in example.pl,
# but are not documented as public... should they be, kind reader?
sub time  { ($_havetimehires ? Time::HiRes::time()    : CORE::time());    }
sub sleep { ($_havetimehires ? Time::HiRes::sleep(@_) : CORE::sleep(@_)); }

#############################################################################
#  THESE ARE FOR TEMPORARY REVERSE SUPPORT. Soon we'll give warnings,
# eventually we'll remove them
#############################################################################
sub	maybesleep { return maybe_sleep(@_); }
sub maxload { return max_load(@_); }
sub sleepfactor { return sleep_factor(@_); }
sub minruntime { return min_run_time(@_); }
sub minsleeptime { return min_sleep_time(@_); }

#############################################################################
#  THINGS AFTER HERE (until perldocs) ARE PRIVATE METHODS !!!
#############################################################################
sub dump_clock { return (($_[0]) ? scalar(localtime($_[0])) : 0); }
sub MAX { my $max = shift; for(@_) { $max = $_ if $_ > $max; } return $max; }

sub init {		# intended to be private
	# try to load Time::HiRes and ProcessTable

	eval{ require Time::HiRes };
	if ($@) { $_havetimehires = 0; } else { $_havetimehires = 1; }
	# eval alone can't seem to import sleep() and time() from Time::HiRes.
	# 'use Time::HiRes qw(sleep time);' from here doesn't seem to get
	# sleep() and time() imported outside this function, either.

	#eval{require Proc::ProcessTable; };  # we don't use this.... yet.
	#if ($@) { $_haveprocprocesstable = 0 } else { $_haveprocprocesstable = 1 }

	eval{
		require Sys::CpuLoad;
		my @l=Sys::CpuLoad::load();
		die unless (@l > 2 && defined($l[0]) && $l[0] =~ /^\s*[0-9]*\.?[0-9]+$/);
	};
	if ($@) { $_havesyscpuload = 0 } else { $_havesyscpuload = 1 }

	eval{ my $pri=getpriority(0,0); setpriority(0,0,$pri); };
		# check for setpriority() and setpriority() with a (hopefully) no-op
	if ($@) { $_havesetpriority = 0 } else { $_havesetpriority = 1 }

	eval{ require BSD::Resource; };
	if ($@) { $_havebsdresource = 0; } else { $_havebsdresource = 1; }

	$_sleepfactor = 0.1; # the default
	$_minruntime = 0.0;
		# can be meaningfully this short if we have Time::HiRes
	$_minsleeptime = 0;	# no 'minimum' time to sleep by default
	$_over_load_minsleeptime = 3.5;	# 4 was default from v0.77
	$_over_load_sleep_drift = 1;
	$_maxload = 0;		# 0 means don't watch loads
	$_loadfunction = undef;		# reset this too
	@_lastloadavgs = (0,0,0);
	Proc::NiceSleep::reset_all();
}

sub reset_all {
	$_numtimesslept = 0;
	$_numtimesmaybesleepcalled = 0;
	$_numtimesloadchecked = 0;
	$_totalsleeptime = 0;
	$_lastloadchecktime = 0;
	$_lastmaybesleeptime = 0;
	$_lastsleeptime =
		$_starttime = Proc::NiceSleep::time();
}

# Invariant(): attempt to check that the vars are self-consistent.
# returns 1 if OK, 0 if object 'bad'. Not intended to be called often
sub Invariant {	# intended to be private.  Used in tests
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	# check obvious things:
	# can we load a method/func from each mod we loaded?
	if ($_havetimehires) { 	# this will die if we can't load func
		my $t = Time::HiRes::time();
		Time::HiRes::sleep(0.0001);
	}
	if ($_havesyscpuload) { 	# this will die if we can't load func
		my @l = Sys::CpuLoad::load();
	}
	# if we think we have Time::HiRes, is time() fractional? Inverse?
	# we used to test that we did or didn't get fractional times, but
	# it turns out that just cause you have Time::HiRes doesn't mean you
	# get fractional times and sleeps.
	if ($_havetimehires) { # could still be integer-based
		#my ($t1, $t2) = (time(), time());	# at least ONE shouldn't be int
		#return 0 if ($t1 == int($t1) && $t2 == int($t2));
	} else {
		# we assume no version of perl has a sub-second time() in CORE (!)
		my ($t1, $t2) = (CORE::time(), CORE::time());	# both should be ints
		return 1 if ($t1 != int($t1) || $t2 != int($t2));
		# but really, even if times are floating point, everything is probably ok
	}
	return 1;	# that's all we test... seems ok!
}

# on some machines, Sys::CpuLoad won't get the load, but it's still
# possible to fetch. So we try harder.
sub _GetCpuLoad {
	unless (defined($_lastsleeptime)) { init(); }	# autoinit on first use
	$_numtimesloadchecked++;
	$_lastloadchecktime = Proc::NiceSleep::time();
	if ($_loadfunction) {		# use the load function if we can
		my (@L) = &${_loadfunction}();
		return @L if @L;
	}
	my @loads = (0,0,0);
	if ($_havesyscpuload) {
		@loads = Sys::CpuLoad::load();
	}
	if ($loads[0] == 0) {	# either the load is that low, or Sys::CpuLoad::load() is
							# just returning (0,0,0) as it does on OSX 10.3 as of 11/2004

		local( %ENV );		# for taint safety
		@ENV{qw(PATH BASH_ENV)} = ( "/usr/bin:/bin",  "");

		open(UPTIME, "/usr/bin/uptime |") || return @loads;
		my $out = ;		# read one line.
		chomp($out);
		close(UPTIME) || return @loads;	# this could fail if pipe didn't work
		if ($out && $out =~ /([0-9.]+)\s+([0-9.]+)\s+([0-9.]+)\s*$/) {
			@loads = ($1, $2, $3);
		}
	}
	return @loads;
}

# Autoload methods go after =cut, and are processed by the autosplit program.
# we have none ... yet.
#############################################################################
1;

__END__