#!/usr/bin/perl -w
use strict;
use POSIX;
use IO::Socket;
use IPC::Open2;
use IPC::Open3;
use HTTP::Date;
use Fcntl;
use Encode;

my $MYNAME     = "Floyd";
my $MYPASSWORD = "xxx";

my $CHANNEL = "#${MYNAME} ";
my $CHANNEL_EMOTE = "#${MYNAME} :";
my $SPEAK   = "say ";
my $EMOTE   = ":";
my $QUOTE   = ":| ";
my $DOING   = "\@doing ";

my $sock = IO::Socket::INET->new(PeerAddr => 'ifmud.ziz.org',
				 PeerPort => '4000',
				 Proto    => 'tcp');

$sock || die "Unable to connect to ifMUD\n";

my %commandlist = ( hi    => \&hi_sub,
		    quit  => \&quit_sub,
		    recap => \&recap_sub,
		    bye   => \&logout,
		    load  => \&load_sub,
		    list  => \&list_sub,
		    help  => \&help_sub,
		    do    => \&do_sub,
		    home  => \&home_sub,
		    say   => \&say_sub,
		    emote => \&emote_sub,
		    showpartial => \&flush_sub );

my %helplist =    ( hi    => "A greeting.",
		    quit  => "Immediately quits the current game being played.",
		    recap => "Redisplays previous text.  If given a numeric argument, displays that much text.",
		    bye   => "Makes $MYNAME leave the mud.",
		    load  => "Loads and starts a game.",
		    list  => "Lists games available.  If followed by a letter range (e.g. 'list a-f'), displays games whose titles begin those letters.  If given a category (one of: adventure, comedy, scifi, horror, fantasy, puzzle, romantic, mystery, children, abuse, realworld, college, historical, adult, superhero, western), displays games which have been put in that category.  'list unsorted' shows games not yet put in a category.  'list new' shows games dated within the last month.  'list saves' shows saved games available.",
		    help  => "Shows help on a topic.",
		    do    => "Make $MYNAME perform some action.  You can give multiple commands by separating them with periods.",
		    home  => "Make $MYNAME go home.",
		    say   => "Make $MYNAME say something.",
		    showpartial   => "Make $MYNAME show any partial line not yet printed.",
		    emote => "Make $MYNAME emote something." );

my %synonyms = ( hello => "hi",
		 hey   => "hi",
		 hiya  => "hi",
		 go    => "do" );

my $gamemode = "single";
my $speakmode = "quote";
my $speakmodeto = "";
my $mode = 0;
my $child_pid = 0;
my $child_rdr = NULL;
my $child_wtr;
my $child_err;

my @recap_buffer;


my $rin = "";

dont_block($sock);

vec($rin, fileno($sock), 1) = 1;

my $sock_buf = "";
my $child_buf = "";
my $flush_buf = "";
my $child_err_buf = "";

my $line_start = $QUOTE;

sub start
{
    select STDOUT; $| = 1;

    log_status("start");

    $SIG{'INT'} = \&sig_handler;
    $SIG{'QUIT'} = \&sig_handler;

    login();
    main();
    logout("..ifMUD", "", "ifMUD");
}


sub sig_handler
{
    my($sig) = @_;
    logout("..SIG$sig", "", "SIG$sig")
}
 
sub log_status
{
    print @_, "\n";
}

sub log_error
{
    print "[ERROR (" . time2str(time()) . "): ", @_, "]\n";
}

sub list_files
{
    my @dirs = @_;
    my @files = ();
    foreach my $dir (@dirs) {
	opendir(DIR, $dir) || return;
	push @files, grep(!/^\./, readdir(DIR));
	closedir DIR;
    }
    return @files;
}

sub gamewrite
{
    my ($message, $name) = @_;
    if($gamemode eq "multi") {
	$message = $name . ", " . $message;
    }
    $message = encode("iso-8859-1", $message);
    syswrite(*WTR, $message . "\n", mength($_));
}

sub mudwrite
{
    $_ = encode("iso-8859-1", $_[0] . $_[1] . "\n");
    syswrite($sock, $_, mength($_));
    log_status "{", $_[0] . $_[1], "}";
}

{
my $outstate = 0;
my $wrap_length = 72;
my $return_count = 0;

sub mudquote
{
    my ($message) = @_;
    my $len;

    if($gamemode eq "multi") {
	my @pieces = split(/<.*?>/, $message, 2);
	if($#pieces == 1) {
	    if(mength($pieces[0])) {
		mudquote($pieces[0]);
	    }
	    $message =~ /<(.*?)>/;
	    my $t = $1;
	    my @tag = split(/\s+/, $t);

	    if(mength(@tag)) {
		if($tag[0] eq "whisper")     { $outstate |= 1; }
		elsif($tag[0] eq "/whisper") { $outstate &= ~1; }
		elsif($tag[0] eq "emote")    { $outstate |= 2; }
		elsif($tag[0] eq "/emote")   { $outstate &= ~2; }

		shift @tag;

		if($outstate == 0) {
		    $wrap_length = 79 - 8;  # Floyd | ...
		    $line_start = $QUOTE;
		} elsif($outstate == 1) {
		    $wrap_length = 79 - 18; # Floyd whispers, "..."
		    $line_start = "whisper " . join(", ", @tag) . "=";
		} elsif($outstate == 2) {
		    $wrap_length = 79 - 6;  # Floyd ...
		    $line_start = $EMOTE;
		} elsif($outstate == 3) {
		    $wrap_length = 79 - 30; # Floyd privately poses to you: ...
		    $line_start = "whisper " . join(", ", @tag) . "=:";
		}
	    }
	    
	    if(mength($pieces[1])) {
		mudquote($pieces[1]);
	    }
	    return;
	}
    }

    if(mength($message) == 0) {
	if($return_count < 8) {
	    mudwrite($line_start, "");
	    $return_count++;
	}
    } else {
	$return_count = 0;
    }

    while(($len = mength($message)) != 0) {
	my $last_break = $len;

	if($len >= $wrap_length) {
	    $len = $wrap_length-1;

	    $last_break = $len;
	    
	    foreach my $x (0..($len)) {
		if(substr($message, $x, 1) =~ /[ \n]/) {
		    $last_break = $x+1;
		}
	    }
	}

	mudwrite($line_start, substr($message, 0, $last_break));
	$message = substr($message, $last_break);
	$message =~ s/^\s*//;
    }
}
}

sub dont_block
{
        my $socket = shift;

        # The following line should be uncommented under UNIX systems.
        fcntl( $socket, F_SETFL, O_NONBLOCK );

        # The following line should be uncommented under Win32 systems.
        #ioctl( $socket, FIOSLEEPTW, 0 );
}


sub buffered_read
{
    my($fd, $buf, $please_die) = @_;

    $_ = decode("iso-8859-1", sysread($fd, $$buf, 4096, mength($$buf)));
    
    if(defined($_) && $_ == 0) {
	if(length($$buf) == 0) {
	    $please_die && die "Read returns 0";
	}
    }

    $$buf =~ s/\r\n/\n/;
    
    my @commands = split(/\n/, $$buf, 2);

    if ($child_rdr && $fd ~~ $child_rdr) {
	$flush_buf = "";
    }
    if($#commands == 1) {
	$$buf = $commands[1];
	return $commands[0];
    }

    if (defined($$buf) && defined($commands[0])) {
    if ($child_rdr && $fd ~~ $child_rdr) {
		$flush_buf = $commands[0];
	}
	log_error("Read data, but not a whole line: " . $commands[0]);
    }

    return undef;
}

sub mudlog
{
    $_ = $_[0];
    return if /^[^ =]+ whispers, \".*\"$/;
    return if /^[^ =]+ pages: /;
    return if /^\[.*?\] /;
    return if /^You paged [^ =]+: /;
    return if /^You whisper \"/;
    return if /^Pollboy hollers/;

    s/^${MYNAME} \|(.*)$/\|$1/;

    if($#recap_buffer > 500) {
	pop @recap_buffer;
    }
    unshift @recap_buffer, $_;
}


sub mudlisten
{
    my ($rout);
    my $rc = 0;
    my $ic = 0;

    do {
	if(!defined($sock)) {
	    die "Socket closed.";
	}
	if($child_pid) {
	    while(defined($_ = buffered_read($child_rdr, \$child_buf, 0))) {
		if (/Glk library error/) { log_error($_); }
		elsif (/\[FLOYD.*\]/) { log_status($_); }
		else { mudquote($_); }
#		unless (/Glk library error/) { mudquote($_); }
#		mudquote($_);
	    }
	}
        if($child_pid) {
            while(defined($_ = buffered_read($child_err, \$child_err_buf, 0))) {
               log_error($_);
            }
        }

	if($child_pid && waitpid(-1, &WNOHANG) == $child_pid) {
	    if (WIFEXITED($?)) {
		log_status "(child dying [exitstatus: " . WEXITSTATUS($?) . "])";
	    } elsif (WIFSIGNALED($?)) {
		log_status "(child dying [termsig: " . WTERMSIG($?) . "])";
	    }  elsif (WIFSTOPPED($?)) {
		log_status "(child dying [stopsig: " . WSTOPSIG($?) . "])";
	    } else {
		log_status "(child dying [not exit, term, or stop])";
	    }
	    mudwrite($SPEAK, "That game over already?  It was just getting good.  Wanna play another?");
	    end_game();
	}
	
	if(defined($_ = buffered_read($sock, \$sock_buf, 1))) {
	    log_status  $_;
	    chomp;
	    mudlog($_);
	    return $_;
	}

	log_status "select()";
    } while(select($rout = $rin, undef, undef, undef) != -1);

    die "select failed: $!\n";
}

sub get_directed
{
    my $input;
    my ($name, $message);
    while($input = mudlisten()) {
	my $prefix="";
	my $mprefix="";

	if($input =~ /^([^ =]+) whispers, \"(.*)\"$/) {
	    $name = $1; $message = $2;
	    return ("whisper $name=", $name, $message);
	}
	if($input =~ /^([^ =]+) pages: (.*)$/) {
	    $name = $1; $message = $2;
	    return ("page $name=", $name, "%" . $message);
	}

	if($input =~ /^\[(.*?)\] (.*)$/) {
	    $input = $2;
	    $prefix = "#" . "$1" . " ";
	    $mprefix = "%";
	}

	if($input =~ /^([^ =]+) (says|asks|exclaims) \((of|to|at) ${MYNAME}\), \"(.*)\"$/i) {
	    $name = $1; $message = $4;
	    return ("${prefix}..$name ", $name, $mprefix . $message);
	}
    }
}

sub login
{
    while(mudlisten() ne "TYPE connect, who, or quit:") {
	;
    }
    mudwrite("", "connect $MYNAME $MYPASSWORD");
    mudwrite($CHANNEL_EMOTE, "here now!");
    mudwrite($DOING, "Waiting for someone to play with me");
}

sub logout
{
    my ($respond, $message, $name) = @_;
    mudwrite("..$name ", "Buh-Bye!");
    mudwrite($CHANNEL_EMOTE, "has disconnected from ifMUD.");
    mudwrite("", "quit");
    gamewrite("save", "");
    gamewrite("shutdown", "");
    $sock->flush;
    $sock->close;
    exit(0);
}

sub mength
{
    my $str = $_[0];
    if(defined $str) {
	return length($str);
    }
    return 0;
}


sub main
{
    my ($respond, $name, $message);

    my $command_time = 0;
    my $command_count = 0;

    while(($respond, $name, $message) = get_directed()) {
	if($mode == 0 || (mength($message) && substr($message, 0, 1) eq "%")) {
	    if(mength($message) && substr($message, 0, 1) eq "%") {
		$message = substr($message, 1);
	    }
	    if(mength($message) && $message =~ /^(\S+?)[.!?]*( (.*))?$/) {
		my $command = lc $1;

		if($synonyms{$command}) {
		    $command = $synonyms{$command};
		}

		if($commandlist{$command}) {

		    if(time() <= $command_time + 5) {
			$command_count++;
			if($command_count > 10) {
			    mudwrite($respond, "$MYNAME is dancing too fast already!  Slow down.");
			    next;
			}
		    } else {
			$command_time = time();
			$command_count = 0;
		    }

		    $commandlist{$command}->($respond, $3, $name);
		} else {
		    mudwrite($respond, "$MYNAME doesn't know that trick.");
		}
	    }
	} else {
	    if($respond =~ /^whisper /) {
		$name = " " . $name;
	    }
	    gamewrite($message, $name);
	}
    }
}




sub hi_sub
{
    my ($respond, $message) = @_;
    mudwrite($respond, "Hi!");
}

sub end_game
{
    vec($rin, fileno($child_rdr), 1) = 0;
    $child_pid = 0;
    vec($rin, fileno($child_err), 1) = 0;
    $child_err = 0;
    $mode = 0;

    $gamemode = "single";

#    $outstate = 0;
#    $wrap_length = 71;
#    $line_start = $QUOTE;
#    $return_count = 0;

    mudwrite($DOING, "waiting for someone to play with me");
}

sub quit_sub
{
    my ($respond, $message, $name) = @_;
    if($child_pid) {
	log_status $child_pid;
	kill 15, $child_pid;
	waitpid($child_pid, 0);
	end_game();
	mudwrite($SPEAK, "game ended by request of $name.");
	return;
    }
    mudwrite($respond, "$MYNAME isn't playing any game right now.");
}


sub load_sub
{
    my ($respond, $message, $name) = @_;

    if($mode == 1) {
	mudwrite($respond, "$MYNAME is already playing a game.");
	return;
    }

    if(mength($message)) {
	$message =~ s/^\s*//;
    }

    if(!mength($message)) {
	mudwrite($respond, "You must give $MYNAME a program name to load.  You can ..$MYNAME list to get a list of games I have.  For more information, do ..$MYNAME help list");
	return;
    }

    if($message =~ /\//) {
	mudwrite($respond, "That game doesn't look so happy.");
	return;
    }

    if($message =~ /\./) {
	mudwrite($respond, "You don't need to include the filename extension for the game.");
	return;
    }

    my $progname = "";
    my @options = ();
    my $gamefile = "";
    $gamemode = "single";

    if(stat("z/$message")) {
	$progname = "debugcheapnitfol"; @options = ("-no-spell", "-i"); $gamefile = "z/$message";
    } elsif(stat("t/$message")) {
	$progname = "cheaptads";   @options = ();     $gamefile = "t/$message";
    } elsif(stat("h/$message")) {
	$progname = "cheaphe";   @options = ();     $gamefile = "h/$message";
    } elsif(stat("g/$message")) {
	$progname = "cheapglulxe";   @options = ();     $gamefile = "g/$message";
    } elsif(stat("a/$message")) {
        $progname = "glkagil"; @options = (); $gamefile = "a/$message/$message";
    } elsif(stat("j/$message")) {
	$progname = "cheapjacl";   @options = ();     $gamefile = "j/$message";
    } elsif(stat("c/$message")) {
	$progname = "cheapscare";   @options = ("-na");     $gamefile = "c/$message";
    } elsif(stat("a3/$message")) {
    	$progname = "cheaparun3"; @options = (); $gamefile = "a3/$message"; 
    } elsif(stat("mag/$message")) {
        $progname = "glkmagnetic"; @options = (); $gamefile = "mag/$message";
    } elsif(stat("x/$message")) {
	$progname = "x/$message";  @options = ();     $gamefile = "";
    } elsif(stat("mz/$message")) {
	$progname = "cheapnitfol"; @options = ("-i", "--no-spell"); $gamefile = "mz/$message";
	$gamemode = "multi";
    } elsif(stat("mt/$message")) {
	$progname = "cheaptads";   @options = ();   $gamefile = "mt/$message";
	$gamemode = "multi";
    } elsif(stat("mx/$message")) {
	$progname = "mx/$message"; @options = ();   $gamefile = "";
	$gamemode = "multi";
    } elsif(stat("mdl/$message")) {
	$progname = "mdli";   @options = ();     $gamefile = "mdl/$message";
    } elsif(stat("java/$message")) {
       $progname = "/usr/bin/java"; @options = qw(-Xmx40M -Dchoicescript.encoding=ISO8859_1 -jar); $gamefile = "java/$message";
       #$progname = "ulimit.sh"; @options = (); $gamefile = "";
    } else {
	# Handling curveship in its special way
	my $fiction = "";
	my $spin = "";
	($fiction, $spin) = split(/ /, $message, 2);
	$spin ||= "";
	$fiction =~ s/^curveship://;
	if (stat("src/curveship/fiction/${fiction}.py")) {
	    if ($spin && stat("src/curveship/spin/${spin}.py")) {
		@options = ("-f", $fiction, "-s", $spin);
	    } else {
		@options = ("-f", $fiction);
	    }
	    $progname = "curveship_wrapper";
	    $gamefile = $fiction;
	    print("../$progname " . join(" ", @options) . " ..$gamefile");
	} else {
	    mudwrite($respond, "$MYNAME doesn't know that game.");
	    return;
	}
    }
  
    chdir("s");
    my $exepath = $progname =~ /^\// ? $progname : "../$progname";
    $child_pid = open2(\*RDR, \*WTR, $exepath, @options, "../$gamefile");
    $child_pid = open3(\*WTR, \*RDR, \*ERR, $exepath, @options, "../$gamefile");
    chdir("..");

    $mode = 1;
    dont_block(*RDR);
    vec($rin,fileno(*RDR),1) = 1;
    dont_block(*ERR);
    vec($rin,fileno(*ERR),1) = 1;

    $child_rdr = *RDR;
    $child_wtr = *WTR;
    $child_err = *ERR;

    mudwrite($DOING, "playing $message");
}

sub load_list
{
    my $file = $_[0];
    my %gamelist;
    open(LIST, "<$file");
    while(<LIST>) {
	chomp;
	if(mength($_)) {
	    my @thisgame = split(/\|/, $_);
	    if(@thisgame != 4) {
		print "Bad list entry: ", $thisgame[0], "\n," 
	    } else {
		my $gamename = shift @thisgame;
		$gamelist{$gamename} = \@thisgame;
	    }
	}
    }
    
    return %gamelist;
}

sub list_sub
{
    my ($respond, $message, $name) = @_;

    $message = lc $message;

    if(mength($message) eq 0) {
	mudwrite($respond, "Floyd have a lot of games! Use 'list all' to show them all if you're sure!");
	return;
    }

    if($message eq "saves") {
	my @savelist = list_files("s");
	mudwrite($respond, join(" ", @savelist));
	return;
    }

    if (lc($message) eq "all") {
      $message = "";
    }

    my %gamelist = load_list("gamelist.txt");
    foreach my $g (keys(%gamelist)) {
	if(!mength($gamelist{$g}->[2])) {
	    $gamelist{$g}->[2] = "unsorted";
	}
    }

    my @filelist = list_files(qw(z t h g a j c a3 mag x mz mt mx mdl java));
    foreach my $f (@filelist) {
	if(!$gamelist{$f}) {
	    $gamelist{$f} = [ "", "", "unsorted" ];
	}
    }

    my $criteria;

    if($gamelist{$message}) {
	$criteria = sub { return $_[0] eq $message; };
    } elsif(mength($message) == 1) {
	$criteria = sub { return substr($_[0], 0, 1) eq $message; };
    } elsif($message =~ /^(.)-(.)$/) {
	my $first = ord $1;
	my $last  = ord $2;
	$criteria = sub { my $l = ord(substr($_[0], 0, 1)); return $first <= $l && $l <= $last; }
    } else {
	$criteria = sub { return index($gamelist{$_[0]}->[2], $message) != -1; }
    }

    my @results;
    foreach my $g (keys(%gamelist)) {
	if(&$criteria($g)) {
	    push @results, $g;
	}
    }
    @results = sort @results;

    if(!@results) {
	mudwrite($respond, "$MYNAME can't find any such games.");
    } elsif(@results >= 5) {
	mudwrite($respond, join(" ", @results));
    } else {
        foreach my $g (@results) {
	    my $t = "$g: " . $gamelist{$g}->[0];
	    if(mength($gamelist{$g}->[1])) {
		$t .= " by " . $gamelist{$g}->[1];
	    }
	    $t .= " (" . $gamelist{$g}->[2] . ")";
	    mudwrite($respond, $t);
	}
    }
}


sub help_sub
{
    my ($respond, $message, $name) = @_;

    if(mength($message)) {
	if($synonyms{$message}) {
	    $message = $synonyms{$message};
	}
	if($helplist{$message}) {
	    mudwrite($respond, $helplist{$message});
	} elsif($commandlist{$message}) {
	    mudwrite($respond, "Oops!  $MYNAME knows that command, but don't have any information on it.");
	} else {
	    mudwrite($respond, "Sorry, $MYNAME doesn't know that command.");
	}
    } else {
	mudwrite($respond, "$MYNAME likes to play games.  If I'm busy playing a game and you want to give me a command like 'hi', you should do '..$MYNAME %hi.'  Help is available for the following commands: " . join(", ", keys(%helplist)) . ".");
    }
}



sub recap_sub
{
    my ($respond, $message, $name) = @_;
    my $lines = 20;

    if(mength($message) && int($message)) {
	$lines = int($message);
    }

    if(!$lines || !$#recap_buffer) {
	mudwrite("page $name=", "No lines to recap");
	return;
    }

    if($lines > $#recap_buffer) {
	$lines = $#recap_buffer;
	mudwrite("page $name=", "Recap buffer not that big; showing last $lines lines.");
    }

    $lines--;

    for my $i (reverse(0..$lines)) {
	mudwrite("page $name=", $recap_buffer[$i]);
    }
}

sub do_sub
{
    my ($respond, $message, $name) = @_;
    
    while(defined($message) && mength($message)) {
	my @commands = split(/\./, $message, 2);
	if(mength($commands[0]) == 0) {
	    @commands = split(/\./, $commands[1], 2);
	    $commands[0] = ".." . $commands[0];
	}

	my $thiscom = $commands[0];
	$message = $commands[1];

	$thiscom =~ s/^\s*//;
	if(mength($thiscom)) {
	    if(substr($thiscom, 0, 1) eq "\@") {
		mudwrite($respond, "$MYNAME is scared of the \@ symbol and won't do it.");
		return;
	    }
	    
	    if($thiscom =~ /^q/i) {
		mudwrite($respond, "You wouldn't want $MYNAME to quit while he's ahead, would you?");
		return;
	    }
	    mudwrite("", $thiscom);
	}
    }
}

sub home_sub
{
    mudwrite($SPEAK, "There's no place like the Floyditorium.");
    mudwrite("", "home");
}

sub say_sub
{
    my ($respond, $message, $name) = @_;
    if($message =~ /^\.\./) {
	mudwrite("", $message);
    } else {
	mudwrite($SPEAK, $message);
    }
}

sub emote_sub
{
    my ($respond, $message, $name) = @_;
    if($message =~ /^(\.\.[^ :,]+) (.*)$/) {
	mudwrite($1, ":" . $2);
    } else {
	mudwrite(":", $message);
    }    
}

sub flush_sub
{
	my ($respond, $message, $name) = @_;
	if ($flush_buf eq "") {
		mudwrite($respond, "No partial line.  Bo-ring.");
	} else {
		my $oldstart = $line_start;
		$line_start = ":> ";
		mudquote($flush_buf);
		$line_start = $oldstart;
		$flush_buf = "";
	}
}


start();