#!/usr/bin/perl -w
# rschedule - User interface to perl Schedule::Load
# $Id: rschedule 98 2007-04-03 15:22:10Z wsnyder $
################ Introduction ################
#
# Copyright 2000-2006 by Wilson Snyder.  This program is free software;
# you can redistribute it and/or modify it under the terms of either the GNU
# General Public License or the Perl Artistic License.
# 
# 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.
# 
######################################################################

require 5.004;
use lib 'blib/lib';	# testing
use Getopt::Long;
use Sys::Hostname;
use Pod::Usage;
use Schedule::Load;
use Schedule::Load::Schedule;
use Config;

######################################################################
# configuration


######################################################################
# globals

######################################################################
# main

$Debug = 0;
my %server_params = ();
my @commands = ();
my @match_params;
my $opt_fixed_load = 1;	# For fixedload
my @opt_classes = ();
my $opt_comment;
my $opt_kill;
my $opt_similar;
my $opt_host = hostname();

if ($0 =~ /(^|[\\\/])rtop$/) {
    # Special program name, force defaults
    push @ARGV, ("hosts", "top");
}
if ($0 =~ /(^|[\\\/])rhosts$/) {
    # Special program name, force defaults
    push @ARGV, ("hosts");
}
if ($0 =~ /(^|[\\\/])rloads$/) {
    # Special program name, force defaults
    push @ARGV, ("loads");
}

if (!GetOptions (
		       "help"		=> \&usage,
		       "debug"		=> \&debug,
		       "version"	=> \&version,
		       "port=i"		=> sub {shift; $server_params{port} = shift;},
		       "dhost=s"	=> sub {shift; push @{$server_params{dhost}}, split(':',shift);},
		       "host=s"		=> \$opt_host,
		       "class=s"	=> \@opt_classes,
		       "load=i"		=> \$opt_fixed_load,
		       "comment=s"	=> \$opt_comment,
		       "kill:i"		=> \$opt_kill,
		       "allow-reserved!"=> sub {shift; push @match_params, (allow_reserved => shift);},
		       "similar!"	=> \$opt_similar,
		       "<>"		=> \&cmd,
		 )) {
    die "%Error: Bad usage, try 'rschedule --help'\n";
}

push @match_params, (classes=>\@opt_classes);
if ($opt_similar) {
    push @match_params,
    (match_cb=>('sub { return 1'
		.'&& ($_[0]->get_undef(qw(archname)) eq \''.$Config{archname}."')"
		.'&& ($_[0]->get_undef(qw(osvers)) eq \''.$Config{osvers}."')"
		.'; }'));
}

# Fetch just once for speed
$scheduler = Schedule::Load::Schedule->fetch(%server_params);
my $secondcmd = 0;
foreach (@commands) {
    print "\n" if $secondcmd++;
    &$_;
}

exit (0);

######################################################################

BEGIN {#static
my $Last_Cmd = "";
my $Opt_Value = 0;
sub cmd {
    my $param = shift;

    # Options to a command just specified
    if ($Last_Cmd eq "class") {
	$Last_Cmd = "";
	my $class = $param;
	$class = "class_$param" if $param !~ /^class_/;
	push @commands, sub {
	    $scheduler->set_stored (host=>$opt_host,
				    $class =>$Opt_Value, );
        };
    } 
    elsif ($Last_Cmd eq "set_const"
	   || $Last_Cmd eq "set_stored") {
	$Last_Cmd = "";
	my $key = $param;
	my $value = 1;
	$value = $1 if $key =~ s/=(.*$)//;
	push @commands, sub {
	    $scheduler->set_stored (host=>$opt_host,
				    set_const => ($Last_Cmd eq "set_const"),
				    $key=>$value, );
        };
    } 
    elsif ($Last_Cmd eq "fixed_load") {
	$Last_Cmd = "";
	push @commands, sub {
	    ($param =~ /^\d+$/) or die "%Error: Fixed_load requires PID argument\n";
	    $scheduler->fixed_load (host=>$opt_host,
				    load=>$opt_fixed_load,
				    pid=>$param);
	};
    }
    elsif ($Last_Cmd eq "cmnd_comment") {
	$Last_Cmd = "";
	push @commands, sub {
	    ($param =~ /^\d+$/) or die "%Error: Cmnd_comment requires PID argument\n";
	    ($opt_comment) or die "%Error: Cmnd_comment requires --comment setting\n";
	    $scheduler->cmnd_comment (host=>$opt_host,
				      comment=>$opt_comment,
				      pid=>$param);
	};
    }
    # New command options
    elsif ($param eq "top") {
	push @commands, sub { print $scheduler->print_top; };
    } elsif ($param eq "hosts") {
	push @commands, sub { print $scheduler->print_hosts; };
    } elsif ($param eq "idle_host_names") {
	push @commands, sub { print join(' ',$scheduler->idle_host_names(@match_params,)),"\n"; };
    } elsif ($param eq "holds") {
	push @commands, sub { print $scheduler->print_holds; };
    } elsif ($param eq "hostnames") {
	push @commands, sub { print join(' ',$scheduler->hostnames(@match_params,)),"\n"; };
    } elsif ($param eq "jobs") {
	push @commands, sub { print $scheduler->jobs(@match_params,),"\n"; };
    } elsif ($param eq "loads") {
	if (defined $opt_kill) {
	    push @commands, sub { print $scheduler->print_kills(signal=>$opt_kill); };
	} else {
	    push @commands, sub { print $scheduler->print_loads; };
	}
    } elsif ($param eq "classes") {
	push @commands, sub { print $scheduler->print_classes; };
    } elsif ($param eq "restart") {	# Undocumented as is nasty
	push @commands, sub { $scheduler->restart; };
    } elsif ($param eq "restart_chooser") {	# Undocumented as is nasty
	push @commands, sub { $scheduler->restart (reporter=>0); };
    } elsif ($param eq "restart_reporter") {	# Undocumented as is nasty
	push @commands, sub { $scheduler->restart (chooser=>0); };
    } elsif ($param eq "status") {
	push @commands, sub { print $scheduler->print_status; };
    } elsif ($param eq "_chooser_close_all") {	# Undocumented, for debugging
	push @commands, sub { $scheduler->_chooser_close_all(); };
    }
    elsif ($param eq "reserve") {
	push @commands, sub {
	    my @param = ();
	    if (defined $opt_comment) {
		if ($opt_comment !~ s/^-//) {
		    $opt_comment = $scheduler->reserve_default_comment . "; " . $opt_comment;
		}
		push @param, (comment=>$opt_comment); 
	    }
	    $scheduler->reserve (host=>$opt_host, @param); 
	}
    } elsif ($param eq "release") {
	push @commands, sub {
	    $scheduler->release (host=>$opt_host); 
	}
    } elsif ($param eq "allow_class") {
	$Last_Cmd = "class";
	$Opt_Value = 1;
    } elsif ($param eq "deny_class") {
	$Last_Cmd = "class";
	$Opt_Value = 0;
    } elsif ($param eq "set_const") {
	$Last_Cmd = $param;
    } elsif ($param eq "set_stored") {
	$Last_Cmd = $param;
    } elsif ($param eq "fixed_load") {
	$Last_Cmd = $param;
    } elsif ($param eq "cmnd_comment") {
	$Last_Cmd = $param;
    } elsif ($param eq "best") {
	push @commands, sub {
	    my $val = $scheduler->best(@match_params, );
	    print "$val\n" if (defined $val);
	    die "%Error: No best host found\n" if (!defined $val);
	};
    } elsif ($param eq "best_or_none") {
	push @commands, sub {
	    my $val = $scheduler->best(@match_params, allow_none=>1,);
	    print "$val\n" if (defined $val);
	    die "%Error: No host as low enough loading\n" if (!defined $val);
	};
    } else {
	die "%Error: Unknown command option $param\n";
    }
}
END {
    if ($Last_Cmd) { die "%Error: Command $Last_Cmd needs another argument\n"; }
}
}#static

######################################################################

sub usage {
    print '$Id: rschedule 98 2007-04-03 15:22:10Z wsnyder $ ', "\n";
    pod2usage(-verbose=>2, -exitval => 2);
    exit(1);
}

sub version {
    print "Version: $Schedule::Load::VERSION\n";
    print 'Id: $Id: rschedule 98 2007-04-03 15:22:10Z wsnyder $ ';
    print "\n";
    exit (1);
}

sub debug {
    $Debug = 1;
    $Schedule::Load::Debug = $Debug;
    $Schedule::Load::Schedule::Debug = $Debug;
    $Schedule::Load::Hosts::Debug = $Debug;
}

######################################################################
######################################################################
######################################################################

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

=pod

=head1 NAME

rschedule - User interface for Perl Schedule::Load configuration and status

=head1 SYNOPSIS

B<rschedule>
[ B<--help> ]
[ B<--port=>I<port> ]
[ B<--dhost=>I<host> ]
[ B<--version> ]

B<rschedule> B<top>
B<rtop>

B<rschedule> B<hosts>
B<rhosts>

B<rschedule> B<loads>
B<rloads>

B<rschedule> B<holds>

B<rschedule> B<status>

B<rschedule> [ B<--host=>I<host> B<--override>] B<reserve>

B<rschedule> [ B<--host=>I<host> ] B<release>

B<rschedule> [ B<--host=>I<host> ] B<allow_class> B<class>

B<rschedule> [ B<--host=>I<host> ] B<deny_class> B<class>

B<rschedule> [ B<--host=>I<host> ] B<set_const> B<var>=B<value>

B<rschedule> [ B<--host=>I<host> ] B<set_stored> B<var>=B<value>

B<rschedule> B<--class=>I<class> B<best>

B<rschedule> B<--class=>I<class> B<best_or_none>

B<rschedule> [ B<--load=>I<load> ] B<fixed_load> B<pid>

=head1 DESCRIPTION

rschedule will report or set status for load distribution using the
Perl Schedule::Load package.

If symbolically linked to the name "rtop" rschedule will by default produce
a listing of each host and the top loads on those hosts.  Similarly, a link
to "rhosts" will show the host report by default, and a link to "rloads"
will show the load report.

=head1 COMMANDS

=over 4

=item allow_class <class>

Sets the hostname to allow the specified class of jobs.  This sticks across reboots.

=item best

Returns the best host for a new job.

=item best_or_none

Returns the best host if there are free CPUs laying around, else fails.

=item classes

Displays a listing of the classes of jobs each host can run.

=item cmnd_comment <pid>

Sets the command comment for the given process ID.  In rschedule top (rtop)
displays, this will be shown rather then the name of the command.  Command
comments are inherited by children of commented parents.

=item deny_class <class>

Sets the hostname to deny the specified class of jobs.

=item fixed_load <pid>

Sets the given process ID to have that process count as one host load, even
if it is using less CPU time then that due to high disk activity or other
sleeps.

=item holds

Displays a listing of jobs that are blocked waiting for resources.

=item hosts

Displays a listing of each host being monitored along with its
load and system type.

=item hostnames

Displays list of each hostname.  Multi-CPU hosts appear once.

=item idle_host_names

Displays list of each idle CPU.  Multi-CPU hosts appear multiple times.

=item loads

Displays a longer command line of top jobs, along with any fixed_load
jobs.

=item release

Releases a host from dedicated use.  Use --host to specify which host.

=item reserve

Reserves a host for dedicated use.  To be reservable the C<reservable> flag
must be set when that host's L<slreportd> is invocated.  This is indicated
on the top report by a "R" in the column next to the command.  To override
a existing reservation you need to release the reservation first.  Use
--host to specify which host.  A optional --comment specifies the
reservation comment; the default time and user will be prepended unless a
leading - is used.

=item set_const B<var=value>

Sets a constant reporter parameter to the specified value.  Slreportd will
loose the information when rebooted, so this should only be used to avoid
restarting the daemon after changing the slreportd's boot flags.

=item set_stored B<var=value>

Sets a stored reporter parameter to the specified value.  Slreportd will
keep the information when rebooted, and override any set_const setting.

=item status

Displays a listing of each host and its daemon's status.  Intended only for
debugging problems with the scheduler.

=item top

Displays a listing of top processes across all hosts being monitored.

=back

=head1 ARGUMENTS

=over 4

=item --allow-reserved

=item --no-allow-reserved

Specifies if reserved hosts may be returned by the best, best_or_none,
hostnames, idle_host_names, and jobs commands.

=item --class <class>

Specifies the job class for the best, best_or_none, hostnames,
idle_host_names, and jobs commands.

=item --comment <comment>

Specifies the command comment for the cmnd_comment command.

=item --dhost <hostname>

Specifies the host name that slchoosed uses.  May be specified multiple
times to specify backup hosts.  Defaults to SLCHOOSED_HOST environment
variable, which contains colon separated host names.

=item --help

Displays this message and program version and exits.

=item --kill <signal>

With the "loads" command, convert the listing to a form that will login to
the host and kill the processes.  With a argument, use the argument as the
signal name.

=item --load <load>

Specifies the load value for the fixed_load command, defaults to 1.

=item --port <portnumber>

Specifies the port number that slchoosed uses.

=item --similar

Specifies only machines with the same OS version as the current host should
be returned for the best, best_or_none, hostnames, idle_host_names, and
jobs commands.

=item --version

Displays program version and exits.

=back

=head1 DISTRIBUTION

The latest version is available from CPAN and from L<http://www.veripool.com/>.

Copyright 1998-2006 by Wilson Snyder.  This package is free software; you
can redistribute it and/or modify it under the terms of either the GNU
Lesser General Public License or the Perl Artistic License.

=head1 SEE ALSO

L<Schedule::Load>

=head1 AUTHORS

Wilson Snyder <wsnyder@wsnyder.org>

=cut
######################################################################