package Schedule::At;

require 5.004;

# Copyright (c) 1997-2008 Jose A. Rodriguez. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

use vars qw($VERSION @ISA $TIME_FORMAT);

$VERSION = '1.09';

###############################################################################
# Load configuration for this OS
###############################################################################

use Config;

my @configs = split (/\./, "$Config{'osname'}");
while (@configs) {
	my $subName = 'AtCfg_' . join('_', @configs);
	$subName =~ s/[^\w\d]/_/g;

	eval "&$subName"; # Call configuration subroutine
	last if !$@; 

	pop @configs;
}

&AtCfg if $@; # Default configuration

###############################################################################
# Public subroutines
###############################################################################

$TIME_FORMAT = '%Q%H%M'; # Format for Date::Manip::DateUnix subroutine

$TAGID = '##### Please, do not remove this Schedule::At TAG: ';

sub add {
	my %params = @_;

	my $command = $AT{($params{FILE} ? 'addFile' : 'add')};
	return &$command($params{JOBID}) if ref($command) eq 'CODE';

	my $atTime = _std2atTime($params{TIME});
	
	$command =~ s/%TIME%/$atTime/g;
	$command =~ s/%FILE%/$params{FILE}/g;

	if ($params{FILE}) {
		return (system($command) / 256);
	} else {
		open (ATCMD, "| $command") or return 1;
		print ATCMD "$TAGID$params{TAG}\n" if $params{TAG};

		print ATCMD ref($params{COMMAND}) eq "ARRAY" ?
			join("\n", @{$params{COMMAND}}) : $params{COMMAND};
                  
		close (ATCMD);
	}

	0;
}

sub remove {
	my %params = @_;

	if ($params{JOBID}) {
		my $command = $AT{'remove'};
		return &$command(@_) if ref($command) eq 'CODE';

		$command =~ s/%JOBID%/$params{JOBID}/g;

		system($command) >> 8;
	} else {
		return if !defined $params{TAG};

		my %jobs = getJobs();
		my %return;

		foreach my $job (values %jobs) {
			next if !defined($job->{JOBID}) || 
				!defined($job->{TAG});

			if ($job->{JOBID} && $params{TAG} eq $job->{TAG}) {
				$return{$job->{JOBID}} = 
					remove(JOBID => "$job->{JOBID}") 
			}
		}

		return \%return
	}
}

sub getJobs {
	my %param = @_;

	my %jobs;
	
	my $command = $AT{'getJobs'};
	return &$command(@_) if ref($command) eq 'CODE';

	open (ATCMD, "$command |")
		or die "Schedule::At: Can't exec getJobs command: $!\n";
	line: while (defined (my $atLine = <ATCMD>)) {
		if (defined $AT{'headings'}) {
			foreach my $head (@{$AT{'headings'}}) {
				next line if $atLine =~ /$head/;
			}
		}

		chomp $atLine;

		my %atJob;
		($atJob{JOBID}, $atJob{TIME}) 
			= &{$AT{'parseJobList'}}($atLine);
		$atJob{TAG} = _getTag(JOBID => $atJob{JOBID});
		next if $param{TAG} && 
			(!$atJob{TAG} || $atJob{TAG} ne $param{TAG});
		next if $param{JOBID} && 
			(!$atJob{JOBID} || $atJob{JOBID} ne $param{JOBID});
		$jobs{$atJob{JOBID}} = \%atJob;
	}
	close (ATCMD);

	%jobs;
}

sub readJobs {
	my %jobs = getJobs(@_);

	my @job_ids = map { $_->{JOBID} } values %jobs;

	my %content;
	foreach my $jobid (@job_ids) {
		$content{$jobid} = _readJob(JOBID => $jobid);
	}

	%content
}

###############################################################################
# Private subroutines
###############################################################################

sub _readJob {
	my %params = @_;

	my $command = $AT{'getCommand'};
	$command = &$command($params{JOBID}) if ref($command) eq 'CODE';

	$command =~ s/%JOBID%/$params{JOBID}/g;

	local $/ = undef; # slurp mode
	open (JOB, "$command")
		or die "Can't open $command: $!\n";
	my $job = <JOB>;
	close (JOB);

	$job
}

sub _getTag {
	my %params = @_;

	my $job =  _readJob(@_);
	$job =~ /$TAGID(.*)$/m;
	return $1;

	my @job = split("\n", _readJob(@_));
	foreach my $commandLine (@job) {
		return $1 if $commandLine =~ /$TAGID(.*)$/;
	}

	undef;
}

sub _std2atTime {
	my ($stdTime) = @_;

	# StdTime: YYYYMMDDHHMM
	my ($year, $month, $day, $hour, $mins) = 
		$stdTime =~ /(....)(..)(..)(..)(..)/;

	my $timeFormat = $AT{'timeFormat'};	
	return &$timeFormat($year, $month, $day, $hour, $mins) 
		if ref($timeFormat) eq 'CODE';

	$timeFormat =~ s/%YEAR%/$year/g;
	$timeFormat =~ s/%MONTH%/$month/g;
	$timeFormat =~ s/%DAY%/$day/g;
	$timeFormat =~ s/%HOUR%/$hour/g;
	$timeFormat =~ s/%MINS%/$mins/g;

	$timeFormat;
}

=head1 NAME

Schedule::At - OS independent interface to the Unix 'at' command

=head1 SYNOPSIS

 require Schedule::At;

 Schedule::At::add(TIME => $string, COMMAND => $string [, TAG =>$string]);
 Schedule::At::add(TIME => $string, COMMAND => \@array [, TAG =>$string]);
 Schedule::At::add(TIME => $string, FILE => $string)

 %jobs = Schedule::At::getJobs();
 %jobs = Schedule::At::getJobs(JOBID => $string);
 %jobs = Schedule::At::getJobs(TAG => $string);

 Schedule::At::readJobs(JOBID => $string);
 Schedule::At::readJobs(TAG => $string);

 Schedule::At::remove(JOBID => $string);
 Schedule::At::remove(TAG => $string);

=head1 DESCRIPTION

This modules provides an OS independent interface to 'at', the Unix 
command that allows you to execute commands at a specified time.

=over 4

=item Schedule::At::add

Adds a new job to the at queue. 

You have to specify a B<TIME> and a command to execute. The B<TIME> has
a common format: YYYYMMDDHHmm where B<YYYY> is the year (4 digits), B<MM>
the month (01-12), B<DD> is the day (01-31), B<HH> the hour (00-23) and
B<mm> the minutes.

The command is passed with the B<COMMAND> or the B<FILE> parameter.
B<COMMAND> can be used to pass the command as an string, or an array of
commands, and B<FILE> to read the commands from a file.

The optional parameter B<TAG> serves as an application specific way to 
identify a job or a set of jobs.

Returns 0 on success or a value != 0 if an error occurred.

=item Schedule::At::readJobs

Read the job content identified by the B<JOBID> or B<TAG> parameters.

Returns a hash of JOBID => $string where $string is the the job
content. As the operating systems usually add a few environment settings,
the content is longer than the command provided when adding the job.

=item Schedule::At::remove

Remove an at job.

You identify the job to be deleted using the B<JOBID> parameter (an 
opaque string returned by the getJobs subroutine). You can also specify
a job or a set of jobs to delete with the B<TAG> parameter, removing
all the jobs that have the same tag (as specified with the add subroutine).

Used with JOBID, returns 0 on success or a value != 0 if an error occurred.
Used with TAG, returns a hash reference where the keys are the JOBID of
the jobs found and the values indicate the success of the remove operation.

=item Schedule::At::getJobs

Called with no params returns a hash with all the current jobs or 
dies if an error has occurred. 
It's possible to specify the B<TAG> or B<JOBID> parameters so only matching
jobs are returned.
For each job the key is a JOBID (an OS dependent string that shouldn't be 
interpreted), and the value is a hash reference. 

This hash reference points to a hash with the keys:

=over 4

=item TIME

An OS dependent string specifying the time to execute the command

=item TAG

The tag specified in the Schedule::At::add subroutine

=back

=back

=head1 EXAMPLES

 use Schedule::At;

 # 1
 Schedule::At::add (TIME => '199801181530', COMMAND => 'ls', 
	TAG => 'ScheduleAt');
 # 2
 @cmdlist = ("ls", "echo hello world");

 Schedule::At::add (TIME => '199801181630', COMMAND => \@cmdlist, 
	TAG => 'ScheduleAt');
 # 3
 Schedule::At::add (TIME => '199801181730', COMMAND => 'df');

 # This will remove #1 and #2 but no #3
 Schedule::At::remove (TAG => 'ScheduleAt');

 my %atJobs = Schedule::At::getJobs();
 foreach my $job (values %atJobs) {
	print "\t", $job->{JOBID}, "\t", $job->{TIME}, ' ', 
		($job->{TAG} || ''), "\n";
 } 

=head1 AUTHOR

Jose A. Rodriguez (josear@ac.upc.es)

=cut

###############################################################################
# OS dependent code
###############################################################################

sub AtCfg {
	# Currently the default configuration just aborts
	die "SORRY! There is no config for this OS.\n";
}

sub AtCfg_solaris {
	$AT{'add'} = 'at %TIME% 2> /dev/null';
	$AT{'addFile'} = 'at -f %FILE% %TIME% 2> /dev/null';
	$AT{'timeFormat'} = sub { 
		my ($year, $month, $day, $hour, $mins) = @_;

		my @months = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 
			'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

		"$hour:$mins " . $months[$month-1] . " $day, $year";
	};
	$AT{'remove'} = 'at -r %JOBID%';
	$AT{'getJobs'} = 'at -l';
	$AT{'headings'} = [];
	$AT{'getCommand'} = '/usr/spool/cron/atjobs/%JOBID%';
	# Ignore "user = xxx" when executed by root
	$AT{'parseJobList'} = sub { $_[0] =~ /^.*(\d{10}.a)\s+(.*)$/ };
}

sub AtCfg_sunos {
	&AtCfg_solaris;
	$AT{'getCommand'} = sub {
		my ($jobid) = @_;

		for my $filename (glob('/usr/spool/cron/atjobs/*')) {
			return $filename if (stat($filename))[1] == $jobid;
		}

		undef;
	}
}

sub AtCfg_dec_osf {
	&AtCfg_solaris;
	# josear.1137594600.a     Wed Jan 18 15:30:00 2006
	$AT{'parseJobList'} = sub { $_[0] =~ /^(\S+)\s+(.*)$/ };
}

sub AtCfg_hpux {
	$AT{'add'} = 'at %TIME% 2> /dev/null';
	$AT{'addFile'} = 'at -f %FILE% %TIME% 2> /dev/null';
	$AT{'timeFormat'} = '%HOUR%:%MINS% %MONTH%/%DAY%/%YEAR%';
	$AT{'remove'} = 'at -r %JOBID%';
	$AT{'getJobs'} = 'at -l';
	$AT{'headings'} = [];
	$AT{'getCommand'} = '/usr/spool/cron/atjobs/%JOBID%';
	$AT{'parseJobList'} = sub { $_[0] =~ /^(\S+)\s+(.*)$/ };
}

sub AtCfg_linux {
	$AT{'add'} = 'at %TIME% 2> /dev/null';
	$AT{'addFile'} = 'at -f %FILE% %TIME% 2> /dev/null';
	$AT{'timeFormat'} = '%HOUR%:%MINS% %MONTH%/%DAY%/%YEAR%';
	$AT{'remove'} = 'atrm %JOBID%';
	$AT{'getJobs'} = 'atq';
	$AT{'headings'} = ['Date'];
	$AT{'getCommand'} = 'at -c %JOBID% |';
	# 1       2003-01-18 15:30 a josear
	$AT{'parseJobList'} = sub { 
		my @fields = split("\t", $_[0]);
		($fields[0], substr($fields[1], 0, 16)) 
	};
}

sub AtCfg_aix {
	&AtCfg_hpux;
}

sub AtCfg_dynixptx {
	$AT{'add'} = 'at %TIME% 2> /dev/null';
	$AT{'addFile'} = 'at -f %FILE% %TIME% 2> /dev/null';
	$AT{'timeFormat'} = sub {
	        my ($year, $month, $day, $hour, $mins) = @_;

	        my @months = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
	                'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

	        "$hour:$mins " . $months[$month-1] . " $day, $year";
	};
	$AT{'remove'} = 'at -r %JOBID%';
	$AT{'getJobs'} = 'at -l';
	$AT{'headings'} = [];
	$AT{'getCommand'} = '/usr/spool/cron/atjobs/%JOBID%';
	$AT{'parseJobList'} = sub {
	        my $user = scalar getpwuid $<;
	        if ($user eq 'root') {
	                $_[0] =~ /^\s*\S+\s*\S+\s*\S+\s*(\S+)\s+(.*)$/
	        }
	        else {
	                $_[0] =~ /(\S+)\s+(.*)$/
	        }
	};
}

sub AtCfg_freebsd {
	$AT{'add'} = 'at %TIME% 2> /dev/null';
	$AT{'addFile'} = 'at -f %FILE% %TIME% 2> /dev/null';
	$AT{'timeFormat'} = sub {
		my ($year, $month, $day, $hour, $mins) = @_;

	my @months = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
		'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

	        "$hour:$mins " . $months[$month-1] . " $day $year";
	};
	$AT{'remove'} = 'atrm %JOBID%';
	$AT{'getJobs'} = 'at -l';
	$AT{'headings'} = ['Date', 'Owner', 'Queue', 'Job'];
	$AT{'getCommand'} = 'at -c %JOBID% | '; 
	$AT{'parseJobList'} = sub { $_[0] =~ s/^\s*(.+)\s+\S+\s+\S+\s+(\d+)$/$2_$1/; $_[0] =~ /^(.+)_(.+)$/ };
}

sub AtCfg_openbsd {
        &AtCfg_freebsd;
        $AT{'headings'} = [];
        $AT{'parseJobList'} = sub { $_[0] =~ /^.*(\d{10}.c)\s+(.*)$/ };
}

# Mac OS X (darwin, tiger)
sub AtCfg_darwin {
	$AT{'add'} = 'at %TIME% 2> /dev/null';
	$AT{'addFile'} = 'at -f %FILE% %TIME% 2> /dev/null';
	$AT{'timeFormat'} = '%HOUR%:%MINS% %MONTH%/%DAY%/%YEAR%';
	$AT{'remove'} = 'atrm %JOBID%';
	$AT{'getJobs'} = 'atq';
	$AT{'headings'} = ['Job','Date'];
	$AT{'getCommand'} = 'at -c %JOBID% | ';
	# 74      Wed Jan 18 15:32:00 2006
	$AT{'parseJobList'} = sub {
		my @fields = split("\t", $_[0]);
		($fields[0], substr($fields[1], 0, 16)) 
	};
}
