A while ago i saw someone in an irc channel making quizzes to people using a Mirc script. So i thought a Perl Bot could do the same job, better. I grabbed
#!/usr/bin/perl -w
#TriviaHam IRC Bot - Helps quizzing in an IRC Channel
#Copyright 2001-2002 Giulio Motta - http://www.giuliomotta.com
#This program is free software; you can redistribute it and/or
#modify it under the terms of the GNU General Public License
#http://www.gnu.org/copyleft/gpl.html
#This program is distributed in the hope that it will be useful,
#but WITHOUT ANY WARRANTY; without even the implied warranty of
#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
#GNU General Public License for more details.
use strict;
use POE;
use POE::Component::IRC;
use Getopt::Std;
my %args;
getopt('spnucioP', \%args);
my $nick = $args{n} || 'TriviaHam';
my $server = $args{s} || 'irc.slashnet.org';
my $port = $args{p} || 6667;
my $username = $args{u} || 'trivia';
my $ircname = $args{i} || "I'm TriviaHam Master";
my $channel = "#" . $args{c} if $args{c};
my $passwd = $args{P} || 'p455W0Rd';
my $owner_nick = $args{o};
my ($q_num, $owner, $question, $answer, $quiztime, %chart);
sub _start {
my ($kernel) = $_[KERNEL];
$kernel->alias_set( 'smileyninja' );
$kernel->post( 'triviabot', 'register', 'all');
$kernel->post( 'triviabot', 'connect', { Debug => 1,
Nick => $nick,
Server => $server,
Port => $port,
Username => $username,
Ircname => $ircname, }
);
}
sub irc_001 {
my ($kernel) = $_[KERNEL];
$kernel->post( 'triviabot', 'mode', $nick, '+i' );
$kernel->post( 'triviabot', 'join', $channel ) if $channel;
if ($owner_nick) {
#this is useless cause i don't know how to
#handle the 'whois' i got back
$kernel->post( 'triviabot', 'whois', $owner_nick);
#here i should set $short_whois = $owner
}
}
sub irc_disconnected {
my ($server) = $_[ARG0];
print "Lost connection to server $server.\n";
}
sub irc_error {
my $err = $_[ARG0];
print "Server error occurred! $err\n";
}
sub irc_socketerr {
my $err = $_[ARG0];
print "Couldn't connect to server: $err\n";
}
sub _stop {
my ($kernel) = $_[KERNEL];
print "Control session stopped.\n";
$kernel->post( 'triviabot', 'quit', 'Neenios on ice!' );
$kernel->alias_remove( 'smileyninja' );
}
sub irc_public {
if ($question) {
my ($kernel, $who, $chan, $msg) = @_[KERNEL, ARG0 .. ARG2];
#i use $answer as a regexp now. still this needs
#better handling cause not everybody knows regexp
if ($msg =~ /$answer/i) {
my $nick = get_nick($who);
$chart{$nick}{p}++;
$quiztime = time - $quiztime;
$chart{$nick}{t} += $quiztime;
my ($secs, $mins) = localtime $quiztime;
$kernel->post('triviabot', 'privmsg', $channel,
sprintf(
"\cC4Congratulations \cB%s\cB! The answer is \c_\cB%s\cB\c_. (%02d:%02
+d)",
$nick, $answer, $mins, $secs)
);
$kernel->post('triviabot', 'privmsg', $channel,
"Now \cB$nick\cB has \cB$chart{$nick}{p}\cB point" .
($chart{$nick}{p}<=1?'':'s') . ".");
($question, $answer, $quiztime) = undef;
}
}
}
sub irc_msg {
my ($kernel, $who, $recipients, $msg) = @_[KERNEL, ARG0 .. ARG2];
my ($command, $rest) = $msg =~ /^\s*(\w+)\s*(.*)/;
if ($who eq $owner) {
SWITCH: for (lc $command) {
($_ eq 'abort') && do{ abort ($kernel); last};
($_ eq 'channel') && do{ channel ($kernel, $rest); last};
($_ eq 'cheat') && do{ cheat ($kernel, $rest); last};
($_ eq 'help') && do{ help ($kernel); last};
($_ eq 'new') && do{ new_question ($kernel, $rest); la
+st};
($_ eq 'reset') && do{ _reset ($kernel); last};
($_ eq 'status') && do{ show_chart ($kernel, $rest); last
+};
($_ eq 'quit') && do{ quit ($kernel); last};
}
} elsif ($command eq 'owner') {
set_owner ($kernel, $rest, $who);
}
}
sub get_nick {
$_ = shift;
/^(.*)!.*$/ or die "Weird-ass who: $_";
return $1;
}
sub set_owner {
my ($kernel, $rest, $who) = @_;
if ($rest eq $passwd) {
$owner = $who;
$kernel->post('triviabot', 'privmsg', get_nick($who),
"You've been successfully authenticated! ".
'Type "help" for commands.');
}
}
sub abort {
my $kernel = shift;
($question, $answer, $quiztime) = undef;
$kernel->post('triviabot', 'privmsg', $channel,
"\cBQuestion number $q_num went unanswered." );
}
sub channel {
my $kernel;
($kernel, $_) = @_;
s/^([^#])/#$1/;
if ($channel) {
$kernel->post('triviabot', 'part', $channel);
undef $channel;
}
unless ( $kernel->post('triviabot', 'join', $_) ) {
# this should be error checking but it won't work
# cause i can't get an error code back
$kernel->post('triviabot', 'privmsg', get_nick($owner),
"Cannot join $_ !" );
return;
}
$channel = $_;
}
sub cheat {
my $kernel;
($kernel, $_) = @_;
if (my ($nick, $modifier) = /^\s*(.+)\s+([+-]?\d+)\s*$/) {
$chart{$nick}{p} += $modifier;
$kernel->post('triviabot', 'privmsg', get_nick($owner),
"Score for $nick has changed by $modifier. " .
"Now is $chart{$nick}{p}." );
} else {
$kernel->post('triviabot', 'privmsg', get_nick($owner),
"Cannot cheat: usage 'cheat <nick> <modifier>'" );
}
}
sub help {
my $kernel = shift;
my $help = <<'EOH';
Usage of TriviaHam
owner <password> # authenticates yourself
new \q<question>\a<answer> # new question
status [param] # display current standings
# no param => returns first 3 positions
# param = 0 => returns all the positions
# param = <other_number> => returns that many positions
abort # abort current question
cheat <nick> <modifier> # changes nick score by modifier
channel <new_channel> # moves bot to another channel
reset # reset everything
quit # quit the bot
help # this help
EOH
for my $line (split "\n", $help) {
$kernel->post('triviabot', 'privmsg', get_nick($owner), $line
+);
select(undef, undef, undef, 0.25);
}
}
sub _reset {
my $kernel = shift;
($q_num, %chart, $question, $answer) = undef;
$kernel->post('triviabot', 'privmsg', get_nick($owner),
"Quiz reset!" );
}
sub new_question {
my $kernel;
($kernel, $_) = @_;
if (($question, $answer) = /^\\q\s*(.+?)\s*\\a\s*(.+?)\s*$/) {
$q_num++;
$kernel->post('triviabot', 'privmsg', $channel,
"\cBQuestion Number\cC4 $q_num\cC0,1: $question" );
$quiztime = time;
} else {
$kernel->post('triviabot', 'privmsg', get_nick($owner),
"Cannot parse new question '$_'" );
}
}
sub show_chart {
my ($kernel, $how_many) = @_;
$how_many =~ s/^.*?(\d+).*?$/$1/;
$how_many = keys %chart if ($how_many eq '0');
$how_many ||= 3;
$how_many--;
my ($j, $min_color, $max_color) = (0, 6, 15);
my $loop = $max_color - $min_color;
my $to_color = $min_color - 1;
$kernel->post('triviabot', 'privmsg', $channel,
"\cVTrivial Standings after \cB$q_num\cB question" . ($q_num<=
+1?'':'s') .
". QuizMaster is \cB" . get_nick($owner));
my @sorted_comps = sort
{$chart{$b}{p} <=> $chart{$a}{p} || $chart{$a}{t} <=> $chart{$b}{t
+}}
keys %chart;
for (@sorted_comps[0..$how_many]) {
last unless $_;
my ($secs, $mins) = localtime $chart{$_}{t};
$kernel->post('triviabot', 'privmsg', $channel,
sprintf( "\cC%d %d) \cB%-9s\cB with \cB%2d\cB point%1s in %02d
+:%02d",
++$j + $to_color, $j, $_, $chart{$_}{p},
$chart{$_}{p}<=1?'':'s', $mins, $secs )
);
$to_color -= $loop unless ( $j % $loop );
}
}
sub quit {
my $kernel = shift;
$kernel->post( 'triviabot', 'quit', 'Game Over' );
}
POE::Component::IRC->new( 'triviabot' ) or
die "Can't instantiate new IRC component!\n";
POE::Session->new( 'main' => [qw(
_start _stop irc_001 irc_disconnected
irc_socketerr irc_error irc_public irc_msg
)] );
$poe_kernel->run();
exit 0;
Some notes about the code:
- I started coding on dicebot.pl example included with POE::Component::IRC, so some code is just borrowed from there.
- I still got some trouble using POE: i put comments where i can't solve my problems, maybe someone can help me out.
- I thought about making it a Xchat Perl plug-in not to waste YASC, but i just liked more this solution that lets you install it even on remote shells without Xchat.
- Thanks goes to Juerd and his irc colors to html. Still someone may find the colors i'm using disturbing or just disgusting. Please give me suggestion on this.
- I should write some POD, of course. Next thing to do.
- Yes, i thought about using a DB of answers/questions. Supporting it should be no issue. Still putting questions realtime is funnier. And you need a HUGE DB not to get repeated questions. If someone knows of such a Db (it should be free, of course), please let me know.
- Help could be powered with specific help about single commands with obvious syntax like help <command>.
- Biggest issue at the moment is $answer being a full regexp. It's powerful but at least confusing to most. Please note that matching like /$answer/i instead of /^$answer$/i isn't a bug, but the correct behavior.
- Any other comment, improvement, suggestion is welcome.
gkinueliileunikg
