From f0489613a7ff870d5abc7cbf9a896046ed496908 Mon Sep 17 00:00:00 2001 From: pdbogen Date: Wed, 29 Aug 2007 21:05:50 +0000 Subject: [PATCH] Initial revisions git-svn-id: https://www.cernu.us/~pdbogen/svn/destult2@1 088b83a4-0077-4247-935c-42ec02c2848b --- .svnignore | 4 + ChangeLog | 101 +++++++++ check | 5 + commands.yaml | 574 ++++++++++++++++++++++++++++++++++++++++++++++++++ config.pl | 43 ++++ config.yaml.example | 8 + core.pl | 129 ++++++++++++ destult2.pl | 33 +++ factoids.yaml.example | 9 + ignored.yaml.example | 2 + irc.pl | 186 ++++++++++++++++ loop | 3 + package | 8 + privs.yaml.example | 2 + 14 files changed, 1107 insertions(+) create mode 100644 .svnignore create mode 100644 ChangeLog create mode 100755 check create mode 100644 commands.yaml create mode 100644 config.pl create mode 100644 config.yaml.example create mode 100644 core.pl create mode 100755 destult2.pl create mode 100644 factoids.yaml.example create mode 100644 ignored.yaml.example create mode 100644 irc.pl create mode 100755 loop create mode 100755 package create mode 100644 privs.yaml.example 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 -- 2.11.0