--- /dev/null
+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: '<wget>' 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 <dictionary>/<query>
+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
--- /dev/null
+--- #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 =~ /<wget>(.+)/ ) {
+ $response =~ s/<wget>//;
+ 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 =~ /<reply>(.+)/ ) {
+ 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/<br>//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 <period> <outputmodule>:<outputmethod>:<outputtarget> <message>", $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 <Number> <Num.Sides>", $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 <N> - 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 class="quote">.*?<p class="qt">(.+?)<\/p>.*?<\/p>/ ||
+ $content =~ m/<p class="qt">(.+)<\/p>/ ) {
+ my $line = $1;
+ $line =~ s/>/>/g;
+ $line =~ s/</</g;
+ $line =~ s/&/&/g;
+ $line =~ s/ / /g;
+ for my $sline (split( /<br \/>/, $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 );
+ }
+ }
--- /dev/null
+=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 );
+ }
+}
--- /dev/null
+=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 ) );
+}
projects / destult.git / commitdiff