From: pdbogen Date: Wed, 29 Aug 2007 21:08:51 +0000 (+0000) Subject: Newer versions of stuff, mostly. Fixed example config file. X-Git-Url: http://git.mmlx.us/?a=commitdiff_plain;h=6b1b70b094957e0d2d0fe463ceef33dbdb3a1a37;p=destult.git Newer versions of stuff, mostly. Fixed example config file. git-svn-id: https://www.cernu.us/~pdbogen/svn/destult2@2 088b83a4-0077-4247-935c-42ec02c2848b --- diff --git a/ChangeLog b/ChangeLog index 7276acb..c883ac9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,136 @@ +2007-02-16 pdbogen + * destult2.pl (1.2): Formatting. + * commands.yaml (1.66): Fixed RSVPs for clearing when there is a + serialized form. Also, patch an authentication hole with + multi-server. + * core.pl (1.17): Multi-server support + * irc.pl (1.18): OOness to irc modules. Multi-server support +2006-12-03 pdbogen + * commands.yaml (1.65): Tweaked the regexp determining what WIKI + will refuse to lookup +2006-11-30 pdbogen + * commands.yaml (1.64): Wiki now prints a usage statement when + called with no argument. + * commands.yaml (1.63): Ignore and unignore strips trailing spaces + from arguments. +2006-11-21 pdbogen + * commands.yaml (1.62): Doh. // isn't the comment marker. + * commands.yaml (1.61): Added an RSVP tracker. Fixed urban + dictionary for multi-word lookups. Tweaked factoid parsing. + * irc.pl (1.17), core.pl (1.16): New POE session creation model. +2006-09-11 pdbogen + * commands.yaml (1.60): Webtender now double-quotes its argument. +2006-08-31 pdbogen + * commands.yaml (1.59): Added grouphug lookup, fixed some issues + with advertisements +2006-05-16 pdbogen + * commands.yaml (1.58): Bash.org broke their RSS feed, so random no + longer works over that. +2006-05-15 pdbogen + * commands.yaml (1.57): Added caching for the DICT.org dicts, as + well as the ability to reference secondary, tertiary, etc. + definitions (by prefixing the query with <#>... e.g., 2.foo ) + * commands.yaml (1.56): Changed to make gcide a bit happier. +2006-05-09 pdbogen + * commands.yaml (1.55): Perl division doesn't truncate. + * commands.yaml (1.54): Webtender was loading the cache from disk + every time a query was made, which is expensive and slow. It's been + changed to only load it the first time, and store it in the heap + thereafter. + * core.pl (1.15), irc.pl (1.16): Update copyright dates + * commands.yaml (1.53): Added a command to grab the seen + information for some user, and to grab Destult's uptime + * core.pl (1.14), irc.pl (1.15): Added code to track the last time + a message from some user was seen. + * commands.yaml (1.52): Bug fixes + * .cvsignore (1.6): Ignore webtender cache + * commands.yaml (1.51): Added a webtender lookup module and fixed a + subroutine call +2006-04-13 pdbogen + * commands.yaml (1.50): Added support for UrbanDictionary.com, and + also the ability to cache the result of dict lookups. Presently, + only urban caches. It should be trivial to add the others. They are + stored in a hashref called DICT_cache in the heap. Each key should + correspond to dict name (e.g., urban, foldoc, etc.), and should be + a hashref itself. Each key of this hashref is the query (less the + dict name), and should be the parsed result. +2006-04-08 pdbogen + * commands.yaml (1.49), irc.pl (1.14): Added the ability for + destult to voice/op people depending on their access level. + * commands.yaml (1.48): Added SnipURL support to RSS to shorten + links. +2006-04-04 pdbogen + * commands.yaml (1.47): More whitespace stripping tweaks. + * commands.yaml (1.46): Tweaked RSS a bit; more information in + help, and better whitespace stripping. +2006-03-06 pdbogen + * commands.yaml (1.45): Really fixed MORSE. + * .cvsignore (1.5): Added 'access.yaml' to ignore list. + * commands.yaml (1.44): Fixed MORSE. + * commands.yaml (1.43): Morse code conversion, heh heh. +2006-02-28 pdbogen + * commands.yaml (1.42): Added a 'REPLACE' command, which can + perform regex s/// on factoids. +2006-02-27 pdbogen + * access.yaml (1.1): Initial revision +2006-02-21 pdbogen + * commands.yaml (1.41): Fixed so that it produces the right number + of headlines. +2006-02-16 pdbogen + * core.pl (1.13): Access level of zero lets anybody use a command + now. + * commands.yaml (1.40): Modified TRANSLATE for improved fault + tolerance. + * commands.yaml (1.39): Fixed fandango lookup +2006-02-10 pdbogen + * commands.yaml (1.38), core.pl (1.12), irc.pl (1.13): Lots of heap + reference keys were unsanitary; they've been trapped in quotes. + Added a FANDANGO command. No-arg reports usage. + * commands.yaml (1.37): RSS modified to be more adaptable. Now, if + a field is prefixed with "!" it will be stripped of HTML. "+" means + newlines will be compressed into |, and "@" means that the field + will begin on its own line. Modified BASH to refer to RSS for its + random function. +2006-02-08 pdbogen + * commands.yaml (1.36): RSS can now accept a list of fields to + fetch. If they are specified, it will fetch ONLY those fields. Any + field can be prefixed with '+' if it should be passed through a + reformatter (which strips HTML and compresses multiple lines) + * commands.yaml (1.35): Added the ability to specify which fields + you want for items in a feed. + * commands.yaml (1.34), core.pl (1.11): Added support for ignoring + a user. + * commands.yaml (1.33): RSS now includes the link to the item + * commands.yaml (1.32): Added an 'RSS' commands to fetch the + headlines from an RSS feed, and a 'JOIN' command to make the bot + join a specific channel. Also, minor changes to the translate + command for improved fault tolerance. + * core.pl (1.10): Added a '+' flag to commands to make them + explicitly not match factoids. This is used for aliasing, to + prevent loops. + * irc.pl (1.12): Added a slight bit of commentary, and a callback + to have the bot join channels. +2006-02-05 pdbogen + * commands.yaml (1.31): Added a babel fish command to translate + stuffs. Also, added '"' translation to bash. + * config.pl (1.3): Apparently YAML changed a bit. + * core.pl (1.9): Fixed the behaviour a little bit to not rely on + the non-munging of $_ +2005-12-11 pdbogen + * commands.yaml (1.30): nbsp->space in ~bash +2005-12-10 pdbogen + * commands.yaml (1.29): Changed 'CMDACCESS' to 'CLASSIFY,' added + 'ACCESS ' and 'LINK '. Added 'BASH + <#>' / 'BASH random' +2005-09-08 pdbogen + * core.pl (1.8), commands.yaml (1.28): Lots of changes. There's a + new auth scheme, which has variables 'authority' levels, and the + access required for commands can be tweaked online (via + 'cmdaccess') +2005-09-05 pdbogen + * irc.pl (1.11): I have no idea. + * commands.yaml (1.27): Added support to explicitly request the + full text of a wikipedia article by prepending the query with a '+' 2005-08-02 pdbogen * commands.yaml (1.26), irc.pl (1.10): Sometimes 'WIKI' produces a lot of text, which can be annoying. The 'ABORT' command will cancel diff --git a/commands.yaml b/commands.yaml index 8467024..4a3e244 100644 --- a/commands.yaml +++ b/commands.yaml @@ -9,18 +9,18 @@ LINK: |- my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; my( $whom, $target ) = split( / /, $what, 2 ); - unless( exists( $heap->{ "access" }->{ uc( $target ) } ) ) { + unless( exists( $heap->{ 'access' }->{ uc( $target ) } ) ) { $kernel->post( $src, $replypath, "'$target' has no access; link not allowed.", $dest ); return; } - if( access2( $heap->{ "access" }, $target, {} ) > access( $kernel, $heap, $who ) ) { + if( access2( $heap->{ 'access' }, $target, {} ) > accessLevel( $kernel, $heap, $who ) ) { $kernel->post( $src, $replypath, "You may not grant access exceeding your own.", $dest ); return; } - if( exists( $heap->{ privs }->{ uc( $whom ) } ) ) { - $heap->{ access }->{ uc( $whom ) } = "~".$target; - DumpFile( "access.yaml", $heap->{ access } ); + if( exists( $heap->{ 'privs' }->{ uc( $whom ) } ) ) { + $heap->{ 'access' }->{ uc( $whom ) } = "~".$target; + DumpFile( "access.yaml", $heap->{ 'access' } ); $kernel->post( $src, $replypath, "Set.", $dest ); } else { $kernel->post( $src, $replypath, "'$whom' not registered.", $dest ); @@ -35,13 +35,13 @@ ACCESS: |- $kernel->post( $src, $replypath, "Access level should be a non-negative integer. (Did you want LINK?)", $dest ); return; } - if( $level > access2( $heap->{ "access" }, $who, {} ) ) { + if( $level > access2( $heap->{ 'access' }, $who, {} ) ) { $kernel->post( $src, $replypath, "You may not grant access exceeding your own.", $dest ); return; } - if( exists( $heap->{ privs }->{ uc( $whom ) } ) ) { - $heap->{ access }->{ uc( $whom ) } = $level; - DumpFile( "access.yaml", $heap->{ access } ); + if( exists( $heap->{ 'privs' }->{ uc( $whom ) } ) ) { + $heap->{ 'access' }->{ uc( $whom ) } = $level; + DumpFile( "access.yaml", $heap->{ 'access' } ); $kernel->post( $src, $replypath, "Set.", $dest ); } else { $kernel->post( $src, $replypath, "'$whom' not registered.", $dest ); @@ -56,9 +56,9 @@ CLASSIFY: |- $kernel->post( $src, $replypath, "Access level should be a non-negative integer.", $dest ); return; } - if( exists( $heap->{ commands }->{ uc( $cmd ) } ) ) { - $heap->{ access }->{ "@".uc( $cmd ) } = $level; - DumpFile( "access.yaml", $heap->{ access } ); + if( exists( $heap->{ 'commands' }->{ uc( $cmd ) } ) ) { + $heap->{ 'access' }->{ "@".uc( $cmd ) } = $level; + DumpFile( "access.yaml", $heap->{ 'access' } ); $kernel->post( $src, $replypath, "Set.", $dest ); } else { $kernel->post( $src, $replypath, "'$cmd' not found.", $dest ); @@ -69,15 +69,15 @@ ACCESSLIST: |- sub { my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; $kernel->post( $src, $replypath, "Commands:", $dest ); - foreach( keys( %{ $heap->{ access } } ) ) { + foreach( keys( %{ $heap->{ 'access' } } ) ) { if( substr( $_, 0, 1 ) eq "@" ) { - $kernel->post( $src, $replypath, " $_: ".$heap->{ access }->{ $_ }, $dest ); + $kernel->post( $src, $replypath, " $_: ".$heap->{ 'access' }->{ $_ }, $dest ); } } $kernel->post( $src, $replypath, "Users:", $dest ); - foreach( keys( %{ $heap->{ access } } ) ) { + foreach( keys( %{ $heap->{ 'access' } } ) ) { unless( substr( $_, 0, 1 ) eq "@" ) { - $kernel->post( $src, $replypath, " $_: ".$heap->{ access }->{ $_ }, $dest ); + $kernel->post( $src, $replypath, " $_: ".$heap->{ 'access' }->{ $_ }, $dest ); } } } @@ -86,11 +86,12 @@ LISTCOMMANDS: |- sub { my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; my $reply = "I have the following commands: "; - foreach( keys( %{ $heap->{ commands } } ) ) { + foreach( keys( %{ $heap->{ 'commands' } } ) ) { $reply .= $_." "; } $kernel->post( $src, $replypath, $reply, $dest ); } + SCTITLE: |- sub { my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; @@ -148,13 +149,13 @@ IDENTIFY: |- ( $whom, $password ) = ( $who, $what ); } - if( exists( $heap->{ privs }->{ uc( $whom ) } ) ) { - if( $heap->{ privs }->{ uc( $whom ) } eq md5_hex( $password ) ) { - $heap->{ identified }->{ uc( $who ) } = 1; - $kernel->post( $src, $replypath, "Hello, $who.", $dest ); - } else { - $kernel->post( $src, $replypath, "Authentication failed.", $dest ); - } + if( exists( $heap->{ 'privs' }->{ uc( $whom ) } ) ) { + if( $heap->{ 'privs' }->{ uc( $whom ) } eq md5_hex( $password ) ) { + $heap->{ 'identified' }->{ $src.uc( $who ) } = 1; + $kernel->post( $src, $replypath, "Hello, $who.", $dest ); + } else { + $kernel->post( $src, $replypath, "Authentication failed.", $dest ); + } } else { $kernel->post( $src, $replypath, "User '$who' not found.", $dest ); } @@ -167,8 +168,8 @@ REGISTER: |- my( $whom, $password ) = split( / /, $what, 2 ); if( $password ) { - $heap->{ privs }->{ uc( $whom ) } = md5_hex( $password ); - DumpFile( "privs.yaml", $heap->{ privs } ); + $heap->{ 'privs' }->{ uc( $whom ) } = md5_hex( $password ); + DumpFile( "privs.yaml", $heap->{ 'privs' } ); $kernel->post( $src, $replypath, "Done.", $dest ); } else { $kernel->post( $src, $replypath, "Bad password.", $dest ); @@ -180,10 +181,10 @@ PASSWORD: |- use Digest::MD5 qw( md5_hex ); my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; my( $old, $new ) = split( / /, $what, 2 ); - if( exists( $heap->{ privs }->{ uc( $who ) } ) ) { - if( $heap->{ privs }->{ uc( $who ) } eq md5_hex( $old ) ) { - $heap->{ privs }->{ uc( $who ) } = md5_hex( $new ); - DumpFile( "privs.yaml", $heap->{ privs } ); + if( exists( $heap->{ 'privs' }->{ uc( $who ) } ) ) { + if( $heap->{ 'privs' }->{ uc( $who ) } eq md5_hex( $old ) ) { + $heap->{ 'privs' }->{ uc( $who ) } = md5_hex( $new ); + DumpFile( "privs.yaml", $heap->{ 'privs' } ); $kernel->post( $src, $replypath, "Passwords changed.", $dest ); } else { $kernel->post( $src, $replypath, "Old passwords do not match.", $dest ); @@ -215,12 +216,12 @@ DEFINE: |- my( $subj, $predicate ) = split( / as /, $what, 2 ); if( $subj ) { if( $predicate ) { - $heap->{ db }->{ uc( $subj ) } = $predicate; - DumpFile( "factoids.yaml", $heap->{ db } ); + $heap->{ 'db' }->{ uc( $subj ) } = $predicate; + DumpFile( "factoids.yaml", $heap->{ 'db' } ); $kernel->post( $src, $replypath, "Okay, $who.", $dest ); } else { - delete $heap->{ db }->{ uc( $subj ) } if exists $heap->{ db }->{ uc( $subj ) }; - DumpFile( "factoids.yaml", $heap->{ db } ); + delete $heap->{ 'db' }->{ uc( $subj ) } if exists $heap->{ 'db' }->{ uc( $subj ) }; + DumpFile( "factoids.yaml", $heap->{ 'db' } ); $kernel->post( $src, $replypath, "Okay, $who.", $dest ); } } else { @@ -233,10 +234,10 @@ APPEND: |- my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; print( "APPEND: $who for $what from $src to $dest via $replypath\n" ); my( $subj, $predicate ) = split( / with /, $what, 2 ); - if( exists( $heap->{ db }->{ uc( $subj ) } ) ) { + if( exists( $heap->{ 'db' }->{ uc( $subj ) } ) ) { if( length( $predicate ) > 0 ) { - $heap->{ db }->{ uc( $subj ) } .= $predicate; - DumpFile( "factoids.yaml", $heap->{ db } ); + $heap->{ 'db' }->{ uc( $subj ) } .= $predicate; + DumpFile( "factoids.yaml", $heap->{ 'db' } ); $kernel->post( $src, $replypath, "$who: Done.", $dest ); } else { $kernel->post( $src, $replypath, "$who: Refusing to append nothing.", $dest ); @@ -250,8 +251,8 @@ PARSE: |- sub { my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; print( "PARSE: $who for $what from $src to $dest via $replypath\n" ); - print( "PARSE: $what is ".$heap->{ db }->{ uc( $what ) }."\n" ); - my( $response, $author ) = split( / -- /, $heap->{ db }->{ uc( $what ) } ); + print( "PARSE: $what is ".$heap->{ 'db' }->{ uc( $what ) }."\n" ); + my( $response, $author ) = split( / -- /, $heap->{ 'db' }->{ uc( $what ) } ); if( $author ) { $author = " -- ".$author; } else { @@ -268,6 +269,10 @@ PARSE: |- } elsif( $response =~ /(.+)/ ) { my @responses = split( /\|/, $1 ); $response = $responses[ int( rand( scalar( @responses ) ) ) ].$author; + } elsif( $response =~ /(.+)/ ) { + $response =~ s///; + $kernel->post( "core", "cmd", $who, "~+".$response, $src, $dest, $replypath ); + return; } else { my @responses = split( /\|/, $response ); $response = "$what is ".$responses[ int( rand( scalar( @responses ) ) ) ].$author; @@ -280,8 +285,8 @@ LITERAL: |- sub { my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; print( "LITERAL: $who for $what from $src to $dest via $replypath\n" ); - if( exists( $heap->{ db }->{ uc( $what ) } ) ) { - $kernel->post( "$src", $replypath, "$what is ".$heap->{ db }->{ uc( $what ) }, $dest ); + if( exists( $heap->{ 'db' }->{ uc( $what ) } ) ) { + $kernel->post( "$src", $replypath, "$what is ".$heap->{ 'db' }->{ uc( $what ) }, $dest ); } else { $kernel->post( "$src", $replypath, "'$what' not found.", $dest ); } @@ -291,7 +296,7 @@ LISTKEYS: |- sub { my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; my $reply = "The following factoids were found: "; - foreach( keys( %{ $heap->{ db } } ) ) { + foreach( keys( %{ $heap->{ 'db' } } ) ) { $reply .= "'$_' "; } $kernel->post( $src, $replypath, $reply, $dest ); @@ -299,57 +304,122 @@ LISTKEYS: |- DICT: |- sub { - use Net::Dict; my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; - print( "DICT: Establish connection.\n" ); - my $dict = Net::Dict->new( $Destult::config{ 'DICT_SERVER' } ); - if( !$dict ) { - $kernel->post( $src, $replypath, "Can't contact dict server.", $dest ); - return; + if( $what =~ /^$/ ) { + $kernel->post( $src, $replypath, "USAGE: dict [/][<#>.]\nSee also: dicts",$dest ); } - if( $what =~ /[a-zA-Z1-9]+\/.+/ ) { - print( "DICT: '".( split( /\//, $what, 2 ) )[0]."' source.\n" ); - $dict -> setDicts( ( ( split( /\//, $what, 2 ) )[0] ) ); - $what = ( split( /\//, $what, 2 ) )[1]; - } else { - print( "DICT: Default sources.\n" ); - $dict -> setDicts( ( "wn", "jargon", "foldoc", "web1913" ) ); - } - print( "DICT: Grab definition.\n" ); - my $lookup = $dict->define( $what ); - print( "DICT: Parsing.\n" ); - if( !@{ $lookup }[0] ) { - print( "DICT: No result.\n" ); - $kernel->post( $src, $replypath, "No result for '$what'.", $dest ); + if( !exists( $heap->{ 'DICT_cache' } ) ) { + $heap->{ 'DICT_cache' } = {}; + } + + my $dict = "default"; + if( $what =~ /^(.+)\/.*/ ) { + $dict = $1; + $what = (split( '/', $what, 2))[1]; + } + my $num = 0; + if( $what =~ /^([0-9]+)\..*/ ) { + $num = ($1 - 1); + $what =~ s/^[0-9]+\.//; + } + + if( !exists( $heap->{ 'DICT_cache' }->{ uc( $dict ) } ) ) { + $heap->{ 'DICT_cache' }->{ uc( $dict ) } = {}; + } + if( exists( $heap->{ 'DICT_cache' }->{ uc( $dict ) }->{ "$num.$what" } ) ) { + print( "DICT: Cached Result", "\n" ); + $kernel->post( $src, $replypath, $heap->{ 'DICT_cache' }->{ uc( $dict ) }->{ "$num.$what" }, $dest ); return; } - my $def = ${@{ $lookup }[0]}[1]; - $def =~ s/\n/ /g; - $def =~ s/ {2,}/ /g; - $def =~ s/ :/:/g; - $def =~ s/[^y](((n|v|adj|adv) ?[0-9]?:)|([0-9]:))/\n$1/gi; - $def =~ s/\[syn.*(\n|$)/\n/g; - $def =~ s/;.*//g; - print( $def, "\n" ); - my @def = split( /\n/, $def ); - my $string = shift( @def ); - $string =~ s/^/'/; - $string =~ s/ *$/':/; - my $j = 0; - for $def ( @def ) { - $def =~ s/ *$//g; - if( $def =~ /(n|v|adj|adv) ?[1-3]?:/i ) { - chop( $string ); - $string .= ($j==0?":":".")." $def;"; - $j++; - } elsif( $def =~ /[1-3]:/i ) { - $def =~ s/[[:space:]]*$//g; - $string .= " $def;"; - } - } - chop( $string ); - $kernel->post( $src, $replypath, $string, $dest ); + if( $dict =~ m/^urban/i ) { + print( "DICT: Urban Dictionary", "\n" ); + use WWW::Search; + + my $key = "84d324f8a5fcae301ec4aefcd258dff2"; + my $search = WWW::Search->new('UrbanDictionary', key=>$key ); + + if( $num > 0 ) { + $search->maximum_to_retrieve( $num + 1 ); + } else { + $search->maximum_to_retrieve( 1 ); + } + $search->timeout( 10 ); + # SOAP::Lite, which is the Urban Dictionary backend, is smart enough to escape queries on its own. + $search->native_query( $what ); + $search->seek_result( $num ); + my $result; + if( !( $result = $search->next_result() ) ) { + print( "DICT: No result", "\n" ); + if( $num == 0 ) { + $kernel->post( $src, $replypath, "No result for '$what'.", $dest ); + } else { + $kernel->post( $src, $replypath, "No entry #".$num." for '$what'.", $dest ); + } + return; + } + my $response = $result->{ 'word' }.": ".$result->{ 'description' }; + $response =~ s/\n/ /g; + print( "DICT: Fetched result\n" ); + $heap->{ 'DICT_cache' }->{ 'URBAN' }->{ "$num.$what" } = $response; + $kernel->post( $src, $replypath, $response, $dest ); + } else { + use Net::Dict; + print( "DICT: Establish connection.\n" ); + my $oDict = Net::Dict->new( $Destult::config{ 'DICT_SERVER' } ); + if( !$oDict ) { + $kernel->post( $src, $replypath, "Can't contact dict server.", $dest ); + return; + } + if( $dict ne "default" ) { + print( "DICT: '".( split( /\//, $what, 2 ) )[0]."' source.\n" ); + $oDict -> setDicts( ( $dict ) ); + } else { + print( "DICT: Default sources.\n" ); + $oDict -> setDicts( ( "wn", "jargon", "foldoc", "web1913" ) ); + } + + print( "DICT: Grab definition.\n" ); + my $lookup = $oDict->define( $what ); + print( "DICT: Parsing.\n" ); + if( $#{ $lookup } < $num ) { + print( "DICT: No result.\n" ); + if( $num == 0 ) { + $kernel->post( $src, $replypath, "No result for '$what'.", $dest ); + } else { + $kernel->post( $src, $replypath, "No result #".$num." for '$what'.", $dest ); + } + return; + } + my $def = ${@{ $lookup }[$num]}[1]; + + $def =~ s/\n/ /g; + $def =~ s/ {2,}/ /g; + $def =~ s/ :/:/g; + $def =~ s/[^y](((n|v|adj|adv) ?[0-9]?:)|([0-9]:))/\n$1/gi; + $def =~ s/\[syn.*(\n|$)/\n/g; + # $def =~ s/;.*//g; + print( $def, "\n" ); + my @def = split( /\n/, $def ); + my $string = shift( @def ); + $string =~ s/^/'/; + $string =~ s/ *$/':/; + my $j = 0; + for $def ( @def ) { + $def =~ s/ *$//g; + if( $def =~ /(n|v|adj|adv) ?[1-3]?:/i ) { + chop( $string ); + $string .= ($j==0?":":".")." $def;"; + $j++; + } elsif( $def =~ /[1-3]:/i ) { + $def =~ s/[[:space:]]*$//g; + $string .= " $def;"; + } + } + chop( $string ); + $heap->{ 'DICT_cache' }->{ uc( $dict ) }->{ "$num.$what" } = $string; + $kernel->post( $src, $replypath, $string, $dest ); + } } NSLOOKUP: |- @@ -365,14 +435,17 @@ NSLOOKUP: |- WIKI: |- sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + + if( !( $what =~ /[a-z0-9]/i ) ) { + $kernel->post( $src, $replypath, "USAGE: ~wiki
", $dest ); + return; + } use Net::Ping; my $ping = Net::Ping->new(); my $time = $ping->ping( "en.wikipedia.org" ); use WWW::Wikipedia; - my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; - my $ping = Net::Ping->new(); - my $time = $ping->ping( "en.wikipedia.org" ); my $string; my $full = 0; if( $time < 5 ) { @@ -425,20 +498,21 @@ ADVERTISE: |- my( $time, $how, $message ) = split( / /, $what, 3 ); my( $prot, $type, $targ ) = split( /:/, $how, 3 ); $time = int( $time ); - if( exists( $heap->{ identified }->{ uc( $who ) } ) ) { - if( $time >= 0 ) { + if( exists( $heap->{ 'identified' }->{ uc( $who ) } ) ) { + if( length( $what ) > 0 && $time >= 0 ) { if( $message ) { - if( !exists( $heap->{ ads } ) ) { - $heap->{ ads } = []; + if( !exists( $heap->{ 'ads' } ) ) { + $heap->{ 'ads' } = []; } - my $ad = scalar( @{ $heap->{ ads } } ); - $heap->{ ads }->[ $ad ] = [ $time, $prot, $type, $targ, $message ]; + my $ad = scalar( @{ $heap->{ 'ads' } } ); + $heap->{ 'ads' }->[ $ad ] = [ $time, $prot, $type, $targ, $message ]; $kernel->delay_set( "advertise", $time, $ad ); + $kernel->post( $src, $replypath, "$who: Advert added as #".$ad, $dest ); } else { - if( exists( $heap->{ ads }->[ $time ] ) ) { + if( exists( $heap->{ 'ads' }->[ $time ] ) ) { $kernel->post( $src, $replypath, "$who: Ad disabled.", $dest ); print( "ADVERTISE: Ad #".$time." disabled.\n" ); - $heap->{ ads }->[ $time ]->[0] = -1; + $heap->{ 'ads' }->[ $time ]->[0] = -1; } else { $kernel->post( $src, $replypath, "$who: Ad #".$time." not found.", $dest ); print( "ADVERTISE: Ad #".$time." not found.\n" ); @@ -447,10 +521,10 @@ ADVERTISE: |- } else { $kernel->post( $src, $replypath, "Usage: ADVERTISE :: ", $dest ); $kernel->post( $src, $replypath, "Ex. : ADVERTISE 3600 mod_irc:send_public_to:#dc Hourly Advertisement", $dest ); - if( exists( $heap->{ ads } ) ) { + if( exists( $heap->{ 'ads' } ) ) { $kernel->post( $src, $replypath, "Current advertisements:", $dest ); my $i = 0; - for( @{ $heap->{ ads } } ) { + for( @{ $heap->{ 'ads' } } ) { my( $period, $prot, $type, $targ, $message ) = @{ $_ }; $kernel->post( $src, $replypath, "$i: ($period) -> $prot:$type:$targ : $message", $dest ); $i++; @@ -539,32 +613,34 @@ BASH: |- my $ping = Net::Ping->new(); my $time = $ping->ping( "bash.org" ); - unless( $what =~ /^[0-9]+$/ || $what eq "random" ) { + unless( $what =~ /^([0-9]+)|(random)$/ ) { $kernel->post( $src, $replypath, "Quote # should be a postive integer.", $dest ); return; } - + if( $time < 5 ) { use LWP::UserAgent; my $ua = LWP::UserAgent->new; my $req = HTTP::Request->new( GET => 'http://bash.org/?'.$what ); my $res = $ua->request( $req ); + my @quotes; if( $res->is_success ) { my $content = $res->content; - $content =~ s/[\n\r]//g; - if( $content =~ m/

.*?

(.+?)<\/p>.*?<\/p>/ || - $content =~ m/

(.+)<\/p>/ ) { - my $line = $1; - $line =~ s/>/>/g; - $line =~ s/<//, $line )) { - $kernel->post( $src, $replypath, $sline, $dest ); - } - } else { - $kernel->post( $src, $replypath, "Received response did not contain a quote section.", $dest ); - } + $content =~ s/[\n\r]//g; + + while( $content =~ s/

.*?(#[0-9]+)<\/b><\/a>.*?

(.*?)<\/p>//i ) { + my $num = $1; + my $text = $2; + $text =~ s/
/\n/gi; + $text =~ s/<//gi; + $text =~ s/&/&/gi; + $text =~ s/"/"/gi; + $text =~ s/ / /gi; + push @quotes, [ $num, $text ]; + } + my $quote = $quotes[ int(rand($#quotes+1)) ]; + $kernel->post( $src, $replypath, $quote->[0].":\n".$quote->[1], $dest ); } else { $kernel->post( $src, $replypath, "Something happened: ".$res->status_line, $dest ); } @@ -572,3 +648,628 @@ BASH: |- $kernel->post( $src, $replypath, "bash.org is responding too slowly.", $dest ); } } + +TRANSLATE: |- + sub { + use Lingua::Translate; + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + if( $what eq "" ) { + my $bbl = Lingua::Translate::Babelfish->new( src=>"en", dest=>"en" ); + my @languages = $bbl->available(); + my $response = join( ', ', @languages ); + $response =~ s/_/->/g; + $kernel->post( $src, $replypath, "I can translate these languages: ".$response, $dest ); + $kernel->post( $src, $replypath, "Usage: translate [from] [to] ", $dest ); + return; + } + my @words = split( / /, $what ); + if( $words[0] eq "from" ) { + shift @words; + } + my $from = shift @words; + if( $words[0] eq "to" ) { + shift @words; + } + my $to = shift @words; + my $tlater; + my $translation; + eval { + $tlater = Lingua::Translate->new( src => $from, dest => $to ); + $translation = $tlater->translate( join( ' ', @words ) ); + }; + if( $@ ) { + chomp $@; + $kernel->post( $src, $replypath, "Translation failed. Invalid arguments? Error message: '$@'", $dest ); + return; + } + $kernel->post( $src, $replypath, $translation, $dest ); + } + +RSS: |- + sub { + use WWW::Shorten 'SnipURL'; + use XML::RSS; + use LWP::Simple; + use Time::CTime; + + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my @args = split( / /, $what ); + if( $#args < 1 || !( $args[1] =~ /^([0-9]+-)?[0-9]+$/ ) ) { + $kernel->post( $src, $replypath, "Usage: RSS - [ ... ]", $dest ); + $kernel->post( $src, $replypath, "Standard fields are usually 'title,' 'link,' 'description.' Prepend a field with '+' to compress whitespace. Prepend a field with '!' to strip out HTML (and convert, where possible.) Prepend a field with '\@' to have that field start on its own line in the response. Any combination of these three flags is acceptable.", $dest ); + return; + } + my $url = shift @args; + my $count = shift @args; + my( $first, $last ); + if( $count =~ /^-([0-9]+)$/ ) { + $first = 0; + $last = $1; + } elsif( $count =~ /^[0-9]+$/ ) { + # I'd like this to be different, but it has to be this way for legacy purposes. + $first = 0; + $last = $count; + } elsif( $count =~ /^([0-9]+)-([0-9]+)$/ ) { + $first = $1; + $last = $2; + } + print( "RSS: $first to $last\n" ); + if( $#args == -1 ) { + @args = ( 'superdate', 'supertitle', 'title', 'link' ); + } + + my $xml; + if( !( $xml = get( $url ) ) ) { + $kernel->post( $src, $replypath, "Failed to fetch RSS feed from $url", $dest ); + return; + } + my $rss = new XML::RSS; + eval { $rss->parse( $xml ); }; + if( $@ ) { + $kernel->post( $src, $replypath, "Document was fetched, but wasn't valid XML", $dest ); + return; + } + my $response = ""; + my @items; + my @nargs; + for my $arg( @args ) { + if( $arg eq "superdate" ) { + push @items, strftime( "%a %b %e %H:%M:%S %Y", localtime ); + } elsif( $arg =~ /^super/ ) { + my $tmp = substr( $arg, 5 ); + if( exists( $rss->{ 'channel' }->{ $arg } ) ) { + push @items, $rss->{ 'channel' }->{ $arg }; + } + } else { + push @nargs, $arg; + } + } + @args = @nargs; + my $n = 0; + for my $item ( @{ $rss->{ 'items' } } ) { + $n++; + if( $n < $first ) { + next; + } + if( $n > $last ) { + last; + } + + my @bits; + for my $arg( @args ) { + my $strip = 0; + my $ownline = 0; + my $compress = 0; + my $oneline = 0; + my $elem = $arg; + + while( $elem =~ /^[+\!@#]/ ) { + if( substr( $elem, 0, 1 ) eq '+' ) { + $elem = substr( $elem, 1 ); + $compress = 1; + } + if( substr( $elem, 0, 1 ) eq '!' ) { + $elem = substr( $elem, 1 ); + $strip = 1; + } + if( substr( $elem, 0, 1 ) eq '@' ) { + $elem = substr( $elem, 1 ); + $ownline = 1; + } + if( substr( $elem, 0, 1 ) eq '#' ) { + $elem = substr( $elem, 1 ); + $oneline = 1; + } + } + if( exists( $item->{ $elem } ) ) { + if( $elem eq "link" ) { + push @bits, "<".makeashorterlink( $item->{ 'link' } ).">"; + } else { + my $tmp = $item->{ $elem }; + if( $strip == 1 ) { + $tmp =~ s/
/\n/g; + $tmp =~ s/<[^>]+>//g; + $tmp =~ s/<//gi; + $tmp =~ s/"/"/gi; + $tmp =~ s/&/&/gi; + } + if( $oneline == 1 ) { + $tmp =~ s/\n/ /gi; + } + if( $compress == 1 ) { + $tmp =~ s/\n/|/gi; + $tmp =~ s/^[|]//; + $tmp =~ s/[|]$//; + $tmp =~ s/[|][[:space:]]+/|/g; + $tmp =~ s/[|]+/|/g; + } + if( $ownline == 1 ) { + $tmp = "\n".$tmp; + } + push @bits, $tmp; + } + } else { + push @bits, $elem; + } + } + push @items, join( ' ', @bits ); + } + $response .= join( ' | ', @items ); + $response =~ s/[|[:space:]]+$//gm; + $kernel->post( $src, $replypath, $response, $dest ); + } + +JOIN: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + if( $what =~ /^[#&][^ ,]+$/ ) { + $kernel->post( "mod_irc", "do_join", $what ); + $kernel->post( $src, $replypath, "Okay.", $dest ); + } else { + $kernel->post( $src, $replypath, "'$what' is not a valid channel name.", $dest ); + } + } + +IGNORE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + $what =~ s/[[:space:]]+$//; + if( exists( $heap->{ 'ignored' }->{ $what } ) ) { + $kernel->post( $src, $replypath, "'$what' is already ignored.", $dest ); + return; + } + $heap->{ 'ignored' }->{ $what } = $who; + $kernel->post( $src, $replypath, "'$what' is now ignored.", $dest ); + DumpFile( "ignored.yaml", $heap->{ 'ignored' } ); + } + +UNIGNORE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + $what =~ s/[[:space:]]+$//; + if( exists( $heap->{ 'ignored' }->{ $what } ) ) { + delete $heap->{ 'ignored' }->{ $what }; + $kernel->post( $src, $replypath, "'$what' is no longer ignored.", $dest ); + DumpFile( "ignored.yaml", $heap->{ 'ignored' } ); + return; + } + $kernel->post( $src, $replypath, "'$what' is not ignored.", $dest ); + } + +REPLACE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my( $factoid, $find, $replace ) = split( '/', $what ); + $factoid =~ s/[[:space:]]+$//gi; + $factoid = uc( $factoid ); + if( exists( $heap->{ 'db' }->{ $factoid } ) ) { + my $fact = $heap->{ 'db' }->{ $factoid }; + eval { $fact =~ s/$find/$replace/gi; }; + if( $! ) { + $kernel->post( $src, $replypath, "Regex Failed: $!", $dest ); + return; + } + $heap->{ 'db' }->{ $factoid } = $fact; + DumpFile( "factoids.yaml", $heap->{ 'db' } ); + $kernel->post( $src, $replypath, $fact, $dest ); + } else { + $kernel->post( $src, $replypath, "There is no factoid called '$factoid'.", $dest ); + return; + } + } + +FANDANGO: |- + sub { + use LWP::Simple; + use POSIX; + + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + + my @args = split( / /, $what ); + my $page = 1; + my $count = 3; + my $start = 0; + my $end = 2; + my $total = 0; + my $zip = 0; + my $theater = ''; + + if( $#args >= 3 ) { + if( $args[3] =~ /^[0-9]+$/ ) { + $count = $args[3]; + } else { + $kernel->post( $src, $replypath, "Number of items to list per page should be numeric.", $dest ); + return; + } + } + if( $#args >= 2 ) { + if( $args[2] =~ /^[0-9]+$/ ) { + $page = $args[2]; + $start = ($args[2]-1)*$count; + $end = $start + $count - 1; + } else { + $kernel->post( $src, $replypath, "Page number should be numeric.", $dest ); + return; + } + } + if( $#args >= 1 ) { + if( $args[0] =~ /^[0-9]{5}$/ ) { + $zip = $args[0]; + } else { + $kernel->post( $src, $replypath, "First argument should be ZIP code.", $dest ); + return; + } + $theater = $args[1]; + } + if( $#args == 0 ) { + if( $args[0] =~ /^[0-9]{5}$/ ) { + my $site = get( 'http://www.fandango.com/TheaterListings.aspx?location='.$args[0] ); + $site =~ s/ / /gi; + my @lines = split( /\n/, $site ); + my @pages; + my @theaters; + + for my $line( @lines ) { + if( $line =~ m!!i && $line =~ m! I !) { + $line =~ s/.*(//g; + $line =~ s/[^0-9 ]//g; + $line =~ s/[[:space:]]+/ /g; + $line =~ s/(^[[:space:]]+)|([[:space:]]+$)//g; + @pages = split( / /, $line ); + last; + } + } + if( $#pages == -1 ) { + @pages = ( 0 ); + } + for my $page( @pages ) { + $site = get( 'http://www.fandango.com/TheaterListings.aspx?pn='.$page.'&location='.$args[0] ); + $site =~ s/ / /gi; + @lines = split( /\n/, $site ); + for my $line( @lines ) { + if( $line =~ m!([^<]+)!i ) { + push @theaters, [ $3, $1, $2 ]; + } + } + } + $kernel->post( $src, $replypath, ($#theaters+1)." theater".($#theaters==0?"":"s")." near ZIP ".$args[0].":", $dest ); + my $i = 0; + for my $theater( @theaters ) { + $kernel->post( $src, $replypath, (++$i).": ".$theater->[ 0 ].": ".$theater->[ 1 ]." ".$theater->[ 2 ], $dest ); + } + return; + } else { + $kernel->post( $src, $replypath, "First argument should be ZIP code.", $dest ); + return; + } + } + if( $#args == -1 ) { + $kernel->post( $src, $replypath, "USAGE: FANDANGO [ [ []]]", $dest ); + return; + } + + my $site = get( 'http://www.fandango.com/TheaterPage.aspx?location='.$zip.'&tid='.$theater ); + $site =~ s/ / /gi; + $site =~ s/[[:space:]]+/ /g; + my @movies = split( /

/, $site ); + pop @movies; + @movies = split( /
/, join( ' ', @movies ) ); + shift @movies; + $total = $#movies; + if( $total < $start ) { + $kernel->post( $src, $replypath, "Page #$page is out of range.", $dest ); + return; + } + @movies = @movies[ $start..$end ]; + $kernel->post( $src, $replypath, "Page $page of ".ceil(($total+1)/$count), $dest ); + for my $movie( @movies ) { + $movie =~ s/.*?<\/span>//gi; + $movie =~ s/.*?<\/span>.*?<\/span>//gi; + $movie =~ s/.*?<\/span>.*?<\/span>//gi; + $movie =~ s/.*?<\/span>//gi;#.*?<\/span>//gi; + $movie =~ s/ I <\/span>/ /gi; + $movie =~ s/<[^>]*>//g; + $movie =~ s/[[:space:]]+/ /g; + $kernel->post( $src, $replypath, $movie, $dest ); + } + } +WEBTENDER: |- + sub { + use YAML qw(LoadFile DumpFile); + use LWP::UserAgent; + + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + + if( !exists( $heap->{ 'WEBTENDER_cache' } ) ) { + if( -f 'webtenderCache.yaml' ) { + $heap->{ 'WEBTENDER_cache' } = LoadFile( "webtenderCache.yaml" ); + } else { + $heap->{ 'WEBTENDER_cache' } = {}; + } + } + + if( !exists( $heap->{ 'WEBTENDER_cache' }->{ uc( $what ) } ) ) { + my $ua = LWP::UserAgent->new( + agent => "Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8) Gecko/20051224 Debian/1.5.dfsg-3 Firefox/1.5" + ); + my $response = $ua->get( 'http://www.webtender.com/cgi-bin/search?name="'.$what.'"' ); + if( $response->{ '_rc' } != 200 ) { + $kernel->post( $src, $replypath, "Failed to retrieve search results.", $dest ); + return; + }; + my $dbn = undef; + OUTER: + for my $line( split( "\n", $response->{ '_content' } ) ) { + if( $line =~ /db\/drink\/([0-9]+)/ ) { + $dbn = $1; + last OUTER; + } + } + if( !defined( $dbn ) ) { + $kernel->post( $src, $replypath, "No match for '$what'", $dest ); + return; + } + $response = $ua->get( 'http://www.webtender.com/db/drink/'.$dbn ); + if( $response->{ '_rc' } != 200 ) { + $kernel->post( $src, $replypath, "Failed to retrieve drink details.", $dest ); + return; + }; + my $result; + my $mode = 0; + for my $line( split( "\n", $response->{ '_content' } ) ) { + if( $line =~ /

([^<]+)/ ) { + $result .= $1."\n"; + } elsif( $line =~ /

(Ingredients:)/i ) { + $result .= $1."\n"; + $mode = 1; + } elsif( $line =~ /

(Mixing Instructions:)/i ) { + $result .= "$1 "; + $mode = 2; + } elsif( $mode == 1 ) { + if( $line =~ /
  • (.*)/i ) { + my $tmp = $1; + $tmp =~ s/<[^>]*>//gi; + $result .= "* $tmp\n"; + } elsif( $line =~ /<\/UL>/i ) { + $mode = 0; + } + } elsif( $mode == 2 ) { + if( $line =~ /

    (.*)<\/P>/i ) { + my $tmp = $1; + $tmp =~ s/<[^>]*>//gi; + $result .= "$tmp\n"; + $mode = 0; + } + } + } + $heap->{ 'WEBTENDER_cache' }->{ uc( $what ) } = $result; + DumpFile( "webtenderCache.yaml", $heap->{ 'WEBTENDER_cache' } ); + } + + my $result = $heap->{ 'WEBTENDER_cache' }->{ uc( $what ) }; + $result =~ s/\n+/\n/g; + $result =~ s/\n$//g; + $kernel->post( $src, $replypath, $result, $dest ); + } + +SEEN: |- + sub { + use POSIX; + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + $what =~ s/(^[[:space:]]+)|([[:space:]]+$)//g; + if( exists( $heap->{ 'seen' } ) && exists( $heap->{ 'seen' }->{ uc( $what ) } ) ) { + my $t = time - $heap->{ 'seen' }->{ uc( $what ) }; + my $response; + if( $t > 86400 ) { + $response .= floor($t/86400)."d "; + $t = $t % 86400; + } + if( $t > 3600 ) { + $response .= floor($t/3600)."h "; + $t = $t % 3600; + } + if( $t > 60 ) { + $response .= floor($t/60)."m "; + $t = $t % 60; + } + $response .= $t."s ago"; + $kernel->post( $src, $replypath, "$what last seen $response", $dest ); + } else { + $kernel->post( $src, $replypath, "I haven't seen $what.", $dest ); + } + } + +MORSE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my $result; + my %morse = ( + 'A' => ".-", 'B' => "-...", 'C' => "-.-.", 'D' => "-..", + 'E' => ".", 'F' => "..-.", 'G' => "--.", 'H' => "....", + 'I' => "..", 'J' => ".---", 'K' => "-.-", 'L' => ".-..", + 'M' => "--", 'N' => "-.", 'O' => "---", 'P' => ".--.", + 'Q' => "--.-", 'R' => ".-.", 'S' => "...", 'T' => "-", + 'U' => "..-", 'V' => "...-", 'W' => ".--", 'X' => "-..-", + 'Y' => "-.--", 'Z' => "--..", '1' => ".----", '2' => "..---", + '3' => "...--", '4' => "....-", '5' => ".....", '6' => "-....", + '7' => "--...", '8' => "---..", '9' => "----.", '0' => "-----", + ); + for( my $i = 0; $i < length( $what ); $i++ ) { + my $ch = uc( substr( $what, $i, 1 ) ); + if( $ch eq ' ' ) { + $result .= " "; + } elsif( exists( $morse{ $ch } ) ) { + print( "$ch => ".$morse{ $ch }, "\n" ); + $result .= $morse{ $ch }." "; + } + } + print( $result, "\n" ); + $kernel->post( $src, $replypath, $result, $dest ); + } + +UPTIME: |- + sub { + use POSIX; + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my( $s, $m, $h, $d, $M, $y ) = gmtime( $heap->{ 'start' } ); + $y += 1900; + my $response = "Core session started on ".sprintf( "%04d-%02d-%02d %02d:%02D:%02d", $y, $M, $d, $h, $m, $s ); + $response .= ", so I have been running for "; + my $t = time - $heap->{ 'start' }; + if( $t > 86400 ) { + $response .= floor($t/86400)."d "; + $t = $t % 86400; + } + if( $t > 3600 ) { + $response .= floor($t/3600)."h "; + $t = $t % 3600; + } + if( $t > 60 ) { + $response .= floor($t/60)."m "; + $t = $t % 60; + } + $response .= $t."s."; + $kernel->post( $src, $replypath, $response, $dest ); + } + +RSVP: |- + sub { + use YAML qw(LoadFile DumpFile); + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + $who = lc( $who ); + if( ! -e ( "rsvps.yaml" ) ) { + $heap->{ 'rsvp' } = {}; + DumpFile( "rsvps.yaml", $heap->{ 'rsvp' } ); + } + if( !exists( $heap->{ "rsvp" } ) ) { + eval { $heap->{ 'rsvp' } = LoadFile( "rsvps.yaml" ) }; + if( $! ) { + $heap->{ 'rsvp' } = {}; + } + } + if( exists( $heap->{ "rsvp" }->{ $who } ) ) { + delete $heap->{ "rsvp" }->{ $who }; + $kernel->post( $src, $replypath, "RSVP removed.", $dest ); + } else { + $heap->{ "rsvp" }->{ $who } = time; + $kernel->post( $src, $replypath, "RSVP added.", $dest ); + } + DumpFile( "rsvps.yaml", $heap->{ 'rsvp' } ); + } + +ARSVP: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + $what = lc( $what ); + $what =~ s/(^[[:space:]]*)|([[:space:]]*$)//g; + if( ! -e ( "rsvps.yaml" ) ) { + $heap->{ 'rsvp' } = {}; + DumpFile( "rsvps.yaml", $heap->{ 'rsvp' } ); + } + if( !exists( $heap->{ "rsvp" } ) ) { + eval { $heap->{ 'rsvp' } = LoadFile( "rsvps.yaml" ) }; + if( $! ) { + $heap->{ 'rsvp' } = {}; + } + } + if( exists( $heap->{ "rsvp" }->{ $what } ) ) { + delete $heap->{ "rsvp" }->{ $what }; + $kernel->post( $src, $replypath, "RSVP for '$what' removed.", $dest ); + } else { + $heap->{ "rsvp" }->{ $what } = time; + $kernel->post( $src, $replypath, "RSVP for '$what' added.", $dest ); + } + DumpFile( "rsvps.yaml", $heap->{ 'rsvp' } ); + } + +RSVPS: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + if( -e ( "rsvps.yaml" ) ) { + eval { $heap->{ 'rsvp' } = LoadFile( "rsvps.yaml" ) }; + } + if( !exists( $heap->{ "rsvp" } ) ) { + $kernel->post( $src, $replypath, "No RSVPs found.", $dest ); + } else { + my @names = keys %{ $heap->{ "rsvp" } }; + if( scalar( @names ) == 0 ) { + $kernel->post( $src, $replypath, "No RSVPs found.", $dest ); + } else { + my $reply = ""; + for my $name ( @names ) { + if( $reply ne "" ) { + $reply .= ", $name"; + } else { + $reply = $name; + } + } + $kernel->post( $src, $replypath, "RSVPs received: $reply", $dest ); + } + } + } + +CLEARRSVP: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + if( !exists( $heap->{ "rsvp" } ) ) { + $kernel->post( $src, $replypath, "No RSVPs found.", $dest ); + } else { + delete $heap->{ "rsvp" }; + if( -e ( "rsvps.yaml" ) ) { + unlink 'rsvps.yaml'; + } + $kernel->post( $src, $replypath, "RSVPs cleared.", $dest ); + } + } + +GROUPHUG: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + use LWP::UserAgent; + my $ua = LWP::UserAgent->new; + my $req = HTTP::Request->new( GET => 'http://grouphug.us/random' ); + my $res = $ua->request( $req ); + my @hugs; + if( $res->is_success ) { + my $content = $res->content; + $content =~ s/[\n\r]//g; + while( $content =~ s/.*?

    ([0-9]+)<\/a>.*?(.*?)<\/td>//i ) { + my $text = "$1: $2"; + $text =~ s/
    / /gi; + $text =~ s/[[:space:]]+/ /gi; + $text =~ s/<[^>]*>//gi; + $text =~ s/<//gi; + $text =~ s/&/&/gi; + $text =~ s/"/"/gi; + $text =~ s/ / /gi; + push @hugs, $text; + } + my $hug = $hugs[ int( rand( $#hugs+1 ) ) ]; + $kernel->post( $src, $replypath, $hug, $dest ); + } else { + $kernel->post( $src, $replypath, "Failed to fetch list of hugs.", $dest ); + } + } diff --git a/config.pl b/config.pl index 12df7f6..0f06970 100644 --- a/config.pl +++ b/config.pl @@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut -use YAML ':all'; +use YAML qw(LoadFile DumpFile); use strict; use warnings; diff --git a/config.yaml.example b/config.yaml.example index ab736b0..06b8cfc 100644 --- a/config.yaml.example +++ b/config.yaml.example @@ -1,6 +1,5 @@ --- #YAML:1.0 -CHANNEL: dc pants -IRC: irc.tamu.edu +SERVERS: irc://irc.tamu.edu/#dc NICKNAME: Destult PASSWORD: Ic43 SC_PORT: 8118 diff --git a/core.pl b/core.pl index 3adfbed..e1093ae 100644 --- a/core.pl +++ b/core.pl @@ -1,5 +1,5 @@ =COPYLEFT - Copyright 2004, Patrick Bogen + Copyright 2004-2006, Patrick Bogen This file is part of Destult2. @@ -22,45 +22,83 @@ use POE::Session; use warnings; use strict; -POE::Session->new( - _start => \&on_start, - cmd => \&cmd, - unidentify => \&unidentify, - advertise => \&advertise, +POE::Session->create( + inline_states => { + _start => \&on_start, + cmd => \&cmd, + unidentify => \&unidentify, + advertise => \&advertise, + seen => \&seen, + }, ) or die( "Unable to create core POE session." ); +sub seen { + my( $kernel, $heap, $who ) = @_[ KERNEL, HEAP, ARG0 ]; + if( !exists( $heap->{ 'seen' } ) ) { + $heap->{ 'seen' } = { }; + } + $heap->{ 'seen' }->{ uc( $who ) } = time; +} sub on_start { my( $kernel, $heap ) = ( $_[KERNEL], $_[HEAP] ); + $heap->{ 'start' } = time; if( -e "commands.yaml" ) { my %source = %{ LoadFile( "commands.yaml" ) }; - foreach( keys %source ) { - $heap->{ commands }->{ $_ } = eval( $source{ $_ } ); - die( $@ ) if $@; - print( "CORE: Parsed $_.\n" ); + for my $key ( keys %source ) { + print( "CORE: Parsing $key..." ); + $heap->{ 'commands' }->{ $key } = eval( $source{ $key } ); + if( $@ ) { + print( "FAILED: $@\n\n" ); + } else { + print( "Done.\n" ); + } } } else { print( "CORE: No commands found.\n" ); } if( -e "factoids.yaml" ) { - $heap->{ db } = \%{ LoadFile( "factoids.yaml" ) }; + $heap->{ 'db' } = \%{ LoadFile( "factoids.yaml" ) }; print( "CORE: Factoids loaded.\n" ); } else { print( "CORE: No factoids found.\n" ); } if( -e "privs.yaml" && -e "access.yaml" ) { - $heap->{ privs } = \%{ LoadFile( "privs.yaml" ) }; - $heap->{ access } = \%{ LoadFile( "access.yaml" ) }; + $heap->{ 'privs' } = \%{ LoadFile( "privs.yaml" ) }; + $heap->{ 'access' } = \%{ LoadFile( "access.yaml" ) }; print( "CORE: Users loaded.\n" ); } else { + $heap->{ 'privs' } = { }; + $heap->{ 'access' } = { }; print( "CORE: No users found.\n" ); } - $heap->{ identified } = {}; + if( -e "ignored.yaml" ) { + $heap->{ 'ignored' } = \%{ LoadFile( "ignored.yaml" ) }; + print( "CORE: Ignored users loaded.\n" ); + } else { + $heap->{ 'ignored' } = { }; + print( "CORE: No ignored users.\n" ); + } + + $heap->{ 'identified' } = {}; + $heap->{ 'servers' } = []; $kernel->alias_set( "core" ); - print( "CORE: ".$Destult::config{ 'NICKNAME' }." Started.\n" ); + print( "CORE: Started.\n" ); + for my $server ( split( / /, $Destult::config{ 'SERVERS' } ) ) { + $server =~ m'([^:]+)://([^/]+)(/[^/]+)*'i; + my( $prot, $host, $opts ) = ( $1, $2, $3 ); + print( "Connect to $host over $prot: $opts\n" ); + if( $prot =~ /irc/i ) { + my @opts = split( '/', $opts ); + shift @opts; + push @{ $heap->{ 'servers' } }, irc::new( $host, shift @opts, @opts ); + } else { + die( "CORE: Unknown protocol: '$prot'" ); + } + } } sub cmd { @@ -69,29 +107,41 @@ sub cmd { $what =~ s/^[~]//; my( $cmd, $subj ) = ( split( / /, $what, 2 ) ); $subj = "" unless $subj; + if( exists( $heap->{ 'ignored' }->{ $who } ) ) { + print( "CORE:!<$who> $cmd -- $subj\n" ) unless( !exists $Destult::config{ 'DEBUG' } ); + return; + } print( "CORE: <$who> $cmd -- $subj\n" ) unless( !exists $Destult::config{ 'DEBUG' } ); - if( exists( $heap->{ commands }->{ uc( $cmd ) } ) ) { - if( !exists $heap->{ access }->{ "@".uc( $cmd ) } || ( - exists $heap->{ identified }->{ uc( $who ) } && - access( $kernel, $heap, uc( $who ) ) >= $heap->{ access }->{ "@".uc( $cmd ) } ) ) { - &{ $heap->{ commands }->{ uc( $cmd ) } }( $kernel, $heap, $who, $subj, $src, $dest, $replypath ); + + my $noparse = 0; + if( substr( $cmd, 0, 1 ) eq "+" ) { + $noparse = 1; + $cmd = substr( $cmd, 1 ); + } + + if( exists( $heap->{ 'commands' }->{ uc( $cmd ) } ) ) { + if( !exists $heap->{ 'access' }->{ "@".uc( $cmd ) } || + $heap->{ 'access' }->{ "@".uc( $cmd ) } == 0 || ( + exists $heap->{ 'identified' }->{ $src.uc( $who ) } && + accessLevel( $kernel, $heap, uc( $who ), $src ) >= $heap->{ 'access' }->{ "@".uc( $cmd ) } ) ) { + &{ $heap->{ 'commands' }->{ uc( $cmd ) } }( $kernel, $heap, $who, $subj, $src, $dest, $replypath ); } else { - $kernel->post( $src, $replypath, "$who: An access level of ".$heap->{ access }->{ "@".uc( $cmd ) }." is required for '$cmd'", $dest ); + $kernel->post( $src, $replypath, "$who: An access level of ".$heap->{ 'access' }->{ "@".uc( $cmd ) }." is required for '$cmd'", $dest ); } - } elsif( exists( $heap->{ db }->{ uc( $what ) } ) ) { - &{ $heap->{ commands }->{ 'PARSE' } }( $kernel, $heap, $who, $what, $src, $dest, $replypath ); + } elsif( exists( $heap->{ 'db' }->{ uc( $what ) } ) && !$noparse ) { + &{ $heap->{ 'commands' }->{ 'PARSE' } }( $kernel, $heap, $who, $what, $src, $dest, $replypath ); } else { $kernel->post( $src, "send_private", "Huh?", $who ); } } -sub access { - my( $kernel, $heap, $whom ) = @_; - if( !exists( $heap->{ identified }->{ uc( $whom ) } ) ) { +sub accessLevel { + my( $kernel, $heap, $whom, $src ) = @_; + if( !exists( $heap->{ 'identified' }->{ $src.uc( $whom ) } ) ) { print( "ACC: $whom isn't idenfitied.\n" ); return 0; } - return access2( $heap->{ access }, $whom, {} ); + return access2( $heap->{ 'access' }, $whom, {} ); } # Put this in two parts so we don't get infinite loops. @@ -113,14 +163,14 @@ sub access2 { sub unidentify { my( $kernel, $heap, $whom ) = @_[ KERNEL, HEAP, ARG0 ]; - if( exists( $heap->{ identified }->{ $whom } ) ) { - delete $heap->{ identified }->{ $whom }; + if( exists( $heap->{ 'identified' }->{ $whom } ) ) { + delete $heap->{ 'identified' }->{ $whom }; } } sub advertise { my( $kernel, $heap, $which ) = @_[ KERNEL, HEAP, ARG0 ]; - my( $period, $prot, $type, $targ, $message ) = @{ $heap->{ ads }->[ $which ] }; + my( $period, $prot, $type, $targ, $message ) = @{ $heap->{ 'ads' }->[ $which ] }; if( $period > 0 ) { print( "CORE: Advertisement '$message' to $prot:$type:$targ for $period valid.\n" ); $kernel->post( $prot, $type, $message, $targ ); diff --git a/destult2.pl b/destult2.pl index 92557af..f667059 100755 --- a/destult2.pl +++ b/destult2.pl @@ -26,8 +26,7 @@ use POE; our( %config ); require "./config.pl"; - -require "./core.pl"; require "./irc.pl"; +require "./core.pl"; $poe_kernel->run(); diff --git a/irc.pl b/irc.pl index b84d60e..87f598b 100644 --- a/irc.pl +++ b/irc.pl @@ -1,5 +1,5 @@ =COPYLEFT - Copyright 2004, Patrick Bogen + Copyright 2004-2006, Patrick Bogen This file is part of Destult2. @@ -18,59 +18,98 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA =cut +package irc; + use POE::Session; use POE::Component::IRC; use Text::Wrap; -POE::Session->new( - _start => \&on_start, - irc_001 => \&on_connect, - irc_public => \&on_public, - irc_msg => \&on_private, - irc_nick => \&on_nick, - irc_kick => \&on_kick, - irc_part => \&on_part, - irc_quit => \&on_quit, - send_private => \&send_private, - send_public => \&send_public, - send_public_to => \&send_public_to, - do_abort => \&do_abort, - watchdog => \&watchdog -) or die( "Unable to create IRC POE session." ); + +sub new { + my $self = {}; + $self->{ "host" } = shift; + $self->{ "channel" } = shift; + $self->{ "nick" } = "Destult"; + $self->{ "port" } = 6667; + $self->{ "password" } = ""; + while( shift ) { + my( $name, $value ) = split( /=/, $_, 2 ); + if( exists( $self->{ $name } ) ) { + $self->{ $name } = $value; + } + } + my $session = POE::Session->create( + inline_states => { + _start => \&on_start, + irc_001 => \&on_connect, + irc_public => \&on_public, + irc_msg => \&on_private, + irc_nick => \&on_nick, + irc_kick => \&on_kick, + irc_part => \&on_part, + irc_quit => \&on_quit, + send_private => \&send_private, + send_public => \&send_public, + send_public_to => \&send_public_to, + do_abort => \&do_abort, + do_join => \&do_join, + do_mode => \&do_mode, + watchdog => \&watchdog, + }, + heap => { + self => $self, + }, + ) or die( "Unable to create IRC POE session." ); + + $self->{ "ssid" } = $session->ID; + bless( $self ); + return $self; +} + +sub do_join { + my( $kernel, $heap, $what ) = @_[ KERNEL, HEAP, ARG0 ]; + if( $what =~ /^[#&][^ ,]+$/ ) { + $kernel->post( $heap->{ 'ircobject' }->session_id(), "join", $what ); + } else { + warn( "'$what' is an invalid channel name" ); + } +} sub do_abort { my( $kernel, $heap ) = @_[ KERNEL, HEAP ]; - $heap->{ ircobject }->{ send_queue } = []; + $heap->{ 'ircobject' }->{ 'send_queue' } = []; return; } sub watchdog { my( $kernel, $heap ) = ( $_[KERNEL], $_[HEAP] ); - if( ! $heap->{ ircobject }->connected() ) { + my $self = $heap->{ "self" }; + if( ! $heap->{ 'ircobject' }->connected() ) { print "IRC : Connection was lost.. reconnecting.\n"; - $kernel->post( $heap->{ ircobject }->session_id(), "connect", { - Nick => $config{ 'NICKNAME' }, + $kernel->post( $heap->{ 'ircobject' }->session_id(), "connect", { + Nick => $self->{ "nick" }, Username => "Destult2", Ircname => "Destultifier-Class Information Bot, v2", - Server => $config{ 'IRC' }, - Port => "6667", + Server => $self->{ "host" }, + Port => $self->{ "port" }, } ); } - $heap->{ timer } = 0 unless defined $heap->{ timer }; - $heap->{ timer }++; + $heap->{ 'timer' } = 0 unless defined $heap->{ 'timer' }; + $heap->{ 'timer' }++; # Back-up wathdog timer, in case IRC thinks it's connected but it isn't. - if( $heap->{ timer } == 60 ) { - $kernel->post( $heap->{ ircobject }->session_id(), "version" ); + if( $heap->{ 'timer' } == 60 ) { + $kernel->post( $heap->{ 'ircobject' }->session_id(), "version" ); } $kernel->delay_set( "watchdog", 5 ); } sub on_start { my( $kernel, $heap ) = ( $_[KERNEL], $_[HEAP] ); + my $self = $heap->{ "self" }; my $irc = POE::Component::IRC->spawn( ) or die( "Unable to spawn IRC object." ); - $heap->{ ircobject } = $irc; + $heap->{ 'ircobject' } = $irc; # This informs the IRC component to listen to: # 001 (Greeting) @@ -78,15 +117,13 @@ sub on_start { # MSG (private message) and # CTCP_ACTION (/me-type actions) - $kernel->alias_set( "mod_irc" ); - - $kernel->post( $heap->{ ircobject }->session_id(), "register", qw( 001 public msg nick kick part quit ) ); - $kernel->post( $heap->{ ircobject }->session_id(), "connect", { - Nick => $config{ 'NICKNAME' }, + $kernel->post( $heap->{ 'ircobject' }->session_id(), "register", qw( 001 public msg nick kick part quit ) ); + $kernel->post( $heap->{ 'ircobject' }->session_id(), "connect", { + Nick => $self->{ "nick" }, Username => "Destult2", Ircname => "Destultifier-Class Information Bot, v2", - Server => $config{ 'IRC' }, - Port => "6667", + Server => $self->{ "host" }, + Port => $self->{ "port" }, } ); $kernel->delay_set( "watchdog", 5 ); print( "IRC : Started.\n" ); @@ -95,21 +132,28 @@ sub on_start { # Connect to the channel specified by the config. sub on_connect { my $heap = $_[HEAP]; - if( exists $config{ 'PASSWORD' } ) { + my $self = $heap->{ "self" }; + if( $self->{ "password" } ne "" ) { print( "IRC : Attempting to register with nickserv.\n" ); - $_[KERNEL]->post( $heap->{ ircobject }->session_id(), "privmsg", "nickserv", "identify ".$config{ 'PASSWORD' } ); + $_[KERNEL]->post( $heap->{ 'ircobject' }->session_id(), "privmsg", "nickserv", "identify ".$self->{ "password" } ); } - print( "IRC : Connected to irc://".$config{ 'IRC' }."/#".$config{ 'CHANNEL' }."\n" ); - for my $chan (split( / /, $config{ 'CHANNEL' } )) { - $_[KERNEL]->post( $heap->{ ircobject }->session_id(), "join", "#".$chan ); + print( "IRC : Connected to irc://".$self->{ "host" }."/".$self->{ "channel" }."\n" ); + for my $chan (split( / /, $self->{ "channel" } )) { + $_[KERNEL]->post( $heap->{ 'ircobject' }->session_id(), "join", $chan ); } } sub on_public { my( $kernel, $who, $msg, $dest ) = @_[ KERNEL, ARG0, ARG2, ARG1 ]; + my $self = $_[HEAP]->{ "self" }; + my $nick = $self->{ "nick" }; $who = (split( /!/, $who, 2 ))[0]; + $msg =~ s/^$nick[ ,:]+/~/i; if( $who eq "a" ) { + # Strip source tag $msg =~ s/^\[[^\]]*\] +//g; + + # Reassign and strip sender ($who, $msg) = split( / /, $msg, 2 ); $who =~ s/[<>]//g; } @@ -117,18 +161,21 @@ sub on_public { $msg =~ s/(\x3)[0-9]{0,2}//g; $msg =~ s/\x02//g; $cmd = ( split( / /, $msg, 2 ) )[0]; + $kernel->post( "core", "seen", $who ); if( $cmd =~ /^[~].*/ ) { - $kernel->post( "core", "cmd", $who, $msg, "mod_irc", $dest->[0], "send_public_to" ); + $kernel->post( "core", "cmd", $who, $msg, $self->{ "ssid" }, $dest->[0], "send_public_to" ); } } sub on_private { my( $kernel, $who, $msg ) = @_[ KERNEL, ARG0, ARG2 ]; + my $self = $_[HEAP]->{ "self" }; $who = (split( /!/, $who, 2 ))[0]; $msg =~ s/(\x3)[0-9]{0,2}//g; $msg =~ s/\x02//g; $cmd = ( split( / /, $msg, 2 ) )[0]; - $kernel->post( "core", "cmd", $who, $msg, "mod_irc", $who, "send_private" ); + $kernel->post( "core", "seen", $who ); + $kernel->post( "core", "cmd", $who, $msg, $self->{ "ssid" }, $who, "send_private" ); } sub send_public { @@ -136,9 +183,9 @@ sub send_public { local( $Text::Wrap::columns = 354 ); my @msg = split( /\n/, wrap( '', '', $msg ) ); for( @msg ) { - $kernel->post( $heap->{ ircobject }->session_id(), "privmsg", "#".$config{ 'CHANNEL' }, $_ ); + $kernel->post( $heap->{ 'ircobject' }->session_id(), "privmsg", $self->{ "channel" }, $_ ); } - print( "IRC : =>".$config{ 'CHANNEL' }.": $msg\n" ); + print( "IRC : =>".$self-{ "channel" }.": $msg\n" ); } sub send_public_to { @@ -148,7 +195,7 @@ sub send_public_to { local( $Text::Wrap::columns = 354 ); my @msg = split( /\n/, wrap( '', '', $msg ) ); for( @msg ) { - $kernel->post( $heap->{ ircobject }->session_id(), "privmsg", $target, $_ ); + $kernel->post( $heap->{ 'ircobject' }->session_id(), "privmsg", $target, $_ ); } } else { print( "IRC : Could not send '$msg' to '$target' -- '$target' is not a channel\n" ); @@ -161,7 +208,7 @@ sub send_private { local( $Text::Wrap::columns = 354 ); my @msg = split( /\n/, wrap( '', '', $msg ) ); for( @msg ) { - $kernel->post( $heap->{ ircobject }->session_id(), "notice", $who, $_ ); + $kernel->post( $heap->{ 'ircobject' }->session_id(), "notice", $who, $_ ); } } @@ -184,3 +231,10 @@ sub on_quit { $whom = ( split( /!/, $whom, 2 ) )[0]; $kernel->post( "core", "unidentify", uc( $whom ) ); } + +sub do_mode { + my( $kernel, $heap, $channel, $mode ) = @_[ KERNEL, HEAP, ARG0, ARG1 ]; + $kernel->post( $heap->{ 'ircobject' }->session_id(), "mode", $channel, $mode ); +} + +return 1;