CUFP giulienk 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 [kobe://POE::Component::IRC] and started coding something: follows what i came up with. <READMORE> <CODE> #!/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:%02d)", $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); last}; ($_ 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; </code> Some notes about the code: <ul> <li>I started coding on dicebot.pl example included with [kobe://POE::Component::IRC], so some code is just borrowed from there. <li>I still got some trouble using POE: i put comments where i can't solve my problems, maybe someone can help me out. <li>I thought about making it a Xchat Perl plug-in not to waste [id://102319|YASC], but i just liked more this solution that lets you install it even on remote shells without Xchat. <li>Thanks goes to [Juerd] and his [id://132260]. Still someone may find the colors i'm using disturbing or just disgusting. Please give me suggestion on this. <li>I should write some POD, of course. Next thing to do. <li>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. <li>Help could be powered with specific help about single commands with obvious syntax like <tt>help <command></tt>. <li>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 <tt>/$answer/i</tt> instead of <tt>/^$answer$/i</tt> isn't a bug, but the correct behavior. <li>Any other comment, improvement, suggestion is welcome. </ul> <TT>gkinueliileunikg</tt>