#!/usr/bin/perl -w

use Net::IRC;
$irc = new Net::IRC;
$conn = $irc->newconn (Nick     => 'greybot',
		       Ircname  => 'the bot that is grey',
		       Username => 'greybot',
		       Server   => 'irc.freenode.net',
		       Port     => '6667');

my (%faq);
my (@faqkeys);
my (%pf);
my (@pfkeys);
my (%channels);

my $ALIAS_DEPTH = 4;

sub on_connect {
	my $self = shift;
	my $password;

	if (open PASS, "<password") {
		print "# Identifying to nickserv\n";
		$password = <PASS>;
		chomp($password);
		$self->privmsg("nickserv", "identify $password");
		close PASS;
	}
	# Apparently, one does not need to do this any more.
	# print "->nickserv set unfiltered on\n";
	# $self->privmsg("nickserv", "set unfiltered on");

	print "# Joining #bash\n";
	$self->join ("#bash");
}

# learn and forget are intentionally omitted here.
sub on_msg {
	my ($self, $event) = @_;
	my ($nick) = $event->nick;
	my ($arg) = $event->args;

	print "*$nick* ", ($event->args), "\n";
	if ($arg =~ /^!?faq/i) {
		cmd_faq($arg, $self, $event, $nick);
	} elsif ($arg =~ /^!?pf/i) {
		cmd_pf($arg, $self, $event, $nick);
	} elsif ($arg =~ /^!?date$/i) {
		cmd_date($self, $event, $nick);
	} elsif ($arg =~ /^!?meta/i) {
		cmd_meta($arg, $self, $event, $nick);
	} else {
		cmd_recall($arg, $self, $event, $nick);
	}
}

sub on_notice {
	my ($self, $event) = @_;
	my ($nick) = $event->nick;
	print "*$nick* ", ($event->args), "\n";
}

sub on_action {
	my ($self, $event) = @_;
	my ($nick) = $event->nick;
	print "* $nick ", ($event->args), "\n";
}

sub on_public {
	my ($self, $event) = @_;
	# my @to = $event->to;
	my ($nick) = ($event->nick);
	my ($arg) = ($event->args);

	print "<$nick> $arg\n";

	if ($arg =~ /^!faq/i) {
		cmd_faq($arg, $self, $event, $event->to);
	} elsif ($arg =~ /^!pf/i) {
		cmd_pf($arg, $self, $event, $event->to);
	} elsif ($arg =~ /^!date$/i) {
		cmd_date($self, $event, $event->to);
	} elsif ($arg =~ /^!learn/i) {
		cmd_learn($arg, $self, $event, $event->to);
	} elsif ($arg =~ /^!forget/i) {
		cmd_forget($arg, $self, $event, $event->to);
	} elsif ($arg =~ /^!meta/i) {
		cmd_meta($arg, $self, $event, $event->to);
	} elsif ($arg =~ /^!/) {
		cmd_recall($arg, $self, $event, $event->to);
	}
}

# Example syntax:
# faq27
# !faq 27
# faq spaces
# faq 2>&1 >newbie
# faq 1 > newbie

# To allow FAQ keys with > in them, there must be a space before ">" in the
# "redirect to a person" syntax.

sub cmd_faq {
	my ($arg, $self, $event, $to) = @_;
	my @to = $to;
	my ($search) = $arg;
	my ($answer) = "";
	my ($rcpt);
	my ($key);

	# Parse the request.  Remove leading "!faq " stuff, then look for a
	# redirection.
	$search =~ s/^!?faq *//i;
	if ($search =~ / >/) {
		$rcpt = $search;
		$search =~ s/ +>.*$//;
		$rcpt =~ s/^.* > *//;
		$rcpt =~ s/ *$//;
	} else {
		undef $rcpt;
	}

	read_faq();
	# First, check for "!faq 27".
	$key = 'faq' . $search;
	if (defined($faq{$key})) {
		$answer = "http://mywiki.wooledge.org/BashFAQ/" .
			sprintf("%03d", $search) . " -- $faq{$key}";
	} else {
		foreach $key (@faqkeys) {
			if ($faq{$key} =~ /\Q$search/i) {
				my ($n);
				$n = $key;
				$n =~ s/^faq//;
				$answer = "http://mywiki.wooledge.org/BashFAQ/" .
					sprintf("%03d", $n) . " -- $faq{$key}";
				last;
			}
		}
	}
	if ($answer eq "") {
		$answer = "No matches found at http://mywiki.wooledge.org/BashFAQ";
	}
	if (defined($rcpt)) {
		print "->$to $rcpt: $answer\n";
		$self->privmsg([ @to ], $rcpt . ": " . $answer);
	} else {
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
	}
}

sub read_faq {
	%faq = ();
	@faqkeys = ();
	my ($line, $nextline);
	if (!open FAQ, "<BashFAQ") {
		print "### Couldn't read FAQ 'BashFAQ': $!\n";
		return;
	}
	while (<FAQ>) {
		if (/<<Anchor/) {
			chomp;
			$line = $_;
			$line =~ s/^.*<<Anchor\(//;	# trim <<Anchor(
			$line =~ s/\)>>.*$//;		# trim )>>
			$nextline = <FAQ>;
			chomp $nextline;
			$nextline =~ s/^=* *//;		# trim leading ==
			$nextline =~ s/ *=*\r*$//;	# trim trailing ==
			$faq{$line} = $nextline;
			push @faqkeys, $line;
		}
	}
	close FAQ;
}

# This is based on cmd_faq.
sub cmd_pf {
	my ($arg, $self, $event, $to) = @_;
	my @to = $to;
	my ($search) = $arg;
	my ($answer) = "";
	my ($rcpt, $key);

	# Parse the request.  Remove leading "!pf " stuff, then look for a
	# redirection.
	$search =~ s/^!?pf *//i;
	if ($search =~ / >/) {
		$rcpt = $search;
		$search =~ s/ +>.*$//;
		$rcpt =~ s/^.* > *//;
		$rcpt =~ s/ *$//;
	} else {
		undef $rcpt;
	}

	read_pf();

	# First, check for "!pf 27" notation.
	$key = 'pf' . $search;
	if (defined($pf{$key})) {
		$answer = "http://mywiki.wooledge.org/BashPitfalls#" . $key .
			" -- Don't do this! -- $pf{$key}";

	# Otherwise, search for the argument as a string.
	} else {
		foreach $key (@pfkeys) {
			if ($pf{$key} =~ /\Q$search/i) {
				$answer = "http://mywiki.wooledge.org/BashPitfalls#" .
					$key . " -- Don't do this! -- $pf{$key}";
				last;
			}
		}
	}

	if ($answer eq "") {
		$answer = "No matches found at http://mywiki.wooledge.org/BashPitfalls";
	}
	if (defined($rcpt)) {
		print "->$to $rcpt: $answer\n";
		$self->privmsg([ @to ], $rcpt . ": " . $answer);
	} else {
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
	}
}

sub read_pf {
	%pf = ();
	@pfkeys = ();
	my ($line, $nextline);
	if (!open PF, "<BashPitfalls") {
		print "### Couldn't read 'BashPitfalls': $!\n";
		return;
	}
	while (<PF>) {
		if (/<<Anchor/) {
			chomp;
			$line = $_;
			$line =~ s/^.*<<Anchor\(//;	# trim <<Anchor(
			$line =~ s/\)>>.*$//;		# trim )>>
			$nextline = <PF>;
			chomp $nextline;
			$nextline =~ s/^=* *//;		# trim leading ==
			$nextline =~ s/ *=*\r*$//;	# trim trailing ==
			$pf{$line} = $nextline;
			push @pfkeys, $line;
		}
	}
	close PF;
}

sub cmd_date {
	my ($self, $event, $to) = @_;
	my (@to) = $to;
	my ($answer);

	$answer = gmtime;
	print "->$to $answer\n";
	$self->privmsg([ @to ], $answer);
}

# Expected syntax:
#  !learn key value ....
# learn is not allowed in privmsg -- must be public.
sub cmd_learn {
	my ($arg, $self, $event, $to) = @_;
	my @to = $to;
	my ($nick) = $event->nick;
	my (@words);
	my ($answer);

	@words = split(' ', $arg);
	if (!defined($words[2])) {
		print "->$to usage: !learn key value...\n";
		$self->privmsg([ @to ], "usage: !learn key value...\n");
		return;
	}

	# Lower-case the key before we do anything else.
	$words[1] = lc($words[1]);
	# Keys MUST NOT contain slashes.
	$words[1] =~ s#/##g;

	# If the key was all slashes, abort.
	if ($words[1] eq "") {
		$answer = "After removing slashes, your key was empty.";
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
		return;
	}

	# If the key is a directory name, abort.
	if (-d "factoids/$words[1]") {
		$answer = "Sorry, $words[1] is a directory.  I can't do that.";
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
		return;
	}

	if (open(LEARN, "<factoids/$words[1]")) {
		$answer = "$words[1] is already defined: ";
		$answer .= <LEARN>;
		close LEARN;
		chomp $answer;
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
		return;
	}
	if (!open(LEARN, ">factoids/$words[1]")) {
		$answer = "ERROR: failed to open factoids/$words[1] ($!)";
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
		return;
	}
	if (!open(META, ">>meta/$words[1]")) {
		$answer = "ERROR: failed to open meta/$words[1] ($!)";
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
		close LEARN;
		return;
	}

	# Phew!  We've got all we need now.
	shift @words;
	shift @words;
	print LEARN join(' ', @words);
	close LEARN;
	print META "$nick " . time . " learn " . join(' ', @words) . "\n";
	close META;
	print "->$to OK, $nick\n";
	$self->privmsg([ @to ], "OK, $nick");
}

# forget must also be done in public.  No secret mass deletions.
sub cmd_forget {
	my ($arg, $self, $event, $to) = @_;
	my @to = $to;
	my ($nick) = $event->nick;
	my (@words);
	my ($answer);

	@words = split(' ', $arg);
	if (!defined($words[1])) {
		print "->$to usage: !forget key\n";
		$self->privmsg([ @to ], "usage: !forget key\n");
		return;
	}

	$arg = lc($words[1]);
	$arg =~ s#/##g;
	if (!open(RECALL, "<factoids/$arg")) {
		$answer = "I don't know what $arg is";
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
		return;
	}
	close RECALL;
	if (!open(META, ">>meta/$arg")) {
		$answer = "ERROR: failed to open meta/$arg ($!)";
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
		return;
	}
	print META "$nick " . time . " forget\n";
	close META;
	unlink "factoids/$arg";
	$answer = "OK, $nick";
	print "->$to $answer\n";
	$self->privmsg([ @to ], $answer);
}

# Example syntax:
# pe
# !pe
# variable variable
# >() > greycat

sub cmd_recall {
	my ($arg, $self, $event, $to) = @_;
	my @to = $to;
	my ($answer, $rcpt);

	# Parse argument, removing leading ! if any, and looking for a redirect.
	$arg =~ s/^!?//;
	if ($arg =~ / >/) {
		$rcpt = $arg;
		$arg =~ s/ +>.*$//;
		$rcpt =~ s/^.* > *//;
		$rcpt =~ s/ *$//;
	} else {
		undef $rcpt;
	}

	# Get the answer from the files
	$answer = recall_lookup($arg, $ALIAS_DEPTH);
	return unless defined($answer);

	if (defined($rcpt)) {
		print "->$to $rcpt: $answer\n";
		$self->privmsg([ @to ], $rcpt . ": " . $answer);
	} else {
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
	}
}

#Get the recall from the factoid DB, following redirects up to a given depth
sub recall_lookup {
	my ($arg, $depth) = @_;
	return unless ($depth > 0);

	$arg = lc($arg);
	$arg =~ s#/##g;

	# Don't open directories, sockets, etc.  Prevents oddness on "!.", etc.
	return unless -f "factoids/$arg";

	if (open(RECALL, "<factoids/$arg")) {
		$answer = <RECALL>;
		close RECALL;
		if ($answer =~ s/^#redirect +//i) {
			return recall_lookup($answer, $depth - 1);
		}
		return $answer;
	}
	return;
}

sub cmd_meta {
	my ($arg, $self, $event, $to) = @_;
	my @to = $to;
	my ($answer);

	$arg =~ s/^!?meta *//i;
	$arg = lc($arg);
	$arg =~ s#/##g;
	if (!open(META, "<meta/$arg")) {
		$answer = "I have no record of $arg";
		print "->$to $answer\n";
		$self->privmsg([ @to ], $answer);
		return;
	}
	# Get the last line.
	while (<META>) { chomp; $answer = $_; }
	close META;
	print "->$to $answer\n";
	$self->privmsg([ @to ], $answer);
}

sub read_channels {
	%channels = ();
	if (!open(CHAN, "<channels")) {
		print "# Can't open 'channels': $!\n";
		return;
	}
	while (<CHAN>) { chomp; $channels{$_} = 1; }
	close CHAN;
}

sub on_invite {
	my ($self, $event) = @_;
	my ($arg, $from) = ($event->args, $event->from);

	print "~ Invited to $arg by $from\n";
	read_channels;
	if (defined($channels{$arg})) {
		print "# Joining $arg\n";
		$self->join("$arg");
	}
}

sub on_kick {
	my ($self, $event) = @_;
	my ($channel, $reason) = $event->args;
	my ($who) = $event->to;
	my ($from) = $event->from;

	print "~ $who kicked from $channel by $from ($reason)\n";
}

$conn->add_handler ('376', \&on_connect);
$conn->add_handler ('msg', \&on_msg);
$conn->add_handler ('notice', \&on_notice);
$conn->add_handler ('caction', \&on_action);
$conn->add_handler ('public', \&on_public);
$conn->add_handler ('invite', \&on_invite);
$conn->add_handler ('kick', \&on_kick);
$| = 1;
$irc->start;