#!/usr/local/bin/perl
##
## nhirc.pl
##
## Nethack-inspired fairly-modular very-customizable thoroughly-silly
## IRC client.
##
## This file is part of NetHirc.  (c) 1998-1999 Tony Monroe.
##

push @rcs_id, q$Id: nhirc.pl,v 1.23 1999/08/26 19:25:39 tony Exp $;
$rcs_date = q$Date: 1999/08/26 19:25:39 $;

##
## Log?  What log?
##

## use strict;	## You're getting to be a real pain in the arse.  You and -w.
use IO::File;
use IO::Handle;
use File::Basename;
use Net::IRC;
use Getopt::Std;
use POSIX qw(strftime ttyname);
use Config;

use constant DUMMY => "brk brk brk!";
use constant L_NORMAL => 0;
use constant L_CONFIRM => 1;
use constant L_PROMPT => 2;

%defaults = ();
%opts = ();
%formats = ();
%stuff = ();
@complaints = ();
%commands = ();
@disasters = ();
%channel_mode_comments = ();
%self_mode_comments = ();
@classes = ();
@scrolls = ();
@deities = ();
@supported_ctcp = ();
%reload_map = ();
%command_map = ();
%handler_map = ();

@whoami = getpwuid($<);
($realname = $whoami[6]) =~ s/,.*//;
$myhome = $whoami[7];
$proghome = $myhome;
$default_nhirclib_path = "/usr/local/share/nethirc";
$libpath = $ENV{NHIRCLIB} || $default_nhirclib_path;
$progname = basename($0);
$osname = $Config{'archname'};
$version = $rcs_id;
&set_line_state(L_NORMAL);
$confirm_positive = "";
$confirm_proceed = [];	## coderef, args
$prompt_proceed = []; 	## coderef, args

$| = 1;

%defaults = ( 'server' => 'irc.home.com',
	      'port' => 6667,
	      'nickname' => $whoami[0],
	      'userfake' => $whoami[0],
	      'ircname' => $realname 
);

%opts = (
    'i'		=>	$defaults{'ircname'},
    'n'		=>	$defaults{'nickname'},
    'p'		=>	$defaults{'port'},
    's'		=>	$defaults{'server'},
    'u'		=>	$defaults{'userfake'},
);

@line_dispatch = ( \&line_normal, \&line_confirm, \&line_prompt );

getopts('s:p:i:n:u:c:h:dl', \%opts);	## Eat your leafy greens!

%reload_map = (
    'all'		=>	[ 'ctcp', 'formats', 'commands', 'handlers', 'helpers' ],
    'baseformats'	=>	\&load_baseformats,
    'ccode'		=>	\&load_ccode,
    'channel_mode'	=>	\&load_channel_mode,
    'classes'		=>	\&load_classes,
    'cmap'		=>	\&load_cmap,
    'commands'		=>	[ 'ccode', 'cmap', ],
    'complaints'	=>	\&load_complaints,
    'ctcp'		=>	\&load_ctcp,
    'deities'		=>	\&load_deities,
    'disasters'		=>	\&load_disasters,
    'handlers'		=>	[ 'hcode', 'hmap' ],
    'hcode'		=>	\&load_hcode,
    'helpers'		=>	\&load_helpers,
    'hmap'		=>	\&load_hmap,
    'formats'		=>	[ 'complaints', 'disasters', 'self_mode', 'channel_mode', 'baseformats', 'classes', 'scrolls', 'deities', 'monsters' ],
    'monsters'		=>	\&load_monsters,
    'scrolls'		=>	\&load_scrolls,
    'self_mode'		=>	\&load_self_mode,
);

$irc = new Net::IRC;
$irc->debug(1) if $opts{'d'};
$userfake = $opts{'u'};

print "***** Connecting to ", $opts{'s'}, ":", $opts{'p'}, " *****\n";

$conn = $irc->newconn( Nick => $opts{'n'},
		       Server => $opts{'s'},
		       Port => $opts{'p'},
		       Ircname => $opts{'i'},
		       Username => $opts{'u'},
		       LocalAddr => $opts{'h'},
		       Verbose => 1
);

$stuff{'conn'} = $conn;	## Okay, a bit of a hack...

&do_reload($conn, 'reload', 'all');

%stuff = (
    cmd_char		=>	'/',
    chanlist		=>	[ ],
    defchannel		=>	undef,
    echo		=>	1,
    deity		=>	&pickrandom(@deities),
    class		=>	&pickrandom(@classes),
    firstconnect	=>	1,
    conn		=>	$conn,
    oldlist		=>	[ ],
    log			=>	undef,
    logname		=> 	undef,
);

$commands{'reload'} = \&do_reload;	## In this file, not elsewhere...
$commands{'source'} = \&do_source;

$formats{'tickle'} = &pickrandom(@disasters);

if ($opts{'c'}) {
    my @cl = split(/,/, $opts{'c'});
    push(@{$stuff{'oldlist'}}, @cl);
}

if ($opts{'l'}) {
    &do_log($stuff{'conn'}, 'log', 'on');
}

for my $s (qw(INT HUP QUIT TERM)) {
    $SIG{$s} = \&oh_no_a_signal unless $irc->debug;
}

$stuff{'stdin'} = bless \*STDIN, 'IO::Handle';	## Can we cheap this?
$stuff{'stdin'}->autoflush(1);
$irc->addfh($stuff{'stdin'}, \&gimme_line, "r");

@nhircrcs = ("$myhome/.nhircrc", map { "$_/nhircrc" } split(/:/, $libpath));

for my $i (@nhircrcs) {
    if (-f $i) {
	&do_source($conn, 'source', $i);
    }
}


$irc->start;

####################################################
## Beware!  Subroutines abound beyond this point! ##
####################################################

sub saytoer {
## It's another one of these "Joy of Lambda" subs.
    my ($conn, $destination, $fh, $filename) = @_;
    return sub {
    ## Takes the given text and writes it to the destination 
    ## (person or channel) with Net::IRC::Connection::privmsg().
	my $line;
	if ($fh->eof) {
	    $irc->removefh($fh);
	    $conn->print(&ircformat('pipeclosed', $filename, $destination));
	    $fh->close;
	    return;
	}
	$line = $fh->getline;
	chomp $line;
	$conn->privmsg($destination, $line);
	if ($destination =~ /^[#&]/) {
	    $conn->print(&ircformat('public', $conn->nick, $line));
	} else {
	    $conn->print(&ircformat('priv_to', $destination, $line));
	}
    };
}

sub filesucker {
## It's another one of these "Joy of Lambda" subs.
    my ($conn, $fh, $filename) = @_;
    return sub {
    ## Takes a line from the given file and executes it, sorta.
	if ($fh->eof) {
	    $conn->print(&ircformat('sourcedone', $filename));
	    $irc->removefh($fh);
	    $fh->close;
	    return;
	}
	$line = $fh->getline;
	chomp $line;
	$x = $stuff{'cmd_char'};
	$line =~ s/^\s+//;
	$line =~ s/^#.*//; 	## Let's be a bit restrictive with comments.
	return if ($line =~ /^\s*$/);
	$line =~ s/^$x+//;
	$line =~ s/\$NICK/$conn->nick()/eg;	## Could be useful.
	($firstword, $rest) = split(' ', $line, 2);
	$command = $commands{$firstword};
	if (not $command) {
	    $conn->print(&ircformat('Enocmdsrc', $firstword, $fh->input_line_number, $filename));
	    return;
	}
	$command->($conn, $firstword, $rest);
    };
}

sub pickrandom { $_[int rand @_] }

sub gimme_line {
    my $fh = shift;
    my $line;
    if ($fh->eof) {
	&bail("You destroy the " . ttyname($fh->fileno) . "!");
    } 
    until ($line !~ /^\s*$/) {
	$line = $fh->getline;
    }
    &figure_line($line);
}

sub figure_line {
##
## The input state has to be global.  Oh well, such is life in 
## a finite state machine.
##
    my $line = shift;
    $line_dispatch[$line_state]->($line);
}

sub line_normal {
    my $line = shift;
    my ($firstword, $rest, $x, $command);
    $x = $stuff{'cmd_char'};
    my $conn = $stuff{'conn'};
    if ($line =~ /^$x$x+/) {
        $line =~ s/^$x//;
        &do_say($conn, 'say', $line);
	&set_line_state(L_NORMAL);
    } elsif ($line =~ /^$x/) {
        $line =~ s/^$x//;
        ($firstword, $rest) = ($line =~ /^(\S+)\s+(.*)$/);
        $command = $commands{$firstword};
        if (not $command) {
            if ($stuff{'happyslash'} == 1) {
		$conn->print(&ircformat('happyslash'));
                &do_say($conn, 'say', "$x$line");
            } else {
		$conn->print(&ircformat('Enocmd', $firstword));
            }
	    &set_line_state(L_NORMAL);
        } else {
            $command->($conn, $firstword, $rest);
	    ## Do NOT clobber line state here!
        }
    } elsif ($line =~ /^\s*$/) {
        &complain;
	&set_line_state(L_NORMAL);
    } else {
        &do_say($conn, 'say', $line);
	&set_line_state(L_NORMAL);
    }
}

sub line_confirm {
    my $line = shift;
    my ($coderef, $x);
    $x = $stuff{'cmd_char'};
    my $conn = $stuff{'conn'};
    if ($line =~ /^$x$x+/) {	## I see you have refused my offer.
	$conn->print(&ircformat('Crefused'));
	return &line_normal($line);
    } elsif ($line =~ /^$confirm_positive/) {
	$conn->print(&ircformat('Caccepted'));
	$coderef = shift @$confirm_proceed;
	$coderef->(@$confirm_proceed);
    } else {
	$conn->print(&ircformat('Crefused'));
    }
    &set_line_state(L_NORMAL);
}

sub line_prompt {
    my $line = shift;
    my $coderef;
    $coderef = shift @$prompt_proceed;
    $coderef->($line, @$prompt_proceed);
    &set_line_state(L_NORMAL);
}

sub modesplitter {
    my $r_modelist = shift;
    my $modestring = shift;
    my @targets = @_;
    my ($parity, $modechar);
    ## Why this way?
    $modestring = reverse $modestring;
    ## Because it's silly and wrong.  Besides, splitting on // is dull. :-)
    while ($modechar = chop($modestring)) {
	if (($modechar eq '+') || ($modechar eq '-')) {
	    $parity = $modechar;
	} else {
	    if ($modechar =~ /[bov]/) {
		push(@$r_modelist, [ $parity . $modechar, shift(@targets) ]);
	    } elsif ($modechar =~ /[kl]/) {
		if ($parity eq '+') {
		    push(@$r_modelist, [ $parity . $modechar, shift(@targets) ]);
		} else {
		    push(@$r_modelist, [ $parity . $modechar ]);
		}
	    } else {
		push(@$r_modelist, [ $parity . $modechar ]);
	    }
	}
    }
}

sub set_channel {
    my ($channel, $status) = @_;
    my $conn = $stuff{'conn'};
    unless (grep { lc($_) eq lc($channel) } @{$stuff{'chanlist'}}) {
	&admin_print($conn, "You see no $channel here.");
	return;
    }
    until (lc($stuff{'chanlist'}->[0]) eq lc($channel)) {
	## Mmm, cheap rotation!
	unshift(@{$stuff{'chanlist'}}, pop(@{$stuff{'chanlist'}}));
    }
    $stuff{'defchannel'} = $stuff{'chanlist'}->[0];
    { 	## Sometimes, you just want 'em to shut up.
	local $^W; 
      	if ($status ne "new") {
	    &admin_print($conn, "You spin and face " . $stuff{'defchannel'} . ".");
	}
    }
}

sub firstword {
    my $line = shift;
    return split(/\s+/, $line, 2);
}

sub confirm {
    my ($question, $response, $proceed) = @_;
    $confirm_positive = $response;
    $confirm_proceed = $proceed;
    print $question, "\n";
    &set_line_state(L_CONFIRM);
}

sub prompt {
    my ($question, $proceed) = @_;
    $prompt_proceed = $proceed;
    print $question, "\n";
    &set_line_state(L_PROMPT);
}

sub set_line_state {
    my $newstate = shift;
    $line_state = $newstate;
}

sub admin_print {
    my $conn = shift;
    $conn->print(&ircformat('admin', @_));
}

sub server_print {
    my $conn = shift;
    my $t = &ircformat('server', @_);
    $conn->print($t);
    if ($stuff{'log'}) { $stuff{'log'}->print(time() . " $t\n"); }
}

sub complain {
    my $conn = shift;
    $conn->print(&ircformat('complaint', &pickrandom(@complaints)));
}

sub bail {
    my $message = shift;
    $message = "You escaped the dungeon." unless $message;
    $global_quit_message_hack = $message;
    $conn->quit($message);
    exit(0);
}

sub ircformat {
    my $format = shift;
    if ((not defined $format) || ($format eq '')) {
	return;
    }
    my $orig = "";
    if (exists $formats{$format}) {
	$orig = $formats{$format};
    } else {
	$orig = $format;
    }
    my $work = $orig;
    my $new = "";
    my $type = "";
    while ($work ne "") {
	$work =~ s/([^%]*)//;
	$new .= $1;
	if (substr($work, 0, 1) eq '%') {
	    $type = substr($work, 1, 1);
	    if ($type eq '%') {
		$new .= $type;
	    } elsif ($type eq 'X') {
		$new .= shift;
	    } elsif ($type eq 'D') {
		shift;
	    } else {
		$new .= substr($work, 0, 2);
	    }
	    $work =~ s/^..//;
	} else {
	    last;
	}
    }
    return $new;
}

sub timeformat {
    my ($now) = @_;
    return strftime($formats{'time'}, localtime($now));
}

sub add_channel {
    my $channel = shift;
    my $conn = $stuff{'conn'};
    if (grep { $_ eq $channel } @{$stuff{'chanlist'}}) {
	&admin_print($conn, "You try to exit $channel, but you enter again from the opposite side!");
	return;
    }
    push(@{$stuff{'chanlist'}}, $channel);
    &admin_print($conn, "\"Hello, " . $conn->nick . ", welcome to $channel!\"");
}

sub get_boolean {
    my $stuff = shift;
    if ($stuff =~ /^(?:y|on|1|#?t)/i) { ## Let's be friendly.
	return 1;
    } elsif ($stuff =~ /^(?:n|off|0|#?f|nil|undef)/i) { ## Let's be friendlier.
	return 0;
    }
    ## And if it's garbage...
    return 0;
}

sub print_boolean {
    my ($var, $which) = @_;
    my @yn = split(/\//, $which);
    return $yn[$var];
}

sub setup_commands {
    my $conn = shift;
    my ($k, $v);
    for $k (keys %command_map) {
	if ((not defined $command_map{$k}) or ($command_map{$k} eq '')) {
	    $v = $k;
	} else {
	    $v = $command_map{$k};
	}
	eval "\$commands{'$k'} = \\&do_$v;";
	if ($@) {
	    print "## Could not add '$v' sub for '$k' command: $@\n";
	    $command_map{$k} = \&do_nothing;
	}
    }
}

sub setup_conn {
    my ($conn, $map) = @_;
    my ($k, $v);
    for $k (keys %$map) {
	if ((not defined $map->{$k}) or ($map->{$k} eq '')) {
	    $v = $k;
	} else {
	    $v = $map->{$k};
	}
	eval "\$conn->add_handler('$k', \\&on_$v);";
	if ($@) {
	    print "## Could not add '$v' handler for '$k' event: $@\n";
	    $conn->add_handler($k, \&on_unknown);
	}
    }
}

sub array_slurp {
    my ($aref, $f, $path) = @_;
    for my $p (split(/:/, $path)) {
	if (open(F, "$p/$f")) {
	    @$aref = <F>;
	    chomp @$aref;
	    last;
	} else {
	    print "Could not open $p/$f: $!\n";
	}
    }
    die "No suitable $f files found in the path!" unless (@$aref);
}

sub hash_slurp {
##
## We'll do this stacked so you only have to change the ones you want
## to change.  We need the defaults late in the path, otherwise things
## will suck horribly.
##
    my ($href, $f, $path) = @_;
    my ($l, $k, $v);
    for my $p (split(/:/, $path)) {
	if (open(F, "$p/$f")) {
	    while ($l = <F>) {
		chomp $l;
		($k, $v) = split(' ', $l, 2);
		$href->{$k} = $v unless (exists $href->{$k});
	    }
	    close F;
	} else {
	    print "Could not open $p/$f: $!\n";
	}
    }
    ## So we'll measure this, hm?
    die "No suitable $f files found in the path!" unless (%$href); 
}

sub do_source {
    my ($conn, $first, $rest) = @_;
    my $line;
    my $fh = new IO::File;
    unless ($fh->open($rest)) {
	$conn->print(&ircformat('Esource', $!));
	return;
    } 
    $conn->print(&ircformat('sourcestart', $rest));
    $irc->addfh($fh, &filesucker($conn, $fh, $rest), "r");
}

sub do_reload {
    my ($conn, $first, $rest) = @_;
    if ($rest =~ /^\s*$/) {
	print "## Okay!  I'll reload nothing then!\n";
	return;
    }
    if (exists $reload_map{$rest}) {
	if (ref($reload_map{$rest}) eq 'CODE') {
	    $reload_map{$rest}->($conn);
	} elsif (ref($reload_map{$rest}) eq 'ARRAY') {
	    ## Infinite recursion is not my problem.
	    for my $k (@{$reload_map{$rest}}) {
		&do_reload($conn, 'reload', $k);
	    }
	} else {
	    print "## Um, what is this garbage related to $rest?\n";
	}
    } else {
	print "## What?  I don't know how to reload $rest!\n";
    }
}

sub load_baseformats {
    print "## Assembling formats.\n";
    %formats = ();
    &hash_slurp(\%formats, "formats", $libpath);
}

sub load_ccode { 
    my $x;
    print "## Issuing commands.\n";
    for my $p (split(/:/, $libpath)) {
	if (-f "$p/commands.pl") {
	   $x = do "$p/commands.pl";
	   print "Couldn't slurp up $p/commands.pl: $@\n" if $@;
	   print "Couldn't slurp up $p/commands.pl: $!\n" unless defined $x;
	   print "Couldn't slurp up $p/commands.pl!\n" unless $x;
	}
    }
}

sub load_channel_mode {
    print "## Nailing down channel modes.\n";
    %channel_mode_comments = ();
    &hash_slurp(\%channel_mode_comments, "channel_mode", $libpath);
}

sub load_classes { 
    print "## Gathering classes.\n";
    @classes = ();
    &array_slurp(\@classes, "classes", $libpath);
}

sub load_cmap { 
    print "## Obfuscating command map.\n";
    %command_map = ();
    &hash_slurp(\%command_map, "commands", $libpath);
    &setup_commands;
}

sub load_complaints { 
    print "## Drafting complaints.\n";
    @complaints = ();
    &array_slurp(\@complaints, "complaints", $libpath);
}

sub load_ctcp { 
    print "## Conjuring CTCP demons.\n";
    @supported_ctcp = ();
    &array_slurp(\@supported_ctcp, "ctcp", $libpath);
    $supported_ctcp = join(' ', @supported_ctcp);
}

sub load_deities { 
    print "## Summoning deities.\n";
    @deities = ();
    &array_slurp(\@deities, "deities", $libpath);
}

sub load_disasters { 
    print "## Engineering disasters.\n";
    @disasters = ();
    &array_slurp(\@disasters, "disasters", $libpath);
}

sub load_hcode { 
    my $x;
    print "## Hoarding handlers.\n";
    for my $p (split(/:/, $libpath)) {
	if (-f "$p/handlers.pl") {
	    $x = do "$p/handlers.pl";
	    print "Couldn't slurp up $p/handlers.pl: $@\n" if $@;
	    print "Couldn't slurp up $p/handlers.pl: $!\n" unless defined $x;
	    print "Couldn't slurp up $p/handlers.pl!\n" unless $x;
	}
    }
}

sub load_helpers {
    my $x;
    print "## Recruiting helpers.\n";
    for my $p (split(/:/, $libpath)) {
	if (-f "$p/helpers.pl") {
	    $x = do "$p/helpers.pl";
	    print "Couldn't read $p/helpers.pl: $@\n" if $@;
	    print "Couldn't read $p/helpers.pl: $!\n" unless defined $x;
	    print "Couldn't read $p/helpers.pl!\n" unless $x;
	}
    }
}

sub load_hmap { 
    my $conn = shift;
    print "## Drawing handler map.\n";
    %handler_map = ();
    &hash_slurp(\%handler_map, "handlers", $libpath);
    &setup_conn($conn, \%handler_map);
}

sub load_monsters {
    print "## Creating monsters.\n";
    @monsters = ();
    &array_slurp(\@monsters, "monsters", $libpath);
}

sub load_scrolls { 
    print "## Writing scrolls.\n";
    @scrolls = ();
    &array_slurp(\@scrolls, "scrolls", $libpath);
}

sub load_self_mode { 
    print "## Pondering self-deprecatory remarks.\n";
    %self_mode_comments = ();
    &hash_slurp(\%self_mode_comments, "self_mode", $libpath);
}

sub oh_no_a_signal {
    my $sig = shift;
    &bail(&ircformat('signal', $sig));
}

sub log_n_print { 
    my $self = shift;
    map {
	$self->print($_);  
	if ($stuff{'log'}) { $stuff{'log'}->print(time() . " $_\n"); }
    } @_;
}
