my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
my( $whom, $target ) = split( / /, $what, 2 );
- unless( exists( $heap->{ "access" }->{ uc( $target ) } ) ) {
+ unless( exists( $heap->{ 'access' }->{ uc( $target ) } ) ) {
$kernel->post( $src, $replypath, "'$target' has no access; link not allowed.", $dest );
return;
}
- if( access2( $heap->{ "access" }, $target, {} ) > access( $kernel, $heap, $who ) ) {
+ if( access2( $heap->{ 'access' }, $target, {} ) > accessLevel( $kernel, $heap, $who ) ) {
$kernel->post( $src, $replypath, "You may not grant access exceeding your own.", $dest );
return;
}
- if( exists( $heap->{ privs }->{ uc( $whom ) } ) ) {
- $heap->{ access }->{ uc( $whom ) } = "~".$target;
- DumpFile( "access.yaml", $heap->{ access } );
+ if( exists( $heap->{ 'privs' }->{ uc( $whom ) } ) ) {
+ $heap->{ 'access' }->{ uc( $whom ) } = "~".$target;
+ DumpFile( "access.yaml", $heap->{ 'access' } );
$kernel->post( $src, $replypath, "Set.", $dest );
} else {
$kernel->post( $src, $replypath, "'$whom' not registered.", $dest );
$kernel->post( $src, $replypath, "Access level should be a non-negative integer. (Did you want LINK?)", $dest );
return;
}
- if( $level > access2( $heap->{ "access" }, $who, {} ) ) {
+ if( $level > access2( $heap->{ 'access' }, $who, {} ) ) {
$kernel->post( $src, $replypath, "You may not grant access exceeding your own.", $dest );
return;
}
- if( exists( $heap->{ privs }->{ uc( $whom ) } ) ) {
- $heap->{ access }->{ uc( $whom ) } = $level;
- DumpFile( "access.yaml", $heap->{ access } );
+ if( exists( $heap->{ 'privs' }->{ uc( $whom ) } ) ) {
+ $heap->{ 'access' }->{ uc( $whom ) } = $level;
+ DumpFile( "access.yaml", $heap->{ 'access' } );
$kernel->post( $src, $replypath, "Set.", $dest );
} else {
$kernel->post( $src, $replypath, "'$whom' not registered.", $dest );
$kernel->post( $src, $replypath, "Access level should be a non-negative integer.", $dest );
return;
}
- if( exists( $heap->{ commands }->{ uc( $cmd ) } ) ) {
- $heap->{ access }->{ "@".uc( $cmd ) } = $level;
- DumpFile( "access.yaml", $heap->{ access } );
+ if( exists( $heap->{ 'commands' }->{ uc( $cmd ) } ) ) {
+ $heap->{ 'access' }->{ "@".uc( $cmd ) } = $level;
+ DumpFile( "access.yaml", $heap->{ 'access' } );
$kernel->post( $src, $replypath, "Set.", $dest );
} else {
$kernel->post( $src, $replypath, "'$cmd' not found.", $dest );
sub {
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
$kernel->post( $src, $replypath, "Commands:", $dest );
- foreach( keys( %{ $heap->{ access } } ) ) {
+ foreach( keys( %{ $heap->{ 'access' } } ) ) {
if( substr( $_, 0, 1 ) eq "@" ) {
- $kernel->post( $src, $replypath, " $_: ".$heap->{ access }->{ $_ }, $dest );
+ $kernel->post( $src, $replypath, " $_: ".$heap->{ 'access' }->{ $_ }, $dest );
}
}
$kernel->post( $src, $replypath, "Users:", $dest );
- foreach( keys( %{ $heap->{ access } } ) ) {
+ foreach( keys( %{ $heap->{ 'access' } } ) ) {
unless( substr( $_, 0, 1 ) eq "@" ) {
- $kernel->post( $src, $replypath, " $_: ".$heap->{ access }->{ $_ }, $dest );
+ $kernel->post( $src, $replypath, " $_: ".$heap->{ 'access' }->{ $_ }, $dest );
}
}
}
sub {
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
my $reply = "I have the following commands: ";
- foreach( keys( %{ $heap->{ commands } } ) ) {
+ foreach( keys( %{ $heap->{ 'commands' } } ) ) {
$reply .= $_." ";
}
$kernel->post( $src, $replypath, $reply, $dest );
}
+
SCTITLE: |-
sub {
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
( $whom, $password ) = ( $who, $what );
}
- if( exists( $heap->{ privs }->{ uc( $whom ) } ) ) {
- if( $heap->{ privs }->{ uc( $whom ) } eq md5_hex( $password ) ) {
- $heap->{ identified }->{ uc( $who ) } = 1;
- $kernel->post( $src, $replypath, "Hello, $who.", $dest );
- } else {
- $kernel->post( $src, $replypath, "Authentication failed.", $dest );
- }
+ if( exists( $heap->{ 'privs' }->{ uc( $whom ) } ) ) {
+ if( $heap->{ 'privs' }->{ uc( $whom ) } eq md5_hex( $password ) ) {
+ $heap->{ 'identified' }->{ $src.uc( $who ) } = 1;
+ $kernel->post( $src, $replypath, "Hello, $who.", $dest );
+ } else {
+ $kernel->post( $src, $replypath, "Authentication failed.", $dest );
+ }
} else {
$kernel->post( $src, $replypath, "User '$who' not found.", $dest );
}
my( $whom, $password ) = split( / /, $what, 2 );
if( $password ) {
- $heap->{ privs }->{ uc( $whom ) } = md5_hex( $password );
- DumpFile( "privs.yaml", $heap->{ privs } );
+ $heap->{ 'privs' }->{ uc( $whom ) } = md5_hex( $password );
+ DumpFile( "privs.yaml", $heap->{ 'privs' } );
$kernel->post( $src, $replypath, "Done.", $dest );
} else {
$kernel->post( $src, $replypath, "Bad password.", $dest );
use Digest::MD5 qw( md5_hex );
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
my( $old, $new ) = split( / /, $what, 2 );
- if( exists( $heap->{ privs }->{ uc( $who ) } ) ) {
- if( $heap->{ privs }->{ uc( $who ) } eq md5_hex( $old ) ) {
- $heap->{ privs }->{ uc( $who ) } = md5_hex( $new );
- DumpFile( "privs.yaml", $heap->{ privs } );
+ if( exists( $heap->{ 'privs' }->{ uc( $who ) } ) ) {
+ if( $heap->{ 'privs' }->{ uc( $who ) } eq md5_hex( $old ) ) {
+ $heap->{ 'privs' }->{ uc( $who ) } = md5_hex( $new );
+ DumpFile( "privs.yaml", $heap->{ 'privs' } );
$kernel->post( $src, $replypath, "Passwords changed.", $dest );
} else {
$kernel->post( $src, $replypath, "Old passwords do not match.", $dest );
my( $subj, $predicate ) = split( / as /, $what, 2 );
if( $subj ) {
if( $predicate ) {
- $heap->{ db }->{ uc( $subj ) } = $predicate;
- DumpFile( "factoids.yaml", $heap->{ db } );
+ $heap->{ 'db' }->{ uc( $subj ) } = $predicate;
+ DumpFile( "factoids.yaml", $heap->{ 'db' } );
$kernel->post( $src, $replypath, "Okay, $who.", $dest );
} else {
- delete $heap->{ db }->{ uc( $subj ) } if exists $heap->{ db }->{ uc( $subj ) };
- DumpFile( "factoids.yaml", $heap->{ db } );
+ delete $heap->{ 'db' }->{ uc( $subj ) } if exists $heap->{ 'db' }->{ uc( $subj ) };
+ DumpFile( "factoids.yaml", $heap->{ 'db' } );
$kernel->post( $src, $replypath, "Okay, $who.", $dest );
}
} else {
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
print( "APPEND: $who for $what from $src to $dest via $replypath\n" );
my( $subj, $predicate ) = split( / with /, $what, 2 );
- if( exists( $heap->{ db }->{ uc( $subj ) } ) ) {
+ if( exists( $heap->{ 'db' }->{ uc( $subj ) } ) ) {
if( length( $predicate ) > 0 ) {
- $heap->{ db }->{ uc( $subj ) } .= $predicate;
- DumpFile( "factoids.yaml", $heap->{ db } );
+ $heap->{ 'db' }->{ uc( $subj ) } .= $predicate;
+ DumpFile( "factoids.yaml", $heap->{ 'db' } );
$kernel->post( $src, $replypath, "$who: Done.", $dest );
} else {
$kernel->post( $src, $replypath, "$who: Refusing to append nothing.", $dest );
sub {
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
print( "PARSE: $who for $what from $src to $dest via $replypath\n" );
- print( "PARSE: $what is ".$heap->{ db }->{ uc( $what ) }."\n" );
- my( $response, $author ) = split( / -- /, $heap->{ db }->{ uc( $what ) } );
+ print( "PARSE: $what is ".$heap->{ 'db' }->{ uc( $what ) }."\n" );
+ my( $response, $author ) = split( / -- /, $heap->{ 'db' }->{ uc( $what ) } );
if( $author ) {
$author = " -- ".$author;
} else {
} elsif( $response =~ /<reply>(.+)/ ) {
my @responses = split( /\|/, $1 );
$response = $responses[ int( rand( scalar( @responses ) ) ) ].$author;
+ } elsif( $response =~ /<alias>(.+)/ ) {
+ $response =~ s/<alias>//;
+ $kernel->post( "core", "cmd", $who, "~+".$response, $src, $dest, $replypath );
+ return;
} else {
my @responses = split( /\|/, $response );
$response = "$what is ".$responses[ int( rand( scalar( @responses ) ) ) ].$author;
sub {
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
print( "LITERAL: $who for $what from $src to $dest via $replypath\n" );
- if( exists( $heap->{ db }->{ uc( $what ) } ) ) {
- $kernel->post( "$src", $replypath, "$what is ".$heap->{ db }->{ uc( $what ) }, $dest );
+ if( exists( $heap->{ 'db' }->{ uc( $what ) } ) ) {
+ $kernel->post( "$src", $replypath, "$what is ".$heap->{ 'db' }->{ uc( $what ) }, $dest );
} else {
$kernel->post( "$src", $replypath, "'$what' not found.", $dest );
}
sub {
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
my $reply = "The following factoids were found: ";
- foreach( keys( %{ $heap->{ db } } ) ) {
+ foreach( keys( %{ $heap->{ 'db' } } ) ) {
$reply .= "'$_' ";
}
$kernel->post( $src, $replypath, $reply, $dest );
DICT: |-
sub {
- use Net::Dict;
my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
- print( "DICT: Establish connection.\n" );
- my $dict = Net::Dict->new( $Destult::config{ 'DICT_SERVER' } );
- if( !$dict ) {
- $kernel->post( $src, $replypath, "Can't contact dict server.", $dest );
- return;
+ if( $what =~ /^$/ ) {
+ $kernel->post( $src, $replypath, "USAGE: dict [<dictionary>/][<#>.]<query>\nSee also: dicts",$dest );
}
- if( $what =~ /[a-zA-Z1-9]+\/.+/ ) {
- print( "DICT: '".( split( /\//, $what, 2 ) )[0]."' source.\n" );
- $dict -> setDicts( ( ( split( /\//, $what, 2 ) )[0] ) );
- $what = ( split( /\//, $what, 2 ) )[1];
- } else {
- print( "DICT: Default sources.\n" );
- $dict -> setDicts( ( "wn", "jargon", "foldoc", "web1913" ) );
- }
- print( "DICT: Grab definition.\n" );
- my $lookup = $dict->define( $what );
- print( "DICT: Parsing.\n" );
- if( !@{ $lookup }[0] ) {
- print( "DICT: No result.\n" );
- $kernel->post( $src, $replypath, "No result for '$what'.", $dest );
+ if( !exists( $heap->{ 'DICT_cache' } ) ) {
+ $heap->{ 'DICT_cache' } = {};
+ }
+
+ my $dict = "default";
+ if( $what =~ /^(.+)\/.*/ ) {
+ $dict = $1;
+ $what = (split( '/', $what, 2))[1];
+ }
+ my $num = 0;
+ if( $what =~ /^([0-9]+)\..*/ ) {
+ $num = ($1 - 1);
+ $what =~ s/^[0-9]+\.//;
+ }
+
+ if( !exists( $heap->{ 'DICT_cache' }->{ uc( $dict ) } ) ) {
+ $heap->{ 'DICT_cache' }->{ uc( $dict ) } = {};
+ }
+ if( exists( $heap->{ 'DICT_cache' }->{ uc( $dict ) }->{ "$num.$what" } ) ) {
+ print( "DICT: Cached Result", "\n" );
+ $kernel->post( $src, $replypath, $heap->{ 'DICT_cache' }->{ uc( $dict ) }->{ "$num.$what" }, $dest );
return;
}
- my $def = ${@{ $lookup }[0]}[1];
- $def =~ s/\n/ /g;
- $def =~ s/ {2,}/ /g;
- $def =~ s/ :/:/g;
- $def =~ s/[^y](((n|v|adj|adv) ?[0-9]?:)|([0-9]:))/\n$1/gi;
- $def =~ s/\[syn.*(\n|$)/\n/g;
- $def =~ s/;.*//g;
- print( $def, "\n" );
- my @def = split( /\n/, $def );
- my $string = shift( @def );
- $string =~ s/^/'/;
- $string =~ s/ *$/':/;
- my $j = 0;
- for $def ( @def ) {
- $def =~ s/ *$//g;
- if( $def =~ /(n|v|adj|adv) ?[1-3]?:/i ) {
- chop( $string );
- $string .= ($j==0?":":".")." $def;";
- $j++;
- } elsif( $def =~ /[1-3]:/i ) {
- $def =~ s/[[:space:]]*$//g;
- $string .= " $def;";
- }
- }
- chop( $string );
- $kernel->post( $src, $replypath, $string, $dest );
+ if( $dict =~ m/^urban/i ) {
+ print( "DICT: Urban Dictionary", "\n" );
+ use WWW::Search;
+
+ my $key = "84d324f8a5fcae301ec4aefcd258dff2";
+ my $search = WWW::Search->new('UrbanDictionary', key=>$key );
+
+ if( $num > 0 ) {
+ $search->maximum_to_retrieve( $num + 1 );
+ } else {
+ $search->maximum_to_retrieve( 1 );
+ }
+ $search->timeout( 10 );
+ # SOAP::Lite, which is the Urban Dictionary backend, is smart enough to escape queries on its own.
+ $search->native_query( $what );
+ $search->seek_result( $num );
+ my $result;
+ if( !( $result = $search->next_result() ) ) {
+ print( "DICT: No result", "\n" );
+ if( $num == 0 ) {
+ $kernel->post( $src, $replypath, "No result for '$what'.", $dest );
+ } else {
+ $kernel->post( $src, $replypath, "No entry #".$num." for '$what'.", $dest );
+ }
+ return;
+ }
+ my $response = $result->{ 'word' }.": ".$result->{ 'description' };
+ $response =~ s/\n/ /g;
+ print( "DICT: Fetched result\n" );
+ $heap->{ 'DICT_cache' }->{ 'URBAN' }->{ "$num.$what" } = $response;
+ $kernel->post( $src, $replypath, $response, $dest );
+ } else {
+ use Net::Dict;
+ print( "DICT: Establish connection.\n" );
+ my $oDict = Net::Dict->new( $Destult::config{ 'DICT_SERVER' } );
+ if( !$oDict ) {
+ $kernel->post( $src, $replypath, "Can't contact dict server.", $dest );
+ return;
+ }
+ if( $dict ne "default" ) {
+ print( "DICT: '".( split( /\//, $what, 2 ) )[0]."' source.\n" );
+ $oDict -> setDicts( ( $dict ) );
+ } else {
+ print( "DICT: Default sources.\n" );
+ $oDict -> setDicts( ( "wn", "jargon", "foldoc", "web1913" ) );
+ }
+
+ print( "DICT: Grab definition.\n" );
+ my $lookup = $oDict->define( $what );
+ print( "DICT: Parsing.\n" );
+ if( $#{ $lookup } < $num ) {
+ print( "DICT: No result.\n" );
+ if( $num == 0 ) {
+ $kernel->post( $src, $replypath, "No result for '$what'.", $dest );
+ } else {
+ $kernel->post( $src, $replypath, "No result #".$num." for '$what'.", $dest );
+ }
+ return;
+ }
+ my $def = ${@{ $lookup }[$num]}[1];
+
+ $def =~ s/\n/ /g;
+ $def =~ s/ {2,}/ /g;
+ $def =~ s/ :/:/g;
+ $def =~ s/[^y](((n|v|adj|adv) ?[0-9]?:)|([0-9]:))/\n$1/gi;
+ $def =~ s/\[syn.*(\n|$)/\n/g;
+ # $def =~ s/;.*//g;
+ print( $def, "\n" );
+ my @def = split( /\n/, $def );
+ my $string = shift( @def );
+ $string =~ s/^/'/;
+ $string =~ s/ *$/':/;
+ my $j = 0;
+ for $def ( @def ) {
+ $def =~ s/ *$//g;
+ if( $def =~ /(n|v|adj|adv) ?[1-3]?:/i ) {
+ chop( $string );
+ $string .= ($j==0?":":".")." $def;";
+ $j++;
+ } elsif( $def =~ /[1-3]:/i ) {
+ $def =~ s/[[:space:]]*$//g;
+ $string .= " $def;";
+ }
+ }
+ chop( $string );
+ $heap->{ 'DICT_cache' }->{ uc( $dict ) }->{ "$num.$what" } = $string;
+ $kernel->post( $src, $replypath, $string, $dest );
+ }
}
NSLOOKUP: |-
WIKI: |-
sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+
+ if( !( $what =~ /[a-z0-9]/i ) ) {
+ $kernel->post( $src, $replypath, "USAGE: ~wiki <article name>", $dest );
+ return;
+ }
use Net::Ping;
my $ping = Net::Ping->new();
my $time = $ping->ping( "en.wikipedia.org" );
use WWW::Wikipedia;
- my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
- my $ping = Net::Ping->new();
- my $time = $ping->ping( "en.wikipedia.org" );
my $string;
my $full = 0;
if( $time < 5 ) {
my( $time, $how, $message ) = split( / /, $what, 3 );
my( $prot, $type, $targ ) = split( /:/, $how, 3 );
$time = int( $time );
- if( exists( $heap->{ identified }->{ uc( $who ) } ) ) {
- if( $time >= 0 ) {
+ if( exists( $heap->{ 'identified' }->{ uc( $who ) } ) ) {
+ if( length( $what ) > 0 && $time >= 0 ) {
if( $message ) {
- if( !exists( $heap->{ ads } ) ) {
- $heap->{ ads } = [];
+ if( !exists( $heap->{ 'ads' } ) ) {
+ $heap->{ 'ads' } = [];
}
- my $ad = scalar( @{ $heap->{ ads } } );
- $heap->{ ads }->[ $ad ] = [ $time, $prot, $type, $targ, $message ];
+ my $ad = scalar( @{ $heap->{ 'ads' } } );
+ $heap->{ 'ads' }->[ $ad ] = [ $time, $prot, $type, $targ, $message ];
$kernel->delay_set( "advertise", $time, $ad );
+ $kernel->post( $src, $replypath, "$who: Advert added as #".$ad, $dest );
} else {
- if( exists( $heap->{ ads }->[ $time ] ) ) {
+ if( exists( $heap->{ 'ads' }->[ $time ] ) ) {
$kernel->post( $src, $replypath, "$who: Ad disabled.", $dest );
print( "ADVERTISE: Ad #".$time." disabled.\n" );
- $heap->{ ads }->[ $time ]->[0] = -1;
+ $heap->{ 'ads' }->[ $time ]->[0] = -1;
} else {
$kernel->post( $src, $replypath, "$who: Ad #".$time." not found.", $dest );
print( "ADVERTISE: Ad #".$time." not found.\n" );
} 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 } ) ) {
+ if( exists( $heap->{ 'ads' } ) ) {
$kernel->post( $src, $replypath, "Current advertisements:", $dest );
my $i = 0;
- for( @{ $heap->{ ads } } ) {
+ for( @{ $heap->{ 'ads' } } ) {
my( $period, $prot, $type, $targ, $message ) = @{ $_ };
$kernel->post( $src, $replypath, "$i: ($period) -> $prot:$type:$targ : $message", $dest );
$i++;
my $ping = Net::Ping->new();
my $time = $ping->ping( "bash.org" );
- unless( $what =~ /^[0-9]+$/ || $what eq "random" ) {
+ unless( $what =~ /^([0-9]+)|(random)$/ ) {
$kernel->post( $src, $replypath, "Quote # should be a postive integer.", $dest );
return;
}
-
+
if( $time < 5 ) {
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
my $req = HTTP::Request->new( GET => 'http://bash.org/?'.$what );
my $res = $ua->request( $req );
+ my @quotes;
if( $res->is_success ) {
my $content = $res->content;
- $content =~ s/[\n\r]//g;
- if( $content =~ m/<p 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 );
- }
+ $content =~ s/[\n\r]//g;
+
+ while( $content =~ s/<p class="quote">.*?<b>(#[0-9]+)<\/b><\/a>.*?<p class="qt">(.*?)<\/p>//i ) {
+ my $num = $1;
+ my $text = $2;
+ $text =~ s/<br \/>/\n/gi;
+ $text =~ s/</</gi;
+ $text =~ s/>/>/gi;
+ $text =~ s/&/&/gi;
+ $text =~ s/"/"/gi;
+ $text =~ s/ / /gi;
+ push @quotes, [ $num, $text ];
+ }
+ my $quote = $quotes[ int(rand($#quotes+1)) ];
+ $kernel->post( $src, $replypath, $quote->[0].":\n".$quote->[1], $dest );
} else {
$kernel->post( $src, $replypath, "Something happened: ".$res->status_line, $dest );
}
$kernel->post( $src, $replypath, "bash.org is responding too slowly.", $dest );
}
}
+
+TRANSLATE: |-
+ sub {
+ use Lingua::Translate;
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ if( $what eq "" ) {
+ my $bbl = Lingua::Translate::Babelfish->new( src=>"en", dest=>"en" );
+ my @languages = $bbl->available();
+ my $response = join( ', ', @languages );
+ $response =~ s/_/->/g;
+ $kernel->post( $src, $replypath, "I can translate these languages: ".$response, $dest );
+ $kernel->post( $src, $replypath, "Usage: translate [from] <Src.Lang.> [to] <Dest.Lang.> <message>", $dest );
+ return;
+ }
+ my @words = split( / /, $what );
+ if( $words[0] eq "from" ) {
+ shift @words;
+ }
+ my $from = shift @words;
+ if( $words[0] eq "to" ) {
+ shift @words;
+ }
+ my $to = shift @words;
+ my $tlater;
+ my $translation;
+ eval {
+ $tlater = Lingua::Translate->new( src => $from, dest => $to );
+ $translation = $tlater->translate( join( ' ', @words ) );
+ };
+ if( $@ ) {
+ chomp $@;
+ $kernel->post( $src, $replypath, "Translation failed. Invalid arguments? Error message: '$@'", $dest );
+ return;
+ }
+ $kernel->post( $src, $replypath, $translation, $dest );
+ }
+
+RSS: |-
+ sub {
+ use WWW::Shorten 'SnipURL';
+ use XML::RSS;
+ use LWP::Simple;
+ use Time::CTime;
+
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ my @args = split( / /, $what );
+ if( $#args < 1 || !( $args[1] =~ /^([0-9]+-)?[0-9]+$/ ) ) {
+ $kernel->post( $src, $replypath, "Usage: RSS <source URL> <first>-<last> [<field1> ... <fieldN>]", $dest );
+ $kernel->post( $src, $replypath, "Standard fields are usually 'title,' 'link,' 'description.' Prepend a field with '+' to compress whitespace. Prepend a field with '!' to strip out HTML (and convert, where possible.) Prepend a field with '\@' to have that field start on its own line in the response. Any combination of these three flags is acceptable.", $dest );
+ return;
+ }
+ my $url = shift @args;
+ my $count = shift @args;
+ my( $first, $last );
+ if( $count =~ /^-([0-9]+)$/ ) {
+ $first = 0;
+ $last = $1;
+ } elsif( $count =~ /^[0-9]+$/ ) {
+ # I'd like this to be different, but it has to be this way for legacy purposes.
+ $first = 0;
+ $last = $count;
+ } elsif( $count =~ /^([0-9]+)-([0-9]+)$/ ) {
+ $first = $1;
+ $last = $2;
+ }
+ print( "RSS: $first to $last\n" );
+ if( $#args == -1 ) {
+ @args = ( 'superdate', 'supertitle', 'title', 'link' );
+ }
+
+ my $xml;
+ if( !( $xml = get( $url ) ) ) {
+ $kernel->post( $src, $replypath, "Failed to fetch RSS feed from $url", $dest );
+ return;
+ }
+ my $rss = new XML::RSS;
+ eval { $rss->parse( $xml ); };
+ if( $@ ) {
+ $kernel->post( $src, $replypath, "Document was fetched, but wasn't valid XML", $dest );
+ return;
+ }
+ my $response = "";
+ my @items;
+ my @nargs;
+ for my $arg( @args ) {
+ if( $arg eq "superdate" ) {
+ push @items, strftime( "%a %b %e %H:%M:%S %Y", localtime );
+ } elsif( $arg =~ /^super/ ) {
+ my $tmp = substr( $arg, 5 );
+ if( exists( $rss->{ 'channel' }->{ $arg } ) ) {
+ push @items, $rss->{ 'channel' }->{ $arg };
+ }
+ } else {
+ push @nargs, $arg;
+ }
+ }
+ @args = @nargs;
+ my $n = 0;
+ for my $item ( @{ $rss->{ 'items' } } ) {
+ $n++;
+ if( $n < $first ) {
+ next;
+ }
+ if( $n > $last ) {
+ last;
+ }
+
+ my @bits;
+ for my $arg( @args ) {
+ my $strip = 0;
+ my $ownline = 0;
+ my $compress = 0;
+ my $oneline = 0;
+ my $elem = $arg;
+
+ while( $elem =~ /^[+\!@#]/ ) {
+ if( substr( $elem, 0, 1 ) eq '+' ) {
+ $elem = substr( $elem, 1 );
+ $compress = 1;
+ }
+ if( substr( $elem, 0, 1 ) eq '!' ) {
+ $elem = substr( $elem, 1 );
+ $strip = 1;
+ }
+ if( substr( $elem, 0, 1 ) eq '@' ) {
+ $elem = substr( $elem, 1 );
+ $ownline = 1;
+ }
+ if( substr( $elem, 0, 1 ) eq '#' ) {
+ $elem = substr( $elem, 1 );
+ $oneline = 1;
+ }
+ }
+ if( exists( $item->{ $elem } ) ) {
+ if( $elem eq "link" ) {
+ push @bits, "<".makeashorterlink( $item->{ 'link' } ).">";
+ } else {
+ my $tmp = $item->{ $elem };
+ if( $strip == 1 ) {
+ $tmp =~ s/<br ?\/?>/\n/g;
+ $tmp =~ s/<[^>]+>//g;
+ $tmp =~ s/</</gi;
+ $tmp =~ s/>/>/gi;
+ $tmp =~ s/"/"/gi;
+ $tmp =~ s/&/&/gi;
+ }
+ if( $oneline == 1 ) {
+ $tmp =~ s/\n/ /gi;
+ }
+ if( $compress == 1 ) {
+ $tmp =~ s/\n/|/gi;
+ $tmp =~ s/^[|]//;
+ $tmp =~ s/[|]$//;
+ $tmp =~ s/[|][[:space:]]+/|/g;
+ $tmp =~ s/[|]+/|/g;
+ }
+ if( $ownline == 1 ) {
+ $tmp = "\n".$tmp;
+ }
+ push @bits, $tmp;
+ }
+ } else {
+ push @bits, $elem;
+ }
+ }
+ push @items, join( ' ', @bits );
+ }
+ $response .= join( ' | ', @items );
+ $response =~ s/[|[:space:]]+$//gm;
+ $kernel->post( $src, $replypath, $response, $dest );
+ }
+
+JOIN: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ if( $what =~ /^[#&][^ ,]+$/ ) {
+ $kernel->post( "mod_irc", "do_join", $what );
+ $kernel->post( $src, $replypath, "Okay.", $dest );
+ } else {
+ $kernel->post( $src, $replypath, "'$what' is not a valid channel name.", $dest );
+ }
+ }
+
+IGNORE: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ $what =~ s/[[:space:]]+$//;
+ if( exists( $heap->{ 'ignored' }->{ $what } ) ) {
+ $kernel->post( $src, $replypath, "'$what' is already ignored.", $dest );
+ return;
+ }
+ $heap->{ 'ignored' }->{ $what } = $who;
+ $kernel->post( $src, $replypath, "'$what' is now ignored.", $dest );
+ DumpFile( "ignored.yaml", $heap->{ 'ignored' } );
+ }
+
+UNIGNORE: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ $what =~ s/[[:space:]]+$//;
+ if( exists( $heap->{ 'ignored' }->{ $what } ) ) {
+ delete $heap->{ 'ignored' }->{ $what };
+ $kernel->post( $src, $replypath, "'$what' is no longer ignored.", $dest );
+ DumpFile( "ignored.yaml", $heap->{ 'ignored' } );
+ return;
+ }
+ $kernel->post( $src, $replypath, "'$what' is not ignored.", $dest );
+ }
+
+REPLACE: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ my( $factoid, $find, $replace ) = split( '/', $what );
+ $factoid =~ s/[[:space:]]+$//gi;
+ $factoid = uc( $factoid );
+ if( exists( $heap->{ 'db' }->{ $factoid } ) ) {
+ my $fact = $heap->{ 'db' }->{ $factoid };
+ eval { $fact =~ s/$find/$replace/gi; };
+ if( $! ) {
+ $kernel->post( $src, $replypath, "Regex Failed: $!", $dest );
+ return;
+ }
+ $heap->{ 'db' }->{ $factoid } = $fact;
+ DumpFile( "factoids.yaml", $heap->{ 'db' } );
+ $kernel->post( $src, $replypath, $fact, $dest );
+ } else {
+ $kernel->post( $src, $replypath, "There is no factoid called '$factoid'.", $dest );
+ return;
+ }
+ }
+
+FANDANGO: |-
+ sub {
+ use LWP::Simple;
+ use POSIX;
+
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+
+ my @args = split( / /, $what );
+ my $page = 1;
+ my $count = 3;
+ my $start = 0;
+ my $end = 2;
+ my $total = 0;
+ my $zip = 0;
+ my $theater = '';
+
+ if( $#args >= 3 ) {
+ if( $args[3] =~ /^[0-9]+$/ ) {
+ $count = $args[3];
+ } else {
+ $kernel->post( $src, $replypath, "Number of items to list per page should be numeric.", $dest );
+ return;
+ }
+ }
+ if( $#args >= 2 ) {
+ if( $args[2] =~ /^[0-9]+$/ ) {
+ $page = $args[2];
+ $start = ($args[2]-1)*$count;
+ $end = $start + $count - 1;
+ } else {
+ $kernel->post( $src, $replypath, "Page number should be numeric.", $dest );
+ return;
+ }
+ }
+ if( $#args >= 1 ) {
+ if( $args[0] =~ /^[0-9]{5}$/ ) {
+ $zip = $args[0];
+ } else {
+ $kernel->post( $src, $replypath, "First argument should be ZIP code.", $dest );
+ return;
+ }
+ $theater = $args[1];
+ }
+ if( $#args == 0 ) {
+ if( $args[0] =~ /^[0-9]{5}$/ ) {
+ my $site = get( 'http://www.fandango.com/TheaterListings.aspx?location='.$args[0] );
+ $site =~ s/ / /gi;
+ my @lines = split( /\n/, $site );
+ my @pages;
+ my @theaters;
+
+ for my $line( @lines ) {
+ if( $line =~ m!<span class="page">!i && $line =~ m! I !) {
+ $line =~ s/.*(<span class="page")/$1/i;
+ $line =~ s/<.+?>//g;
+ $line =~ s/[^0-9 ]//g;
+ $line =~ s/[[:space:]]+/ /g;
+ $line =~ s/(^[[:space:]]+)|([[:space:]]+$)//g;
+ @pages = split( / /, $line );
+ last;
+ }
+ }
+ if( $#pages == -1 ) {
+ @pages = ( 0 );
+ }
+ for my $page( @pages ) {
+ $site = get( 'http://www.fandango.com/TheaterListings.aspx?pn='.$page.'&location='.$args[0] );
+ $site =~ s/ / /gi;
+ @lines = split( /\n/, $site );
+ for my $line( @lines ) {
+ if( $line =~ m!<a class="titleLink" href="http://www.fandango.com/TheaterPage.aspx.*?location=([^&]+)&tid=([^"]+)">([^<]+)</a>!i ) {
+ push @theaters, [ $3, $1, $2 ];
+ }
+ }
+ }
+ $kernel->post( $src, $replypath, ($#theaters+1)." theater".($#theaters==0?"":"s")." near ZIP ".$args[0].":", $dest );
+ my $i = 0;
+ for my $theater( @theaters ) {
+ $kernel->post( $src, $replypath, (++$i).": ".$theater->[ 0 ].": ".$theater->[ 1 ]." ".$theater->[ 2 ], $dest );
+ }
+ return;
+ } else {
+ $kernel->post( $src, $replypath, "First argument should be ZIP code.", $dest );
+ return;
+ }
+ }
+ if( $#args == -1 ) {
+ $kernel->post( $src, $replypath, "USAGE: FANDANGO <ZIP> [<THEATER> [<Page#> [<MoviesPerPage>]]]", $dest );
+ return;
+ }
+
+ my $site = get( 'http://www.fandango.com/TheaterPage.aspx?location='.$zip.'&tid='.$theater );
+ $site =~ s/ / /gi;
+ $site =~ s/[[:space:]]+/ /g;
+ my @movies = split( /<div class="?theaterSpaceDivider"? ?>/, $site );
+ pop @movies;
+ @movies = split( /<div class="movieInfo">/, join( ' ', @movies ) );
+ shift @movies;
+ $total = $#movies;
+ if( $total < $start ) {
+ $kernel->post( $src, $replypath, "Page #$page is out of range.", $dest );
+ return;
+ }
+ @movies = @movies[ $start..$end ];
+ $kernel->post( $src, $replypath, "Page $page of ".ceil(($total+1)/$count), $dest );
+ for my $movie( @movies ) {
+ $movie =~ s/<span class="bullet">.*?<\/span>//gi;
+ $movie =~ s/<span class="showInstruction">.*?<\/span>.*?<\/span>//gi;
+ $movie =~ s/<span class="movieCast">.*?<\/span>.*?<\/span>//gi;
+ $movie =~ s/<span class="?movieSynopsis"?>.*?<\/span>//gi;#.*?<\/span>//gi;
+ $movie =~ s/<span class="showtimeSeparator"> I <\/span>/ /gi;
+ $movie =~ s/<[^>]*>//g;
+ $movie =~ s/[[:space:]]+/ /g;
+ $kernel->post( $src, $replypath, $movie, $dest );
+ }
+ }
+WEBTENDER: |-
+ sub {
+ use YAML qw(LoadFile DumpFile);
+ use LWP::UserAgent;
+
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+
+ if( !exists( $heap->{ 'WEBTENDER_cache' } ) ) {
+ if( -f 'webtenderCache.yaml' ) {
+ $heap->{ 'WEBTENDER_cache' } = LoadFile( "webtenderCache.yaml" );
+ } else {
+ $heap->{ 'WEBTENDER_cache' } = {};
+ }
+ }
+
+ if( !exists( $heap->{ 'WEBTENDER_cache' }->{ uc( $what ) } ) ) {
+ my $ua = LWP::UserAgent->new(
+ agent => "Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8) Gecko/20051224 Debian/1.5.dfsg-3 Firefox/1.5"
+ );
+ my $response = $ua->get( 'http://www.webtender.com/cgi-bin/search?name="'.$what.'"' );
+ if( $response->{ '_rc' } != 200 ) {
+ $kernel->post( $src, $replypath, "Failed to retrieve search results.", $dest );
+ return;
+ };
+ my $dbn = undef;
+ OUTER:
+ for my $line( split( "\n", $response->{ '_content' } ) ) {
+ if( $line =~ /db\/drink\/([0-9]+)/ ) {
+ $dbn = $1;
+ last OUTER;
+ }
+ }
+ if( !defined( $dbn ) ) {
+ $kernel->post( $src, $replypath, "No match for '$what'", $dest );
+ return;
+ }
+ $response = $ua->get( 'http://www.webtender.com/db/drink/'.$dbn );
+ if( $response->{ '_rc' } != 200 ) {
+ $kernel->post( $src, $replypath, "Failed to retrieve drink details.", $dest );
+ return;
+ };
+ my $result;
+ my $mode = 0;
+ for my $line( split( "\n", $response->{ '_content' } ) ) {
+ if( $line =~ /<H1>([^<]+)/ ) {
+ $result .= $1."\n";
+ } elsif( $line =~ /<H3>(Ingredients:)/i ) {
+ $result .= $1."\n";
+ $mode = 1;
+ } elsif( $line =~ /<H3>(Mixing Instructions:)/i ) {
+ $result .= "$1 ";
+ $mode = 2;
+ } elsif( $mode == 1 ) {
+ if( $line =~ /<LI>(.*)/i ) {
+ my $tmp = $1;
+ $tmp =~ s/<[^>]*>//gi;
+ $result .= "* $tmp\n";
+ } elsif( $line =~ /<\/UL>/i ) {
+ $mode = 0;
+ }
+ } elsif( $mode == 2 ) {
+ if( $line =~ /<P>(.*)<\/P>/i ) {
+ my $tmp = $1;
+ $tmp =~ s/<[^>]*>//gi;
+ $result .= "$tmp\n";
+ $mode = 0;
+ }
+ }
+ }
+ $heap->{ 'WEBTENDER_cache' }->{ uc( $what ) } = $result;
+ DumpFile( "webtenderCache.yaml", $heap->{ 'WEBTENDER_cache' } );
+ }
+
+ my $result = $heap->{ 'WEBTENDER_cache' }->{ uc( $what ) };
+ $result =~ s/\n+/\n/g;
+ $result =~ s/\n$//g;
+ $kernel->post( $src, $replypath, $result, $dest );
+ }
+
+SEEN: |-
+ sub {
+ use POSIX;
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ $what =~ s/(^[[:space:]]+)|([[:space:]]+$)//g;
+ if( exists( $heap->{ 'seen' } ) && exists( $heap->{ 'seen' }->{ uc( $what ) } ) ) {
+ my $t = time - $heap->{ 'seen' }->{ uc( $what ) };
+ my $response;
+ if( $t > 86400 ) {
+ $response .= floor($t/86400)."d ";
+ $t = $t % 86400;
+ }
+ if( $t > 3600 ) {
+ $response .= floor($t/3600)."h ";
+ $t = $t % 3600;
+ }
+ if( $t > 60 ) {
+ $response .= floor($t/60)."m ";
+ $t = $t % 60;
+ }
+ $response .= $t."s ago";
+ $kernel->post( $src, $replypath, "$what last seen $response", $dest );
+ } else {
+ $kernel->post( $src, $replypath, "I haven't seen $what.", $dest );
+ }
+ }
+
+MORSE: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ my $result;
+ my %morse = (
+ 'A' => ".-", 'B' => "-...", 'C' => "-.-.", 'D' => "-..",
+ 'E' => ".", 'F' => "..-.", 'G' => "--.", 'H' => "....",
+ 'I' => "..", 'J' => ".---", 'K' => "-.-", 'L' => ".-..",
+ 'M' => "--", 'N' => "-.", 'O' => "---", 'P' => ".--.",
+ 'Q' => "--.-", 'R' => ".-.", 'S' => "...", 'T' => "-",
+ 'U' => "..-", 'V' => "...-", 'W' => ".--", 'X' => "-..-",
+ 'Y' => "-.--", 'Z' => "--..", '1' => ".----", '2' => "..---",
+ '3' => "...--", '4' => "....-", '5' => ".....", '6' => "-....",
+ '7' => "--...", '8' => "---..", '9' => "----.", '0' => "-----",
+ );
+ for( my $i = 0; $i < length( $what ); $i++ ) {
+ my $ch = uc( substr( $what, $i, 1 ) );
+ if( $ch eq ' ' ) {
+ $result .= " ";
+ } elsif( exists( $morse{ $ch } ) ) {
+ print( "$ch => ".$morse{ $ch }, "\n" );
+ $result .= $morse{ $ch }." ";
+ }
+ }
+ print( $result, "\n" );
+ $kernel->post( $src, $replypath, $result, $dest );
+ }
+
+UPTIME: |-
+ sub {
+ use POSIX;
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ my( $s, $m, $h, $d, $M, $y ) = gmtime( $heap->{ 'start' } );
+ $y += 1900;
+ my $response = "Core session started on ".sprintf( "%04d-%02d-%02d %02d:%02D:%02d", $y, $M, $d, $h, $m, $s );
+ $response .= ", so I have been running for ";
+ my $t = time - $heap->{ 'start' };
+ if( $t > 86400 ) {
+ $response .= floor($t/86400)."d ";
+ $t = $t % 86400;
+ }
+ if( $t > 3600 ) {
+ $response .= floor($t/3600)."h ";
+ $t = $t % 3600;
+ }
+ if( $t > 60 ) {
+ $response .= floor($t/60)."m ";
+ $t = $t % 60;
+ }
+ $response .= $t."s.";
+ $kernel->post( $src, $replypath, $response, $dest );
+ }
+
+RSVP: |-
+ sub {
+ use YAML qw(LoadFile DumpFile);
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ $who = lc( $who );
+ if( ! -e ( "rsvps.yaml" ) ) {
+ $heap->{ 'rsvp' } = {};
+ DumpFile( "rsvps.yaml", $heap->{ 'rsvp' } );
+ }
+ if( !exists( $heap->{ "rsvp" } ) ) {
+ eval { $heap->{ 'rsvp' } = LoadFile( "rsvps.yaml" ) };
+ if( $! ) {
+ $heap->{ 'rsvp' } = {};
+ }
+ }
+ if( exists( $heap->{ "rsvp" }->{ $who } ) ) {
+ delete $heap->{ "rsvp" }->{ $who };
+ $kernel->post( $src, $replypath, "RSVP removed.", $dest );
+ } else {
+ $heap->{ "rsvp" }->{ $who } = time;
+ $kernel->post( $src, $replypath, "RSVP added.", $dest );
+ }
+ DumpFile( "rsvps.yaml", $heap->{ 'rsvp' } );
+ }
+
+ARSVP: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ $what = lc( $what );
+ $what =~ s/(^[[:space:]]*)|([[:space:]]*$)//g;
+ if( ! -e ( "rsvps.yaml" ) ) {
+ $heap->{ 'rsvp' } = {};
+ DumpFile( "rsvps.yaml", $heap->{ 'rsvp' } );
+ }
+ if( !exists( $heap->{ "rsvp" } ) ) {
+ eval { $heap->{ 'rsvp' } = LoadFile( "rsvps.yaml" ) };
+ if( $! ) {
+ $heap->{ 'rsvp' } = {};
+ }
+ }
+ if( exists( $heap->{ "rsvp" }->{ $what } ) ) {
+ delete $heap->{ "rsvp" }->{ $what };
+ $kernel->post( $src, $replypath, "RSVP for '$what' removed.", $dest );
+ } else {
+ $heap->{ "rsvp" }->{ $what } = time;
+ $kernel->post( $src, $replypath, "RSVP for '$what' added.", $dest );
+ }
+ DumpFile( "rsvps.yaml", $heap->{ 'rsvp' } );
+ }
+
+RSVPS: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ if( -e ( "rsvps.yaml" ) ) {
+ eval { $heap->{ 'rsvp' } = LoadFile( "rsvps.yaml" ) };
+ }
+ if( !exists( $heap->{ "rsvp" } ) ) {
+ $kernel->post( $src, $replypath, "No RSVPs found.", $dest );
+ } else {
+ my @names = keys %{ $heap->{ "rsvp" } };
+ if( scalar( @names ) == 0 ) {
+ $kernel->post( $src, $replypath, "No RSVPs found.", $dest );
+ } else {
+ my $reply = "";
+ for my $name ( @names ) {
+ if( $reply ne "" ) {
+ $reply .= ", $name";
+ } else {
+ $reply = $name;
+ }
+ }
+ $kernel->post( $src, $replypath, "RSVPs received: $reply", $dest );
+ }
+ }
+ }
+
+CLEARRSVP: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ if( !exists( $heap->{ "rsvp" } ) ) {
+ $kernel->post( $src, $replypath, "No RSVPs found.", $dest );
+ } else {
+ delete $heap->{ "rsvp" };
+ if( -e ( "rsvps.yaml" ) ) {
+ unlink 'rsvps.yaml';
+ }
+ $kernel->post( $src, $replypath, "RSVPs cleared.", $dest );
+ }
+ }
+
+GROUPHUG: |-
+ sub {
+ my( $kernel, $heap, $who, $what, $src, $dest, $replypath ) = @_;
+ use LWP::UserAgent;
+ my $ua = LWP::UserAgent->new;
+ my $req = HTTP::Request->new( GET => 'http://grouphug.us/random' );
+ my $res = $ua->request( $req );
+ my @hugs;
+ if( $res->is_success ) {
+ my $content = $res->content;
+ $content =~ s/[\n\r]//g;
+ while( $content =~ s/<td class="conf-id" valign="top">.*?<h4><a href="[^"]*">([0-9]+)<\/a>.*?<td class="conf-text">(.*?)<\/td>//i ) {
+ my $text = "$1: $2";
+ $text =~ s/<br \/>/ /gi;
+ $text =~ s/[[:space:]]+/ /gi;
+ $text =~ s/<[^>]*>//gi;
+ $text =~ s/</</gi;
+ $text =~ s/>/>/gi;
+ $text =~ s/&/&/gi;
+ $text =~ s/"/"/gi;
+ $text =~ s/ / /gi;
+ push @hugs, $text;
+ }
+ my $hug = $hugs[ int( rand( $#hugs+1 ) ) ];
+ $kernel->post( $src, $replypath, $hug, $dest );
+ } else {
+ $kernel->post( $src, $replypath, "Failed to fetch list of hugs.", $dest );
+ }
+ }
=COPYLEFT
- Copyright 2004, Patrick Bogen
+ Copyright 2004-2006, Patrick Bogen
This file is part of Destult2.
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
=cut
+package irc;
+
use POE::Session;
use POE::Component::IRC;
use Text::Wrap;
-POE::Session->new(
- _start => \&on_start,
- irc_001 => \&on_connect,
- irc_public => \&on_public,
- irc_msg => \&on_private,
- irc_nick => \&on_nick,
- irc_kick => \&on_kick,
- irc_part => \&on_part,
- irc_quit => \&on_quit,
- send_private => \&send_private,
- send_public => \&send_public,
- send_public_to => \&send_public_to,
- do_abort => \&do_abort,
- watchdog => \&watchdog
-) or die( "Unable to create IRC POE session." );
+
+sub new {
+ my $self = {};
+ $self->{ "host" } = shift;
+ $self->{ "channel" } = shift;
+ $self->{ "nick" } = "Destult";
+ $self->{ "port" } = 6667;
+ $self->{ "password" } = "";
+ while( shift ) {
+ my( $name, $value ) = split( /=/, $_, 2 );
+ if( exists( $self->{ $name } ) ) {
+ $self->{ $name } = $value;
+ }
+ }
+ my $session = POE::Session->create(
+ inline_states => {
+ _start => \&on_start,
+ irc_001 => \&on_connect,
+ irc_public => \&on_public,
+ irc_msg => \&on_private,
+ irc_nick => \&on_nick,
+ irc_kick => \&on_kick,
+ irc_part => \&on_part,
+ irc_quit => \&on_quit,
+ send_private => \&send_private,
+ send_public => \&send_public,
+ send_public_to => \&send_public_to,
+ do_abort => \&do_abort,
+ do_join => \&do_join,
+ do_mode => \&do_mode,
+ watchdog => \&watchdog,
+ },
+ heap => {
+ self => $self,
+ },
+ ) or die( "Unable to create IRC POE session." );
+
+ $self->{ "ssid" } = $session->ID;
+ bless( $self );
+ return $self;
+}
+
+sub do_join {
+ my( $kernel, $heap, $what ) = @_[ KERNEL, HEAP, ARG0 ];
+ if( $what =~ /^[#&][^ ,]+$/ ) {
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "join", $what );
+ } else {
+ warn( "'$what' is an invalid channel name" );
+ }
+}
sub do_abort {
my( $kernel, $heap ) = @_[ KERNEL, HEAP ];
- $heap->{ ircobject }->{ send_queue } = [];
+ $heap->{ 'ircobject' }->{ 'send_queue' } = [];
return;
}
sub watchdog {
my( $kernel, $heap ) = ( $_[KERNEL], $_[HEAP] );
- if( ! $heap->{ ircobject }->connected() ) {
+ my $self = $heap->{ "self" };
+ if( ! $heap->{ 'ircobject' }->connected() ) {
print "IRC : Connection was lost.. reconnecting.\n";
- $kernel->post( $heap->{ ircobject }->session_id(), "connect", {
- Nick => $config{ 'NICKNAME' },
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "connect", {
+ Nick => $self->{ "nick" },
Username => "Destult2",
Ircname => "Destultifier-Class Information Bot, v2",
- Server => $config{ 'IRC' },
- Port => "6667",
+ Server => $self->{ "host" },
+ Port => $self->{ "port" },
} );
}
- $heap->{ timer } = 0 unless defined $heap->{ timer };
- $heap->{ timer }++;
+ $heap->{ 'timer' } = 0 unless defined $heap->{ 'timer' };
+ $heap->{ 'timer' }++;
# Back-up wathdog timer, in case IRC thinks it's connected but it isn't.
- if( $heap->{ timer } == 60 ) {
- $kernel->post( $heap->{ ircobject }->session_id(), "version" );
+ if( $heap->{ 'timer' } == 60 ) {
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "version" );
}
$kernel->delay_set( "watchdog", 5 );
}
sub on_start {
my( $kernel, $heap ) = ( $_[KERNEL], $_[HEAP] );
+ my $self = $heap->{ "self" };
my $irc = POE::Component::IRC->spawn( ) or die( "Unable to spawn IRC object." );
- $heap->{ ircobject } = $irc;
+ $heap->{ 'ircobject' } = $irc;
# This informs the IRC component to listen to:
# 001 (Greeting)
# MSG (private message) and
# CTCP_ACTION (/me-type actions)
- $kernel->alias_set( "mod_irc" );
-
- $kernel->post( $heap->{ ircobject }->session_id(), "register", qw( 001 public msg nick kick part quit ) );
- $kernel->post( $heap->{ ircobject }->session_id(), "connect", {
- Nick => $config{ 'NICKNAME' },
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "register", qw( 001 public msg nick kick part quit ) );
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "connect", {
+ Nick => $self->{ "nick" },
Username => "Destult2",
Ircname => "Destultifier-Class Information Bot, v2",
- Server => $config{ 'IRC' },
- Port => "6667",
+ Server => $self->{ "host" },
+ Port => $self->{ "port" },
} );
$kernel->delay_set( "watchdog", 5 );
print( "IRC : Started.\n" );
# Connect to the channel specified by the config.
sub on_connect {
my $heap = $_[HEAP];
- if( exists $config{ 'PASSWORD' } ) {
+ my $self = $heap->{ "self" };
+ if( $self->{ "password" } ne "" ) {
print( "IRC : Attempting to register with nickserv.\n" );
- $_[KERNEL]->post( $heap->{ ircobject }->session_id(), "privmsg", "nickserv", "identify ".$config{ 'PASSWORD' } );
+ $_[KERNEL]->post( $heap->{ 'ircobject' }->session_id(), "privmsg", "nickserv", "identify ".$self->{ "password" } );
}
- print( "IRC : Connected to irc://".$config{ 'IRC' }."/#".$config{ 'CHANNEL' }."\n" );
- for my $chan (split( / /, $config{ 'CHANNEL' } )) {
- $_[KERNEL]->post( $heap->{ ircobject }->session_id(), "join", "#".$chan );
+ print( "IRC : Connected to irc://".$self->{ "host" }."/".$self->{ "channel" }."\n" );
+ for my $chan (split( / /, $self->{ "channel" } )) {
+ $_[KERNEL]->post( $heap->{ 'ircobject' }->session_id(), "join", $chan );
}
}
sub on_public {
my( $kernel, $who, $msg, $dest ) = @_[ KERNEL, ARG0, ARG2, ARG1 ];
+ my $self = $_[HEAP]->{ "self" };
+ my $nick = $self->{ "nick" };
$who = (split( /!/, $who, 2 ))[0];
+ $msg =~ s/^$nick[ ,:]+/~/i;
if( $who eq "a" ) {
+ # Strip source tag
$msg =~ s/^\[[^\]]*\] +//g;
+
+ # Reassign and strip sender
($who, $msg) = split( / /, $msg, 2 );
$who =~ s/[<>]//g;
}
$msg =~ s/(\x3)[0-9]{0,2}//g;
$msg =~ s/\x02//g;
$cmd = ( split( / /, $msg, 2 ) )[0];
+ $kernel->post( "core", "seen", $who );
if( $cmd =~ /^[~].*/ ) {
- $kernel->post( "core", "cmd", $who, $msg, "mod_irc", $dest->[0], "send_public_to" );
+ $kernel->post( "core", "cmd", $who, $msg, $self->{ "ssid" }, $dest->[0], "send_public_to" );
}
}
sub on_private {
my( $kernel, $who, $msg ) = @_[ KERNEL, ARG0, ARG2 ];
+ my $self = $_[HEAP]->{ "self" };
$who = (split( /!/, $who, 2 ))[0];
$msg =~ s/(\x3)[0-9]{0,2}//g;
$msg =~ s/\x02//g;
$cmd = ( split( / /, $msg, 2 ) )[0];
- $kernel->post( "core", "cmd", $who, $msg, "mod_irc", $who, "send_private" );
+ $kernel->post( "core", "seen", $who );
+ $kernel->post( "core", "cmd", $who, $msg, $self->{ "ssid" }, $who, "send_private" );
}
sub send_public {
local( $Text::Wrap::columns = 354 );
my @msg = split( /\n/, wrap( '', '', $msg ) );
for( @msg ) {
- $kernel->post( $heap->{ ircobject }->session_id(), "privmsg", "#".$config{ 'CHANNEL' }, $_ );
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "privmsg", $self->{ "channel" }, $_ );
}
- print( "IRC : =>".$config{ 'CHANNEL' }.": $msg\n" );
+ print( "IRC : =>".$self-{ "channel" }.": $msg\n" );
}
sub send_public_to {
local( $Text::Wrap::columns = 354 );
my @msg = split( /\n/, wrap( '', '', $msg ) );
for( @msg ) {
- $kernel->post( $heap->{ ircobject }->session_id(), "privmsg", $target, $_ );
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "privmsg", $target, $_ );
}
} else {
print( "IRC : Could not send '$msg' to '$target' -- '$target' is not a channel\n" );
local( $Text::Wrap::columns = 354 );
my @msg = split( /\n/, wrap( '', '', $msg ) );
for( @msg ) {
- $kernel->post( $heap->{ ircobject }->session_id(), "notice", $who, $_ );
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "notice", $who, $_ );
}
}
$whom = ( split( /!/, $whom, 2 ) )[0];
$kernel->post( "core", "unidentify", uc( $whom ) );
}
+
+sub do_mode {
+ my( $kernel, $heap, $channel, $mode ) = @_[ KERNEL, HEAP, ARG0, ARG1 ];
+ $kernel->post( $heap->{ 'ircobject' }->session_id(), "mode", $channel, $mode );
+}
+
+return 1;
projects / destult.git / commitdiff