#!/opt/perl/bin/perl 
# PerlMonksCB <-> Intermud gateway
#
# $Revision: 1.18 $ $Date: 2004/03/20 16:08:28 $

use warnings;
use strict;
no strict 'vars';
# use lib '/home/castaway/perlprogs/lib';
use lib '/home/castaway/perl/lib/';

use threads;
use Thread::Conveyor;
use threads::shared;
use MUD::Intermud::DB;
use MUD::Intermud::v2;
use PerlMonksTickers;
use PerlMonks::HTML;
use IO::Select;
use IO::Socket;
use Storable;
use Data::Dumper;
use DBI;

use LWP::UserAgent;
use HTML::TableContentParser;
use HTML::TokeParser;
use HTML::Entities;
use HTTP::Daemon;
use HTTP::Status;
use HTTP::Request::Common;
use URI::Escape;
use Encode;

use Date::Parse;
use Time::ParseDate;
use Date::Format;
use Date::Calc qw(Delta_DHMS Date_to_Time);
use Time::HiRes 'time';

use Devel::Size qw(size total_size);
use Hash::Case::Preserve;

## Configurable
my $MORE   = 20;
# my $LOGDIR = '/mnt/linbackup/log/';
# my $LOGDIR = '/home/castaway/log/';
# my $LOGDIR = '/mnt/tall/im2/log/';
my $LOGDIR = '/home/castaway/perl/log/';
my $CBUSER = 'im2';
my $DEBUGGING = 1;

###############################################################################
# Various globals
$Devel::Size::warn = 0;         # Dont show CVS warnings
$ENV{'PM_USER'} = $CBUSER;
my @messagecallbacks = (\&IM2::Chatter::Callbacks::discern_karma,
					   \&parsecblinks
					   ); 

my $ua = LWP::UserAgent->new();
my $cookies = PerlMonksTickers->get_cookiejar_ref();
my %Users = ();
my @pmlevels = ('initiate', 'novice', 'acolyte', 'scribe', 'monk', 'friar',
                'abbot', 'bishop', 'pontiff', 'saint');
my $latest_public_message;
my $latest_nodes;
my $latest_im2_msg = -1;
my %pm_users = ();
my %notes = ();
my %alarms = ();

# Multiplexer
our %stats : shared = ();
$stats{'startup'} = time();
$stats{'im2users'} = 0;
$stats{'im2logins'} = 0;
$stats{'im2authusers'} = 0;

$telnetoutput  = Thread::Conveyor->new();
$httpoutput    = Thread::Conveyor->new();
$newestnodes   = Thread::Conveyor->new();
$langcb        = Thread::Conveyor->new();
$messtomain    = Thread::Conveyor->new();
$newuser       = Thread::Conveyor->new();

our $telnetfinish : shared;
our $telnetcurrent : shared;
our $telnetpid : shared;

my $telnetthread = threads->create("start_telnet_server");
my $httpthread = threads->create("start_http_server");
$telnetfinish = 0;
$telnetpid = 0;
$telnetcurrent = 0;

# Stuff we saved last time
our $pm_users;
# share($pm_users);
$pm_users = retrieve($LOGDIR . 'pm_users.log');
$notes = retrieve($LOGDIR . 'pm_notes.log');
$alarms = retrieve($LOGDIR . 'pm_alarms.log');
$karma = retrieve($LOGDIR . 'pm_karma.log');
$links = retrieve($LOGDIR . 'pm_links.log');

%pm_users = %{$pm_users}; undef($pm_users);
%notes = %{$notes}; undef($notes);
%alarms = %{$alarms}; undef($alarms);
# %links = %{$links}; undef($links);
my $dbh = DBI->connect("dbi:SQLite2:${LOGDIR}pm_links.db");
%karma = %{$karma}; undef($karma);

tie %karma, 'Hash::Case::Preserve', %karma;

debug(dumper(\%notes));
debug(dumper(\%alarms));
# debug(dumper(\%pm_users));
# debug(dumper(\%karma));

# Intermud2 stuff
my $idb = MUD::Intermud::DB->new({dbname =>
                                  '/home/castaway/perl/data/cbgateway.db',
                                  DEBUG => 'off',
                                  'logpath' => $LOGDIR});
$idb->createTables() unless $idb->isDatabase();
my $i2 = MUD::Intermud::v2->new({'mudname' => 'PerlMonks',
                                 'wholist'  => \&who_remote,
                                 'fingerinfo' => \&finger_remote,
                                 'channelhist' => \&channel_hist,
                                 'channellist' => \&channel_list,
                                 'database' => $idb,
#				 'savefile' => '/home/castaway/perl/data/i2data.dat',
                                 'DEBUG' => 'off'
                                });

my $sel = IO::Select->new();
my $i2sock = $i2->getSocket();
$sel->add($i2sock);
$sel->add(\*STDIN);

run();
sub run
{
    # Parameter: None

    my $messagetime = time();
    my $dailytime = time();
    while (1)
    {
        my $finish = 0;
        my @handles = $sel->can_read(5);
        foreach $handle (@handles)
        {
            if ($handle == $i2sock)
            {
                my $result = $i2->readData();
                if (!defined($result))
                {
                    $finish = 1;
                    last;
                }
                next if($result eq '0');
                send_output($result) if ($result ne '0'); 
            }
            elsif ($handle == \*STDIN)
            {
                $line = <STDIN>;
                chomp($line);
                if ($line eq 'q' || $line eq 'quit')
                {
                    $finish = 1;
                    last;
                }
                else
                {
                    parse_command(1, $line);
                }
            }
        }
        while(my $mess = $messtomain->take_dontwait())
        {
            if($mess->{type} eq 'question')
            {
                parse_im2_question($mess->{user}, 'multi',
                                   $mess->{text});
            }
            elsif($mess->{type} eq 'msgs')
            {
                $Users{$mess->{user}}{msgs} = 
                  !$Users{$mess->{user}}{msgs};
            }
        }
        while(my $lcb = $langcb->take_dontwait())
        {
            $i2->send(@$lcb);
        }
        while(my $u = $newuser->take_dontwait())
        {
            $Users{$u->{user}}{type} = $u->{type};
            $Users{$u->{user}}{user} = $u->{user};
            $Users{$u->{user}}{lastmsg} = 0;
            $Users{$u->{user}}{lasthere} = 0;
            $cookies->{$u->{user}} = $u->{cookie} if($u->{cookie});
        }
        if ($finish)
        {
            $i2->closei2();
            $idb->closedb();
            store \%pm_users, $LOGDIR . 'pm_users.log';
            store \%notes, $LOGDIR . 'pm_notes.log';
            store \%alarms, $LOGDIR . 'pm_alarms.log';
            store \%karma, $LOGDIR . 'pm_karma.log';
            store \%links, $LOGDIR . 'pm_links.log';
            lock ($telnetfinish);
            $telnetfinish = 1;
            $telnetthread->detach();
            last;
        }
        my $res = $i2->checkTimeouts() if(!@handles);
        #	check_ip() if (@handles);
        print_output(1, $res) if($res);
        $res = check_perlmonks();
        if (time() - $messagetime > 300)
        {
		    # backup previous versions!
            rename($LOGDIR . 'pm_users.log', $LOGDIR . 'pm_users.log.bak') 
			  if(-e $LOGDIR . 'pm_users.log');
            rename($LOGDIR . 'pm_karma.log', $LOGDIR . 'pm_karma.log.bak') 
			  if(-e $LOGDIR . 'pm_karma.log');
#            rename($LOGDIR . 'pm_links.log', $LOGDIR . 'pm_links.log.bak') 
#			  if(-e $LOGDIR . 'pm_links.log');
            store \%pm_users, $LOGDIR . 'pm_users.log';
            store \%karma, $LOGDIR . 'pm_karma.log';
#            store \%links, $LOGDIR . 'pm_links.log';
            $res = check_messages();
            $res = check_nodes();
            $messagetime = time();
        }
        if (time() - $dailytime > 3600 * 3)
        {
            #	    $res = check_birthdays();
        }
        $res = check_alarms();
        if(time() - $telnetcurrent > 180)
        {
            # the telnet thread isnt looping? huh?
            debug("Can't see telnet thread.. \n");
            # kill, 9, $telnetpid;
            # $telnetthread = threads->create("start_telnet_server");
        }
    }
}

sub send_output
{
    # Send a message to the CB
    # Parameter: Result hash
    my ($output) = @_;

    if (!$output || ref($output) ne 'HASH' || !defined($output->{'output'}))
    {
        return 0;
    }

    debug("send_output: " . Dumper($output)) 
      unless ($output->{'output'} =~ /auth/);

    my $mesg = $output->{'output'};
    $mesg =~ s/\p{IsC}//g;
    if (!length($mesg))
    {
        return 0;
    }

    if (lc($output->{'mud'}) eq 'perlmonks' || 
        lc($output->{'from'}) eq $CBUSER. '@perlmonks')
    {
        print $output->{'from'}, ' ', $output->{'output'}, "\n";
        return 0;
    }

    if (($output->{'type'} eq 'channel:perlmonks' ||
         $output->{'type'} eq 'channel:perlmonks-de' ||
        ($output->{'type'} eq 'cmd:tell' && lc($output->{'to'}) ne $CBUSER)) && 
        !$Users{lc($output->{'from'})}) 
       
    {
        my @user = split('@', $output->{'from'});
        my @args = ($CBUSER, $user[1], 'tell', $user[0], 
                    'Sorry, to chat to perlmonks on the perlmonks channel, you need to create a '.
                    'PerlMonks user on www.perlmonks.org, and authenticate yourself by sending '.
                    'a tell to "'. $CBUSER . '@perlmonks" with "auth [<name>] <password>". Your cookie '.
                    'will not be stored on disk, only in memory of this script.');
        $i2->send(@args);
        return 1;
    }

    if ($output->{'type'} eq 'cmd:tell' && lc($output->{'to'}) eq $CBUSER)
    {
        if ($output->{'output'} =~ /^\/msg \[$CBUSER\] auth \[(.*?)\] (.*)$/)
        {
            my $u = $1;
            my $p = $2;
            my $userauth = auth_pm_user($1, $2);
            if (!$userauth)
            {
                my @user = split('@', $output->{'from'});
                my @args = ($CBUSER, $user[1], 'tell', $user[0], 
                            'Sorry, I couldn\'t authenticate you at perlmonks! It\'s either down, or your'.
                            ' user or password was misspelled.');
                $i2->send(@args);
                return 1;
            }
            my @user = split('@', $output->{'from'});
            my @args = ($CBUSER, $user[1], 'tell', $user[0], 'Found you!');
            $i2->send(@args);
            $Users{lc($output->{'from'})}->{'user'} = $u;
            $Users{lc($output->{'from'})}->{'lastmsg'} = 0;
            $Users{lc($output->{'from'})}->{'lasthere'} = 0;
            $Users{lc($output->{'from'})}->{'type'} = 'intermud';
            $res = check_messages();
            debug(Dumper(\%Users));
        }
        elsif (!$Users{lc($output->{'from'})}{'user'})
        {
            my @user = split('@', $output->{'from'});
            my @args = ($CBUSER, $user[1], 'tell', $user[0], 
                        "I don't know you, please authorize with ".
                        "\"auth [<name>] <password>\"!");
            $i2->send(@args);
        }
        elsif ($output->{'output'} =~ /^\/msg \[$CBUSER\] (.+)$/)
        {
#	    debug("From: " . $output->{'from'} . "\n");
#	    debug("User: " . $Users{lc($output->{'from'})}{'user'} . "\n");
#	    debug("Users: " . Dumper(\%Users));
            parse_im2_question($Users{lc($output->{'from'})}{'user'}, 'tell',
                               $1);
        }
        return 1;
    }
	    
    if ($output->{'type'} eq 'channel:perlmonks' ||
        $output->{'type'} eq 'cmd:tell')
    {
        $Users{lc($output->{'from'})}->{'lasthere'} = time();
        PerlMonksTickers->send_message('message' => $mesg,
                                       'user'    => $Users{lc($output->{'from'})}->{'user'});
    }
    if($output->{'type'} eq 'channel:perlmonks-de')
    {
        add_to_langcb($Users{lc($output->{'from'})}->{'user'},
                      $mesg);
    }
}


sub print_output
{
    # Output something, add to history / colour when type is given
    # Parameter: UserId, Result Hash
    my ($userid, $output) = @_;

    debug(Dumper($output));
    if (!$output || !defined($output->{'output'}))
    {
        return 0;
    }

    my $mesg = $output->{'output'};
    $mesg =~ s/\p{IsC}//g;
    debug("Message : $mesg\n");
    if (!length($mesg))
    {
        return 0;
    }
#    if($output->{'type'})
#    {
#	$mesg = colour_output($userid, $output->{'type'}, $mesg);
#    }

#    debug($mesg . "\n");
    if (my $pos = index($mesg, chr(255)) > -1)
    {
        substr($mesg, $pos, 0, chr(255));
    }
    my @lines = split('\n', $mesg);
    do_more($userid, @lines);
}

sub do_more
{
    # Output lines using more
    # Parameter: Lines
    my ($userid, @lines) = @_;

#    my $sout = $Users{$userid}{'socket'};
    my $sout = \*STDOUT;
#    debug("do_more: " . Dumper(\@lines));
    if (scalar(@lines) > $MORE)
#    while(scalar(@lines) > $MORE)
    {
        # if the output has more than $MORE lines
        # %Mores{$userid}[MORE][lines]
        debug("do_more: More than $MORE\n");
        if (!$Mores{$userid})
        {
            $Mores{$userid}{'lines'} = [];
            $Mores{$userid}{'more'} = 0;
        }
        else
        {
            $Mores{$userid}{'more'} = 0;
        }
        $Mores{$userid}{'lines'} = \@lines;
        more_text($userid, undef);

        return 0;
#	for (my $i = 0; $i < $MORE; $i++)
#	{
#	    print $sout shift(@lines) . "\r\n";
#	}
#	print $sout "---- More ----";
#	ReadKey 0; ## Socket!?
    }	
#    @lines = map { $_ = HTML::Entities::decode($_) if(defined($_)); } @lines;
#    @lines = map { $_ if(defined($_)); } @lines;
    print $sout join("\r\n", @lines) . "\r\n";

}

sub more_text
{
    # Called by command 'more' with +, -, or q as parameter
    # + => Give out next $Mores{$userid}{'lines}[ .. {'current'}][ .. {'more'}]
    # - => Give out previous
    # q => delete current
    # Parameter: UserId, Param
    my ($userid, $param) = @_;

    if (!$Mores{$userid})
    {
        return {'output' => "No more texts available."};
    }
    if (!$Mores{$userid}{'lines'})
    {
        return {'output' => "Nothing more to show."};
    }

    my $result;
    my $sout = \*STDOUT;
#    my $sout = $Users{$userid}{'socket'};
    if (!defined($param))
    {
        my @lines;
        my $more = $Mores{$userid}{'more'} * $MORE;
        my $more2 = $more + $MORE - 1 > @{$Mores{$userid}{'lines'}} ?
          @{$Mores{$userid}{'lines'}} - 1: $more + $MORE - 1;
#	debug("more_text: " . Dumper(\%Mores));
	
        @lines = @{$Mores{$userid}{'lines'}}[$more .. $more2];
	
        do_more($userid, @lines);
        print $sout "---- More ----\r\n";
    }
    elsif ($param eq '+')
    {
        if ($Mores{$userid}{'more'} >= @{$Mores{$userid}{'lines'}} - 2)
        {
            $result->{'output'} = "No more text.";
            return $result;
        }
        $Mores{$userid}{'more'}++;

        my @lines;
        my $more = $Mores{$userid}{'more'} * $MORE;
        my $more2 = $more + $MORE - 1 > @{$Mores{$userid}{'lines'}} ?
          @{$Mores{$userid}{'lines'}} - 1: $more + $MORE - 1;
#	debug("more_text: " . Dumper(\%Mores));
	
        @lines = @{$Mores{$userid}{'lines'}}[$more .. $more2];
	
        do_more($userid, @lines);
        if ($Mores{$userid}{'more'} < @{$Mores{$userid}{'lines'}} - 2)
        {
            print $sout "---- More ----\r\n";
        }
    }
    elsif ($param eq '-')
    {
        if ($Mores{$userid}{'more'} < 1)
        {
            $result->{'output'} = "Already at the beginning!";
            return $result;
        }
        $Mores{$userid}{'more'}--;
        my @lines;
        my $more = $Mores{$userid}{'more'} * $MORE;
        my $more2 = $more + $MORE - 1 > @{$Mores{$userid}{'lines'}} ?
          @{$Mores{$userid}{'lines'}} - 1: $more + $MORE - 1;
#	debug("more_text: " . Dumper(\%Mores));
	
        @lines = @{$Mores{$userid}{'lines'}}[$more .. $more2];
	
        do_more($userid, @lines);
        print $sout "---- More ----\r\n";
	
    }
    elsif ($param eq 'q')
    {
        $Mores{$userid}{'lines'} = [];
        $result->{'output'} = "More deleted.\n";
        return $result;
    }
    return 0;
}

sub parse_command
{
}

sub who_remote
{
    my $otherusers = PerlMonksTickers->other_users();
    my %userinfo = ();
    my $table = Text::FormatTable->new('l r');
    foreach my $ou (keys(%{$otherusers}))
    {
        $userinfo{$ou} = PerlMonksTickers->xp(for_user => $ou);
    }
    foreach my $user (sort { $userinfo{$b}->{'xp'} <=> $userinfo{$a}->{'xp'} }
                      keys %userinfo) 
    { 
        $table->row($user, $pmlevels[$userinfo{$user}->{'level'} - 1]);
    }

#    local $/="\r\n";
    my $answer = '';
    $answer .= '-' x 79 . "\r\n";
    $answer .= ' ' x 35 . "PerlMonks\r\n";
    $answer .= ' ' x 27 . "http://www.perlmonks.org\r\n";
    $answer .= '-' x 79 . "\r\n";
    $answer .= $table->render(79);
    $answer .= '-' x 79 . "\r\n";
	
    return $answer;
}

sub finger_remote
{
# finger <name> XP, Level ?
# finger <me> XP, Level, Last few messages, XP to next level?
    my (%request) = @_;
    
    my $answer = '';
    if (lc($request{'data'}) eq lc($request{'snd'}) && 
        $cookies->{lc($request{'snd'})})
    {
        my $xp = PerlMonksTickers->xp('user' => $request{'data'});
        my $mess = PerlMonksTickers->private_messages('user' => $request{'data'});
#	debug(Dumper($mess));
        my @messages = sort {$mess->[$b]->{'message_id'} <=> 
                               $mess->[$a]->{'message_id'}} (0..$#$mess);
        $answer .= '-' x 79 . "\n";
        $answer .= 'Name: ' . $request{'snd'} . "\n";
        $answer .= 'Level: ' . $pmlevels[$xp->{'level'} - 1] . "\n";
        $answer .= 'XP: ' . $xp->{'xp'} . "\n";
        $answer .= 'XP to next level: ' . $xp->{'xp2nextlevel'} . "\n";
        $answer .= '-' x 79 . "\n";
        if (@messages)
        {
            $answer .= 'Last 6 (unarchived) messages received:' . "\n";
        }
        else
        {
            $answer .= 'No messages in message box.' . "\n";
        }

        my $i = 0;
        foreach my $m (@messages)
        {
            next if($mess->[$m]->{'status'} eq 'archived');
            $answer .= $mess->[$m]->{'time'} . ' ' . $mess->[$m]->{'author'} .
              ' ' . $mess->[$m]->{'text'} . "\n";
            $i++;
            last if($i > 6);
        }
        $answer .= '-' x 79 . "\n";
    }
    else
    {
        my $xp = PerlMonksTickers->xp('for_user' => $request{'data'});
#	my $test = PerlMonksTickers->any_node('node' => $request{'data'});
#	debug(Dumper($test));
        $answer .= '-' x 79 . "\n";
        $answer .= 'Name: ' . $request{'data'} . "\n";
        $answer .= 'Level: ' . $pmlevels[$xp->{'level'} - 1] . "\n";
        $answer .= 'XP: ' . $xp->{'xp'} . "\n";
        $answer .= '-' x 79 . "\n";
    }

    return $answer;
}

sub channel_hist
{
    return '';
}

sub channel_list
{
    return '';
}

sub check_perlmonks
{
    # Collect latest messages from chatterbox and parse
    # Parameter: None

    my $cblines = PerlMonksTickers->chatterbox();
    
    my @lines = 
      PerlMonksTickers->only_new_messages( $latest_public_message, @$cblines);
    debug(Dumper(\@lines)) if(@lines);

    foreach my $line (@lines)
    {
        my $text = HTML::Entities::decode($line->{'text'});
#        my $text = $line->{'text'};
        $text =~ tr/\r\n\t/ /s;
#	$text =~ s/&#([0-9a-f]{2,4});/chr hex $1/ieg;            #'
        my @args = ();
#	if(lc($line->{'author'}) eq 'im2')
#	{
#	    # don't repost messages from intermud to intermud..
#	    next;
#	}

        my $etime = str2time($line->{'time'}, 'EDT');
        $pm_users{lc($line->{'author'})}->{'time'} = $etime;
        $pm_users{lc($line->{'author'})}->{'said'} = $text 
            if (!$pm_users{lc($line->{'author'})}->{'dont'});

        $httpoutput->put({'type' => 'public',
                          'author' => $line->{'author'}, 
                          'time' => $line->{'time'},
                          'text' => $line->{'text'}});

        if ($text =~ s/^\/me //i)
        {
            @args = ($line->{'author'}, 'all', 'channel', 'perlmonks',
                     'emote', $text);
            $telnetoutput->put({'type' => 'cb', 
                                'text' => $line->{'author'} . " " . $text});
        }
        elsif ($text =~ s/^\/me\'s //i)
        {
            @args = ($line->{'author'}, 'all', 'channel', 'perlmonks',
                     'gemote', $text);
            $telnetoutput->put({'type' => 'cb',
                               'text' => $line->{'author'} . "'s " . $text});
        }
        else
        {
            @args = ($line->{'author'}, 'all', 'channel', 'perlmonks',
                     '', $text);
            $telnetoutput->put({'type' => 'cb',
                               'text' => $line->{'author'} . ": " . $text});
        }
        my $result = $i2->send(@args);

#       debug("Got line: $text\n");
        if ($text =~ /^\[$CBUSER\]: (.*)/)
        {
            debug("Got question: from: " . $line->{'author'} . ": $1\n");
            parse_im2_question($line->{'author'}, 'msg', $1);
        }
        debug(Dumper($result));
        print_output(1, $i2->getError(), 'error') if !defined($result);
        print_output(1, $result) if($result ne '0');

        ## call any defined callbacks
#        for(Devel::Symdump->functions('IM2::Chatter::Callbacks')) {
#          my $f = \&$_;
#          debug(Dumper($f));
#          $f->( $line );
#        }
		$line->{'text'} = $text;
		foreach my $cb (@messagecallbacks)
		{
			$cb->($line) unless($pm_users{lc($line->{'author'})}->{'dont'});
		}
#       IM2::Chatter::Callbacks::karma($text, $line->{author}); 
    }
}

sub check_nodes
{
    # Look for new nodes, maximum a few hours old.
    # Parameters: None

    $latest_nodes = time() - (3600*2) if(!$latest_nodes);
    my $newnodes = PerlMonksTickers->newest_nodes('types' => ['monkdiscuss',
                                                              'perlquestion',
                                                              'perlmeditation',
                                                              'perlnews'],
                                                  'sinceunixtime' => $latest_nodes);
    my @nnodes = PerlMonksTickers->only_new_nodes($latest_nodes, @$newnodes);

    foreach my $nnode (@nnodes)
    {
        foreach my $u (keys %Users) 
        {
            my @user = split('@', $u);
	    return if(@user < 2);
            my @args = ($CBUSER, $user[1], 'tell', $user[0], 
		' New Node: [id://' . $nnode->{node_id} . '|' . 
		$nnode->{'title'} . ']');
            $i2->send(@args);
        }

        $newestnodes->put('im2: New Node: [id://' . $nnode->{node_id} . 
                              '|' . $nnode->{'title'} . ']');
    }

    debug(Dumper(\@nnodes));

}

sub check_messages
{
    foreach $user (keys %Users)
    {
#       print("Get msgs for user: $user\n");
        next if(!$Users{$user}->{'user'}); # grrr!
        next if($Users{$user}{type} eq 'intermud' && 
                time() - $Users{$user}->{'lasthere'} > 3600);
        next if($Users{$user}{type} eq 'telnet' &&
                !$Users{$user}{msgs});

	my @args = ('user' => $Users{$user}->{'user'});
	push @args, ('since_id' => $Users{$user}->{'lastmsg'}) 
	  if($Users{$user}->{'lastmsg'} > 0);
        my $mess = PerlMonksTickers->private_messages(@args);
	
#        my $mess = PerlMonksTickers->private_messages('user' => $Users{$user}->{'user'}, 
#	    'since_id' => $Users{$user}->{'lastmsg'});
#        my @messages = grep {$mess->[$_]->{'message_id'} > $Users{$user}->{'lastmsg'} }
#          (0..$#$mess) if($mess);

#	debug("Message: " . Dumper($mess));
        my @messages = (0..$#$mess);
	
        if (@messages)
        {
            @messages = sort {$mess->[$b]->{'message_id'} <=>
                                $mess->[$a]->{'message_id'}} @messages;
            
            $Users{$user}->{'lastmsg'} = $mess->[$messages[0]]->{'message_id'};
            if($#messages > 10)
            {
                splice(@messages, 10);
                # Chop off anything more than 10 messages, and add one from
                # im2, saying we didnt bother to send more than 10
                push @$mess, {'message_id' => 0,
                              'text' => "More messages found, only the last 10 have been returned to you.",
                              'status' => 'x',
                              'author' => $CBUSER };
                # Add the index of the message we just created to the @messages
                # array (array of @$mess indexes)
                push @messages, $#$mess;

#                debug(Dumper(\@messages));
            }
            
            foreach my $m (@messages)
            {
                next if($mess->[$m]->{'status'} eq 'archived');
                my $text = HTML::Entities::decode($mess->[$m]->{'text'});
                if($Users{$user}{type} eq 'telnet')
                {
                    $telnetoutput->put({'type' => 'multi',
                                       'who' => $user,
                                       'text' => 
                                       '['.$mess->[$m]{message_id}.'] '.$mess->[$m]{author}.' said '.$text});
                    next;
                }

                my @user = split('@', $user);
                my @args = ($mess->[$m]->{'author'}, $user[1], 'tell', $user[0], 
                            "[" . $mess->[$m]->{'message_id'} . "] " . 
                            $text);
                $i2->send(@args);
            }
        }
    }

    my $mess = PerlMonksTickers->private_messages('user' => $CBUSER, since_id => $latest_im2_msg);
#    debug(Dumper($mess));
#    my @messages = grep {$mess->[$_]->{'message_id'} > $latest_im2_msg }
#      (0..$#$mess) if($mess);
    my @messages = (0..$#$mess);
    if (@messages)
    {
        @messages = sort {$mess->[$b]->{'message_id'} <=>
                            $mess->[$a]->{'message_id'}} @messages;

        $latest_im2_msg = $mess->[$messages[0]]->{'message_id'};
        
        foreach my $m (@messages)
        {
            debug("Got question via /msg: from: " . $mess->[$m]->{'author'} . 
                  ": " . $mess->[$m]->{'text'} . "\n");
            parse_im2_question($mess->[$m]->{'author'}, 'msg', 
                               $mess->[$m]->{'text'});

            PerlMonksTickers->modify_inbox('user' => $CBUSER,
                                           'delete', => $mess->[$m]->{'message_id'});

# http://www.perlmonks.net/?node=Message+Inbox&op=message&deletemsg_540510577=yup
        }    
    }

#[Perlmonks Bart@PerlMonks] <input type="checkbox" name="deletemsg_540509589" value="yup">

#    }
#    @lines = map {$_->{'author'} . " " . $_->{'text'}} @lines;
#    debug(Dumper(\@lines));   

}

sub parse_im2_question
{
    # Simple bot questions.
    # Parameter: From which user, How (over cb, msg, tell), 
    #            The text directed at im2.
    my ($from, $how, $question) = @_;

    my $answer = '';
    my $logout = 0;

    $stats{'questions'}++;

    if ($question =~ /^how long until (\d+) (\d+) (\d+)(?: (\d+) (\d+))?/i)
    {
        my ($sec2,$min2,$hour2,$mday2,$mon2,$year2,$wday,$yday,$isdst) =
          localtime();

        my ($Dd,$Dh,$Dm,$Ds) = Delta_DHMS(
                                          $year2+1900,$mon2+1,$mday2,
                                          $hour2,$min2,$sec2,
                                          $3,$2,$1,
                                          defined($4) ? $4 : 0,
                                          defined($5) ? $5 : 0,
                                          0);

        $answer = "That's $Dd days, $Dh hours and $Dm minutes.";

    }
    elsif ($question =~ /^size (.+)$/i)
    {
	$answer = "Nanana.. ";
	my $svar = $1;
        if (lc($from) =~ /^(theorbtwo|castaway)$/)
        {
	    $answer = show_size($svar);
	}
    }
    elsif ($question =~ /^dump (.*)$/i)
    {
        $answer = "Nanana.. ";
        my $dvar = $1;
        if (lc($from) =~ /^(theorbtwo|castaway)$/)
        {
            $answer = show_dump($dvar);
        }
    }
    elsif ($question =~ /^postbio$/i)
    {
        $answer = "Nanana.. ";
        if (lc($from) =~ /^(theorbtwo|castaway)$/)
        {
            post_im2_bio();
            $answer = "Done.";
        }
    }
    elsif ($question =~ /^birthdays$/i)
    {
        $answer = "Nanana.. ";
        if (lc($from) =~ /^(theorbtwo|castaway)$/)
        {
            update_birthdays();
            $answer = "Done.";
        }
    }
    elsif ($question =~ /^poke (.*?) (.*)$/i)
    {
        $answer = "Nanana.. ";
        my ($pvar, $pval) = ($1, $2);
        if (lc($from) =~ /^(theorbtwo|castaway)$/)
        {
            $answer = poke_value($pvar, $pval);
        }
    }
    elsif ($question =~ /^eval (.*)$/i)
    {
        $answer = "Nanana.. ";
        my $es = $1;
        if (lc($from) =~ /^(theorbtwo|castaway)$/)
        {
            $answer = show_eval($es);
        }
    }
    elsif ($question =~ /^dont remember me$/i)
    {
        $answer = "Ok, I won't remember what you said.";
        $pm_users{lc($from)}->{'dont'} = 1;
        $pm_users{lc($from)}->{'said'} = undef;
    }
    elsif ($question =~ /^said (.+?)\??$/i)
    {
        my $searched = $1;
        $answer = "I don't know what $searched said, sorry.";
        if ($pm_users{lc($searched)} && $pm_users{lc($searched)}->{'said'})
        {
            $answer = "$searched said: " . $pm_users{lc($searched)}->{'said'};
        }
    }
    elsif ($question =~ /^seen (.+?)\??$/i)
    {
        my $searched = $1;
        $answer = "I haven't seen $searched";
        if ($pm_users{lc($searched)})
        {
            my $timesince = time() - $pm_users{lc($searched)}->{'time'};
            $timesince = secs2str($timesince);
            # XX::YY hours/mins ago?
            $answer = "I last saw [$searched] at " . 
              getlocaltime($pm_users{lc($searched)}->{'time'}, $from) . 
                " ($timesince ago) on the CB.";
        }

    }
    elsif ($question =~ /^who/)
    {
	if($how ne 'multi')
	{
	    $answer = '';
	}
	else
	{
	    $answer = who_remote();
	}
	
    }
    elsif ($question =~ /^guess 500_000 (.+)$/i)
    {
        my ($t, $rest) = parsedate($1, GMT => 1, PREFER_FUTURE => 1, FUZZY => 1);
        my $tdate = gmtime($t);
        $answer = "Oops, can't parse your guess of $1 as a date/time. Blame parsedate if you like!";
        if($pm_users{lc($from)}->{'500000'})
        {
            $answer = "Nanana, you already guessed!";
        }
        elsif($t)
        {
            $answer = "Ok, added your guess of $tdate. " . 
                "(See [im2] for the list)";
            $pm_users{lc($from)}->{'500000'} = [$tdate, scalar gmtime()];
        }
        post_im2_bio();
    }
    elsif ($question =~ /^add note(?: for (.+?))?: (.+)/i)
    {
        my $who = $2 ? lc($1) : $from; 
        $note = $2 ? $2 : $1;
        if (length($notes{$who}) + length($who) + 1 > 240)
        {
            $answer = "Sorry, the note would be too long then.";
        }
        else
        {
            $notes{$who} .= ';' . $note;
            $answer = "Done.";
        }
    }
    elsif ($question =~ /^get note$/i)
    {
        $answer = "No note from you!";
        if ($notes{$from})
        {
            $answer = $notes{$from};
        }
    }
    elsif ($question =~ /^delete note$/i)
    {
        $notes{$from} = '';
        $answer = "Done";
    }
    elsif ($question =~ /^delete message (\d+)$/i)
    {
        debug("Delete message: $1 for $from.\n");
        PerlMonksTickers->modify_inbox('user' => $from,
                                       'delete' => $1);
        $answer = "Done";
    }
    elsif ($question =~ /^archive message (\d+)$/i)
    {
        debug("Archive message: $1 for $from.\n");
        PerlMonksTickers->modify_inbox('user' => $from,
                                       'archive' => $1);
        $answer = "Done";
    }
    elsif ($question =~ /^logout$/i)
    {
        my ($usermud) = grep { $Users{$_}{'user'} eq lc($from) } keys %Users;
        if ($usermud)
        {
            $logout = 1;
            $answer = "Byeeee";
        }
    }
    elsif ($question =~ /^add alarm: (.*)$/)
#    elsif($question =~ m!^add alarm: (\d+)/(\d+)/(\d+)(?: (\d+):(\d+))? (\b[A-Z]{3,}\b) (.*)$!i)
#/^add alarm: (\d+) (\d+) (\d+)(?: (\d+) (\d+))? (-|\+)(\d+) (.*)$/)
    {
#        # Day, Month, Year, Hour, Minute, +/- Zone
#        my ($day, $mon, $year, $hour, $min, $zone, $mesg) = 
#            ($1, $2, $3, 0, 0, '', 0, '');
#        if($6)
#        {
#            ($hour, $min, $zone, $mesg) = ($4, $5, $6, $7);
#        }
#        else
#        {
#            ($zone, $mesg) = ($4, $5);
#        }

#        my $string = sprintf("%d/%d/%d %d:%d %s", $mon, $day, $year,
#                             $hour, $min, $zone);
#        debug("Alarm: $string\n");
#        my $time = str2time($string, "GMT");

#       my $evalstr = "$hour = $hour $pm $zone";
#       eval $evalstr;
#       if($hour > 23)
#       {
#           $day += 1;
#           $hour = $hour - 24;
#       }
#       elsif($hour < 0)
#       {
#           $day -= 1;
#           $hour = $hour + 24;
#       }

#       my $time = Date_to_Time($year,$mon,$day, $hour,$min,0);
        my ($time, $rest) = parsedate($1, 
                                      PREFER_FUTURE => 1,
                                      GMT => 1,
                                      FUZZY => 1);
        $answer = "Sorry, couldn't parse that!";
        if ($time)
        {
            $mesg = $rest;
            $alarms{$time} = [] if(!$alarms{$time});
            $alarms{$time}->[scalar @{$alarms{$time}}] = {'message' => $mesg,
                                                          'who' => lc($from),
                                                          'method' => $how };

            debug("Alarms: " . Dumper(\%alarms));
	    
            $answer = "Alarm set for: " . getlocaltime($time, $from);
        }
    }
#      elsif ($question =~ /^delete alarm: (?:(\d+) (\d+) (\d+)(?: (\d+) (\d+))? (-|\+)(\d+))|(\d+)$/i)
#      {
#          my $time;
#          if ($2)
#          {
#              # Day, Month, Year, Hour, Minute, +/- Zone
#              my ($day, $mon, $year, $hour, $min, $pm, $zone, $mesg) = 
#                ($1, $2, $3, 0, 0, '', 0, '');
#              if ($6)
#              {
#                  ($hour, $min, $pm, $zone, $mesg) = ($4, $5, $6, $7, $8);
#              }
#              else
#              {
#                  ($pm, $zone, $mesg) = ($4, $5, $6);
#              }
            
#              my $evalstr = "$hour = $hour $pm $zone";
#              eval $evalstr;
#              if ($hour > 23)
#              {
#                  $day += 1;
#                  $hour = $hour - 24;
#              }
#              elsif ($hour < 0)
#              {
#                  $day -= 1;
#                  $hour = $hour + 24;
#              }
#              $time = Date_to_Time($year,$mon,$day, $hour,$min,0);
#          }
#          else
#          {
#              $time = $1;
#          }
#          my ($useralarm) = grep {$_->{'who'} eq lc($from) && $_ == $time} 
#            @{$alarms{$time}} if($alarms{$time});
        
#          $answer = "You have no alarm set at that time!";
#          if ($useralarm)
#          {
#              delete $alarms{$time}->[$useralarm];
#              delete $alarms{$time} if(!@{$alarms{$time}});
#              $answer = "Done";
#          }
#      }
    elsif ($question =~ /^list alarms$/i)
    {
        $answer = '';

        debug("LA: " . Dumper(\%alarms));
        my @useralarms = map { {$_ => [ grep {$_->{'who'} eq lc($from)} @{$alarms{$_}}] } } keys %alarms;
#       my @useralarms = map { my @als = grep {$_->{'who'} eq lc($from)} @{$alarms{$_}}; {$_ => \@als} } keys %alarms;

#[Perlmonks Demerphq@PerlMonks] castaway, <code>my $copy=eval { "do{".Data::Dumper->new([$var])->Purity(1)->Indent(0)->Dump().'$VAR1}' } or die $@;</code>
#[Perlmonks Demerphq@PerlMonks] incidentally castway your problem:<code>for $k(keys %hash){ for $i (0..$#{$hash{$k}}) { for my $k2 (keys %{$hash{$k}[$i]}) { print "$k $i $k2\n" if (1) } } } }</code>

        debug("LA: " . Dumper(\@useralarms));
        foreach my $alm (@useralarms)
        {
            my $alms = $alm->{(keys %{$alm})[0]};
            debug(Dumper($alms));
            foreach my $ua (@{$alms})
            {
                debug(Dumper($ua));
                $answer .= "[" . (keys %{$alm})[0] . "|" . 
                  gmtime((keys %{$alm})[0]) . "] " . 
                    $ua->{'message'} . "\n";
            }
        }
    }
    elsif ($question =~ /^set timezone (.*)$/i)
    {
        $pm_users{lc($from)}->{'timezone'} = $1;
        $answer = "Done";
    }
    elsif ($question =~ /^stats$/i)
    {
        # Users seen, Running, Questions, 
        lock(%stats);
        $answer .= "I have been running for " .
          secs2str(time() - $stats{'startup'}) . ".\n";
        $answer .= "I have answered " . $stats{'questions'} . " question(s).\n";
        $answer .= "I have seen " . scalar(keys(%pm_users)) . " CB users (ever).\n";
        $answer .= $stats{'im2users'} . " user(s), (". 
          $stats{'im2authusers'} . " authorised) are currently using the Multiplexer.\n";
        $answer .= "A total of " . $stats{'im2logins'} . " user(s) have logged in since I last rebooted.\n";
    }
    elsif ($question =~ /^play pool$/i)
    {
        $answer = "I've added you! (See [im2] for the list)";
        if ($pm_users{lc($from)}->{'pool'})
        {
            $pm_users{lc($from)}->{'pool'} = undef;
            $answer = "Shame you don't want to be listed any more!";
        }
        else
        {
            $pm_users{lc($from)}->{'pool'} = 'yes';
        }
        post_im2_bio();
    }
    elsif ($question =~ /^parse_date_rel (.*)$/i)
    {
        $answer = "I couldn't parse that!";
        my ($t, $rest) = parsedate($1, PREFER_FUTURE => 1);
        if ($t)
        {
            $answer = "Got: " . gmtime($t) . " + $rest";
        }
    }
    elsif ($question =~ /^parse_date (.*)$/i)
    {
        $answer = "I couldn't parse that!";
        my ($t, $rest) = parsedate($1, NO_RELATIVE => 1, PREFER_FUTURE => 1);
        if ($t)
        {
            $answer = "Got: " . gmtime($t) . " + $rest";
        }
    }
    elsif ($question =~ /^karma\s+(.+)/i)
    {
        my $question = $1;
        if ($question eq '--dump') 
        {
            $answer = '[http://desert-island.dynodns.net/perl/im2/karma.html|karma stats]';
        } 
        else 
        {
            my $k;
            if (exists $pm_users{$question} and 
                exists $pm_users{$question}->{karma} and 
                !$pm_users{lc($question)}->{'dont'}) 
            {
                $k = $pm_users{$question}->{karma};
                $answer =  "karma for [$question] is $k->{value}, " .
                  "(max: $k->{max}, min: $k->{min})";
            } 
            elsif(defined($karma{$question}))
            {
                $k = $karma{$question};
                $answer =  "karma for '$question' is $k->{value}, " .
                  "(max: $k->{max}, min: $k->{min})";
            }
  
            if (defined $k and ref($k) eq 'HASH') 
            {
                my $coms = $k->{comments};
                my $c = (sort { $coms->{$a} <=> $coms->{$b} } keys %$coms)[0];
  
                $answer .= " most popular comment: $c"
                  if defined $c;
            } 
            else 
            {
                $answer = "no karma for '$question'";
            }
        }
    }
    elsif ($question =~ /^help$/i)
    {
        $answer = "<code>I know the following commands: 'how long until <day> <month> <year> [<hour> <minute>]', 'seen <name>', 'add note: <note>', 'get note', 'delete note', 'delete message <nr>', 'add alarm: <D> <M> <YYYY> [<HR> <MIN>](-|+) <timezone> <message>', 'delete alarm: <date>/<time>', 'list alarms', 'karma [ITEM|--dump]'</code>";
    }
    else
    {
        if ($how ne 'cb')
        {
            $answer = "I didn't understand that, try 'help'";
        }
    }

    if ($answer)
    {
        if ($how eq 'cb')
        {
            PerlMonksTickers->send_message('message' => $answer,
                                           'user'    => $CBUSER);
        }
        elsif ($how eq 'tell')
        {
#           print(Dumper(\%Users));
            my ($usermud) = grep { $Users{$_}{'user'} && $Users{$_}{'user'} eq lc($from) } keys %Users;
            if ($usermud)
            {
                my @user = split('@', $usermud, 2);  
                my @args = ($CBUSER, $user[1], 'tell', $user[0], $answer);
                $i2->send(@args);
            }
	}
        elsif ($how eq 'msg')
        {
            PerlMonksTickers->send_message('message' => "/msg [$from] " . $answer,
                                           'user'    => $CBUSER);
	}
	elsif ($how eq 'multi')
	{
	    $telnetoutput->put({'type' => 'multi',
                           'who' => $from,
                           'text' => $answer});
	}
    }
    if ($logout)
    {
        my ($usermud) = grep { $Users{$_}{'user'} eq lc($from) } keys %Users;
        delete $Users{$usermud}, delete $cookies->{lc($from)} if($usermud);
        
    }
}

sub check_alarms
{
    # check if any alarms have been reached
    # Parameter: None

    my $t = time();
    my @alarms = grep { $_ < $t } keys %alarms;
#    debug("CA: " . Dumper(\@alarms)) if(@alarms);

    foreach my $a (@alarms)
    {
        foreach my $larm (@{$alarms{$a}})
        {
            if ($larm->{'method'} eq 'cb')
            {
                PerlMonksTickers->send_message('message' => $larm->{'message'},
                                               'user'    => $larm->{'who'});
            }
            elsif ($larm->{'method'} eq 'tell')
            {
                my ($usermud) = grep { $Users{$_}{'user'} eq lc($larm->{'who'}) } 
                  keys %Users;
                if (!$usermud)
                {
                    # User isn't logged in, keep alarm for next time..
                    debug("User " . $larm->{'who'} . " isn't logged in!\n");
                    next;
                }
                my @user = split('@', $usermud, 2);  
                my @args = ($CBUSER, $user[1], 'tell', $user[0], $larm->{'message'});
                $i2->send(@args);
            }
            elsif ($larm->{'method'} eq 'msg')
            {
                PerlMonksTickers->send_message('message' => "/msg [" . 
                                               $larm->{'who'} . "] " . 
                                               $larm->{'message'},
                                               'user'    => $CBUSER);
            }
            undef($larm);
        }
        if (!grep {$_} @{$alarms{$a}})
        {
            delete $alarms{$a};
        }
    }
}

sub check_birthdays
{
    # Check if anyone has a birthday today, and is online
    # Congratulate, and mark as such!
    # Parameters: None

    my $otherusers = PerlMonksTickers->other_users();
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
      localtime(time);
    $mon += 1;
    $year += 1900;

    my @pmbdays = grep { $pm_users{$_}->{'birthday'} &&
                           $pm_users{$_}->{'birthday'}->{'month'} eq $mon &&
                             $pm_users{$_}->{'birthday'}->{'day'} eq $mday }
      keys(%pm_users);

    if (!@pmbdays)
    {
        $pm_users{$_}->{'birthday'}->{'done'} = undef 
          foreach (keys(%pm_users));
    }

    foreach my $pmu (@pmbdays)
    {
        next if($pm_users{$pmu}->{'birthday'}->{'done'});

        if (my ($user) = grep {$otherusers->{lc($_)}} @pmbdays)
        {
            PerlMonksTickers->send_message('message' => 
                                           "/msg Happy Birthday [$user]!",
                                           'user'    => $CBUSER);
        }
        $pm_users{$pmu}->{'birthday'}->{'done'} = 'yes';
    }
    
}

sub show_size
{
    # Show how much memory a particular variable is using
    # Parameter: Variable
    my ($var) = @_;

    my $result;
    my $ans = '';

    if ($var =~ /^\%main::/)
    {
        $result = "You dont wanna do that!";
        return $result;
    }

    if ($var eq 'all')
    {
        foreach my $k (keys %main::)
        {
            next if($k =~ /main/);
            next if($k =~ /::/);
            debug("show_size: $k\n");
            my $eval = "\$ans .= Dumper(\\$k) . \"\\n\" if($k)";
            eval $eval;
        }
    }
    else
    {
        my $eval = "\$ans = 'Size:' . size(\\$var) . ' Total_Size:' . 
                total_size(\\$var) if($var)";
        eval $eval;
    }
    if ($@)
    {
        $result = "Eval failed: $@";
        return $result;
    }
    $result = "Size of $var: $ans";
    return $result;    
}

sub show_eval
{
    # Evaluate something.. Ieks!
    my ($evalstring) = @_;

    my $result;
    
    debug("Evaluating.. $evalstring\n");
    $result = eval $evalstring;
    if ($@)
    {
        $result = "Eval failed: $@";
    }

    return $result;
}

sub show_dump
{
    # Dump the contents of a variable to a users output.
    # Parameter: UserId, Variable
    my ($var) = @_;

    my $result;
    my $ans = '';

    if ($var =~ /^\%main::/)
    {
        $result = "You dont wanna do that!";
        return $result;
    }

    if ($var eq 'all')
    {
        foreach my $k (keys %main::)
        {
            next if($k =~ /main/);
            my $eval = "\$ans .= Dumper(\\$var) . \"\\n\" if($var)";
            eval $eval;
        }
    }
    else
    {
        my $eval = "\$ans .= Dumper(\\$var) . \"\\n\" if($var)";
        eval $eval;
    }
    if ($@)
    {
        $result = "Eval failed: $@";
        return $result;
    }
    $ans =~ s/'password' => '(.*?)'/'password' => '<censored>'/sg if($ans);
    $result = "Contents of $var: $ans";
    return $result;    
}


sub poke_value
{
    # Change an inner variable, dangerous!
    # Parameter: UserId, Variable, Value
    my ($var, $value) = @_;

    my $temp;
    eval "\$temp = $var";
    debug("poke_value: previous value: $temp\n");

    my $eval = "$var = $value";
    eval $eval;
    if ($@)
    {
        $result = "Eval failed: $@";
        return $result;
    }

    return "$var set to $value, was $temp";
}

# Given username, password, verifies that we've got a valid PM account.
# Returns undef if we couldn't reach the server (non-authorative failure)
# Returns 0 if we reached the server, but couldn't log in (authorative failure)
# Returns the cookie, otherwise.
sub auth_pm_user {
    my ($user, $pass) = @_;
    # 2546 is strikefear, which should be quick to load.

    my $resp = $ua->request(
                            GET 'http://perlmonks.org/?node_id=2546&op=login' .
                            '&user=' . uri_escape($user) .
                            '&passwd=' . uri_escape($pass) 
                           );
#    debug(Dumper($resp));
    if (!$resp->is_success) {
        return undef;
    } 
    my $cookie = $resp->header('set-cookie');
 
    # If it isn't defined, then it doesn't exist, meaning we fetched the page OK,
    # but couldn't login.  Assume this is an authoratitive error -- it could be
    # that Everything code died in a way that gives a page with an error, not a 
    # 500, but ignore that possibilty for now.
    if (!defined $resp->header('set-cookie')) {
        return 0;
    }
 
    # The set-cookie header is "NAME=VALUE; ...", where ... is a lot of optional
    # parameters that we don't care about.
    ($cookie) = split(/;/, $cookie, 2);
# return $cookie;

    my $cj = HTTP::Cookies->new();
    $cj->extract_cookies($resp);
# debug(Dumper($cj));

    $cookies->{$user} = $cj if($cj);

    return $cookie;
}

sub check_ip
{
    # If PerlMud is left running and the router changes IP, re-ping all muds
    # Parameter: None

    my $ip = scalar gethostbyname('desert-island.dynodns.net');
    return if(!$ip);
    my $newhostip = inet_ntoa($ip);
    if ($newhostip && $newhostip ne $hostip)
    {
        debug("New HostIP: $newhostip\n");
        $hostip = $newhostip;
        $i2->send('perlmonks', 'all', 'ping');
    }
}

sub secs2str
{
    # Takes a value in seconds and outputs a string with hours, mins, secs etc.
    # Parameter: Seconds
    my ($secs) = @_;

    my $minsecs = 60;
    my $hoursecs = 3600;
    my $daysecs = 3600*24;

    my ($ansdays, $anshours, $ansmins) = (0,0,0);
    if ($secs >= $daysecs)
    {
        $ansdays = int($secs / $daysecs);
        $secs = $secs - ($ansdays * $daysecs);
    }
    if ($secs >= $hoursecs)
    {
        $anshours = int($secs / $hoursecs);
        $secs = $secs - ($anshours * $hoursecs);
    }
    if ($secs >= $minsecs)
    {
        $ansmins = int($secs / $minsecs);
        $secs = $secs - ($ansmins * $minsecs);
    }

    my $answer .= sprintf("%d days %02d:%02d:%02d", 
                          $ansdays, $anshours, $ansmins, $secs);
    return $answer;
    
}

sub getlocaltime
{
    # Convert an epoch time to a localised time, or GMT if no timezone set
    # Parameter: Time, User
    my ($time, $user) = @_;

    my $tz = $pm_users{lc($user)}->{'timezone'} || 'GMT';
    return ctime($time, $tz) . $tz;
}

sub post_im2_bio
{
    # Get im2s bio from ../data/im2homenode.html, 
    # add pool-players list, add 300_000th node guesses, and post
    # Parameter: None

    my $datadir = $LOGDIR;
    $datadir =~ s/log/data/;
    open(BIO, '/home/castaway/perl/data' . "/im2homenode.html") || return;
    my $bio = join("", <BIO>);
    close(BIO);

    my @pusers = grep {$pm_users{$_}->{'pool'}} keys %pm_users;
    debug(Dumper(\@pusers));

    foreach my $user (sort(@pusers))
    {
        $bio .= "<br>[$user]";
    }
      $bio .= <<'HTML';
  <p>
  <table width="99%">
  <tr>
  <td bgcolor="#000066"><font color="#FFFFFF"><b>The 500_000th node will appear on:</b></font></td>
  </tr>
  </table>
To submit guesses when the 500.000th node will appear: <code>/msg im2 guess 500_000 <datetime></code><br />
Guesses will be parsed with Time::ParseDate::parsedate, and will assume GMT per default.<br />
HTML

     @pusers = grep {$pm_users{$_}->{'500000'}} keys %pm_users;
     $bio .= <<HTML;
 <table>
  <tr>
   <td>
    <b>User</b>
   </td>
   <td>
    <b>Guessed</b>
   </td>
   <td>
    <b>On</b>
   </td>
  </tr>
HTML

     foreach my $user (sort(@pusers))
     {
         $bio .= "<tr><td>[$user]</td><td><b>".$pm_users{$user}->{'500000'}[0]." GMT </b></td><td>" . $pm_users{$user}->{'500000'}[1] . " GMT </td></tr>";
     }
     $bio .= "</table>";

    PerlMonksTickers->post_bio('user' => $CBUSER,
                               'node_id' => '243505',
                               'doctext' => $bio);

}

sub update_birthdays
{
    # Grabs Birthdays from PM Stats and updates the pm_users hash
    # Parameter: None

    my $response = $ua->request(HTTP::Request->new(GET => 'http://tinymicros.com/pm/index.php?goto=upcomingbirthdays&sortopt=3&sortlist=5&'));
    if ($response->is_success) 
    {
        my $stuff = HTML::TableContentParser->new();
        my $table_data = $stuff->parse($response->content);
        foreach my $table (@$table_data) 
        {
            next unless exists $table->{headers} && 
              grep 'Current Age' , @{$table->{headers}};
          ROW:
            foreach my $row (@{$table->{rows}}) 
            { 
                next unless (exists $row->{cells});
                my @fields;
                foreach my $cell (@{$row->{cells}}) 
                { 
                    # assumes that monks in list is not part of a monk's name and will not change
                    next ROW if (exists $cell->{data} && $cell->{data} =~ /monks in list/);
                    $cell->{data} =~ s|</?NOBR>||g;
                    push @fields , $cell->{data};
                }
                # Here is where you would update database instead of printing it
#               printf("%-9s:  %s\n","Node ID",$fields[0]);
#               printf("%-9s:  %s\n","Link",$fields[1]);
                my $link = HTML::TokeParser->new(\$fields[1]);
                my $name = $link->get_trimmed_text("/a");
                next if(!$pm_users{lc($name)});

#               printf("%-9s:  %s\n","Name",$name);
#               printf("%-9s:  %s\n","Birthday",$fields[2]);
#               printf("%-9s:  %s\n","Days Left",$fields[3]);
#               printf("%-9s:  %s\n\n","Age",$fields[4]);

                my ($year, $month, $day) = split('-', $fields[2]);

                # Age is only the age at the time we grabbed the info!
                $pm_users{lc($name)}->{'birthday'} = {'month' => $month,
                                                      'day'   => $day,
                                                      'year'  => $year,
                                                      'age'   => $fields[4]};
                $pm_users{lc($name)}->{'node_id'} = $fields[0];
            }
            # Saftey, but only 1 table should have a Current Age header
            last;           
        }
    }
    else 
    {
        # You probably want to do something else if the page isn't available
#       print "Data unavailable\n";    
    }    

}

sub parsecblinks
{
    # collect http:// from CB
    my ($data) = @_;
    
    my $ddate = parsedate($data->{'time'}, 
			  ZONE => 'EST5EDT',
			  WHOLE => 1);
    debug("ParseCBLinks: can't parse $data->{'time'}!\n"), return if(!$ddate);
    my @localt = localtime($ddate);
    my $newtime =  strftime("%Y-%m-%d %H:%M:%S", @localt); 
    debug("ParseCBLinks: Got date: $newtime\n");
          
    my $stm = $dbh->prepare_cached("INSERT INTO links (url, author, type, comment, time) VALUES (?, ?, ?, ?, ?)") or debug("Can't prepare insert to links: $DBI::errstr");

    while($data->{'text'} =~ /\[(http:\/\/[^ ]+)\]/g)
    {
        my ($url, $comment) = split(/\|/, $1);

        debug("ParseCBLinks: $url, $comment, $data->{'author'}, $newtime\n");
        $stm->execute($url, 
                      $data->{'author'},
                      'url', 
                      ($comment || ''), 
                      $newtime) 
            or debug("Can't execute insert to links: $DBI::errstr");

#         push(@{$links{$url}}, {'author' => $data->{'author'},
#                                'type' => 'url',
#                                'comment' => $comment ? $comment : '',
#                                'time' => $newtime});
    }
}

#####
# Debug ausgaben
#
sub debug
{
    $DEBUG = 'log';
    # Parameter: None.
    if ($DEBUG eq 'on')
    {
        print STDOUT "$_[0]";
    } elsif ($DEBUG eq 'log')
    {
        # Append text to debug log
        my $filename = $LOGDIR . '/debug_cbgateway.log';
        
        open(DEBUGFILE, ">>", $filename) or die "Can't open $filename: $!\n";
        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
          localtime(time);
        my $time = sprintf("%02d.%02d %02d:%02d:%02d ", 
                           $mday,$mon + 1,$hour,$min,$sec) . $_[0];
        print DEBUGFILE "$time";
        close(DEBUGFILE);
    }
}

sub dumper
{
    my ($var, $name) = @_;

    return Data::Dumper->new([$var],[qw(name)])->Purity(1)->Dump(),"\n";

#[Perlmonks Demerphq@PerlMonks] Please remember to set Purity(1). <Code>print Data::Dumper->new([$var],[qw(varname)])->Purity(1)->Dump(),"\n";</code> is the form

}

sub add_to_langcb
{
    my ($author, $text) = @_;
    my @time = gmtime();
    my $time = strftime("%Y-%m-%d %H:%M:%S", @time);

    debug("Add to langcb: $author $time $text\n");

    $httpoutput->put({'type' => 'local',
                      'author' => $author,
                      'time' => $time,
                      'text' => $text});

    if ($text =~ s/^\/me //i)
    {
        $langcb->put([$author, 'all', 'channel', 'perlmonks-de',
                 'emote', $text]);
        $telnetoutput->put({'type' => 'langcb', 
                            'text' => $author . " " . $text});
    }
    elsif ($text =~ s/^\/me\'s //i)
    {
        $langcb->put([$author, 'all', 'channel', 'perlmonks-de',
                 'gemote', $text]);
        $telnetoutput->put({'type' => 'langcb',
                            'text' => $author . "'s " . $text});
    }
    else
    {
        $langcb->put([$author, 'all', 'channel', 'perlmonks-de',
                 '', $text]);
        $telnetoutput->put({'type' => 'langcb',
                            'text' => $author . ": " . $text});
    }
}

sub start_telnet_server
{
    # Start a telnet server listening on port 4040, accept connections
    # Send all entries in $telnetoutput to the connected clients
    # Parameter: None

    require Net::Telnet::Options;
    require Text::Wrap;
    require Linux::Pid;
    Text::Wrap->import();
    $Text::Wrap::huge = 'overflow';
    $Text::Wrap::separator = "\r\n";

    $telnetpid = Linux::Pid::getpid();
    my $MAXUSERS = 10;
    my @telnetclients = ();

    my $sel = IO::Select->new();
#    my  $server = IO::Socket::INET->new( LocalAddr  => '192.168.1.1',
    my  $server = IO::Socket::INET->new( 
                                        LocalPort  => 4040,
                                        Proto      => 'tcp',
                                        Listen     => 1,
                                        Reuse      => 1,
                                        Timeout    => 60);
    die "Can't listen on 4040 ($!)" unless $server;

    $sel->add($server);

    while (1)
    {
        my @handles = $sel->can_read(5);
#        debug("Looping.. \n");
        foreach $handle (@handles)
        {
            my $ind;
            debug("Handle: $handle \n");
            if ($handle == $server)
            {
                my $sockclient = $server->accept();
                debug("Oops, couldnt accept new connection ($!)\n") 
                    if(!$sockclient);
                if (@telnetclients >= $MAXUSERS)
                {
                    debug("E_TOO_MANY_CLIENTS!\n");
                    print $sockclient "Sorry, we're full!\r\n";
                    $sockclient->close();
                    next;
                }
                $sel->add($sockclient);
                my $newind = @telnetclients;

                $telnetclients[$newind]{'socket'} = $sockclient;
                $telnetclients[$newind]{'width'} = 79;
                $telnetclients[$newind]{'height'} = 24;
                $telnetclients[$newind]{'options'} = 
                    Net::Telnet::Options->new();
                $telnetclients[$newind]{'options'}->
                    activeDoOption('NAWS' => {'SB' => sub {
                        return if($telnetclients[$newind]{'width'} == 0);
                        my ($cmd, $subcmd, $data, $pos) = @_;
                        debug ("NAWS SB: $cmd\n");
                        return unless($cmd eq 'IS');
                        my @sizes = unpack('nn', $subcmd);
                        debug ("NAWS width, height: @sizes\n");
                        debug ("Index: $newind\n");
                        $telnetclients[$newind]{'width'} = $sizes[0] - 1;
                        $telnetclients[$newind]{'height'} = $sizes[1] - 1;
                        debug ("Set: $newind, " . Dumper($telnetclients[$newind]) . "\n");
                        return;
                    } } );    
                # Throw options at client :)
                $telnetclients[$newind]{'options'}->
                    doActiveOptions($sockclient);

                debug("New Telnet connection: $sockclient!\n");
                debug("From: " . $sockclient->peerhost() . "\n");
                $telnetclients[$newind]{'ip'} = $sockclient->peerhost();
                print_client($telnetclients[$newind], 
                             "Welcome to [$CBUSER]s CB Multiplexer!\r\n");
                print_client($telnetclients[$newind], 
                             "Supported Telnet Options: NAWS.\r\n");
                print_client($telnetclients[$newind], 
                             ".oO( But no colour, or, much of anything else really..)\r\n");
                print_client($telnetclients[$newind], 
                             "To login to PerlMonks, type: auth ]yourname[ yourpassword\r\n");
                print_client($telnetclients[$newind], 
                             "(Replacing 'yourname' and 'yourpassword' with appropriate values)\r\n");
                $telnetclients[$newind]{'user'} = '';
                lock(%stats);
                $stats{'im2users'}++;
                $stats{'im2logins'}++;
            }
            elsif (($ind) = grep($telnetclients[$_]{'socket'} == $handle, 
                                 (0..$#telnetclients)))
            {
#                my $line = <$handle>;
                recv($handle, $line, 1024, 0);
                if($telnetclients[$_]{'debug'})
                {
                    debug("Got:$line:\n");
                }

                debug("Huh?: $!\n") if($!);
                if (!$line || $!)
                {
                    debug("Telnet connection closed: $handle!\n");
                    debug("From: " . $handle->peerhost() . "\n") 
                        if($handle->peerhost());
                    $sel->remove($handle);
                    $handle->close();
                    lock (%stats);
                    $stats{'im2users'}--;
                    $stats{'im2authusers'}-- if($telnetclients[$ind]{'user'});
                    splice(@telnetclients, $ind, 1);
                    next;
                }
#                debug("TelnetSr-Client".Dumper($telnetclients[$ind])."\n");
#                debug("TelnetSr-Line: $line\n");
                my $origline = $line;
                debug("Line from: $ind\n");
                $line = $telnetclients[$ind]{'options'}->
                    answerTelnetOpts($handle, $line);
                debug("Line length: " . length($line) . "\n");

                if($line !~ /[\r\n]/s)
                {
                    # Icky windows client workaround!
                    $telnetclients[$ind]{'currentline'} .= $line;
                    if($telnetclients[$ind]{'ip'} =~ /^192\.168\./)
                    {
                        debug("Got: $origline\n");
                        debug("Current line: " . $telnetclients[$ind]{'currentline'} . "\n");
                    }
                    next;
                }
                if($telnetclients[$ind]{'currentline'})
                {
                    $line = $telnetclients[$ind]{'currentline'} . $line;
                    $telnetclients[$ind]{'currentline'} = '';
                }
                $line = convert_backspace($line);
                $line =~ s/\p{IsC}//g;
                $line =~ s/[\r\n]//g;
#               debug("TelnetSr-Line: $line\n") if $main::DEBUGGING;
#                debug("TelnetSr-Line: $line\n");
                if ($line =~ /^auth \](.*?)\[ (.*)$/)
                {
                    my $userauth = auth_pm_user($1, $2);
                    if (!$userauth)
                    {
                        print_client($telnetclients[$ind], 
                                     "Sorry, I can't seem to authenticate you!\r\n");
                        next;
                    }
                    $telnetclients[$ind]{'user'} = $1;
                    $telnetclients[$ind]{'time'} = time();
                    print_client($telnetclients[$ind], "Found you!\r\n");
                    $newuser->put({user => $telnetclients[$ind]{'user'},
                                   type => 'telnet',
                                   cookie => $cookies->{$telnetclients[$ind]{'user'}}});
                    lock(%stats);
                    $stats{'im2authusers'}++;
                    next;
                }

                if ($telnetclients[$ind]{'user'})
                {
#                    debug("(User): " . Dumper($telnetclients[$ind]). "\n");
                    parse_mp_command($telnetclients[$ind], $1), next 
                        if($line =~ m|^/im2\s?(.*)|);

                    add_to_langcb($telnetclients[$ind]{'user'},
                                  $1), next
                                      if($line =~ m|/cbl (.*)|);

                    if (time() - $telnetclients[$ind]{'time'} >= 0.5)
                    { 
                        PerlMonksTickers->send_message('message' => $line,
                                                       'user' => $telnetclients[$ind]{'user'}); 
                    }
                    else
                    {
                        my $sock = $telnetclients[$ind]{'socket'};
                        print_client($telnetclients[$ind], "Not so fast!\r\n"); 
                    }
                    print_client($telnetclients[$ind], "You typed: (" .
                                 length($origline) . "): $line\r\n") 
                        if($telnetclients[$ind]{'echo'});
                }
                else
                {
                    my $sock = $telnetclients[$ind]{'socket'};
#                    debug("(Not User1)\n");
                    if($sock && !$sock->connected())
                    {
                        debug("Oops, not connected!\n");
                        debug("Telnet connection closed: $handle!\n");
                        debug("From: " . $handle->peerhost() . "\n") 
                            if($handle->peerhost());
                        $sel->remove($handle);
                        $handle->close();
                        lock (%stats);
                        $stats{'im2users'}--;
                        $stats{'im2authusers'}-- if($telnetclients[$ind]{'user'});
                        splice(@telnetclients, $ind, 1);
                        next;
                    }
                    else
                    {
                        print_client($telnetclients[$ind], 
                                     "You're not authorised bub!\r\n"); 
                    }
#                    debug("(Not User2)\n");
                }
                $telnetclients[$ind]{'time'} = time();

            }
        }
        my $toprint;
        while ($toprint = $telnetoutput->take_dontwait())
        {
#            $toprint =~ s/[^ -~]//g;
            $toprint->{'text'} =~ s/\xFF/\xFF\xFF/g;
            if($toprint->{'type'} eq 'multi')
            {
                debug("To Client: ". Dumper($toprint));
#                debug("To Client: ". Dumper(\@telnetclients));
                my ($pc) = grep($_->{'user'} eq $toprint->{'who'}, @telnetclients);
                debug("To Client: ". Dumper($pc));
                print_client($pc, 'im2:' . $toprint->{'text'}."\r\n");
                next;
            }
            $toprint->{'text'} =~ s/\p{IsC}//g;
            foreach (0..$#telnetclients)
            {
                next if($toprint->{'type'} eq 'langcb' && 
                   !$telnetclients[$_]->{'lang'}); 
                print_client($telnetclients[$_], $toprint->{'text'}."\r\n");
            }
        }
        while ($toprint = $newestnodes->take_dontwait())
        {
#            $toprint =~ s/[^ -~]//g;
            $toprint =~ s/\p{IsC}//g;
            foreach (0..$#telnetclients)
            {
                print_client($telnetclients[$_], $toprint. "\r\n");
            }
        }
        if ($telnetfinish)
        {
            foreach (0..$#telnetclients)
            {
                print_client($telnetclients[$_], "Going down, bye!\r\n");
                $s->close();
                $sel->remove($s);
            }
            return 1;
        }
        $telnetcurrent = time();
    }   
    return 1;
}

sub print_client
{
    # Parameter: telnetclienthashref, Text
    my ($tchash, $text) = @_;
    my $sock = $tchash->{'socket'};
    $Text::Wrap::columns = $tchash->{'width'};

#    debug(Dumper($tchash));

    return if(!$sock); # heh?
    
    $tchash->{'width'} ? 
        $sock->print(wrap("", "", $text)) : 
        $sock->print($text);
    # $sock->print($text);
}

sub parse_mp_command
{
    # do local commands..
    # Parameter: telnetclienthashref, command
    my ($tchash, $command) = @_;

    if($command eq 'echo on')
    {
        $tchash->{'echo'} = 1;
    }
    elsif($command eq 'echo off')
    {
        $tchash->{'echo'} = 0;
    }
    elsif($command eq 'wrap off')
    {
        $tchash->{'width'} = 0;
    }
    elsif($command =~ /^wrap (\d+)$/)
    {
        $tchash->{'width'} = $1;
    }
    elsif($command eq 'wrap on')
    {
        $tchash->{'width'} = 79;
    }
    elsif($command =~ /^msgs\s?(on|off)$/)
    {
        $messtomain->put({type => 'msgs',
                          user => $tchash->{'user'}});
    }
    elsif($command eq 'debug')
    {
        $tchash->{'debug'} = !$tchash->{'debug'};
    }
    elsif($command eq 'lang')
    {
        $tchash->{'lang'} = !$tchash->{'lang'};
    }
    else
    {
        $messtomain->put({type => 'question',
                          user => $tchash->{'user'}, 
                          text => $command});
    }
}

sub ignore_options
{
    # remove all telnet options from incoming text
    # Parameter: Text
    my ($text) = @_;

    my $chIAC = chr(255);
    my $chDONT = chr(254);
    my $chDO = chr(253);
    my $chWONT = chr(252);
    my $chWILL = chr(251);
    my $chSB = chr(250);
    my $chSE = chr(240);
    my $chSEND = chr(1);
    my $chIS = chr(0);
    my $chEOR = chr(239);
    my $pos = -1;
    while (($pos = index($text, $chIAC, $pos)) > -1)
    {
        my $nextchar = substr($text, $pos + 1, 1);
        if (!length($nextchar))
        {
            last;
        }
        if ($nextchar eq $chIAC)
        {
            substr($text, $pos, 1) = '';
            $pos++;
        }
        elsif ($nextchar =~ /($chDONT|$chDO|$chWONT|$chWILL)/)
        {
            substr($text, $pos, 3) = '';
        }
        elsif ($nextchar eq $chSB)
        {
            my $endpos = index($text, $chSE, $pos);
            substr($text, $pos, $endpos - $pos + 1) = '';
        }
        elsif ($nextchar eq $chEOR)
        {
            substr($text, $pos, 2) = '';
        }
        else
        {
            substr($text, $pos, 2) = '';
        }
    }
    return $text;
}

sub convert_backspace
{
    # Windows Telnet sends backspace + delete chars extra, parse correct text
    # (Only if no linemode??)
    # Parameter: UserId, Text
    my ($text) = @_;

    my $pos = index($text, chr(8));
    while ($pos > 0)
    {
        substr($text, $pos - 1, 2) = '';
        $pos = index($text, chr(8));
    }

    $pos = index($text, chr(127));
    while ($pos > 0)
    {
        substr($text, $pos-1, 2) = '';
        $pos = index($text, chr(127));
    }

#     while ($pos >= 0)
#     {
#         substr($text, $pos, 2) = '';
#         $pos = index($text, chr(127));
#     }

    return $text;
}

my $httpcookies = {};
sub start_http_server
{
    # Start an HTTP server on port 4041, accepting connections
    # output three 'files', publicchatter, privatemessages, and otherusers
    # Incoming chatter: Thread::Conveyor - $httpoutput
    # 'pushing'? (continuous document)
    # Parameter: None

    my $MAXUSERS = 30;
    my @httpclients = ();
    my $httpserv = HTTP::Daemon->new(LocalPort => 4041,
                                     Reuse     => 1,
                                     Listen    => 10,
                                     Timeout   => 60);
    die "Can't start HTTP Daemon on 4041 ($!)" unless $httpserv;
#    print "Please contact me at: <URL:", $d->url, ">\n";
    my $httpselect = IO::Select->new();
    $httpselect->add($httpserv);

    while (1)
    {
#        debug("Looping.. \n"); - yes, it does!
        my @handles = $httpselect->can_read(5);
        foreach $handle (@handles)
        {
            my $ind;
            debug("Handle: $handle\n");
            if($handle == $httpserv)
            {
                my $hclient = $httpserv->accept();
                debug("Accepted new HTTP connection from: " . 
                      $hclient->peerhost() . "\n");
                
                if(@httpclients >= $MAXUSERS)
                {
                    debug("E_TOO_MANY_HTTP_CLIENTS!\n");
                    $hclient->send_error(RC_SERVICE_UNAVAILABLE);
                    $hclient->close();
                    next;
                }
                $httpselect->add($hclient);
                my $newind = @httpclients;
                $httpclients[$newind]{'socket'} = $hclient;
                $httpclients[$newind]{'ip'} = $hclient->peerhost();
                $httpclients[$newind]{'last'} = time();
            }
            elsif(($ind) = grep($httpclients[$_]{'socket'} == $handle,
                                (0..$#httpclients)))
            {
#                debug("Found client: $ind\n");
                my $request = $handle->get_request();
                if(!defined($request))
                {
                    debug("Buggy request: " . $handle->reason . "\n");
#                    $handle->send_error(RC_BAD_REQUEST);
                    $httpselect->remove($handle);
                    $handle->close();
                    splice(@httpclients, $ind, 1);
                    next;
                }
#                debug("Request: " . Dumper($request) . "\n");
                debug("User-Agent: " . $request->header('user-agent') . "\n");
#                debug("Headers: " . Dumper($request) . "\n") 
#                    if($httpclients[$ind]{'ip'} eq '127.0.0.1');
#                if($request->method eq 'GET' and 
#                   my $funcbase = isoururl($request->uri))
                if(my $funcbase = isoururl($request->uri, $request->content))
                {
                    $httpclients[$ind]{'last'} = time();
                    my $response = HTTP::Response->new();
                    $response->code(200);
                    $response->content_type("text/html");
#                    $response->content_encoding("ISO-8859-1"); # ??
                    my $cookie;
                    if($cookie = $request->header('cookie'))
                    {
                        ($cookie) = split(/;/, $cookie, 2);
                    }

#                    debug("Got cookie! $cookie\n") if($cookie);

                    my ($content, $lastmod, $cookie) = 
                        $funcbase->[0]->($httpclients[$ind], 
                                         $funcbase->[1], $cookie);
                    $lastmod ||=0;
                    $response->header('set-cookie', $cookie) if($cookie);
#                    debug("Sent cookie! $cookie\n") if($cookie);
#                    debug("Set cookie $httpcookies->{'cookie'}\n") 
#                        if($cookie);
                    $response->last_modified($lastmod);
                    $response->content($content);
                    $handle->send_response($response);
#                    debug("Sent output to " . Dumper($handle) . "\n");
                }
                else
                {
                    debug("Unknown URI: " . $request->uri->path . "\n");
                    $handle->send_error(RC_FORBIDDEN);
                }

                if(!$request->headers->header('connection') || 
                   $request->headers->header('connection') !~ /\bkeep-alive\b/i)
                {
                    $httpselect->remove($handle);
                    $handle->close;
                    splice(@httpclients, $ind, 1);
                    undef($handle);
                }
            }
            else
            {
                debug("Some other handle? $handle\n");
            }
            if ($telnetfinish)
            {
                foreach (0..$#httpclients)
                {
                    my $h = $httpclients[$_]{'socket'};
                    $s->close();
                    $sel->remove($s);
                }
                return 1;
            }
	    my @deadclients = 
		grep { $httpclients[$_]->{'last'} < time() - 180 }
	           (0..$#httpclients);
            foreach my $cli (@deadclients)
	    {
		my $h = $httpclients[$cli]{'socket'};
		$httpselect->remove($h);
		$h->close;
		splice(@httpclients, $cli, 1);
		undef($h);
	    }

#            debug("End loop\n");
        }
    }
    return 1;
}

sub isoururl
{
    # Is this a url we care about?
    my $url = shift;

    my %urls = ('/publicchatter' => sub { getchatter('public', @_) }, 
                '/localchatter'  => sub { getchatter('local', @_) }, 
                '/talkbar'       => \&gettalkbar,
                '/frameset'      => \&getframeset,
                '/post'          => \&postchatter,
                '/login'         => \&loginuser
                );

    # eg: /publicchatter?base=http://perlmonks.org
    
    
    # $url =~ /^\/(\w+)\?base=(http.+perlmonks\.(org|com|net))$/
#    if($url =~ m|^/(\w+)(?:\?base=([^&;]*))?$| && $urls{$1})

    if($urls{$url->path})
    {
        my %options;
        my $input = $url->query || shift;
        if($input)
        {
            # uri_unescape is broken, and doesn't do +es.
            %options = map { tr/+/ /; $_=uri_unescape($_); }
                             map ( split(/=/, $_, 2), 
                                   split(/[;&]/, $input) );
        }
#        debug("page: $1, url: $2\n");
#        debug("query: " . $url->query . "\n");
        debug(Dumper(\%options));

        $options{'base'} ||= 'http://perlmonks.org';

        return [$urls{$url->path}, \%options];
    }
    return undef;
}

{
    my %last10lines = ('public' => [],
                       'local' => []
                      );
    my %lastmodified = ('public' => 0,
                        'local' => 0 
                       );

    sub getchatter
    {
        # Update @last10lines to the last 10 lines of $httpoutput;
        # (author, time in EST5EDT,text) 
        # encode entities in text
        # htmlify
        my $type = shift();
        my $client  = shift();
        my $BASEURL = shift()->{'base'};

        if(!%last10lines)
        {
            %last10lines = ('public' => [],
                            'local' => []
                            );
            %lastmodified = ('public' => 0,
                             'local' => 0 
                             );
        }            

        my $changed = 0;
        my @httpother = ();
        while($input = $httpoutput->take_dontwait())
        {
            $changed = 1;
            if($input->{'type'} eq $type)
            {
                debug("adding: " . Dumper($input) . "\n");
                @{$last10lines{$type}} 
                = splice(@{$last10lines{$type}}, -10) 
                    if(@{$last10lines{$type}} >= 10);
                my $ind = @{$last10lines{$type}};
#            $out = PerlMonks::HTML::htmlscreen($out, 1,
#                                               $PerlMonks::HTML::APPROVED_CHATTER);
#            my $out = $input->[2];

#                my $out = HTML::Entities::decode($input->{'text'});
		my $out = $input->{'text'};
                if ($out =~ s|^/me (.*)$|$1|i) 
                {
                    $out = '<i>['.$input->{'author'}."] $out</i>";
                } 
                elsif ($out =~ s|^/me(.*)$|$1|i) 
                {
                    $out = '<i>['.$input->{'author'}."]'s $out</i>";
                } 
                else 
                {
                    $out = '<b>&lt;</b>['.$input->{'author'}.']<b>&gt;</b> ' . $out;
                }

                $last10lines{$type}[$ind] = $out;

            }
            else
            {
                push @httpother, $input;
            }
        }
        $httpoutput->put($_) foreach (@httpother);
	
        $lastmodified->{$type} = time if($changed);

        my $html = '<html><head><title>IM2: ' . ucfirst($type) . 
            ' Chatter</title>' . "\n";
        $html .= '<base target="_new" />' . "\n";
        $html .= '<meta http-equiv="refresh" content="5"   />' . "\n";
        $html .= '</head><body>' . "\n";
        foreach(@{$last10lines{$type}})
        {
 #           local $PerlMonks::HTML::pmrooturl=$BASEURL;
#	    debug("In: $_\n");
            my $out = PerlMonks::HTML::pmhtml2realhtml($_);
#            $out = PerlMonks::HTML::htmlscreen($out, 1,
#		$PerlMonks::HTML::APPROVED_CHATTER);
#	    debug("Out: $_\n");
            $html .= $out . "<br />\n";
        }

        $html .= '</body></html>';

        return ($html, $lastmodified->{$type});
    }        
# <b>&lt;</b><a href="/index.pl?node_id=221638" title="Posted :59:30 (0:12 before next)">castaway</a><b>&gt;</b> a) use 2.9, b) get 3.3<!-- --></b></i></u></tt></em></strong><br />
# <b>&lt;</b><a href="/index.pl?node_id=221638" title="Posted :59:42 (1:16 ago)">castaway</a><b>&gt;</b> or that<!-- --></b></i></u></tt></em></strong><br />
}

sub getframeset
{
    # Frameset ala FPC, private/talk/otherusers -> PM, chatter from us
    my $client = shift;
    my $options = shift;
    my $BASEURL = $options->{'base'};
    my $talkopt = $options->{'talksimple'} || 0;
    my $base = uri_escape($BASEURL);

    my $talkbar = $talkopt ? 'all+mouth+and+no+ears' : 'ad_and_talk';

#    <frame src="/talkbar?base=$base" marginwidth="0" marginheight="0" />
#    <link rel="icon" href="/favicon.ico" />
    my $frameset = <<"HTML";
<html>
  <head>
    <title>IM2 FullPage Chat</title>   
  </head>
  <frameset rows="160,*">
    <frame src="$BASEURL/?node=$talkbar;displaytype=raw" marginwidth="0" marginheight="0" />
    <frameset cols="80%,20%">
      <frameset rows="25%,75%">
<!--      <frameset rows="25%,35%,7%,33%"> -->
        <frame src="$BASEURL/index.pl?displaytype=raw&type=superdoc&node=privatemessages" />
        <frame src="/publicchatter?base=$base" />
<!--        <frame src="/talkbar?base=$base" /> -->
<!--        <frame src="/localchatter" /> -->
      </frameset>
      <frame src="$BASEURL/index.pl?displaytype=raw&node=showotherusers" />
    </frameset>
  <noframes>
    <p>No Frames?  <a href="/publicchatter?base=$base">Chat Here</a></p>
   </noframes>
  </frameset>
</html>
HTML

    return $frameset;
}

sub gettalkbar
{
    my $client = shift;
    my $BASEURL = shift()->{'base'};

    my $talkbar = <<"HTML";
<html>
   <head>
    <title>talkbar</title>
  </head>

<body>
   <form method="post" action="/post" enctype="application/x-www-form-urlencoded">
      <input type="text" name="message"  size=40 maxlength=240 />
      <input type="submit" name="message_send" value="talk" />
   </form>
</body>
</html>
HTML

#      <input type="image" name="message_send" src="$BASEURL/images/bluetalk.gif" value="talk" />
    return $talkbar;
}

sub loginuser
{
    # Verify/Login user to PM, set cookie?
    # user=XX passwd=XX
    my $client = shift();
    my $options = shift();
    my $cookie = shift();

    my $auth = auth_pm_user($options->{'user'}, $options->{'passwd'});
    push(@{$httpcookies{$client->{'ip'}}}, $auth);

    my $loginresp = << "HTML";
<html>
  <head>
    <title>Login</title>
  </head>

<body>
HTML
    
    $loginresp .= $auth ? "Success!" : "Failed";
    $loginresp .= "</body></html>";

    $cookie = $auth . "; path=/; max-age=315360000";
    return ($loginresp, '', $cookie);
}

sub postchatter
{
    # Post incoming local chatter to the local CB
    # Text: = message
    my $client = shift();
    my $options = shift();
    my $cookie = shift();

    debug("Cookies: $cookie, " . $client->{'cookie'} . "\n");

    if(defined($cookie) && 
       grep(/\Q$cookie\E/, @{$httpcookies{$client->{'ip'}}}))
    {
        debug("Cookie: $cookie\n");
        my ($user) = $cookie =~ /^userpass=(.*?)\%25/;
        debug("User: $user\n");
        add_to_langcb($user,
                      $options->{'message'}
                      );
    }

    return gettalkbar($client, $options, $cookie);
}

BEGIN {
    # use strict; my %pm_users; our %karma;
    package IM2::Chatter::Callbacks;
    use Regexp::Common;
    use Data::Dumper;

#    my $user_re     = qr< (\w\w+) | ( \[ ..+? \] ) >x;
    my $user_re     = qr< (\w\w+) | ( \[ [^]]{2,}? \] ) >x;
    my $complex_re  = qr/ ( $RE{balanced}{-parens => '()'} | $RE{balanced}{-parens => '[]'}  ) /x;
    my $vote_re     = qr< \+\+ | -- (?: \s+ | $ ) >x;
    my $comment_re  = qr{ (?: (?: \s* <!-- \s* (.*?) \s* --> ) | (?: \s* \043 \s* (.*) $ ) )? }x;

    my $req_re      = qr< (?: $user_re | $complex_re ) ( $vote_re ) >x;

    sub grok_karma {
      local $_ = $_[0];

      my($item, $direction, $comment)
        = grep defined, m< $req_re ($comment_re) >x;
  
      ## make sure we don't look at this ITEM again
      $_[0]    =~ s{ \Q$item\E \Q$direction\E $comment_re }()xg;
  
      ## drop grouping () but keep [] for shortcuts
      $item    =~ s{ (?: \( \s* | \s* \) ) }()gx;

      ## deal single char ITEMs instead of messing with $complex_re
      return if length $item <= 1;
  
      $comment =~ s{(?:^(?:\s*#\s*|\s*<!--\s*))|(?:-->$)?}()g;
  
      ## munge shortcut
      if( $item =~ $RE{balanced}{-parens => '[]'} ) {
        $item    =~ s{ \| ( [^\]]+ ) \] }(])x;
        $comment = $1 if ( not defined $comment or  length $comment == 0 )
                           and defined $1       and length $1;
        $item    =~ s{ ^ \[ | \] $ }()gx
          if exists $pm_users{lc( ($item =~ /^ \[ ([^\]]+) \] $/x)[0] ) };
      }

      return $item, $direction, $comment;
    }

    sub karmic_type {
      my($item, $author) = @_;

      my $default = { value => 0, comments => {}, min => 0, max => 0 };
      my $ret;
      if (exists $pm_users{lc $item}) {
        $item = lc $item;

        ## skip self-voters
        return if $item eq lc $author;

        $pm_users{$item}->{karma} = $default
          unless exists $pm_users{$item}->{karma};

        $ret = $pm_users{$item}->{karma};
      } else {
        $main::karma{$item} = $default
          unless exists $main::karma{$item};

        $ret = $main::karma{$item};
      }

      return $ret;
    }

    sub discern_karma 
    {
        return unless $_[0]->{'text'} =~ /$req_re/;

        (local $_, my $author) = @{$_[0]}{qw/ text author/};

        ## drop code before doing anything useful
        s{<(?:tt|code|pre)>(.*?)</(?:tt|code|pre)>}()g;

        while(/$req_re/) {
            my($item, $direction, $comment) = grok_karma $_;
            next unless defined $item;
            
            my $kr = karmic_type $item, $author;
            next unless defined $kr;

            $kr->{value} += $direction eq '++' ? 1 : -1;
            $kr->{max}    = $kr->{value} 
              if $kr->{value} > $kr->{max};
            $kr->{min}    = $kr->{value} 
              if $kr->{value} < $kr->{min};
            $kr->{comments}{$comment}++
              if defined $comment and length $comment;

            main::debug(Dumper($kr));
            $main::karma{'[max]'} = $kr->{max}
              if ($main::karma{'[max]'} > $kr->{max});
            $main::karma{'[min]'} = $kr->{min}
              if ($main::karma{'[min]'} < $kr->{min});

        }

        return 1;
    }
}



# Channel: Chatterbox
# Newest nodes etc -> mud has to apply for the channel?
# (09:07:37) TheOrbTwo: Yeah, status=archived or status=active on the tag.
# (msgbox)
#
## finger <name> XP, Level ?
## finger <me> XP, Level, Last few messages, XP to next level?
# - location from homenode etc?
#
## Remember last msgbox download from each logged in user, and show new msgs as tells??
# show id:// links as titles? PerlMonksTickers??
# [Perlmonks Demerphq@PerlMonks] [castaway] I was think of proposing a new xml ticker that does just that. problem is it is potentially expensive. You can resolve the id:// by using the [id://37150|Node Query XML ticker]
# [Perlmonks Demerphq@PerlMonks] <a href="/index.pl?node_id=37150;nodes=37150">Example</a>
# [Perlmonks Demerphq@PerlMonks] "nodes" is a comma seperated list of node ids.
#
## Take notes? 10 per name?
## help?
#[Perlmonks Im2@PerlMonks] You told Castaway@PerlMud: [2003-04-18 23:08:50] I love you.
#[Perlmonks Im2@PerlMonks] You told Castaway@PerlMud: [2003-04-16 23:24:08] I love you.

## 'You told' ??? replies!?
## - Wasnt formatted as a message, but as a 'cmd:tell' to <name>, which was sent with the usual 'send message' CB fun, and went to the CB!
#
## /me's -> gemote
#18.05 09:44:14 $VAR1 = {
#          '1053211200' => [
#                            {
#                              'who' => 'castaway',
#                              'method' => 'tell',
#                              'message' => 'test'
#                            }
#                          ]
#        };
#
## Accept telnet connects on a port and broadcast CB output to clients?
#
##(node 15848) Error: requested login for user DaFire, but no cookie file found.
# at cbgateway.perl line 522
#(16:07:50) TheOrbTwo: Also, suggestion: If date is missing, use today, or tommorow if that'd be already-happened.  Also, report the date and time the alarm was actualy set for.
#
# infobot-like? collect lines containing perl keywords, and parrot answers..
# - at times of low conversation.. (ratio?)
#
## PM Pool league!
## /msg / tell im2 add me to the pool league
## -> dynamically update homenode list !?
#
# translation??
#
# 2. telnet stream for newest nodes?
#
# PM idea: Links on nodes which show stats - eg level of monk when node was written - data from pm stats?
#
# add alarm: cron syntax, permanent alarms? (every day at 15:45 -> james getting up?)
#
# Oops.. logout when 2 people are logged in as same pm-user bugs, cos the cookie is then gone!
#
# Stats: Add usage of telnet-multiplexer stats? (logins, users.. )
#
# /help, /auth, /history /logout /msgs (latest messages..) /stats ... ?
#
# 
# Net::OSCAR, perlmonkscb, etc!
#
# Global karma max/min? $karma{'[max]'}
#[Perlmonks Bart@PerlMonks] Oh, in case you want to reproduce it: connect, start typing "auth ..." and then disconnect.
#
# ability to add to [im2dev] list ...
#
# improve user-xml-finger info
# delete multiple /msgs at once
# get /msgs for telnet people