File Coverage

blib/lib/Schedule/Load/Schedule.pm

Criterion	Covered	Total	%
statement	130	151	86.0
branch	39	84	46.4
condition	12	42	28.5
subroutine	22	25	88.0
pod	10	14	71.4
total	213	316	67.4

# Schedule::Load::Schedule.pm -- Schedule jobs across a network
# See copyright, etc in below POD section.
######################################################################

package Schedule::Load::Schedule;
require 5.004;
require Exporter;
@ISA = qw(Exporter Schedule::Load::Hosts);

use Schedule::Load qw (:_utils);
use Schedule::Load::Hosts;
use Schedule::Load::ResourceReq;
use Sys::Hostname;
use Time::localtime;

use strict;
use vars qw($VERSION $Debug @MoY);
use Carp;

######################################################################
#### Configuration Section

# Other configurable settings.
$Debug = $Schedule::Load::Debug;
$VERSION = '3.064';
@MoY = ('Jan','Feb','Mar','Apr','May','Jun',
	'Jul','Aug','Sep','Oct','Nov','Dec');

######################################################################
#### Globals

######################################################################
#### Creator

sub new {
    @_ >= 1 or croak 'usage: '.__PACKAGE__.'->new ({options})';
    my $proto = shift;
    return $proto->SUPER::new
	( scheduled_hosts => [],
	  @_);
}

######################################################################
#### Constructor

######################################################################
#### Accessors

sub scheduled_hosts {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->scheduled_hosts (perhaps you forgot to check schedule return for undef)';
    return (wantarray ? @{$self->{scheduled_hosts}} : $self->{scheduled_hosts});
}

sub scheduled_hostnames {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->scheduled_hosts (perhaps you forgot to check schedule return for undef)';
    return () if !$self->{scheduled_hosts}[0];
    my @names = map {$_->hostname; } $self->scheduled_hosts;
    return @names;
}

sub hosts_of_class {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->hosts()';
    # DEPRECIATED.  Return all hosts matching given class
    # allow_reserved was ignored in the old implementation...
    return $self->hosts_match (@_, allow_reserved=>1);
}

######################################################################
######################################################################
#### Functions

sub reserve_default_comment {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->reserve_default_comment)';
    return sprintf ("$self->{username} at %02d-%s %02d:%02d",
		    localtime->mday, $MoY[localtime->mon],
		    localtime->hour, localtime->min),
}

sub reserve {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->reserve)';
    my $params = {
	host=>hostname(),
	uid=>$<,
	comment=>$self->reserve_default_comment(),
	@_,};

    print __PACKAGE__."::reserve($params->{host}, $params->{comment})\n" if $Debug;
    $self->_fetch_if_unfetched();

    my $host = $self->get_host($params->{host});
    ($host) or die "%Error: Host $params->{host} not found, so not reserved\n";
    (!$host->reserved) or die "%Error: Host $params->{host} already reserved by ".$host->reserved."\nrelease this reservation first.\n";
    ($host->reservable) or die "%Error: Host $params->{host} is not reservable\n";

    $self->set_stored(host=>$params->{host},
		      reserved=>$params->{comment},);
    $self->fetch();
    $host = $self->get_host($params->{host});	# Fetch might have new reference
    ($host) or croak "%Error: Host $params->{host} not responding";
    ($host->reserved) or croak "%Error: Host $params->{host} didn't accept reservation";
}

sub release {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->hosts)';
    my $params = {
	host=>hostname(),
	@_,};

    print __PACKAGE__."::release($params->{host})\n" if $Debug;
    $self->_fetch_if_unfetched();

    my $host = $self->get_host($params->{host});
    if (!$host) {
	warn "Note: Host $params->{host} not found, so not released\n";
	return;
    }
    if (!$host->reserved) {
	warn "Note: Host $params->{host} not reserved, so not released\n";
	return;
    }

    $self->set_stored(host=>$params->{host},
		      reserved=>0,);
    $self->fetch();
    $host = $self->get_host($params->{host});	# Fetch might have new reference
    ($host) or croak "%Error: Host $params->{host} not responding";
    (!$host->reserved) or croak "%Error: Host $params->{host} didn't accept release";
}

sub fixed_load {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->fixed_load)';
    my $params = {
	host=>hostname(),
	load=>1,  # Negative for all cpus
	uid=>$<,
	pid=>$$,
	req_hostname=>hostname(),  # Where to do a pid_exists
	#req_pid=>pid,
	@_,};
    $params->{req_pid} ||= $params->{pid};
    print __PACKAGE__."::fixed_load($params->{load})\n" if $Debug;
    $self->_request(_pfreeze( 'report_fwd_fixed_load', $params, $Debug));
}

sub hold_release {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->hold_release)';
    my $params = {
	hold_key=>undef,
	@_,};

    print __PACKAGE__."::hold_release($params->{hold_key})\n" if $Debug;
    $self->_request(_pfreeze( 'hold_release', $params, $Debug));
}

######################################################################
######################################################################
#### Scheduling

sub best {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->best';
    my %params = (allow_none=>0,
		  @_);
    print __PACKAGE__."::best()\n" if $Debug;
    # Backward compatible best function, scheduling on one host without
    # need to understand new Hold and ResourceReq structures.

    # Make a hold element with passed params
    my $hold = Schedule::Load::Hold->new(hold_key=>"best",);
    $hold->set_fields (%{$self},%params);
    # Make resource requests with passed params
    my $req = Schedule::Load::ResourceReq->new();
    $req->set_fields (%{$self},%params);
    my $rtn = $self->schedule
	(resources=>[$req],
	 hold=>$hold,
	 allow_none=>1,
	 %params);
    return undef if !$rtn;
    return undef if !$rtn || !$rtn->scheduled_hosts;
    my @hn = $rtn->scheduled_hostnames;
    return $hn[0];
}

sub jobs {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->jobs';
    #** Old depreciated interface
    print __PACKAGE__."::jobs()\n" if $Debug;
    my @names = $self->idle_host_names(@_);
    return ($#names+1);
}

sub schedule {
    my $self = shift;
    my %params = (allow_none=>0,
		  hold=>undef,	# Schedule::Load::Hold reference, undef not to hold
		  resources=>[],# Schedule::Load::ResourceReq reference
		  @_);

    $self->{scheduled_hosts} = [];
    $self->{_schrtn} = undef;
    $params{resources}[0] or croak "%Error: Not passed any resources=>[] to schedule,";

    use Data::Dumper; print "SCHEDULE: ",Dumper(\%params) if $Debug;
    $self->_request(_pfreeze ("schedule", \%params, 0&&$Debug));

    use Data::Dumper; print "RETURN: ",Dumper($self->{_schrtn}) if $Debug;
    (defined $self->{_schrtn}) or die "%Error: Didn't get proper schedule response\n";

    if (!$self->{_schrtn}{best}) {
	return undef;
    } else {
	# Remap the hostnames to references (can't pass refs across a socket!)
	foreach my $hostname (@{$self->{_schrtn}{best}}) {
	    my $host = $self->get_host($hostname);
	    if (!$host) {
		# It's a host that wasn't in our cache....
		print " Gethost $hostname failed, retrying caching\n" if $Debug;
		$self->kill_cache;
		$self->fetch;
		$host = $self->get_host($hostname);
		if (!$host) {
		    print " Gethost $hostname retry failed\n" if $Debug;
		    return undef;  # Next scheduler attempt should make sense of it all...
		}
	    }
	    push @{$self->{scheduled_hosts}}, $host;
	}
    }
    return $self;
}

sub night_hours_p {
    # Return true if working hours
    my $working = ((localtime->hour >= 7 && localtime->hour < 22)
		   && (localtime->wday >= 1 && localtime->wday < 6)); # M-F
    return !$working;
}

######################################################################
######################################################################
#### Changing persistent store's on a host

sub set_stored {
    my $self = shift; ($self && ref($self)) or croak 'usage: $self->hosts)';
    my $params = {
	host=>undef,
	#set_const=>undef,	# If true, put into constant rather than stored data
	@_,};

    print __PACKAGE__."::set_stored($params->{host})\n" if $Debug;
    $self->_fetch_if_unfetched();

    my $host = $self->get_host($params->{host});
    ($host) or die "%Error: Host $params->{host} not found, so not set\n";

    $self->_request(_pfreeze( 'report_fwd_set', $params, $Debug));
    $self->fetch();
}

sub _set_host_stored {
    my $self = shift;
    my $host = shift;
    my $var = shift;
    my $value = shift;
}

######################################################################
#### Package return
1;

######################################################################
__END__