#!/usr/bin/perl

use strict;
use warnings;
use Parse::RecDescent;
use Tie::IxHash;
use Getopt::Long;
use DateTime;
use DateTime::Format::Strptime;

our $VERSION = 0.01;

my $nick = 'cronic';
my @chans;
my $server = 'irc.perl.org';
my $debug;
my $tick_freq = 1;
my $stamp = DateTime::Format::Strptime->new(
	pattern => '%FT%T',
	locale => 'en_GB',
	time_zone => 'UTC' );
my $list_version;
my $help;
my $man;

GetOptions(
	'nickname=s' => \$nick,
	'channel=s' => \@chans,
	'server=s' => \$server,
	'debug!' => \$debug,
	'tick=i' => \$tick_freq,
	'version!' => \$list_version,
	'help!' => \$help,
	'manual!' => \$man,
);

=head1 NAME

cronic - an IRC bot for time related things

=head1 SYNOPSIS

  nohup cronic.pl [options] &
  cronic.pl --help
  cronic.pl --manual

=head1 OPTIONS

=over 4

=item C<--server>

Name of the IRC server to connect to. Defaults to irc.perl.org

=item C<--nick>

Nickname to use for this bot. Defaults to cronic.

=item C<--chan>

Channel to join. Specify this option multiple times to have the bot on
multiple channels.

=item C<--debug>

Send debugging output to stdout. Primarily of interest to developers.

=item C<--tick>

Specify the tick polling interval in seconds. Default is 1 second.
Increase this if there are performance issues on the server.

=item C<--version>

List the version number.

=item C<--help>

Give help on the options available.

=item C<--man> 

Give the full manual page.

=back

=head1 DESCRIPTION

Cronic is an IRC bot for functions related to time. This was inspired by an
idea of using IRC for Cogers debating online. Cogers debates are strict about
how much time is allocated to each speaker.

This document contains command line usage instructions, and is of interest to
someone hosting the bot software. For a full user guide, see 
L<http://www.ivorw.com/cronic_user_guide.html>

=head1 SUPPORT

Please email any bug reports, feature requests, etc .to cronic at xemaps.com.

=head1 COPYRIGHT AND LICENSE

This program is copyright (C) Ivor Williams, 2006.

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found at the following url:
L<http://www.ivorw.com/cronic_license.txt>. If deriving a work from this
code, please host your own copy of this license.

=cut

my $cronic = Bot::Cronic->new(
	nick => $nick,
	channels => \@chans,
	server => $server,
	);

$main::RD_TRACE = 1 if $debug;

my $gram = <<'END';
<autotree>

croncmd: defer(?) repeat(?) action

action: 'say' /.*/
	| 'tell' recipient /.*/
	| 'Sorry'
	| 'queue'
	| 'time' location(?)
	| 'zone' location

defer: 'after' interval
	| 'in' interval
	| 'at' time

repeat: 'every' interval finish(?)

finish: 'until' time

interval: /\d+/ 'seconds'
	| /\d+/ 'minutes'
	| /\d+/ 'hours'
	| /\d+(?:\:\d\d){0,2}/
	
time: /\d\d(?:\:\d\d){0,2}/

location: 'in' /.+/
	| /.+/

recipient: nick
	| channel

channel: /#\w+/

nick: /\w+/

END

my $cronspeak = Parse::RecDescent->new($gram)
	or die "Bad grammar";

$cronic->run;

package Bot::Cronic;

use base qw/Bot::BasicBot/;
use Data::Dumper;
use Parse::RecDescent::Topiary 0.02;

my %timer_queue;
my %zone;
my %locale;
my %pattern;
my @zones;
my %lastchan;

sub init {
	my $self = shift;

	tie %timer_queue, 'Tie::IxHash';
	%zone = ( '##default' => 'Europe/London');
	%locale = ( '##default' => 'en_GB');
	%pattern = ( '##default' => '%b %d %T %Z %Y');
	@zones = DateTime::TimeZone->all_names;
}

sub said {
	my ($self,$argh) = @_;
	my $body = $argh->{body};

	print "said() called\n" if $debug;
	my $chan = $argh->{channel};
	$lastchan{$argh->{who}} = $chan if $chan =~ /^#/;
	print "lastchan:", Dumper \%lastchan if $debug;
	return unless $argh->{address};
	print Dumper $argh if $debug;
	
#	my $tree = $cronspeak->croncmd($body);
	my $tree = topiary(
			tree => $cronspeak->croncmd($body),
			namespace => 'Bot::Cronic',
			ucfirst => 1,
			args => { lt => $self->local_time($argh)} 
			);
	if ($tree) {
		print Dumper $tree if $debug;
		$tree->despatch($self,$argh);
	}
	else {
		return unless $argh->{raw_body} =~ /^$nick[:,]/;
		$self->reply( $argh, "Sorry, I don't understand $body",
		);
	}
}

sub tick {
	my $self = shift;

	my ($time) = each %timer_queue;
	if ($time && ($time lt $stamp->format_datetime(	DateTime->now))) {
		my ($action,$args,$rpt) = @{$timer_queue{$time}};
		delete $timer_queue{$time};
		print "Despatching for $time\n" if $debug;
		$rpt->queue($self,$action,$args,$time) if $rpt;
		$action->despatch($self,$args);
	}
	$tick_freq;
}

sub enqueue {
	my ($self, $time, $action, $args, $repeat) = @_;
	
	$timer_queue{$stamp->format_datetime($time)} = [$action,$args,$repeat];
	tied(%timer_queue)->SortByKey;
}

sub dump_queue {
	my ($self,$chan) = @_;
	
	map {($timer_queue{$_}[1]{channel} eq $chan) 
		? ($_,$timer_queue{$_}[0]) : () }
		keys %timer_queue;
}

sub local_time {
	my ($self, $args) = @_;
	
	my @lookup = ('##default');
	my $who = $args->{who};
	if ($args->{address} eq 'msg') {
		unshift @lookup,$lastchan{$who} if exists $lastchan{$who};
		unshift @lookup,$who;
	}
	else {
		unshift @lookup,$args->{channel};
	}
	my ($tz, $loc, $ptn);
	for (@lookup) {
		$tz ||= $zone{$_} if exists $zone{$_};
		$loc ||= $locale{$_} if exists $locale{$_};
		$ptn ||= $pattern{$_} if exists $pattern{$_};
	}
	return DateTime::Format::Strptime->new( 
		time_zone => $tz,
		locale => $loc,
		pattern => $ptn,
	);
}

sub help {
	my ($self,$args) = shift;

	my $msg = '';
	$msg = 'Detailed help not available. ' if $@;
	$msg .= 'A full help text is at '.
		"http://www.ivorw.com/cronic_user_guide.html";
#	$self->reply($args, $msg);
}

package Bot::Cronic::Base;
use base qw(Parse::RecDescent::Topiary::Base);

sub new {
	my $pkg = shift;
	my $self = $pkg->SUPER::new(@_);

	delete $self->{args};
	$self;
}

package Bot::Cronic::Croncmd;
use base qw(Bot::Cronic::Base);

sub despatch {
	my ($self,$bot,$args) = @_;

	my ($defer) = @{$self->{'defer(?)'}};
	my ($repeat) = @{$self->{'repeat(?)'}};
	if ($defer) {
		$defer->queue($bot,$self->{action},$args,$repeat);
	}
	else {
		$self->{action}->despatch($bot,$args);
		if ($repeat) {
			$repeat->queue($bot,$self->{action},$args);
		}
	}
}

package Bot::Cronic::Action;
use base qw(Bot::Cronic::Base);

sub despatch {
	my ($self,$bot,$args) = @_;

	my $loctime = $bot->local_time($args);
	my $verb;
	$verb = $self->{__VALUE__} if exists $self->{__VALUE__};
	$verb = $self->{__STRING1__} if exists $self->{__STRING1__};
	my $message = $self->$verb($bot,$args,$loctime);
	
	return unless $message;

}

sub queue {
	my ($self,$bot,$args,$lt) = @_;

	my @q = $bot->dump_queue($args->{channel});
	my $message = @q ? "Queue of actions:\n" : "Queue is empty";
	while (@q) {
		my $time = $stamp->parse_datetime(shift @q);
		$time->set_time_zone($lt->time_zone);
		my $action = shift @q;
		$message .= sprintf "%25s %s\n", 
			$lt->format_datetime($time), 
			$action->dump;
	}
	$bot->reply( $args, $message);
}

sub time {
	my ($self,$bot,$args,$lt) = @_;
	
	my $now = DateTime->now( time_zone => $lt->time_zone );
	
	my ($loc) = @{$self->{'location(?)'}};
	
	if (!$loc) {
		$bot->reply( $args, $lt->format_datetime($now));
		return;
	}
		
	my @tz = $loc->decode;
	if (!@tz) {
		$bot->reply( $args, "haven't a clue");
		return;
	}
	my %continent = map { /^(\w+)/, 1 } @tz;
	my $message = '';
	my $prefix = '';
	if (keys(%continent) > 1) {
		$message = "World time:\n";
	}
	elsif (@tz > 1) {
		$prefix = (keys %continent)[0];
		$message = "Time in $prefix:\n";
		$prefix .= '/';
	}
	
	my %times;
	tie %times, 'Tie::IxHash';
	for (@tz) {
		$now->set_time_zone($_);
		s/$prefix//;
		push @{$times{ $lt->format_datetime($now)}}, $_;
	}
	tied(%times)->SortByKey;
	while (my ($time,$z) = each %times) {
		$message .= sprintf "%-28s %s\n", $time, 
			join ', ',@$z;
	}
	$bot->reply( $args, $message);
}

sub zone {
	my ($self,$bot,$args) = @_;
	
	my @tz = $self->{location}->decode;
	my $message;
	if (@tz > 1) {
		$message = "Location ambiguous, try \"time ".
		$self->{location}{__PATTERN1__} . '"';
	}
	elsif (!@tz) {
		$message = "Location unknown";
	}
	else {
		my $setting = $args->{address} eq 'msg'
			? $args->{who} : $args->{channel};
		$zone{$setting} = $tz[0];
		$message = 'OK';
	}
	$bot->reply( $args, $message);
}

sub say {
	my ($self,$bot,$args) = @_;
	
	$bot->reply( $args, $self->{__PATTERN1__});
}

sub tell {
	my ($self,$bot,$args) = @_;

	my $rec = $self->{recipient};
	my $msg = $self->{__PATTERN1__};
	if (exists $rec->{channel}) {
		my $chan = $rec->{channel}{__VALUE__};
		if (grep {$_ eq $chan} @chans) {
			$bot->say( 
				channel => $chan,
				body => $msg,
			);
		}
		else {
			$bot->reply( $args, "Sorry, not on $chan");
		}
	}
	else { 
		my $who = $rec->{nick}{__VALUE__};
		
		if ($args->{address} eq 'msg') {
			$bot->say(
				channel => 'msg',
				body	=> $msg,
				who	=> $who,
			);
		}
		else {
			$bot->say(
				channel => $args->{channel},
				body	=> $msg,
				who	=> $who,
				address	=> $who,
			);
		}
	}
}

sub Sorry { }	# This might get called if this bot starts talking
		# to another cronic bot :)

sub dump {
	my $self = shift;

	return $self->{__VALUE__} if exists $self->{__VALUE__};

	return "$self->{__STRING1__} $self->{__PATTERN1__}"; 
}

package Bot::Cronic::Defer;
use base qw(Bot::Cronic::Base);

sub queue {
	my ($self,$bot,$action,$args,$rpt) = @_;
	my $timer_obj = ($self->{__STRING1__} eq 'at') 
		? $self->{time} : $self->{interval};
	my $evt = $timer_obj->utc;
	
	if (!$evt) {
		$bot->reply( $args, 
		"Sorry, that time is in the past. ".
		"Current time is ".$bot->local_time->format_datetime(
			DateTime->now ) );
		return;
	}
	$bot->enqueue($evt, $action, $args, $rpt);
	$bot->reply($args, "OK");
}

package Bot::Cronic::Time;
use base qw(Bot::Cronic::Base);

sub new {
	my ($pkg,%args) = @_;
	my $self = $pkg->SUPER::new(%args);
	$self->{lt} = $args{args}{lt};
	$self->{utc} = $self->calc_future_time;
	return $self;
}

sub utc {
	my $self = shift;

	return $self->{utc};
}

sub calc_future_time {
	my $self = shift;

	my $loc = $self->{lt};
	my $evt = DateTime->now( time_zone => $loc->time_zone );
	my $now = $evt->clone;
	my $time = $self->{__VALUE__};
	if ($time =~ /^(\d\d)(?:\:(\d\d)(?:\:(\d\d))?)?$/) {
		$evt->set_hour($1);
		$evt->set_minute( $2 || 0 );
		$evt->set_second( $3 || 0 );
	}
	else {
		$evt = $loc->parse_datetime($time );
	}
	return undef if $evt < $now;
	$evt->set_time_zone('UTC');
	return $evt;
}

package Bot::Cronic::Interval;
use base qw(Bot::Cronic::Base);

sub new {
	my $pkg = shift;
	my $self = $pkg->SUPER::new(@_);
	$self->{utc} = $self->calc_future_time;
	return $self;
}

sub utc {
	my $self = shift;

	return $self->{utc};
}

sub calc_future_time {
	my ($self,$time) = @_;
	my $evt = $time ? $stamp->parse_datetime($time) :
		DateTime->now( time_zone => 'UTC');
		
	if (exists $self->{__STRING1__}) {
		$evt->add( $self->{__STRING1__}, $self->{__PATTERN1__} );
	}
	else {
		my $seconds = $self->{__VALUE__};
		1 while $seconds =~ s/^(\d+)\:(\d+)/$1 * 60 + $2/e;
		$evt->add( seconds => $seconds );
	}
	return $evt;
}

package Bot::Cronic::Repeat;
use base qw(Bot::Cronic::Base);

sub queue {
	my ($self,$bot,$action,$args,$time) = @_;
	my $evt = $self->{interval}->calc_future_time($time);
	my ($fin) = @{$self->{'finish(?)'}};
	my $timeup;
	if ($fin) {
		$timeup = $evt > $fin->{time}->utc;
	}
	if (!$timeup) {
		$bot->enqueue($evt, $action, $args, $self);
	}
}

package Bot::Cronic::Finish;
use base qw(Bot::Cronic::Base);

package Bot::Cronic::Location;
use base qw(Bot::Cronic::Base);

sub decode {
	my $self = shift;

	my $loc_match = $self->{__PATTERN1__} || $self->{__VALUE__};
	print __PACKAGE__."::decode pattern is $loc_match\n" if $debug;
	$loc_match =~ s/ /_/g;
	return grep { /$loc_match/i } @zones;
}

package Bot::Cronic::Recipient;
use base qw(Bot::Cronic::Base);

package Bot::Cronic::Nick;
use base qw(Bot::Cronic::Base);

package Bot::Cronic::Channel;
use base qw(Bot::Cronic::Base);