From: pdbogen Date: Wed, 29 Aug 2007 21:05:50 +0000 (+0000) Subject: Initial revisions X-Git-Url: http://git.mmlx.us/?a=commitdiff_plain;h=f0489613a7ff870d5abc7cbf9a896046ed496908;p=destult.git Initial revisions git-svn-id: https://www.cernu.us/~pdbogen/svn/destult2@1 088b83a4-0077-4247-935c-42ec02c2848b --- f0489613a7ff870d5abc7cbf9a896046ed496908 diff --git a/.svnignore b/.svnignore new file mode 100644 index 0000000..658bffa --- /dev/null +++ b/.svnignore @@ -0,0 +1,4 @@ +config.yaml +privs.yaml +factoids.yaml +ignored.yaml diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..7276acb --- /dev/null +++ b/ChangeLog @@ -0,0 +1,101 @@ +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 + sending, and requires the 'do_abort' event in the source session. +2005-07-28 pdbogen + * commands.yaml (1.25): Tweaked the wikipedia stuff a bit. +2005-07-08 pdbogen + * config.yaml.example (1.5): DICT_SERVER option added + * commands.yaml (1.24): More fault tolerance in DICT, and + configurable server. +2005-07-06 pdbogen + * commands.yaml (1.23): Bugfix in SIEVE + * commands.yaml (1.22): Bugfix in SIEVE + * commands.yaml (1.20), commands.yaml (1.21): Bugfix in SIEVE + * commands.yaml (1.19): Added a prime number generated based off + the Sieve of Erastothenes +2005-06-14 pdbogen + * commands.yaml (1.18): Append made more specific, and removed an + old newline from rlsomething. + * commands.yaml (1.17): $nick in a factoid will be replaced with + whoever called it. + * irc.pl (1.9): Re-inforcements to the watchdog timer +2005-06-07 pdbogen + * commands.yaml (1.16): Two changes: Added 'RLSOMETHING,' a toy + that generates a backronym for 'RL'. 2: Another factoid tag has + been added: '' This sends a GET request to a web page + (possibly with basic authentication like + http://user:pass@site/page). Note: this discards the output. This + is for interfacing with simple control webapps. It was written to + allow control of php-Lancaster. +2005-05-27 pdbogen + * commands.yaml (1.15): Added a 'dice' command +2005-05-22 pdbogen + * commands.yaml (1.14): Added 'RANDOM' and made sctitle a bit more + fault tolerant. +2005-05-18 pdbogen + * commands.yaml (1.13): See above. + * commands.yaml (1.12): ~dict can now accept a specific dictionary + in the form of / +2005-05-17 pdbogen + * commands.yaml (1.11): Added a command to terminate the bot. N.B.: + If Destult is used with the loop script, this will just restart it. + * irc.pl (1.8): Some functions that needed the heap didn't have it + defined. + * package (1.3): Reverse-sort the update stanzas + * package (1.2): Groups changes by date + * commands.yaml (1.10): Preliminary support for redundant Shoutcast + title fetching + * irc.pl (1.7): Switched to new-style POE::Component::IRC, and + added a Watchdog timer to reconnect if we lose the connection to + IRC. (5-second intervals) + * commands.yaml (1.9): Added 'listcommands' + * commands.yaml (1.8): Modified for upper-case config directives, + and online configuration adjustment added. + * config.pl (1.2), config.yaml.example (1.4), core.pl (1.7), irc.pl + (1.6): Modified for upper-case config directives + * commands.yaml (1.7): Adds a direct call to the Devil's + Dictionary, and support for appending to factoids + * irc.pl (1.5): Adds multi-channel support + * package (1.1): Let's me easily package cvs builds. Yay. + * config.yaml.example (1.3): Added SC_server and SC_port for + shoutcast server and shoutcast port. + * commands.yaml (1.6): Added code to fetch the title from a + shoutcast stream. Requires Netx::WebRadio::Station::Shoutcast if + you want to use it. +2005-01-20 pdbogen + * irc.pl (1.4): Underscores and dashes are okay for channel names + * commands.yaml (1.5): Fixed some bugs, added the ability to show + current advertisements and a usage message if the Period is <0 +2005-01-17 pdbogen + * core.pl (1.6): Changed a delay call to a delay_set call. + * .cvsignore (1.4): Added ignored.yaml + * commands.yaml (1.4): Added priveleged 'advertise' command + * core.pl (1.5): Added 'advertise' event. + * factoids.yaml.example (1.1), ignored.yaml.example (1.1), + privs.yaml.example (1.1): Initial revision. + * irc.pl (1.3): Modified send_public and send_private to use the + same paragraph-wrapping as send_public_to +2005-01-16 pdbogen + * commands.yaml (1.3): Added a DNS query command + * factoids.yaml (1.4), ignored.yaml (1.2), privs.yaml (1.3): + Shouldn't be in the repository. +2004-12-21 pdbogen + * factoids.yaml (1.3), privs.yaml (1.2): [no log message] + * .cvsignore (1.3): Added factoids.yaml + * commands.yaml (1.2): Added 'identify', 'register', 'password', + and 'define' + * core.pl (1.4): Added identity tracking + * irc.pl (1.2): Added tracking of nick changes, kicks, quits, and + parts + * .cvsignore (1.2): Added privs.yaml +2004-12-20 pdbogen + * factoids.yaml (1.2): Cleaned up 'say hi'. + * core.pl (1.3): Really fixed multiple-word factoids. + * core.pl (1.2): Fixed multiple-word factoids. + * config.yaml.example (1.2): Stripped useless options + * loop (1.2): Changed 'destult' to 'destult2' + * .cvsignore (1.1), check (1.1), commands.yaml (1.1), config.pl + (1.1), config.yaml.example (1.1), core.pl (1.1), destult2.pl (1.1), + factoids.yaml (1.1), ignored.yaml (1.1), irc.pl (1.1), loop (1.1), + privs.yaml (1.1): Initial Revision diff --git a/check b/check new file mode 100755 index 0000000..5926cf9 --- /dev/null +++ b/check @@ -0,0 +1,5 @@ +#!/bin/bash +for i in *.pl +do + perl -c $i +done diff --git a/commands.yaml b/commands.yaml new file mode 100644 index 0000000..8467024 --- /dev/null +++ b/commands.yaml @@ -0,0 +1,574 @@ +--- #YAML:1.0 +DIE: |- + sub { + exit; + } + +LINK: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my( $whom, $target ) = split( / /, $what, 2 ); + + 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 ) ) { + $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 } ); + $kernel->post( $src, $replypath, "Set.", $dest ); + } else { + $kernel->post( $src, $replypath, "'$whom' not registered.", $dest ); + } + } + +ACCESS: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my( $whom, $level ) = split( / /, $what, 2 ); + unless( $level =~ /^[0-9]$/ ) { + $kernel->post( $src, $replypath, "Access level should be a non-negative integer. (Did you want LINK?)", $dest ); + return; + } + 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 } ); + $kernel->post( $src, $replypath, "Set.", $dest ); + } else { + $kernel->post( $src, $replypath, "'$whom' not registered.", $dest ); + } + } + +CLASSIFY: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my( $cmd, $level ) = split( / /, $what, 2 ); + unless( $level =~ /^[0-9]$/ ) { + $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 } ); + $kernel->post( $src, $replypath, "Set.", $dest ); + } else { + $kernel->post( $src, $replypath, "'$cmd' not found.", $dest ); + } + } + +ACCESSLIST: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + $kernel->post( $src, $replypath, "Commands:", $dest ); + foreach( keys( %{ $heap->{ access } } ) ) { + if( substr( $_, 0, 1 ) eq "@" ) { + $kernel->post( $src, $replypath, " $_: ".$heap->{ access }->{ $_ }, $dest ); + } + } + $kernel->post( $src, $replypath, "Users:", $dest ); + foreach( keys( %{ $heap->{ access } } ) ) { + unless( substr( $_, 0, 1 ) eq "@" ) { + $kernel->post( $src, $replypath, " $_: ".$heap->{ access }->{ $_ }, $dest ); + } + } + } + +LISTCOMMANDS: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my $reply = "I have the following commands: "; + foreach( keys( %{ $heap->{ commands } } ) ) { + $reply .= $_." "; + } + $kernel->post( $src, $replypath, $reply, $dest ); + } +SCTITLE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + if( !exists $Destult::config{ 'SC_SERVER' } ) { + $kernel->post( $src, $replypath, "No shoutcast server configured.", $dest ); + return 0; + } + $Destult::config{ 'SC_PORT' } = 8000 unless exists $Destult::config{ 'SC_PORT' }; + + use Netx::WebRadio::Station::Shoutcast; + + my $station = Netx::WebRadio::Station::Shoutcast->new(); + if( $station->connect( + $Destult::config{ 'SC_SERVER' }, + $Destult::config{ 'SC_PORT' } + ) + ) { + $station->title( " " ); + my $i = 0; + while( $station->title() eq " " ) { + if( $i++ > 10000 ) { + $kernel->post( $src, $replypath, "Couldn't get title. Try again?", $dest ); + return; + } + if( !$station->receive() ) { + $kernel->post( $src, $replypath, "Problem getting data from server.", $dest ); + return; + } + } + $kernel->post( $src, $replypath, $station->title(), $dest ); + } else { + # my $http = new HTTP::Lite; + # my $req = $http->request( + # "http://".$Destult::config{ 'SC_SERVER' }. + # ":".$Destult::config{ 'SC_PORT' }."/index.html" + # ) or { + # $kernel->post( $src, $replypath, "Direct connect to stream failed and HTML grab failed.", $dest ); + # return 0; + # } + $kernel->post( $src, $replypath, "Direct connect to stream failed.", $dest ); + } + } + +IDENTIFY: |- + sub { + use Digest::MD5 qw( md5_hex ); + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my( $whom, $password ); + print( "IDENTIFY: $who for ***** from $src to $dest via $replypath\n" ); + + my @array = split( / /, $what ); + if( scalar( @array ) > 1 ) { + ( $whom, $password ) = split( / /, $what, 2 ); + } else { + ( $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 ); + } + } else { + $kernel->post( $src, $replypath, "User '$who' not found.", $dest ); + } + } + +REGISTER: |- + sub { + use Digest::MD5 qw( md5_hex ); + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my( $whom, $password ) = split( / /, $what, 2 ); + + if( $password ) { + $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 ); + } + } + +PASSWORD: |- + sub { + 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 } ); + $kernel->post( $src, $replypath, "Passwords changed.", $dest ); + } else { + $kernel->post( $src, $replypath, "Old passwords do not match.", $dest ); + } + } else { + $kernel->post( $src, $replypath, "You are not registered.", $dest ); + } + } + +CONFIG: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my( $subj, $predicate ) = split( / /, $what, 2 ); + if( $predicate ) { + $Destult::config{ uc( $subj ) } = $predicate; + DumpFile( "config.yaml", \%Destult::config ); + $kernel->post( $src, $replypath, "Okay, $who.", $dest ); + } elsif( exists( $Destult::config{ uc( $subj ) } ) ) { + $kernel->post( $src, $replypath, "$subj is '".$Destult::config{ uc( $subj ) }."'.", $dest ); + } else { + $kernel->post( $src, $replypath, "$subj is not found.", $dest ); + } + } + +DEFINE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + print( "DEFINE: $who for $what from $src to $dest via $replypath\n" ); + my( $subj, $predicate ) = split( / as /, $what, 2 ); + if( $subj ) { + if( $predicate ) { + $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 } ); + $kernel->post( $src, $replypath, "Okay, $who.", $dest ); + } + } else { + $kernel->post( $src, $replypath, "Invalid subject.", $dest ); + } + } + +APPEND: |- + sub { + 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( length( $predicate ) > 0 ) { + $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 ); + } + } else { + $kernel->post( $src, $replypath, "$who: '$subj' not found.", $dest ); + } + } + +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 ) } ); + if( $author ) { + $author = " -- ".$author; + } else { + $author = ""; + } + if( $response =~ /(.+)/ ) { + $response =~ s///; + my @targets = split( /[^\\];/, $response ); + for my $target (@targets) { + system( "wget $target -O /dev/null -b -o /dev/null" ); + } + $kernel->post( $src, $replypath, "Okay.", $dest ); + return; + } elsif( $response =~ /(.+)/ ) { + my @responses = split( /\|/, $1 ); + $response = $responses[ int( rand( scalar( @responses ) ) ) ].$author; + } else { + my @responses = split( /\|/, $response ); + $response = "$what is ".$responses[ int( rand( scalar( @responses ) ) ) ].$author; + } + $response =~ s/\$nick/$who/gi; + $kernel->post( "$src", $replypath, $response, $dest ); + } + +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 ); + } else { + $kernel->post( "$src", $replypath, "'$what' not found.", $dest ); + } + } + +LISTKEYS: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my $reply = "The following factoids were found: "; + foreach( keys( %{ $heap->{ db } } ) ) { + $reply .= "'$_' "; + } + $kernel->post( $src, $replypath, $reply, $dest ); + } + +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 =~ /[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 ); + 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 ); + } + +NSLOOKUP: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + if( $what =~ /^[-\w.]+$/ ) { + my $response = `host $what`; + $kernel->post( $src, $replypath, $response, $dest ); + } else { + $kernel->post( $src, $replypath, "Argument rejected. (Does not match /^[-\\w.]+\$/)", $dest ); + } + } + +WIKI: |- + sub { + 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 ) { + my $wiki = WWW::Wikipedia->new(); + $wiki->timeout( 5 ); + print( "WIKI: Searching...\n" ); + my $result; + if( substr( $what, 0, 1 ) eq "+" ) { + $full = 1; + $what = substr( $what, 1 ); + } + eval { $result = $wiki->search( $what ); }; + $string = $@ if $@; + + if( $result && $result->text() && $full == 0 ) { + print( "WIKI: Processing...\n" ); + $string = $result->text(); + $string =~ s/
//g; + $string =~ s/<(th|td|small)[^<>]*>[^<>]*<\/(th|td|small)>//gi; + $string =~ s/<[^<>]*>//g; + $string =~ s/\n\s*\n/@@@@@/g; + $string =~ s/\n/ /g; + $string =~ s/@@@@@/\n/g; + $string =~ s/\n/ -- /g; + $string =~ s/\s{2,}/ /g; + $string =~ s/—/ - /g; + } elsif( $result && $result->fulltext() ) { + $string = $result->fulltext(); + $string =~ s/\n/ /g; + $string =~ s/<(th|td|small)[^<>]*>[^<>]*<\/(th|td|small)>//gi; + $string =~ s/<[^<>]*>//g; + $string =~ s/\s{2,}/ /g; + } elsif( !$string ) { + print( "WIKI: No Result.\n" ); + $string = "No results for '$what'."; + } + if( $full != 0 && $result && $result->related() ) { + $string .= "\nRelated: ".join( " -- ", $result->related() ); + } + } else { + $string = "Wikipedia.org is responding too slowly (".$time."s)."; + } + $kernel->post( $src, $replypath, $string, $dest ); + } + +ADVERTISE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + print( "ADVERTISE: $who for $what from $src to $dest via $replypath\n" ); + 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( $message ) { + if( !exists( $heap->{ ads } ) ) { + $heap->{ ads } = []; + } + my $ad = scalar( @{ $heap->{ ads } } ); + $heap->{ ads }->[ $ad ] = [ $time, $prot, $type, $targ, $message ]; + $kernel->delay_set( "advertise", $time, $ad ); + } else { + if( exists( $heap->{ ads }->[ $time ] ) ) { + $kernel->post( $src, $replypath, "$who: Ad disabled.", $dest ); + print( "ADVERTISE: Ad #".$time." disabled.\n" ); + $heap->{ ads }->[ $time ]->[0] = -1; + } else { + $kernel->post( $src, $replypath, "$who: Ad #".$time." not found.", $dest ); + print( "ADVERTISE: Ad #".$time." not found.\n" ); + } + } + } 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 } ) ) { + $kernel->post( $src, $replypath, "Current advertisements:", $dest ); + my $i = 0; + for( @{ $heap->{ ads } } ) { + my( $period, $prot, $type, $targ, $message ) = @{ $_ }; + $kernel->post( $src, $replypath, "$i: ($period) -> $prot:$type:$targ : $message", $dest ); + $i++; + } + } + } + } else { + $kernel->post( $src, $replypath, "'Advertise' is restricted to identified users.", $dest ); + } + } + +RANDOM: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my @opts = split( / /, $what ); + if( $#opts >= 0 ) { + $kernel->post( $src, $replypath, $opts[ int( rand( $#opts+1 ) ) ], $dest ); + } + } + +DICE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my @opts = split( / /, $what, 2 ); + if( !( $opts[0] =~ /^[0-9]+$/ ) || + !( $opts[1] =~ /^[1-9][0-9]*$/ ) ) { + $kernel->post( $src, $replypath, "Usage: dice ", $dest ); + return; + } + + if( length( $opts[1] ) * $opts[0] > 300 ) { + $kernel->post( $src, $replypath, "Flood prevention triggered; output throttled.", $dest ); + return; + } + my $response = "Results: "; + for( my $i = 0; $i < $opts[0]; $i++ ) { + $response .= int( rand( $opts[1] ) )+1 ." "; + } + $kernel->post( $src, $replypath, $response, $dest ); + } + +RLSOMETHING: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my $response; + my @arrs = split( /\n/, `cat /usr/share/dict/words | grep -i ^r` ); + $response = $arrs[ int( rand( $#arrs ) ) ]." "; + my @ells = split( /\n/, `cat /usr/share/dict/words | grep -i ^l` ); + $response .= $ells[ int( rand( $#ells ) ) ]; + $kernel->post( $src, $replypath, $response, $dest ); + } + +SIEVE: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + my $response; + if( !( $what =~ /^([0-9]{2,}|[2-9])$/ ) ) { + $kernel->post( $src, $replypath, "Usage: sieve - Calculates the largest prime <= N", $dest ); + return; + } + my @array=0..$what; + for( my $i = 2; $i <= $what; $i++ ) { + next unless exists( $array[$i] ); + for( my $j = int( $what/$i ); $j > 1; $j-- ) { + delete $array[ $i * $j ] if exists $array[ $i * $j ]; + } + } + for( my $j = $what; $j >= 0; $j-- ) { + if( exists( $array[ $j ] ) ) { + $kernel->post( $src, $replypath, $array[ $j ], $dest ); + return; + } + } + } +ABORT: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + $kernel->post( $src, "do_abort" ); + $kernel->post( $src, $replypath, "Done.", $dest ); + } +BASH: |- + sub { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_; + + use Net::Ping; + my $ping = Net::Ping->new(); + my $time = $ping->ping( "bash.org" ); + + unless( $what =~ /^[0-9]+$/ || $what eq "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 ); + 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 ); + } + } else { + $kernel->post( $src, $replypath, "Something happened: ".$res->status_line, $dest ); + } + } else { + $kernel->post( $src, $replypath, "bash.org is responding too slowly.", $dest ); + } + } diff --git a/config.pl b/config.pl new file mode 100644 index 0000000..12df7f6 --- /dev/null +++ b/config.pl @@ -0,0 +1,43 @@ +=COPYLEFT + Copyright 2004, Patrick Bogen + + This file is part of Destult2. + + Destult2 is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + Destult2 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. + + You should have received a copy of the GNU General Public License + along with Destult2; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +=cut + +use YAML ':all'; +use strict; +use warnings; + +%Destult::config = ( + 'IRC' => "127.0.0.1", + 'NICKNAME' => "Destult", + 'CHANNEL' => "test", + 'PASSWORD' => "", +); + +# Load up the config file. +if( -e "config.yaml" ) { + %Destult::config = %{ LoadFile( "config.yaml" ) }; + foreach( keys( %Destult::config ) ) { + $Destult::config{ uc( $_ ) } = $Destult::config{ $_ }; + delete $Destult::config{ $_ } if $_ ne uc( $_ ); + } + DumpFile( "config.yaml", \%Destult::config ); +} else { + DumpFile( "config.yaml", \%Destult::config ); + die( "No config file. Default written. These values are probably wrong." ); +} diff --git a/config.yaml.example b/config.yaml.example new file mode 100644 index 0000000..ab736b0 --- /dev/null +++ b/config.yaml.example @@ -0,0 +1,8 @@ +--- #YAML:1.0 +CHANNEL: dc pants +IRC: irc.tamu.edu +NICKNAME: Destult +PASSWORD: Ic43 +SC_PORT: 8118 +SC_SERVER: grace.fast-serv.com +DICT_SERVER: dict.org diff --git a/core.pl b/core.pl new file mode 100644 index 0000000..3adfbed --- /dev/null +++ b/core.pl @@ -0,0 +1,129 @@ +=COPYLEFT + Copyright 2004, Patrick Bogen + + This file is part of Destult2. + + Destult2 is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + Destult2 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. + + You should have received a copy of the GNU General Public License + along with Destult2; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +=cut + +use POE::Session; +use warnings; +use strict; + +POE::Session->new( + _start => \&on_start, + cmd => \&cmd, + unidentify => \&unidentify, + advertise => \&advertise, +) or die( "Unable to create core POE session." ); + + +sub on_start { + my( $kernel, $heap ) = ( $_[KERNEL], $_[HEAP] ); + if( -e "commands.yaml" ) { + my %source = %{ LoadFile( "commands.yaml" ) }; + foreach( keys %source ) { + $heap->{ commands }->{ $_ } = eval( $source{ $_ } ); + die( $@ ) if $@; + print( "CORE: Parsed $_.\n" ); + } + } else { + print( "CORE: No commands found.\n" ); + } + + if( -e "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" ) }; + print( "CORE: Users loaded.\n" ); + } else { + print( "CORE: No users found.\n" ); + } + + $heap->{ identified } = {}; + $kernel->alias_set( "core" ); + print( "CORE: ".$Destult::config{ 'NICKNAME' }." Started.\n" ); +} + +sub cmd { + my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = + ( $_[KERNEL], $_[HEAP], $_[ARG0], $_[ARG1], $_[ARG2], $_[ARG3], $_[ARG4] ); + $what =~ s/^[~]//; + my( $cmd, $subj ) = ( split( / /, $what, 2 ) ); + $subj = "" unless $subj; + 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 ); + } else { + $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 ); + } else { + $kernel->post( $src, "send_private", "Huh?", $who ); + } +} + +sub access { + my( $kernel, $heap, $whom ) = @_; + if( !exists( $heap->{ identified }->{ uc( $whom ) } ) ) { + print( "ACC: $whom isn't idenfitied.\n" ); + return 0; + } + return access2( $heap->{ access }, $whom, {} ); +} + +# Put this in two parts so we don't get infinite loops. +sub access2 { + my( $access, $whom, $visited ) = @_; + if( exists $access->{ uc( $whom ) } ) { + if( $access->{ uc( $whom ) } =~ /^[0-9]+$/ ) { + print( "ACC: $whom: ".$access->{ uc( $whom ) }, "\n" ); + return $access->{ uc( $whom ) }; + } elsif( substr( $access->{ uc( $whom ) }, 0, 1 ) eq "~" ) { + print( "ACC: $whom -> ".substr( $access->{ uc( $whom ) }, 1 ), "\n" ); + $visited->{ uc( $whom ) } = 1; + return access2( $access, substr( $access->{ uc( $whom ) }, 1 ), $visited ); + } + } + print( "ACC: $whom has no access.\n" ); + return 0; +} + +sub unidentify { + my( $kernel, $heap, $whom ) = @_[ KERNEL, HEAP, ARG0 ]; + 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 ] }; + if( $period > 0 ) { + print( "CORE: Advertisement '$message' to $prot:$type:$targ for $period valid.\n" ); + $kernel->post( $prot, $type, $message, $targ ); + $kernel->delay_set( "advertise", $period, $which ); + } +} diff --git a/destult2.pl b/destult2.pl new file mode 100755 index 0000000..92557af --- /dev/null +++ b/destult2.pl @@ -0,0 +1,33 @@ +#!/usr/bin/perl + +=COPYLEFT + Copyright 2004, Patrick Bogen + + This file is part of Destult. + + Destult is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + Destult 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. + + You should have received a copy of the GNU General Public License + along with Destult; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +=cut +package Destult; +use warnings; +use strict; +use POE; + +our( %config ); +require "./config.pl"; + +require "./core.pl"; +require "./irc.pl"; + +$poe_kernel->run(); diff --git a/factoids.yaml.example b/factoids.yaml.example new file mode 100644 index 0000000..e8ebbd8 --- /dev/null +++ b/factoids.yaml.example @@ -0,0 +1,9 @@ +--- #YAML:1.0 +8BALL: >- + Signs point to yes.|Yes.|Reply hazy, try again.|Without a doubt.|My + sources say no.|As I see it, yes.|You may rely on it.|Concentrate and ask + again.|Outlook not so good.|It is decidedly so.|Better not tell you + now.|Very doubtful.|Yes - definitely.|It is certain.|Cannot predict + now.|Most likely.|Ask again later.|My reply is no.|Outlook good.|Don't count + on it. +'<3': 'I less-than-three you too.' diff --git a/ignored.yaml.example b/ignored.yaml.example new file mode 100644 index 0000000..f4bf308 --- /dev/null +++ b/ignored.yaml.example @@ -0,0 +1,2 @@ +--- #YAML:1.0 +Grif: 1 diff --git a/irc.pl b/irc.pl new file mode 100644 index 0000000..b84d60e --- /dev/null +++ b/irc.pl @@ -0,0 +1,186 @@ +=COPYLEFT + Copyright 2004, Patrick Bogen + + This file is part of Destult2. + + Destult2 is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + Destult2 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. + + You should have received a copy of the GNU General Public License + along with Destult2; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +=cut + +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 do_abort { + my( $kernel, $heap ) = @_[ KERNEL, HEAP ]; + $heap->{ ircobject }->{ send_queue } = []; + return; +} + +sub watchdog { + my( $kernel, $heap ) = ( $_[KERNEL], $_[HEAP] ); + if( ! $heap->{ ircobject }->connected() ) { + print "IRC : Connection was lost.. reconnecting.\n"; + $kernel->post( $heap->{ ircobject }->session_id(), "connect", { + Nick => $config{ 'NICKNAME' }, + Username => "Destult2", + Ircname => "Destultifier-Class Information Bot, v2", + Server => $config{ 'IRC' }, + Port => "6667", + } ); + } + $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" ); + } + $kernel->delay_set( "watchdog", 5 ); +} + +sub on_start { + my( $kernel, $heap ) = ( $_[KERNEL], $_[HEAP] ); + + my $irc = POE::Component::IRC->spawn( ) or die( "Unable to spawn IRC object." ); + + $heap->{ ircobject } = $irc; + + # This informs the IRC component to listen to: + # 001 (Greeting) + # Public (I.e., msg from a channel) + # 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' }, + Username => "Destult2", + Ircname => "Destultifier-Class Information Bot, v2", + Server => $config{ 'IRC' }, + Port => "6667", + } ); + $kernel->delay_set( "watchdog", 5 ); + print( "IRC : Started.\n" ); +} + +# Connect to the channel specified by the config. +sub on_connect { + my $heap = $_[HEAP]; + if( exists $config{ 'PASSWORD' } ) { + print( "IRC : Attempting to register with nickserv.\n" ); + $_[KERNEL]->post( $heap->{ ircobject }->session_id(), "privmsg", "nickserv", "identify ".$config{ '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 ); + } +} + +sub on_public { + my( $kernel, $who, $msg, $dest ) = @_[ KERNEL, ARG0, ARG2, ARG1 ]; + $who = (split( /!/, $who, 2 ))[0]; + if( $who eq "a" ) { + $msg =~ s/^\[[^\]]*\] +//g; + ($who, $msg) = split( / /, $msg, 2 ); + $who =~ s/[<>]//g; + } + # Strip color + $msg =~ s/(\x3)[0-9]{0,2}//g; + $msg =~ s/\x02//g; + $cmd = ( split( / /, $msg, 2 ) )[0]; + if( $cmd =~ /^[~].*/ ) { + $kernel->post( "core", "cmd", $who, $msg, "mod_irc", $dest->[0], "send_public_to" ); + } +} + +sub on_private { + my( $kernel, $who, $msg ) = @_[ KERNEL, ARG0, ARG2 ]; + $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" ); +} + +sub send_public { + my( $kernel, $heap, $msg ) = @_[ KERNEL, HEAP, ARG0 ]; + local( $Text::Wrap::columns = 354 ); + my @msg = split( /\n/, wrap( '', '', $msg ) ); + for( @msg ) { + $kernel->post( $heap->{ ircobject }->session_id(), "privmsg", "#".$config{ 'CHANNEL' }, $_ ); + } + print( "IRC : =>".$config{ 'CHANNEL' }.": $msg\n" ); +} + +sub send_public_to { + my( $kernel, $heap, $msg, $target ) = @_[ KERNEL, HEAP, ARG0, ARG1 ]; + if( $target =~ /^[#&][a-zA-Z0-9-_]+$/ ) { + print( "IRC : =>$target: $msg\n" ); + local( $Text::Wrap::columns = 354 ); + my @msg = split( /\n/, wrap( '', '', $msg ) ); + for( @msg ) { + $kernel->post( $heap->{ ircobject }->session_id(), "privmsg", $target, $_ ); + } + } else { + print( "IRC : Could not send '$msg' to '$target' -- '$target' is not a channel\n" ); + } +} + +sub send_private { + my( $kernel, $heap, $msg, $who ) = @_[ KERNEL, HEAP, ARG0, ARG1 ]; + my $nick = ( split( /!/, $target, 2 ) )[0]; + local( $Text::Wrap::columns = 354 ); + my @msg = split( /\n/, wrap( '', '', $msg ) ); + for( @msg ) { + $kernel->post( $heap->{ ircobject }->session_id(), "notice", $who, $_ ); + } +} + +sub on_kick { + my( $kernel, $heap, $whom ) = @_[ KERNEL, HEAP, ARG2 ]; + $kernel->post( "core", "unidentify", uc( $whom ) ); +} +sub on_nick { + my( $kernel, $heap, $whom ) = @_[ KERNEL, HEAP, ARG0 ]; + $whom = ( split( /!/, $whom, 2 ) )[0]; + $kernel->post( "core", "unidentify", uc( $whom ) ); +} +sub on_part { + my( $kernel, $heap, $whom ) = @_[ KERNEL, HEAP, ARG0 ]; + $whom = ( split( /!/, $whom, 2 ) )[0]; + $kernel->post( "core", "unidentify", uc( $whom ) ); +} +sub on_quit { + my( $kernel, $heap, $whom ) = @_[ KERNEL, HEAP, ARG0 ]; + $whom = ( split( /!/, $whom, 2 ) )[0]; + $kernel->post( "core", "unidentify", uc( $whom ) ); +} diff --git a/loop b/loop new file mode 100755 index 0000000..9c1c86c --- /dev/null +++ b/loop @@ -0,0 +1,3 @@ +./destult2.pl +sleep 5s +exec ./loop diff --git a/package b/package new file mode 100755 index 0000000..325ddee --- /dev/null +++ b/package @@ -0,0 +1,8 @@ +rm ChangeLog +cvs2cl --FSF -r +cat ChangeLog | perl -e 'use strict; use warnings; my $cur; my %events; while( <> ) { chomp; if( /^[\d]{4}-[\d]{2}-[\d]{2}/ ) { $cur = $_; } elsif( !( /^[\w]*$/ ) ) { if( !exists( $events{ $cur } ) ) { $events{ $cur } = [ $_ ]; } else { push @{ $events{ $cur } }, $_; } } }; for( reverse sort keys %events ) { print $_, "\n"; for( @{ $events{ $_ } } ) { print $_, "\n"; } }' > ChangeLog2 +mv ChangeLog2 ChangeLog +rm package +cd .. +NAME=destult2-`date +%Y-%m-%d`-CVS.tar.bz2 +tar cjf $NAME destult2 diff --git a/privs.yaml.example b/privs.yaml.example new file mode 100644 index 0000000..9436c32 --- /dev/null +++ b/privs.yaml.example @@ -0,0 +1,2 @@ +--- #YAML:1.0 +SOMEUSER: d41d8cd98f00b204e9800998ecf8427e