#!/usr/bin/perl use strict; use DBI; # IRC Server stuff use POE; use POE::Component::IRC; my $current_nick = 'francoise'; my $channel = '#kiffer.de'; POE::Component::IRC->new("francoise"); POE::Session->new ( _start => \&irc_start, irc_join => \&irc_join, irc_part => \&irc_part, irc_nick => \&irc_nick, irc_quit => \&irc_quit, irc_376 => \&irc_connect, #end of motd irc_372 => \&irc_motd, irc_353 => \&irc_names, irc_311 => \&irc_whois, irc_public => \&irc_pub_msg, irc_msg => \&irc_priv_msg, irc_ctcp_action => \&irc_action, # _default => \&irc_default, ); my %commands = ( 'help' => \&francoise_help, 'stat' => \&francoise_stat, 'topten' => \&francoise_topten, 'topten0r' => \&francoise_topten0r, 'forget' => \&francoise_forget, 'alias' => \&francoise_alias, ); # this helps identify jamaica autorejoiner and doublejoiner # %jamaica holds encodedIP => nick # %jamaicat holds encodedIP => lastjoin # $jamaicatimeout says, after which timeout an IP is 'clear' # for now 2 hours my %jamaica; my %jamaicat; my $jamaicatimeout = 7200; my $hv = join( '|', ( 'bin', 'bist', 'ist', 'is', 'sind', 'seid', 'werde', 'wirst', 'wird', 'werden', 'werdet', 'war', 'warst', 'waren', 'wart', 'habe', 'hast', 'hat', 'haben', 'habt', 'hatte', 'hattest', 'hatten', 'hattet', 'muss', 'muß', 'musst', 'mußt', 'muessen', 'müssen', 'muesst', 'mueßt', 'müsst', 'müßt' ) ); my %pasthv = ( 'bin' => 'war', 'bist' => 'warst', 'ist' => 'war', 'is' => 'war', 'sind' => 'waren', 'seid' => 'wart', 'werde' => 'bin', 'wirst' => 'bist', 'wird' => 'ist', 'werden' => 'sind', 'werdet' => 'seid', 'war' => 'war', 'warst' => 'warst', 'waren' => 'waren', 'wart' => 'wart', 'habe' => 'hatte', 'hast' => 'hattest', 'hat' => 'hatte', 'haben' => 'hatten', 'habt' => 'hattet', 'hatte' => 'hatte', 'hattest' => 'hattest', 'hatten' => 'hatten', 'hattet' => 'hattet', 'muss' => 'musste', 'muß' => 'musste', 'musst' => 'musstest', 'mußt' => 'musstest', 'muessen' => 'mussten', 'müssen' => 'mussten', 'muesst' => 'musstet', 'mueßt' => 'musstet', 'müsst' => 'musstet', 'müßt' => 'musstet' ); my %conjhv = ( 'bin' => 'wäre', 'bist' => 'wärst', 'ist' => 'wäre', 'sind' => 'wären', 'seid' => 'wärt', 'werde' => 'würde', 'wirst' => 'würdest', 'wird' => 'würde', 'werden' => 'würden', 'werdet' => 'würdet', 'war' => 'wäre', 'warst' => 'wärst', 'waren' => 'wären', 'wart' => 'wärt', 'habe' => 'hätte', 'hast' => 'hättest', 'hat' => 'hätte', 'haben' => 'hätten', 'habt' => 'hättet', 'hatte' => 'hätte', 'hattest' => 'hättest', 'hatten' => 'hätten', 'hattet' => 'hättet', 'muss' => 'müsste', 'muß' => 'müsste', 'musst' => 'müsstest', 'mußt' => 'müsstest', 'muessen' => 'müssten', 'müssen' => 'müssten', 'muesst' => 'müsstet', 'mueßt' => 'müsstet', 'müsst' => 'müsstet', 'müßt' => 'müsstet' ); my %futuhv = ( 'bin' => 'werde', 'bist' => 'wirst', 'ist' => 'wird', 'sind' => 'werden', 'seid' => 'werdet', 'werde' => 'werde', 'wirst' => 'wirst', 'wird' => 'wird', 'werden' => 'werden', 'werdet' => 'werdet', 'war' => 'bin', 'warst' => 'bist', 'waren' => 'sind', 'wart' => 'seid', 'habe' => 'habe', 'hast' => 'hast', 'hat' => 'hat', 'haben' => 'haben', 'habt' => 'habt', 'hatte' => 'habe', 'hattest' => 'hast', 'hatte' => 'hat', 'hatten' => 'haben', 'hattet' => 'habt', 'muss' => 'muss', 'muß' => 'muss', 'musst' => 'musst', 'mußt' => 'mußt', 'muessen' => 'muessen', 'müssen' => 'müssen', 'muesst' => 'müsst', 'mueßt' => 'müsst', 'müsst' => 'müsst', 'müßt' => 'müsst' ); my $starttime = time(); # Database connection stuff my $dbh = DBI->connect("DBI:Pg:dbname='francoise'", 'francoise', 'kiffer') or die "ohoh, datenbank b0rken: $!"; sub irc_start { my ( $kernel, $heap, $session ) = @_[KERNEL, HEAP, SESSION ]; $kernel->refcount_increment( $session->ID(), "my bot"); $kernel->post(francoise=> register=> "all"); $kernel->post(francoise=>connect=> { Nick => $current_nick, Username => 'francoise', Ircname => 'francoise', Server => 'irc.kiffer.de', Port => '6667', } ); } # minifunctions, console output only sub irc_connect { $_[KERNEL]->post(francoise=>join=>$channel); } sub irc_motd { my $msg = $_[ARG1]; print "MOTD: $msg\n"; } sub irc_part { my $channel = $_[ARG1]; my $nick = (split /!/, $_[ARG0])[0]; print "#-> $nick has parted $channel\n"; } sub irc_quit { my $nick = $_[ARG0]; my $reason = $_[ARG1]; print "#-> $nick has quit ($reason)\n"; } sub irc_default { print "IRC $1 received\n" if ( $_[ARG0] =~ /^irc_(.*)$/ ); } #names list on join, check all users sub irc_names { my $kernel = $_[KERNEL]; my ( $channel, $names ) = (split /:/, $_[ARG1]); for my $user ( split ' ', $names ) { $user =~ s/^[@%+]//; $kernel->post( 'francoise', 'whois', $user); } $channel =~ s/[@|=] (.*?) /$1/; print "#-> Users on $channel [ $names ]\n"; } #nick change sub irc_nick { my ( $kernel, $newnick_ ) = @_[ KERNEL, ARG1 ]; my $oldnick_ = (split /!/, $_[ARG0])[0]; my $oldnick = francoise_getbasenick( $oldnick_ ); my $newnick = francoise_getbasenick( $newnick_ ); francoise_verifyuser( $newnick_, '', 0, $kernel ) if $newnick_ ne $current_nick && $newnick ne $oldnick; print "#-> $oldnick_ is now known as $newnick_\n"; } #user joined sub irc_join { my ( $kernel, $channel ) = @_[KERNEL, ARG1]; $_[ARG0] =~ /(.+)!~(.+)@(.+)/ or return; my ( $nick, $user, $host ) = ($1,$2,$3); $kernel->post( 'francoise', 'privmsg', $channel, 'Hier bin ich!'), return if $nick eq $current_nick; francoise_verifyuser( $nick, $host, 1 ); return unless $host eq 'jamaica.kiffer.de'; $kernel->post( 'francoise', 'privmsg', $channel, "Ich glaub ja, $jamaica{$user} und $nick kennen sich.") if $jamaica{$user} && $nick ne $jamaica{$user} && time() - $jamaicat{$user} < $jamaicatimeout; $jamaica{$user} = $nick; $jamaicat{$user} = time(); print "#-> $nick has joined $channel\n"; } sub irc_pub_msg{ my ( $kernel, $msg ) = @_[KERNEL, ARG2]; my $channel = $_[ARG1]->[0]; my $nick_ = (split /!/, $_[ARG0])[0]; my @words = (split / /, $msg); my $w0rds = 0; return if $nick_ eq $current_nick; #tidy nick and tidy msg from dest nick my $nick = francoise_verifyuser( $nick_, "", 0, $kernel ); $msg =~ s/^\S+: +//; #execute commands &{$commands{ $1 } || \&francoise_donothing } ( $kernel, $channel, $2 ) if $msg =~ /^!(\S+) *(.*)$/; #update dictionary my $sth_lookup = $dbh->prepare( "SELECT COUNT(*) FROM words WHERE word = ?"); my $sth_insert = $dbh->prepare( "INSERT INTO words ( word, is_0r, is_action ) VALUES ( ?, ?, ? )"); for my $word ( @words ) { my $is0r = 'false'; my $isact = 'false'; $sth_lookup->execute( $word ); $is0r = 'true', $w0rds++ if $word =~ /0r/; $isact = 'true' if $word =~ /^\*.*\*$/; $sth_insert->execute( $word, $is0r, $isact ) unless ($sth_lookup->fetchrow_array)[0]; } #reply to whereis requests if ( $msg =~ /^wo ist? (\S+?)\??$/i ) { my $wois_ = $1; my $wois = francoise_getbasenick( $1 ); my ($awaymsg) = $dbh->selectrow_array( "SELECT awaymsg FROM users WHERE nick = ? AND isaway = 'true'", undef, $wois); $kernel->post( 'francoise', 'privmsg', $channel, $awaymsg ? "$wois_ ist $awaymsg" : "Ich weiss nicht, wo $wois_ ist." ); } elsif( $msg =~ /^(.+?)\s+($hv)\s+(.*)$/i ) { #learn some new knowledge my ( $trigger, $hilfsverb, $reply ) = ($1,$2,$3); $dbh->do( "INSERT INTO knowledge ( trigger, hilfsverb, reply ) VALUES ( ?, ?, ?) ", undef, $trigger, $hilfsverb, $reply ) unless ($dbh->selectrow_array( "SELECT COUNT(*) FROM knowledge WHERE trigger = ? AND hilfsverb = ? AND reply = ?", undef, $trigger, $hilfsverb, $reply ))[0]; } else { #search in our knowledge my $thr = join ' ', $dbh->selectrow_array( "SELECT trigger, hilfsverb, reply FROM knowledge WHERE trigger = ? ORDER BY RANDOM() LIMIT 1", undef, $msg ); $thr =~ s/^.*?(?: +?)(.*)$/$1/; $thr =~ s/!who/$nick/g; $thr =~ s'!date'francoise_date()'eg; $thr =~ s'!time'francoise_time()'eg; $kernel->post( 'francoise', 'privmsg', $channel, $thr ) if $thr; } #credit word and line count to user $dbh->do( "UPDATE users SET lines = lines + 1, words = words + ?, w0rds = w0rds + ?, isaway = false WHERE nick = ?", undef, $#words + 1, $w0rds, $nick );; print "$channel: <$nick> $msg\n"; } sub irc_action{ my ( $who, $msg ) = @_[ ARG0, ARG2 ]; my $nick = francoise_getbasenick( ( split /!/, $who )[0] ); #note whereis information $dbh->do( "UPDATE users SET isaway = true, awaymsg = ? WHERE nick = ?", undef, $1, $nick ) if( $msg =~ /^ist? (.+)$/ ); } sub irc_priv_msg{ my ( $kernel, $msg ) = @_[KERNEL, ARG2]; my $nick = (split /!/, $_[ARG0])[0]; &{$commands{ $1 } || \&francoise_donothing } ( $kernel, $nick, $2 ) if( $msg =~ /^!(\S+) *(.*)$/ ); #todo: hide that better, the lady is no puppet on a string $kernel->post( 'francoise', 'privmsg', $channel, $1) if( $msg =~ /^!say (.*)$/ ); $kernel->post( 'francoise', $1, $2, $3, $4 ) if $msg =~ /^!magic +(\S+) +(\S+) +(\S+) (.*)/; print "PRIV: [$nick] $msg\n"; } sub irc_whois{ my ( $nick, $host ) = (split / /, $_[ARG1])[0,2]; francoise_verifyuser( $nick, $host, 0 ) if( $nick ne $current_nick ); } sub francoise_getbasenick{ my $nick = $_[0]; $nick =~ s/^(.+?)[_|^-].*/$1/; return ($dbh->selectrow_array( "SELECT nick FROM aliases WHERE alias = ?", undef, $nick ))[0] || $nick; } sub francoise_verifyuser { my ( $nick_, $host, $updtime, $kernel ) = @_; my $nick = francoise_getbasenick( $nick_ ); $kernel->post( 'francoise', 'whois', $nick_), return $nick unless $host; my ($cnt) = $dbh->selectrow_array( "SELECT COUNT(*) FROM users WHERE nick=?", undef, $nick ); $dbh->do( "INSERT INTO users(id, nick, words, lines, lastlogin, lasthost) VALUES ( '', ?, 0, 0, now(), ? )", undef, $nick, $host) unless $cnt; $dbh->do( "UPDATE users SET lasthost = ?" . ( $updtime ? ", lastlogin = now()" : "" ) . " WHERE nick = ?", undef, $host, $nick ) if $cnt; return $nick; } sub francoise_help { my ( $kernel, $dest ) = @_; $kernel->post( 'francoise', 'privmsg', $dest, 'Hallo, ich bin Francoise, der freundliche Kifferchat-Bot.'); $kernel->post( 'francoise', 'privmsg', $dest, 'Ich kann folgende Kommandos ausfuehren:'); $kernel->post( 'francoise', 'privmsg', $dest, '!help Diese Hilfe anzeigen'); $kernel->post( 'francoise', 'privmsg', $dest, '!stat Informationen ueber mich ausgeben'); $kernel->post( 'francoise', 'privmsg', $dest, '!topten Die aktivsten Chatter anzeigen'); $kernel->post( 'francoise', 'privmsg', $dest, '!topten0r Die 13370rsten Chatter anzeigen'); $kernel->post( 'francoise', 'privmsg', $dest, '!forget Einen Trigger vergessen'); } sub francoise_stat { my ( $kernel, $dest, $msg ) = @_; francoise_userstat( $kernel, $dest, $msg ), return if $msg; my $age = time() - $starttime; my $secs = $age % 60; my $mins = ( $age / 60 ) % 3600; my $hours = ( $age / 3600 ) % 86400; my $days = $age / 86400; my $agestring; if( $age < 60 ) { $agestring = "$secs Sekunden"; } elsif( $age < 3600 ) { $agestring = "$mins Minuten $secs Sekunden"; } elsif( $age < 86400) { $agestring = "$hours Stunden $mins Minuten"; } else { $agestring = "$days Tage $hours Stunden"; } my ($usercnt) = $dbh->selectrow_array( "SELECT COUNT(*) FROM users" ); my ($knowcnt) = $dbh->selectrow_array( "SELECT COUNT(*) FROM knowledge" ); $kernel->post( 'francoise', 'privmsg', $dest, "Ich bin schon $agestring alt, kenne $usercnt Chatter und weiss ueber $knowcnt Dinge bescheid." ); } sub francoise_userstat{ my ( $kernel, $dest, $msg ) = @_; my $nick = francoise_getbasenick( $msg ); my @userstat = $dbh->selectrow_array( "SELECT words, lines, w0rds, isaway, awaymsg FROM users WHERE nick = ?", undef, $nick ); my $awaymsg = $userstat[3] ? " $nick ist momentan $userstat[4]." : ""; $kernel->post( 'francoise', 'privmsg', $dest, "$nick hat schon $userstat[0] Worte in $userstat[1] Zeilen von sich gegeben und $userstat[2] mal in den Kanal ge0red.$awaymsg"); } sub francoise_topten{ my ($kernel, $dest ) = @_; my $sth = $dbh->prepare( "SELECT words, nick FROM users WHERE words > 0 ORDER BY words DESC LIMIT 10" ); $sth->execute(); while ( my ($words, $nick) = $sth->fetchrow_array ) { $kernel->post( 'francoise', 'privmsg', $dest, "$words $nick" ); } } sub francoise_topten0r { my ($kernel, $dest ) = @_; my $sth = $dbh->prepare( "SELECT w0rds, nick FROM users WHERE w0rds > 0 ORDER BY w0rds DESC LIMIT 10" ); $sth->execute(); while ( my ($w0rds, $nick ) = $sth->fetchrow_array ) { $kernel->post( 'francoise', 'privmsg', $dest, "$w0rds $nick" ); } } sub francoise_alias{ my ($kernel, $dest, $msg ) = @_; my ($nick, $alias) = (split / /, $msg ); my ($tmp) = $dbh->selectrow_array( "SELECT nick FROM aliases WHERE alias = ?", undef, $nick ); $alias = $nick, $nick = $tmp if $tmp; ($tmp) = $dbh->selectrow_array( "SELECT COUNT(*) FROM aliases WHERE nick = ? AND alias = ?", undef, $nick, $alias ); return if $tmp; my ( $usw, $usl, $us0 ) = $dbh->selectrow_array( "SELECT words, lines, w0rds FROM users WHERE nick = ?", undef, $nick ); my ( $alw, $all, $al0 ) = $dbh->selectrow_array( "SELECT words, lines, w0rds FROM users WHERE nick = ?", undef, $alias); if( $alw || $all ) { $dbh->do( "UPDATE users SET isaway = false, words = ?, lines = ?, w0rds = ? WHERE nick = ?", undef, $usw+$alw, $usl+$all, $us0 + $al0, $nick ); $dbh->do( "INSERT INTO aliases ( nick, alias ) VALUES ( ?, ? )", undef, $nick, $alias ); $dbh->do( "DELETE FROM users WHERE nick = ?", undef, $alias ); } } sub francoise_forget { my ($kernel, $channel, $what) = @_; my ($tmp) = $dbh->selectrow_array("SELECT COUNT(*) FROM knowledge WHERE trigger = ?", undef, $what); if ($tmp) { $dbh->do("DELETE FROM knowledge WHERE trigger = ?", undef, $what); $kernel->post('francoise', 'privmsg', $channel, "Mist, seit der letzten Tuete weiss ich nix mehr von $what :("); } else { $kernel->post('francoise', 'privmsg', $channel, "$what? Nie von gehoert! *schwoer*"); } } sub francoise_donothing { } sub francoise_time { my ( $sec,$min,$hour) = localtime(time); return sprintf "%02d:%02d:%02d", $hour, $min, $sec; } my @mons = ('Januar','Februar','März','April','Mai','Juni','Juli','August','September','Oktober','November','Dezember'); sub francoise_date { my ($sec,$min,$hour,$mday,$mon) = localtime(time); return sprintf "%02d. %s", $mday, $mons[$mon]; } #start everything $poe_kernel->run();