############################################################################
# extensible, enterprise semantic modulator .... ok, a word-kicker.        #
# author: cj_ <cjones@gruntle.org>                                         #
#                                                                          #
# - put this in your ~/.irssi/scripts directory                            #
# - type /run bwk                                                          #
# - type /bwk help                                                         #
#                                                                          #
############################################################################
#   This program is free software; you can redistribute it and/or modify   #
#   it under the terms of the GNU General Public License as published by   #
#   the Free Software Foundation; version 2 dated June, 1991.              #
#                                                                          #
#   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.                           #
#                                                                          #
#   You should have received a copy of the GNU General Public License      #
#   along with this program; if not, write to the Free Software            #
#   Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA              #
#   02111-1307, USA.                                                       #
############################################################################

use strict;
use vars qw($VERSION %IRSSI $SPLASH);
use Data::Dumper;
use Irssi;

$VERSION = "1.3";
%IRSSI = (
	author		=> 'cj_',
	contact		=> 'cjones@gruntle.org',
	download	=> 'http://gruntle.org/projects/irssi',
	name		=> 'bwk',
	description	=> 'kick people for using bad words',
	license		=> 'GPL',
	changed		=> 'Sat Sep  6 16:53:00 PDT 2003',
	version		=> $VERSION,
);
$SPLASH = "$IRSSI{name} $IRSSI{version} by $IRSSI{author} <$IRSSI{contact}>";

sub bwk {
	my $text = shift;
	my @args = shellwords($text);

	# which command was invoked?
	my $cmd = shift(@args);
	if    ($cmd =~ /^list/io)   { list_words()    }
	elsif ($cmd =~ /^add/io )   { add_word(@args) }
	elsif ($cmd =~ /^del/io )   { del_word(@args) }
	elsif ($cmd =~ /^cl/io  )   { clear_words()   }
	elsif ($cmd =~ /^help/io)   { show_help()     }
	elsif ($cmd =~ /^update/io) { update()        }
	elsif ($cmd =~ /^stats/io)  { show_stats()    }
	else                        { display_error() }
}

sub clear_words {
	Irssi::settings_set_str("bwk_data", undef);
	Irssi::print("banwords cleared");
}

sub add_word {
	my @args = @_;

	##############
	# parse args #
	##############
	
	# channel
	my $chan = shift(@args);
	my @chan_args = split(/\s*,\s*/, $chan);
	my @chans;
	foreach my $chan_arg (@chan_args) {
		if ($chan_arg eq '*') { @chans = ($chan_arg); last }
		if ($chan_arg =~ /^#.+/) { push(@chans, $chan_arg) }
		else { Irssi::print("invalid: $chan_arg") }
	}
	$chan = join(",", @chans);

	# action
	my $action = shift(@args);
	unless ($action =~ /^(?:kill|kick|ban)$/i) {
		Irssi::print("action must be one of kill, kick or ban");
		return;
	}

	# pattern to match
	my $pattern;
	my $word = shift(@args);
	if (!$word) {
		Irssi::print("you must enter a word or regexp");
		return;
	}

	if ($word =~ /^-regexp/i) {
		$pattern = shift(@args);
		unless ($pattern) {
			Irssi::print("empty regexp");
			return;
		}
	} else {
		$pattern = "\\b$word\\b";
	}

	# if we have any args left, check them
	my $exempt;
	my $reason;
	while (my $arg = shift(@args)) {
		if ($arg =~ /^-exempt/i) {
			$exempt = shift(@args);
		} elsif (!$reason) {
			$reason = $arg;
		} else {
			Irssi::print("ignoring extra argument: $arg");
		}
	}

	# load list of banwords and add new one
	my @banwords = load_banwords();
	my $new_banword = {
		chan	=> $chan,
		action	=> $action,
		pattern	=> $pattern,
		exempt	=> $exempt,
		reason	=> $reason,
	};
	push(@banwords, $new_banword);
	save_banwords(@banwords);
	my $str = format_banword($new_banword);
	Irssi::print("bwk added: $str");
}

sub list_words {
	my @banwords = load_banwords();
	if (scalar(@banwords) == 0) {
		Irssi::print("there are no banwords");
		return;
	}

	for (my $i = 0; $i < scalar(@banwords); $i++) {
		my $obj = $banwords[$i];
		my $str = format_banword($obj);
		$str = ($i + 1) . ". $str";
		Irssi::print($str);
	}
}

sub show_stats {
	my $stats = load_stats();
	my $show_header = 1;
	foreach my $key (sort { $stats->{$b} <=> $stats->{$a} } keys %$stats) {
		if ($show_header) {
			Irssi::print("bwk stats (# - pattern)");
			$show_header = 0;
		}
		my $line = sprintf('%3d - \'%s\'', $stats->{$key}, $key);
		Irssi::print($line);
	}
}

sub format_banword {
	my $obj = shift;
	my $chan = $obj->{chan};
	my $action = $obj->{action};
	my $pattern = $obj->{pattern};
	my $exempt = $obj->{exempt};
	my $reason = $obj->{reason};

	$chan = "all" if $chan eq '*';

	my @str;
	push(@str, "$chan: $action on '$pattern'");
	push(@str, "exempt: $exempt") if $exempt;
	push(@str, "reason: $reason") if $reason;

	my $str = join(". ", @str);
	return $str;
}

sub del_word {
	my @args = @_;
	my $arg = shift(@args);
	unless ($arg =~ /^\d+$/) {
		Irssi::print("enter a number to delete (try list first)");
		return;
	}

	my @banwords = load_banwords();
	if (scalar(@banwords) == 0) {
		Irssi::print("there are none!");
		return;
	}

	if ($arg > scalar(@banwords)) {
		Irssi::print("out of range.  try list first");
		return;
	}

	my $ind = ($arg - 1);
	my ($banword) = splice(@banwords, $ind, 1);
	save_banwords(@banwords);

	my $str = format_banword($banword);
	Irssi::print("deleted: $str");
}

sub show_help { 
	my $help = <<EOH;
/set bwk_active <on|off>
/bwk <cmd>
   add (see below)
   list
   delete #
   clear
   update

   add <chan> <action> <word> [-exempt <nicks>] [reason]
     chan: list of comma-separted channels, or * for all
     action: either kill, kick or ban (ban also kicks)
     word: a trigger word, or -regexp <perl regular expression>
           note that you must escape \\'s, so for \\b, you need
           to write \\\\b.
     exempt: a list of comma separated nicks that are immune
     reason: give this reason when kick/killing.  be sure to
             quote this if it's more than one word
EOH
	Irssi::print(draw_box($SPLASH, $help, undef, 1), MSGLEVEL_CLIENTCRAP);
}

sub draw_box {
	# taken from a busted script distributed with irssi
	# just a simple ascii line-art around help text
	my ($title, $text, $footer, $color) = @_;
	$footer = $title unless($footer);
	my $box;
	$box .= '%R,--[%n%9%U' . $title . '%U%9%R]%n' . "\n";
	foreach my $line (split(/\n/, $text)) {
		$box .= '%R|%n ' . $line . "\n";
	}
	$box .= '%R`--<%n' . $footer . '%R>->%n';
	$box =~ s/%.//g unless $color;
	return $box;
}

sub display_error { Irssi::print("huh?  try /bwk help") }

sub shellwords {
	# parse quoted arguments properly, like a shell would
	# taken from shellwords.pl in perl5.. irssi does not
	# play nice with require op, hence the inclusion
	my $text = join('', @_) if @_;
	my (@words, $snippet, $field);

	$text =~ s/^\s+//;
	while ($text ne '') {
		$field = '';
		for (;;) {
			if ($text =~ s/^"(([^"\\]|\\.)*)"//) {
				($snippet = $1) =~ s#\\(.)#$1#g;
			} elsif ($text =~ /^"/) {
				Irssi::print("Unmatched double quote");
				return;
			} elsif ($text =~ s/^'(([^'\\]|\\.)*)'//) {
				($snippet = $1) =~ s#\\(.)#$1#g;
			} elsif ($text =~ /^'/) {
				Irssi::print("Unmatched single quote");
				return;
			} elsif ($text =~ s/^\\(.)//) {
				$snippet = $1;
			} elsif ($text =~ s/^([^\s\\'"]+)//) {
				$snippet = $1;
			} else {
				$text =~ s/^\s+//;
				last;
			}
			$field .= $snippet;
		}
		push(@words, $field);
	}
	return @words;
}

sub signal_handler_public {
	return unless (Irssi::settings_get_bool("bwk_active"));

	my ($server, $msg, $nick, $host, $chan) = @_;

	# don't attack services
	return if $nick =~ /^(?:global|devnull|(?:nick|chan|oper|memo)serv)$/i;

	# get list of banwords, return if none
	my @banwords = load_banwords();
	return if (scalar(@banwords) == 0);

	# iterate over each
	foreach my $banword (@banwords) {
		my @ban_chans = split(/\s*,\s*/, $banword->{chan});
		my @ban_exempts = split(/\s*,\s*/, $banword->{exempt});
		my $ban_pattern = $banword->{pattern};
		my $ban_action = $banword->{action};
		my $ban_reason = $banword->{reason};

		my $match;

		# check channel
		$match = 0;
		foreach my $ban_chan (@ban_chans) {
			if ($ban_chan eq '*' or $ban_chan =~ /^$chan$/i) {
				$match = 1;
				last;
			}
		}
		next unless $match;

		# check exempts
		$match = 0;
		foreach my $ban_exempt (@ban_exempts) {
			if ($ban_exempt =~ /^$nick$/i) { $match = 1; last }
		}
		next if $match;

		# check message
		my $search_pattern;
		eval "\$search_pattern = qr\'$ban_pattern\'i"; next if $@;

		# prevent CHEATING

		$msg =~ s/\x03\d+(,\d+)?(\26)*//g;

		my $newmsg;
		for (my $i = 0; $i < length($msg); $i++) {
			my $chr = substr($msg, $i, 1);
			my $ord = ord($chr);

			if ($ord >= 32 and $ord <= 126) {
				$newmsg .= $chr;
			}
		}
		$msg = $newmsg;


		next unless ($msg =~ $search_pattern);

		#######################
		# ok, we have a match #
		#######################

		# accounting
		my $stats = load_stats();
		$stats->{$ban_pattern}++;
		save_stats($stats);

		# take action
		if ($ban_action =~ /^kill$/i) {
			# kill user
			return unless ($server->{server_operator});
			Irssi::print("killing $nick for saying \"$ban_pattern\"");
			$server->send_raw("KILL $nick :$ban_reason");
		} elsif ($ban_action =~ /^kick$/i) {
			# just kick the user
			return unless ($server->{usermode} =~ /o/);
			Irssi::print("kicking $nick from $chan for saying \"$ban_pattern\"");
			$server->send_raw("KICK $chan $nick :$ban_reason");
		} elsif ($ban_action =~ /^ban$/i) {
			# ban user & kick
			return unless ($server->{usermode} =~ /o/);
			Irssi::print("kickbaning $nick from $chan for saying \"$ban_pattern\"");
			$server->send_raw("MODE $chan +b $nick!$host");
			$server->send_raw("KICK $chan $nick :$ban_reason");
		}

		# we did something, break the loop
		return;
	}
}

sub update {
	# automatically check for updates
	my $baseURL = $IRSSI{download} . "/" . $IRSSI{name};
	
	# do we have useragent?
	eval "use LWP::UserAgent";
	if ($@) {
		Irssi::print("LWP::UserAgent failed to load: $!");
		return;
	}

	# first see what the latest version is
	my $ua = LWP::UserAgent->new();
	$ua->agent("$IRSSI{name}-$IRSSI{version} updater");
	my $req = HTTP::Request->new(GET => "$baseURL/CURRENT");
	my $res = $ua->request($req);
	if (!$res->is_success()) {
		Irssi::print("Problem contacting the mothership: " . $res->status_line());
		return;
	}

	my $latest_version = $res->content(); chomp $latest_version;
	Irssi::print("Your version is: $VERSION");
	Irssi::print("Current version is: $latest_version");

	if ($VERSION >= $latest_version) {
		Irssi::print("You are up to date");
		return;
	}

	# uh oh, old stuff!  time to update
	Irssi::print("You are out of date, fetching latest");
	$req = HTTP::Request->new(GET => "$baseURL/$IRSSI{name}-$latest_version.pl");

	my $script_dir = Irssi::get_irssi_dir() . "/scripts";
	my $saveTo = "$script_dir/downloaded-$IRSSI{name}.pl";
	$res = $ua->request($req, $saveTo);
	if (!$res->is_success()) {
		Irssi::print("Problem contacting the mothership: " . $res->status_line());
		return;
	}

	# copy to location
	rename($saveTo, "$script_dir/$IRSSI{name}.pl");

	Irssi::print("Updated successfully! '/run $IRSSI{name}' to load");
}

# use data dumper to store hash references in an irssi register

sub load_stats {
	my $str = load_string("bwk_stats");
	return $str;
}

sub save_stats { 
	my $str = shift;
	save_string("bwk_stats", $str);
}

sub save_banwords { 
	my @banwords = @_;
	save_string("bwk_data", \@banwords);
}

sub load_banwords { 
	my $banwords_ref = load_string("bwk_data");
	my @banwords;
	if (defined $banwords_ref) {
		@banwords = @$banwords_ref;
	}

	return @banwords;
}

# data::dumper methods for packing and unpacking data structures
sub load_string {
	my $reg = shift;
	my $str = Irssi::settings_get_str($reg);
	my $dump_str;
	eval($str);
	if ($@) { Irssi::print("problem with $reg format"); return }
	return $dump_str if $dump_str;
}

sub save_string {
	my $reg = shift;
	my $str = shift;
	my $dump = Data::Dumper->new([$str], ['dump_str']);
	$dump->Indent(0);
	$dump->Purity(1);
	my $dump_str = $dump->Dump();
	Irssi::settings_set_str($reg, $dump_str);
}



Irssi::command_bind("bwk", \&bwk);
Irssi::signal_add("message public", \&signal_handler_public);
Irssi::settings_add_str($IRSSI{name}, "bwk_data", undef);
Irssi::settings_add_str($IRSSI{name}, "bwk_stats", undef);
Irssi::settings_add_bool($IRSSI{name}, "bwk_active", 1);

###########
# startup #
###########

Irssi::print($SPLASH);